1 (* Benchmark from Joe Hurd
<joe
.hurd@cl
.cam
.ac
.uk
> on
2002-09-24.
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
14 (*#line
0.0 "$HOME/dev/sml/basic/src/PP.sig"*)
15 (* PP
-- pretty
-printing
-- from the SML
/NJ library
*)
20 type ppconsumer
= { consumer
: string -> unit
,
22 flush
: unit
-> unit
}
24 datatype break_style
=
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
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
.
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
).
54 [ppconsumer
] is the
type of sinks for pretty
-printing
. A value
of
55 type ppconsumer is a record
56 { consumer
: string -> unit
,
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
.
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
.
68 [break_style
] is the
type of line break styles for blocks
:
70 [CONSISTENT
] specifies that
if any line break occurs inside the
71 block
, then all indicated line breaks occur
.
73 [INCONSISTENT
] specifies that breaks will be inserted to only to
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
.
80 [dest_ppstream ppstrm
] extracts the linewidth
, flush function
, and
81 consumer from a ppstream
.
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
.
97 [add_newline ppstrm
] issues a newline
.
99 [add_string ppstrm str
] outputs the
string str to the ppstream
.
101 [begin_block ppstrm style blockoffset
] begins a new block
and
102 level
of indentation
, with the given style
and block offset
.
104 [end_block ppstrm
] closes the current block
.
106 [clear_ppstream ppstrm
] restarts the stream
, without affecting the
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
.
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
.
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
.
123 Example
1: A simple prettyprinter for Booleans
:
129 begin_block pps INCONSISTENT
6;
130 add_string
pps (if d
then "right" else "wrong");
134 Now one may define a ppstream to print to
, and exercise it
:
136 val ppstrm
= PP
.mk_ppstream
{consumer
=
137 fn s
=> TextIO.output(TextIO.stdOut
, s
),
140 fn () => TextIO.flushOut
TextIO.stdOut
};
142 fun ppb b
= (ppbool ppstrm b
; PP
.flush_ppstream ppstrm
);
145 wrong
> val it
= () : unit
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
:
154 > val it
= wrong
: bool
156 > val it
= right
: bool
158 See library Meta for a description
of installPP
.
161 Example
2: Prettyprinting simple
expressions (examples
/pretty
/ppexpr
.sml
):
166 | Plus
of expr
* expr
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;
175 add_string pps
" + ";
176 add_break
pps (0, 1);
181 begin_block pps INCONSISTENT
0;
186 val _
= installPP ppexpr
;
188 (* Some example values
: *)
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
);
198 Plus(e3
, Plus(e3
, Plus(e3
, Plus(e3
, Plus(e3
, Plus(e3
, e7
))))));
200 (*#line
0.0 "$HOME/dev/sml/basic/src/PP.sml"*)
201 (* PP
-- Oppen
-style prettyprinters
.
203 * Modified for Milton ML from SML
/NJ Library version
0.2
205 * COPYRIGHT (c
) 1992 by AT
&T Bell Laboratories
.
206 * See file mosml
/copyrght
/copyrght
.att for details
.
209 (* the functions
and data for actually doing printing
. *)
217 (* the queue library
, formerly
in unit Ppqueue
*)
219 datatype Qend
= Qback | Qfront
222 exception QUEUE_EMPTY
223 exception REQUESTED_QUEUE_SIZE_TOO_SMALL
226 fun ++ i n
= (i
+ 1) mod n
227 fun -- i n
= (i
- 1) mod n
230 abstype 'a queue
= QUEUE
of {elems
: 'a array
, (* the contents
*)
233 size
: int} (* fixed size
of element array
*)
236 fun is_empty (QUEUE
{front
=ref ~
1, back
=ref ~
1,...}) = true
239 fun mk_queue n init_val
=
241 then raise REQUESTED_QUEUE_SIZE_TOO_SMALL
242 else QUEUE
{elems
=array(n
, init_val
), front
=ref ~
1, back
=ref ~
1, size
=n
}
244 fun clear_queue (QUEUE
{front
,back
,...}) = (front
:= ~
1; back
:= ~
1)
246 fun queue_at
Qfront (QUEUE
{elems
,front
,...}) = elems sub
!front
247 | queue_at
Qback (QUEUE
{elems
,back
,...}) = elems sub
!back
249 fun en_queue Qfront
item (Q
as QUEUE
{elems
,front
,back
,size
}) =
251 then (front
:= 0; back
:= 0;
252 update(elems
,0,item
))
253 else let val i
= --(!front
) size
255 then raise QUEUE_FULL
256 else (update(elems
,i
,item
); front
:= i
)
258 | en_queue Qback
item (Q
as QUEUE
{elems
,front
,back
,size
}) =
260 then (front
:= 0; back
:= 0;
261 update(elems
,0,item
))
262 else let val i
= ++(!back
) size
264 then raise QUEUE_FULL
265 else (update(elems
,i
,item
); back
:= i
)
268 fun de_queue
Qfront (Q
as QUEUE
{front
,back
,size
,...}) =
269 if (!front
= !back
) (* unitary queue
*)
271 else front
:= ++(!front
) size
272 | de_queue
Qback (Q
as QUEUE
{front
,back
,size
,...}) =
275 else back
:= --(!back
) size
277 end (* abstype queue
*)
281 val magic
: 'a
-> 'a
= fn x
=> x
283 (* exception PP_FAIL
of string *)
285 datatype break_style
= CONSISTENT | INCONSISTENT
289 | PACK_ONTO_LINE
of int
290 | ONE_PER_LINE
of int
292 (* Some global values
*)
293 val INFINITY
= 999999
295 abstype indent_stack
= Istack
of break_info list ref
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
) =
301 of nil
=> raise Fail
"PP-error: top: badly formed block"
303 fun push (x
,(Istack stk
)) = stk
:= x
::(!stk
)
304 fun pop (Istack stk
) =
306 of nil
=> raise Fail
"PP-error: pop: badly formed block"
307 | _
::rest
=> stk
:= rest
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
.
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
322 abstype delim_stack
= Dstack
of int queue
324 fun new_delim_stack i
= Dstack(mk_queue i ~
1)
325 fun reset_delim_stack (Dstack q
) = clear_queue q
327 fun pop_delim_stack (Dstack d
) = de_queue Qfront d
328 fun pop_bottom_delim_stack (Dstack d
) = de_queue Qback d
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
337 type block_info
= { Block_size
: int ref
,
339 How_to_indent
: break_style
}
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
.
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,
356 (* The initial values
in the token buffer
*)
357 val initial_token_value
= S
{String = "", Length
= 0}
359 (* type ppstream
= General
.ppstream
; *)
362 {consumer
: string -> unit
,
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
*)
375 type ppstream
= ppstream_
377 type ppconsumer
= {consumer
: string -> unit
,
379 flush
: unit
-> unit
}
381 fun mk_ppstream
{consumer
,linewidth
,flush
} =
383 then raise Fail
"PP-error: linewidth too_small"
384 else let val buf_size
= 3*linewidth
386 PPS
{consumer
= consumer
,
387 linewidth
= linewidth
,
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}
399 fun dest_ppstream(pps
: ppstream
) =
400 let val PPS
{consumer
,linewidth
,flush
, ...} = magic pps
401 in {consumer
=consumer
,linewidth
=linewidth
,flush
=flush
} end
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
=>
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
]
418 fun cr_indent (ofn
, i
) = ofn ("\n"^
(nspaces i
))
419 fun indent (ofn
,i
) = ofn (nspaces i
)
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
.
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
,
437 (push ((if (!Block_size
> sp_left
)
438 then ONE_PER_LINE (linewidth
- (sp_left
- Block_offset
))
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
))
449 |
print_BB (PPS
{the_indent_stack
, linewidth
, space_left
=ref sp_left
,...},
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
))
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
))
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
) []
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
480 (* "cursor" is how many spaces across the page we are
. *)
482 fun print_token(PPS
{consumer
,space_left
,...}, S
{String,Length
}) =
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
)
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
)
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
)
505 else (space_left
:= !space_left
- Number_of_blanks
;
506 indent (consumer
,Number_of_blanks
)))
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
,...}
514 val buf_size
= 3*linewidth
518 else (update(the_token_buffer
,i
,initial_token_value
);
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
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
.
532 fun BB_inc_right_index(PPS
{the_token_buffer
, right_index
, ++,...})=
533 case (the_token_buffer
sub (!right_index
))
537 fun E_inc_right_index(PPS
{the_token_buffer
,right_index
, ++,...})=
538 case (the_token_buffer
sub (!right_index
))
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
548 |
(E
{Pend
= ref
0, Uend
= ref
0}) => true
552 fun advance_left (ppstrm
as PPS
{consumer
,left_index
,left_sum
,
553 the_token_buffer
,++,...},
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 _
= ()
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
) =
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
578 if (token_size instr
< 0) (* synchronization point
; cannot advance
*)
580 else (print_token(ppstrm
,instr
);
582 if (pointers_coincide ppstrm
)
584 else (* increment left index
*)
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
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
);
602 |
(E
{Pend
= ref
0, Uend
= ref
0}) =>
603 (update(the_token_buffer
,!left_index
,
604 initial_token_value
);
608 loop (the_token_buffer
sub (!left_index
))))
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
,...}
619 (if (delim_stack_is_empty the_delim_stack
)
620 then (left_index
:= 0;
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
,
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
)))
638 fun end_block(pps
: ppstream
) =
639 let val ppstrm
= magic pps
: ppstream_
640 val PPS
{the_token_buffer
,the_delim_stack
,right_index
,...}
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
)))
654 fun check_delim_stack(PPS
{the_token_buffer
,the_delim_stack
,right_sum
,...}) =
656 if (delim_stack_is_empty the_delim_stack
)
658 else case(the_token_buffer
sub (top_delim_stack the_delim_stack
))
659 of (BB
{Ublocks
as ref ((b
as {Block_size
, ...})::rst
),
662 then (Block_size
:= !right_sum
+ !Block_size
;
663 Pblocks
:= b
:: (!Pblocks
);
665 if (List.length rst
= 0)
666 then pop_delim_stack the_delim_stack
671 (Pend
:= (!Pend
) + (!Uend
);
673 pop_delim_stack the_delim_stack
;
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
;
682 | _
=> raise Fail
"PP-error: check_delim_stack.catchall"
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
, ++, ...}
693 (if (delim_stack_is_empty the_delim_stack
)
694 then (left_index
:= 0; right_index
:= 0;
695 left_sum
:= 1; right_sum
:= 1)
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
))
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
,...}
711 (if (delim_stack_is_empty the_delim_stack
)
713 else (check_delim_stack ppstrm
;
714 advance_left(ppstrm
, the_token_buffer
sub (!left_index
)));
721 fun flush_ppstream ppstrm
=
722 (flush_ppstream0 ppstrm
;
723 clear_ppstream ppstrm
)
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
,++,...}
731 fun fnl
[{Block_size
, ...}:block_info
] = Block_size
:= INFINITY
732 |
fnl (_
::rst
) = fnl rst
733 | fnl _
= raise Fail
"PP-error: fnl: internal error"
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
);
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")
748 fun check_stream () =
749 if ((!right_sum
- !left_sum
) > !space_left
)
750 then if (delim_stack_is_empty the_delim_stack
)
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
)
757 the_token_buffer
sub (!left_index
));
758 if (pointers_coincide ppstrm
)
764 val slen
= String.size s
765 val S_token
= S
{String = s
, Length
= slen
}
767 in if (delim_stack_is_empty the_delim_stack
)
768 then print_token(ppstrm
,S_token
)
770 update(the_token_buffer
, !right_index
, S_token
);
771 right_sum
:= (!right_sum
)+slen
;
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
781 (* Derived form
. Builds a ppstream
, sends pretty printing commands called
in
782 f to the ppstream
, then flushes ppstream
.
785 fun with_pp ppconsumer ppfn
=
786 let val ppstrm
= mk_ppstream ppconsumer
788 flush_ppstream0 ppstrm
791 (TextIO.print (">>>> Pretty-printer failure: " ^ msg ^
"\n"))
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
))
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
*)
806 signature Binarymap
=
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
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
.
835 [mkDict ordr
] returns a new
, empty map whose keys have ordering
838 [insert(m
, i
, v
)] extends (or modifies
) map m to map i to v
.
840 [find (m
, k
)] returns v
if m maps k to v
; otherwise raises NotFound
.
842 [peek(m
, k
)] returns SOME v
if m maps k to v
; otherwise returns NONE
.
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
.
848 [numItems m
] returns the number
of entries
in m (that is
, the size
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
.
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
).
858 [revapp f m
] applies function f to the
entries (k
, v
) in m
, in
859 decreasing order
of k
.
861 [foldl f e m
] applies the folding function f to the
entries (k
, v
)
862 in m
, in increasing order
of k
.
864 [foldr f e m
] applies the folding function f to the
entries (k
, v
)
865 in m
, in decreasing order
of k
.
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
.
870 [transform f m
] returns a new map whose entries have
form (k
, f v
),
871 where (k
, v
) is an entry
in m
.
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
.
879 * This code was adapted from Stephen Adams
' binary tree implementation
880 * of applicative integer sets
.
882 * Copyright
1992 Stephen Adams
.
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
.
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
898 * E
-mail
: sra@ecs
.soton
.ac
.uk
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
.
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
.
917 structure Binarymap
:> Binarymap
=
922 fun wt (i
: int) = 3 * i
924 datatype ('key
, 'a
) dict
=
925 DICT
of ('key
* 'key
-> order
) * ('key
, 'a
) tree
926 and ('key
, 'a
) tree
=
931 left
: ('key
, 'a
) tree
,
932 right
: ('key
, 'a
) tree
}
935 |
treeSize (T
{cnt
,...}) = cnt
937 fun numItems (DICT(_
, t
)) = treeSize t
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
}
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
,...},
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
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
}
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
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
977 | T
' (p
as (_
,_
,E
,T
{left
=E
,...})) = single_L p
978 | T
' (p
as (_
,_
,T
{right
=E
,...},E
)) = single_R p
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
986 if rln
< rrn
then single_L p
else double_L p
989 else if ln
>= wt rn
then (*left is too big
*)
990 let val lln
= treeSize ll
991 val lrn
= treeSize lr
993 if lrn
< lln
then single_R p
else double_R p
996 else T
{key
=k
,value
=v
,cnt
=ln
+rn
+1,left
=l
,right
=r
}
999 fun min (T
{left
=E
,key
,value
,...}) = (key
,value
)
1000 |
min (T
{left
,...}) = min left
1001 | min _
= raise Match
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
1008 fun delete
' (E
,r
) = r
1010 | delete
' (l
,r
) = let val (mink
,minv
) = min r
1011 in T
'(mink
,minv
,l
,delmin r
) end
1014 fun mkDict cmpKey
= DICT(cmpKey
, E
)
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
)
1023 T
{key
=x
,value
=v
,left
=left
,right
=right
,cnt
= #cnt set
}
1024 in DICT(cmpKey
, ins t
) end
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
1035 fun peek arg
= (SOME(find arg
)) handle NotFound
=> NONE
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
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
)
1055 fun revapp
f (DICT(_
, d
)) = let
1057 |
a (T
{key
,value
,left
,right
,...}) = (a right
; f(key
,value
); a left
)
1060 fun app
f (DICT(_
, d
)) = let
1062 |
a (T
{key
,value
,left
,right
,...}) = (a left
; f(key
,value
); a right
)
1065 fun foldr f
init (DICT(_
, d
)) = let
1067 |
a (T
{key
,value
,left
,right
,...}) v
= a
left (f(key
,value
,a right v
))
1070 fun foldl f
init (DICT(_
, d
)) = let
1072 |
a (T
{key
,value
,left
,right
,...}) v
= a
right (f(key
,value
,a left v
))
1075 fun map
f (DICT(cmpKey
, d
)) = let
1077 |
a (T
{key
,value
,left
,right
,cnt
}) = let
1079 val value
' = f(key
,value
)
1081 T
{cnt
=cnt
, key
=key
,value
=value
',left
= left
', right
= a right
}
1083 in DICT(cmpKey
, a d
) end
1085 fun transform
f (DICT(cmpKey
, d
)) =
1087 |
a (T
{key
,value
,left
,right
,cnt
}) =
1088 let val left
' = a left
1090 T
{cnt
=cnt
, key
=key
, value
=f value
, left
= left
',
1093 in DICT(cmpKey
, a d
) end
1097 (*#line
0.0 "$HOME/dev/sml/basic/src/Susp.sig"*)
1098 (* Susp
-- support for lazy evaluation
*)
1105 val delay
: (unit
-> 'a
) -> 'a susp
1106 val force
: 'a susp
-> 'a
1111 ['a susp
] is the
type of lazily evaluated expressions
with result
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
1121 [force su
] forces the suspension su
and returns the result
of the
1122 expression e stored
in the suspension
.
1124 (*#line
0.0 "$HOME/dev/sml/basic/src/Susp.sml"*)
1125 (* Susp
-- support for lazy evaluation
1995-05-22 *)
1127 structure Susp
:> Susp
=
1130 datatype 'a thunk
= VAL
of 'a | THUNK
of unit
-> 'a
;
1132 type 'a susp
= 'a thunk ref
;
1134 fun delay (f
: unit
-> 'a
) = ref (THUNK f
);
1136 fun force (su
: 'a susp
) : 'a
=
1139 | THUNK f
=> let val v
= f () in su
:= VAL v
; v
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 (* ========================================================================= *)
1151 (* The ML implementation
*)
1154 (* Pointer equality using the run
-time system
*)
1156 (* Quotations a la Mosml
*)
1157 datatype 'a frag
= QUOTE
of string | ANTIQUOTE
of 'a
1159 (* Timing function applications a la Mosml
.time
*)
1160 val time
: ('a
-> 'b
) -> 'a
-> 'b
1162 (* Bring certain declarations to the top
-level
*)
1163 type ppstream
= PP
.ppstream
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
1171 (*#line
0.0 "$HOME/dev/sml/basic/src/Milton.sml"*)
1172 (* ========================================================================= *)
1173 (* MLton SPECIFIC FUNCTIONS
*)
1174 (* Created by Joe Hurd
, September
2002 *)
1175 (* ========================================================================= *)
1177 structure Milton
:> Milton
=
1180 (* ------------------------------------------------------------------------- *)
1181 (* The ML implementation
. *)
1182 (* ------------------------------------------------------------------------- *)
1186 (* ------------------------------------------------------------------------- *)
1187 (* Pointer equality using the run
-time system
. *)
1188 (* ------------------------------------------------------------------------- *)
1190 (* ------------------------------------------------------------------------- *)
1191 (* Quotations a la Mosml
. *)
1192 (* ------------------------------------------------------------------------- *)
1194 datatype 'a frag
= QUOTE
of string | ANTIQUOTE
of 'a
;
1196 (* ------------------------------------------------------------------------- *)
1197 (* Timing function applications a la Mosml
.time
. *)
1198 (* ------------------------------------------------------------------------- *)
1204 val s
= Time
.fmt
3 t
1206 case size (List.last (String.fields (fn x
=> x
= #
".") s
)) of 3 => s
1209 | _
=> raise Fail
"Milton.time"
1211 val c
= Timer
.startCPUTimer ()
1212 val r
= Timer
.startRealTimer ()
1215 val {usr
, sys
, ...} = Timer
.checkCPUTimer c
1216 val real = Timer
.checkRealTimer r
1219 ("User: " ^ p usr ^
" System: " ^ p sys ^
" Real: " ^ p
real ^
"\n")
1221 val y
= f x
handle e
=> (pt (); raise e
)
1227 (* ------------------------------------------------------------------------- *)
1228 (* Bring certain declarations to the top
-level
. *)
1229 (* ------------------------------------------------------------------------- *)
1231 type ppstream
= PP
.ppstream
;
1233 (* ------------------------------------------------------------------------- *)
1234 (* Dummy versions
of Mosml declarations to stop MLton barfing
. *)
1235 (* ------------------------------------------------------------------------- *)
1237 val quotation
= ref
false;
1238 val load
= fn (_
: string) => ();
1239 val installPP
= fn (_
: ppstream
-> 'a
-> unit
) => ();
1243 (*#line
0.0 "basic/Useful.sig"*)
1244 (* ========================================================================= *)
1245 (* ML UTILITY FUNCTIONS
*)
1246 (* Created by Joe Hurd
, April
2001 *)
1247 (* ========================================================================= *)
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
1268 val C
: ('a
-> 'b
-> 'c
) -> 'b
-> 'a
-> 'c
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
1278 val bool_to_string
: bool -> string
1279 val non
: ('a
-> bool) -> 'a
-> bool
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
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
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
*)
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
1327 val lex_compare
: ('a
* 'a
-> order
) -> ('a
* 'a
) list
-> order
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
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
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
1351 val real_to_string
: real -> string;
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
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
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
1382 datatype ('a
, 'b
) maplet
= |
-> of 'a
* 'b
1383 val pp_maplet
: 'a pp
-> 'b pp
-> ('a
, 'b
) maplet pp
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
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
->
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
1401 (* Information about the environment
*)
1403 val date
: unit
-> string
1406 (*#line
0.0 "basic/Useful.sml"*)
1407 (* ========================================================================= *)
1408 (* ML UTILITY FUNCTIONS
*)
1409 (* Created by Joe Hurd
, April
2001 *)
1410 (* ========================================================================= *)
1412 structure Useful
:> Useful
=
1417 (* ------------------------------------------------------------------------- *)
1418 (* Exceptions
, profiling
and tracing
. *)
1419 (* ------------------------------------------------------------------------- *)
1421 exception ERR_EXN
of {origin_function
: string, message
: string};
1422 exception BUG_EXN
of {origin_function
: string, message
: string};
1424 fun ERR f s
= ERR_EXN
{origin_function
= f
, message
= s
};
1425 fun BUG f s
= BUG_EXN
{origin_function
= f
, message
= s
};
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";
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";
1435 fun assert b e
= if b
then () else raise e
;
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
);
1442 fun total f x
= SOME (f x
) handle ERR_EXN _
=> NONE
;
1444 fun can f
= Option
.isSome
o total f
;
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";
1451 val tmr
= Timer
.startCPUTimer ()
1453 val {usr
, sys
, ...} = Timer
.checkCPUTimer tmr
1455 (Time
.toReal usr
+ Time
.toReal sys
, res
)
1458 val tracing
= ref
1;
1460 val traces
: {module
: string, alignment
: int -> int} list ref
= ref
[];
1464 val trace_printer
= print
;
1466 let val t
= List.find (fn {module
, ...} => module
= m
) (!traces
)
1467 in case t
of NONE
=> MAX | SOME
{alignment
, ...} => alignment l
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
1476 (* ------------------------------------------------------------------------- *)
1478 (* ------------------------------------------------------------------------- *)
1480 fun C f x y
= f 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
);
1486 fun f oo g
= fn x
=> f
o (g x
);
1488 (* ------------------------------------------------------------------------- *)
1490 (* ------------------------------------------------------------------------- *)
1492 fun bool_to_string
true = "true"
1493 | bool_to_string
false = "false";
1495 fun non f
= not
o f
;
1497 (* ------------------------------------------------------------------------- *)
1499 (* ------------------------------------------------------------------------- *)
1501 fun op##
(f
, g
) (x
, y
) = (f x
, g 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
);
1512 (* ------------------------------------------------------------------------- *)
1513 (* State transformers
. *)
1514 (* ------------------------------------------------------------------------- *)
1516 val unit
: 'a
-> 's
-> 'a
* 's
= pair
;
1518 fun bind
f (g
: 'a
-> 's
-> 'b
* 's
) = uncurry g
o f
;
1520 fun mmap
f (m
: 's
-> 'a
* 's
) = bind
m (unit
o f
);
1522 fun join (f
: 's
-> ('s
-> 'a
* 's
) * 's
) = bind f I
;
1524 fun mwhile c b
= let fun f a
= if c a
then bind (b a
) f
else unit a
in f
end;
1526 (* ------------------------------------------------------------------------- *)
1528 (* ------------------------------------------------------------------------- *)
1530 fun cons x y
= x
:: y
;
1531 fun append xs ys
= xs @ ys
;
1533 fun unwrap
[a
] = a | unwrap _
= raise ERR
"unwrap" "not a singleton";
1535 fun first f
[] = NONE
1536 | first
f (x
:: xs
) = (case f x
of NONE
=> first f xs | s
=> s
);
1541 | idx
n (x
:: xs
) = if p x
then SOME n
else idx (n
+ 1) xs
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
)));
1552 (* This is an optimized version
*)
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
)
1558 (* This is the pure version
1559 fun partial_maps (_
: 'a
-> 's
-> 'b option
* 's
) [] = unit
[]
1560 | partial_maps
f (x
:: xs
) =
1562 (fn yo
=> bind (partial_maps f xs
)
1563 (fn ys
=> unit (case yo
of NONE
=> ys | SOME y
=> y
:: ys
)));
1566 (* This is an optimized version
*)
1567 fun partial_maps f
=
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
)
1574 fn l
=> fn (s
: 's
) => (rev ## I
) (foldl
g ([], s
) l
)
1577 fun enumerate n
= fst
o C (maps (fn x
=> fn m
=> ((m
, x
), m
+ 1))) n
;
1582 | z
l (x
:: xs
) (y
:: ys
) = z (f x y
:: l
) xs ys
1583 | z _ _ _
= raise ERR
"zipwith" "lists different lengths";
1585 fn xs
=> fn ys
=> rev (z
[] xs ys
)
1588 fun zip xs ys
= zipwith pair xs ys
;
1591 foldl (fn ((x
, y
), (xs
, ys
)) => (x
:: xs
, y
:: ys
)) ([], []) (rev ab
);
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
1601 let val xs
' = rev xs
in aux xs
' [] xs
' (rev ys
) end
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);
1609 fun split l n
= aux
[] l n
;
1612 fun update_nth f n l
=
1614 val (a
, b
) = split l n
1616 case b
of [] => raise Subscript
1617 | h
:: t
=> a @
(f h
:: t
)
1620 (* ------------------------------------------------------------------------- *)
1621 (* Lists
-as-sets
. *)
1622 (* ------------------------------------------------------------------------- *)
1624 fun mem x
= List.exists (equal x
);
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
;
1629 (* Removes duplicates
*)
1630 fun setify s
= foldl (fn (v
, x
) => if mem v x
then x
else v
:: x
) [] s
;
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
;
1637 fun subset s t
= List.all (fn x
=> mem x t
) s
;
1639 fun distinct
[] = true
1640 |
distinct (x
:: rest
) = not (mem x rest
) andalso distinct rest
;
1642 (* ------------------------------------------------------------------------- *)
1644 (* ------------------------------------------------------------------------- *)
1649 |
lex (x
:: l
) = case f x
of EQUAL
=> lex l | y
=> y
1654 (* ------------------------------------------------------------------------- *)
1655 (* Finding the minimal element
of a list
, wrt some order
. *)
1656 (* ------------------------------------------------------------------------- *)
1660 fun min_acc best
[] = best
1661 | min_acc
best (h
:: t
) = min_acc (if f best h
then best
else h
) t
1663 fn [] => raise ERR
"min" "empty list"
1664 | h
:: t
=> min_acc h t
1667 (* ------------------------------------------------------------------------- *)
1668 (* Merge (for the following merge
-sort
, but generally useful too
). *)
1669 (* ------------------------------------------------------------------------- *)
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
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 (* ------------------------------------------------------------------------- *)
1689 |
srt (l
as [x
]) = l
1692 val halfway
= length l
div 2
1694 merge
f (srt (List.take (l
, halfway
))) (srt (List.drop (l
, halfway
)))
1700 (* ------------------------------------------------------------------------- *)
1702 (* ------------------------------------------------------------------------- *)
1704 val int_to_string
= Int.toString
;
1705 val string_to_int
= Option
.valOf
o Int.fromString
;
1707 fun int_to_bits
0 = []
1708 | int_to_bits n
= (n
mod 2 <> 0) :: (int_to_bits (n
div 2));
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
);
1713 fun interval m
0 = []
1714 | interval m len
= m
:: interval (m
+ 1) (len
- 1);
1716 fun divides a b
= if a
= 0 then b
= 0 else b
mod (Int.abs a
) = 0;
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;
1722 fun looking res
0 _ _
= rev res
1723 | looking res n f x
=
1727 val f
' = both
f (not
o divides p
)
1729 looking res
' (n
- 1) f
' (p
+ 1)
1732 fun primes n
= looking
[] n (K
true) 2
1735 (* ------------------------------------------------------------------------- *)
1737 (* ------------------------------------------------------------------------- *)
1739 fun variant x vars
= if mem x vars
then variant (x ^
"'") vars
else x
;
1741 fun variant_num x vars
=
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
1746 if mem x vars
then v
1 else x
1751 fun check s
= assert (String.isPrefix p s
) (ERR
"dest_prefix" "")
1754 fn s
=> (check s
; String.extract (s
, size_p
, NONE
))
1757 fun is_prefix p
= can (dest_prefix p
);
1759 fun mk_prefix p s
= p ^ s
;
1761 (* ------------------------------------------------------------------------- *)
1763 (* ------------------------------------------------------------------------- *)
1765 val real_to_string
= Real.toString
;
1767 (* ------------------------------------------------------------------------- *)
1768 (* Pretty
-printing
. *)
1769 (* ------------------------------------------------------------------------- *)
1771 type 'a pp
= ppstream
-> 'a
-> unit
;
1773 val LINE_LENGTH
= ref
75;
1775 fun unit_pp pp_a a
pp () = pp_a pp a
;
1777 fun pp_unit_pp pp upp
= upp
pp ();
1779 fun pp_map f
pp_a (ppstrm
: ppstream
) x
: unit
= pp_a
ppstrm (f x
);
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
);
1785 fun pp_sequence sep pp_a
=
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
)
1792 (PP
.begin_block pp PP
.INCONSISTENT
0; pp_seq pp l
; PP
.end_block pp
)
1795 fun pp_unop s pp_a pp a
=
1796 (PP
.begin_block pp PP
.CONSISTENT
0;
1798 PP
.add_break
pp (1, 0);
1802 fun pp_binop s pp_a pp_b
pp (a
, b
) =
1803 (PP
.begin_block pp PP
.CONSISTENT
0;
1806 PP
.add_break
pp (1, 0);
1810 fun pp_nothing pp _
= (PP
.begin_block pp PP
.CONSISTENT
0; PP
.end_block pp
);
1812 fun pp_string pp s
=
1813 (PP
.begin_block pp PP
.CONSISTENT
0; PP
.add_string pp s
; PP
.end_block pp
);
1815 val pp_unit
= fn z
=> (pp_map (K
"()") pp_string
) z
;
1817 val pp_bool
= pp_map bool_to_string pp_string
;
1819 val pp_int
= pp_map int_to_string pp_string
;
1821 val pp_real
= pp_map real_to_string pp_string
;
1824 pp_map (fn LESS
=> "LESS" | EQUAL
=> "EQUAL" | GREATER
=> "GREATER")
1827 fun pp_list pp_a
= pp_bracket ("[", "]") (pp_sequence
"," pp_a
);
1829 fun pp_pair pp_a pp_b
= pp_bracket ("(", ")") (pp_binop
"," pp_a pp_b
);
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
)));
1837 val pp_l
= fn z
=> (pp_sequence
"," (pp_binop
" =" pp_string pp_unit_pp
)) z
;
1839 fun pp_record l
= pp_bracket ("{", "}") (unit_pp pp_l l
);
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
;
1845 (* ------------------------------------------------------------------------- *)
1847 (* ------------------------------------------------------------------------- *)
1849 datatype ('a
, 'b
) sum
= INL
of 'a | INR
of 'b
1851 fun is_inl (INL _
) = true |
is_inl (INR _
) = false;
1853 fun is_inr (INR _
) = true |
is_inr (INL _
) = false;
1855 (* ------------------------------------------------------------------------- *)
1857 (* ------------------------------------------------------------------------- *)
1859 datatype ('a
, 'b
) maplet
= |
-> of 'a
* 'b
;
1861 fun pp_maplet pp_a pp_b
=
1862 pp_map (fn a |
-> b
=> (a
, b
)) (pp_binop
" |->" pp_a pp_b
);
1864 (* ------------------------------------------------------------------------- *)
1866 (* ------------------------------------------------------------------------- *)
1868 datatype ('a
, 'b
) tree
= BRANCH
of 'a
* ('a
, 'b
) tree list | LEAF
of 'b
;
1870 fun tree_size (LEAF _
) = 1
1871 |
tree_size (BRANCH (_
, t
)) = foldl (op+ o (tree_size ## I
)) 1 t
;
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
);
1876 fun tree_foldl f_b f_l
=
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
1881 fn state
=> fn t
=> fold
state (t
, [])
1884 fun tree_partial_foldl f_b f_l
=
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
)
1891 fn state
=> fn t
=> fold
state (t
, [])
1894 (* ------------------------------------------------------------------------- *)
1895 (* Useful imperative features
. *)
1896 (* ------------------------------------------------------------------------- *)
1898 fun lazify_thunk f
= let val s
= Susp
.delay f
in fn () => Susp
.force s
end;
1901 val generator
= ref
0
1903 fun new_int () = let val n
= !generator
val () = generator
:= n
+ 1 in n
end;
1907 let val n
= !generator
val () = generator
:= n
+ k
in interval n k
end;
1910 fun with_flag (r
, update
) f x
=
1913 val () = r
:= update old
1914 val y
= f x
handle e
=> (r
:= old
; raise e
)
1920 (* ------------------------------------------------------------------------- *)
1921 (* Information about the environment
. *)
1922 (* ------------------------------------------------------------------------- *)
1924 val host
= Option
.getOpt (OS
.Process
.getEnv
"HOSTNAME", "unknown");
1926 val date
= Date
.fmt
"%H:%M:%S %d/%m/%Y" o Date
.fromTimeLocal
o Time
.now
;
1929 (*#line
0.0 "basic/Queue.sig"*)
1930 (* ========================================================================= *)
1931 (* A QUEUE DATATYPE FOR ML
*)
1932 (* Created by Joe Hurd
, October
2001 *)
1933 (* ========================================================================= *)
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
1951 (*#line
0.0 "basic/Queue.sml"*)
1952 (* ========================================================================= *)
1953 (* A QUEUE DATATYPE FOR ML
*)
1954 (* Created by Joe Hurd
, October
2001 *)
1955 (* ========================================================================= *)
1957 structure Queue
:> Queue
=
1960 type 'a queue
= 'a list
* 'a list
;
1962 val empty
: 'a queue
= ([], []);
1964 fun norm ([], ys
as _
:: _
) = (rev ys
, [])
1967 fun add
z (xs
, ys
) = norm (xs
, z
:: ys
);
1969 fun is_empty ([], _
) = true
1970 |
is_empty (_
:: _
, _
) = false;
1972 fun hd ([], _
) = raise Empty
1973 |
hd (x
:: _
, _
) = x
;
1975 fun tl ([], _
) = raise Empty
1976 |
tl (_
:: xs
, ys
) = norm (xs
, ys
);
1978 val length
= fn (xs
, ys
) => length xs
+ length ys
;
1980 fun from_list l
= (rev l
, []);
1982 fun to_list (xs
, ys
) = xs @ rev ys
;
1988 pp_map
to_list (pp_bracket ("Q[", "]") (pp_sequence
"," pp_a
));
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 (* ========================================================================= *)
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
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 (* ========================================================================= *)
2024 structure Heap
:> Heap
=
2027 datatype 'a node
= E | T
of int * 'a
* 'a node
* 'a node
;
2029 datatype 'a heap
= Heap
of ('a
* 'a
-> order
) * int * 'a node
;
2032 |
rank (T (r
, _
, _
, _
)) = r
;
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
);
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
)))
2048 fun empty f
= Heap (f
, 0, E
);
2050 fun add
x (Heap (f
, n
, a
)) = Heap (f
, n
+ 1, merge
f (T (1, x
, E
, E
), a
));
2052 fun is_empty (Heap (_
, _
, E
)) = true
2053 |
is_empty (Heap (_
, _
, T _
)) = false;
2055 fun top (Heap (_
, _
, E
)) = raise Empty
2056 |
top (Heap (_
, _
, T (_
, x
, _
, _
))) = x
;
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
)));
2061 fun size (Heap (_
, n
, _
)) = n
;
2066 |
ap (E
:: rest
) = ap rest
2067 |
ap (T (_
, d
, a
, b
) :: rest
) = (f d
; ap (a
:: b
:: rest
))
2069 fn Heap (_
, _
, a
) => ap
[a
]
2074 if is_empty h
then rev res
2075 else let val (x
, h
) = remove h
in to_lst (x
:: res
) h
end;
2077 fun to_list h
= to_lst
[] h
;
2084 pp_map
to_list (pp_bracket ("H[", "]") (pp_sequence
"," pp_a
));
2088 (*#line
0.0 "basic/Multiset.sig"*)
2089 (* ========================================================================= *)
2090 (* A MULTISET DATATYPE FOR ML
*)
2091 (* Created by Joe Hurd
, July
2002 *)
2092 (* ========================================================================= *)
2094 signature Multiset
=
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
2112 (*#line
0.0 "basic/Multiset.sml"*)
2113 (* ========================================================================= *)
2114 (* A MULTISET DATATYPE FOR ML
*)
2115 (* Created by Joe Hurd
, July
2002 *)
2116 (* ========================================================================= *)
2119 List.app load
["Binarymap", "Useful"];
2124 structure Multiset
:> Multiset
=
2127 structure M
= Binarymap
;
2129 fun Mpurge m k
= let val (m
, _
) = M
.remove (m
, k
) in m
end;
2134 fun f (x
, y
, ()) = if p (x
, y
) then () else raise Cut
2136 fn a
=> (M
.foldl
f () a
; true) handle Cut
=> false
2139 type 'a mset
= ('a
, int) M
.dict
;
2141 fun empty ord
: 'a mset
= M
.mkDict ord
;
2143 fun insert (_
, 0) a
= a
2145 (case M
.peek (a
, x
) of NONE
=> M
.insert (a
, x
, n
)
2147 let val n
'' = n
+ n
'
2148 in if n
'' = 0 then Mpurge a x
else M
.insert (a
, x
, n
'')
2151 fun count m x
= case M
.peek (m
, x
) of SOME n
=> n | NONE
=> 0;
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
;
2157 fun compl a
: 'a mset
= M
.transform ~ a
;
2159 fun subtract a b
= union
a (compl b
);
2162 fun sign a
= (Mall (fn (_
, n
) => 0 <= n
) a
, Mall (fn (_
, n
) => n
<= 0) a
);
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
);
2172 (case compare (a
, b
) of SOME LESS
=> true
2173 | SOME EQUAL
=> true
2176 fun app
f (a
: 'a mset
) = M
.app f a
;
2178 fun to_list (a
: 'a mset
) = M
.listItems a
;
2184 pp_map (map Useful
.|
-> o to_list
)
2185 (pp_bracket ("M[", "]") (pp_sequence
"," (Useful
.pp_maplet pp_a pp_int
)));
2189 (*#line
0.0 "basic/Stream.sig"*)
2190 (* ========================================================================= *)
2191 (* A POSSIBLY
-INFINITE STREAM DATATYPE FOR ML
*)
2192 (* Created by Joe Hurd
, April
2001 *)
2193 (* ========================================================================= *)
2198 datatype 'a stream
= NIL | CONS
of 'a
* (unit
-> 'a stream
)
2199 type 'a Sthk
= unit
-> 'a stream
2201 (* If you
're wondering how to create an infinite stream
: *)
2202 (* val stream4
= let fun s4 () = CONS
4 s4
in s4 () end; *)
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
*)
2228 (*#line
0.0 "basic/Stream.sml"*)
2229 (* ========================================================================= *)
2230 (* A POSSIBLY
-INFINITE STREAM DATATYPE FOR ML
*)
2231 (* Created by Joe Hurd
, April
2001 *)
2232 (* ========================================================================= *)
2234 structure Stream
:> Stream
=
2241 (* ------------------------------------------------------------------------- *)
2242 (* The
datatype declaration encapsulates all the primitive operations
. *)
2243 (* ------------------------------------------------------------------------- *)
2245 datatype 'a stream
= NIL | CONS
of 'a
* (unit
-> 'a stream
);
2247 type 'a Sthk
= unit
-> 'a stream
;
2249 (* ------------------------------------------------------------------------- *)
2250 (* Useful functions
. *)
2251 (* ------------------------------------------------------------------------- *)
2253 val cons
= fn z
=> curry CONS z
;
2255 fun null NIL
= true |
null (CONS _
) = false;
2257 fun hd NIL
= raise Empty |
hd (CONS (h
, _
)) = h
;
2259 fun tl NIL
= raise Empty |
tl (CONS (_
, t
)) = t ();
2261 fun dest s
= (hd s
, tl s
);
2263 fun repeat x
= let fun rep () = CONS (x
, rep
) in rep () end;
2265 fun count n
= CONS (n
, fn () => count (n
+ 1));
2268 let fun f NIL
= c |
f (CONS (x
, xs
)) = b
x (fn () => f (xs ())) in f
end;
2273 |
m (CONS (h
, t
)) = CONS (f h
, fn () => m (t ()))
2281 |
mt (CONS (h
, t
)) = CONS (h
, mt
' t
)
2282 and mt
' t
= f (fn () => mt (t ()))
2290 |
mp (CONS (h
, t
)) =
2291 case f h
of NONE
=> mp (t ())
2292 | SOME h
' => CONS (h
', fn () => mp (t ()))
2300 | mm
s (CONS (x
, xs
)) =
2301 let val (y
, s
') = f x s
2302 in CONS (y
, fn () => mm s
' (xs ()))
2308 fun partial_maps f
=
2311 | mm
s (CONS (x
, xs
)) =
2313 val (yo
, s
') = f x s
2316 case yo
of NONE
=> t () | SOME y
=> CONS (y
, t
)
2322 fun filter f
= partial_map (fn x
=> if f x
then SOME x
else NONE
);
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
)));
2333 |
z (CONS (x
, xs
)) (CONS (y
, ys
)) =
2334 CONS (f x y
, fn () => z (xs ()) (ys ()))
2339 fun zip s t
= zipwith pair s t
;
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 ()));
2346 fun drop n s
= N n tl s
handle Empty
=> raise Subscript
;
2349 fun to_lst res NIL
= res
2350 | to_lst
res (CONS (x
, xs
)) = to_lst (x
:: res
) (xs ());
2352 val to_list
= fn z
=> (rev
o to_lst
[]) z
2355 fun from_list
[] = NIL
2356 |
from_list (x
:: xs
) = CONS (x
, fn () => from_list xs
);
2358 fun from_textfile filename
=
2361 val fh
= openIn filename
2363 case inputLine fh
of NONE
=> (closeIn fh
; NIL
)
2364 | SOME s
=> CONS (s
, lazify_thunk res
)
2370 (*#line
0.0 "basic/Parser.sig"*)
2371 (* ========================================================================= *)
2372 (* PARSER COMBINATORS
*)
2373 (* Created by Joe Hurd
, April
2001 *)
2374 (* ========================================================================= *)
2379 (* Recommended fixities
2386 type 'a pp
= 'a Useful
.pp
2387 type 'a stream
= 'a Stream
.stream
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
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
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
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 (* ()[]{}.,; *)
2433 type 'a quotation
= 'a frag list
2434 val quotation_parser
: (string -> 'a
) -> 'b pp
-> 'b quotation
-> 'a
2437 (*#line
0.0 "basic/Parser.sml"*)
2438 (* ========================================================================= *)
2439 (* PARSER COMBINATORS
*)
2440 (* Created by Joe Hurd
, April
2001 *)
2441 (* ========================================================================= *)
2444 app load
["Useful", "Stream"];
2449 structure Parser
:> Parser
=
2454 structure S
= Stream
;
2462 type 'a stream
= 'a Stream
.stream
;
2463 val omap
= Option
.map
;
2465 (* ------------------------------------------------------------------------- *)
2467 (* ------------------------------------------------------------------------- *)
2471 fun op ++ (parser1
, parser2
) input
=
2473 val (result1
, rest1
) = parser1 input
2474 val (result2
, rest2
) = parser2 rest1
2476 ((result1
, result2
), rest2
)
2479 fun op >> (parser
, treatment
) input
=
2481 val (result
, rest
) = parser input
2483 (treatment result
, rest
)
2486 fun op >>++ (parser
, treatment
) input
=
2488 val (result
, rest
) = parser input
2490 treatment result rest
2493 fun op ||
(parser1
, parser2
) input
= parser1 input
2494 handle Noparse
=> parser2 input
;
2496 fun many parser input
=
2498 val (result
, next
) = parser input
2499 val (results
, rest
) = many parser next
2501 ((result
:: results
), rest
)
2503 handle Noparse
=> ([], input
);
2505 fun atleastone p
= (p
++ many p
) >> op::;
2507 fun nothing input
= ((), input
);
2509 fun optional p
= (p
>> SOME
) ||
(nothing
>> K NONE
);
2511 (* ------------------------------------------------------------------------- *)
2513 (* ------------------------------------------------------------------------- *)
2515 type ('a
, 'b
) parser
= 'a stream
-> 'b
* 'a stream
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
;
2521 fun finished S
.NIL
= ((), S
.NIL
)
2522 |
finished (S
.CONS _
) = raise Noparse
;
2524 val finished
: ('a
, unit
) parser
= finished
2526 fun some p
= maybe (fn x
=> if p x
then SOME x
else NONE
);
2528 fun any input
= some (K
true) input
;
2530 fun exact tok
= some (fn item
=> item
= tok
);
2532 (* ------------------------------------------------------------------------- *)
2533 (* Parsing
and pretty
-printing for
infix operators
. *)
2534 (* ------------------------------------------------------------------------- *)
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
;
2543 val sort_ops
: infixities
-> infixities
=
2545 fun order
{prec
, tok
= _
, left_assoc
= _
}
2546 {prec
= prec
', tok
= _
, left_assoc
= _
} =
2550 fun unflatten ({tok
, prec
, left_assoc
}, ([], _
)) =
2551 ([(left_assoc
, [tok
])], prec
)
2552 |
unflatten ({tok
, prec
, left_assoc
}, ((a
, l
) :: dealt
, p
)) =
2554 (assert (left_assoc
= a
) (BUG
"infix parser/printer" "mixed assocs");
2555 ((a
, tok
:: l
) :: dealt
, p
))
2557 ((left_assoc
, [tok
]) :: (a
, l
) :: dealt
, prec
);
2559 val layerops
= fst
o foldl
unflatten ([], 0) o sort_ops
;
2563 fun chop (#
" " :: chs
) = (curry
op+ 1 ## I
) (chop chs
) | chop chs
= (0, chs
);
2564 fun nspaces n
= N
n (curry
op^
" ") "";
2567 val chs
= explode tok
2568 val (r
, chs
) = chop (rev chs
)
2569 val (l
, chs
) = chop (rev chs
)
2571 ((l
, r
), implode chs
)
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));
2577 val op_spaces
= (lrspaces ## I
) o spacify
;
2578 val op_clean
= snd
o spacify
;
2581 val optoks
: infixities
-> string list
= map (fn {tok
, ...} => op_clean tok
);
2583 fun parse_gen_infix update sof toks parse inp
=
2585 val (e
, rest
) = parse inp
2587 case rest
of S
.NIL
=> NONE
2588 | S
.CONS (h
, t
) => if mem h toks
then SOME (h
, t
) else NONE
2590 case continue
of NONE
=> (sof e
, rest
)
2591 |
SOME (h
, t
) => parse_gen_infix
update (update sof h e
) toks
parse (t ())
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
;
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
;
2600 fun parse_infixes ops
=
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
2606 fn con
=> fn subparser
=> foldl (fn (p
, sp
) => p con sp
) subparser iparsers
2609 fun pp_gen_infix left toks
: 'a des
-> 'a iprinter
-> 'a iprinter
=
2611 val spc
= map op_spaces toks
2613 fn dest
=> fn pp_sub
=>
2616 case dest tm
of NONE
=> NONE
2617 |
SOME (t
, a
, b
) => omap (pair (a
, b
)) (List.find (equal t
o snd
) spc
)
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
))
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
)
2632 fun pp_left_infix toks
= pp_gen_infix
true toks
;
2634 fun pp_right_infix toks
= pp_gen_infix
false toks
;
2636 fun pp_infixes ops
=
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
2643 fn dest
=> fn pp_sub
=>
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
2648 fun subpr
pp (tmr
as (tm
, _
)) =
2650 (begin_block pp INCONSISTENT
1; add_string pp
"(";
2651 printer subpr
pp (tm
, false); add_string pp
")"; end_block pp
)
2655 (begin_block pp INCONSISTENT
0; printer subpr pp tmr
; end_block pp
)
2659 (* ------------------------------------------------------------------------- *)
2661 (* ------------------------------------------------------------------------- *)
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
"()[]{}.,;";
2672 (* ------------------------------------------------------------------------- *)
2674 (* ------------------------------------------------------------------------- *)
2676 type 'a quotation
= 'a frag list
;
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
) ""
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 (* ========================================================================= *)
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
2699 (* Datatypes for terms
and formulas
*)
2702 | Fn
of string * term list
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
2716 (* Contructors
and destructors
*)
2717 val dest_var
: term
-> string
2718 val is_var
: term
-> bool
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
2727 val mk_const
: string -> term
2728 val dest_const
: term
-> string
2729 val is_const
: term
-> bool
2731 val mk_binop
: string -> term
* term
-> term
2732 val dest_binop
: string -> term
-> term
* term
2733 val is_binop
: string -> term
-> bool
2735 val dest_atom
: formula
-> term
2736 val is_atom
: formula
-> bool
2738 val list_mk_conj
: formula list
-> formula
2739 val strip_conj
: formula
-> formula list
2740 val flatten_conj
: formula
-> formula list
2742 val list_mk_disj
: formula list
-> formula
2743 val strip_disj
: formula
-> formula list
2744 val flatten_disj
: formula
-> formula list
2746 val list_mk_forall
: string list
* formula
-> formula
2747 val strip_forall
: formula
-> string list
* formula
2749 val list_mk_exists
: string list
* formula
-> formula
2750 val strip_exists
: formula
-> string list
* formula
2753 val new_var
: unit
-> term
2754 val new_vars
: int -> term list
2756 (* Sizes
of terms
and formulas
*)
2757 val term_size
: term
-> int
2758 val formula_size
: formula
-> int
2760 (* Total comparison functions for terms
and formulas
*)
2761 val term_compare
: term
* term
-> order
2762 val formula_compare
: formula
* formula
-> order
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
2770 (* Operations on formula negations
*)
2771 val negative
: formula
-> bool
2772 val positive
: formula
-> bool
2773 val negate
: formula
-> formula
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
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
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
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
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
2810 (* A
datatype to antiquote both terms
and formulas
*)
2811 datatype thing
= Term
of term | Formula
of formula
;
2813 (* Operators parsed
and printed
infix *)
2814 val infixes
: infixities ref
2816 (* Deciding whether a
string denotes a variable or constant
*)
2817 val var_string
: (string -> bool) ref
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
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
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 (* ========================================================================= *)
2848 app load
["Useful", "Stream", "Parser", "Mosml", "Binarymap"];
2853 structure Term1
:> Term1
=
2861 infixr |
-> ::> @
> oo ##
;
2863 (* ------------------------------------------------------------------------- *)
2864 (* Datatypes for storing first
-order terms
and formulas
. *)
2865 (* ------------------------------------------------------------------------- *)
2869 | Fn
of string * term list
;
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
;
2883 (* ------------------------------------------------------------------------- *)
2884 (* Constructors
and destructors
. *)
2885 (* ------------------------------------------------------------------------- *)
2889 fun dest_var (Var v
) = v
2890 |
dest_var (Fn _
) = raise ERR
"dest_var" "";
2892 val is_var
= can dest_var
;
2896 fun dest_fn (Fn f
) = f
2897 |
dest_fn (Var _
) = raise ERR
"dest_fn" "";
2899 val is_fn
= can dest_fn
;
2901 val fn_name
= fst
o dest_fn
;
2903 val fn_args
= snd
o dest_fn
;
2905 val fn_arity
= length
o fn_args
;
2907 fun fn_function tm
= (fn_name tm
, fn_arity tm
);
2911 fun mk_const c
= (Fn (c
, []));
2913 fun dest_const (Fn (c
, [])) = c
2914 | dest_const _
= raise ERR
"dest_const" "";
2916 val is_const
= can dest_const
;
2918 (* Binary functions
*)
2920 fun mk_binop
f (a
, b
) = Fn (f
, [a
, b
]);
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";
2926 fun is_binop f
= can (dest_binop f
);
2930 fun dest_atom (Atom a
) = a
2931 | dest_atom _
= raise ERR
"dest_atom" "";
2933 val is_atom
= can dest_atom
;
2937 fun list_mk_conj l
= (case rev l
of [] => True | h
:: t
=> foldl And h t
);
2940 fun conj
cs (And (a
, b
)) = conj (a
:: cs
) b
2941 | conj cs fm
= rev (fm
:: cs
);
2943 fun strip_conj True
= []
2944 | strip_conj fm
= conj
[] fm
;
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
2954 fn fm
=> flat
[] [fm
]
2959 fun list_mk_disj l
= (case rev l
of [] => False | h
:: t
=> foldl Or h t
);
2962 fun disj
cs (Or (a
, b
)) = disj (a
:: cs
) b
2963 | disj cs fm
= rev (fm
:: cs
);
2965 fun strip_disj False
= []
2966 | strip_disj fm
= disj
[] fm
;
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
2976 fn fm
=> flat
[] [fm
]
2979 (* Universal quantifiers
*)
2981 fun list_mk_forall ([], body
) = body
2982 |
list_mk_forall (v
:: vs
, body
) = Forall (v
, list_mk_forall (vs
, body
));
2985 fun dest
vs (Forall (v
, b
)) = dest (v
:: vs
) b
2986 | dest vs tm
= (rev vs
, tm
);
2988 val strip_forall
= dest
[];
2991 (* Existential quantifiers
*)
2993 fun list_mk_exists ([], body
) = body
2994 |
list_mk_exists (v
:: vs
, body
) = Exists (v
, list_mk_exists (vs
, body
));
2997 fun dest
vs (Exists (v
, b
)) = dest (v
:: vs
) b
2998 | dest vs tm
= (rev vs
, tm
);
3000 val strip_exists
= dest
[];
3003 (* ------------------------------------------------------------------------- *)
3004 (* A
datatype to antiquote both terms
and formulas
. *)
3005 (* ------------------------------------------------------------------------- *)
3007 datatype thing
= Term
of term | Formula
of formula
;
3009 (* ------------------------------------------------------------------------- *)
3010 (* Built
-in infix operators
and reserved symbols
. *)
3011 (* ------------------------------------------------------------------------- *)
3013 val infixes
: infixities ref
= ref
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 *)
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}];
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}];
3048 val reserved
= ["!", "?", "(", ")", ".", "~"];
3050 (* ------------------------------------------------------------------------- *)
3051 (* Deciding whether a
string denotes a variable or constant
. *)
3052 (* ------------------------------------------------------------------------- *)
3055 ref (C mem
[#
"_",#
"v",#
"w",#
"x",#
"y",#
"z"] o Char.toLower
o hd
o explode
);
3057 (* ------------------------------------------------------------------------- *)
3058 (* Pretty
-printing
. *)
3059 (* ------------------------------------------------------------------------- *)
3061 (* Purely functional pretty
-printing
*)
3064 pp_map (fn s
=> if !var_string s
then s
else "var->" ^ s ^
"<-var") pp_string
;
3067 pp_map (fn s
=> if !var_string s
then "const->" ^ s ^
"<-const" else s
)
3071 pp_map (fn s
=> if !var_string s
then "fn->" ^ s ^
"<-fn" else s
) pp_string
;
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
)
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
) =
3097 fun pr
pp (Fn (q
, [Var v
, tm
])) =
3099 val (vs
, body
) = binds q tm
3103 app (fn a
=> (add_break
pp (1, 0); pp_vname pp a
)) vs
;
3105 add_break
pp (1, 0);
3106 if is_q body
then pr pp body
else pp_tm
pp (body
, false)
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
)
3111 (if is_q tm
then (if r
then pp_bracket ("(", ")") else I
) pp_q
3114 and molecule
pp (tm
, r
) =
3116 val (n
, x
) = negs tm
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
);
3123 and pp_btm pp tm
= pp_bracket ("(", ")") pp_tm
pp (tm
, false)
3124 and pp_tm pp tmr
= iprinter idest molecule pp tmr
3126 pp_map (C pair
false) pp_tm
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
;
3141 fun pp_formula
' ops
= pp_map
demote (pp_term
' ops
);
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
;
3147 (* Pretty
-printing things is needed for parsing thing quotations
*)
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
;
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
);
3156 (* Pretty
-printing using
!infixes
and !LINE_LENGTH
*)
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
;
3163 (* ------------------------------------------------------------------------- *)
3165 (* ------------------------------------------------------------------------- *)
3170 (fn ((_
, (toks
, _
)), _
) => toks
) o
3171 (many (some space
) ++
3173 ((((atleastone (some alphanum
) ||
3174 (some (fn c
=> symbol c
andalso c
<> #
"~") ++ many (some symbol
)) >>
3176 ||
some (fn c
=> c
= #
"~" orelse punct c
) >> str
) ++
3177 many (some space
)) >> fst
)) ++
3180 val lex_str
= lexer
o Stream
.from_list
o explode
;
3182 (* Purely functional parsing
*)
3185 some (fn tok
=> not (mem tok reserved
) andalso !var_string tok
);
3187 fun term_parser ops
=
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
])
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
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
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
;
3226 fun formula_parser ops
= term_parser ops
>> promote
;
3229 fun string_to_term
' ops
=
3230 fst
o ((term_parser ops
++ finished
) >> fst
) o Stream
.from_list
o lex_str
;
3232 fun string_to_formula
' ops
=
3233 fst
o ((formula_parser ops
++ finished
) >> fst
) o Stream
.from_list
o lex_str
;
3235 fun parse_term
' ops
=
3236 quotation_parser (string_to_term
' ops
) (pp_bracketed_thing ops
);
3238 fun parse_formula
' ops
=
3239 quotation_parser (string_to_formula
' ops
) (pp_bracketed_thing ops
);
3241 (* Parsing using
!infixes
*)
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
;
3248 (* ------------------------------------------------------------------------- *)
3249 (* New variables
. *)
3250 (* ------------------------------------------------------------------------- *)
3254 val num_var
= Var
o mk_prefix prefix
o int_to_string
;
3256 val new_var
= num_var
o new_int
;
3257 val new_vars
= map num_var
o new_ints
;
3260 (* ------------------------------------------------------------------------- *)
3261 (* Sizes
of terms
and formulas
. *)
3262 (* ------------------------------------------------------------------------- *)
3266 | szt
n (Var _
:: tms
) = szt (n
+ 1) tms
3267 | szt
n (Fn (_
, args
) :: tms
) = szt (n
+ 1) (args @ tms
);
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
);
3281 val term_size
= szt
0 o wrap
;
3282 val formula_size
= sz
0 o wrap
;
3285 (* ------------------------------------------------------------------------- *)
3286 (* Total comparison functions for terms
and formulas
. *)
3287 (* ------------------------------------------------------------------------- *)
3290 fun lex EQUAL f x
= f x | lex x _ _
= x
;
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
)
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
;
3333 val term_compare
= cmt
o wrap
;
3334 val formula_compare
= cm
o wrap
;
3337 (* ------------------------------------------------------------------------- *)
3338 (* Basic operations on literals
. *)
3339 (* ------------------------------------------------------------------------- *)
3341 fun mk_literal (true, a
) = a
3342 |
mk_literal (false, a
) = Not a
;
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" "";
3348 val is_literal
= can dest_literal
;
3350 val literal_atom
= snd
o dest_literal
;
3352 (* ------------------------------------------------------------------------- *)
3353 (* Dealing
with formula negations
. *)
3354 (* ------------------------------------------------------------------------- *)
3356 fun negative (Not p
) = true
3357 | negative _
= false;
3359 val positive
= non negative
;
3361 fun negate (Not p
) = p
3364 (* ------------------------------------------------------------------------- *)
3365 (* Functions
and relations
in a formula
. *)
3366 (* ------------------------------------------------------------------------- *)
3370 | fnc
fs (Var _
:: tms
) = fnc fs tms
3371 | fnc
fs (Fn (n
, a
) :: tms
) = fnc (insert (n
, length a
) fs
) (a @ tms
);
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
);
3386 val functions
= func
[] o wrap
;
3389 val function_names
= map fst
o functions
;
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
);
3405 val relations
= rel
[] o wrap
;
3408 val relation_names
= map fst
o relations
;
3410 (* ------------------------------------------------------------------------- *)
3411 (* The equality relation has a special status
. *)
3412 (* ------------------------------------------------------------------------- *)
3414 val eq_rel
= ("=", 2);
3416 fun mk_eq (a
, b
) = Atom (Fn ("=", [a
, b
]));
3418 fun dest_eq (Atom (Fn ("=", [a
, b
]))) = (a
, b
)
3419 | dest_eq _
= raise ERR
"dest_eq" "";
3421 val is_eq
= can dest_eq
;
3423 val lhs
= fst
o dest_eq
;
3425 val rhs
= snd
o dest_eq
;
3427 val eq_occurs
= mem eq_rel
o relations
;
3429 val relations_no_eq
= List.filter (non (equal eq_rel
)) o relations
;
3431 (* ------------------------------------------------------------------------- *)
3432 (* Free variables
in terms
and formulas
. *)
3433 (* ------------------------------------------------------------------------- *)
3439 if null av
then mem
else (fn v
=> fn vs
=> mem v av
orelse mem v 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
)
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
);
3459 fun FVT tm
= rev (fvt
[] [] [tm
]);
3460 fun FV fm
= rev (fv
[] [([], fm
)]);
3461 fun FVL fms
= rev (fv
[] (map (pair
[]) fms
));
3464 val specialize
= snd
o strip_forall
;
3466 fun generalize fm
= list_mk_forall (FV fm
, fm
);
3468 (* ------------------------------------------------------------------------- *)
3470 (* ------------------------------------------------------------------------- *)
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";
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
;
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
);
3489 fun atom_rewrite r
= Atom
o rewrite r
o dest_atom
;
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
;
3495 (* ------------------------------------------------------------------------- *)
3496 (* The Knuth
-Bendix ordering
. *)
3497 (* ------------------------------------------------------------------------- *)
3499 type Weight
= string * int -> int;
3500 type Prec
= (string * int) * (string * int) -> order
;
3502 val no_vars
= Multiset
.empty
String.compare
;
3503 fun one_var v
= Multiset
.insert (v
, 1) no_vars
;
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
)
3514 (* The Knuth
-Bendix ordering is partial when terms contain variables
*)
3516 fun kb_compare w p
=
3518 fun kbo
[] = SOME EQUAL
3519 |
kbo (tu
:: rest
) =
3520 if op= tu
then SOME EQUAL
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
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"
3545 (*#line
0.0 "fol/Subst1.sig"*)
3546 (* ========================================================================= *)
3547 (* SUBSTITUTIONS ON FIRST
-ORDER TERMS AND FORMULAS
*)
3548 (* Created by Joe Hurd
, June
2002 *)
3549 (* ========================================================================= *)
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
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
3580 (*#line
0.0 "fol/Subst1.sml"*)
3581 (* ========================================================================= *)
3582 (* SUBSTITUTIONS ON FIRST
-ORDER TERMS AND FORMULAS
*)
3583 (* Created by Joe Hurd
, June
2002 *)
3584 (* ========================================================================= *)
3587 app load
["Binarymap", "Useful", "Term1"];
3592 structure Subst1
:> Subst1
=
3600 infixr |
-> ::> @
> oo ##
;
3602 structure M
= Binarymap
;
3604 (* ------------------------------------------------------------------------- *)
3605 (* Helper functions
. *)
3606 (* ------------------------------------------------------------------------- *)
3608 fun Mpurge (d
, k
) = fst (M
.remove (d
, k
)) handle NotFound
=> d
;
3610 (* ------------------------------------------------------------------------- *)
3611 (* The underlying representation
. *)
3612 (* ------------------------------------------------------------------------- *)
3614 datatype subst
= Subst
of (string, term
) M
.dict
;
3616 (* ------------------------------------------------------------------------- *)
3618 (* ------------------------------------------------------------------------- *)
3620 val |
<>|
= Subst (M
.mkDict
String.compare
);
3622 fun (a |
-> b
) ::> (Subst d
) = Subst (M
.insert (d
, a
, b
));
3624 fun (Subst sub1
) @
> (Subst sub2
) =
3625 Subst (M
.foldl (fn (a
, b
, d
) => M
.insert (d
, a
, b
)) sub2 sub1
);
3627 fun null (Subst s
) = M
.numItems s
= 0;
3629 fun find_redex
r (Subst d
) = M
.peek (d
, r
);
3631 fun purge
v (Subst d
) = Subst (Mpurge (d
, v
));
3634 exception Unchanged
;
3636 fun always f x
= f x
handle Unchanged
=> x
;
3638 fun pair_unchanged
f (x
, y
) =
3640 val (c
, x
) = (true, f x
) handle Unchanged
=> (false, x
)
3641 val (c
, y
) = (true, f y
) handle Unchanged
=> (c
, y
)
3643 if c
then (x
, y
) else raise Unchanged
3646 fun list_unchanged f
=
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
3651 h
o foldl
g (false, [])
3654 fun find_unchanged v r
=
3655 case find_redex v r
of SOME t
=> t | NONE
=> raise Unchanged
;
3659 fun f (Var v
) = find_unchanged v r
3660 |
f (Fn (n
, a
)) = Fn (n
, list_unchanged f a
)
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
3678 if null r
then I
else always f
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
)
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
;
3689 fun norm (sub
as Subst dict
) =
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
3695 if removed
then Subst dict
' else sub
3698 fun to_maplets (Subst s
) = map (op|
->) (M
.listItems s
);
3700 fun from_maplets ms
= foldl (op ::>) |
<>|
(rev ms
);
3703 from_maplets
o List.filter (fn (a |
-> _
) => mem a vs
) o to_maplets
;
3705 (* Note
: this just doesn
't work
with cyclic substitutions
! *)
3706 fun refine (Subst sub1
) sub2
=
3709 let val b
' = term_subst sub2 b
3710 in if Var a
= b
' then s
else (a |
-> b
') ::> s
3713 foldl f
sub2 (M
.listItems sub1
)
3718 fun rs (v
, Var w
, l
) = if mem w l
then raise QF
else w
:: l
3719 |
rs (_
, Fn _
, _
) = raise QF
3721 fun is_renaming (Subst sub
) = (M
.foldl rs
[] sub
; true) handle QF
=> false;
3724 fun foldl f
b (Subst sub
) = M
.foldl (fn (s
, t
, a
) => f (s |
-> t
) a
) b sub
;
3726 fun foldr f
b (Subst sub
) = M
.foldr (fn (s
, t
, a
) => f (s |
-> t
) a
) b sub
;
3731 (fn [] => pp_string pp
"|<>|"
3732 | l
=> pp_list (pp_maplet pp_string pp_term
) pp l
));
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 (* ========================================================================= *)
3744 type term
= Term1
.term
3745 type formula
= Term1
.formula
3746 type subst
= Subst1
.subst
3748 (* An ABSTRACT
type for theorems
*)
3750 datatype inference
= Axiom | Refl | Assume | Inst | Factor | Resolve | Equality
3752 (* Destruction
of theorems is fine
*)
3753 val dest_thm
: thm
-> formula list
* (inference
* thm list
)
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
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 (* ========================================================================= *)
3771 structure Kernel1
:> Kernel1
=
3778 type subst
= Subst1
.subst
;
3779 val formula_subst
= Subst1
.formula_subst
;
3781 (* ------------------------------------------------------------------------- *)
3782 (* An ABSTRACT
type for theorems
. *)
3783 (* ------------------------------------------------------------------------- *)
3785 datatype inference
= Axiom | Refl | Assume | Inst | Factor | Resolve | Equality
;
3787 datatype thm
= Thm
of formula list
* (inference
* thm list
);
3789 (* ------------------------------------------------------------------------- *)
3790 (* Destruction
of theorems is fine
. *)
3791 (* ------------------------------------------------------------------------- *)
3793 fun dest_thm (Thm th
) = th
;
3795 val clause
= fst
o dest_thm
;
3797 (* ------------------------------------------------------------------------- *)
3798 (* But creation is only allowed by the primitive rules
of inference
. *)
3799 (* ------------------------------------------------------------------------- *)
3802 if List.all is_literal cl
then Thm (cl
, (Axiom
, []))
3803 else raise ERR
"AXIOM" "argument not a list of literals";
3805 fun REFL tm
= Thm ([mk_eq (tm
, tm
)], (Refl
, []));
3808 if is_literal fm
then Thm ([fm
, negate fm
], (Assume
, []))
3809 else raise ERR
"ASSUME" "argument not a literal";
3811 fun INST
env (th
as Thm (cl
, pr
)) =
3813 val cl
' = map (formula_subst env
) cl
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
]))
3822 let val cl
= rev (setify (clause th
))
3823 in if cl
= clause th
then th
else Thm (cl
, (Factor
, [th
]))
3826 fun RESOLVE fm th1 th2
=
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
3833 assert (cl1
<> cl1
' orelse cl2
<> cl2
')
3834 (ERR
"RESOLVE" "resolvant does not feature in either clause")
3836 Thm (cl1
' @ cl2
', (Resolve
, [th1
, th2
]))
3839 fun EQUALITY fm p res lr th
=
3843 val red
= literal_subterm p fm
3845 Not (mk_eq (if lr
then (red
, res
) else (res
, red
)))
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
3856 Thm (eq_lit
:: other_lits
, (Equality
, [th
]))
3860 (*#line
0.0 "fol/Match1.sig"*)
3861 (* ========================================================================= *)
3862 (* MATCHING AND UNIFICATION
*)
3863 (* Created by Joe Hurd
, September
2001 *)
3864 (* ========================================================================= *)
3869 type term
= Term1
.term
3870 type formula
= Term1
.formula
3871 type subst
= Subst1
.subst
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
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
3887 (*#line
0.0 "fol/Match1.sml"*)
3888 (* ========================================================================= *)
3889 (* MATCHING AND UNIFICATION
*)
3890 (* Created by Joe Hurd
, September
2001 *)
3891 (* ========================================================================= *)
3894 app load
["Useful", "Mosml", "Term1"];
3899 structure Match1
:> Match1
=
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
;
3912 (* ------------------------------------------------------------------------- *)
3914 (* ------------------------------------------------------------------------- *)
3916 fun raw_match env x tm
=
3917 (case Subst1
.find_redex x env
of NONE
=> (x |
-> tm
) ::> env
3919 if tm
= tm
' then env
3920 else raise ERR
"match" "one var trying to match two different terms");
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";
3930 fun match tm tm
' = Subst1
.norm (matchl |
<>|
[(tm
, tm
')]);
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";
3939 fun matchl_literals sub
= matchl sub
o List.mapPartial conv
;
3942 fun match_literals lit lit
' = Subst1
.norm (matchl_literals |
<>|
[(lit
, lit
')]);
3944 (* ------------------------------------------------------------------------- *)
3946 (* ------------------------------------------------------------------------- *)
3949 fun occurs v tm
= mem
v (FVT tm
);
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"
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";
3970 fun unify env tm tm
' = unifyl env
[(tm
, tm
')];
3972 fun unify_and_apply tm tm
' = term_subst (unify |
<>| tm tm
') tm
;
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";
3981 fun unifyl_literals env
= unifyl env
o List.mapPartial conv
;
3984 fun unify_literals env lit lit
' = unifyl_literals env
[(lit
, lit
')];
3987 (*#line
0.0 "fol/TermNet1.sig"*)
3988 (* ========================================================================= *)
3989 (* MATCHING AND UNIFICATION FOR SETS OF TERMS
*)
3990 (* Created by Joe Hurd
, September
2001 *)
3991 (* ========================================================================= *)
3993 signature TermNet1
=
3996 type 'a pp
= 'a Useful
.pp
3997 type ('a
, 'b
) maplet
= ('a
, 'b
) Useful
.maplet
3998 type term
= Term1
.term
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
4013 (*#line
0.0 "fol/TermNet1.sml"*)
4014 (* ========================================================================= *)
4015 (* MATCHING AND UNIFICATION FOR SETS OF TERMS
*)
4016 (* Created by Joe Hurd
, September
2001 *)
4017 (* ========================================================================= *)
4020 app load
["Useful", "Mosml", "Term1"];
4025 structure TermNet1
:> TermNet1
=
4032 val flatten
= List.concat
;
4034 (* ------------------------------------------------------------------------- *)
4035 (* Helper functions
. *)
4036 (* ------------------------------------------------------------------------- *)
4039 fun fifo_order (m
, _
) (n
, _
) = m
<= n
;
4041 fun restore_fifo_order l
= map
snd (sort fifo_order l
);
4044 fun partition_find f l
=
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
4053 (* ------------------------------------------------------------------------- *)
4054 (* Term discrimination trees are optimized for match queries
. *)
4055 (* ------------------------------------------------------------------------- *)
4057 datatype pattern
= VAR | FN
of string * int;
4059 type 'a map
= (pattern
, 'a
) tree
;
4061 datatype 'a term_map
= MAP
of int * (int * 'a
) map list
;
4063 val empty
= MAP (0, []);
4065 fun size (MAP (i
, _
)) = i
;
4067 fun to_list (MAP (_
, n
)) =
4068 restore_fifo_order (flatten (map (tree_foldr (K flatten
) wrap
) n
));
4070 fun pp_term_map pp_a
= pp_map
to_list (pp_list pp_a
);
4073 fun find_pat
x (BRANCH (p
, _
)) = p
= x
4074 | find_pat
_ (LEAF _
) = raise BUG
"find_pat" "misplaced LEAF";
4076 fun add a
[] l
= LEAF a
:: l
4077 | add
a (tm
:: rest
) l
=
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
4084 case this
of NONE
=> []
4085 |
SOME (BRANCH (_
, l
)) => l
4086 |
SOME (LEAF _
) => raise BUG
"add" "misplaced LEAF"
4088 BRANCH (pat
, add a rest next
) :: others
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";
4095 fun from_maplets l
= foldl (uncurry insert
) empty l
;
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";
4104 fun final a
[] = SOME a
4105 | final
_ (_
:: _
) = raise BUG
"match" "too many subterms";
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";
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
);
4121 fun final
a (0, []) = SOME a
4122 | final
_ (0, _
:: _
) = raise BUG
"matched" "too many subterms"
4123 | final
_ (n
, _
) = raise BUG
"matched" "still skipping";
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";
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
);
4139 fun final
a (0, []) = SOME a
4140 | final
_ (0, _
:: _
) = raise BUG
"unify" "too many subterms"
4141 | final
_ (n
, _
) = raise BUG
"unify" "still skipping";
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";
4148 (* ------------------------------------------------------------------------- *)
4149 (* We can overlay the above
type with a simple list
type. *)
4150 (* ------------------------------------------------------------------------- *)
4152 type 'a simple
= int * int * term list
* 'a list
;
4154 type 'a term_map
= ('a simple
, 'a term_map
) sum
;
4156 fun check (0, _
, t
, a
) =
4157 INR (from_maplets (foldl (fn (x
, xs
) => op|
-> x
:: xs
) [] (zip t a
)))
4160 val empty
: 'a term_map
= INR empty
;
4162 fun new n
= check (n
, 0, [], []);
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
));
4169 val match
= fn INL (_
, _
, _
, xs
) => K (rev xs
) | INR d
=> match d
;
4171 val matched
= fn INL (_
, _
, _
, xs
) => K (rev xs
) | INR d
=> matched d
;
4173 val unify
= fn INL (_
, _
, _
, xs
) => K (rev xs
) | INR d
=> unify d
;
4175 val size
= fn INL (_
, s
, _
, _
) => s | INR d
=> size d
;
4177 val from_maplets
= INR
o from_maplets
;
4179 val to_list
= fn INL (_
, _
, _
, xs
) => rev xs | INR d
=> to_list d
;
4183 (fn INL (_
, _
, _
, xs
) => pp_list pp_a pp xs | INR d
=> pp_term_map pp_a pp d
);
4187 (*#line
0.0 "fol/LiteralNet1.sig"*)
4188 (* ========================================================================= *)
4189 (* MATCHING AND UNIFICATION FOR SETS OF LITERALS
*)
4190 (* Created by Joe Hurd
, June
2002 *)
4191 (* ========================================================================= *)
4193 signature LiteralNet1
=
4196 type 'a pp
= 'a Useful
.pp
4197 type formula
= Term1
.formula
4198 type ('a
, 'b
) maplet
= ('a
, 'b
) Term1
.maplet
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
4214 (*#line
0.0 "fol/LiteralNet1.sml"*)
4215 (* ========================================================================= *)
4216 (* MATCHING AND UNIFICATION FOR SETS OF LITERALS
*)
4217 (* Created by Joe Hurd
, June
2002 *)
4218 (* ========================================================================= *)
4221 app load
["Useful", "Mosml", "Term1"];
4226 structure LiteralNet1
:> LiteralNet1
=
4233 structure T
= TermNet1
;
4235 (* ------------------------------------------------------------------------- *)
4237 (* ------------------------------------------------------------------------- *)
4239 type 'a literal_map
=
4240 ('a T
.term_map
* 'a T
.term_map
) * ((int * 'a list
) * (int * 'a list
));
4242 val empty
= ((T
.empty
, T
.empty
), ((0, []), (0, [])));
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
);
4250 fun from_maplets l
= foldl (uncurry insert
) empty l
;
4252 fun to_list ((pos
, neg
), ((_
, t
), (_
, f
))) =
4253 rev t @ rev f @ T
.to_list pos @ T
.to_list neg
;
4255 fun pp_literal_map pp_a
= pp_map
to_list (pp_list pp_a
);
4258 fun pos ((pos
, _
), _
) = T
.size pos
;
4259 fun neg ((_
, neg
), _
) = T
.size neg
;
4260 fun truth (_
, ((n
, _
), _
)) = n
;
4261 fun falsity (_
, (_
, (n
, _
))) = n
;
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
};
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";
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";
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";
4286 (*#line
0.0 "fol/Subsume1.sig"*)
4287 (* ========================================================================= *)
4288 (* A TYPE FOR SUBSUMPTION CHECKING
*)
4289 (* Created by Joe Hurd
, April
2002 *)
4290 (* ========================================================================= *)
4292 signature Subsume1
=
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
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
4310 (*#line
0.0 "fol/Subsume1.sml"*)
4311 (* ========================================================================= *)
4312 (* A TYPE FOR SUBSUMPTION CHECKING
*)
4313 (* Created by Joe Hurd
, April
2002 *)
4314 (* ========================================================================= *)
4317 app load
["Thm1", "Match1"];
4322 structure Subsume1
:> Subsume1
=
4327 open Useful Term1 Match1
;
4329 structure N
= LiteralNet1
;
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
;
4338 (* ------------------------------------------------------------------------- *)
4340 (* ------------------------------------------------------------------------- *)
4342 val () = traces
:= {module
= "Subsume1", alignment
= K
1} :: !traces
;
4344 fun chat l m
= trace
{module
= "Subsume1", message
= m
, level
= l
};
4346 (* ------------------------------------------------------------------------- *)
4347 (* Helper functions
. *)
4348 (* ------------------------------------------------------------------------- *)
4350 val frozen_prefix
= "FROZEN__";
4352 fun mk_frozen v
= Fn (frozen_prefix ^ v
, []);
4355 val chk
= String.isPrefix frozen_prefix
;
4357 let val l
= size frozen_prefix
in fn s
=> String.extract (s
, l
, NONE
) end;
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";
4364 val is_frozen
= can dest_frozen
;
4366 fun freeze_vars fms
=
4368 val vars
= FV (list_mk_disj fms
)
4369 val sub
= foldl (fn (v
, s
) => (v |
-> mk_frozen v
) ::> s
) |
<>| vars
4371 map (formula_subst sub
) fms
4375 fun f (v |
-> a
) = (v |
-> (if is_frozen a
then Var (dest_frozen a
) else a
));
4377 val defrost_vars
= Subst1
.from_maplets
o map f
o Subst1
.to_maplets
;
4380 val lit_size
= formula_size
o literal_atom
;
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
));
4386 (* ------------------------------------------------------------------------- *)
4387 (* The core engine for subsumption checking
. *)
4388 (* ------------------------------------------------------------------------- *)
4390 type 'a sinfo
= {sub
: subst
, hd
: formula
, tl
: formula list
, fin
: 'a
};
4392 type 'a subs
= 'a sinfo N
.literal_map
;
4394 fun add_lits (i
as {hd
, ...}) (net
: 'a subs
) = N
.insert (hd |
-> i
) net
;
4397 fun subsum strict lits
=
4400 (if strict
then ofilter (non Subst1
.is_renaming
) else SOME
) o
4403 let val lit_net
= N
.from_maplets (map (fn l
=> (l |
-> ())) lits
)
4404 in List.exists (null
o N
.matched lit_net
)
4406 fun extend sub lits fin net
=
4407 if impossible lits
then net
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
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
)
4425 fun subsumes strict net lits
=
4426 subsum
strict (freeze_vars lits
) (net
, [])
4427 handle ERR_EXN _
=> raise BUG
"subsumes" "shouldn't fail";
4430 (* ------------------------------------------------------------------------- *)
4431 (* The user interface
. *)
4432 (* ------------------------------------------------------------------------- *)
4434 type 'a subsume
= ('a
, 'a subs
) sum
;
4436 val empty
: 'a subsume
= INR N
.empty
;
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
);
4443 fun subsumed (INL fin
) _
= [(|
<>|
, fin
)]
4444 |
subsumed (INR _
) [] = []
4445 |
subsumed (INR net
) lits
= subsumes
false net lits
;
4447 fun strictly_subsumed _
[] = []
4448 |
strictly_subsumed (INL fin
) _
= [(|
<>|
, fin
)]
4449 |
strictly_subsumed (INR net
) lits
= subsumes
true net lits
;
4451 fun info ((INL _
) : 'a subsume
) = "*"
4452 |
info (INR net
) = int_to_string (N
.size net
);
4454 val pp_subsum
= fn z
=> pp_map info pp_string z
;
4458 installPP pp_formula
;
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)`
]);
4468 (*#line
0.0 "fol/Tptp1.sig"*)
4469 (* ========================================================================= *)
4470 (* INTERFACE TO TPTP PROBLEM FILES
*)
4471 (* Created by Joe Hurd
, December
2001 *)
4472 (* ========================================================================= *)
4477 type term
= Term1
.term
4478 type formula
= Term1
.formula
4480 (* Maintaining different relation
and function names
in TPTP problems
*)
4481 val renaming
: {tptp
: string, fol
: string, arity
: int} list ref
4483 (* Parsing
: pass
in a filename
*)
4484 val parse_cnf
: string -> formula
4487 (*#line
0.0 "fol/Tptp1.sml"*)
4488 (* ========================================================================= *)
4489 (* INTERFACE TO TPTP PROBLEM FILES
*)
4490 (* Created by Joe Hurd
, December
2001 *)
4491 (* ========================================================================= *)
4494 app load
["Stream", "Useful", "Parser", "Term1"];
4499 structure Tptp1
:> Tptp1
=
4502 open Parser Useful Term1
;
4510 structure S
= Stream
;
4512 (* ------------------------------------------------------------------------- *)
4513 (* Abbreviating relation
and function names
in TPTP problems
. *)
4514 (* ------------------------------------------------------------------------- *)
4516 type rename
= {tptp
: string, fol
: string, arity
: int};
4518 val renaming
: rename list ref
= ref
[{tptp
= "equal", fol
= "=", arity
= 2}];
4520 (* ------------------------------------------------------------------------- *)
4521 (* Parsing
: pass
in a filename
. *)
4522 (* ------------------------------------------------------------------------- *)
4524 val comment
= equal #
"%" o hd
o explode
;
4526 val input_lines
= S
.filter (non comment
) o S
.from_textfile
;
4528 val input_chars
= S
.flatten
o S
.map (S
.from_list
o explode
);
4530 datatype tok_type
= Lower | Upper | Symbol | Punct
;
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
;
4541 val lex
= many lexer
++ (many (some space
) ++ finished
) >> fst
;
4543 val input_toks
= S
.from_list
o fst
o lex
;
4545 fun Var
' "T" = Var
"T'"
4546 | Var
' "F" = Var
"F'"
4547 | Var
' v
= Var (if !var_string v
then v
else "v_" ^ v
);
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
) =
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
)
4558 fun Fn
' A
= Fn (mapped
A (!renaming
));
4561 fun term_parser input
=
4562 ((some (equal Upper
o fst
) >> (Var
' o snd
)) ||
4563 ((some (equal Lower
o fst
) >> snd
) ++
4565 (exact (Punct
, "(") ++ term_parser
++
4566 many ((exact (Punct
, ",") ++ term_parser
) >> snd
) ++
4567 exact (Punct
, ")")) >>
4568 (fn SOME (_
, (t
, (ts
, _
))) => t
:: ts | NONE
=> [])) >>
4571 val literal_parser
=
4572 ((exact (Symbol
, "++") >> K
true ||
exact (Symbol
, "--") >> K
false) ++
4574 (fn (s
, t
) => mk_literal (s
, Atom (case t
of Var v
=> Fn (v
, []) | _
=> t
)));
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
));
4584 val cnf_parser
= fst
o ((many clause_parser
++ finished
) >> fst
);
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;
4591 fun generalize_clause fm
=
4595 val nvars
= length vars
4596 val var_fn
= if nvars
<= 15 then variant
else variant_num
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
)
4602 generalize (formula_subst sub fm
)
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
;
4611 val parse_cnf
= input_cnf
o input_toks
o input_chars
o input_lines
;
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 (* ========================================================================= *)
4623 type 'a pp
= 'a Useful
.pp
4627 (* Annotated primitive inferences
*)
4628 datatype inference
' =
4629 Axiom
' of formula list
4631 | Assume
' of formula
4632 | Inst
' of subst
* thm
4634 | Resolve
' of formula
* thm
* thm
4635 | Equality
' of formula
* int list
* term
* bool * thm
4637 val primitive_inference
: inference
' -> thm
4639 (* User
-friendly destructors
*)
4640 val clause
: thm
-> formula list
4641 val inference
: thm
-> inference
'
4642 val proof
: thm
-> (thm
* inference
') list
4644 (* Pretty
-printing
of theorems
and inferences
*)
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
4654 (* A total comparison function for theorems
*)
4655 val thm_compare
: thm
* thm
-> order
4657 (* Contradictions
and unit clauses
*)
4658 val is_contradiction
: thm
-> bool
4659 val dest_unit
: thm
-> formula
4660 val is_unit
: thm
-> bool
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
4670 val TRANSITIVITY
: thm
4671 val FUN_CONGRUENCE
: string * int -> thm
4672 val REL_CONGRUENCE
: string * int -> thm
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 (* ========================================================================= *)
4682 app load
["Useful", "Term1", "Kernel1", "Match1"];
4687 structure Thm1
:> Thm1
=
4690 open Useful Term1 Kernel1 Match1
;
4692 infixr |
-> ::> oo ##
;
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
;
4701 (* ------------------------------------------------------------------------- *)
4702 (* Annotated primitive inferences
. *)
4703 (* ------------------------------------------------------------------------- *)
4705 datatype inference
' =
4706 Axiom
' of formula list
4708 | Assume
' of formula
4709 | Inst
' of subst
* thm
4711 | Resolve
' of formula
* thm
* thm
4712 | Equality
' of formula
* int list
* term
* bool * thm
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
;
4722 val clause
= fst
o dest_thm
;
4724 (* ------------------------------------------------------------------------- *)
4725 (* Pretty
-printing
of theorems
*)
4726 (* ------------------------------------------------------------------------- *)
4729 (PP
.begin_block pp PP
.INCONSISTENT
3;
4730 PP
.add_string pp
"|- ";
4731 pp_formula
pp (list_mk_disj (clause th
));
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";
4743 val pp_inference
= pp_map inf_to_string pp_string
;
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
)) =
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
)]) ());
4761 fun pp_inference
' pp inf
=
4764 val (i
, ppf
) = pp_inf inf
4766 (begin_block pp INCONSISTENT
0;
4768 add_break
pp (1, 0);
4774 val pp_proof
= pp_list (pp_pair pp_thm pp_inference
');
4776 (* Purely functional pretty
-printing
*)
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
';
4781 (* Pretty
-printing using
!LINE_LENGTH
*)
4783 fun thm_to_string th
= thm_to_string
' (!LINE_LENGTH
) th
;
4784 fun inference_to_string inf
= inference_to_string
' (!LINE_LENGTH
) inf
;
4786 (* ------------------------------------------------------------------------- *)
4787 (* A total comparison function for theorems
. *)
4788 (* ------------------------------------------------------------------------- *)
4791 fun cmp Axiom Axiom
= EQUAL
4792 | cmp Axiom _
= LESS
4793 | cmp _ Axiom
= GREATER
4794 | cmp Refl Refl
= EQUAL
4796 | cmp _ Refl
= GREATER
4797 | cmp Assume Assume
= EQUAL
4798 | cmp Assume _
= LESS
4799 | cmp _ Assume
= GREATER
4800 | cmp Inst Inst
= EQUAL
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
;
4812 |
cm ((th1
, th2
) :: l
) =
4814 val (l1
, (p1
, ths1
)) = dest_thm th1
4815 val (l2
, (p2
, ths2
)) = dest_thm th2
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
)
4826 val thm_compare
= cm
o wrap
;
4829 (* ------------------------------------------------------------------------- *)
4830 (* Reconstructing proofs
. *)
4831 (* ------------------------------------------------------------------------- *)
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
4842 fun reconstruct_equality l r
=
4844 fun recon_fn
p (f
, args
) (f
', args
') rest
=
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
)
4852 case (tm
, tm
') of (Fn a
, Fn a
') => recon_fn p a a
' rest
4853 | _
=> recon_tm rest
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
4861 case recon_lit lit lit
' of SOME p
=> SOME (lit
, p
) | NONE
=> NONE
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
])) =
4872 val f
= reconstruct_resolvant (clause th1
) (clause th2
)
4874 case f (cl
, cl
) of SOME l
=> l
4876 case first
f (List.tabulate (length cl
, split cl
)) of SOME l
=> l
4877 | NONE
=> raise BUG
"inference" "couldn't reconstruct resolvant"
4879 Resolve
' (l
, th1
, th2
)
4881 |
reconstruct (Not fm
:: cl
, (Equality
, [th
])) =
4883 val (tm1
, tm2
) = dest_eq fm
4885 case first (reconstruct_equality tm1 tm2
) (zip (clause th
) cl
) of
4886 SOME (l
, p
) => Equality
' (l
, p
, tm2
, true, th
)
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"
4892 | reconstruct _
= raise BUG
"inference" "malformed inference";
4896 val i
= reconstruct (dest_thm th
)
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
))
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
);
4912 fun reduce (th
, pf
) =
4913 if contains pf th
then pf
4914 else add
th (foldl reduce
pf (snd (snd (dest_thm th
))));
4916 fun proof th
= finalize (reduce (th
, empty
));
4919 (* ------------------------------------------------------------------------- *)
4920 (* Contradictions
and unit clauses
. *)
4921 (* ------------------------------------------------------------------------- *)
4923 val is_contradiction
= null
o clause
;
4926 case clause th
of [lit
] => lit | _
=> raise ERR
"dest_unit" "not a unit";
4928 val is_unit
= can dest_unit
;
4930 (* ------------------------------------------------------------------------- *)
4932 (* ------------------------------------------------------------------------- *)
4934 fun CONTR lit th
= RESOLVE (negate lit
) (ASSUME lit
) th
;
4936 fun WEAKEN lits th
= foldl (uncurry CONTR
) th (rev lits
);
4938 fun FRESH_VARSL ths
=
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
)
4947 val FRESH_VARS
= unwrap
o FRESH_VARSL
o wrap
;
4949 fun UNIT_SQUASH th
=
4951 fun squash
env (x
:: (xs
as y
:: _
)) = squash (unify_literals env x y
) xs
4952 | squash env _
= env
4954 FACTOR (INST (squash |
<>|
(clause th
)) th
)
4957 val REFLEXIVITY
= REFL (Var
"x");
4960 EQUALITY (mk_eq (Var
"x", Var
"x")) [0] (Var
"y") true REFLEXIVITY
;
4963 EQUALITY (mk_eq (Var
"y", Var
"z")) [0] (Var
"x") false
4964 (ASSUME (Not (mk_eq (Var
"y", Var
"z"))));
4966 fun FUN_CONGRUENCE (function
, arity
) =
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
))
4971 EQUALITY (List.last (clause th
)) [1,i
] (List.nth (ys
, i
)) true th
4972 val refl
= INST (("x" |
-> Fn (function
, xs
)) ::> |
<>|
) REFLEXIVITY
4974 foldl f
refl (rev (interval
0 arity
))
4977 fun REL_CONGRUENCE (relation
, arity
) =
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
))
4982 EQUALITY (List.last (clause th
)) [i
] (List.nth (ys
, i
)) true th
4983 val refl
= ASSUME (Not (Atom (Fn (relation
, xs
))))
4985 foldl f
refl (rev (interval
0 arity
))
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 (* ========================================================================= *)
4999 type term
= Term1
.term
5000 type formula
= Term1
.formula
5003 (* Simplification
*)
5004 val simplify
: formula
-> formula
5006 (* Negation normal form
*)
5007 val nnf
: formula
-> formula
5009 (* Prenex normal form
*)
5010 val prenex
: formula
-> formula
5011 val pnf
: formula
-> formula
5014 val skolemize
: formula
-> formula
5015 val full_skolemize
: formula
-> formula
5017 (* A tautology filter for clauses
*)
5018 val tautologous
: formula list
-> bool
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
*)
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 (* ========================================================================= *)
5038 app load
["Useful", "Term1"];
5041 structure Canon1
:> Canon1
=
5044 open Useful Term1 Thm1
;
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
;
5054 (* ------------------------------------------------------------------------- *)
5055 (* Simplification
. *)
5056 (* ------------------------------------------------------------------------- *)
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
;
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
))
5093 (* ------------------------------------------------------------------------- *)
5094 (* Negation normal form
. *)
5095 (* ------------------------------------------------------------------------- *)
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
5105 and nnf
' True
= False
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
5116 (* ------------------------------------------------------------------------- *)
5117 (* Prenex normal form
. *)
5118 (* ------------------------------------------------------------------------- *)
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
5133 and pullquant_l fm Q C x p q
=
5135 val x
' = variant
x (FV fm
)
5137 Q (x
', pullquants (C (formula_subst ((x |
-> Var x
') ::> |
<>|
) p
, q
)))
5139 and pullquant_r fm Q C x p q
=
5141 val x
' = variant
x (FV fm
)
5143 Q (x
', pullquants (C (p
, formula_subst ((x |
-> Var x
') ::> |
<>|
) q
)))
5145 and pullquant_2 fm Q C x y p q
=
5147 val x
' = variant
x (FV fm
)
5149 Q (x
', pullquants(C (formula_subst ((x |
-> Var x
') ::> |
<>|
) p
,
5150 formula_subst ((x |
-> Var x
') ::> |
<>|
) q
)))
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
))
5159 val pnf
= prenex
o nnf
o simplify
;
5161 (* ------------------------------------------------------------------------- *)
5162 (* Skolemization function
. *)
5163 (* ------------------------------------------------------------------------- *)
5165 fun skolem
avoid (Exists (y
, p
)) =
5167 val xs
= subtract (FV p
) [y
]
5168 val f
= variant (if xs
= [] then "c_" ^ y
else "f_" ^ y
) avoid
5170 skolem
avoid (formula_subst ((y |
-> Fn (f
, map Var xs
)) ::> |
<>|
) p
)
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
5176 and skolem2 avoid C p q
=
5178 val p
' = skolem avoid p
5179 val q
' = skolem (union
avoid (function_names p
')) q
5184 fun skolemize fm
= skolem (function_names fm
) fm
;
5186 val full_skolemize
= specialize
o prenex
o skolemize
o nnf
o simplify
;
5188 (* ------------------------------------------------------------------------- *)
5189 (* A tautology filter for clauses
. *)
5190 (* ------------------------------------------------------------------------- *)
5192 fun tautologous cls
=
5194 val (pos
, neg
) = List.partition positive cls
5196 intersect
pos (map negate neg
) <> []
5199 (* ------------------------------------------------------------------------- *)
5200 (* Conjunctive Normal Form
. *)
5201 (* ------------------------------------------------------------------------- *)
5203 fun distrib s1 s2
= cartwith union s1 s2
;
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
]];
5209 fun simpcnf True
= []
5210 | simpcnf False
= [[]]
5211 | simpcnf fm
= List.filter (non tautologous
) (purecnf fm
);
5214 List.concat
o map (simpcnf
o specialize
o prenex
) o flatten_conj
o
5215 skolemize
o nnf
o simplify
5217 val cnf
= list_mk_conj
o map list_mk_disj
o clausal
;
5219 val axiomatize
= map AXIOM
o clausal
;
5221 fun eq_axiomatize fm
=
5223 val eqs
= [REFLEXIVITY
, SYMMETRY
, TRANSITIVITY
]
5224 val rels
= map
REL_CONGRUENCE (relations_no_eq fm
)
5225 val funs
= map
FUN_CONGRUENCE (functions fm
)
5227 eqs @ funs @ rels @ axiomatize fm
5230 fun eq_axiomatize
' fm
= (if eq_occurs fm
then eq_axiomatize
else axiomatize
) fm
;
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 (* ========================================================================= *)
5242 type 'a pp
= 'a Useful
.pp
5243 type formula
= Term1
.formula
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
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 (* ========================================================================= *)
5266 ["Useful", "Mosml", "Term1", "Thm1", "Canon1", "Match1"];
5271 structure Units1
:> Units1
=
5274 open Useful Term1 Thm1 Match1
;
5276 infix |
-> ::> @
> oo ##
;
5278 structure N
= LiteralNet1
;
5280 (* ------------------------------------------------------------------------- *)
5281 (* Auxiliary functions
. *)
5282 (* ------------------------------------------------------------------------- *)
5284 fun lift_options f
=
5286 fun g res
[] = SOME (rev res
)
5287 | g
res (x
:: xs
) = case f x
of SOME y
=> g (y
:: res
) xs | NONE
=> NONE
5292 (* ------------------------------------------------------------------------- *)
5293 (* Operations on the raw unit cache
. *)
5294 (* ------------------------------------------------------------------------- *)
5296 type uns
= thm N
.literal_map
;
5298 val uempty
: uns
= N
.empty
;
5300 fun uadd th uns
= N
.insert (dest_unit th |
-> th
) uns
;
5302 fun usubsumes uns lit
=
5303 List.find (can (C match_literals lit
) o dest_unit
)
5304 (rev (N
.match uns lit
));
5309 Option
.map (fn th
=> INST (match_literals (dest_unit th
) lit
) th
)
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"
5322 fn th
=> foldl demod
th (clause th
)
5325 (* ------------------------------------------------------------------------- *)
5326 (* The user interface
. *)
5327 (* ------------------------------------------------------------------------- *)
5329 type units
= (thm
, uns
) sum
;
5331 val empty
= INR uempty
;
5333 fun subsumes (INL th
) = K (SOME th
)
5334 |
subsumes (INR uns
) = usubsumes uns
;
5336 fun prove (INL th
) = SOME
o map (fn False
=> th | lit
=> CONTR lit th
)
5337 |
prove (INR uns
) = uprove uns
;
5339 fun demod (INL th
) = K th
5340 |
demod (INR uns
) = udemod uns
;
5342 fun info ((INL _
) : units
) = "*"
5343 |
info (INR uns
) = int_to_string (N
.size uns
);
5345 val pp_units
= pp_map info pp_string
;
5347 (* Adding a theorem involves squashing it to a unit
, if possible
. *)
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
5354 val th
= udemod uns th
5356 if is_contradiction th
then INL th
5357 else case total UNIT_SQUASH th
of NONE
=> U | SOME th
=> INR (uadd th uns
)
5360 val addl
= C (foldl (uncurry add
));
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 (* ========================================================================= *)
5370 signature Problem1
=
5373 type 'a quotation
= 'a frag list
5374 type 'a problem
= {name
: string, goal
: 'a quotation
}
5376 (* Accessing individual problems
*)
5377 val get
: 'a problem list
-> string -> 'a quotation
5379 (* The master collections
*)
5380 val nonequality
: 'a problem list
5381 val equality
: 'a problem list
5382 val tptp
: 'a problem list
5384 (* Some compilations
*)
5385 (*val quick
: 'a problem list
*)
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 (* ========================================================================= *)
5395 structure Problem1
:> Problem1
=
5398 type 'a quotation
= 'a frag list
;
5400 type 'a problem
= {name
: string, goal
: 'a quotation
};
5402 (* ========================================================================= *)
5403 (* Accessing individual problems
. *)
5404 (* ========================================================================= *)
5406 fun extract (p
: 'a problem list
) n
=
5407 Option
.valOf (List.find (fn {name
, ...} => name
= n
) p
);
5409 fun get p
= #goal
o extract p
;
5411 (* ========================================================================= *)
5412 (* Problems without equality
. *)
5413 (* ========================================================================= *)
5417 (* ------------------------------------------------------------------------- *)
5418 (* Trivia (some
of which demonstrate ex
-bugs
in provers
). *)
5419 (* ------------------------------------------------------------------------- *)
5425 {name
= "P_or_not_P",
5427 QUOTE
"\np \\/ ~p"]},
5431 QUOTE
"\n!x y. ?z. p x \\/ p y ==> p z"]},
5435 QUOTE
"\n(!x. p (g (c x))) ==> ?z. p (g z)"]},
5439 QUOTE
"\n(!x. ?y. f y x x) ==> ?z. f z 0 0"]},
5443 QUOTE
"\n!x. ?v w. !y z. p x /\\ q y ==> (p v \\/ r w) /\\ (r z ==> q v)"]},
5445 (* ------------------------------------------------------------------------- *)
5446 (* Propositional Logic
. *)
5447 (* ------------------------------------------------------------------------- *)
5451 QUOTE
"\np ==> q <=> ~q ==> ~p"]},
5455 QUOTE
"\n~~p <=> p"]},
5459 QUOTE
"\n~(p ==> q) ==> q ==> p"]},
5463 QUOTE
"\n~p ==> q <=> ~q ==> p"]},
5467 QUOTE
"\n(p \\/ q ==> p \\/ r) ==> p \\/ (q ==> r)"]},
5471 QUOTE
"\np \\/ ~p"]},
5475 QUOTE
"\np \\/ ~~~p"]},
5479 QUOTE
"\n((p ==> q) ==> p) ==> p"]},
5483 QUOTE
"\n(p \\/ q) /\\ (~p \\/ q) /\\ (p \\/ ~q) ==> ~(~q \\/ ~q)"]},
5487 QUOTE
"\n(q ==> r) /\\ (r ==> p /\\ q) /\\ (p ==> q /\\ r) ==> (p <=> q)"]},
5491 QUOTE
"\np <=> p"]},
5495 QUOTE
"\n((p <=> q) <=> r) <=> p <=> q <=> r"]},
5499 QUOTE
"\np \\/ q /\\ r <=> (p \\/ q) /\\ (p \\/ r)"]},
5503 QUOTE
"\n(p <=> q) <=> (q \\/ ~p) /\\ (~q \\/ p)"]},
5507 QUOTE
"\np ==> q <=> ~p \\/ q"]},
5511 QUOTE
"\n(p ==> q) \\/ (q ==> p)"]},
5515 QUOTE
"\np /\\ (q ==> r) ==> s <=> (~p \\/ q \\/ s) /\\ (~p \\/ ~r \\/ s)"]},
5517 {name
= "MATHS4_EXAMPLE",
5519 QUOTE
"\n(a \\/ ~k ==> g) /\\ (g ==> q) /\\ ~q ==> k"]},
5521 {name
= "XOR_ASSOC",
5523 QUOTE
"\n~(~(p <=> q) <=> r) <=> ~(p <=> ~(q <=> r))"]},
5525 (* ------------------------------------------------------------------------- *)
5526 (* Monadic Predicate Logic
. *)
5527 (* ------------------------------------------------------------------------- *)
5529 (* The drinker
's principle
*)
5532 QUOTE
"\n?very_popular_guy. !whole_pub. drinks very_popular_guy ==> drinks whole_pub"]},
5536 QUOTE
"\n?x. !y z. (p y ==> q z) ==> p x ==> q x"]},
5540 QUOTE
"\n(!x y. ?z. !w. p x /\\ q y ==> r z /\\ u w) /\\ (!x y. p x /\\ q y) ==> ?z. r z"]},
5544 QUOTE
"\n(?x. p ==> q x) /\\ (?x. q x ==> p) ==> ?x. p <=> q x"]},
5548 QUOTE
"\n(!x. p <=> q x) ==> (p <=> !x. q x)"]},
5552 QUOTE
"\n(!x. p \\/ q x) <=> p \\/ !x. q x"]},
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"]},
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"]},
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)"]},
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"]},
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"]},
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)"]},
5588 QUOTE
"\n(!x. p x \\/ g x ==> ~h x) /\\ (!x. (g x ==> ~u x) ==> p x /\\ h x) ==>\n!x. u x"]},
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"]},
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"]},
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)"]},
5605 (* This gives rise to
5184 clauses when converted to CNF
! *)
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"]},
5613 QUOTE
"\n?x y. p x y ==> !x y. p x y"]},
5615 (* ------------------------------------------------------------------------- *)
5616 (* Full predicate
logic (without Identity
and Functions
) *)
5617 (* ------------------------------------------------------------------------- *)
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"]},
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"]},
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)"]},
5639 QUOTE
"\n~?x. !y. p y x <=> ~p y y"]},
5643 QUOTE
"\n(?y. !x. p x y <=> p x x) ==> ~!x. ?y. !z. p z y <=> ~p z x"]},
5647 QUOTE
"\n(!z. ?y. !x. p x y <=> p x z /\\ ~p x x) ==> ~?z. !x. p x z"]},
5651 QUOTE
"\n~?y. !x. p x y <=> ~?z. p x z /\\ p z x"]},
5655 QUOTE
"\n(!x y. q x y <=> !z. p z x <=> p z y) ==> !x y. q x y <=> q y x"]},
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"]},
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"]},
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"]},
5677 QUOTE
"\n(!x. f0 a x \\/ !y. f0 x y) ==> ?x. !y. f0 x y"]},
5679 (* ------------------------------------------------------------------------- *)
5680 (* Example from Manthey
and Bry
, CADE
-9. *)
5681 (* ------------------------------------------------------------------------- *)
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"]},
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)"]},
5700 (* ------------------------------------------------------------------------- *)
5701 (* See info
-hol
, circa
1500. *)
5702 (* ------------------------------------------------------------------------- *)
5706 QUOTE
"\n!x. ?v w. !y z. p x /\\ q y ==> (p v \\/ r w) /\\ (r z ==> q v)"]},
5710 QUOTE
"\n(!x. p x <=> ~p (f x)) ==> ?x. p x /\\ ~p (f x)"]},
5714 QUOTE
"\n!x. p x (f x) <=> ?y. (!z. p z y ==> p z (f x)) /\\ p x y"]},
5716 (* ------------------------------------------------------------------------- *)
5717 (* From Gilmore
's classic paper
. *)
5718 (* ------------------------------------------------------------------------- *)
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]
5726 {name
= "GILMORE_1",
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"]},
5733 JRH
: This is not valid
, according to Gilmore
5734 {name
= "GILMORE_2",
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
)`
},
5741 {name
= "GILMORE_3",
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"]},
5747 {name
= "GILMORE_4",
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)"]},
5751 {name
= "GILMORE_5",
5753 QUOTE
"\n(!x. ?y. f x y \\/ f y x) /\\ (!x y. f y x ==> f y y) ==> ?z. f z z"]},
5755 {name
= "GILMORE_6",
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"]},
5762 {name
= "GILMORE_7",
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"]},
5767 {name
= "GILMORE_8",
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"]},
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
)
5779 {name
= "GILMORE_9",
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)"]},
5790 (* ------------------------------------------------------------------------- *)
5791 (* Translation
of Gilmore procedure using separate definitions
. *)
5792 (* ------------------------------------------------------------------------- *)
5794 {name
= "GILMORE_9a",
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)"]},
5800 (* ------------------------------------------------------------------------- *)
5801 (* Example from Davis
-Putnam papers
where Gilmore procedure is poor
. *)
5802 (* ------------------------------------------------------------------------- *)
5804 {name
= "DAVIS_PUTNAM_EXAMPLE",
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)"]},
5808 (* ------------------------------------------------------------------------- *)
5809 (* The interesting example
where connections make the proof longer
. *)
5810 (* ------------------------------------------------------------------------- *)
5812 {name
= "BAD_CONNECTIONS",
5815 QUOTE
"\n~a /\\ (a \\/ b) /\\ (c \\/ d) /\\ (~b \\/ e \\/ f) /\\ (~c \\/ ~e) /\\ (~c \\/ ~f) /\\\n(~b \\/ g \\/ h) /\\ (~d \\/ ~g) /\\ (~d \\/ ~h) ==> F"]},
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 (* ------------------------------------------------------------------------- *)
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"]},
5829 (* ------------------------------------------------------------------------- *)
5830 (* The steamroller
. *)
5831 (* ------------------------------------------------------------------------- *)
5833 {name
= "STEAM_ROLLER",
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"]},
5849 (* ------------------------------------------------------------------------- *)
5850 (* An incestuous example used to establish completeness characterization
. *)
5851 (* ------------------------------------------------------------------------- *)
5853 {name
= "MODEL_COMPLETENESS",
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))"]}
5867 (* ========================================================================= *)
5868 (* Problems
with equality
. *)
5869 (* ========================================================================= *)
5873 (* ------------------------------------------------------------------------- *)
5874 (* Trivia (some
of which demonstrate ex
-bugs
in the prover
). *)
5875 (* ------------------------------------------------------------------------- *)
5877 {name
= "REFLEXIVITY",
5883 QUOTE
"\n!x y. x = y ==> y = x"]},
5885 {name
= "TRANSITIVITY",
5887 QUOTE
"\n!x y z. x = y /\\ y = z ==> x = z"]},
5889 {name
= "TRANS_SYMM",
5891 QUOTE
"\n!x y z. x = y /\\ y = z ==> z = x"]},
5893 {name
= "SUBSTITUTIVITY",
5895 QUOTE
"\n!x y. f x /\\ x = y ==> f y"]},
5897 {name
= "CYCLIC_SUBSTITUTION_BUG",
5899 QUOTE
"\n(!x. y = g (c x)) ==> ?z. y = g z"]},
5901 (* ------------------------------------------------------------------------- *)
5902 (* Simple equality problems
. *)
5903 (* ------------------------------------------------------------------------- *)
5907 QUOTE
"\n(a = b \\/ c = d) /\\ (a = c \\/ b = d) ==> a = d \\/ b = c"]},
5911 QUOTE
"\n(?x y. !z. z = x \\/ z = y) /\\ p a /\\ p b /\\ ~(a = b) ==> !x. p x"]},
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"]},
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"]},
5923 (* ------------------------------------------------------------------------- *)
5924 (* The Melham problem after an inverse skolemization step
. *)
5925 (* ------------------------------------------------------------------------- *)
5927 {name
= "UNSKOLEMIZED_MELHAM",
5929 QUOTE
"\n(!x y. g x = g y ==> f x = f y) ==> !y. ?w. !x. y = g x ==> w = f x"]},
5931 (* ------------------------------------------------------------------------- *)
5932 (* The example always given for congruence closure
. *)
5933 (* ------------------------------------------------------------------------- *)
5935 {name
= "CONGRUENCE_CLOSURE_EXAMPLE",
5937 QUOTE
"\n!x. f (f (f (f (f x)))) = x /\\ f (f (f x)) = x ==> f x = x"]},
5939 (* ------------------------------------------------------------------------- *)
5940 (* A simple
example (see EWD1266a
and the application to Morley
's theorem
). *)
5941 (* ------------------------------------------------------------------------- *)
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"]},
5950 QUOTE
"\n(!x. f (f x) = f x) /\\ (!x. ?y. f y = x) ==> !x. f x = x"]},
5952 (* ------------------------------------------------------------------------- *)
5953 (* Wishnu Prasetya
's example
. *)
5954 (* ------------------------------------------------------------------------- *)
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'"]},
5961 (* ------------------------------------------------------------------------- *)
5962 (* An equality version
of the Agatha puzzle
. *)
5963 (* ------------------------------------------------------------------------- *)
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"]},
5978 (* ------------------------------------------------------------------------- *)
5979 (* Group theory examples
. *)
5980 (* ------------------------------------------------------------------------- *)
5982 (* JRH
: (Size
18, 61814 seconds
.) *)
5983 {name
= "GROUP_RIGHT_INVERSE",
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"]},
5988 {name
= "GROUP_RIGHT_IDENTITY",
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"]},
5993 {name
= "KLEIN_GROUP_COMMUTATIVE",
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"]}
6000 (* ========================================================================= *)
6001 (* Some sample problems from the TPTP archive
. *)
6002 (* Note
: for brevity some relation
/function names have been shortened
. *)
6003 (* ========================================================================= *)
6007 (* ------------------------------------------------------------------------- *)
6008 (* TPTP problems that have demonstrated bugs
in the prover
. *)
6009 (* ------------------------------------------------------------------------- *)
6011 (* Solved trivially by meson without cache cutting
, but not
with. *)
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"]},
6027 (* ------------------------------------------------------------------------- *)
6028 (* Problems used by the fol unit test to exercise the TPTP parser
. *)
6029 (* ------------------------------------------------------------------------- *)
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"]},
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"]},
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"]},
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"]},
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"]},
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"]},
6111 (* ------------------------------------------------------------------------- *)
6112 (* Small problems that are tricky to prove
. *)
6113 (* ------------------------------------------------------------------------- *)
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"]},
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"]},
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"]},
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"]},
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"]},
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"]},
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"]},
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"]},
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"]},
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"]},
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"]},
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"]},
6244 {name
= "GRP128-4.003",
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"]},
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"]}
6276 (* ========================================================================= *)
6277 (* A FEW SAMPLE THEOREMS TO CHECK LARGE RUNS
*)
6278 (* ========================================================================= *)
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",
6294 * extract equality
"TRANS_SYMM",
6295 * extract equality
"CYCLIC_SUBSTITUTION_BUG",
6296 * extract equality
"P48"];
6299 (*#line
0.0 "src/Meter1.sig"*)
6300 (* ========================================================================= *)
6301 (* METERING TIME AND INFERENCES
*)
6302 (* Created by Joe Hurd
, November
2001 *)
6303 (* ========================================================================= *)
6308 type 'a pp
= 'a Useful
.pp
6311 type limit
= {time
: real option
, infs
: int option
}
6312 val unlimited
: limit
6314 val limit_to_string
: limit
-> string
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
6323 (* Meters record time
and inferences
*)
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
6333 (*#line
0.0 "src/Meter1.sml"*)
6334 (* ========================================================================= *)
6335 (* METERING TIME AND INFERENCES
*)
6336 (* Created by Joe Hurd
, November
2001 *)
6337 (* ========================================================================= *)
6341 ["Useful", "Mosml", "Term1", "Thm1", "Canon1", "Match1"];
6346 structure Meter1
:> Meter1
=
6351 infix |
-> ::> @
> oo ##
::* ::@
;
6353 (* ------------------------------------------------------------------------- *)
6355 (* ------------------------------------------------------------------------- *)
6357 type limit
= {time
: real option
, infs
: int option
};
6359 val unlimited
= {time
= NONE
, infs
= NONE
};
6361 val expired
= {time
= SOME
0.0, infs
= SOME
0};
6363 fun limit_to_string
{time
, infs
} =
6365 (case time
of NONE
=> "unlimited"
6366 | SOME r
=> Real.fmt (StringCvt.FIX (SOME
3)) r ^
"s") ^
6368 (case infs
of NONE
=> "unlimited" | SOME i
=> int_to_string i
) ^
6371 (* ------------------------------------------------------------------------- *)
6372 (* Meter readings
. *)
6373 (* ------------------------------------------------------------------------- *)
6375 type meter_reading
= {time
: real, infs
: int};
6377 val zero_reading
= {time
= 0.0, infs
= 0};
6379 fun add_readings
{time
: real, infs
} {time
= time
', infs
= infs
'} =
6380 {time
= time
+ time
', infs
= infs
+ infs
'};
6382 fun pp_meter_reading pp
{time
, infs
} =
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
6405 fun meter_reading_to_string r
=
6406 PP
.pp_to_string (!LINE_LENGTH
) pp_meter_reading r
;
6408 (* ------------------------------------------------------------------------- *)
6409 (* Meters record time
and inferences
. *)
6410 (* ------------------------------------------------------------------------- *)
6412 type meter
= {read
: unit
-> meter_reading
, log
: (int -> unit
), lim
: limit
};
6414 fun new_time_meter () =
6416 val tmr
= Timer
.startCPUTimer ()
6418 (fn {usr
, sys
, ...} => Time
.toReal (Time
.+ (usr
, sys
)))
6419 (Timer
.checkCPUTimer tmr
)
6424 fun new_inference_meter () =
6429 (read
, fn n
=> infs
:= !infs
+ n
)
6432 fun new_meter lim
: meter
=
6434 val tread
= new_time_meter ()
6435 val (iread
, ilog
) = new_inference_meter ()
6437 {read
= (fn () => {time
= tread (), infs
= iread ()}),
6438 log
= ilog
, lim
= lim
}
6441 fun sub_meter
{read
, log
, lim
= _
} lim
=
6443 val {time
= init_time
: real, infs
= init_infs
} = read ()
6444 fun sub
{time
, infs
} = {time
= time
- init_time
, infs
= infs
- init_infs
}
6446 {read
= sub
o read
, log
= log
, lim
= lim
}
6449 val read_meter
= fn ({read
, ...} : meter
) => read ();
6451 val check_meter
= fn ({read
, lim
= {time
, infs
}, ...} : meter
) =>
6453 val {time
= t
, infs
= i
} = read ()
6455 (case time
of NONE
=> true | SOME time
=> t
< time
) andalso
6456 (case infs
of NONE
=> true | SOME infs
=> i
< infs
)
6459 val record_infs
= fn ({log
, ...} : meter
) => log
;
6461 val pp_meter
= pp_map read_meter pp_meter_reading
;
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 (* ========================================================================= *)
6473 type 'a pp
= 'a Useful
.pp
6474 type 'a stream
= 'a Stream
.stream
6475 type formula
= Term1
.formula
6477 type limit
= Meter1
.limit
6478 type meter
= Meter1
.meter
6479 type meter_reading
= Meter1
.meter_reading
6480 type units
= Units1
.units
6482 (* The
type of a generic solver
*)
6484 type solver
= formula list
-> thm list option stream
6486 val contradiction_solver
: thm
-> solver
6488 (* Filters to cut off searching or drop subsumed solutions
*)
6490 val solved_filter
: solver
-> solver
6491 val subsumed_filter
: solver
-> solver
6493 (* User
-friendly interface to generic solvers
*)
6495 val solve
: solver
-> formula list
-> thm list list
6496 val find
: solver
-> formula list
-> thm list option
6497 val refute
: solver
-> thm option
6499 (* Solver nodes must construct themselves from the following 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
*)
6507 (* Solver nodes also incorporate a name
. *)
6509 type node_data
= {name
: string, solver_con
: form
-> solver
}
6512 val mk_solver_node
: node_data
-> solver_node
6513 val pp_solver_node
: solver_node pp
6515 (* At each step we schedule a time slice to the least cost solver node
. *)
6517 val SLICE
: limit ref
6519 type cost_fn
= meter_reading
-> real
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
*)
6526 (* This allows us to hierarchically arrange solver nodes
. *)
6528 val combine
: (cost_fn
* solver_node
) list
-> solver_node
6530 (* Overriding the
'natural
' set
of support from the problem
. *)
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
6540 (* Initializing a solver node makes it ready for action
. *)
6542 type init_data
= {limit
: limit
, thms
: thm list
, hyps
: thm list
}
6544 val initialize
: solver_node
-> init_data
-> solver
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 (* ========================================================================= *)
6555 ["Useful", "Mosml", "Term1", "Thm1", "Canon1", "Match1", "Meter1", "Units1",
6561 structure Solver1
:> Solver1
=
6564 open Useful Term1 Match1 Thm1 Meter1
;
6566 infix |
-> ::> @
> oo ##
;
6568 structure S
= Stream
;
6569 structure U
= Units1
;
6571 type 'a stream
= 'a S
.stream
;
6572 type units
= U
.units
;
6574 val |
<>|
= Subst1
.|
<>|
;
6575 val op ::> = Subst1
.::>;
6577 (* ------------------------------------------------------------------------- *)
6579 (* ------------------------------------------------------------------------- *)
6581 val () = traces
:= {module
= "Solver1", alignment
= K
1} :: !traces
;
6583 fun chat l m
= trace
{module
= "Solver1", message
= m
, level
= l
};
6585 (* ------------------------------------------------------------------------- *)
6586 (* Helper functions
. *)
6587 (* ------------------------------------------------------------------------- *)
6590 S
.fold (fn x
=> fn xs
=> S
.CONS (x
, if f x
then K S
.NIL
else xs
)) S
.NIL
;
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
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";
6602 val name_to_string
= str
o hd
o explode
;
6604 fun option_case n _ NONE
= n
6605 | option_case _
s (SOME _
) = s
;
6607 (* ------------------------------------------------------------------------- *)
6608 (* The
type of a generic solver
. *)
6609 (* ------------------------------------------------------------------------- *)
6611 type solver
= formula list
-> thm list option stream
;
6614 fun contr th
[False
] = [th
]
6615 | contr th gs
= map (C CONTR th
) gs
;
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
));
6622 (* ------------------------------------------------------------------------- *)
6623 (* Filters to cut off searching or drop subsumed solutions
. *)
6624 (* ------------------------------------------------------------------------- *)
6627 fun concl
[] = False
6629 | concl _
= raise BUG
"concl" "not a literal";
6631 fun solved_filter solver goals
=
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
)
6637 drop_after
final (solver goals
)
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
=
6650 val fms
= distinctivize (List.mapPartial (total dest_unit
) ths
)
6652 if non
null (Subsume1
.subsumed s fms
) then (NONE
, s
)
6653 else (SOME (SOME ths
), Subsume1
.add (fms |
-> ()) s
)
6655 handle ERR_EXN _
=> raise BUG
"advance" "shouldn't fail";
6657 fun subsumed_filter s g
= S
.partial_maps advance Subsume1
.empty (s g
);
6660 (* ------------------------------------------------------------------------- *)
6661 (* User
-friendly interface to generic solvers
*)
6662 (* ------------------------------------------------------------------------- *)
6664 fun raw_solve s
= S
.partial_map I
o (subsumed_filter (solved_filter s
));
6666 fun solve s
= S
.to_list
o (raw_solve s
);
6668 fun find s
= (fn S
.NIL
=> NONE | S
.CONS (x
, _
) => SOME x
) o raw_solve s
;
6670 fun refute s
= Option
.map
unwrap (find s
[False
]);
6672 (* ------------------------------------------------------------------------- *)
6673 (* Solver nodes must construct themselves from the following form
. *)
6674 (* ------------------------------------------------------------------------- *)
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
*)
6682 (* ------------------------------------------------------------------------- *)
6683 (* Solver nodes also incorporate a name
. *)
6684 (* ------------------------------------------------------------------------- *)
6686 type node_data
= {name
: string, solver_con
: form
-> solver
};
6688 datatype solver_node
=
6689 Solver_node
of {name
: string, initial
: string, solver_con
: form
-> solver
};
6691 fun mk_solver_node
{name
, solver_con
} =
6693 {name
= name
, initial
= (str
o hd
o explode
) name
, solver_con
= solver_con
};
6695 val pp_solver_node
= pp_map (fn Solver_node
{name
, ...} => name
) pp_string
;
6697 (* ------------------------------------------------------------------------- *)
6698 (* At each step we schedule a time slice to the least cost solver node
. *)
6699 (* ------------------------------------------------------------------------- *)
6701 val SLICE
: limit ref
= ref
{time
= SOME (1.0 / 3.0), infs
= NONE
};
6703 type cost_fn
= Meter1
.meter_reading
-> real;
6706 fun sq x
: real = x
* x
;
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
);
6714 (* ------------------------------------------------------------------------- *)
6715 (* This allows us to hierarchically arrange solver nodes
. *)
6716 (* ------------------------------------------------------------------------- *)
6719 fun name (Solver_node
{name
, ...}) = name
;
6720 fun initial (Solver_node
{initial
, ...}) = initial
;
6722 | seq
f (h
:: t
) = foldl (fn (n
, s
) => s ^
"," ^ f n
) (f h
) t
;
6724 fun combine_names csolvers
= "[" ^
seq (name
o snd
) csolvers ^
"]";
6725 fun combine_initials csolvers
= "[" ^
seq (initial
o snd
) csolvers ^
"]";
6728 datatype subnode
= Subnode
of
6730 used
: meter_reading
,
6731 cost
: meter_reading
-> real,
6732 solns
: (unit
-> thm list option stream
) option
};
6734 fun init_subnode (cost
, (name
, solver
: solver
)) goal
=
6737 used
= zero_reading
,
6739 solns
= SOME (fn () => solver goal
)};
6741 fun least_cost
[] = K NONE
6743 (SOME
o snd
o min (fn (r
, _
) => fn (s
, _
) => r
<= s
) o
6744 map (fn (n
, Subnode
{used
, cost
, ...}) => (cost used
, n
)))
6746 val choose_subnode
=
6748 List.filter (fn (_
, Subnode
{solns
, ...}) => Option
.isSome solns
) o
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 _
=> "");
6757 | seq
f (h
:: t
) = foldl (fn (n
, s
) => s ^
"--" ^ f n
) (f h
) t
;
6759 fun status_info subnodes units
=
6760 "[" ^ seq subnode_info subnodes ^
"]--u=" ^ U
.info units ^
"--";
6763 fun schedule check read stat
=
6766 (chat
2 (stat nodes
);
6767 if not (check ()) then
6768 (chat
1 "?\n"; S
.CONS (NONE
, fn () => sched nodes
))
6770 case choose_subnode nodes
of NONE
=> (chat
1 "!\n"; S
.NIL
)
6773 val Subnode
{name
, used
, solns
, cost
} = List.nth (nodes
, n
)
6774 val () = chat
1 name
6775 val seq
= (Option
.valOf solns
) ()
6777 val () = chat
2 ("--t=" ^
time_to_string (#time r
) ^
"\n")
6778 val used
= add_readings used r
6780 case seq
of S
.NIL
=> (NONE
, NONE
) | S
.CONS (a
, r
) => (a
, SOME r
)
6782 Subnode
{name
= name
, used
= used
, cost
= cost
, solns
= solns
}
6783 val nodes
= update_nth (K node
) n nodes
6785 case res
of NONE
=> ()
6786 | SOME _
=> (chat
2 (stat nodes
); chat
1 "$\n")
6788 S
.CONS (res
, fn () => sched nodes
)
6794 fun combine_solvers (n
, i
) csolvers
{slice
, units
, thms
, hyps
} =
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
, ...}) =
6802 solver_con
{slice
= meter
, units
= units
, thms
= thms
, hyps
= hyps
})
6803 val cnodes
= map (I ## f
) csolvers
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
)
6809 fn goal
=> schedule check read
stat (map (C init_subnode goal
) cnodes
)
6812 fun combine csolvers
=
6814 val n
= combine_names csolvers
6815 val i
= combine_initials csolvers
6818 {name
= n
, initial
= i
, solver_con
= combine_solvers (n
, i
) csolvers
}
6821 (* ------------------------------------------------------------------------- *)
6822 (* Overriding the
'natural
' set
of support from the problem
. *)
6823 (* ------------------------------------------------------------------------- *)
6825 fun sos_solver_con filt name solver_con
{slice
, units
, thms
, hyps
} =
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
)
6832 solver_con
{slice
= slice
, units
= units
, thms
= thms
', hyps
= hyps
'}
6835 fun set_of_support
filt (Solver_node
{name
, initial
, solver_con
}) =
6836 let val name
' = "!" ^ name
6839 {name
= name
', initial
= initial
,
6840 solver_con
= sos_solver_con filt name
' solver_con
}
6843 val everything
: thm
-> bool = K
true;
6845 val one_negative
= (fn x
=> null x
orelse List.exists negative x
) o clause
;
6847 val one_positive
= (fn x
=> null x
orelse List.exists positive x
) o clause
;
6849 val all_negative
= List.all negative
o clause
;
6851 val all_positive
= List.all positive
o clause
;
6853 val nothing
: thm
-> bool = K
false;
6855 (* ------------------------------------------------------------------------- *)
6856 (* Initializing a solver node makes it ready for action
. *)
6857 (* ------------------------------------------------------------------------- *)
6859 type init_data
= {limit
: limit
, thms
: thm list
, hyps
: thm list
}
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
6866 val meter
= ref (new_meter expired
)
6867 val units
= ref U
.empty
6869 solver_con
{slice
= meter
, units
= units
, thms
= thms
, hyps
= hyps
}
6872 let val () = meter
:= new_meter limit
6873 in drop_after (fn _
=> not (check_meter (!meter
))) (solver g
)
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 (* ========================================================================= *)
6888 type solver_node
= Solver1
.solver_node
6890 (* Tuning 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}
6899 val defaults
: parameters
6901 (* The meson solver
*)
6902 val meson
' : parameters
-> solver_node
6903 val meson
: solver_node (* Uses defaults
*)
6905 (* The delta preprocessor
as a solver
*)
6906 val delta
' : parameters
-> solver_node
6907 val delta
: solver_node (* Uses defaults
*)
6909 (* The prolog solver
*)
6910 val prolog
' : parameters
-> solver_node
6911 val prolog
: solver_node (* Uses defaults
*)
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 (* ========================================================================= *)
6923 ["Useful", "Stream", "Mosml", "Term1", "Thm1", "Canon1", "Match1",
6924 "Solver1", "Meter1", "Units1"];
6929 structure Meson1
:> Meson1
=
6932 open Useful Term1 Match1 Thm1 Canon1 Meter1 Solver1
;
6934 infix |
-> ::> @
> oo ##
;
6936 structure S
= Stream
;
6937 structure N
= LiteralNet1
;
6938 structure U
= Units1
;
6940 val |
<>|
= Subst1
.|
<>|
;
6941 val op ::> = Subst1
.::>;
6942 val formula_subst
= Subst1
.formula_subst
;
6944 (* ------------------------------------------------------------------------- *)
6946 (* ------------------------------------------------------------------------- *)
6948 val () = traces
:= {module
= "Meson1", alignment
= K
1} :: !traces
;
6950 fun chat l m
= trace
{module
= "Meson1", message
= m
, level
= l
};
6952 (* ------------------------------------------------------------------------- *)
6953 (* Tuning parameters
. *)
6954 (* ------------------------------------------------------------------------- *)
6957 {ancestor_pruning
: bool,
6958 ancestor_cutting
: bool,
6959 state_simplify
: bool,
6960 cache_cutting
: bool,
6961 divide_conquer
: bool,
6962 unit_lemmaizing
: bool};
6965 {ancestor_pruning
= true,
6966 ancestor_cutting
= true,
6967 state_simplify
= true,
6968 cache_cutting
= true,
6969 divide_conquer
= true,
6970 unit_lemmaizing
= true};
6972 (* ------------------------------------------------------------------------- *)
6973 (* Helper functions
. *)
6974 (* ------------------------------------------------------------------------- *)
6976 fun halves n
= let val n1
= n
div 2 in (n1
, n
- n1
) end;
6978 fun splittable
[] = false
6979 | splittable
[_
] = false
6980 | splittable _
= true;
6986 val y
= f x
handle e
as ERR_EXN _
=> (r
:= v
; raise e
)
6996 |
u (CONS (x
, xs
)) = CONS (x
, if p x
then K NIL
else fn () => u (xs ()))
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
;
7010 datatype 'a choice
= CHOICE
of unit
-> 'a
* 'a choice
;
7012 fun dest_choice (CHOICE c
) = c
;
7014 val no_choice
= (fn () => raise ERR
"no_choice" "always fails");
7016 fun binary_choice f g
=
7018 let val (a
, c
) = f () in (a
, CHOICE (binary_choice (dest_choice c
) g
)) end
7019 handle ERR_EXN _
=> g ());
7021 fun first_choice
[] = no_choice
7022 | first_choice
[f
] = f
7023 |
first_choice (f
:: fs
) = binary_choice
f (first_choice fs
);
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
;
7031 val (l1
, l
') = split l m
7032 val (l2
, l3
) = split l
' n
7037 fun thm_proves th False
= is_contradiction th
7038 | thm_proves th goal
=
7039 case clause th
of [lit
] => lit
= goal |
[] => true | _
=> false;
7041 fun filter_meter meter
=
7042 S
.filter (fn a
=> Option
.isSome a
orelse not (check_meter (!meter
)));
7044 (* ------------------------------------------------------------------------- *)
7045 (* Compiling the rule set used by meson
. *)
7046 (* ------------------------------------------------------------------------- *)
7048 type rule
= {asms
: formula list
, c
: formula
, thm
: thm
, asmn
: int};
7050 datatype rules
= Rules
of rule N
.literal_map
;
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
;
7062 (pp_map (fn {asms
, c
, ...} => (asms
, c
))
7063 (pp_binop
" ==>" (pp_list pp_formula
) pp_formula
)));
7065 fun add_contrapositives chosen sos
th (Rules ruls
) =
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
}
7074 Rules (foldl (fn (h
, t
) => N
.insert (f h
) t
) ruls contrs
)
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
7082 val meson_rules
= thms_to_rules I
;
7084 val prolog_rules
= thms_to_rules (wrap
o hd
);
7086 (* ------------------------------------------------------------------------- *)
7087 (* Creating the delta goals
. *)
7088 (* ------------------------------------------------------------------------- *)
7090 val thms_to_delta_goals
=
7092 map (fn (f
,n
) => [Atom (Fn (f
,new_vars n
)), Not (Atom (Fn (f
,new_vars n
)))]) o
7093 foldl (uncurry union
) [] o
7098 (* ------------------------------------------------------------------------- *)
7099 (* The state passed around by meson
. *)
7100 (* ------------------------------------------------------------------------- *)
7102 type state
= {env
: subst
, depth
: int, proof
: thm list
, offset
: int};
7104 fun update_env
f ({env
, depth
, proof
, offset
} : state
) =
7105 {env
= f env
, depth
= depth
, proof
= proof
, offset
= offset
};
7107 fun update_depth
f ({env
, depth
, proof
, offset
} : state
) =
7108 {env
= env
, depth
= f depth
, proof
= proof
, offset
= offset
};
7110 fun update_proof
f ({env
, depth
, proof
, offset
} : state
) =
7111 {env
= env
, depth
= depth
, proof
= f proof
, offset
= offset
};
7113 fun update_offset
f ({env
, depth
, proof
, offset
} : state
) =
7114 {env
= env
, depth
= depth
, proof
= proof
, offset
= f offset
};
7116 (* ------------------------------------------------------------------------- *)
7117 (* Ancestor pruning
. *)
7118 (* ------------------------------------------------------------------------- *)
7120 fun ancestor_prune
false _ _
= K
false
7121 | ancestor_prune
true env g
=
7123 val g
' = formula_subst env g
7124 fun check a
' = a
' = g
'
7126 List.exists (check
o formula_subst env
)
7129 (* ------------------------------------------------------------------------- *)
7130 (* Ancestor cutting
. *)
7131 (* ------------------------------------------------------------------------- *)
7133 fun ancestor_cut
false _ _
= K
false
7134 | ancestor_cut
true env g
=
7136 val g
' = negate (formula_subst env g
)
7137 fun check a
' = a
' = g
'
7139 List.exists (check
o formula_subst env
)
7142 (* ------------------------------------------------------------------------- *)
7143 (* Cache cutting
. *)
7144 (* ------------------------------------------------------------------------- *)
7146 fun cache_cont
c ({offset
, ...} : state
) =
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
) []
7151 fun purify (s
as {env
, depth
= n
, ...} : state
) =
7154 fun p (n
', l
') = n
<= n
' andalso l
= l
'
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
)
7163 fun cache_cut
false = I
7165 fn f
=> fn a
=> fn g
=> fn c
=> fn s
=> f a
g (cache_cont c s
) s
;
7167 (* ------------------------------------------------------------------------- *)
7168 (* Unit clause shortcut
. *)
7169 (* ------------------------------------------------------------------------- *)
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";
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
)
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
;
7185 (* ------------------------------------------------------------------------- *)
7186 (* The core
of meson
: ancestor unification or Prolog
-style extension
. *)
7187 (* ------------------------------------------------------------------------- *)
7189 fun freshen_rule ({thm
, asms
, c
, ...} : rule
) i
=
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
)
7196 ((INST sub thm
, map (formula_subst sub
) asms
, formula_subst sub c
), i
+ fvn
)
7199 fun reward r
= update_depth (fn n
=> n
+ r
);
7201 fun spend m f
c (s
as {depth
= n
, ...} : state
) =
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"
7212 fun unify
env (th
, asms
, c
) g
= (th
, asms
, unify_literals env c g
)
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
)
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
;
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"
7229 fun modus_ponens th
gs (state
as {env
, ...}) =
7230 update_proof (mp
env (INST env th
) (rev gs
)) state
;
7233 fun swivelp m n
= update_proof (swivel m n
);
7235 fun meson_expand
{parm
: parameters
, rules
, cut
, meter
, saturated
} =
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
))
7246 (*val () = print ("meson: " ^ formula_to_string g ^
".\n")*)
7247 fun reduction
a () =
7249 val state
= update_env (K (unify_literals env
g (negate a
))) state
7250 val state
= update_proof (cons (ASSUME g
)) state
7252 (record_infs (!meter
) 1; cont state
)
7254 val expansion
= expand_rule ancestors g cont state
7257 (map reduction ancestors @
7258 map
expansion (rules_unify
rules (formula_subst env g
))) ()
7260 and expand_rule ancestors g cont
{env
, depth
, proof
, offset
} r () =
7262 val depth
= depth
- #asmn r
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
7270 expands (g
:: ancestors
) asms (cont
o modus_ponens th asms
)
7271 {env
= env
, depth
= depth
, proof
= proof
, offset
= offset
}
7273 and expands ancestors g
c (s
as {depth
= n
, ...}) =
7274 if #divide_conquer parm
andalso splittable g
then
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
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
) ()
7286 else foldl (uncurry (cut expand ancestors
)) c (rev g
) s
7291 (* ------------------------------------------------------------------------- *)
7292 (* Full meson procedure
. *)
7293 (* ------------------------------------------------------------------------- *)
7295 fun meson_finally
g ({env
, proof
, ...} : state
) =
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")*)
7302 assert (List.all (uncurry thm_proves
) (zip proof
' g
'))
7303 (BUG
"meson" "did not prove goal list")
7305 (SOME (FRESH_VARSL proof
'), CHOICE no_choice
)
7308 fun raw_meson system goals depth
=
7311 foldl (uncurry (meson_expand system
)) (meson_finally goals
) (rev goals
)
7312 {env
= |
<>|
, depth
= depth
, proof
= [], offset
= 0});
7314 (* ------------------------------------------------------------------------- *)
7316 (* ------------------------------------------------------------------------- *)
7319 {parm
: parameters
, rules
: rules
, meter
: meter ref
, saturated
: bool ref
,
7321 (formula list
-> formula
-> (state
-> 'a
) -> state
-> 'a
) ->
7322 formula list
-> formula
-> (state
-> 'a
) -> state
-> 'a
};
7324 fun mk_system parm units meter rules
: 'a system
=
7326 val {cache_cutting
= caching
, unit_lemmaizing
= lemmaizing
, ...} = parm
7331 saturated
= ref
false,
7332 cut
= unit_cut lemmaizing units
o cache_cut caching
}
7339 fn {slice
, units
, thms
, hyps
} =>
7341 val ruls
= meson_rules thms hyps
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
7354 (S
.map (unit_check goals
) (S
.flatten (S
.map (f goals
) (d
0))))
7357 val meson
= meson
' defaults
;
7363 fn {slice
, units
, thms
, hyps
} =>
7365 val ruls
= meson_rules thms hyps
7366 val dgoals
= thms_to_delta_goals hyps
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
7380 case delta_goals
of S
.NIL
=> K S
.NIL
7381 | _
=> fn goals
=> filter_meter
slice (S
.map (unit_check goals
) (h ()))
7384 val delta
= delta
' defaults
;
7386 val prolog_depth
= case Int.maxInt
of NONE
=> 1000000 | SOME i
=> i
;
7392 fn {slice
, units
, thms
, hyps
} =>
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
7400 fn goals
=> S
.map_thk
f (fn () => raw_meson system goals prolog_depth
) ()
7403 val prolog
= prolog
' defaults
;
7408 val time
= Mosml
.time
;
7411 installPP pp_formula
;
7412 installPP Subst1
.pp_subst
;
7416 val limit
: limit ref
= ref
{infs
= NONE
, time
= SOME
30.0};
7417 fun prolog_solve d q
=
7420 (initialize prolog
{limit
= !limit
, thms
= d
, hyps
= []})) q
;
7423 (initialize (set_of_support all_negative meson
)
7424 {limit
= !limit
, thms
= [], hyps
= axiomatize (Not (generalize g
))});
7427 (initialize (set_of_support all_negative delta
)
7428 {limit
= !limit
, thms
= [], hyps
= eq_axiomatize (Not (generalize g
))});
7430 (* Testing the delta prover
*)
7432 val p48
= parse_formula (get equality
"P48");
7435 (* Testing the prolog solver
*)
7437 val database
= (axiomatize
o parse_formula
)
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))"];
7442 try (prolog_solve database
) [parse_formula
[QUOTE
"subset x (0 :: 1 :: 2 :: nil)"]];
7444 try (prolog_solve database
) [parse_formula `
subset (0 :: 1 :: 2 :: nil
) x`
];
7447 val database
= (axiomatize
o parse_formula
)
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)"];
7453 try (prolog_solve database
) [parse_formula
[QUOTE
"p (s 0) 3"]];
7455 (* Testing the meson prover
*)
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"]);
7465 val p39
= parse_formula (get nonequality
"P39");
7466 clausal (Not (generalize p39
));
7467 axiomatize (Not (generalize p39
));
7470 val num14
= parse_formula (get tptp
"NUM014-1");
7473 val p55
= parse_formula (get nonequality
"P55");
7476 val p26
= parse_formula (get nonequality
"P26");
7477 clausal (Not (generalize p26
));
7480 val los
= parse_formula (get nonequality
"LOS");
7483 val reduced_num284
= parse_formula
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
;
7493 val p29
= parse_formula (get nonequality
"P29");
7494 clausal (Not (generalize p29
));
7497 val num1
= parse_formula (get tptp
"NUM001-1");
7500 val model_completeness
= parse_formula (get nonequality
"MODEL_COMPLETENESS");
7501 meson_prove model_completeness
;
7505 (*#line
0.0 "src/Resolvers1.sig"*)
7506 (* ========================================================================= *)
7507 (* A TYPE TO FIND RESOLVANT CLAUSES
*)
7508 (* Created by Joe Hurd
, April
2002 *)
7509 (* ========================================================================= *)
7511 signature Resolvers1
=
7514 type 'a pp
= 'a Useful
.pp
7515 type formula
= Term1
.formula
7516 type subst
= Subst1
.subst
7520 type resolvant
= {mate
: thm
, sub
: subst
, res
: thm
}
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
7529 (*#line
0.0 "src/Resolvers1.sml"*)
7530 (* ========================================================================= *)
7531 (* A TYPE TO FIND RESOLVANT CLAUSES
*)
7532 (* Created by Joe Hurd
, April
2002 *)
7533 (* ========================================================================= *)
7536 app load
["Thm1", "Match1"];
7541 structure Resolvers1
:> Resolvers1
=
7546 open Useful Term1 Match1 Thm1 Canon1
;
7548 structure N
= LiteralNet1
;
7550 val |
<>|
= Subst1
.|
<>|
;
7551 val op ::> = Subst1
.::>;
7552 val formula_subst
= Subst1
.formula_subst
;
7554 (* ------------------------------------------------------------------------- *)
7556 (* ------------------------------------------------------------------------- *)
7558 val () = traces
:= {module
= "Resolvers1", alignment
= K
1} :: !traces
;
7560 fun chat l m
= trace
{module
= "Resolvers1", message
= m
, level
= l
};
7562 (* ------------------------------------------------------------------------- *)
7563 (* Helper functions
. *)
7564 (* ------------------------------------------------------------------------- *)
7567 case split l n
of (_
, []) => raise ERR
"trich" "no exact"
7568 |
(l
, h
:: t
) => (l
, h
, t
);
7570 (* ------------------------------------------------------------------------- *)
7571 (* The
type definition
with some simple operations
. *)
7572 (* ------------------------------------------------------------------------- *)
7574 type resolvers
= (int * thm
) N
.literal_map
;
7576 type resolvant
= {mate
: thm
, sub
: subst
, res
: thm
};
7578 val empty_resolvers
: resolvers
= N
.empty
;
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
))
7585 fun resolvers_info (net
: resolvers
) = int_to_string (N
.size net
);
7587 val pp_resolvers
= pp_map resolvers_info pp_string
;
7589 val dest_resolvers
: resolvers
-> thm list
=
7590 map snd
o List.filter (equal
0 o fst
) o N
.to_list
;
7592 (* ------------------------------------------------------------------------- *)
7593 (* A reference implementation for debugging
. *)
7594 (* ------------------------------------------------------------------------- *)
7598 val nvars
= enumerate
0 (FV (list_mk_conj lits
))
7599 val ms
= map (fn (n
, v
) => v |
-> Var ("__" ^
(int_to_string n
))) nvars
7601 map (formula_subst (Subst1
.from_maplets ms
)) lits
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
);
7610 fun all_nonempty_subsets l
= tl (subs
[] [([], l
)]);
7613 fun pairs
[] = raise ERR
"pairs" "empty"
7615 |
pairs (h
:: (t
as h
' :: _
)) = (h
, h
') :: pairs t
;
7617 fun sanity_resolve_on th th
' s s
' =
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
'))
7623 {mate
= th
', sub
= sub
, res
= res
}
7626 fun sanity_resolve th th
' =
7628 (cartwith (total
o sanity_resolve_on th th
')
7629 (all_nonempty_subsets (clause th
))
7630 (all_nonempty_subsets (map
negate (clause th
'))));
7632 fun sanity_resolvants net th
=
7633 List.concat (map (sanity_resolve th
) (dest_resolvers net
));
7635 fun sanity_check net
th (res
: resolvant list
) =
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
)
7642 if subset fast slow
then ()
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!")
7651 if subset slow fast
then ()
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")
7661 (print ("\nsanity_check: ok:\nnet = " ^
7662 f (map
clause (dest_resolvers net
)) ^
"\nth = " ^
7663 thm_to_string th ^
"\nres = " ^ f fast ^
"\n"))
7669 (* ------------------------------------------------------------------------- *)
7670 (* The core engine for combined factor
/resolution steps
. *)
7671 (* ------------------------------------------------------------------------- *)
7673 fun resolve_on s r th th
' =
7674 SOME (FACTOR (RESOLVE
r (INST s th
) (INST s th
')));
7676 fun resolve acc
[] = acc
7677 | resolve
acc ((avoid
, sub
, res
, []) :: others
) =
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
) =
7683 fun f c
= resolve
acc (c ((x
:: avoid
, sub
, res
, xs
) :: others
))
7685 case total (unify_literals sub res
) x
of NONE
=> f I
7687 => f (cons (avoid
, Subst1
.refine sub sub
', formula_subst sub
' res
, xs
))
7690 fun resolve_from (n
, th
) (n
', th
') =
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
')
7698 List.mapPartial
f (resolve
[] [(prev @ prev
', sub
, res
, succ @ succ
')])
7701 fun resolvants net th
=
7703 fun g (_
, mate
) ((sub
, res
), l
) = {mate
= mate
, sub
= sub
, res
= res
} :: l
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
*)
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";
7720 installPP pp_formula
;
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
);
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 (* ========================================================================= *)
7744 type 'a subsume
= 'a Subsume1
.subsume
7747 (* Tuning parameters
*)
7748 type parameters
= {fifo_skew
: int, cleaning_freq
: int}
7749 val defaults
: parameters
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)" *)
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 (* ========================================================================= *)
7770 app load
["Heap", "Queue", "Thm1", "Subsumers1"];
7775 structure Theap1
:> Theap1
=
7780 open Useful Term1 Thm1
;
7782 structure Q
= Queue
;
7784 structure S
= Subsume1
;
7786 type 'a queue
= 'a Q
.queue
;
7787 type 'a heap
= 'a H
.heap
;
7788 type 'a subsume
= 'a S
.subsume
;
7790 (* ------------------------------------------------------------------------- *)
7791 (* Tuning parameters
. *)
7792 (* ------------------------------------------------------------------------- *)
7794 type parameters
= {fifo_skew
: int, cleaning_freq
: int}
7796 val defaults
= {fifo_skew
= 3, cleaning_freq
= 1000};
7798 (* ------------------------------------------------------------------------- *)
7799 (* Theorem HEAPs
. *)
7800 (* ------------------------------------------------------------------------- *)
7803 ((int * int) * (int * int)) * thm queue
* (int * (int * thm
) heap
) *
7806 local fun order ((m
, _
: thm
), (n
, _
: thm
)) = Int.compare (m
, n
);
7807 in val empty_theap_heap
= H
.empty order
;
7810 fun new_theap
{fifo_skew
, cleaning_freq
} =
7811 ((D cleaning_freq
, D fifo_skew
), Q
.empty
, (0, empty_theap_heap
), S
.empty
);
7813 val empty_theap
: theap
= new_theap defaults
;
7815 fun theap_size (_
, _
, (_
, h
), _
) = H
.size h
;
7816 fun theap_weight (_
, _
, (w
, _
), _
) = w
;
7819 fun clean_theap (((_
, C
), F
), Q
, (_
, H
), _
) =
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
)
7827 if Q
.is_empty q
then n
7833 (case total (Polyhash
.remove hash
) (clause th
) of NONE
=> n
7834 | SOME v
=> add (v
, th
) n
)
7837 (fn (q
, w
, h
, l
) => (((C
, C
), F
), q
, (w
, h
), l
))
7838 (check
Q (Q
.empty
, 0, empty_theap_heap
, S
.empty
))
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
) =
7846 val v
= formula_size (list_mk_disj cl
)
7847 val h
' = H
.add (v
, th
) h
7849 (((c
- 1, cm
), f
), Q
.add th q
, (w
+ v
, h
'), S
.add (clause th |
-> th
) l
)
7852 fun theap_addl ths h
= foldl (uncurry theap_add
) h ths
;
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
7860 let val ((v
, x
), h
) = H
.remove h
7861 in SOME (x
, ((c
, (n
- 1, f
)), q
, (w
- v
, h
), l
))
7864 fun theap_subsumers (_
, _
, _
, l
) = l
;
7866 fun theap_info thp
=
7867 "(" ^
int_to_string (theap_size thp
) ^
"," ^
7868 int_to_string (theap_weight thp
) ^
")";
7871 (*#line
0.0 "src/Resolution1.sig"*)
7872 (* ========================================================================= *)
7873 (* THE RESOLUTION PROOF PROCEDURE
*)
7874 (* Created by Joe Hurd
, November
2001 *)
7875 (* ========================================================================= *)
7877 signature Resolution1
=
7880 type solver_node
= Solver1
.solver_node
7882 (* Tuning parameters
*)
7884 {subsumption_checking
: int, (* in the range
0..3 *)
7885 positive_refinement
: bool,
7886 theap_parm
: Theap1
.parameters
}
7888 val defaults
: parameters
7891 val resolution
' : parameters
-> solver_node
7892 val resolution
: solver_node (* Uses defaults
*)
7895 (*#line
0.0 "src/Resolution1.sml"*)
7896 (* ========================================================================= *)
7897 (* THE RESOLUTION PROOF PROCEDURE
*)
7898 (* Created by Joe Hurd
, November
2001 *)
7899 (* ========================================================================= *)
7903 ["Useful", "Mosml", "Term1", "Thm1", "Canon1", "Theap1",
7904 "Stream", "Solver1", "Meter1", "Units1", "Resolvers1"];
7909 structure Resolution1
:> Resolution1
=
7912 open Useful Term1 Thm1 Canon1 Meter1 Solver1 Resolvers1 Theap1
;
7914 infix |
-> ::> @
> oo ##
::* ::@
;
7916 structure S
= Stream
;
7917 structure U
= Units1
;
7919 type 'a subsume
= 'a Subsume1
.subsume
;
7921 (* ------------------------------------------------------------------------- *)
7923 (* ------------------------------------------------------------------------- *)
7925 val () = traces
:= {module
= "Resolution1", alignment
= K
1} :: !traces
;
7927 fun chat l m
= trace
{module
= "Resolution1", message
= m
, level
= l
};
7929 (* ------------------------------------------------------------------------- *)
7930 (* Tuning parameters
. *)
7931 (* ------------------------------------------------------------------------- *)
7934 {subsumption_checking
: int, (* in the range
0..3 *)
7935 positive_refinement
: bool,
7936 theap_parm
: Theap1
.parameters
}
7939 {subsumption_checking
= 1,
7940 positive_refinement
= true,
7941 theap_parm
= Theap1
.defaults
};
7943 (* ------------------------------------------------------------------------- *)
7944 (* Clause stores
. *)
7945 (* ------------------------------------------------------------------------- *)
7947 type store
= thm subsume
* resolvers
;
7949 val empty_store
: store
= (Subsume1
.empty
, empty_resolvers
);
7951 fun store_add
th (s
, r
) =
7952 (Subsume1
.add (clause th |
-> th
) s
, add_resolver th r
);
7954 fun store_resolvants ((_
, r
) : store
) = find_resolvants r
;
7956 fun store_subsumed ((s
, _
) : store
) = Subsume1
.subsumed s
o clause
;
7958 fun store_info (s
, r
) = "(" ^ Subsume1
.info s ^
"," ^ resolvers_info r ^
")";
7960 (* ------------------------------------------------------------------------- *)
7961 (* Positive refinement
. *)
7962 (* ------------------------------------------------------------------------- *)
7965 val pos_th
= List.all positive
o clause
;
7967 fun check
true = K
true
7968 | check
false = fn ({mate
, ...} : resolvant
) => pos_th mate
;
7970 fun positive_check
false = K (K
true)
7971 | positive_check
true = check
o pos_th
;
7974 (* ------------------------------------------------------------------------- *)
7975 (* Full resolution procedure
. *)
7976 (* ------------------------------------------------------------------------- *)
7978 exception Contradiction
of thm
;
7980 fun unit_strengthen units th
=
7981 (case first (U
.subsumes units
) (clause th
) of SOME th
=> th
7982 | NONE
=> U
.demod units th
);
7984 fun subsumption_check store th
=
7985 case store_subsumed store th
of [] => SOME th | _
:: _
=> NONE
;
7987 fun theap_strengthen theap th
=
7988 (case Subsume1
.strictly_subsumed (theap_subsumers theap
) (clause th
) of []
7990 |
(_
, th
) :: _
=> th
);
7992 fun resolve (parm
: parameters
) =
7995 int_to_string k ^
(if k
= r
then "" else "/" ^ int_to_string r
)
7997 fun L n
= n
<= #subsumption_checking parm
7998 val pos_filt
= Option
.filter
o positive_check (#positive_refinement parm
)
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
8005 fun next_candidate u f s w
=
8006 case theap_remove w
of NONE
=> NONE
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
))
8012 fun retention_test u f s th
=
8014 (Option
.mapPartial (ftest (L
3) f
o stest (L
3) s
o upass u
o #res
) o
8018 if is_contradiction th
then raise Contradiction th
else U
.add th
8020 fn record
=> fn (facts
, used
, unused
) => fn units
=>
8021 (case next_candidate units facts used unused
of NONE
=> NONE
8022 |
SOME (th
, unused
) =>
8024 val units
= check_add th units
8025 val used
= store_add th used
8026 val th
= FRESH_VARS th
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
8035 SOME ((facts
, used
, unused
), units
)
8037 handle ERR_EXN _
=> raise BUG
"resolve" "shouldn't fail"
8040 fun raw_resolution parm
=
8042 {name
= "resolution",
8044 fn {slice
, units
, thms
, hyps
} =>
8046 val resolve
' = resolve parm
8047 fun run wrap state
=
8048 if not (check_meter (!slice
)) then S
.CONS (NONE
, wrap state
)
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
))
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")
8065 fn goals
=> wrapper
goals (facts
, used
, unused
) ()
8068 fun resolution
' parm
=
8069 (if #positive_refinement parm
then set_of_support everything
else I
)
8070 (raw_resolution parm
);
8072 val resolution
= resolution
' defaults
;
8077 val time
= Mosml
.time
;
8080 installPP pp_formula
;
8081 installPP Subst1
.pp_subst
;
8084 (* Testing the resolution prover
*)
8086 val limit
: limit ref
= ref
{infs
= NONE
, time
= SOME
30.0};
8087 fun resolution_prove g
=
8089 (initialize (set_of_support all_negative resolution
)
8090 {limit
= !limit
, thms
= [], hyps
= axiomatize (Not (generalize g
))});
8092 axiomatize (Not (generalize True
));
8093 resolution_prove True
;
8095 val prop13
= parse_formula (get nonequality
"PROP_13");
8096 axiomatize (Not (generalize prop13
));
8097 resolution_prove prop13
;
8099 val p33
= parse_formula (get nonequality
"P33");
8100 axiomatize (Not (generalize p33
));
8101 resolution_prove p33
;
8103 val p59
= parse_formula (get nonequality
"P59");
8104 val ths
= axiomatize (Not (generalize p59
));
8105 resolution_prove p59
;
8107 val p39
= parse_formula (get nonequality
"P39");
8108 clausal (Not (generalize p39
));
8109 axiomatize (Not (generalize p39
));
8110 resolution_prove p39
;
8112 val num14
= parse_formula (get tptp
"NUM014-1");
8113 resolution_prove num14
;
8115 val p55
= parse_formula (get nonequality
"P55");
8116 resolution_prove p55
;
8118 val p26
= parse_formula (get nonequality
"P26");
8119 clausal (Not (generalize p26
));
8120 resolution_prove p26
;
8122 val los
= parse_formula (get nonequality
"LOS");
8123 resolution_prove los
;
8125 val reduced_num284
= parse_formula
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
;
8135 val p29
= parse_formula (get nonequality
"P29");
8136 clausal (Not (generalize p29
));
8137 resolution_prove p29
;
8139 val num1
= parse_formula (get tptp
"NUM001-1");
8140 resolution_prove num1
;
8142 val gilmore9
= parse_formula (get nonequality
"GILMORE_9");
8143 axiomatize (Not (generalize gilmore9
));
8144 resolution_prove gilmore9
;
8146 val model_completeness
= parse_formula (get nonequality
"MODEL_COMPLETENESS");
8147 resolution_prove model_completeness
;
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 (* ========================================================================= *)
8160 type formula
= Term1
.formula
8162 type limit
= Meter1
.limit
8163 type solver
= Solver1
.solver
8164 type solver_node
= Solver1
.solver_node
8166 (* Tuning parameters
*)
8167 type Mparm
= Meson1
.parameters
8168 type Rparm
= Resolution1
.parameters
8174 resolution_parm
: Rparm
}
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
8183 (* The metis combination
of solvers
*)
8184 val metis
' : parameters
-> solver_node
8185 val metis
: solver_node (* Uses defaults
*)
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
*)
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 (* ========================================================================= *)
8203 ["Useful", "Mosml", "Term1", "Thm1", "Canon1",
8204 "Solver1", "Meson1", "Resolution1"];
8209 structure Metis1
:> Metis1
=
8212 open Useful Term1 Thm1 Meter1 Canon1 Solver1 Meson1 Resolution1
;
8214 infix |
-> ::> @
> oo ##
::* ::@
;
8216 (* ------------------------------------------------------------------------- *)
8217 (* Tuning parameters
. *)
8218 (* ------------------------------------------------------------------------- *)
8220 type Mparm
= Meson1
.parameters
;
8221 type Rparm
= Resolution1
.parameters
;
8228 resolution_parm
: Rparm
};
8234 meson_parm
= Meson1
.defaults
,
8235 resolution_parm
= Resolution1
.defaults
};
8237 fun update_parm_meson f parm
=
8239 val {meson
, delta
, resolution
, meson_parm
, resolution_parm
} = parm
8241 {meson
= f meson
, delta
= delta
, resolution
= resolution
,
8242 meson_parm
= meson_parm
, resolution_parm
= resolution_parm
}
8245 fun update_parm_delta f parm
=
8247 val {meson
, delta
, resolution
, meson_parm
, resolution_parm
} = parm
8249 {meson
= meson
, delta
= f delta
, resolution
= resolution
,
8250 meson_parm
= meson_parm
, resolution_parm
= resolution_parm
}
8253 fun update_parm_resolution f parm
=
8255 val {meson
, delta
, resolution
, meson_parm
, resolution_parm
} = parm
8257 {meson
= meson
, delta
= delta
, resolution
= f resolution
,
8258 meson_parm
= meson_parm
, resolution_parm
= resolution_parm
}
8261 fun update_parm_meson_parm f parm
=
8263 val {meson
, delta
, resolution
, meson_parm
, resolution_parm
} = parm
8265 {meson
= meson
, delta
= delta
, resolution
= resolution
,
8266 meson_parm
= f meson_parm
, resolution_parm
= resolution_parm
}
8269 fun update_parm_resolution_parm f parm
=
8271 val {meson
, delta
, resolution
, meson_parm
, resolution_parm
} = parm
8273 {meson
= meson
, delta
= delta
, resolution
= resolution
,
8274 meson_parm
= meson_parm
, resolution_parm
= f resolution_parm
}
8277 (* ------------------------------------------------------------------------- *)
8278 (* The metis combination
of solvers
. *)
8279 (* ------------------------------------------------------------------------- *)
8281 fun metis
' {meson
= m
, delta
= d
, resolution
= r
, meson_parm
, resolution_parm
} =
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
)
8288 val metis
= metis
' defaults
;
8290 (* ------------------------------------------------------------------------- *)
8291 (* A user
-friendly interface
. *)
8292 (* ------------------------------------------------------------------------- *)
8294 val settings
= ref defaults
;
8296 val limit
: limit ref
= ref
{time
= NONE
, infs
= NONE
};
8298 fun raw_prove (Imp (a
, Imp (b
, False
))) =
8300 val (thms
, hyps
) = (axiomatize a
, axiomatize b
)
8301 val solv
= metis
' (!settings
)
8303 refute (initialize solv
{limit
= !limit
, thms
= thms
, hyps
= hyps
})
8305 | raw_prove _
= raise ERR
"raw_prove" "formula not of type a ==> b ==> F";
8309 val hyps
= eq_axiomatize
' (Not (generalize g
))
8310 val solv
= set_of_support
all_negative (metis
' (!settings
))
8312 refute (initialize solv
{limit
= !limit
, thms
= [], hyps
= hyps
})
8315 fun query database
=
8316 initialize prolog
{thms
= axiomatize database
, hyps
= [], limit
= unlimited
};
8319 val time
= Mosml
.time
;
8322 installPP pp_formula
;
8323 installPP Subst1
.pp_subst
;
8326 (* Testing the metis prover
*)
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
));
8334 val p39
= parse_formula
[QUOTE
"~(?x. !y. P(y,x) <=> ~P(y,y))"];
8335 clausal (Not (generalize p39
));
8336 axiomatize (Not (generalize p39
));
8339 val num14
= parse_formula
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"];
8349 val p26
= parse_formula
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
));
8356 val los
= parse_formula
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"];
8362 val puz2
= parse_formula
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"];
8393 val num284
= parse_formula
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"];
8405 val p29
= parse_formula
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
));
8412 val num27
= parse_formula
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"];
8438 val model_completeness
= parse_formula
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
;
8450 val agatha
= parse_formula
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())"];
8465 val boo3
= parse_formula
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"];
8519 val fld5
= parse_formula
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"];
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 (* ========================================================================= *)
8583 (* Loading the modules we use
*)
8594 "Useful", "Term1", "Canon1", "Tptp1", "Metis1", "Problem1"];
8596 (* Infix operators
*)
8598 infixr ## |
-> ::> @
> oo
;
8600 (* Pretty printers
*)
8602 val () = installPP Term1
.pp_term
;
8603 val () = installPP Term1
.pp_formula
;
8604 val () = installPP Subst1
.pp_subst
;
8605 val () = installPP Thm1
.pp_thm
;
8607 (* Parsing quotations
*)
8609 val () = quotation
:= true;
8611 (* Creating nice output
*)
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
[]);
8617 fun advertize s
= print ("==" ^ s ^ chs #
"=" (77 - size s
) ^
"\n\n");
8618 fun separator () = print (chs #
"-" 79 ^
"\n\n");
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
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
8637 fun b2s
true = "on" | b2s
false = "off";
8638 val i2s
= Useful
.int_to_string
;
8639 val l2s
= Meter1
.limit_to_string
;
8641 fun show (settings
: Metis1
.parameters
) =
8643 val {meson
= Mactive
, delta
= Dactive
, resolution
= Ractive
,
8644 meson_parm
= Mparm
, resolution_parm
= Rparm
} = settings
8646 "resolution = " ^ b2s Ractive ^
"\n" ^
8647 "meson = " ^ b2s Mactive ^
"\n" ^
8648 "delta = " ^ b2s Dactive ^
"\n" ^
8650 "resolution_parm:\n" ^
8651 " subsumption_checking = " ^
i2s (#subsumption_checking Rparm
) ^
"\n" ^
8652 " positive_refinement = " ^
b2s (#positive_refinement Rparm
) ^
"\n" ^
8654 " fifo_skew = " ^
i2s (#
fifo_skew (#theap_parm Rparm
)) ^
"\n" ^
8655 " theap_cleaning = " ^
i2s (#
cleaning_freq (#theap_parm Rparm
)) ^
"\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" ^
8665 "limit = " ^
l2s (!Metis1
.limit
) ^
"\n\n"
8669 (* The core proving function
*)
8671 val cnf_normalization
= ref
false;
8673 fun with_cnf b
= Useful
.with_flag (cnf_normalization
, Useful
.K b
);
8677 val prover
= if !cnf_normalization
then Metis1
.prove
else Metis1
.raw_prove
8679 case Useful
.try prover fm
of SOME _
8680 => print
"METIS: SUCCESSFULLY PROVED\nMETIS: "
8681 | NONE
=> print
"METIS: FAILED TO PROVE\nMETIS: "
8684 fun process name goal
=
8685 (print ("METIS: Problem " ^ name ^
"\n");
8686 Milton
.time core_prove goal
;
8689 fun process_set (n
, s
) =
8691 val () = advertize n
8692 fun f
{name
, goal
} = process
name (Term1
.parse_formula goal
)
8695 | p
:: ps
=> (f p
; app (fn x
=> (separator (); f x
)) ps
)
8698 (* Get options from the command line
*)
8703 fun tlimit
"-" = NONE | tlimit s
= SOME (Real.fromInt (string_to_int s
));
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
)
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
);
8726 val l
= (**CommandLine
.arguments ()**) []
8729 split
l (length l
- n
)
8733 val (opts
, work
) = if Milton
.ml
= "MLton" then options () else ([], []);
8734 (*#line
0.0 "data/benchmark.sml"*)
8735 val pure
= null ((**CommandLine
.arguments ()**) []);
8741 if pure
then settings
:= update_parm_meson (K
true) (!settings
) else ();
8745 open Useful Problem1
;
8747 (Option
.valOf
o List.find (fn {name
, goal
= _
} => name
= n
)) p
;
8750 if pure
then ["P29", "LDA007-3", "GRP010-4", "GEO002-4"] else ["GEO002-4"];
8754 val {meson
, resolution
, ...} = !Metis1
.settings
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)
8763 val src0
= ["P26", "P29", "P46", "GILMORE_1", "LOS", "STEAM_ROLLER"];
8765 val src1
= ["P48", "P49", "AGATHA"];
8768 ["LCL009-1", "COL060-3", "COL058-2", "LCL107-1", "LDA007-3",
8769 "GRP010-4", "BOO021-1", "GEO002-4", "GRP128-4.003"];
8771 val set0
= map (extract nonequality
) (prune src0
);
8772 val set1
= map (extract equality
) (prune src1
);
8773 val set2
= map (extract tptp
) (prune src2
);
8776 val program
= "benchmark" ^
(if pure
then "*" else "");
8778 val () = advertize (program ^
"==starting");
8780 val () = advertize
"settings";
8782 val () = print (show (!Metis1
.settings
));
8784 val () = with_cnf
true process_set ("nonequality", set0
);
8786 val () = with_cnf
true process_set ("equality", set1
);
8788 val () = with_cnf
false process_set ("tptp", set2
);
8790 val () = advertize (program ^
"==finishing");
8799 else (main (); doit (n
- 1))