(******************************************************************)
(* GENERATED FILE -- DO NOT EDIT -- GENERATED FILE -- DO NOT EDIT *)
(* GENERATED FILE -- DO NOT EDIT -- GENERATED FILE -- DO NOT EDIT *)
(* GENERATED FILE -- DO NOT EDIT -- GENERATED FILE -- DO NOT EDIT *)
(******************************************************************)
print_depth 0;
structure Metis = struct structure Word = Word structure Array = Array end;
(**** Original file: Portable.sig ****)
(* ========================================================================= *)
(* ML SPECIFIC FUNCTIONS *)
(* Copyright (c) 2001-2007 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Portable =
sig
(* ------------------------------------------------------------------------- *)
(* The ML implementation. *)
(* ------------------------------------------------------------------------- *)
val ml : string
(* ------------------------------------------------------------------------- *)
(* Pointer equality using the run-time system. *)
(* ------------------------------------------------------------------------- *)
val pointerEqual : 'a * 'a -> bool
(* ------------------------------------------------------------------------- *)
(* Timing function applications. *)
(* ------------------------------------------------------------------------- *)
val time : ('a -> 'b) -> 'a -> 'b
(* ------------------------------------------------------------------------- *)
(* Critical section markup (multiprocessing) *)
(* ------------------------------------------------------------------------- *)
val CRITICAL: (unit -> 'a) -> 'a
(* ------------------------------------------------------------------------- *)
(* Generating random values. *)
(* ------------------------------------------------------------------------- *)
val randomBool : unit -> bool
val randomInt : int -> int (* n |-> [0,n) *)
val randomReal : unit -> real (* () |-> [0,1] *)
val randomWord : unit -> Metis.Word.word
end
(**** Original file: PortableIsabelle.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* Isabelle ML SPECIFIC FUNCTIONS *)
(* ========================================================================= *)
structure Portable :> Portable =
struct
(* ------------------------------------------------------------------------- *)
(* The ML implementation. *)
(* ------------------------------------------------------------------------- *)
val ml = ml_system;
(* ------------------------------------------------------------------------- *)
(* Pointer equality using the run-time system. *)
(* ------------------------------------------------------------------------- *)
val pointerEqual = pointer_eq;
(* ------------------------------------------------------------------------- *)
(* Timing function applications a la Mosml.time. *)
(* ------------------------------------------------------------------------- *)
val time = timeap;
(* ------------------------------------------------------------------------- *)
(* Critical section markup (multiprocessing) *)
(* ------------------------------------------------------------------------- *)
fun CRITICAL e = NAMED_CRITICAL "metis" e;
(* ------------------------------------------------------------------------- *)
(* Generating random values. *)
(* ------------------------------------------------------------------------- *)
val randomWord = RandomWord.next_word;
val randomBool = RandomWord.next_bool;
fun randomInt n = RandomWord.next_int 0 (n - 1);
val randomReal = RandomWord.next_real;
end;
(* ------------------------------------------------------------------------- *)
(* Quotations a la Moscow ML. *)
(* ------------------------------------------------------------------------- *)
datatype 'a frag = QUOTE of string | ANTIQUOTE of 'a;
end;
(**** Original file: PP.sig ****)
(* ========================================================================= *)
(* PP -- pretty-printing -- from the SML/NJ library *)
(* *)
(* Modified for Moscow ML from SML/NJ Library version 0.2 *)
(* *)
(* COPYRIGHT (c) 1992 by AT&T Bell Laboratories. *)
(* *)
(* STANDARD ML OF NEW JERSEY COPYRIGHT NOTICE, LICENSE AND DISCLAIMER. *)
(* *)
(* Permission to use, copy, modify, and distribute this software and its *)
(* documentation for any purpose and without fee is hereby granted, *)
(* provided that the above copyright notice appear in all copies and that *)
(* both the copyright notice and this permission notice and warranty *)
(* disclaimer appear in supporting documentation, and that the name of *)
(* AT&T Bell Laboratories or any AT&T entity not be used in advertising *)
(* or publicity pertaining to distribution of the software without *)
(* specific, written prior permission. *)
(* *)
(* AT&T disclaims all warranties with regard to this software, including *)
(* all implied warranties of merchantability and fitness. In no event *)
(* shall AT&T be liable for any special, indirect or consequential *)
(* damages or any damages whatsoever resulting from loss of use, data or *)
(* profits, whether in an action of contract, negligence or other *)
(* tortious action, arising out of or in connection with the use or *)
(* performance of this software. *)
(* ========================================================================= *)
signature PP =
sig
type ppstream
type ppconsumer =
{consumer : string -> unit,
linewidth : int,
flush : unit -> unit}
datatype break_style =
CONSISTENT
| INCONSISTENT
val mk_ppstream : ppconsumer -> ppstream
val dest_ppstream : ppstream -> ppconsumer
val add_break : ppstream -> int * int -> unit
val add_newline : ppstream -> unit
val add_string : ppstream -> string -> unit
val begin_block : ppstream -> break_style -> int -> unit
val end_block : ppstream -> unit
val clear_ppstream : ppstream -> unit
val flush_ppstream : ppstream -> unit
val with_pp : ppconsumer -> (ppstream -> unit) -> unit
val pp_to_string : int -> (ppstream -> 'a -> unit) -> 'a -> string
end
(*
This structure provides tools for creating customized Oppen-style
pretty-printers, based on the type ppstream. A ppstream is an
output stream that contains prettyprinting commands. The commands
are placed in the stream by various function calls listed below.
There following primitives add commands to the stream:
begin_block, end_block, add_string, add_break, and add_newline.
All calls to add_string, add_break, and add_newline must happen
between a pair of calls to begin_block and end_block must be
properly nested dynamically. All calls to begin_block and
end_block must be properly nested (dynamically).
[ppconsumer] is the type of sinks for pretty-printing. A value of
type ppconsumer is a record
{ consumer : string -> unit,
linewidth : int,
flush : unit -> unit }
of a string consumer, a specified linewidth, and a flush function
which is called whenever flush_ppstream is called.
A prettyprinter can be called outright to print a value. In
addition, a prettyprinter for a base type or nullary datatype ty
can be installed in the top-level system. Then the installed
prettyprinter will be invoked automatically whenever a value of
type ty is to be printed.
[break_style] is the type of line break styles for blocks:
[CONSISTENT] specifies that if any line break occurs inside the
block, then all indicated line breaks occur.
[INCONSISTENT] specifies that breaks will be inserted to only to
avoid overfull lines.
[mk_ppstream {consumer, linewidth, flush}] creates a new ppstream
which invokes the consumer to output text, putting at most
linewidth characters on each line.
[dest_ppstream ppstrm] extracts the linewidth, flush function, and
consumer from a ppstream.
[add_break ppstrm (size, offset)] notifies the pretty-printer that
a line break is possible at this point.
* When the current block style is CONSISTENT:
** if the entire block fits on the remainder of the line, then
output size spaces; else
** increase the current indentation by the block offset;
further indent every item of the block by offset, and add
one newline at every add_break in the block.
* When the current block style is INCONSISTENT:
** if the next component of the block fits on the remainder of
the line, then output size spaces; else
** issue a newline and indent to the current indentation level
plus the block offset plus the offset.
[add_newline ppstrm] issues a newline.
[add_string ppstrm str] outputs the string str to the ppstream.
[begin_block ppstrm style blockoffset] begins a new block and
level of indentation, with the given style and block offset.
[end_block ppstrm] closes the current block.
[clear_ppstream ppstrm] restarts the stream, without affecting the
underlying consumer.
[flush_ppstream ppstrm] executes any remaining commands in the
ppstream (that is, flushes currently accumulated output to the
consumer associated with ppstrm); executes the flush function
associated with the consumer; and calls clear_ppstream.
[with_pp consumer f] makes a new ppstream from the consumer and
applies f (which can be thought of as a producer) to that
ppstream, then flushed the ppstream and returns the value of f.
[pp_to_string linewidth printit x] constructs a new ppstream
ppstrm whose consumer accumulates the output in a string s. Then
evaluates (printit ppstrm x) and finally returns the string s.
Example 1: A simple prettyprinter for Booleans:
load "PP";
fun ppbool pps d =
let open PP
in
begin_block pps INCONSISTENT 6;
add_string pps (if d then "right" else "wrong");
end_block pps
end;
Now one may define a ppstream to print to, and exercise it:
val ppstrm = Metis.PP.mk_ppstream {consumer =
fn s => Metis.TextIO.output(Metis.TextIO.stdOut, s),
linewidth = 72,
flush =
fn () => Metis.TextIO.flushOut Metis.TextIO.stdOut};
fun ppb b = (ppbool ppstrm b; Metis.PP.flush_ppstream ppstrm);
- ppb false;
wrong> val it = () : unit
The prettyprinter may also be installed in the toplevel system;
then it will be used to print all expressions of type bool
subsequently computed:
- installPP ppbool;
> val it = () : unit
- 1=0;
> val it = wrong : bool
- 1=1;
> val it = right : bool
See library Meta for a description of installPP.
Example 2: Prettyprinting simple expressions (examples/pretty/Metis.ppexpr.sml):
datatype expr =
Cst of int
| Neg of expr
| Plus of expr * expr
fun ppexpr pps e0 =
let open PP
fun ppe (Cst i) = add_string pps (Metis.Int.toString i)
| ppe (Neg e) = (add_string pps "~"; ppe e)
| ppe (Plus(e1, e2)) = (begin_block pps CONSISTENT 0;
add_string pps "(";
ppe e1;
add_string pps " + ";
add_break pps (0, 1);
ppe e2;
add_string pps ")";
end_block pps)
in
begin_block pps INCONSISTENT 0;
ppe e0;
end_block pps
end
val _ = installPP ppexpr;
(* Some example values: *)
val e1 = Cst 1;
val e2 = Cst 2;
val e3 = Plus(e1, Neg e2);
val e4 = Plus(Neg e3, e3);
val e5 = Plus(Neg e4, e4);
val e6 = Plus(e5, e5);
val e7 = Plus(e6, e6);
val e8 =
Plus(e3, Plus(e3, Plus(e3, Plus(e3, Plus(e3, Plus(e3, e7))))));
*)
(**** Original file: PP.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* PP -- pretty-printing -- from the SML/NJ library *)
(* *)
(* Modified for Moscow ML from SML/NJ Library version 0.2 *)
(* *)
(* COPYRIGHT (c) 1992 by AT&T Bell Laboratories. *)
(* *)
(* STANDARD ML OF NEW JERSEY COPYRIGHT NOTICE, LICENSE AND DISCLAIMER. *)
(* *)
(* Permission to use, copy, modify, and distribute this software and its *)
(* documentation for any purpose and without fee is hereby granted, *)
(* provided that the above copyright notice appear in all copies and that *)
(* both the copyright notice and this permission notice and warranty *)
(* disclaimer appear in supporting documentation, and that the name of *)
(* AT&T Bell Laboratories or any AT&T entity not be used in advertising *)
(* or publicity pertaining to distribution of the software without *)
(* specific, written prior permission. *)
(* *)
(* AT&T disclaims all warranties with regard to this software, including *)
(* all implied warranties of merchantability and fitness. In no event *)
(* shall AT&T be liable for any special, indirect or consequential *)
(* damages or any damages whatsoever resulting from loss of use, data or *)
(* profits, whether in an action of contract, negligence or other *)
(* tortious action, arising out of or in connection with the use or *)
(* performance of this software. *)
(* ========================================================================= *)
structure PP :> PP =
struct
open Array
infix 9 sub
(* the queue library, formerly in unit Ppqueue *)
datatype Qend = Qback | Qfront
exception QUEUE_FULL
exception QUEUE_EMPTY
exception REQUESTED_QUEUE_SIZE_TOO_SMALL
local
fun ++ i n = (i + 1) mod n
fun -- i n = (i - 1) mod n
in
abstype 'a queue = QUEUE of {elems: 'a array, (* the contents *)
front: int Unsynchronized.ref,
back: int Unsynchronized.ref,
size: int} (* fixed size of element array *)
with
fun is_empty (QUEUE{front=Unsynchronized.ref ~1, back=Unsynchronized.ref ~1,...}) = true
| is_empty _ = false
fun mk_queue n init_val =
if (n < 2)
then raise REQUESTED_QUEUE_SIZE_TOO_SMALL
else QUEUE{elems=array(n, init_val), front=Unsynchronized.ref ~1, back=Unsynchronized.ref ~1, size=n}
fun clear_queue (QUEUE{front,back,...}) = (front := ~1; back := ~1)
fun queue_at Qfront (QUEUE{elems,front,...}) = elems sub !front
| queue_at Qback (QUEUE{elems,back,...}) = elems sub !back
fun en_queue Qfront item (Q as QUEUE{elems,front,back,size}) =
if (is_empty Q)
then (front := 0; back := 0;
update(elems,0,item))
else let val i = --(!front) size
in if (i = !back)
then raise QUEUE_FULL
else (update(elems,i,item); front := i)
end
| en_queue Qback item (Q as QUEUE{elems,front,back,size}) =
if (is_empty Q)
then (front := 0; back := 0;
update(elems,0,item))
else let val i = ++(!back) size
in if (i = !front)
then raise QUEUE_FULL
else (update(elems,i,item); back := i)
end
fun de_queue Qfront (Q as QUEUE{front,back,size,...}) =
if (!front = !back) (* unitary queue *)
then clear_queue Q
else front := ++(!front) size
| de_queue Qback (Q as QUEUE{front,back,size,...}) =
if (!front = !back)
then clear_queue Q
else back := --(!back) size
end (* abstype queue *)
end (* local *)
val magic: 'a -> 'a = fn x => x
(* exception PP_FAIL of string *)
datatype break_style = CONSISTENT | INCONSISTENT
datatype break_info
= FITS
| PACK_ONTO_LINE of int
| ONE_PER_LINE of int
(* Some global values *)
val INFINITY = 999999
abstype indent_stack = Istack of break_info list Unsynchronized.ref
with
fun mk_indent_stack() = Istack (Unsynchronized.ref([]:break_info list))
fun clear_indent_stack (Istack stk) = (stk := ([]:break_info list))
fun top (Istack stk) =
case !stk
of nil => raise Fail "PP-error: top: badly formed block"
| x::_ => x
fun push (x,(Istack stk)) = stk := x::(!stk)
fun pop (Istack stk) =
case !stk
of nil => raise Fail "PP-error: pop: badly formed block"
| _::rest => stk := rest
end
(* The delim_stack is used to compute the size of blocks. It is
a stack of indices into the token buffer. The indices only point to
BBs, Es, and BRs. We push BBs and Es onto the stack until a BR
is encountered. Then we compute sizes and pop. When we encounter
a BR in the middle of a block, we compute the Distance_to_next_break
of the previous BR in the block, if there was one.
We need to be able to delete from the bottom of the delim_stack, so
we use a queue, treated with a stack discipline, i.e., we only add
items at the head of the queue, but can delete from the front or
back of the queue.
*)
abstype delim_stack = Dstack of int queue
with
fun new_delim_stack i = Dstack(mk_queue i ~1)
fun reset_delim_stack (Dstack q) = clear_queue q
fun pop_delim_stack (Dstack d) = de_queue Qfront d
fun pop_bottom_delim_stack (Dstack d) = de_queue Qback d
fun push_delim_stack(i,Dstack d) = en_queue Qfront i d
fun top_delim_stack (Dstack d) = queue_at Qfront d
fun bottom_delim_stack (Dstack d) = queue_at Qback d
fun delim_stack_is_empty (Dstack d) = is_empty d
end
type block_info = { Block_size : int Unsynchronized.ref,
Block_offset : int,
How_to_indent : break_style }
(* Distance_to_next_break includes Number_of_blanks. Break_offset is
a local offset for the break. BB represents a sequence of contiguous
Begins. E represents a sequence of contiguous Ends.
*)
datatype pp_token
= S of {String : string, Length : int}
| BB of {Pblocks : block_info list Unsynchronized.ref, (* Processed *)
Ublocks : block_info list Unsynchronized.ref} (* Unprocessed *)
| E of {Pend : int Unsynchronized.ref, Uend : int Unsynchronized.ref}
| BR of {Distance_to_next_break : int Unsynchronized.ref,
Number_of_blanks : int,
Break_offset : int}
(* The initial values in the token buffer *)
val initial_token_value = S{String = "", Length = 0}
(* type ppstream = General.ppstream; *)
datatype ppstream_ =
PPS of
{consumer : string -> unit,
linewidth : int,
flush : unit -> unit,
the_token_buffer : pp_token array,
the_delim_stack : delim_stack,
the_indent_stack : indent_stack,
++ : int Unsynchronized.ref -> unit, (* increment circular buffer index *)
space_left : int Unsynchronized.ref, (* remaining columns on page *)
left_index : int Unsynchronized.ref, (* insertion index *)
right_index : int Unsynchronized.ref, (* output index *)
left_sum : int Unsynchronized.ref, (* size of strings and spaces inserted *)
right_sum : int Unsynchronized.ref} (* size of strings and spaces printed *)
type ppstream = ppstream_
type ppconsumer = {consumer : string -> unit,
linewidth : int,
flush : unit -> unit}
fun mk_ppstream {consumer,linewidth,flush} =
if (linewidth<5)
then raise Fail "PP-error: linewidth too_small"
else let val buf_size = 3*linewidth
in magic(
PPS{consumer = consumer,
linewidth = linewidth,
flush = flush,
the_token_buffer = array(buf_size, initial_token_value),
the_delim_stack = new_delim_stack buf_size,
the_indent_stack = mk_indent_stack (),
++ = fn i => i := ((!i + 1) mod buf_size),
space_left = Unsynchronized.ref linewidth,
left_index = Unsynchronized.ref 0, right_index = Unsynchronized.ref 0,
left_sum = Unsynchronized.ref 0, right_sum = Unsynchronized.ref 0}
) : ppstream
end
fun dest_ppstream(pps : ppstream) =
let val PPS{consumer,linewidth,flush, ...} = magic pps
in {consumer=consumer,linewidth=linewidth,flush=flush} end
local
val space = " "
fun mk_space (0,s) = String.concat s
| mk_space (n,s) = mk_space((n-1), (space::s))
val space_table = Vector.tabulate(100, fn i => mk_space(i,[]))
fun nspaces n = Vector.sub(space_table, n)
handle General.Subscript =>
if n < 0
then ""
else let val n2 = n div 2
val n2_spaces = nspaces n2
val extra = if (n = (2*n2)) then "" else space
in String.concat [n2_spaces, n2_spaces, extra]
end
in
fun cr_indent (ofn, i) = ofn ("\n"^(nspaces i))
fun indent (ofn,i) = ofn (nspaces i)
end
(* Print a the first member of a contiguous sequence of Begins. If there
are "processed" Begins, then take the first off the list. If there are
no processed Begins, take the last member off the "unprocessed" list.
This works because the unprocessed list is treated as a stack, the
processed list as a FIFO queue. How can an item on the unprocessed list
be printable? Because of what goes on in add_string. See there for details.
*)
fun print_BB (_,{Pblocks = Unsynchronized.ref [], Ublocks = Unsynchronized.ref []}) =
raise Fail "PP-error: print_BB"
| print_BB (PPS{the_indent_stack,linewidth,space_left=Unsynchronized.ref sp_left,...},
{Pblocks as Unsynchronized.ref({How_to_indent=CONSISTENT,Block_size,
Block_offset}::rst),
Ublocks=Unsynchronized.ref[]}) =
(push ((if (!Block_size > sp_left)
then ONE_PER_LINE (linewidth - (sp_left - Block_offset))
else FITS),
the_indent_stack);
Pblocks := rst)
| print_BB(PPS{the_indent_stack,linewidth,space_left=Unsynchronized.ref sp_left,...},
{Pblocks as Unsynchronized.ref({Block_size,Block_offset,...}::rst),Ublocks=Unsynchronized.ref[]}) =
(push ((if (!Block_size > sp_left)
then PACK_ONTO_LINE (linewidth - (sp_left - Block_offset))
else FITS),
the_indent_stack);
Pblocks := rst)
| print_BB (PPS{the_indent_stack, linewidth, space_left=Unsynchronized.ref sp_left,...},
{Ublocks,...}) =
let fun pr_end_Ublock [{How_to_indent=CONSISTENT,Block_size,Block_offset}] l =
(push ((if (!Block_size > sp_left)
then ONE_PER_LINE (linewidth - (sp_left - Block_offset))
else FITS),
the_indent_stack);
List.rev l)
| pr_end_Ublock [{Block_size,Block_offset,...}] l =
(push ((if (!Block_size > sp_left)
then PACK_ONTO_LINE (linewidth - (sp_left - Block_offset))
else FITS),
the_indent_stack);
List.rev l)
| pr_end_Ublock (a::rst) l = pr_end_Ublock rst (a::l)
| pr_end_Ublock _ _ =
raise Fail "PP-error: print_BB: internal error"
in Ublocks := pr_end_Ublock(!Ublocks) []
end
(* Uend should always be 0 when print_E is called. *)
fun print_E (_,{Pend = Unsynchronized.ref 0, Uend = Unsynchronized.ref 0}) =
raise Fail "PP-error: print_E"
| print_E (istack,{Pend, ...}) =
let fun pop_n_times 0 = ()
| pop_n_times n = (pop istack; pop_n_times(n-1))
in pop_n_times(!Pend); Pend := 0
end
(* "cursor" is how many spaces across the page we are. *)
fun print_token(PPS{consumer,space_left,...}, S{String,Length}) =
(consumer String;
space_left := (!space_left) - Length)
| print_token(ppstrm,BB b) = print_BB(ppstrm,b)
| print_token(PPS{the_indent_stack,...},E e) =
print_E (the_indent_stack,e)
| print_token (PPS{the_indent_stack,space_left,consumer,linewidth,...},
BR{Distance_to_next_break,Number_of_blanks,Break_offset}) =
(case (top the_indent_stack)
of FITS =>
(space_left := (!space_left) - Number_of_blanks;
indent (consumer,Number_of_blanks))
| (ONE_PER_LINE cursor) =>
let val new_cursor = cursor + Break_offset
in space_left := linewidth - new_cursor;
cr_indent (consumer,new_cursor)
end
| (PACK_ONTO_LINE cursor) =>
if (!Distance_to_next_break > (!space_left))
then let val new_cursor = cursor + Break_offset
in space_left := linewidth - new_cursor;
cr_indent(consumer,new_cursor)
end
else (space_left := !space_left - Number_of_blanks;
indent (consumer,Number_of_blanks)))
fun clear_ppstream(pps : ppstream) =
let val PPS{the_token_buffer, the_delim_stack,
the_indent_stack,left_sum, right_sum,
left_index, right_index,space_left,linewidth,...}
= magic pps
val buf_size = 3*linewidth
fun set i =
if (i = buf_size)
then ()
else (update(the_token_buffer,i,initial_token_value);
set (i+1))
in set 0;
clear_indent_stack the_indent_stack;
reset_delim_stack the_delim_stack;
left_sum := 0; right_sum := 0;
left_index := 0; right_index := 0;
space_left := linewidth
end
(* Move insertion head to right unless adding a BB and already at a BB,
or unless adding an E and already at an E.
*)
fun BB_inc_right_index(PPS{the_token_buffer, right_index, ++,...})=
case (the_token_buffer sub (!right_index))
of (BB _) => ()
| _ => ++right_index
fun E_inc_right_index(PPS{the_token_buffer,right_index, ++,...})=
case (the_token_buffer sub (!right_index))
of (E _) => ()
| _ => ++right_index
fun pointers_coincide(PPS{left_index,right_index,the_token_buffer,...}) =
(!left_index = !right_index) andalso
(case (the_token_buffer sub (!left_index))
of (BB {Pblocks = Unsynchronized.ref [], Ublocks = Unsynchronized.ref []}) => true
| (BB _) => false
| (E {Pend = Unsynchronized.ref 0, Uend = Unsynchronized.ref 0}) => true
| (E _) => false
| _ => true)
fun advance_left (ppstrm as PPS{consumer,left_index,left_sum,
the_token_buffer,++,...},
instr) =
let val NEG = ~1
val POS = 0
fun inc_left_sum (BR{Number_of_blanks, ...}) =
left_sum := (!left_sum) + Number_of_blanks
| inc_left_sum (S{Length, ...}) = left_sum := (!left_sum) + Length
| inc_left_sum _ = ()
fun last_size [{Block_size, ...}:block_info] = !Block_size
| last_size (_::rst) = last_size rst
| last_size _ = raise Fail "PP-error: last_size: internal error"
fun token_size (S{Length, ...}) = Length
| token_size (BB b) =
(case b
of {Pblocks = Unsynchronized.ref [], Ublocks = Unsynchronized.ref []} =>
raise Fail "PP-error: BB_size"
| {Pblocks as Unsynchronized.ref(_::_),Ublocks=Unsynchronized.ref[]} => POS
| {Ublocks, ...} => last_size (!Ublocks))
| token_size (E{Pend = Unsynchronized.ref 0, Uend = Unsynchronized.ref 0}) =
raise Fail "PP-error: token_size.E"
| token_size (E{Pend = Unsynchronized.ref 0, ...}) = NEG
| token_size (E _) = POS
| token_size (BR {Distance_to_next_break, ...}) = !Distance_to_next_break
fun loop (instr) =
if (token_size instr < 0) (* synchronization point; cannot advance *)
then ()
else (print_token(ppstrm,instr);
inc_left_sum instr;
if (pointers_coincide ppstrm)
then ()
else (* increment left index *)
(* When this is evaluated, we know that the left_index has not yet
caught up to the right_index. If we are at a BB or an E, we can
increment left_index if there is no work to be done, i.e., all Begins
or Ends have been dealt with. Also, we should do some housekeeping and
clear the buffer at left_index, otherwise we can get errors when
left_index catches up to right_index and we reset the indices to 0.
(We might find ourselves adding a BB to an "old" BB, with the result
that the index is not pushed onto the delim_stack. This can lead to
mangled output.)
*)
(case (the_token_buffer sub (!left_index))
of (BB {Pblocks = Unsynchronized.ref [], Ublocks = Unsynchronized.ref []}) =>
(update(the_token_buffer,!left_index,
initial_token_value);
++left_index)
| (BB _) => ()
| (E {Pend = Unsynchronized.ref 0, Uend = Unsynchronized.ref 0}) =>
(update(the_token_buffer,!left_index,
initial_token_value);
++left_index)
| (E _) => ()
| _ => ++left_index;
loop (the_token_buffer sub (!left_index))))
in loop instr
end
fun begin_block (pps : ppstream) style offset =
let val ppstrm = magic pps : ppstream_
val PPS{the_token_buffer, the_delim_stack,left_index,
left_sum, right_index, right_sum,...}
= ppstrm
in
(if (delim_stack_is_empty the_delim_stack)
then (left_index := 0;
left_sum := 1;
right_index := 0;
right_sum := 1)
else BB_inc_right_index ppstrm;
case (the_token_buffer sub (!right_index))
of (BB {Ublocks, ...}) =>
Ublocks := {Block_size = Unsynchronized.ref (~(!right_sum)),
Block_offset = offset,
How_to_indent = style}::(!Ublocks)
| _ => (update(the_token_buffer, !right_index,
BB{Pblocks = Unsynchronized.ref [],
Ublocks = Unsynchronized.ref [{Block_size = Unsynchronized.ref (~(!right_sum)),
Block_offset = offset,
How_to_indent = style}]});
push_delim_stack (!right_index, the_delim_stack)))
end
fun end_block(pps : ppstream) =
let val ppstrm = magic pps : ppstream_
val PPS{the_token_buffer,the_delim_stack,right_index,...}
= ppstrm
in
if (delim_stack_is_empty the_delim_stack)
then print_token(ppstrm,(E{Pend = Unsynchronized.ref 1, Uend = Unsynchronized.ref 0}))
else (E_inc_right_index ppstrm;
case (the_token_buffer sub (!right_index))
of (E{Uend, ...}) => Uend := !Uend + 1
| _ => (update(the_token_buffer,!right_index,
E{Uend = Unsynchronized.ref 1, Pend = Unsynchronized.ref 0});
push_delim_stack (!right_index, the_delim_stack)))
end
local
fun check_delim_stack(PPS{the_token_buffer,the_delim_stack,right_sum,...}) =
let fun check k =
if (delim_stack_is_empty the_delim_stack)
then ()
else case(the_token_buffer sub (top_delim_stack the_delim_stack))
of (BB{Ublocks as Unsynchronized.ref ((b as {Block_size, ...})::rst),
Pblocks}) =>
if (k>0)
then (Block_size := !right_sum + !Block_size;
Pblocks := b :: (!Pblocks);
Ublocks := rst;
if (List.length rst = 0)
then pop_delim_stack the_delim_stack
else ();
check(k-1))
else ()
| (E{Pend,Uend}) =>
(Pend := (!Pend) + (!Uend);
Uend := 0;
pop_delim_stack the_delim_stack;
check(k + !Pend))
| (BR{Distance_to_next_break, ...}) =>
(Distance_to_next_break :=
!right_sum + !Distance_to_next_break;
pop_delim_stack the_delim_stack;
if (k>0)
then check k
else ())
| _ => raise Fail "PP-error: check_delim_stack.catchall"
in check 0
end
in
fun add_break (pps : ppstream) (n, break_offset) =
let val ppstrm = magic pps : ppstream_
val PPS{the_token_buffer,the_delim_stack,left_index,
right_index,left_sum,right_sum, ++, ...}
= ppstrm
in
(if (delim_stack_is_empty the_delim_stack)
then (left_index := 0; right_index := 0;
left_sum := 1; right_sum := 1)
else ++right_index;
update(the_token_buffer, !right_index,
BR{Distance_to_next_break = Unsynchronized.ref (~(!right_sum)),
Number_of_blanks = n,
Break_offset = break_offset});
check_delim_stack ppstrm;
right_sum := (!right_sum) + n;
push_delim_stack (!right_index,the_delim_stack))
end
fun flush_ppstream0(pps : ppstream) =
let val ppstrm = magic pps : ppstream_
val PPS{the_delim_stack,the_token_buffer, flush, left_index,...}
= ppstrm
in
(if (delim_stack_is_empty the_delim_stack)
then ()
else (check_delim_stack ppstrm;
advance_left(ppstrm, the_token_buffer sub (!left_index)));
flush())
end
end (* local *)
fun flush_ppstream ppstrm =
(flush_ppstream0 ppstrm;
clear_ppstream ppstrm)
fun add_string (pps : ppstream) s =
let val ppstrm = magic pps : ppstream_
val PPS{the_token_buffer,the_delim_stack,consumer,
right_index,right_sum,left_sum,
left_index,space_left,++,...}
= ppstrm
fun fnl [{Block_size, ...}:block_info] = Block_size := INFINITY
| fnl (_::rst) = fnl rst
| fnl _ = raise Fail "PP-error: fnl: internal error"
fun set(dstack,BB{Ublocks as Unsynchronized.ref[{Block_size,...}:block_info],...}) =
(pop_bottom_delim_stack dstack;
Block_size := INFINITY)
| set (_,BB {Ublocks = Unsynchronized.ref(_::rst), ...}) = fnl rst
| set (dstack, E{Pend,Uend}) =
(Pend := (!Pend) + (!Uend);
Uend := 0;
pop_bottom_delim_stack dstack)
| set (dstack,BR{Distance_to_next_break,...}) =
(pop_bottom_delim_stack dstack;
Distance_to_next_break := INFINITY)
| set _ = raise (Fail "PP-error: add_string.set")
fun check_stream () =
if ((!right_sum - !left_sum) > !space_left)
then if (delim_stack_is_empty the_delim_stack)
then ()
else let val i = bottom_delim_stack the_delim_stack
in if (!left_index = i)
then set (the_delim_stack, the_token_buffer sub i)
else ();
advance_left(ppstrm,
the_token_buffer sub (!left_index));
if (pointers_coincide ppstrm)
then ()
else check_stream ()
end
else ()
val slen = String.size s
val S_token = S{String = s, Length = slen}
in if (delim_stack_is_empty the_delim_stack)
then print_token(ppstrm,S_token)
else (++right_index;
update(the_token_buffer, !right_index, S_token);
right_sum := (!right_sum)+slen;
check_stream ())
end
(* Derived form. The +2 is for peace of mind *)
fun add_newline (pps : ppstream) =
let val PPS{linewidth, ...} = magic pps
in add_break pps (linewidth+2,0) end
(* Derived form. Builds a ppstream, sends pretty printing commands called in
f to the ppstream, then flushes ppstream.
*)
fun with_pp ppconsumer ppfn =
let val ppstrm = mk_ppstream ppconsumer
in ppfn ppstrm;
flush_ppstream0 ppstrm
end
handle Fail msg =>
(TextIO.print (">>>> Pretty-printer failure: " ^ msg ^ "\n"))
fun pp_to_string linewidth ppfn ob =
let val l = Unsynchronized.ref ([]:string list)
fun attach s = l := (s::(!l))
in with_pp {consumer = attach, linewidth=linewidth, flush = fn()=>()}
(fn ppstrm => ppfn ppstrm ob);
String.concat(List.rev(!l))
end
end
end;
(**** Original file: Useful.sig ****)
(* ========================================================================= *)
(* ML UTILITY FUNCTIONS *)
(* Copyright (c) 2001-2005 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Useful =
sig
(* ------------------------------------------------------------------------- *)
(* Exceptions. *)
(* ------------------------------------------------------------------------- *)
exception Error of string
exception Bug of string
val partial : exn -> ('a -> 'b option) -> 'a -> 'b
val total : ('a -> 'b) -> 'a -> 'b option
val can : ('a -> 'b) -> 'a -> bool
(* ------------------------------------------------------------------------- *)
(* Tracing. *)
(* ------------------------------------------------------------------------- *)
val tracePrint : (string -> unit) Unsynchronized.ref
val trace : string -> unit
(* ------------------------------------------------------------------------- *)
(* Combinators. *)
(* ------------------------------------------------------------------------- *)
val C : ('a -> 'b -> 'c) -> 'b -> 'a -> 'c
val I : 'a -> 'a
val K : 'a -> 'b -> 'a
val S : ('a -> 'b -> 'c) -> ('a -> 'b) -> 'a -> 'c
val W : ('a -> 'a -> 'b) -> 'a -> 'b
val funpow : int -> ('a -> 'a) -> 'a -> 'a
val exp : ('a * 'a -> 'a) -> 'a -> int -> 'a -> 'a
val equal : ''a -> ''a -> bool
val notEqual : ''a -> ''a -> bool
(* ------------------------------------------------------------------------- *)
(* Pairs. *)
(* ------------------------------------------------------------------------- *)
val fst : 'a * 'b -> 'a
val snd : 'a * 'b -> 'b
val pair : 'a -> 'b -> 'a * 'b
val swap : 'a * 'b -> 'b * 'a
val curry : ('a * 'b -> 'c) -> 'a -> 'b -> 'c
val uncurry : ('a -> 'b -> 'c) -> 'a * 'b -> 'c
val ## : ('a -> 'c) * ('b -> 'd) -> 'a * 'b -> 'c * 'd
(* ------------------------------------------------------------------------- *)
(* State transformers. *)
(* ------------------------------------------------------------------------- *)
val unit : 'a -> 's -> 'a * 's
val bind : ('s -> 'a * 's) -> ('a -> 's -> 'b * 's) -> 's -> 'b * 's
val mmap : ('a -> 'b) -> ('s -> 'a * 's) -> 's -> 'b * 's
val mjoin : ('s -> ('s -> 'a * 's) * 's) -> 's -> 'a * 's
val mwhile : ('a -> bool) -> ('a -> 's -> 'a * 's) -> 'a -> 's -> 'a * 's
(* ------------------------------------------------------------------------- *)
(* Lists: note we count elements from 0. *)
(* ------------------------------------------------------------------------- *)
val cons : 'a -> 'a list -> 'a list
val hdTl : 'a list -> 'a * 'a list
val append : 'a list -> 'a list -> 'a list
val singleton : 'a -> 'a list
val first : ('a -> 'b option) -> 'a list -> 'b option
val index : ('a -> bool) -> 'a list -> int option
val maps : ('a -> 's -> 'b * 's) -> 'a list -> 's -> 'b list * 's
val mapsPartial : ('a -> 's -> 'b option * 's) -> 'a list -> 's -> 'b list * 's
val enumerate : 'a list -> (int * 'a) list
val zipwith : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
val zip : 'a list -> 'b list -> ('a * 'b) list
val unzip : ('a * 'b) list -> 'a list * 'b list
val cartwith : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
val cart : 'a list -> 'b list -> ('a * 'b) list
val divide : 'a list -> int -> 'a list * 'a list (* Subscript *)
val revDivide : 'a list -> int -> 'a list * 'a list (* Subscript *)
val updateNth : int * 'a -> 'a list -> 'a list (* Subscript *)
val deleteNth : int -> 'a list -> 'a list (* Subscript *)
(* ------------------------------------------------------------------------- *)
(* Sets implemented with lists. *)
(* ------------------------------------------------------------------------- *)
val mem : ''a -> ''a list -> bool
val insert : ''a -> ''a list -> ''a list
val delete : ''a -> ''a list -> ''a list
val setify : ''a list -> ''a list (* removes duplicates *)
val union : ''a list -> ''a list -> ''a list
val intersect : ''a list -> ''a list -> ''a list
val difference : ''a list -> ''a list -> ''a list
val subset : ''a list -> ''a list -> bool
val distinct : ''a list -> bool
(* ------------------------------------------------------------------------- *)
(* Comparisons. *)
(* ------------------------------------------------------------------------- *)
val mapCompare : ('a -> 'b) -> ('b * 'b -> order) -> 'a * 'a -> order
val revCompare : ('a * 'a -> order) -> 'a * 'a -> order
val prodCompare :
('a * 'a -> order) -> ('b * 'b -> order) -> ('a * 'b) * ('a * 'b) -> order
val lexCompare : ('a * 'a -> order) -> 'a list * 'a list -> order
val optionCompare : ('a * 'a -> order) -> 'a option * 'a option -> order
val boolCompare : bool * bool -> order (* true < false *)
(* ------------------------------------------------------------------------- *)
(* Sorting and searching. *)
(* ------------------------------------------------------------------------- *)
val minimum : ('a * 'a -> order) -> 'a list -> 'a * 'a list (* Empty *)
val maximum : ('a * 'a -> order) -> 'a list -> 'a * 'a list (* Empty *)
val merge : ('a * 'a -> order) -> 'a list -> 'a list -> 'a list
val sort : ('a * 'a -> order) -> 'a list -> 'a list
val sortMap : ('a -> 'b) -> ('b * 'b -> order) -> 'a list -> 'a list
(* ------------------------------------------------------------------------- *)
(* Integers. *)
(* ------------------------------------------------------------------------- *)
val interval : int -> int -> int list
val divides : int -> int -> bool
val gcd : int -> int -> int
val primes : int -> int list
val primesUpTo : int -> int list
(* ------------------------------------------------------------------------- *)
(* Strings. *)
(* ------------------------------------------------------------------------- *)
val rot : int -> char -> char
val charToInt : char -> int option
val charFromInt : int -> char option
val nChars : char -> int -> string
val chomp : string -> string
val trim : string -> string
val join : string -> string list -> string
val split : string -> string -> string list
val mkPrefix : string -> string -> string
val destPrefix : string -> string -> string
val isPrefix : string -> string -> bool
(* ------------------------------------------------------------------------- *)
(* Tables. *)
(* ------------------------------------------------------------------------- *)
type columnAlignment = {leftAlign : bool, padChar : char}
val alignColumn : columnAlignment -> string list -> string list -> string list
val alignTable : columnAlignment list -> string list list -> string list
(* ------------------------------------------------------------------------- *)
(* Reals. *)
(* ------------------------------------------------------------------------- *)
val percentToString : real -> string
val pos : real -> real
val log2 : real -> real (* Domain *)
(* ------------------------------------------------------------------------- *)
(* Sum datatype. *)
(* ------------------------------------------------------------------------- *)
datatype ('a,'b) sum = Left of 'a | Right of 'b
val destLeft : ('a,'b) sum -> 'a
val isLeft : ('a,'b) sum -> bool
val destRight : ('a,'b) sum -> 'b
val isRight : ('a,'b) sum -> bool
(* ------------------------------------------------------------------------- *)
(* Useful impure features. *)
(* ------------------------------------------------------------------------- *)
val newInt : unit -> int
val newInts : int -> int list
val withRef : 'r Unsynchronized.ref * 'r -> ('a -> 'b) -> 'a -> 'b
val cloneArray : 'a Metis.Array.array -> 'a Metis.Array.array
(* ------------------------------------------------------------------------- *)
(* The environment. *)
(* ------------------------------------------------------------------------- *)
val host : unit -> string
val time : unit -> string
val date : unit -> string
val readTextFile : {filename : string} -> string
val writeTextFile : {filename : string, contents : string} -> unit
(* ------------------------------------------------------------------------- *)
(* Profiling and error reporting. *)
(* ------------------------------------------------------------------------- *)
val try : ('a -> 'b) -> 'a -> 'b
val warn : string -> unit
val die : string -> 'exit
val timed : ('a -> 'b) -> 'a -> real * 'b
val timedMany : ('a -> 'b) -> 'a -> real * 'b
val executionTime : unit -> real (* Wall clock execution time *)
end
(**** Original file: Useful.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* ML UTILITY FUNCTIONS *)
(* Copyright (c) 2001-2004 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Useful :> Useful =
struct
(* ------------------------------------------------------------------------- *)
(* Exceptions *)
(* ------------------------------------------------------------------------- *)
exception Error of string;
exception Bug of string;
fun errorToString (Error message) = "\nError: " ^ message ^ "\n"
| errorToString _ = raise Bug "errorToString: not an Error exception";
fun bugToString (Bug message) = "\nBug: " ^ message ^ "\n"
| bugToString _ = raise Bug "bugToString: not a Bug exception";
fun total f x = SOME (f x) handle Error _ => NONE;
fun can f = Option.isSome o total f;
fun partial (e as Error _) f x = (case f x of SOME y => y | NONE => raise e)
| partial _ _ _ = raise Bug "partial: must take an Error exception";
(* ------------------------------------------------------------------------- *)
(* Tracing *)
(* ------------------------------------------------------------------------- *)
val tracePrint = Unsynchronized.ref print;
fun trace message = !tracePrint message;
(* ------------------------------------------------------------------------- *)
(* Combinators *)
(* ------------------------------------------------------------------------- *)
fun C f x y = f y x;
fun I x = x;
fun K x y = x;
fun S f g x = f x (g x);
fun W f x = f x x;
fun funpow 0 _ x = x
| funpow n f x = funpow (n - 1) f (f x);
fun exp m =
let
fun f _ 0 z = z
| f x y z = f (m (x,x)) (y div 2) (if y mod 2 = 0 then z else m (z,x))
in
f
end;
val equal = fn x => fn y => x = y;
val notEqual = fn x => fn y => x <> y;
(* ------------------------------------------------------------------------- *)
(* Pairs *)
(* ------------------------------------------------------------------------- *)
fun fst (x,_) = x;
fun snd (_,y) = y;
fun pair x y = (x,y);
fun swap (x,y) = (y,x);
fun curry f x y = f (x,y);
fun uncurry f (x,y) = f x y;
val op## = fn (f,g) => fn (x,y) => (f x, g y);
(* ------------------------------------------------------------------------- *)
(* State transformers *)
(* ------------------------------------------------------------------------- *)
val unit : 'a -> 's -> 'a * 's = pair;
fun bind f (g : 'a -> 's -> 'b * 's) = uncurry g o f;
fun mmap f (m : 's -> 'a * 's) = bind m (unit o f);
fun mjoin (f : 's -> ('s -> 'a * 's) * 's) = bind f I;
fun mwhile c b = let fun f a = if c a then bind (b a) f else unit a in f end;
(* ------------------------------------------------------------------------- *)
(* Lists *)
(* ------------------------------------------------------------------------- *)
fun cons x y = x :: y;
fun hdTl l = (hd l, tl l);
fun append xs ys = xs @ ys;
fun singleton a = [a];
fun first f [] = NONE
| first f (x :: xs) = (case f x of NONE => first f xs | s => s);
fun index p =
let
fun idx _ [] = NONE
| idx n (x :: xs) = if p x then SOME n else idx (n + 1) xs
in
idx 0
end;
fun maps (_ : 'a -> 's -> 'b * 's) [] = unit []
| maps f (x :: xs) =
bind (f x) (fn y => bind (maps f xs) (fn ys => unit (y :: ys)));
fun mapsPartial (_ : 'a -> 's -> 'b option * 's) [] = unit []
| mapsPartial f (x :: xs) =
bind
(f x)
(fn yo =>
bind
(mapsPartial f xs)
(fn ys => unit (case yo of NONE => ys | SOME y => y :: ys)));
fun enumerate l = fst (maps (fn x => fn m => ((m, x), m + 1)) l 0);
fun zipwith f =
let
fun z l [] [] = l
| z l (x :: xs) (y :: ys) = z (f x y :: l) xs ys
| z _ _ _ = raise Error "zipwith: lists different lengths";
in
fn xs => fn ys => rev (z [] xs ys)
end;
fun zip xs ys = zipwith pair xs ys;
fun unzip ab =
foldl (fn ((x, y), (xs, ys)) => (x :: xs, y :: ys)) ([], []) (rev ab);
fun cartwith f =
let
fun aux _ res _ [] = res
| aux xsCopy res [] (y :: yt) = aux xsCopy res xsCopy yt
| aux xsCopy res (x :: xt) (ys as y :: _) =
aux xsCopy (f x y :: res) xt ys
in
fn xs => fn ys =>
let val xs' = rev xs in aux xs' [] xs' (rev ys) end
end;
fun cart xs ys = cartwith pair xs ys;
local
fun revDiv acc l 0 = (acc,l)
| revDiv _ [] _ = raise Subscript
| revDiv acc (h :: t) n = revDiv (h :: acc) t (n - 1);
in
fun revDivide l = revDiv [] l;
end;
fun divide l n = let val (a,b) = revDivide l n in (rev a, b) end;
fun updateNth (n,x) l =
let
val (a,b) = revDivide l n
in
case b of [] => raise Subscript | _ :: t => List.revAppend (a, x :: t)
end;
fun deleteNth n l =
let
val (a,b) = revDivide l n
in
case b of [] => raise Subscript | _ :: t => List.revAppend (a,t)
end;
(* ------------------------------------------------------------------------- *)
(* Sets implemented with lists *)
(* ------------------------------------------------------------------------- *)
fun mem x = List.exists (equal x);
fun insert x s = if mem x s then s else x :: s;
fun delete x s = List.filter (not o equal x) s;
fun setify s = rev (foldl (fn (v,x) => if mem v x then x else v :: x) [] s);
fun union s t = foldl (fn (v,x) => if mem v t then x else v :: x) t (rev s);
fun intersect s t =
foldl (fn (v,x) => if mem v t then v :: x else x) [] (rev s);
fun difference s t =
foldl (fn (v,x) => if mem v t then x else v :: x) [] (rev s);
fun subset s t = List.all (fn x => mem x t) s;
fun distinct [] = true
| distinct (x :: rest) = not (mem x rest) andalso distinct rest;
(* ------------------------------------------------------------------------- *)
(* Comparisons. *)
(* ------------------------------------------------------------------------- *)
fun mapCompare f cmp (a,b) = cmp (f a, f b);
fun revCompare cmp x_y =
case cmp x_y of LESS => GREATER | EQUAL => EQUAL | GREATER => LESS;
fun prodCompare xCmp yCmp ((x1,y1),(x2,y2)) =
case xCmp (x1,x2) of
LESS => LESS
| EQUAL => yCmp (y1,y2)
| GREATER => GREATER;
fun lexCompare cmp =
let
fun lex ([],[]) = EQUAL
| lex ([], _ :: _) = LESS
| lex (_ :: _, []) = GREATER
| lex (x :: xs, y :: ys) =
case cmp (x,y) of
LESS => LESS
| EQUAL => lex (xs,ys)
| GREATER => GREATER
in
lex
end;
fun optionCompare _ (NONE,NONE) = EQUAL
| optionCompare _ (NONE,_) = LESS
| optionCompare _ (_,NONE) = GREATER
| optionCompare cmp (SOME x, SOME y) = cmp (x,y);
fun boolCompare (true,false) = LESS
| boolCompare (false,true) = GREATER
| boolCompare _ = EQUAL;
(* ------------------------------------------------------------------------- *)
(* Sorting and searching. *)
(* ------------------------------------------------------------------------- *)
(* Finding the minimum and maximum element of a list, wrt some order. *)
fun minimum cmp =
let
fun min (l,m,r) _ [] = (m, List.revAppend (l,r))
| min (best as (_,m,_)) l (x :: r) =
min (case cmp (x,m) of LESS => (l,x,r) | _ => best) (x :: l) r
in
fn [] => raise Empty
| h :: t => min ([],h,t) [h] t
end;
fun maximum cmp = minimum (revCompare cmp);
(* Merge (for the following merge-sort, but generally useful too). *)
fun merge cmp =
let
fun mrg acc [] ys = List.revAppend (acc,ys)
| mrg acc xs [] = List.revAppend (acc,xs)
| mrg acc (xs as x :: xt) (ys as y :: yt) =
(case cmp (x,y) of
GREATER => mrg (y :: acc) xs yt
| _ => mrg (x :: acc) xt ys)
in
mrg []
end;
(* Merge sort (stable). *)
fun sort cmp =
let
fun findRuns acc r rs [] = rev (rev (r :: rs) :: acc)
| findRuns acc r rs (x :: xs) =
case cmp (r,x) of
GREATER => findRuns (rev (r :: rs) :: acc) x [] xs
| _ => findRuns acc x (r :: rs) xs
fun mergeAdj acc [] = rev acc
| mergeAdj acc (xs as [_]) = List.revAppend (acc,xs)
| mergeAdj acc (x :: y :: xs) = mergeAdj (merge cmp x y :: acc) xs
fun mergePairs [xs] = xs
| mergePairs l = mergePairs (mergeAdj [] l)
in
fn [] => []
| l as [_] => l
| h :: t => mergePairs (findRuns [] h [] t)
end;
fun sortMap _ _ [] = []
| sortMap _ _ (l as [_]) = l
| sortMap f cmp xs =
let
fun ncmp ((m,_),(n,_)) = cmp (m,n)
val nxs = map (fn x => (f x, x)) xs
val nys = sort ncmp nxs
in
map snd nys
end;
(* ------------------------------------------------------------------------- *)
(* Integers. *)
(* ------------------------------------------------------------------------- *)
fun interval m 0 = []
| interval m len = m :: interval (m + 1) (len - 1);
fun divides _ 0 = true
| divides 0 _ = false
| divides a b = b mod (Int.abs a) = 0;
local
fun hcf 0 n = n
| hcf 1 _ = 1
| hcf m n = hcf (n mod m) m;
in
fun gcd m n =
let
val m = Int.abs m
and n = Int.abs n
in
if m < n then hcf m n else hcf n m
end;
end;
local
fun both f g n = f n andalso g n;
fun next f = let fun nx x = if f x then x else nx (x + 1) in nx end;
fun looking res 0 _ _ = rev res
| looking res n f x =
let
val p = next f x
val res' = p :: res
val f' = both f (not o divides p)
in
looking res' (n - 1) f' (p + 1)
end;
fun calcPrimes n = looking [] n (K true) 2
val primesList = Unsynchronized.ref (calcPrimes 10);
in
fun primes n = CRITICAL (fn () =>
if length (!primesList) <= n then List.take (!primesList,n)
else
let
val l = calcPrimes n
val () = primesList := l
in
l
end);
fun primesUpTo n = CRITICAL (fn () =>
let
fun f k [] =
let
val l = calcPrimes (2 * k)
val () = primesList := l
in
f k (List.drop (l,k))
end
| f k (p :: ps) =
if p <= n then f (k + 1) ps else List.take (!primesList, k)
in
f 0 (!primesList)
end);
end;
(* ------------------------------------------------------------------------- *)
(* Strings. *)
(* ------------------------------------------------------------------------- *)
local
fun len l = (length l, l)
val upper = len (explode "ABCDEFGHIJKLMNOPQRSTUVWXYZ");
val lower = len (explode "abcdefghijklmnopqrstuvwxyz");
fun rotate (n,l) c k =
List.nth (l, (k + Option.valOf (index (equal c) l)) mod n);
in
fun rot k c =
if Char.isLower c then rotate lower c k
else if Char.isUpper c then rotate upper c k
else c;
end;
fun charToInt #"0" = SOME 0
| charToInt #"1" = SOME 1
| charToInt #"2" = SOME 2
| charToInt #"3" = SOME 3
| charToInt #"4" = SOME 4
| charToInt #"5" = SOME 5
| charToInt #"6" = SOME 6
| charToInt #"7" = SOME 7
| charToInt #"8" = SOME 8
| charToInt #"9" = SOME 9
| charToInt _ = NONE;
fun charFromInt 0 = SOME #"0"
| charFromInt 1 = SOME #"1"
| charFromInt 2 = SOME #"2"
| charFromInt 3 = SOME #"3"
| charFromInt 4 = SOME #"4"
| charFromInt 5 = SOME #"5"
| charFromInt 6 = SOME #"6"
| charFromInt 7 = SOME #"7"
| charFromInt 8 = SOME #"8"
| charFromInt 9 = SOME #"9"
| charFromInt _ = NONE;
fun nChars x =
let
fun dup 0 l = l | dup n l = dup (n - 1) (x :: l)
in
fn n => implode (dup n [])
end;
fun chomp s =
let
val n = size s
in
if n = 0 orelse String.sub (s, n - 1) <> #"\n" then s
else String.substring (s, 0, n - 1)
end;
local
fun chop [] = []
| chop (l as (h :: t)) = if Char.isSpace h then chop t else l;
in
val trim = implode o chop o rev o chop o rev o explode;
end;
fun join _ [] = "" | join s (h :: t) = foldl (fn (x,y) => y ^ s ^ x) h t;
local
fun match [] l = SOME l
| match _ [] = NONE
| match (x :: xs) (y :: ys) = if x = y then match xs ys else NONE;
fun stringify acc [] = acc
| stringify acc (h :: t) = stringify (implode h :: acc) t;
in
fun split sep =
let
val pat = String.explode sep
fun div1 prev recent [] = stringify [] (rev recent :: prev)
| div1 prev recent (l as h :: t) =
case match pat l of
NONE => div1 prev (h :: recent) t
| SOME rest => div1 (rev recent :: prev) [] rest
in
fn s => div1 [] [] (explode s)
end;
end;
(***
fun pluralize {singular,plural} = fn 1 => singular | _ => plural;
***)
fun mkPrefix p s = p ^ s;
fun destPrefix p =
let
fun check s = String.isPrefix p s orelse raise Error "destPrefix"
val sizeP = size p
in
fn s => (check s; String.extract (s,sizeP,NONE))
end;
fun isPrefix p = can (destPrefix p);
(* ------------------------------------------------------------------------- *)
(* Tables. *)
(* ------------------------------------------------------------------------- *)
type columnAlignment = {leftAlign : bool, padChar : char}
fun alignColumn {leftAlign,padChar} column =
let
val (n,_) = maximum Int.compare (map size column)
fun pad entry row =
let
val padding = nChars padChar (n - size entry)
in
if leftAlign then entry ^ padding ^ row
else padding ^ entry ^ row
end
in
zipwith pad column
end;
fun alignTable [] rows = map (K "") rows
| alignTable [{leftAlign = true, padChar = #" "}] rows = map hd rows
| alignTable (align :: aligns) rows =
alignColumn align (map hd rows) (alignTable aligns (map tl rows));
(* ------------------------------------------------------------------------- *)
(* Reals. *)
(* ------------------------------------------------------------------------- *)
val realToString = Real.toString;
fun percentToString x = Int.toString (Real.round (100.0 * x)) ^ "%";
fun pos r = Real.max (r,0.0);
local
val invLn2 = 1.0 / Math.ln 2.0;
in
fun log2 x = invLn2 * Math.ln x;
end;
(* ------------------------------------------------------------------------- *)
(* Sums. *)
(* ------------------------------------------------------------------------- *)
datatype ('a,'b) sum = Left of 'a | Right of 'b
fun destLeft (Left l) = l
| destLeft _ = raise Error "destLeft";
fun isLeft (Left _) = true
| isLeft (Right _) = false;
fun destRight (Right r) = r
| destRight _ = raise Error "destRight";
fun isRight (Left _) = false
| isRight (Right _) = true;
(* ------------------------------------------------------------------------- *)
(* Useful impure features. *)
(* ------------------------------------------------------------------------- *)
local
val generator = Unsynchronized.ref 0
in
fun newInt () = CRITICAL (fn () =>
let
val n = !generator
val () = generator := n + 1
in
n
end);
fun newInts 0 = []
| newInts k = CRITICAL (fn () =>
let
val n = !generator
val () = generator := n + k
in
interval n k
end);
end;
fun withRef (r,new) f x =
let
val old = !r
val () = r := new
val y = f x handle e => (r := old; raise e)
val () = r := old
in
y
end;
fun cloneArray a =
let
fun index i = Array.sub (a,i)
in
Array.tabulate (Array.length a, index)
end;
(* ------------------------------------------------------------------------- *)
(* Environment. *)
(* ------------------------------------------------------------------------- *)
fun host () = Option.getOpt (OS.Process.getEnv "HOSTNAME", "unknown");
fun time () = Date.fmt "%H:%M:%S" (Date.fromTimeLocal (Time.now ()));
fun date () = Date.fmt "%d/%m/%Y" (Date.fromTimeLocal (Time.now ()));
fun readTextFile {filename} =
let
open TextIO
val h = openIn filename
val contents = inputAll h
val () = closeIn h
in
contents
end;
fun writeTextFile {filename,contents} =
let
open TextIO
val h = openOut filename
val () = output (h,contents)
val () = closeOut h
in
()
end;
(* ------------------------------------------------------------------------- *)
(* Profiling *)
(* ------------------------------------------------------------------------- *)
local
fun err x s = TextIO.output (TextIO.stdErr, x ^ ": " ^ s ^ "\n");
in
fun try f x = f x
handle e as Error _ => (err "try" (errorToString e); raise e)
| e as Bug _ => (err "try" (bugToString e); raise e)
| e => (err "try" "strange exception raised"; raise e);
val warn = err "WARNING";
fun die s = (err "\nFATAL ERROR" s; OS.Process.exit OS.Process.failure);
end;
fun timed f a =
let
val tmr = Timer.startCPUTimer ()
val res = f a
val {usr,sys,...} = Timer.checkCPUTimer tmr
in
(Time.toReal usr + Time.toReal sys, res)
end;
local
val MIN = 1.0;
fun several n t f a =
let
val (t',res) = timed f a
val t = t + t'
val n = n + 1
in
if t > MIN then (t / Real.fromInt n, res) else several n t f a
end;
in
fun timedMany f a = several 0 0.0 f a
end;
val executionTime =
let
val startTime = Time.toReal (Time.now ())
in
fn () => Time.toReal (Time.now ()) - startTime
end;
end
end;
(**** Original file: Lazy.sig ****)
(* ========================================================================= *)
(* SUPPORT FOR LAZY EVALUATION *)
(* Copyright (c) 2007 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Lazy =
sig
type 'a lazy
val delay : (unit -> 'a) -> 'a lazy
val force : 'a lazy -> 'a
val memoize : (unit -> 'a) -> unit -> 'a
end
(**** Original file: Lazy.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* SUPPORT FOR LAZY EVALUATION *)
(* Copyright (c) 2007 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Lazy :> Lazy =
struct
datatype 'a thunk =
Value of 'a
| Thunk of unit -> 'a;
datatype 'a lazy = Lazy of 'a thunk Unsynchronized.ref;
fun delay f = Lazy (Unsynchronized.ref (Thunk f));
fun force (Lazy (Unsynchronized.ref (Value v))) = v
| force (Lazy (s as Unsynchronized.ref (Thunk f))) =
let
val v = f ()
val () = s := Value v
in
v
end;
fun memoize f =
let
val t = delay f
in
fn () => force t
end;
end
end;
(**** Original file: Ordered.sig ****)
(* ========================================================================= *)
(* ORDERED TYPES *)
(* Copyright (c) 2004-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Ordered =
sig
type t
val compare : t * t -> order
(*
PROVIDES
!x : t. compare (x,x) = EQUAL
!x y : t. compare (x,y) = LESS <=> compare (y,x) = GREATER
!x y : t. compare (x,y) = EQUAL ==> compare (y,x) = EQUAL
!x y z : t. compare (x,y) = EQUAL ==> compare (x,z) = compare (y,z)
!x y z : t.
compare (x,y) = LESS andalso compare (y,z) = LESS ==>
compare (x,z) = LESS
!x y z : t.
compare (x,y) = GREATER andalso compare (y,z) = GREATER ==>
compare (x,z) = GREATER
*)
end
(**** Original file: Ordered.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* ORDERED TYPES *)
(* Copyright (c) 2004-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure IntOrdered =
struct type t = int val compare = Int.compare end;
structure StringOrdered =
struct type t = string val compare = String.compare end;
end;
(**** Original file: Set.sig ****)
(* ========================================================================= *)
(* FINITE SETS *)
(* Copyright (c) 2004-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Set =
sig
(* ------------------------------------------------------------------------- *)
(* Finite sets *)
(* ------------------------------------------------------------------------- *)
type 'elt set
val comparison : 'elt set -> ('elt * 'elt -> order)
val empty : ('elt * 'elt -> order) -> 'elt set
val singleton : ('elt * 'elt -> order) -> 'elt -> 'elt set
val null : 'elt set -> bool
val size : 'elt set -> int
val member : 'elt -> 'elt set -> bool
val add : 'elt set -> 'elt -> 'elt set
val addList : 'elt set -> 'elt list -> 'elt set
val delete : 'elt set -> 'elt -> 'elt set (* raises Error *)
(* Union and intersect prefer elements in the second set *)
val union : 'elt set -> 'elt set -> 'elt set
val unionList : 'elt set list -> 'elt set
val intersect : 'elt set -> 'elt set -> 'elt set
val intersectList : 'elt set list -> 'elt set
val difference : 'elt set -> 'elt set -> 'elt set
val symmetricDifference : 'elt set -> 'elt set -> 'elt set
val disjoint : 'elt set -> 'elt set -> bool
val subset : 'elt set -> 'elt set -> bool
val equal : 'elt set -> 'elt set -> bool
val filter : ('elt -> bool) -> 'elt set -> 'elt set
val partition : ('elt -> bool) -> 'elt set -> 'elt set * 'elt set
val count : ('elt -> bool) -> 'elt set -> int
val foldl : ('elt * 's -> 's) -> 's -> 'elt set -> 's
val foldr : ('elt * 's -> 's) -> 's -> 'elt set -> 's
val findl : ('elt -> bool) -> 'elt set -> 'elt option
val findr : ('elt -> bool) -> 'elt set -> 'elt option
val firstl : ('elt -> 'a option) -> 'elt set -> 'a option
val firstr : ('elt -> 'a option) -> 'elt set -> 'a option
val exists : ('elt -> bool) -> 'elt set -> bool
val all : ('elt -> bool) -> 'elt set -> bool
val map : ('elt -> 'a) -> 'elt set -> ('elt * 'a) list
val transform : ('elt -> 'a) -> 'elt set -> 'a list
val app : ('elt -> unit) -> 'elt set -> unit
val toList : 'elt set -> 'elt list
val fromList : ('elt * 'elt -> order) -> 'elt list -> 'elt set
val pick : 'elt set -> 'elt (* raises Empty *)
val random : 'elt set -> 'elt (* raises Empty *)
val deletePick : 'elt set -> 'elt * 'elt set (* raises Empty *)
val deleteRandom : 'elt set -> 'elt * 'elt set (* raises Empty *)
val compare : 'elt set * 'elt set -> order
val close : ('elt set -> 'elt set) -> 'elt set -> 'elt set
val toString : 'elt set -> string
(* ------------------------------------------------------------------------- *)
(* Iterators over sets *)
(* ------------------------------------------------------------------------- *)
type 'elt iterator
val mkIterator : 'elt set -> 'elt iterator option
val mkRevIterator : 'elt set -> 'elt iterator option
val readIterator : 'elt iterator -> 'elt
val advanceIterator : 'elt iterator -> 'elt iterator option
end
(**** Original file: RandomSet.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* FINITE SETS IMPLEMENTED WITH RANDOMLY BALANCED TREES *)
(* Copyright (c) 2004-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure RandomSet :> Set =
struct
exception Bug = Useful.Bug;
exception Error = Useful.Error;
val pointerEqual = Portable.pointerEqual;
val K = Useful.K;
val snd = Useful.snd;
val randomInt = Portable.randomInt;
val randomWord = Portable.randomWord;
(* ------------------------------------------------------------------------- *)
(* Random search trees. *)
(* ------------------------------------------------------------------------- *)
type priority = Word.word;
datatype 'a tree =
E
| T of
{size : int,
priority : priority,
left : 'a tree,
key : 'a,
right : 'a tree};
type 'a node =
{size : int,
priority : priority,
left : 'a tree,
key : 'a,
right : 'a tree};
datatype 'a set = Set of ('a * 'a -> order) * 'a tree;
(* ------------------------------------------------------------------------- *)
(* Random priorities. *)
(* ------------------------------------------------------------------------- *)
local
val randomPriority = randomWord;
val priorityOrder = Word.compare;
in
fun treeSingleton key =
T {size = 1, priority = randomPriority (),
left = E, key = key, right = E};
fun nodePriorityOrder cmp (x1 : 'a node, x2 : 'a node) =
let
val {priority = p1, key = k1, ...} = x1
and {priority = p2, key = k2, ...} = x2
in
case priorityOrder (p1,p2) of
LESS => LESS
| EQUAL => cmp (k1,k2)
| GREATER => GREATER
end;
end;
(* ------------------------------------------------------------------------- *)
(* Debugging functions. *)
(* ------------------------------------------------------------------------- *)
local
fun checkSizes E = 0
| checkSizes (T {size,left,right,...}) =
let
val l = checkSizes left
and r = checkSizes right
val () = if l + 1 + r = size then () else raise Error "wrong size"
in
size
end
fun checkSorted _ x E = x
| checkSorted cmp x (T {left,key,right,...}) =
let
val x = checkSorted cmp x left
val () =
case x of
NONE => ()
| SOME k =>
case cmp (k,key) of
LESS => ()
| EQUAL => raise Error "duplicate keys"
| GREATER => raise Error "unsorted"
in
checkSorted cmp (SOME key) right
end;
fun checkPriorities _ E = NONE
| checkPriorities cmp (T (x as {left,right,...})) =
let
val () =
case checkPriorities cmp left of
NONE => ()
| SOME l =>
case nodePriorityOrder cmp (l,x) of
LESS => ()
| EQUAL => raise Error "left child has equal key"
| GREATER => raise Error "left child has greater priority"
val () =
case checkPriorities cmp right of
NONE => ()
| SOME r =>
case nodePriorityOrder cmp (r,x) of
LESS => ()
| EQUAL => raise Error "right child has equal key"
| GREATER => raise Error "right child has greater priority"
in
SOME x
end;
in
fun checkWellformed s (set as Set (cmp,tree)) =
(let
val _ = checkSizes tree
val _ = checkSorted cmp NONE tree
val _ = checkPriorities cmp tree
in
set
end
handle Error err => raise Bug err)
handle Bug bug => raise Bug (s ^ "\nRandomSet.checkWellformed: " ^ bug);
end;
(* ------------------------------------------------------------------------- *)
(* Basic operations. *)
(* ------------------------------------------------------------------------- *)
fun comparison (Set (cmp,_)) = cmp;
fun empty cmp = Set (cmp,E);
fun treeSize E = 0
| treeSize (T {size = s, ...}) = s;
fun size (Set (_,tree)) = treeSize tree;
fun mkT p l k r =
T {size = treeSize l + 1 + treeSize r, priority = p,
left = l, key = k, right = r};
fun singleton cmp key = Set (cmp, treeSingleton key);
local
fun treePeek cmp E pkey = NONE
| treePeek cmp (T {left,key,right,...}) pkey =
case cmp (pkey,key) of
LESS => treePeek cmp left pkey
| EQUAL => SOME key
| GREATER => treePeek cmp right pkey
in
fun peek (Set (cmp,tree)) key = treePeek cmp tree key;
end;
(* treeAppend assumes that every element of the first tree is less than *)
(* every element of the second tree. *)
fun treeAppend _ t1 E = t1
| treeAppend _ E t2 = t2
| treeAppend cmp (t1 as T x1) (t2 as T x2) =
case nodePriorityOrder cmp (x1,x2) of
LESS =>
let
val {priority = p2, left = l2, key = k2, right = r2, ...} = x2
in
mkT p2 (treeAppend cmp t1 l2) k2 r2
end
| EQUAL => raise Bug "RandomSet.treeAppend: equal keys"
| GREATER =>
let
val {priority = p1, left = l1, key = k1, right = r1, ...} = x1
in
mkT p1 l1 k1 (treeAppend cmp r1 t2)
end;
(* nodePartition splits the node into three parts: the keys comparing less *)
(* than the supplied key, an optional equal key, and the keys comparing *)
(* greater. *)
local
fun mkLeft [] t = t
| mkLeft (({priority,left,key,...} : 'a node) :: xs) t =
mkLeft xs (mkT priority left key t);
fun mkRight [] t = t
| mkRight (({priority,key,right,...} : 'a node) :: xs) t =
mkRight xs (mkT priority t key right);
fun treePart _ _ lefts rights E = (mkLeft lefts E, NONE, mkRight rights E)
| treePart cmp pkey lefts rights (T x) = nodePart cmp pkey lefts rights x
and nodePart cmp pkey lefts rights (x as {left,key,right,...}) =
case cmp (pkey,key) of
LESS => treePart cmp pkey lefts (x :: rights) left
| EQUAL => (mkLeft lefts left, SOME key, mkRight rights right)
| GREATER => treePart cmp pkey (x :: lefts) rights right;
in
fun nodePartition cmp x pkey = nodePart cmp pkey [] [] x;
end;
(* union first calls treeCombineRemove, to combine the values *)
(* for equal keys into the first map and remove them from the second map. *)
(* Note that the combined key is always the one from the second map. *)
local
fun treeCombineRemove _ t1 E = (t1,E)
| treeCombineRemove _ E t2 = (E,t2)
| treeCombineRemove cmp (t1 as T x1) (t2 as T x2) =
let
val {priority = p1, left = l1, key = k1, right = r1, ...} = x1
val (l2,k2,r2) = nodePartition cmp x2 k1
val (l1,l2) = treeCombineRemove cmp l1 l2
and (r1,r2) = treeCombineRemove cmp r1 r2
in
case k2 of
NONE => if treeSize l2 + treeSize r2 = #size x2 then (t1,t2)
else (mkT p1 l1 k1 r1, treeAppend cmp l2 r2)
| SOME k2 => (mkT p1 l1 k2 r1, treeAppend cmp l2 r2)
end;
fun treeUnionDisjoint _ t1 E = t1
| treeUnionDisjoint _ E t2 = t2
| treeUnionDisjoint cmp (T x1) (T x2) =
case nodePriorityOrder cmp (x1,x2) of
LESS => nodeUnionDisjoint cmp x2 x1
| EQUAL => raise Bug "RandomSet.unionDisjoint: equal keys"
| GREATER => nodeUnionDisjoint cmp x1 x2
and nodeUnionDisjoint cmp x1 x2 =
let
val {priority = p1, left = l1, key = k1, right = r1, ...} = x1
val (l2,_,r2) = nodePartition cmp x2 k1
val l = treeUnionDisjoint cmp l1 l2
and r = treeUnionDisjoint cmp r1 r2
in
mkT p1 l k1 r
end;
in
fun union (s1 as Set (cmp,t1)) (Set (_,t2)) =
if pointerEqual (t1,t2) then s1
else
let
val (t1,t2) = treeCombineRemove cmp t1 t2
in
Set (cmp, treeUnionDisjoint cmp t1 t2)
end;
end;
(*DEBUG
val union = fn t1 => fn t2 =>
checkWellformed "RandomSet.union: result"
(union (checkWellformed "RandomSet.union: input 1" t1)
(checkWellformed "RandomSet.union: input 2" t2));
*)
(* intersect is a simple case of the union algorithm. *)
local
fun treeIntersect _ _ E = E
| treeIntersect _ E _ = E
| treeIntersect cmp (t1 as T x1) (t2 as T x2) =
let
val {priority = p1, left = l1, key = k1, right = r1, ...} = x1
val (l2,k2,r2) = nodePartition cmp x2 k1
val l = treeIntersect cmp l1 l2
and r = treeIntersect cmp r1 r2
in
case k2 of
NONE => treeAppend cmp l r
| SOME k2 => mkT p1 l k2 r
end;
in
fun intersect (s1 as Set (cmp,t1)) (Set (_,t2)) =
if pointerEqual (t1,t2) then s1
else Set (cmp, treeIntersect cmp t1 t2);
end;
(*DEBUG
val intersect = fn t1 => fn t2 =>
checkWellformed "RandomSet.intersect: result"
(intersect (checkWellformed "RandomSet.intersect: input 1" t1)
(checkWellformed "RandomSet.intersect: input 2" t2));
*)
(* delete raises an exception if the supplied key is not found, which *)
(* makes it simpler to maximize sharing. *)
local
fun treeDelete _ E _ = raise Error "RandomSet.delete: element not found"
| treeDelete cmp (T {priority,left,key,right,...}) dkey =
case cmp (dkey,key) of
LESS => mkT priority (treeDelete cmp left dkey) key right
| EQUAL => treeAppend cmp left right
| GREATER => mkT priority left key (treeDelete cmp right dkey);
in
fun delete (Set (cmp,tree)) key = Set (cmp, treeDelete cmp tree key);
end;
(*DEBUG
val delete = fn t => fn x =>
checkWellformed "RandomSet.delete: result"
(delete (checkWellformed "RandomSet.delete: input" t) x);
*)
(* Set difference *)
local
fun treeDifference _ t1 E = t1
| treeDifference _ E _ = E
| treeDifference cmp (t1 as T x1) (T x2) =
let
val {size = s1, priority = p1, left = l1, key = k1, right = r1} = x1
val (l2,k2,r2) = nodePartition cmp x2 k1
val l = treeDifference cmp l1 l2
and r = treeDifference cmp r1 r2
in
if Option.isSome k2 then treeAppend cmp l r
else if treeSize l + treeSize r + 1 = s1 then t1
else mkT p1 l k1 r
end;
in
fun difference (Set (cmp,tree1)) (Set (_,tree2)) =
if pointerEqual (tree1,tree2) then Set (cmp,E)
else Set (cmp, treeDifference cmp tree1 tree2);
end;
(*DEBUG
val difference = fn t1 => fn t2 =>
checkWellformed "RandomSet.difference: result"
(difference (checkWellformed "RandomSet.difference: input 1" t1)
(checkWellformed "RandomSet.difference: input 2" t2));
*)
(* Subsets *)
local
fun treeSubset _ E _ = true
| treeSubset _ _ E = false
| treeSubset cmp (t1 as T x1) (T x2) =
let
val {size = s1, left = l1, key = k1, right = r1, ...} = x1
and {size = s2, ...} = x2
in
s1 <= s2 andalso
let
val (l2,k2,r2) = nodePartition cmp x2 k1
in
Option.isSome k2 andalso
treeSubset cmp l1 l2 andalso
treeSubset cmp r1 r2
end
end;
in
fun subset (Set (cmp,tree1)) (Set (_,tree2)) =
pointerEqual (tree1,tree2) orelse
treeSubset cmp tree1 tree2;
end;
(* Set equality *)
local
fun treeEqual _ E E = true
| treeEqual _ E _ = false
| treeEqual _ _ E = false
| treeEqual cmp (t1 as T x1) (T x2) =
let
val {size = s1, left = l1, key = k1, right = r1, ...} = x1
and {size = s2, ...} = x2
in
s1 = s2 andalso
let
val (l2,k2,r2) = nodePartition cmp x2 k1
in
Option.isSome k2 andalso
treeEqual cmp l1 l2 andalso
treeEqual cmp r1 r2
end
end;
in
fun equal (Set (cmp,tree1)) (Set (_,tree2)) =
pointerEqual (tree1,tree2) orelse
treeEqual cmp tree1 tree2;
end;
(* filter is the basic function for preserving the tree structure. *)
local
fun treeFilter _ _ E = E
| treeFilter cmp pred (T {priority,left,key,right,...}) =
let
val left = treeFilter cmp pred left
and right = treeFilter cmp pred right
in
if pred key then mkT priority left key right
else treeAppend cmp left right
end;
in
fun filter pred (Set (cmp,tree)) = Set (cmp, treeFilter cmp pred tree);
end;
(* nth picks the nth smallest key (counting from 0). *)
local
fun treeNth E _ = raise Subscript
| treeNth (T {left,key,right,...}) n =
let
val k = treeSize left
in
if n = k then key
else if n < k then treeNth left n
else treeNth right (n - (k + 1))
end;
in
fun nth (Set (_,tree)) n = treeNth tree n;
end;
(* ------------------------------------------------------------------------- *)
(* Iterators. *)
(* ------------------------------------------------------------------------- *)
fun leftSpine E acc = acc
| leftSpine (t as T {left,...}) acc = leftSpine left (t :: acc);
fun rightSpine E acc = acc
| rightSpine (t as T {right,...}) acc = rightSpine right (t :: acc);
datatype 'a iterator =
LR of 'a * 'a tree * 'a tree list
| RL of 'a * 'a tree * 'a tree list;
fun mkLR [] = NONE
| mkLR (T {key,right,...} :: l) = SOME (LR (key,right,l))
| mkLR (E :: _) = raise Bug "RandomSet.mkLR";
fun mkRL [] = NONE
| mkRL (T {key,left,...} :: l) = SOME (RL (key,left,l))
| mkRL (E :: _) = raise Bug "RandomSet.mkRL";
fun mkIterator (Set (_,tree)) = mkLR (leftSpine tree []);
fun mkRevIterator (Set (_,tree)) = mkRL (rightSpine tree []);
fun readIterator (LR (key,_,_)) = key
| readIterator (RL (key,_,_)) = key;
fun advanceIterator (LR (_,next,l)) = mkLR (leftSpine next l)
| advanceIterator (RL (_,next,l)) = mkRL (rightSpine next l);
(* ------------------------------------------------------------------------- *)
(* Derived operations. *)
(* ------------------------------------------------------------------------- *)
fun null s = size s = 0;
fun member x s = Option.isSome (peek s x);
fun add s x = union s (singleton (comparison s) x);
(*DEBUG
val add = fn s => fn x =>
checkWellformed "RandomSet.add: result"
(add (checkWellformed "RandomSet.add: input" s) x);
*)
local
fun unionPairs ys [] = rev ys
| unionPairs ys (xs as [_]) = List.revAppend (ys,xs)
| unionPairs ys (x1 :: x2 :: xs) = unionPairs (union x1 x2 :: ys) xs;
in
fun unionList [] = raise Error "RandomSet.unionList: no sets"
| unionList [s] = s
| unionList l = unionList (unionPairs [] l);
end;
local
fun intersectPairs ys [] = rev ys
| intersectPairs ys (xs as [_]) = List.revAppend (ys,xs)
| intersectPairs ys (x1 :: x2 :: xs) =
intersectPairs (intersect x1 x2 :: ys) xs;
in
fun intersectList [] = raise Error "RandomSet.intersectList: no sets"
| intersectList [s] = s
| intersectList l = intersectList (intersectPairs [] l);
end;
fun symmetricDifference s1 s2 = union (difference s1 s2) (difference s2 s1);
fun disjoint s1 s2 = null (intersect s1 s2);
fun partition pred set = (filter pred set, filter (not o pred) set);
local
fun fold _ NONE acc = acc
| fold f (SOME iter) acc =
let
val key = readIterator iter
in
fold f (advanceIterator iter) (f (key,acc))
end;
in
fun foldl f b m = fold f (mkIterator m) b;
fun foldr f b m = fold f (mkRevIterator m) b;
end;
local
fun find _ NONE = NONE
| find pred (SOME iter) =
let
val key = readIterator iter
in
if pred key then SOME key
else find pred (advanceIterator iter)
end;
in
fun findl p m = find p (mkIterator m);
fun findr p m = find p (mkRevIterator m);
end;
local
fun first _ NONE = NONE
| first f (SOME iter) =
let
val key = readIterator iter
in
case f key of
NONE => first f (advanceIterator iter)
| s => s
end;
in
fun firstl f m = first f (mkIterator m);
fun firstr f m = first f (mkRevIterator m);
end;
fun count p = foldl (fn (x,n) => if p x then n + 1 else n) 0;
fun fromList cmp l = List.foldl (fn (k,s) => add s k) (empty cmp) l;
fun addList s l = union s (fromList (comparison s) l);
fun toList s = foldr op:: [] s;
fun map f s = rev (foldl (fn (x,l) => (x, f x) :: l) [] s);
fun transform f s = rev (foldl (fn (x,l) => f x :: l) [] s);
fun app f s = foldl (fn (x,()) => f x) () s;
fun exists p s = Option.isSome (findl p s);
fun all p s = not (exists (not o p) s);
local
fun iterCompare _ NONE NONE = EQUAL
| iterCompare _ NONE (SOME _) = LESS
| iterCompare _ (SOME _) NONE = GREATER
| iterCompare cmp (SOME i1) (SOME i2) =
keyIterCompare cmp (readIterator i1) (readIterator i2) i1 i2
and keyIterCompare cmp k1 k2 i1 i2 =
case cmp (k1,k2) of
LESS => LESS
| EQUAL => iterCompare cmp (advanceIterator i1) (advanceIterator i2)
| GREATER => GREATER;
in
fun compare (s1,s2) =
if pointerEqual (s1,s2) then EQUAL
else
case Int.compare (size s1, size s2) of
LESS => LESS
| EQUAL => iterCompare (comparison s1) (mkIterator s1) (mkIterator s2)
| GREATER => GREATER;
end;
fun pick s =
case findl (K true) s of
SOME p => p
| NONE => raise Error "RandomSet.pick: empty";
fun random s =
case size s of
0 => raise Error "RandomSet.random: empty"
| n => nth s (randomInt n);
fun deletePick s = let val x = pick s in (x, delete s x) end;
fun deleteRandom s = let val x = random s in (x, delete s x) end;
fun close f s = let val s' = f s in if equal s s' then s else close f s' end;
fun toString s = "{" ^ (if null s then "" else Int.toString (size s)) ^ "}";
end
end;
(**** Original file: Set.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* FINITE SETS *)
(* Copyright (c) 2004-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Set = RandomSet;
end;
(**** Original file: ElementSet.sig ****)
(* ========================================================================= *)
(* FINITE SETS WITH A FIXED ELEMENT TYPE *)
(* Copyright (c) 2004-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature ElementSet =
sig
type element
(* ------------------------------------------------------------------------- *)
(* Finite sets *)
(* ------------------------------------------------------------------------- *)
type set
val empty : set
val singleton : element -> set
val null : set -> bool
val size : set -> int
val member : element -> set -> bool
val add : set -> element -> set
val addList : set -> element list -> set
val delete : set -> element -> set (* raises Error *)
(* Union and intersect prefer elements in the second set *)
val union : set -> set -> set
val unionList : set list -> set
val intersect : set -> set -> set
val intersectList : set list -> set
val difference : set -> set -> set
val symmetricDifference : set -> set -> set
val disjoint : set -> set -> bool
val subset : set -> set -> bool
val equal : set -> set -> bool
val filter : (element -> bool) -> set -> set
val partition : (element -> bool) -> set -> set * set
val count : (element -> bool) -> set -> int
val foldl : (element * 's -> 's) -> 's -> set -> 's
val foldr : (element * 's -> 's) -> 's -> set -> 's
val findl : (element -> bool) -> set -> element option
val findr : (element -> bool) -> set -> element option
val firstl : (element -> 'a option) -> set -> 'a option
val firstr : (element -> 'a option) -> set -> 'a option
val exists : (element -> bool) -> set -> bool
val all : (element -> bool) -> set -> bool
val map : (element -> 'a) -> set -> (element * 'a) list
val transform : (element -> 'a) -> set -> 'a list
val app : (element -> unit) -> set -> unit
val toList : set -> element list
val fromList : element list -> set
val pick : set -> element (* raises Empty *)
val random : set -> element (* raises Empty *)
val deletePick : set -> element * set (* raises Empty *)
val deleteRandom : set -> element * set (* raises Empty *)
val compare : set * set -> order
val close : (set -> set) -> set -> set
val toString : set -> string
(* ------------------------------------------------------------------------- *)
(* Iterators over sets *)
(* ------------------------------------------------------------------------- *)
type iterator
val mkIterator : set -> iterator option
val mkRevIterator : set -> iterator option
val readIterator : iterator -> element
val advanceIterator : iterator -> iterator option
end
(**** Original file: ElementSet.sml ****)
(* ========================================================================= *)
(* FINITE SETS WITH A FIXED ELEMENT TYPE *)
(* Copyright (c) 2004-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
functor ElementSet (Key : Ordered) :> ElementSet where type element = Key.t =
struct
open Metis;
type element = Key.t;
(* ------------------------------------------------------------------------- *)
(* Finite sets *)
(* ------------------------------------------------------------------------- *)
type set = Key.t Set.set;
val empty = Set.empty Key.compare;
fun singleton key = Set.singleton Key.compare key;
val null = Set.null;
val size = Set.size;
val member = Set.member;
val add = Set.add;
val addList = Set.addList;
val delete = Set.delete;
val op union = Set.union;
val unionList = Set.unionList;
val intersect = Set.intersect;
val intersectList = Set.intersectList;
val difference = Set.difference;
val symmetricDifference = Set.symmetricDifference;
val disjoint = Set.disjoint;
val op subset = Set.subset;
val equal = Set.equal;
val filter = Set.filter;
val partition = Set.partition;
val count = Set.count;
val foldl = Set.foldl;
val foldr = Set.foldr;
val findl = Set.findl;
val findr = Set.findr;
val firstl = Set.firstl;
val firstr = Set.firstr;
val exists = Set.exists;
val all = Set.all;
val map = Set.map;
val transform = Set.transform;
val app = Set.app;
val toList = Set.toList;
fun fromList l = Set.fromList Key.compare l;
val pick = Set.pick;
val random = Set.random;
val deletePick = Set.deletePick;
val deleteRandom = Set.deleteRandom;
val compare = Set.compare;
val close = Set.close;
val toString = Set.toString;
(* ------------------------------------------------------------------------- *)
(* Iterators over sets *)
(* ------------------------------------------------------------------------- *)
type iterator = Key.t Set.iterator;
val mkIterator = Set.mkIterator;
val mkRevIterator = Set.mkRevIterator;
val readIterator = Set.readIterator;
val advanceIterator = Set.advanceIterator;
end
structure Metis = struct open Metis;
structure IntSet =
ElementSet (IntOrdered);
structure StringSet =
ElementSet (StringOrdered);
end;
(**** Original file: Map.sig ****)
(* ========================================================================= *)
(* FINITE MAPS *)
(* Copyright (c) 2004-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Map =
sig
(* ------------------------------------------------------------------------- *)
(* Finite maps *)
(* ------------------------------------------------------------------------- *)
type ('key,'a) map
val new : ('key * 'key -> order) -> ('key,'a) map
val null : ('key,'a) map -> bool
val size : ('key,'a) map -> int
val singleton : ('key * 'key -> order) -> 'key * 'a -> ('key,'a) map
val inDomain : 'key -> ('key,'a) map -> bool
val peek : ('key,'a) map -> 'key -> 'a option
val insert : ('key,'a) map -> 'key * 'a -> ('key,'a) map
val insertList : ('key,'a) map -> ('key * 'a) list -> ('key,'a) map
val get : ('key,'a) map -> 'key -> 'a (* raises Error *)
(* Union and intersect prefer keys in the second map *)
val union :
('a * 'a -> 'a option) -> ('key,'a) map -> ('key,'a) map -> ('key,'a) map
val intersect :
('a * 'a -> 'a option) -> ('key,'a) map -> ('key,'a) map -> ('key,'a) map
val delete : ('key,'a) map -> 'key -> ('key,'a) map (* raises Error *)
val difference : ('key,'a) map -> ('key,'b) map -> ('key,'a) map
val subsetDomain : ('key,'a) map -> ('key,'a) map -> bool
val equalDomain : ('key,'a) map -> ('key,'a) map -> bool
val mapPartial : ('key * 'a -> 'b option) -> ('key,'a) map -> ('key,'b) map
val filter : ('key * 'a -> bool) -> ('key,'a) map -> ('key,'a) map
val map : ('key * 'a -> 'b) -> ('key,'a) map -> ('key,'b) map
val app : ('key * 'a -> unit) -> ('key,'a) map -> unit
val transform : ('a -> 'b) -> ('key,'a) map -> ('key,'b) map
val foldl : ('key * 'a * 's -> 's) -> 's -> ('key,'a) map -> 's
val foldr : ('key * 'a * 's -> 's) -> 's -> ('key,'a) map -> 's
val findl : ('key * 'a -> bool) -> ('key,'a) map -> ('key * 'a) option
val findr : ('key * 'a -> bool) -> ('key,'a) map -> ('key * 'a) option
val firstl : ('key * 'a -> 'b option) -> ('key,'a) map -> 'b option
val firstr : ('key * 'a -> 'b option) -> ('key,'a) map -> 'b option
val exists : ('key * 'a -> bool) -> ('key,'a) map -> bool
val all : ('key * 'a -> bool) -> ('key,'a) map -> bool
val domain : ('key,'a) map -> 'key list
val toList : ('key,'a) map -> ('key * 'a) list
val fromList : ('key * 'key -> order) -> ('key * 'a) list -> ('key,'a) map
val random : ('key,'a) map -> 'key * 'a (* raises Empty *)
val compare : ('a * 'a -> order) -> ('key,'a) map * ('key,'a) map -> order
val equal : ('a -> 'a -> bool) -> ('key,'a) map -> ('key,'a) map -> bool
val toString : ('key,'a) map -> string
(* ------------------------------------------------------------------------- *)
(* Iterators over maps *)
(* ------------------------------------------------------------------------- *)
type ('key,'a) iterator
val mkIterator : ('key,'a) map -> ('key,'a) iterator option
val mkRevIterator : ('key,'a) map -> ('key,'a) iterator option
val readIterator : ('key,'a) iterator -> 'key * 'a
val advanceIterator : ('key,'a) iterator -> ('key,'a) iterator option
end
(**** Original file: RandomMap.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* FINITE MAPS IMPLEMENTED WITH RANDOMLY BALANCED TREES *)
(* Copyright (c) 2004-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure RandomMap :> Map =
struct
exception Bug = Useful.Bug;
exception Error = Useful.Error;
val pointerEqual = Portable.pointerEqual;
val K = Useful.K;
val snd = Useful.snd;
val randomInt = Portable.randomInt;
val randomWord = Portable.randomWord;
(* ------------------------------------------------------------------------- *)
(* Random search trees. *)
(* ------------------------------------------------------------------------- *)
type priority = Word.word;
datatype ('a,'b) tree =
E
| T of
{size : int,
priority : priority,
left : ('a,'b) tree,
key : 'a,
value : 'b,
right : ('a,'b) tree};
type ('a,'b) node =
{size : int,
priority : priority,
left : ('a,'b) tree,
key : 'a,
value : 'b,
right : ('a,'b) tree};
datatype ('a,'b) map = Map of ('a * 'a -> order) * ('a,'b) tree;
(* ------------------------------------------------------------------------- *)
(* Random priorities. *)
(* ------------------------------------------------------------------------- *)
local
val randomPriority = randomWord;
val priorityOrder = Word.compare;
in
fun treeSingleton (key,value) =
T {size = 1, priority = randomPriority (),
left = E, key = key, value = value, right = E};
fun nodePriorityOrder cmp (x1 : ('a,'b) node, x2 : ('a,'b) node) =
let
val {priority = p1, key = k1, ...} = x1
and {priority = p2, key = k2, ...} = x2
in
case priorityOrder (p1,p2) of
LESS => LESS
| EQUAL => cmp (k1,k2)
| GREATER => GREATER
end;
end;
(* ------------------------------------------------------------------------- *)
(* Debugging functions. *)
(* ------------------------------------------------------------------------- *)
local
fun checkSizes E = 0
| checkSizes (T {size,left,right,...}) =
let
val l = checkSizes left
and r = checkSizes right
val () = if l + 1 + r = size then () else raise Error "wrong size"
in
size
end;
fun checkSorted _ x E = x
| checkSorted cmp x (T {left,key,right,...}) =
let
val x = checkSorted cmp x left
val () =
case x of
NONE => ()
| SOME k =>
case cmp (k,key) of
LESS => ()
| EQUAL => raise Error "duplicate keys"
| GREATER => raise Error "unsorted"
in
checkSorted cmp (SOME key) right
end;
fun checkPriorities _ E = NONE
| checkPriorities cmp (T (x as {left,right,...})) =
let
val () =
case checkPriorities cmp left of
NONE => ()
| SOME l =>
case nodePriorityOrder cmp (l,x) of
LESS => ()
| EQUAL => raise Error "left child has equal key"
| GREATER => raise Error "left child has greater priority"
val () =
case checkPriorities cmp right of
NONE => ()
| SOME r =>
case nodePriorityOrder cmp (r,x) of
LESS => ()
| EQUAL => raise Error "right child has equal key"
| GREATER => raise Error "right child has greater priority"
in
SOME x
end;
in
fun checkWellformed s (m as Map (cmp,tree)) =
(let
val _ = checkSizes tree
val _ = checkSorted cmp NONE tree
val _ = checkPriorities cmp tree
in
m
end
handle Error err => raise Bug err)
handle Bug bug => raise Bug (s ^ "\nRandomMap.checkWellformed: " ^ bug);
end;
(* ------------------------------------------------------------------------- *)
(* Basic operations. *)
(* ------------------------------------------------------------------------- *)
fun comparison (Map (cmp,_)) = cmp;
fun new cmp = Map (cmp,E);
fun treeSize E = 0
| treeSize (T {size = s, ...}) = s;
fun size (Map (_,tree)) = treeSize tree;
fun mkT p l k v r =
T {size = treeSize l + 1 + treeSize r, priority = p,
left = l, key = k, value = v, right = r};
fun singleton cmp key_value = Map (cmp, treeSingleton key_value);
local
fun treePeek cmp E pkey = NONE
| treePeek cmp (T {left,key,value,right,...}) pkey =
case cmp (pkey,key) of
LESS => treePeek cmp left pkey
| EQUAL => SOME value
| GREATER => treePeek cmp right pkey
in
fun peek (Map (cmp,tree)) key = treePeek cmp tree key;
end;
(* treeAppend assumes that every element of the first tree is less than *)
(* every element of the second tree. *)
fun treeAppend _ t1 E = t1
| treeAppend _ E t2 = t2
| treeAppend cmp (t1 as T x1) (t2 as T x2) =
case nodePriorityOrder cmp (x1,x2) of
LESS =>
let
val {priority = p2,
left = l2, key = k2, value = v2, right = r2, ...} = x2
in
mkT p2 (treeAppend cmp t1 l2) k2 v2 r2
end
| EQUAL => raise Bug "RandomSet.treeAppend: equal keys"
| GREATER =>
let
val {priority = p1,
left = l1, key = k1, value = v1, right = r1, ...} = x1
in
mkT p1 l1 k1 v1 (treeAppend cmp r1 t2)
end;
(* nodePartition splits the node into three parts: the keys comparing less *)
(* than the supplied key, an optional equal key, and the keys comparing *)
(* greater. *)
local
fun mkLeft [] t = t
| mkLeft (({priority,left,key,value,...} : ('a,'b) node) :: xs) t =
mkLeft xs (mkT priority left key value t);
fun mkRight [] t = t
| mkRight (({priority,key,value,right,...} : ('a,'b) node) :: xs) t =
mkRight xs (mkT priority t key value right);
fun treePart _ _ lefts rights E = (mkLeft lefts E, NONE, mkRight rights E)
| treePart cmp pkey lefts rights (T x) = nodePart cmp pkey lefts rights x
and nodePart cmp pkey lefts rights (x as {left,key,value,right,...}) =
case cmp (pkey,key) of
LESS => treePart cmp pkey lefts (x :: rights) left
| EQUAL => (mkLeft lefts left, SOME (key,value), mkRight rights right)
| GREATER => treePart cmp pkey (x :: lefts) rights right;
in
fun nodePartition cmp x pkey = nodePart cmp pkey [] [] x;
end;
(* union first calls treeCombineRemove, to combine the values *)
(* for equal keys into the first map and remove them from the second map. *)
(* Note that the combined key is always the one from the second map. *)
local
fun treeCombineRemove _ _ t1 E = (t1,E)
| treeCombineRemove _ _ E t2 = (E,t2)
| treeCombineRemove cmp f (t1 as T x1) (t2 as T x2) =
let
val {priority = p1,
left = l1, key = k1, value = v1, right = r1, ...} = x1
val (l2,k2_v2,r2) = nodePartition cmp x2 k1
val (l1,l2) = treeCombineRemove cmp f l1 l2
and (r1,r2) = treeCombineRemove cmp f r1 r2
in
case k2_v2 of
NONE =>
if treeSize l2 + treeSize r2 = #size x2 then (t1,t2)
else (mkT p1 l1 k1 v1 r1, treeAppend cmp l2 r2)
| SOME (k2,v2) =>
case f (v1,v2) of
NONE => (treeAppend cmp l1 r1, treeAppend cmp l2 r2)
| SOME v => (mkT p1 l1 k2 v r1, treeAppend cmp l2 r2)
end;
fun treeUnionDisjoint _ t1 E = t1
| treeUnionDisjoint _ E t2 = t2
| treeUnionDisjoint cmp (T x1) (T x2) =
case nodePriorityOrder cmp (x1,x2) of
LESS => nodeUnionDisjoint cmp x2 x1
| EQUAL => raise Bug "RandomSet.unionDisjoint: equal keys"
| GREATER => nodeUnionDisjoint cmp x1 x2
and nodeUnionDisjoint cmp x1 x2 =
let
val {priority = p1,
left = l1, key = k1, value = v1, right = r1, ...} = x1
val (l2,_,r2) = nodePartition cmp x2 k1
val l = treeUnionDisjoint cmp l1 l2
and r = treeUnionDisjoint cmp r1 r2
in
mkT p1 l k1 v1 r
end;
in
fun union f (m1 as Map (cmp,t1)) (Map (_,t2)) =
if pointerEqual (t1,t2) then m1
else
let
val (t1,t2) = treeCombineRemove cmp f t1 t2
in
Map (cmp, treeUnionDisjoint cmp t1 t2)
end;
end;
(*DEBUG
val union = fn f => fn t1 => fn t2 =>
checkWellformed "RandomMap.union: result"
(union f (checkWellformed "RandomMap.union: input 1" t1)
(checkWellformed "RandomMap.union: input 2" t2));
*)
(* intersect is a simple case of the union algorithm. *)
local
fun treeIntersect _ _ _ E = E
| treeIntersect _ _ E _ = E
| treeIntersect cmp f (t1 as T x1) (t2 as T x2) =
let
val {priority = p1,
left = l1, key = k1, value = v1, right = r1, ...} = x1
val (l2,k2_v2,r2) = nodePartition cmp x2 k1
val l = treeIntersect cmp f l1 l2
and r = treeIntersect cmp f r1 r2
in
case k2_v2 of
NONE => treeAppend cmp l r
| SOME (k2,v2) =>
case f (v1,v2) of
NONE => treeAppend cmp l r
| SOME v => mkT p1 l k2 v r
end;
in
fun intersect f (m1 as Map (cmp,t1)) (Map (_,t2)) =
if pointerEqual (t1,t2) then m1
else Map (cmp, treeIntersect cmp f t1 t2);
end;
(*DEBUG
val intersect = fn f => fn t1 => fn t2 =>
checkWellformed "RandomMap.intersect: result"
(intersect f (checkWellformed "RandomMap.intersect: input 1" t1)
(checkWellformed "RandomMap.intersect: input 2" t2));
*)
(* delete raises an exception if the supplied key is not found, which *)
(* makes it simpler to maximize sharing. *)
local
fun treeDelete _ E _ = raise Error "RandomMap.delete: element not found"
| treeDelete cmp (T {priority,left,key,value,right,...}) dkey =
case cmp (dkey,key) of
LESS => mkT priority (treeDelete cmp left dkey) key value right
| EQUAL => treeAppend cmp left right
| GREATER => mkT priority left key value (treeDelete cmp right dkey);
in
fun delete (Map (cmp,tree)) key = Map (cmp, treeDelete cmp tree key);
end;
(*DEBUG
val delete = fn t => fn x =>
checkWellformed "RandomMap.delete: result"
(delete (checkWellformed "RandomMap.delete: input" t) x);
*)
(* Set difference on domains *)
local
fun treeDifference _ t1 E = t1
| treeDifference _ E _ = E
| treeDifference cmp (t1 as T x1) (T x2) =
let
val {size = s1, priority = p1,
left = l1, key = k1, value = v1, right = r1} = x1
val (l2,k2_v2,r2) = nodePartition cmp x2 k1
val l = treeDifference cmp l1 l2
and r = treeDifference cmp r1 r2
in
if Option.isSome k2_v2 then treeAppend cmp l r
else if treeSize l + treeSize r + 1 = s1 then t1
else mkT p1 l k1 v1 r
end;
in
fun difference (Map (cmp,tree1)) (Map (_,tree2)) =
Map (cmp, treeDifference cmp tree1 tree2);
end;
(*DEBUG
val difference = fn t1 => fn t2 =>
checkWellformed "RandomMap.difference: result"
(difference (checkWellformed "RandomMap.difference: input 1" t1)
(checkWellformed "RandomMap.difference: input 2" t2));
*)
(* subsetDomain is mainly used when using maps as sets. *)
local
fun treeSubsetDomain _ E _ = true
| treeSubsetDomain _ _ E = false
| treeSubsetDomain cmp (t1 as T x1) (T x2) =
let
val {size = s1, left = l1, key = k1, right = r1, ...} = x1
and {size = s2, ...} = x2
in
s1 <= s2 andalso
let
val (l2,k2_v2,r2) = nodePartition cmp x2 k1
in
Option.isSome k2_v2 andalso
treeSubsetDomain cmp l1 l2 andalso
treeSubsetDomain cmp r1 r2
end
end;
in
fun subsetDomain (Map (cmp,tree1)) (Map (_,tree2)) =
pointerEqual (tree1,tree2) orelse
treeSubsetDomain cmp tree1 tree2;
end;
(* Map equality *)
local
fun treeEqual _ _ E E = true
| treeEqual _ _ E _ = false
| treeEqual _ _ _ E = false
| treeEqual cmp veq (t1 as T x1) (T x2) =
let
val {size = s1, left = l1, key = k1, value = v1, right = r1, ...} = x1
and {size = s2, ...} = x2
in
s1 = s2 andalso
let
val (l2,k2_v2,r2) = nodePartition cmp x2 k1
in
(case k2_v2 of NONE => false | SOME (_,v2) => veq v1 v2) andalso
treeEqual cmp veq l1 l2 andalso
treeEqual cmp veq r1 r2
end
end;
in
fun equal veq (Map (cmp,tree1)) (Map (_,tree2)) =
pointerEqual (tree1,tree2) orelse
treeEqual cmp veq tree1 tree2;
end;
(* mapPartial is the basic function for preserving the tree structure. *)
(* It applies the argument function to the elements *in order*. *)
local
fun treeMapPartial cmp _ E = E
| treeMapPartial cmp f (T {priority,left,key,value,right,...}) =
let
val left = treeMapPartial cmp f left
and value' = f (key,value)
and right = treeMapPartial cmp f right
in
case value' of
NONE => treeAppend cmp left right
| SOME value => mkT priority left key value right
end;
in
fun mapPartial f (Map (cmp,tree)) = Map (cmp, treeMapPartial cmp f tree);
end;
(* map is a primitive function for efficiency reasons. *)
(* It also applies the argument function to the elements *in order*. *)
local
fun treeMap _ E = E
| treeMap f (T {size,priority,left,key,value,right}) =
let
val left = treeMap f left
and value = f (key,value)
and right = treeMap f right
in
T {size = size, priority = priority, left = left,
key = key, value = value, right = right}
end;
in
fun map f (Map (cmp,tree)) = Map (cmp, treeMap f tree);
end;
(* nth picks the nth smallest key/value (counting from 0). *)
local
fun treeNth E _ = raise Subscript
| treeNth (T {left,key,value,right,...}) n =
let
val k = treeSize left
in
if n = k then (key,value)
else if n < k then treeNth left n
else treeNth right (n - (k + 1))
end;
in
fun nth (Map (_,tree)) n = treeNth tree n;
end;
(* ------------------------------------------------------------------------- *)
(* Iterators. *)
(* ------------------------------------------------------------------------- *)
fun leftSpine E acc = acc
| leftSpine (t as T {left,...}) acc = leftSpine left (t :: acc);
fun rightSpine E acc = acc
| rightSpine (t as T {right,...}) acc = rightSpine right (t :: acc);
datatype ('key,'a) iterator =
LR of ('key * 'a) * ('key,'a) tree * ('key,'a) tree list
| RL of ('key * 'a) * ('key,'a) tree * ('key,'a) tree list;
fun mkLR [] = NONE
| mkLR (T {key,value,right,...} :: l) = SOME (LR ((key,value),right,l))
| mkLR (E :: _) = raise Bug "RandomMap.mkLR";
fun mkRL [] = NONE
| mkRL (T {key,value,left,...} :: l) = SOME (RL ((key,value),left,l))
| mkRL (E :: _) = raise Bug "RandomMap.mkRL";
fun mkIterator (Map (_,tree)) = mkLR (leftSpine tree []);
fun mkRevIterator (Map (_,tree)) = mkRL (rightSpine tree []);
fun readIterator (LR (key_value,_,_)) = key_value
| readIterator (RL (key_value,_,_)) = key_value;
fun advanceIterator (LR (_,next,l)) = mkLR (leftSpine next l)
| advanceIterator (RL (_,next,l)) = mkRL (rightSpine next l);
(* ------------------------------------------------------------------------- *)
(* Derived operations. *)
(* ------------------------------------------------------------------------- *)
fun null m = size m = 0;
fun get m key =
case peek m key of
NONE => raise Error "RandomMap.get: element not found"
| SOME value => value;
fun inDomain key m = Option.isSome (peek m key);
fun insert m key_value =
union (SOME o snd) m (singleton (comparison m) key_value);
(*DEBUG
val insert = fn m => fn x =>
checkWellformed "RandomMap.insert: result"
(insert (checkWellformed "RandomMap.insert: input" m) x);
*)
local
fun fold _ NONE acc = acc
| fold f (SOME iter) acc =
let
val (key,value) = readIterator iter
in
fold f (advanceIterator iter) (f (key,value,acc))
end;
in
fun foldl f b m = fold f (mkIterator m) b;
fun foldr f b m = fold f (mkRevIterator m) b;
end;
local
fun find _ NONE = NONE
| find pred (SOME iter) =
let
val key_value = readIterator iter
in
if pred key_value then SOME key_value
else find pred (advanceIterator iter)
end;
in
fun findl p m = find p (mkIterator m);
fun findr p m = find p (mkRevIterator m);
end;
local
fun first _ NONE = NONE
| first f (SOME iter) =
let
val key_value = readIterator iter
in
case f key_value of
NONE => first f (advanceIterator iter)
| s => s
end;
in
fun firstl f m = first f (mkIterator m);
fun firstr f m = first f (mkRevIterator m);
end;
fun fromList cmp l = List.foldl (fn (k_v,m) => insert m k_v) (new cmp) l;
fun insertList m l = union (SOME o snd) m (fromList (comparison m) l);
fun filter p =
let
fun f (key_value as (_,value)) =
if p key_value then SOME value else NONE
in
mapPartial f
end;
fun app f m = foldl (fn (key,value,()) => f (key,value)) () m;
fun transform f = map (fn (_,value) => f value);
fun toList m = foldr (fn (key,value,l) => (key,value) :: l) [] m;
fun domain m = foldr (fn (key,_,l) => key :: l) [] m;
fun exists p m = Option.isSome (findl p m);
fun all p m = not (exists (not o p) m);
fun random m =
case size m of
0 => raise Error "RandomMap.random: empty"
| n => nth m (randomInt n);
local
fun iterCompare _ _ NONE NONE = EQUAL
| iterCompare _ _ NONE (SOME _) = LESS
| iterCompare _ _ (SOME _) NONE = GREATER
| iterCompare kcmp vcmp (SOME i1) (SOME i2) =
keyIterCompare kcmp vcmp (readIterator i1) (readIterator i2) i1 i2
and keyIterCompare kcmp vcmp (k1,v1) (k2,v2) i1 i2 =
case kcmp (k1,k2) of
LESS => LESS
| EQUAL =>
(case vcmp (v1,v2) of
LESS => LESS
| EQUAL =>
iterCompare kcmp vcmp (advanceIterator i1) (advanceIterator i2)
| GREATER => GREATER)
| GREATER => GREATER;
in
fun compare vcmp (m1,m2) =
if pointerEqual (m1,m2) then EQUAL
else
case Int.compare (size m1, size m2) of
LESS => LESS
| EQUAL =>
iterCompare (comparison m1) vcmp (mkIterator m1) (mkIterator m2)
| GREATER => GREATER;
end;
fun equalDomain m1 m2 = equal (K (K true)) m1 m2;
fun toString m = "<" ^ (if null m then "" else Int.toString (size m)) ^ ">";
end
end;
(**** Original file: Map.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* FINITE MAPS *)
(* Copyright (c) 2004-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Map = RandomMap;
end;
(**** Original file: KeyMap.sig ****)
(* ========================================================================= *)
(* FINITE MAPS WITH A FIXED KEY TYPE *)
(* Copyright (c) 2004-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature KeyMap =
sig
type key
(* ------------------------------------------------------------------------- *)
(* Finite maps *)
(* ------------------------------------------------------------------------- *)
type 'a map
val new : unit -> 'a map
val null : 'a map -> bool
val size : 'a map -> int
val singleton : key * 'a -> 'a map
val inDomain : key -> 'a map -> bool
val peek : 'a map -> key -> 'a option
val insert : 'a map -> key * 'a -> 'a map
val insertList : 'a map -> (key * 'a) list -> 'a map
val get : 'a map -> key -> 'a (* raises Error *)
(* Union and intersect prefer keys in the second map *)
val union : ('a * 'a -> 'a option) -> 'a map -> 'a map -> 'a map
val intersect : ('a * 'a -> 'a option) -> 'a map -> 'a map -> 'a map
val delete : 'a map -> key -> 'a map (* raises Error *)
val difference : 'a map -> 'a map -> 'a map
val subsetDomain : 'a map -> 'a map -> bool
val equalDomain : 'a map -> 'a map -> bool
val mapPartial : (key * 'a -> 'b option) -> 'a map -> 'b map
val filter : (key * 'a -> bool) -> 'a map -> 'a map
val map : (key * 'a -> 'b) -> 'a map -> 'b map
val app : (key * 'a -> unit) -> 'a map -> unit
val transform : ('a -> 'b) -> 'a map -> 'b map
val foldl : (key * 'a * 's -> 's) -> 's -> 'a map -> 's
val foldr : (key * 'a * 's -> 's) -> 's -> 'a map -> 's
val findl : (key * 'a -> bool) -> 'a map -> (key * 'a) option
val findr : (key * 'a -> bool) -> 'a map -> (key * 'a) option
val firstl : (key * 'a -> 'b option) -> 'a map -> 'b option
val firstr : (key * 'a -> 'b option) -> 'a map -> 'b option
val exists : (key * 'a -> bool) -> 'a map -> bool
val all : (key * 'a -> bool) -> 'a map -> bool
val domain : 'a map -> key list
val toList : 'a map -> (key * 'a) list
val fromList : (key * 'a) list -> 'a map
val compare : ('a * 'a -> order) -> 'a map * 'a map -> order
val equal : ('a -> 'a -> bool) -> 'a map -> 'a map -> bool
val random : 'a map -> key * 'a (* raises Empty *)
val toString : 'a map -> string
(* ------------------------------------------------------------------------- *)
(* Iterators over maps *)
(* ------------------------------------------------------------------------- *)
type 'a iterator
val mkIterator : 'a map -> 'a iterator option
val mkRevIterator : 'a map -> 'a iterator option
val readIterator : 'a iterator -> key * 'a
val advanceIterator : 'a iterator -> 'a iterator option
end
(**** Original file: KeyMap.sml ****)
(* ========================================================================= *)
(* FINITE MAPS WITH A FIXED KEY TYPE *)
(* Copyright (c) 2004-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
functor KeyMap (Key : Ordered) :> KeyMap where type key = Key.t =
struct
open Metis;
type key = Key.t;
(* ------------------------------------------------------------------------- *)
(* Finite maps *)
(* ------------------------------------------------------------------------- *)
type 'a map = (Key.t,'a) Map.map;
fun new () = Map.new Key.compare;
val null = Map.null;
val size = Map.size;
fun singleton key_value = Map.singleton Key.compare key_value;
val inDomain = Map.inDomain;
val peek = Map.peek;
val insert = Map.insert;
val insertList = Map.insertList;
val get = Map.get;
(* Both op union and intersect prefer keys in the second map *)
val op union = Map.union;
val intersect = Map.intersect;
val delete = Map.delete;
val difference = Map.difference;
val subsetDomain = Map.subsetDomain;
val equalDomain = Map.equalDomain;
val mapPartial = Map.mapPartial;
val filter = Map.filter;
val map = Map.map;
val app = Map.app;
val transform = Map.transform;
val foldl = Map.foldl;
val foldr = Map.foldr;
val findl = Map.findl;
val findr = Map.findr;
val firstl = Map.firstl;
val firstr = Map.firstr;
val exists = Map.exists;
val all = Map.all;
val domain = Map.domain;
val toList = Map.toList;
fun fromList l = Map.fromList Key.compare l;
val compare = Map.compare;
val equal = Map.equal;
val random = Map.random;
val toString = Map.toString;
(* ------------------------------------------------------------------------- *)
(* Iterators over maps *)
(* ------------------------------------------------------------------------- *)
type 'a iterator = (Key.t,'a) Map.iterator;
val mkIterator = Map.mkIterator;
val mkRevIterator = Map.mkRevIterator;
val readIterator = Map.readIterator;
val advanceIterator = Map.advanceIterator;
end
structure Metis = struct open Metis
structure IntMap =
KeyMap (IntOrdered);
structure StringMap =
KeyMap (StringOrdered);
end;
(**** Original file: Sharing.sig ****)
(* ========================================================================= *)
(* PRESERVING SHARING OF ML VALUES *)
(* Copyright (c) 2005-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Sharing =
sig
(* ------------------------------------------------------------------------- *)
(* Pointer equality. *)
(* ------------------------------------------------------------------------- *)
val pointerEqual : 'a * 'a -> bool
(* ------------------------------------------------------------------------- *)
(* List operations. *)
(* ------------------------------------------------------------------------- *)
val map : ('a -> 'a) -> 'a list -> 'a list
val updateNth : int * 'a -> 'a list -> 'a list
val setify : ''a list -> ''a list
(* ------------------------------------------------------------------------- *)
(* Function caching. *)
(* ------------------------------------------------------------------------- *)
val cache : ('a * 'a -> order) -> ('a -> 'b) -> 'a -> 'b
(* ------------------------------------------------------------------------- *)
(* Hash consing. *)
(* ------------------------------------------------------------------------- *)
val hashCons : ('a * 'a -> order) -> 'a -> 'a
end
(**** Original file: Sharing.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* PRESERVING SHARING OF ML VALUES *)
(* Copyright (c) 2005-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Sharing :> Sharing =
struct
infix ==
(* ------------------------------------------------------------------------- *)
(* Pointer equality. *)
(* ------------------------------------------------------------------------- *)
val pointerEqual = Portable.pointerEqual;
val op== = pointerEqual;
(* ------------------------------------------------------------------------- *)
(* List operations. *)
(* ------------------------------------------------------------------------- *)
fun map f =
let
fun m _ a_b [] = List.revAppend a_b
| m ys a_b (x :: xs) =
let
val y = f x
val ys = y :: ys
in
m ys (if x == y then a_b else (ys,xs)) xs
end
in
fn l => m [] ([],l) l
end;
fun updateNth (n,x) l =
let
val (a,b) = Useful.revDivide l n
in
case b of
[] => raise Subscript
| h :: t => if x == h then l else List.revAppend (a, x :: t)
end;
fun setify l =
let
val l' = Useful.setify l
in
if length l' = length l then l else l'
end;
(* ------------------------------------------------------------------------- *)
(* Function caching. *)
(* ------------------------------------------------------------------------- *)
fun cache cmp f =
let
val cache = Unsynchronized.ref (Map.new cmp)
in
fn a =>
case Map.peek (!cache) a of
SOME b => b
| NONE =>
let
val b = f a
val () = cache := Map.insert (!cache) (a,b)
in
b
end
end;
(* ------------------------------------------------------------------------- *)
(* Hash consing. *)
(* ------------------------------------------------------------------------- *)
fun hashCons cmp = cache cmp Useful.I;
end
end;
(**** Original file: Stream.sig ****)
(* ========================================================================= *)
(* A POSSIBLY-INFINITE STREAM DATATYPE FOR ML *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Stream =
sig
(* ------------------------------------------------------------------------- *)
(* The stream type *)
(* ------------------------------------------------------------------------- *)
datatype 'a stream = NIL | CONS of 'a * (unit -> 'a stream)
(* If you're wondering how to create an infinite stream: *)
(* val stream4 = let fun s4 () = Metis.Stream.CONS (4,s4) in s4 () end; *)
(* ------------------------------------------------------------------------- *)
(* Stream constructors *)
(* ------------------------------------------------------------------------- *)
val repeat : 'a -> 'a stream
val count : int -> int stream
val funpows : ('a -> 'a) -> 'a -> 'a stream
(* ------------------------------------------------------------------------- *)
(* Stream versions of standard list operations: these should all terminate *)
(* ------------------------------------------------------------------------- *)
val cons : 'a -> (unit -> 'a stream) -> 'a stream
val null : 'a stream -> bool
val hd : 'a stream -> 'a (* raises Empty *)
val tl : 'a stream -> 'a stream (* raises Empty *)
val hdTl : 'a stream -> 'a * 'a stream (* raises Empty *)
val singleton : 'a -> 'a stream
val append : 'a stream -> (unit -> 'a stream) -> 'a stream
val map : ('a -> 'b) -> 'a stream -> 'b stream
val maps : ('a -> 's -> 'b * 's) -> 's -> 'a stream -> 'b stream
val zipwith : ('a -> 'b -> 'c) -> 'a stream -> 'b stream -> 'c stream
val zip : 'a stream -> 'b stream -> ('a * 'b) stream
val take : int -> 'a stream -> 'a stream (* raises Subscript *)
val drop : int -> 'a stream -> 'a stream (* raises Subscript *)
(* ------------------------------------------------------------------------- *)
(* Stream versions of standard list operations: these might not terminate *)
(* ------------------------------------------------------------------------- *)
val length : 'a stream -> int
val exists : ('a -> bool) -> 'a stream -> bool
val all : ('a -> bool) -> 'a stream -> bool
val filter : ('a -> bool) -> 'a stream -> 'a stream
val foldl : ('a * 's -> 's) -> 's -> 'a stream -> 's
val concat : 'a stream stream -> 'a stream
val mapPartial : ('a -> 'b option) -> 'a stream -> 'b stream
val mapsPartial : ('a -> 's -> 'b option * 's) -> 's -> 'a stream -> 'b stream
(* ------------------------------------------------------------------------- *)
(* Stream operations *)
(* ------------------------------------------------------------------------- *)
val memoize : 'a stream -> 'a stream
val toList : 'a stream -> 'a list
val fromList : 'a list -> 'a stream
val toString : char stream -> string
val fromString : string -> char stream
val toTextFile : {filename : string} -> string stream -> unit
val fromTextFile : {filename : string} -> string stream (* line by line *)
end
(**** Original file: Stream.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* A POSSIBLY-INFINITE STREAM DATATYPE FOR ML *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Stream :> Stream =
struct
val K = Useful.K;
val pair = Useful.pair;
val funpow = Useful.funpow;
(* ------------------------------------------------------------------------- *)
(* The datatype declaration encapsulates all the primitive operations *)
(* ------------------------------------------------------------------------- *)
datatype 'a stream =
NIL
| CONS of 'a * (unit -> 'a stream);
(* ------------------------------------------------------------------------- *)
(* Stream constructors *)
(* ------------------------------------------------------------------------- *)
fun repeat x = let fun rep () = CONS (x,rep) in rep () end;
fun count n = CONS (n, fn () => count (n + 1));
fun funpows f x = CONS (x, fn () => funpows f (f x));
(* ------------------------------------------------------------------------- *)
(* Stream versions of standard list operations: these should all terminate *)
(* ------------------------------------------------------------------------- *)
fun cons h t = CONS (h,t);
fun null NIL = true | null (CONS _) = false;
fun hd NIL = raise Empty
| hd (CONS (h,_)) = h;
fun tl NIL = raise Empty
| tl (CONS (_,t)) = t ();
fun hdTl s = (hd s, tl s);
fun singleton s = CONS (s, K NIL);
fun append NIL s = s ()
| append (CONS (h,t)) s = CONS (h, fn () => append (t ()) s);
fun map f =
let
fun m NIL = NIL
| m (CONS (h, t)) = CONS (f h, fn () => m (t ()))
in
m
end;
fun maps f =
let
fun mm _ NIL = NIL
| mm s (CONS (x, xs)) =
let
val (y, s') = f x s
in
CONS (y, fn () => mm s' (xs ()))
end
in
mm
end;
fun zipwith f =
let
fun z NIL _ = NIL
| z _ NIL = NIL
| z (CONS (x,xs)) (CONS (y,ys)) =
CONS (f x y, fn () => z (xs ()) (ys ()))
in
z
end;
fun zip s t = zipwith pair s t;
fun take 0 _ = NIL
| take n NIL = raise Subscript
| take 1 (CONS (x,_)) = CONS (x, K NIL)
| take n (CONS (x,xs)) = CONS (x, fn () => take (n - 1) (xs ()));
fun drop n s = funpow n tl s handle Empty => raise Subscript;
(* ------------------------------------------------------------------------- *)
(* Stream versions of standard list operations: these might not terminate *)
(* ------------------------------------------------------------------------- *)
local
fun len n NIL = n
| len n (CONS (_,t)) = len (n + 1) (t ());
in
fun length s = len 0 s;
end;
fun exists pred =
let
fun f NIL = false
| f (CONS (h,t)) = pred h orelse f (t ())
in
f
end;
fun all pred = not o exists (not o pred);
fun filter p NIL = NIL
| filter p (CONS (x,xs)) =
if p x then CONS (x, fn () => filter p (xs ())) else filter p (xs ());
fun foldl f =
let
fun fold b NIL = b
| fold b (CONS (h,t)) = fold (f (h,b)) (t ())
in
fold
end;
fun concat NIL = NIL
| concat (CONS (NIL, ss)) = concat (ss ())
| concat (CONS (CONS (x, xs), ss)) =
CONS (x, fn () => concat (CONS (xs (), ss)));
fun mapPartial f =
let
fun mp NIL = NIL
| mp (CONS (h,t)) =
case f h of
NONE => mp (t ())
| SOME h' => CONS (h', fn () => mp (t ()))
in
mp
end;
fun mapsPartial f =
let
fun mm _ NIL = NIL
| mm s (CONS (x, xs)) =
let
val (yo, s') = f x s
val t = mm s' o xs
in
case yo of NONE => t () | SOME y => CONS (y, t)
end
in
mm
end;
(* ------------------------------------------------------------------------- *)
(* Stream operations *)
(* ------------------------------------------------------------------------- *)
fun memoize NIL = NIL
| memoize (CONS (h,t)) = CONS (h, Lazy.memoize (fn () => memoize (t ())));
local
fun toLst res NIL = rev res
| toLst res (CONS (x, xs)) = toLst (x :: res) (xs ());
in
fun toList s = toLst [] s;
end;
fun fromList [] = NIL
| fromList (x :: xs) = CONS (x, fn () => fromList xs);
fun toString s = implode (toList s);
fun fromString s = fromList (explode s);
fun toTextFile {filename = f} s =
let
val (h,close) =
if f = "-" then (TextIO.stdOut, K ())
else (TextIO.openOut f, TextIO.closeOut)
fun toFile NIL = ()
| toFile (CONS (x,y)) = (TextIO.output (h,x); toFile (y ()))
val () = toFile s
in
close h
end;
fun fromTextFile {filename = f} =
let
val (h,close) =
if f = "-" then (TextIO.stdIn, K ())
else (TextIO.openIn f, TextIO.closeIn)
fun strm () =
case TextIO.inputLine h of
NONE => (close h; NIL)
| SOME s => CONS (s,strm)
in
memoize (strm ())
end;
end
end;
(**** Original file: Heap.sig ****)
(* ========================================================================= *)
(* A HEAP DATATYPE FOR ML *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Heap =
sig
type 'a heap
val new : ('a * 'a -> order) -> 'a heap
val add : 'a heap -> 'a -> 'a heap
val null : 'a heap -> bool
val top : 'a heap -> 'a (* raises Empty *)
val remove : 'a heap -> 'a * 'a heap (* raises Empty *)
val size : 'a heap -> int
val app : ('a -> unit) -> 'a heap -> unit
val toList : 'a heap -> 'a list
val toStream : 'a heap -> 'a Metis.Stream.stream
val toString : 'a heap -> string
end
(**** Original file: Heap.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* A HEAP DATATYPE FOR ML *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Heap :> Heap =
struct
(* Leftist heaps as in Purely Functional Data Structures, by Chris Okasaki *)
datatype 'a node = E | T of int * 'a * 'a node * 'a node;
datatype 'a heap = Heap of ('a * 'a -> order) * int * 'a node;
fun rank E = 0
| rank (T (r,_,_,_)) = r;
fun makeT (x,a,b) =
if rank a >= rank b then T (rank b + 1, x, a, b) else T (rank a + 1, x, b, a);
fun merge cmp =
let
fun mrg (h,E) = h
| mrg (E,h) = h
| mrg (h1 as T (_,x,a1,b1), h2 as T (_,y,a2,b2)) =
case cmp (x,y) of
GREATER => makeT (y, a2, mrg (h1,b2))
| _ => makeT (x, a1, mrg (b1,h2))
in
mrg
end;
fun new cmp = Heap (cmp,0,E);
fun add (Heap (f,n,a)) x = Heap (f, n + 1, merge f (T (1,x,E,E), a));
fun size (Heap (_, n, _)) = n;
fun null h = size h = 0;
fun top (Heap (_,_,E)) = raise Empty
| top (Heap (_, _, T (_,x,_,_))) = x;
fun remove (Heap (_,_,E)) = raise Empty
| remove (Heap (f, n, T (_,x,a,b))) = (x, Heap (f, n - 1, merge f (a,b)));
fun app f =
let
fun ap [] = ()
| ap (E :: rest) = ap rest
| ap (T (_,d,a,b) :: rest) = (f d; ap (a :: b :: rest))
in
fn Heap (_,_,a) => ap [a]
end;
fun toList h =
if null h then []
else
let
val (x,h) = remove h
in
x :: toList h
end;
fun toStream h =
if null h then Stream.NIL
else
let
val (x,h) = remove h
in
Stream.CONS (x, fn () => toStream h)
end;
fun toString h =
"Heap[" ^ (if null h then "" else Int.toString (size h)) ^ "]";
end
end;
(**** Original file: Parser.sig ****)
(* ========================================================================= *)
(* PARSING AND PRETTY PRINTING *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Parser =
sig
(* ------------------------------------------------------------------------- *)
(* Pretty printing for built-in types *)
(* ------------------------------------------------------------------------- *)
type ppstream = Metis.PP.ppstream
datatype breakStyle = Consistent | Inconsistent
type 'a pp = ppstream -> 'a -> unit
val lineLength : int Unsynchronized.ref
val beginBlock : ppstream -> breakStyle -> int -> unit
val endBlock : ppstream -> unit
val addString : ppstream -> string -> unit
val addBreak : ppstream -> int * int -> unit
val addNewline : ppstream -> unit
val ppMap : ('a -> 'b) -> 'b pp -> 'a pp
val ppBracket : string -> string -> 'a pp -> 'a pp
val ppSequence : string -> 'a pp -> 'a list pp
val ppBinop : string -> 'a pp -> 'b pp -> ('a * 'b) pp
val ppChar : char pp
val ppString : string pp
val ppUnit : unit pp
val ppBool : bool pp
val ppInt : int pp
val ppReal : real pp
val ppOrder : order pp
val ppList : 'a pp -> 'a list pp
val ppOption : 'a pp -> 'a option pp
val ppPair : 'a pp -> 'b pp -> ('a * 'b) pp
val ppTriple : 'a pp -> 'b pp -> 'c pp -> ('a * 'b * 'c) pp
val toString : 'a pp -> 'a -> string (* Uses !lineLength *)
val fromString : ('a -> string) -> 'a pp
val ppTrace : 'a pp -> string -> 'a -> unit
(* ------------------------------------------------------------------------- *)
(* Recursive descent parsing combinators *)
(* ------------------------------------------------------------------------- *)
(* Generic parsers
Recommended fixities:
infixr 9 >>++
infixr 8 ++
infixr 7 >>
infixr 6 ||
*)
exception NoParse
val error : 'a -> 'b * 'a
val ++ : ('a -> 'b * 'a) * ('a -> 'c * 'a) -> 'a -> ('b * 'c) * 'a
val >> : ('a -> 'b * 'a) * ('b -> 'c) -> 'a -> 'c * 'a
val >>++ : ('a -> 'b * 'a) * ('b -> 'a -> 'c * 'a) -> 'a -> 'c * 'a
val || : ('a -> 'b * 'a) * ('a -> 'b * 'a) -> 'a -> 'b * 'a
val first : ('a -> 'b * 'a) list -> 'a -> 'b * 'a
val mmany : ('s -> 'a -> 's * 'a) -> 's -> 'a -> 's * 'a
val many : ('a -> 'b * 'a) -> 'a -> 'b list * 'a
val atLeastOne : ('a -> 'b * 'a) -> 'a -> 'b list * 'a
val nothing : 'a -> unit * 'a
val optional : ('a -> 'b * 'a) -> 'a -> 'b option * 'a
(* Stream based parsers *)
type ('a,'b) parser = 'a Metis.Stream.stream -> 'b * 'a Metis.Stream.stream
val everything : ('a, 'b list) parser -> 'a Metis.Stream.stream -> 'b Metis.Stream.stream
val maybe : ('a -> 'b option) -> ('a,'b) parser
val finished : ('a,unit) parser
val some : ('a -> bool) -> ('a,'a) parser
val any : ('a,'a) parser
val exact : ''a -> (''a,''a) parser
(* ------------------------------------------------------------------------- *)
(* Infix operators *)
(* ------------------------------------------------------------------------- *)
type infixities = {token : string, precedence : int, leftAssoc : bool} list
val infixTokens : infixities -> string list
val parseInfixes :
infixities -> (string * 'a * 'a -> 'a) -> (string,'a) parser ->
(string,'a) parser
val ppInfixes :
infixities -> ('a -> (string * 'a * 'a) option) -> ('a * bool) pp ->
('a * bool) pp
(* ------------------------------------------------------------------------- *)
(* Quotations *)
(* ------------------------------------------------------------------------- *)
type 'a quotation = 'a Metis.frag list
val parseQuotation : ('a -> string) -> (string -> 'b) -> 'a quotation -> 'b
end
(**** Original file: Parser.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* PARSER COMBINATORS *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Parser :> Parser =
struct
infixr 9 >>++
infixr 8 ++
infixr 7 >>
infixr 6 ||
(* ------------------------------------------------------------------------- *)
(* Helper functions. *)
(* ------------------------------------------------------------------------- *)
exception Bug = Useful.Bug;
val trace = Useful.trace
and equal = Useful.equal
and I = Useful.I
and K = Useful.K
and C = Useful.C
and fst = Useful.fst
and snd = Useful.snd
and pair = Useful.pair
and curry = Useful.curry
and funpow = Useful.funpow
and mem = Useful.mem
and sortMap = Useful.sortMap;
(* ------------------------------------------------------------------------- *)
(* Pretty printing for built-in types *)
(* ------------------------------------------------------------------------- *)
type ppstream = PP.ppstream
datatype breakStyle = Consistent | Inconsistent
type 'a pp = PP.ppstream -> 'a -> unit;
val lineLength = Unsynchronized.ref 75;
fun beginBlock pp Consistent = PP.begin_block pp PP.CONSISTENT
| beginBlock pp Inconsistent = PP.begin_block pp PP.INCONSISTENT;
val endBlock = PP.end_block
and addString = PP.add_string
and addBreak = PP.add_break
and addNewline = PP.add_newline;
fun ppMap f ppA (ppstrm : PP.ppstream) x : unit = ppA ppstrm (f x);
fun ppBracket l r ppA pp a =
let
val ln = size l
in
beginBlock pp Inconsistent ln;
if ln = 0 then () else addString pp l;
ppA pp a;
if r = "" then () else addString pp r;
endBlock pp
end;
fun ppSequence sep ppA pp =
let
fun ppX x = (addString pp sep; addBreak pp (1,0); ppA pp x)
in
fn [] => ()
| h :: t =>
(beginBlock pp Inconsistent 0;
ppA pp h;
app ppX t;
endBlock pp)
end;
fun ppBinop s ppA ppB pp (a,b) =
(beginBlock pp Inconsistent 0;
ppA pp a;
if s = "" then () else addString pp s;
addBreak pp (1,0);
ppB pp b;
endBlock pp);
fun ppTrinop ab bc ppA ppB ppC pp (a,b,c) =
(beginBlock pp Inconsistent 0;
ppA pp a;
if ab = "" then () else addString pp ab;
addBreak pp (1,0);
ppB pp b;
if bc = "" then () else addString pp bc;
addBreak pp (1,0);
ppC pp c;
endBlock pp);
(* Pretty-printers for common types *)
fun ppString pp s =
(beginBlock pp Inconsistent 0;
addString pp s;
endBlock pp);
val ppUnit = ppMap (fn () => "()") ppString;
val ppChar = ppMap str ppString;
val ppBool = ppMap (fn true => "true" | false => "false") ppString;
val ppInt = ppMap Int.toString ppString;
val ppReal = ppMap Real.toString ppString;
val ppOrder =
let
fun f LESS = "Less"
| f EQUAL = "Equal"
| f GREATER = "Greater"
in
ppMap f ppString
end;
fun ppList ppA = ppBracket "[" "]" (ppSequence "," ppA);
fun ppOption _ pp NONE = ppString pp "-"
| ppOption ppA pp (SOME a) = ppA pp a;
fun ppPair ppA ppB = ppBracket "(" ")" (ppBinop "," ppA ppB);
fun ppTriple ppA ppB ppC = ppBracket "(" ")" (ppTrinop "," "," ppA ppB ppC);
(* Keep eta expanded to evaluate lineLength when supplied with a *)
fun toString ppA a = PP.pp_to_string (!lineLength) ppA a;
fun fromString toS = ppMap toS ppString;
fun ppTrace ppX nameX x =
trace (toString (ppBinop " =" ppString ppX) (nameX,x) ^ "\n");
(* ------------------------------------------------------------------------- *)
(* Generic. *)
(* ------------------------------------------------------------------------- *)
exception NoParse;
val error : 'a -> 'b * 'a = fn _ => raise NoParse;
fun op ++ (parser1,parser2) input =
let
val (result1,input) = parser1 input
val (result2,input) = parser2 input
in
((result1,result2),input)
end;
fun op >> (parser : 'a -> 'b * 'a, treatment) input =
let
val (result,input) = parser input
in
(treatment result, input)
end;
fun op >>++ (parser,treatment) input =
let
val (result,input) = parser input
in
treatment result input
end;
fun op || (parser1,parser2) input =
parser1 input handle NoParse => parser2 input;
fun first [] _ = raise NoParse
| first (parser :: parsers) input = (parser || first parsers) input;
fun mmany parser state input =
let
val (state,input) = parser state input
in
mmany parser state input
end
handle NoParse => (state,input);
fun many parser =
let
fun sparser l = parser >> (fn x => x :: l)
in
mmany sparser [] >> rev
end;
fun atLeastOne p = (p ++ many p) >> op::;
fun nothing input = ((),input);
fun optional p = (p >> SOME) || (nothing >> K NONE);
(* ------------------------------------------------------------------------- *)
(* Stream-based. *)
(* ------------------------------------------------------------------------- *)
type ('a,'b) parser = 'a Stream.stream -> 'b * 'a Stream.stream
fun everything parser =
let
fun f input =
let
val (result,input) = parser input
in
Stream.append (Stream.fromList result) (fn () => f input)
end
handle NoParse =>
if Stream.null input then Stream.NIL else raise NoParse
in
f
end;
fun maybe p Stream.NIL = raise NoParse
| maybe p (Stream.CONS (h,t)) =
case p h of SOME r => (r, t ()) | NONE => raise NoParse;
fun finished Stream.NIL = ((), Stream.NIL)
| finished (Stream.CONS _) = raise NoParse;
fun some p = maybe (fn x => if p x then SOME x else NONE);
fun any input = some (K true) input;
fun exact tok = some (fn item => item = tok);
(* ------------------------------------------------------------------------- *)
(* Parsing and pretty-printing for infix operators. *)
(* ------------------------------------------------------------------------- *)
type infixities = {token : string, precedence : int, leftAssoc : bool} list;
local
fun unflatten ({token,precedence,leftAssoc}, ([],_)) =
([(leftAssoc, [token])], precedence)
| unflatten ({token,precedence,leftAssoc}, ((a,l) :: dealt, p)) =
if p = precedence then
let
val _ = leftAssoc = a orelse
raise Bug "infix parser/printer: mixed assocs"
in
((a, token :: l) :: dealt, p)
end
else
((leftAssoc,[token]) :: (a,l) :: dealt, precedence);
in
fun layerOps infixes =
let
val infixes = sortMap #precedence Int.compare infixes
val (parsers,_) = foldl unflatten ([],0) infixes
in
parsers
end;
end;
local
fun chop (#" " :: chs) = let val (n,l) = chop chs in (n + 1, l) end
| chop chs = (0,chs);
fun nspaces n = funpow n (curry op^ " ") "";
fun spacify tok =
let
val chs = explode tok
val (r,chs) = chop (rev chs)
val (l,chs) = chop (rev chs)
in
((l,r), implode chs)
end;
fun lrspaces (l,r) =
(if l = 0 then K () else C addString (nspaces l),
if r = 0 then K () else C addBreak (r, 0));
in
fun opSpaces s = let val (l_r,s) = spacify s in (lrspaces l_r, s) end;
val opClean = snd o spacify;
end;
val infixTokens : infixities -> string list =
List.map (fn {token,...} => opClean token);
fun parseGenInfix update sof toks parse inp =
let
val (e, rest) = parse inp
val continue =
case rest of
Stream.NIL => NONE
| Stream.CONS (h, t) => if mem h toks then SOME (h, t) else NONE
in
case continue of
NONE => (sof e, rest)
| SOME (h,t) => parseGenInfix update (update sof h e) toks parse (t ())
end;
fun parseLeftInfix toks con =
parseGenInfix (fn f => fn t => fn a => fn b => con (t, f a, b)) I toks;
fun parseRightInfix toks con =
parseGenInfix (fn f => fn t => fn a => fn b => f (con (t, a, b))) I toks;
fun parseInfixes ops =
let
fun layeredOp (x,y) = (x, List.map opClean y)
val layeredOps = List.map layeredOp (layerOps ops)
fun iparser (a,t) = (if a then parseLeftInfix else parseRightInfix) t
val iparsers = List.map iparser layeredOps
in
fn con => fn subparser => foldl (fn (p,sp) => p con sp) subparser iparsers
end;
fun ppGenInfix left toks =
let
val spc = List.map opSpaces toks
in
fn dest => fn ppSub =>
let
fun dest' tm =
case dest tm of
NONE => NONE
| SOME (t, a, b) =>
Option.map (pair (a,b)) (List.find (equal t o snd) spc)
open PP
fun ppGo pp (tmr as (tm,r)) =
case dest' tm of
NONE => ppSub pp tmr
| SOME ((a,b),((lspc,rspc),tok)) =>
((if left then ppGo else ppSub) pp (a,true);
lspc pp; addString pp tok; rspc pp;
(if left then ppSub else ppGo) pp (b,r))
in
fn pp => fn tmr as (tm,_) =>
case dest' tm of
NONE => ppSub pp tmr
| SOME _ => (beginBlock pp Inconsistent 0; ppGo pp tmr; endBlock pp)
end
end;
fun ppLeftInfix toks = ppGenInfix true toks;
fun ppRightInfix toks = ppGenInfix false toks;
fun ppInfixes ops =
let
val layeredOps = layerOps ops
val toks = List.concat (List.map (List.map opClean o snd) layeredOps)
fun iprinter (a,t) = (if a then ppLeftInfix else ppRightInfix) t
val iprinters = List.map iprinter layeredOps
in
fn dest => fn ppSub =>
let
fun printer sub = foldl (fn (ip,p) => ip dest p) sub iprinters
fun isOp t = case dest t of SOME (x,_,_) => mem x toks | _ => false
open PP
fun subpr pp (tmr as (tm,_)) =
if isOp tm then
(beginBlock pp Inconsistent 1; addString pp "(";
printer subpr pp (tm, false); addString pp ")"; endBlock pp)
else ppSub pp tmr
in
fn pp => fn tmr =>
(beginBlock pp Inconsistent 0; printer subpr pp tmr; endBlock pp)
end
end;
(* ------------------------------------------------------------------------- *)
(* Quotations *)
(* ------------------------------------------------------------------------- *)
type 'a quotation = 'a frag list;
fun parseQuotation printer parser quote =
let
fun expand (QUOTE q, s) = s ^ q
| expand (ANTIQUOTE a, s) = s ^ printer a
val string = foldl expand "" quote
in
parser string
end;
end
end;
(**** Original file: Options.sig ****)
(* ========================================================================= *)
(* PROCESSING COMMAND LINE OPTIONS *)
(* Copyright (c) 2003-2004 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Options =
sig
(* ------------------------------------------------------------------------- *)
(* Option processors take an option with its associated arguments. *)
(* ------------------------------------------------------------------------- *)
type proc = string * string list -> unit
type ('a,'x) mkProc = ('x -> proc) -> ('a -> 'x) -> proc
(* ------------------------------------------------------------------------- *)
(* One command line option: names, arguments, description and a processor. *)
(* ------------------------------------------------------------------------- *)
type opt =
{switches : string list, arguments : string list,
description : string, processor : proc}
(* ------------------------------------------------------------------------- *)
(* Option processors may raise an OptionExit exception. *)
(* ------------------------------------------------------------------------- *)
type optionExit = {message : string option, usage : bool, success : bool}
exception OptionExit of optionExit
(* ------------------------------------------------------------------------- *)
(* Constructing option processors. *)
(* ------------------------------------------------------------------------- *)
val beginOpt : (string,'x) mkProc
val endOpt : unit -> proc
val stringOpt : (string,'x) mkProc
val intOpt : int option * int option -> (int,'x) mkProc
val realOpt : real option * real option -> (real,'x) mkProc
val enumOpt : string list -> (string,'x) mkProc
val optionOpt : string * ('a,'x) mkProc -> ('a option,'x) mkProc
(* ------------------------------------------------------------------------- *)
(* Basic options useful for all programs. *)
(* ------------------------------------------------------------------------- *)
val basicOptions : opt list
(* ------------------------------------------------------------------------- *)
(* All the command line options of a program. *)
(* ------------------------------------------------------------------------- *)
type allOptions =
{name : string, version : string, header : string,
footer : string, options : opt list}
(* ------------------------------------------------------------------------- *)
(* Usage information. *)
(* ------------------------------------------------------------------------- *)
val versionInformation : allOptions -> string
val usageInformation : allOptions -> string
(* ------------------------------------------------------------------------- *)
(* Exit the program gracefully. *)
(* ------------------------------------------------------------------------- *)
val exit : allOptions -> optionExit -> 'exit
val succeed : allOptions -> 'exit
val fail : allOptions -> string -> 'exit
val usage : allOptions -> string -> 'exit
val version : allOptions -> 'exit
(* ------------------------------------------------------------------------- *)
(* Process the command line options passed to the program. *)
(* ------------------------------------------------------------------------- *)
val processOptions : allOptions -> string list -> string list * string list
end
(**** Original file: Options.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* PROCESSING COMMAND LINE OPTIONS *)
(* Copyright (c) 2003-2004 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Options :> Options =
struct
infix ##
open Useful;
(* ------------------------------------------------------------------------- *)
(* One command line option: names, arguments, description and a processor *)
(* ------------------------------------------------------------------------- *)
type proc = string * string list -> unit;
type ('a,'x) mkProc = ('x -> proc) -> ('a -> 'x) -> proc;
type opt = {switches : string list, arguments : string list,
description : string, processor : proc};
(* ------------------------------------------------------------------------- *)
(* Option processors may raise an OptionExit exception *)
(* ------------------------------------------------------------------------- *)
type optionExit = {message : string option, usage : bool, success : bool};
exception OptionExit of optionExit;
(* ------------------------------------------------------------------------- *)
(* Wrappers for option processors *)
(* ------------------------------------------------------------------------- *)
fun beginOpt f p (s : string, l : string list) : unit = f (p s) (s,l);
fun endOpt () (_ : string, [] : string list) = ()
| endOpt _ (_, _ :: _) = raise Bug "endOpt";
fun stringOpt _ _ (_ : string, []) = raise Bug "stringOpt"
| stringOpt f p (s, (h : string) :: t) : unit = f (p h) (s,t);
local
fun range NONE NONE = "Z"
| range (SOME i) NONE = "{n IN Z | " ^ Int.toString i ^ " <= n}"
| range NONE (SOME j) = "{n IN Z | n <= " ^ Int.toString j ^ "}"
| range (SOME i) (SOME j) =
"{n IN Z | " ^ Int.toString i ^ " <= n <= " ^ Int.toString j ^ "}";
fun oLeq (SOME x) (SOME y) = x <= y | oLeq _ _ = true;
fun argToInt arg omin omax x =
(case Int.fromString x of
SOME i =>
if oLeq omin (SOME i) andalso oLeq (SOME i) omax then i else
raise OptionExit
{success = false, usage = false, message =
SOME (arg ^ " option needs an integer argument in the range "
^ range omin omax ^ " (not " ^ x ^ ")")}
| NONE =>
raise OptionExit
{success = false, usage = false, message =
SOME (arg ^ " option needs an integer argument (not \"" ^ x ^ "\")")})
handle Overflow =>
raise OptionExit
{success = false, usage = false, message =
SOME (arg ^ " option suffered integer overflow on argument " ^ x)};
in
fun intOpt _ _ _ (_,[]) = raise Bug "intOpt"
| intOpt (omin,omax) f p (s:string, h :: (t : string list)) : unit =
f (p (argToInt s omin omax h)) (s,t);
end;
local
fun range NONE NONE = "R"
| range (SOME i) NONE = "{n IN R | " ^ Real.toString i ^ " <= n}"
| range NONE (SOME j) = "{n IN R | n <= " ^ Real.toString j ^ "}"
| range (SOME i) (SOME j) =
"{n IN R | " ^ Real.toString i ^ " <= n <= " ^ Real.toString j ^ "}";
fun oLeq (SOME (x:real)) (SOME y) = x <= y | oLeq _ _ = true;
fun argToReal arg omin omax x =
(case Real.fromString x of
SOME i =>
if oLeq omin (SOME i) andalso oLeq (SOME i) omax then i else
raise OptionExit
{success = false, usage = false, message =
SOME (arg ^ " option needs an real argument in the range "
^ range omin omax ^ " (not " ^ x ^ ")")}
| NONE =>
raise OptionExit
{success = false, usage = false, message =
SOME (arg ^ " option needs an real argument (not \"" ^ x ^ "\")")})
in
fun realOpt _ _ _ (_,[]) = raise Bug "realOpt"
| realOpt (omin,omax) f p (s:string, h :: (t : string list)) : unit =
f (p (argToReal s omin omax h)) (s,t);
end;
fun enumOpt _ _ _ (_,[]) = raise Bug "enumOpt"
| enumOpt (choices : string list) f p (s : string, h :: t) : unit =
if mem h choices then f (p h) (s,t) else
raise OptionExit
{success = false, usage = false,
message = SOME ("follow parameter " ^ s ^ " with one of {" ^
join "," choices ^ "}, not \"" ^ h ^ "\"")};
fun optionOpt _ _ _ (_,[]) = raise Bug "optionOpt"
| optionOpt (x : string, p) f q (s : string, l as h :: t) : unit =
if h = x then f (q NONE) (s,t) else p f (q o SOME) (s,l);
(* ------------------------------------------------------------------------- *)
(* Basic options useful for all programs *)
(* ------------------------------------------------------------------------- *)
val basicOptions : opt list =
[{switches = ["--"], arguments = [],
description = "no more options",
processor = fn _ => raise Fail "basicOptions: --"},
{switches = ["-?","-h","--help"], arguments = [],
description = "display all options and exit",
processor = fn _ => raise OptionExit
{message = SOME "displaying all options", usage = true, success = true}},
{switches = ["-v", "--version"], arguments = [],
description = "display version information",
processor = fn _ => raise Fail "basicOptions: -v, --version"}];
(* ------------------------------------------------------------------------- *)
(* All the command line options of a program *)
(* ------------------------------------------------------------------------- *)
type allOptions = {name : string, version : string, header : string,
footer : string, options : opt list};
(* ------------------------------------------------------------------------- *)
(* Usage information *)
(* ------------------------------------------------------------------------- *)
fun versionInformation ({version, ...} : allOptions) = version;
fun usageInformation ({name,version,header,footer,options} : allOptions) =
let
fun listOpts {switches = n, arguments = r, description = s,
processor = _} =
let
fun indent (s, "" :: l) = indent (s ^ " ", l) | indent x = x
val (res,n) = indent (" ",n)
val res = res ^ join ", " n
val res = foldl (fn (x,y) => y ^ " " ^ x) res r
in
[res ^ " ...", " " ^ s]
end
val alignment =
[{leftAlign = true, padChar = #"."},
{leftAlign = true, padChar = #" "}]
val table = alignTable alignment (map listOpts options)
in
header ^ join "\n" table ^ "\n" ^ footer
end;
(* ------------------------------------------------------------------------- *)
(* Exit the program gracefully *)
(* ------------------------------------------------------------------------- *)
fun exit (allopts : allOptions) (optexit : optionExit) =
let
val {name, options, ...} = allopts
val {message, usage, success} = optexit
fun err s = TextIO.output (TextIO.stdErr, s)
in
case message of NONE => () | SOME m => err (name ^ ": " ^ m ^ "\n");
if usage then err (usageInformation allopts) else ();
OS.Process.exit (if success then OS.Process.success else OS.Process.failure)
end;
fun succeed allopts =
exit allopts {message = NONE, usage = false, success = true};
fun fail allopts mesg =
exit allopts {message = SOME mesg, usage = false, success = false};
fun usage allopts mesg =
exit allopts {message = SOME mesg, usage = true, success = false};
fun version allopts =
(print (versionInformation allopts);
exit allopts {message = NONE, usage = false, success = true});
(* ------------------------------------------------------------------------- *)
(* Process the command line options passed to the program *)
(* ------------------------------------------------------------------------- *)
fun processOptions (allopts : allOptions) =
let
fun findOption x =
case List.find (fn {switches = n, ...} => mem x n) (#options allopts) of
NONE => raise OptionExit
{message = SOME ("unknown switch \"" ^ x ^ "\""),
usage = true, success = false}
| SOME {arguments = r, processor = f, ...} => (r,f)
fun getArgs x r xs =
let
fun f 1 = "a following argument"
| f m = Int.toString m ^ " following arguments"
val m = length r
val () =
if m <= length xs then () else
raise OptionExit
{usage = false, success = false, message = SOME
(x ^ " option needs " ^ f m ^ ": " ^ join " " r)}
in
divide xs m
end
fun process [] = ([], [])
| process ("--" :: xs) = ([("--",[])], xs)
| process ("-v" :: _) = version allopts
| process ("--version" :: _) = version allopts
| process (x :: xs) =
if x = "" orelse x = "-" orelse hd (explode x) <> #"-" then ([], x :: xs)
else
let
val (r,f) = findOption x
val (ys,xs) = getArgs x r xs
val () = f (x,ys)
in
(cons (x,ys) ## I) (process xs)
end
in
fn l =>
let
val (a,b) = process l
val a = foldl (fn ((x,xs),ys) => x :: xs @ ys) [] (rev a)
in
(a,b)
end
handle OptionExit x => exit allopts x
end;
end
end;
(**** Original file: Name.sig ****)
(* ========================================================================= *)
(* NAMES *)
(* Copyright (c) 2004-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Name =
sig
type name = string
val compare : name * name -> order
val pp : name Metis.Parser.pp
end
(**** Original file: Name.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* NAMES *)
(* Copyright (c) 2004-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Name :> Name =
struct
type name = string;
val compare = String.compare;
val pp = Parser.ppString;
end
structure NameOrdered =
struct type t = Name.name val compare = Name.compare end
structure NameSet =
struct
local
structure S = ElementSet (NameOrdered);
in
open S;
end;
val pp =
Parser.ppMap
toList
(Parser.ppBracket "{" "}" (Parser.ppSequence "," Name.pp));
end
structure NameMap = KeyMap (NameOrdered);
structure NameArity =
struct
type nameArity = Name.name * int;
fun name ((n,_) : nameArity) = n;
fun arity ((_,i) : nameArity) = i;
fun nary i n_i = arity n_i = i;
val nullary = nary 0
and unary = nary 1
and binary = nary 2
and ternary = nary 3;
fun compare ((n1,i1),(n2,i2)) =
case Name.compare (n1,n2) of
LESS => LESS
| EQUAL => Int.compare (i1,i2)
| GREATER => GREATER;
val pp = Parser.ppMap (fn (n,i) => n ^ "/" ^ Int.toString i) Parser.ppString;
end
structure NameArityOrdered =
struct type t = NameArity.nameArity val compare = NameArity.compare end
structure NameAritySet =
struct
local
structure S = ElementSet (NameArityOrdered);
in
open S;
end;
val allNullary = all NameArity.nullary;
val pp =
Parser.ppMap
toList
(Parser.ppBracket "{" "}" (Parser.ppSequence "," NameArity.pp));
end
structure NameArityMap = KeyMap (NameArityOrdered);
end;
(**** Original file: Term.sig ****)
(* ========================================================================= *)
(* FIRST ORDER LOGIC TERMS *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Term =
sig
(* ------------------------------------------------------------------------- *)
(* A type of first order logic terms. *)
(* ------------------------------------------------------------------------- *)
type var = Metis.Name.name
type functionName = Metis.Name.name
type function = functionName * int
type const = functionName
datatype term =
Var of var
| Fn of functionName * term list
(* ------------------------------------------------------------------------- *)
(* Constructors and destructors. *)
(* ------------------------------------------------------------------------- *)
(* Variables *)
val destVar : term -> var
val isVar : term -> bool
val equalVar : var -> term -> bool
(* Functions *)
val destFn : term -> functionName * term list
val isFn : term -> bool
val fnName : term -> functionName
val fnArguments : term -> term list
val fnArity : term -> int
val fnFunction : term -> function
val functions : term -> Metis.NameAritySet.set
val functionNames : term -> Metis.NameSet.set
(* Constants *)
val mkConst : const -> term
val destConst : term -> const
val isConst : term -> bool
(* Binary functions *)
val mkBinop : functionName -> term * term -> term
val destBinop : functionName -> term -> term * term
val isBinop : functionName -> term -> bool
(* ------------------------------------------------------------------------- *)
(* The size of a term in symbols. *)
(* ------------------------------------------------------------------------- *)
val symbols : term -> int
(* ------------------------------------------------------------------------- *)
(* A total comparison function for terms. *)
(* ------------------------------------------------------------------------- *)
val compare : term * term -> order
(* ------------------------------------------------------------------------- *)
(* Subterms. *)
(* ------------------------------------------------------------------------- *)
type path = int list
val subterm : term -> path -> term
val subterms : term -> (path * term) list
val replace : term -> path * term -> term
val find : (term -> bool) -> term -> path option
val ppPath : path Metis.Parser.pp
val pathToString : path -> string
(* ------------------------------------------------------------------------- *)
(* Free variables. *)
(* ------------------------------------------------------------------------- *)
val freeIn : var -> term -> bool
val freeVars : term -> Metis.NameSet.set
(* ------------------------------------------------------------------------- *)
(* Fresh variables. *)
(* ------------------------------------------------------------------------- *)
val newVar : unit -> term
val newVars : int -> term list
val variantPrime : Metis.NameSet.set -> var -> var
val variantNum : Metis.NameSet.set -> var -> var
(* ------------------------------------------------------------------------- *)
(* Special support for terms with type annotations. *)
(* ------------------------------------------------------------------------- *)
val isTypedVar : term -> bool
val typedSymbols : term -> int
val nonVarTypedSubterms : term -> (path * term) list
(* ------------------------------------------------------------------------- *)
(* Special support for terms with an explicit function application operator. *)
(* ------------------------------------------------------------------------- *)
val mkComb : term * term -> term
val destComb : term -> term * term
val isComb : term -> bool
val listMkComb : term * term list -> term
val stripComb : term -> term * term list
(* ------------------------------------------------------------------------- *)
(* Parsing and pretty printing. *)
(* ------------------------------------------------------------------------- *)
(* Infix symbols *)
val infixes : Metis.Parser.infixities Unsynchronized.ref
(* The negation symbol *)
val negation : Metis.Name.name Unsynchronized.ref
(* Binder symbols *)
val binders : Metis.Name.name list Unsynchronized.ref
(* Bracket symbols *)
val brackets : (Metis.Name.name * Metis.Name.name) list Unsynchronized.ref
(* Pretty printing *)
val pp : term Metis.Parser.pp
val toString : term -> string
(* Parsing *)
val fromString : string -> term
val parse : term Metis.Parser.quotation -> term
end
(**** Original file: Term.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* FIRST ORDER LOGIC TERMS *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Term :> Term =
struct
open Useful;
(* ------------------------------------------------------------------------- *)
(* Helper functions. *)
(* ------------------------------------------------------------------------- *)
fun stripSuffix pred s =
let
fun f 0 = ""
| f n =
let
val n' = n - 1
in
if pred (String.sub (s,n')) then f n'
else String.substring (s,0,n)
end
in
f (size s)
end;
(* ------------------------------------------------------------------------- *)
(* A type of first order logic terms. *)
(* ------------------------------------------------------------------------- *)
type var = Name.name;
type functionName = Name.name;
type function = functionName * int;
type const = functionName;
datatype term =
Var of Name.name
| Fn of Name.name * term list;
(* ------------------------------------------------------------------------- *)
(* Constructors and destructors. *)
(* ------------------------------------------------------------------------- *)
(* Variables *)
fun destVar (Var v) = v
| destVar (Fn _) = raise Error "destVar";
val isVar = can destVar;
fun equalVar v (Var v') = v = v'
| equalVar _ _ = false;
(* Functions *)
fun destFn (Fn f) = f
| destFn (Var _) = raise Error "destFn";
val isFn = can destFn;
fun fnName tm = fst (destFn tm);
fun fnArguments tm = snd (destFn tm);
fun fnArity tm = length (fnArguments tm);
fun fnFunction tm = (fnName tm, fnArity tm);
local
fun func fs [] = fs
| func fs (Var _ :: tms) = func fs tms
| func fs (Fn (n,l) :: tms) =
func (NameAritySet.add fs (n, length l)) (l @ tms);
in
fun functions tm = func NameAritySet.empty [tm];
end;
local
fun func fs [] = fs
| func fs (Var _ :: tms) = func fs tms
| func fs (Fn (n,l) :: tms) = func (NameSet.add fs n) (l @ tms);
in
fun functionNames tm = func NameSet.empty [tm];
end;
(* Constants *)
fun mkConst c = (Fn (c, []));
fun destConst (Fn (c, [])) = c
| destConst _ = raise Error "destConst";
val isConst = can destConst;
(* Binary functions *)
fun mkBinop f (a,b) = Fn (f,[a,b]);
fun destBinop f (Fn (x,[a,b])) =
if x = f then (a,b) else raise Error "Term.destBinop: wrong binop"
| destBinop _ _ = raise Error "Term.destBinop: not a binop";
fun isBinop f = can (destBinop f);
(* ------------------------------------------------------------------------- *)
(* The size of a term in symbols. *)
(* ------------------------------------------------------------------------- *)
val VAR_SYMBOLS = 1;
val FN_SYMBOLS = 1;
local
fun sz n [] = n
| sz n (Var _ :: tms) = sz (n + VAR_SYMBOLS) tms
| sz n (Fn (func,args) :: tms) = sz (n + FN_SYMBOLS) (args @ tms);
in
fun symbols tm = sz 0 [tm];
end;
(* ------------------------------------------------------------------------- *)
(* A total comparison function for terms. *)
(* ------------------------------------------------------------------------- *)
local
fun cmp [] [] = EQUAL
| cmp (Var _ :: _) (Fn _ :: _) = LESS
| cmp (Fn _ :: _) (Var _ :: _) = GREATER
| cmp (Var v1 :: tms1) (Var v2 :: tms2) =
(case Name.compare (v1,v2) of
LESS => LESS
| EQUAL => cmp tms1 tms2
| GREATER => GREATER)
| cmp (Fn (f1,a1) :: tms1) (Fn (f2,a2) :: tms2) =
(case Name.compare (f1,f2) of
LESS => LESS
| EQUAL =>
(case Int.compare (length a1, length a2) of
LESS => LESS
| EQUAL => cmp (a1 @ tms1) (a2 @ tms2)
| GREATER => GREATER)
| GREATER => GREATER)
| cmp _ _ = raise Bug "Term.compare";
in
fun compare (tm1,tm2) = cmp [tm1] [tm2];
end;
(* ------------------------------------------------------------------------- *)
(* Subterms. *)
(* ------------------------------------------------------------------------- *)
type path = int list;
fun subterm tm [] = tm
| subterm (Var _) (_ :: _) = raise Error "Term.subterm: Var"
| subterm (Fn (_,tms)) (h :: t) =
if h >= length tms then raise Error "Term.replace: Fn"
else subterm (List.nth (tms,h)) t;
local
fun subtms [] acc = acc
| subtms ((path,tm) :: rest) acc =
let
fun f (n,arg) = (n :: path, arg)
val acc = (rev path, tm) :: acc
in
case tm of
Var _ => subtms rest acc
| Fn (_,args) => subtms (map f (enumerate args) @ rest) acc
end;
in
fun subterms tm = subtms [([],tm)] [];
end;
fun replace tm ([],res) = if res = tm then tm else res
| replace tm (h :: t, res) =
case tm of
Var _ => raise Error "Term.replace: Var"
| Fn (func,tms) =>
if h >= length tms then raise Error "Term.replace: Fn"
else
let
val arg = List.nth (tms,h)
val arg' = replace arg (t,res)
in
if Sharing.pointerEqual (arg',arg) then tm
else Fn (func, updateNth (h,arg') tms)
end;
fun find pred =
let
fun search [] = NONE
| search ((path,tm) :: rest) =
if pred tm then SOME (rev path)
else
case tm of
Var _ => search rest
| Fn (_,a) =>
let
val subtms = map (fn (i,t) => (i :: path, t)) (enumerate a)
in
search (subtms @ rest)
end
in
fn tm => search [([],tm)]
end;
val ppPath = Parser.ppList Parser.ppInt;
val pathToString = Parser.toString ppPath;
(* ------------------------------------------------------------------------- *)
(* Free variables. *)
(* ------------------------------------------------------------------------- *)
local
fun free _ [] = false
| free v (Var w :: tms) = v = w orelse free v tms
| free v (Fn (_,args) :: tms) = free v (args @ tms);
in
fun freeIn v tm = free v [tm];
end;
local
fun free vs [] = vs
| free vs (Var v :: tms) = free (NameSet.add vs v) tms
| free vs (Fn (_,args) :: tms) = free vs (args @ tms);
in
fun freeVars tm = free NameSet.empty [tm];
end;
(* ------------------------------------------------------------------------- *)
(* Fresh variables. *)
(* ------------------------------------------------------------------------- *)
local
val prefix = "_";
fun numVar i = Var (mkPrefix prefix (Int.toString i));
in
fun newVar () = numVar (newInt ());
fun newVars n = map numVar (newInts n);
end;
fun variantPrime avoid =
let
fun f v = if NameSet.member v avoid then f (v ^ "'") else v
in
f
end;
fun variantNum avoid v =
if not (NameSet.member v avoid) then v
else
let
val v = stripSuffix Char.isDigit v
fun f n =
let
val v_n = v ^ Int.toString n
in
if NameSet.member v_n avoid then f (n + 1) else v_n
end
in
f 0
end;
(* ------------------------------------------------------------------------- *)
(* Special support for terms with type annotations. *)
(* ------------------------------------------------------------------------- *)
fun isTypedVar (Var _) = true
| isTypedVar (Fn (":", [Var _, _])) = true
| isTypedVar (Fn _) = false;
local
fun sz n [] = n
| sz n (Var _ :: tms) = sz (n + 1) tms
| sz n (Fn (":",[tm,_]) :: tms) = sz n (tm :: tms)
| sz n (Fn (_,args) :: tms) = sz (n + 1) (args @ tms);
in
fun typedSymbols tm = sz 0 [tm];
end;
local
fun subtms [] acc = acc
| subtms ((_, Var _) :: rest) acc = subtms rest acc
| subtms ((_, Fn (":", [Var _, _])) :: rest) acc = subtms rest acc
| subtms ((path, tm as Fn func) :: rest) acc =
let
fun f (n,arg) = (n :: path, arg)
val acc = (rev path, tm) :: acc
in
case func of
(":",[arg,_]) => subtms ((0 :: path, arg) :: rest) acc
| (_,args) => subtms (map f (enumerate args) @ rest) acc
end;
in
fun nonVarTypedSubterms tm = subtms [([],tm)] [];
end;
(* ------------------------------------------------------------------------- *)
(* Special support for terms with an explicit function application operator. *)
(* ------------------------------------------------------------------------- *)
fun mkComb (f,a) = Fn (".",[f,a]);
fun destComb (Fn (".",[f,a])) = (f,a)
| destComb _ = raise Error "destComb";
val isComb = can destComb;
fun listMkComb (f,l) = foldl mkComb f l;
local
fun strip tms (Fn (".",[f,a])) = strip (a :: tms) f
| strip tms tm = (tm,tms);
in
fun stripComb tm = strip [] tm;
end;
(* ------------------------------------------------------------------------- *)
(* Parsing and pretty printing. *)
(* ------------------------------------------------------------------------- *)
(* Operators parsed and printed infix *)
val infixes : Parser.infixities Unsynchronized.ref = Unsynchronized.ref
[(* ML symbols *)
{token = " / ", precedence = 7, leftAssoc = true},
{token = " div ", precedence = 7, leftAssoc = true},
{token = " mod ", precedence = 7, leftAssoc = true},
{token = " * ", precedence = 7, leftAssoc = true},
{token = " + ", precedence = 6, leftAssoc = true},
{token = " - ", precedence = 6, leftAssoc = true},
{token = " ^ ", precedence = 6, leftAssoc = true},
{token = " @ ", precedence = 5, leftAssoc = false},
{token = " :: ", precedence = 5, leftAssoc = false},
{token = " = ", precedence = 4, leftAssoc = true},
{token = " <> ", precedence = 4, leftAssoc = true},
{token = " <= ", precedence = 4, leftAssoc = true},
{token = " < ", precedence = 4, leftAssoc = true},
{token = " >= ", precedence = 4, leftAssoc = true},
{token = " > ", precedence = 4, leftAssoc = true},
{token = " o ", precedence = 3, leftAssoc = true},
{token = " -> ", precedence = 2, leftAssoc = false}, (* inferred prec *)
{token = " : ", precedence = 1, leftAssoc = false}, (* inferred prec *)
{token = ", ", precedence = 0, leftAssoc = false}, (* inferred prec *)
(* Logical connectives *)
{token = " /\\ ", precedence = ~1, leftAssoc = false},
{token = " \\/ ", precedence = ~2, leftAssoc = false},
{token = " ==> ", precedence = ~3, leftAssoc = false},
{token = " <=> ", precedence = ~4, leftAssoc = false},
(* Other symbols *)
{token = " . ", precedence = 9, leftAssoc = true}, (* function app *)
{token = " ** ", precedence = 8, leftAssoc = true},
{token = " ++ ", precedence = 6, leftAssoc = true},
{token = " -- ", precedence = 6, leftAssoc = true},
{token = " == ", precedence = 4, leftAssoc = true}];
(* The negation symbol *)
val negation : Name.name Unsynchronized.ref = Unsynchronized.ref "~";
(* Binder symbols *)
val binders : Name.name list Unsynchronized.ref = Unsynchronized.ref ["\\","!","?","?!"];
(* Bracket symbols *)
val brackets : (Name.name * Name.name) list Unsynchronized.ref = Unsynchronized.ref [("[","]"),("{","}")];
(* Pretty printing *)
local
open Parser;
in
fun pp inputPpstrm inputTerm =
let
val quants = !binders
and iOps = !infixes
and neg = !negation
and bracks = !brackets
val bracks = map (fn (b1,b2) => (b1 ^ b2, b1, b2)) bracks
val bTokens = map #2 bracks @ map #3 bracks
val iTokens = infixTokens iOps
fun destI (Fn (f,[a,b])) =
if mem f iTokens then SOME (f,a,b) else NONE
| destI _ = NONE
val iPrinter = ppInfixes iOps destI
val specialTokens = neg :: quants @ ["$","(",")"] @ bTokens @ iTokens
fun vName bv s = NameSet.member s bv
fun checkVarName bv s = if vName bv s then s else "$" ^ s
fun varName bv = ppMap (checkVarName bv) ppString
fun checkFunctionName bv s =
if mem s specialTokens orelse vName bv s then "(" ^ s ^ ")" else s
fun functionName bv = ppMap (checkFunctionName bv) ppString
fun isI tm = Option.isSome (destI tm)
fun stripNeg (tm as Fn (f,[a])) =
if f <> neg then (0,tm)
else let val (n,tm) = stripNeg a in (n + 1, tm) end
| stripNeg tm = (0,tm)
val destQuant =
let
fun dest q (Fn (q', [Var v, body])) =
if q <> q' then NONE
else
(case dest q body of
NONE => SOME (q,v,[],body)
| SOME (_,v',vs,body) => SOME (q, v, v' :: vs, body))
| dest _ _ = NONE
in
fn tm => Useful.first (fn q => dest q tm) quants
end
fun isQuant tm = Option.isSome (destQuant tm)
fun destBrack (Fn (b,[tm])) =
(case List.find (fn (n,_,_) => n = b) bracks of
NONE => NONE
| SOME (_,b1,b2) => SOME (b1,tm,b2))
| destBrack _ = NONE
fun isBrack tm = Option.isSome (destBrack tm)
fun functionArgument bv ppstrm tm =
(addBreak ppstrm (1,0);
if isBrack tm then customBracket bv ppstrm tm
else if isVar tm orelse isConst tm then basic bv ppstrm tm
else bracket bv ppstrm tm)
and basic bv ppstrm (Var v) = varName bv ppstrm v
| basic bv ppstrm (Fn (f,args)) =
(beginBlock ppstrm Inconsistent 2;
functionName bv ppstrm f;
app (functionArgument bv ppstrm) args;
endBlock ppstrm)
and customBracket bv ppstrm tm =
case destBrack tm of
SOME (b1,tm,b2) => ppBracket b1 b2 (term bv) ppstrm tm
| NONE => basic bv ppstrm tm
and innerQuant bv ppstrm tm =
case destQuant tm of
NONE => term bv ppstrm tm
| SOME (q,v,vs,tm) =>
let
val bv = NameSet.addList (NameSet.add bv v) vs
in
addString ppstrm q;
varName bv ppstrm v;
app (fn v => (addBreak ppstrm (1,0); varName bv ppstrm v)) vs;
addString ppstrm ".";
addBreak ppstrm (1,0);
innerQuant bv ppstrm tm
end
and quantifier bv ppstrm tm =
if not (isQuant tm) then customBracket bv ppstrm tm
else
(beginBlock ppstrm Inconsistent 2;
innerQuant bv ppstrm tm;
endBlock ppstrm)
and molecule bv ppstrm (tm,r) =
let
val (n,tm) = stripNeg tm
in
beginBlock ppstrm Inconsistent n;
funpow n (fn () => addString ppstrm neg) ();
if isI tm orelse (r andalso isQuant tm) then bracket bv ppstrm tm
else quantifier bv ppstrm tm;
endBlock ppstrm
end
and term bv ppstrm tm = iPrinter (molecule bv) ppstrm (tm,false)
and bracket bv ppstrm tm = ppBracket "(" ")" (term bv) ppstrm tm
in
term NameSet.empty
end inputPpstrm inputTerm;
end;
fun toString tm = Parser.toString pp tm;
(* Parsing *)
local
open Parser;
infixr 9 >>++
infixr 8 ++
infixr 7 >>
infixr 6 ||
val isAlphaNum =
let
val alphaNumChars = explode "_'"
in
fn c => mem c alphaNumChars orelse Char.isAlphaNum c
end;
local
val alphaNumToken = atLeastOne (some isAlphaNum) >> implode;
val symbolToken =
let
fun isNeg c = str c = !negation
val symbolChars = explode "<>=-*+/\\?@|!$%&#^:;~"
fun isSymbol c = mem c symbolChars
fun isNonNegSymbol c = not (isNeg c) andalso isSymbol c
in
some isNeg >> str ||
(some isNonNegSymbol ++ many (some isSymbol)) >> (implode o op::)
end;
val punctToken =
let
val punctChars = explode "()[]{}.,"
fun isPunct c = mem c punctChars
in
some isPunct >> str
end;
val lexToken = alphaNumToken || symbolToken || punctToken;
val space = many (some Char.isSpace);
in
val lexer = (space ++ lexToken ++ space) >> (fn (_,(tok,_)) => tok);
end;
fun termParser inputStream =
let
val quants = !binders
and iOps = !infixes
and neg = !negation
and bracks = ("(",")") :: !brackets
val bracks = map (fn (b1,b2) => (b1 ^ b2, b1, b2)) bracks
val bTokens = map #2 bracks @ map #3 bracks
fun possibleVarName "" = false
| possibleVarName s = isAlphaNum (String.sub (s,0))
fun vName bv s = NameSet.member s bv
val iTokens = infixTokens iOps
val iParser = parseInfixes iOps (fn (f,a,b) => Fn (f,[a,b]))
val specialTokens = neg :: quants @ ["$"] @ bTokens @ iTokens
fun varName bv =
Parser.some (vName bv) ||
(exact "$" ++ some possibleVarName) >> (fn (_,s) => s)
fun fName bv s = not (mem s specialTokens) andalso not (vName bv s)
fun functionName bv =
Parser.some (fName bv) ||
(exact "(" ++ any ++ exact ")") >> (fn (_,(s,_)) => s)
fun basic bv tokens =
let
val var = varName bv >> Var
val const = functionName bv >> (fn f => Fn (f,[]))
fun bracket (ab,a,b) =
(exact a ++ term bv ++ exact b) >>
(fn (_,(tm,_)) => if ab = "()" then tm else Fn (ab,[tm]))
fun quantifier q =
let
fun bind (v,t) = Fn (q, [Var v, t])
in
(exact q ++ atLeastOne (some possibleVarName) ++
exact ".") >>++
(fn (_,(vs,_)) =>
term (NameSet.addList bv vs) >>
(fn body => foldr bind body vs))
end
in
var ||
const ||
first (map bracket bracks) ||
first (map quantifier quants)
end tokens
and molecule bv tokens =
let
val negations = many (exact neg) >> length
val function =
(functionName bv ++ many (basic bv)) >> Fn || basic bv
in
(negations ++ function) >>
(fn (n,tm) => funpow n (fn t => Fn (neg,[t])) tm)
end tokens
and term bv tokens = iParser (molecule bv) tokens
in
term NameSet.empty
end inputStream;
in
fun fromString input =
let
val chars = Stream.fromList (explode input)
val tokens = everything (lexer >> singleton) chars
val terms = everything (termParser >> singleton) tokens
in
case Stream.toList terms of
[tm] => tm
| _ => raise Error "Syntax.stringToTerm"
end;
end;
local
val antiquotedTermToString =
Parser.toString (Parser.ppBracket "(" ")" pp);
in
val parse = Parser.parseQuotation antiquotedTermToString fromString;
end;
end
structure TermOrdered =
struct type t = Term.term val compare = Term.compare end
structure TermSet = ElementSet (TermOrdered);
structure TermMap = KeyMap (TermOrdered);
end;
(**** Original file: Subst.sig ****)
(* ========================================================================= *)
(* FIRST ORDER LOGIC SUBSTITUTIONS *)
(* Copyright (c) 2002-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Subst =
sig
(* ------------------------------------------------------------------------- *)
(* A type of first order logic substitutions. *)
(* ------------------------------------------------------------------------- *)
type subst
(* ------------------------------------------------------------------------- *)
(* Basic operations. *)
(* ------------------------------------------------------------------------- *)
val empty : subst
val null : subst -> bool
val size : subst -> int
val peek : subst -> Metis.Term.var -> Metis.Term.term option
val insert : subst -> Metis.Term.var * Metis.Term.term -> subst
val singleton : Metis.Term.var * Metis.Term.term -> subst
val union : subst -> subst -> subst
val toList : subst -> (Metis.Term.var * Metis.Term.term) list
val fromList : (Metis.Term.var * Metis.Term.term) list -> subst
val foldl : (Metis.Term.var * Metis.Term.term * 'a -> 'a) -> 'a -> subst -> 'a
val foldr : (Metis.Term.var * Metis.Term.term * 'a -> 'a) -> 'a -> subst -> 'a
val pp : subst Metis.Parser.pp
val toString : subst -> string
(* ------------------------------------------------------------------------- *)
(* Normalizing removes identity substitutions. *)
(* ------------------------------------------------------------------------- *)
val normalize : subst -> subst
(* ------------------------------------------------------------------------- *)
(* Applying a substitution to a first order logic term. *)
(* ------------------------------------------------------------------------- *)
val subst : subst -> Metis.Term.term -> Metis.Term.term
(* ------------------------------------------------------------------------- *)
(* Restricting a substitution to a smaller set of variables. *)
(* ------------------------------------------------------------------------- *)
val restrict : subst -> Metis.NameSet.set -> subst
val remove : subst -> Metis.NameSet.set -> subst
(* ------------------------------------------------------------------------- *)
(* Composing two substitutions so that the following identity holds: *)
(* *)
(* subst (compose sub1 sub2) tm = subst sub2 (subst sub1 tm) *)
(* ------------------------------------------------------------------------- *)
val compose : subst -> subst -> subst
(* ------------------------------------------------------------------------- *)
(* Substitutions can be inverted iff they are renaming substitutions. *)
(* ------------------------------------------------------------------------- *)
val invert : subst -> subst (* raises Error *)
val isRenaming : subst -> bool
(* ------------------------------------------------------------------------- *)
(* Creating a substitution to freshen variables. *)
(* ------------------------------------------------------------------------- *)
val freshVars : Metis.NameSet.set -> subst
(* ------------------------------------------------------------------------- *)
(* Matching for first order logic terms. *)
(* ------------------------------------------------------------------------- *)
val match : subst -> Metis.Term.term -> Metis.Term.term -> subst (* raises Error *)
(* ------------------------------------------------------------------------- *)
(* Unification for first order logic terms. *)
(* ------------------------------------------------------------------------- *)
val unify : subst -> Metis.Term.term -> Metis.Term.term -> subst (* raises Error *)
end
(**** Original file: Subst.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* FIRST ORDER LOGIC SUBSTITUTIONS *)
(* Copyright (c) 2002-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Subst :> Subst =
struct
open Useful;
(* ------------------------------------------------------------------------- *)
(* A type of first order logic substitutions. *)
(* ------------------------------------------------------------------------- *)
datatype subst = Subst of Term.term NameMap.map;
(* ------------------------------------------------------------------------- *)
(* Basic operations. *)
(* ------------------------------------------------------------------------- *)
val empty = Subst (NameMap.new ());
fun null (Subst m) = NameMap.null m;
fun size (Subst m) = NameMap.size m;
fun peek (Subst m) v = NameMap.peek m v;
fun insert (Subst m) v_tm = Subst (NameMap.insert m v_tm);
fun singleton v_tm = insert empty v_tm;
local
fun compatible (tm1,tm2) =
if tm1 = tm2 then SOME tm1 else raise Error "Subst.union: incompatible";
in
fun union (s1 as Subst m1) (s2 as Subst m2) =
if NameMap.null m1 then s2
else if NameMap.null m2 then s1
else Subst (NameMap.union compatible m1 m2);
end;
fun toList (Subst m) = NameMap.toList m;
fun fromList l = Subst (NameMap.fromList l);
fun foldl f b (Subst m) = NameMap.foldl f b m;
fun foldr f b (Subst m) = NameMap.foldr f b m;
fun pp ppstrm sub =
Parser.ppBracket "<[" "]>"
(Parser.ppSequence "," (Parser.ppBinop " |->" Parser.ppString Term.pp))
ppstrm (toList sub);
val toString = Parser.toString pp;
(* ------------------------------------------------------------------------- *)
(* Normalizing removes identity substitutions. *)
(* ------------------------------------------------------------------------- *)
local
fun isNotId (v,tm) = not (Term.equalVar v tm);
in
fun normalize (sub as Subst m) =
let
val m' = NameMap.filter isNotId m
in
if NameMap.size m = NameMap.size m' then sub else Subst m'
end;
end;
(* ------------------------------------------------------------------------- *)
(* Applying a substitution to a first order logic term. *)
(* ------------------------------------------------------------------------- *)
fun subst sub =
let
fun tmSub (tm as Term.Var v) =
(case peek sub v of
SOME tm' => if Sharing.pointerEqual (tm,tm') then tm else tm'
| NONE => tm)
| tmSub (tm as Term.Fn (f,args)) =
let
val args' = Sharing.map tmSub args
in
if Sharing.pointerEqual (args,args') then tm
else Term.Fn (f,args')
end
in
fn tm => if null sub then tm else tmSub tm
end;
(* ------------------------------------------------------------------------- *)
(* Restricting a substitution to a given set of variables. *)
(* ------------------------------------------------------------------------- *)
fun restrict (sub as Subst m) varSet =
let
fun isRestrictedVar (v,_) = NameSet.member v varSet
val m' = NameMap.filter isRestrictedVar m
in
if NameMap.size m = NameMap.size m' then sub else Subst m'
end;
fun remove (sub as Subst m) varSet =
let
fun isRestrictedVar (v,_) = not (NameSet.member v varSet)
val m' = NameMap.filter isRestrictedVar m
in
if NameMap.size m = NameMap.size m' then sub else Subst m'
end;
(* ------------------------------------------------------------------------- *)
(* Composing two substitutions so that the following identity holds: *)
(* *)
(* subst (compose sub1 sub2) tm = subst sub2 (subst sub1 tm) *)
(* ------------------------------------------------------------------------- *)
fun compose (sub1 as Subst m1) sub2 =
let
fun f (v,tm,s) = insert s (v, subst sub2 tm)
in
if null sub2 then sub1 else NameMap.foldl f sub2 m1
end;
(* ------------------------------------------------------------------------- *)
(* Substitutions can be inverted iff they are renaming substitutions. *)
(* ------------------------------------------------------------------------- *)
local
fun inv (v, Term.Var w, s) =
if NameMap.inDomain w s then raise Error "Subst.invert: non-injective"
else NameMap.insert s (w, Term.Var v)
| inv (_, Term.Fn _, _) = raise Error "Subst.invert: non-variable";
in
fun invert (Subst m) = Subst (NameMap.foldl inv (NameMap.new ()) m);
end;
val isRenaming = can invert;
(* ------------------------------------------------------------------------- *)
(* Creating a substitution to freshen variables. *)
(* ------------------------------------------------------------------------- *)
val freshVars =
let
fun add (v,m) = insert m (v, Term.newVar ())
in
NameSet.foldl add empty
end;
(* ------------------------------------------------------------------------- *)
(* Matching for first order logic terms. *)
(* ------------------------------------------------------------------------- *)
local
fun matchList sub [] = sub
| matchList sub ((Term.Var v, tm) :: rest) =
let
val sub =
case peek sub v of
NONE => insert sub (v,tm)
| SOME tm' =>
if tm = tm' then sub
else raise Error "Subst.match: incompatible matches"
in
matchList sub rest
end
| matchList sub ((Term.Fn (f1,args1), Term.Fn (f2,args2)) :: rest) =
if f1 = f2 andalso length args1 = length args2 then
matchList sub (zip args1 args2 @ rest)
else raise Error "Subst.match: different structure"
| matchList _ _ = raise Error "Subst.match: functions can't match vars";
in
fun match sub tm1 tm2 = matchList sub [(tm1,tm2)];
end;
(* ------------------------------------------------------------------------- *)
(* Unification for first order logic terms. *)
(* ------------------------------------------------------------------------- *)
local
fun solve sub [] = sub
| solve sub ((tm1_tm2 as (tm1,tm2)) :: rest) =
if Portable.pointerEqual tm1_tm2 then solve sub rest
else solve' sub (subst sub tm1) (subst sub tm2) rest
and solve' sub (Term.Var v) tm rest =
if Term.equalVar v tm then solve sub rest
else if Term.freeIn v tm then raise Error "Subst.unify: occurs check"
else
(case peek sub v of
NONE => solve (compose sub (singleton (v,tm))) rest
| SOME tm' => solve' sub tm' tm rest)
| solve' sub tm1 (tm2 as Term.Var _) rest = solve' sub tm2 tm1 rest
| solve' sub (Term.Fn (f1,args1)) (Term.Fn (f2,args2)) rest =
if f1 = f2 andalso length args1 = length args2 then
solve sub (zip args1 args2 @ rest)
else
raise Error "Subst.unify: different structure";
in
fun unify sub tm1 tm2 = solve sub [(tm1,tm2)];
end;
end
end;
(**** Original file: Atom.sig ****)
(* ========================================================================= *)
(* FIRST ORDER LOGIC ATOMS *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Atom =
sig
(* ------------------------------------------------------------------------- *)
(* A type for storing first order logic atoms. *)
(* ------------------------------------------------------------------------- *)
type relationName = Metis.Name.name
type relation = relationName * int
type atom = relationName * Metis.Term.term list
(* ------------------------------------------------------------------------- *)
(* Constructors and destructors. *)
(* ------------------------------------------------------------------------- *)
val name : atom -> relationName
val arguments : atom -> Metis.Term.term list
val arity : atom -> int
val relation : atom -> relation
val functions : atom -> Metis.NameAritySet.set
val functionNames : atom -> Metis.NameSet.set
(* Binary relations *)
val mkBinop : relationName -> Metis.Term.term * Metis.Term.term -> atom
val destBinop : relationName -> atom -> Metis.Term.term * Metis.Term.term
val isBinop : relationName -> atom -> bool
(* ------------------------------------------------------------------------- *)
(* The size of an atom in symbols. *)
(* ------------------------------------------------------------------------- *)
val symbols : atom -> int
(* ------------------------------------------------------------------------- *)
(* A total comparison function for atoms. *)
(* ------------------------------------------------------------------------- *)
val compare : atom * atom -> order
(* ------------------------------------------------------------------------- *)
(* Subterms. *)
(* ------------------------------------------------------------------------- *)
val subterm : atom -> Metis.Term.path -> Metis.Term.term
val subterms : atom -> (Metis.Term.path * Metis.Term.term) list
val replace : atom -> Metis.Term.path * Metis.Term.term -> atom
val find : (Metis.Term.term -> bool) -> atom -> Metis.Term.path option
(* ------------------------------------------------------------------------- *)
(* Free variables. *)
(* ------------------------------------------------------------------------- *)
val freeIn : Metis.Term.var -> atom -> bool
val freeVars : atom -> Metis.NameSet.set
(* ------------------------------------------------------------------------- *)
(* Substitutions. *)
(* ------------------------------------------------------------------------- *)
val subst : Metis.Subst.subst -> atom -> atom
(* ------------------------------------------------------------------------- *)
(* Matching. *)
(* ------------------------------------------------------------------------- *)
val match : Metis.Subst.subst -> atom -> atom -> Metis.Subst.subst (* raises Error *)
(* ------------------------------------------------------------------------- *)
(* Unification. *)
(* ------------------------------------------------------------------------- *)
val unify : Metis.Subst.subst -> atom -> atom -> Metis.Subst.subst (* raises Error *)
(* ------------------------------------------------------------------------- *)
(* The equality relation. *)
(* ------------------------------------------------------------------------- *)
val eqRelation : relation
val mkEq : Metis.Term.term * Metis.Term.term -> atom
val destEq : atom -> Metis.Term.term * Metis.Term.term
val isEq : atom -> bool
val mkRefl : Metis.Term.term -> atom
val destRefl : atom -> Metis.Term.term
val isRefl : atom -> bool
val sym : atom -> atom (* raises Error if given a refl *)
val lhs : atom -> Metis.Term.term
val rhs : atom -> Metis.Term.term
(* ------------------------------------------------------------------------- *)
(* Special support for terms with type annotations. *)
(* ------------------------------------------------------------------------- *)
val typedSymbols : atom -> int
val nonVarTypedSubterms : atom -> (Metis.Term.path * Metis.Term.term) list
(* ------------------------------------------------------------------------- *)
(* Parsing and pretty printing. *)
(* ------------------------------------------------------------------------- *)
val pp : atom Metis.Parser.pp
val toString : atom -> string
val fromString : string -> atom
val parse : Metis.Term.term Metis.Parser.quotation -> atom
end
(**** Original file: Atom.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* FIRST ORDER LOGIC ATOMS *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Atom :> Atom =
struct
open Useful;
(* ------------------------------------------------------------------------- *)
(* A type for storing first order logic atoms. *)
(* ------------------------------------------------------------------------- *)
type relationName = Name.name;
type relation = relationName * int;
type atom = relationName * Term.term list;
(* ------------------------------------------------------------------------- *)
(* Constructors and destructors. *)
(* ------------------------------------------------------------------------- *)
fun name ((rel,_) : atom) = rel;
fun arguments ((_,args) : atom) = args;
fun arity atm = length (arguments atm);
fun relation atm = (name atm, arity atm);
val functions =
let
fun f (tm,acc) = NameAritySet.union (Term.functions tm) acc
in
fn atm => foldl f NameAritySet.empty (arguments atm)
end;
val functionNames =
let
fun f (tm,acc) = NameSet.union (Term.functionNames tm) acc
in
fn atm => foldl f NameSet.empty (arguments atm)
end;
(* Binary relations *)
fun mkBinop p (a,b) : atom = (p,[a,b]);
fun destBinop p (x,[a,b]) =
if x = p then (a,b) else raise Error "Atom.destBinop: wrong binop"
| destBinop _ _ = raise Error "Atom.destBinop: not a binop";
fun isBinop p = can (destBinop p);
(* ------------------------------------------------------------------------- *)
(* The size of an atom in symbols. *)
(* ------------------------------------------------------------------------- *)
fun symbols atm = foldl (fn (tm,z) => Term.symbols tm + z) 1 (arguments atm);
(* ------------------------------------------------------------------------- *)
(* A total comparison function for atoms. *)
(* ------------------------------------------------------------------------- *)
fun compare ((p1,tms1),(p2,tms2)) =
case Name.compare (p1,p2) of
LESS => LESS
| EQUAL => lexCompare Term.compare (tms1,tms2)
| GREATER => GREATER;
(* ------------------------------------------------------------------------- *)
(* Subterms. *)
(* ------------------------------------------------------------------------- *)
fun subterm _ [] = raise Bug "Atom.subterm: empty path"
| subterm ((_,tms) : atom) (h :: t) =
if h >= length tms then raise Error "Atom.subterm: bad path"
else Term.subterm (List.nth (tms,h)) t;
fun subterms ((_,tms) : atom) =
let
fun f ((n,tm),l) = map (fn (p,s) => (n :: p, s)) (Term.subterms tm) @ l
in
foldl f [] (enumerate tms)
end;
fun replace _ ([],_) = raise Bug "Atom.replace: empty path"
| replace (atm as (rel,tms)) (h :: t, res) : atom =
if h >= length tms then raise Error "Atom.replace: bad path"
else
let
val tm = List.nth (tms,h)
val tm' = Term.replace tm (t,res)
in
if Sharing.pointerEqual (tm,tm') then atm
else (rel, updateNth (h,tm') tms)
end;
fun find pred =
let
fun f (i,tm) =
case Term.find pred tm of
SOME path => SOME (i :: path)
| NONE => NONE
in
fn (_,tms) : atom => first f (enumerate tms)
end;
(* ------------------------------------------------------------------------- *)
(* Free variables. *)
(* ------------------------------------------------------------------------- *)
fun freeIn v atm = List.exists (Term.freeIn v) (arguments atm);
val freeVars =
let
fun f (tm,acc) = NameSet.union (Term.freeVars tm) acc
in
fn atm => foldl f NameSet.empty (arguments atm)
end;
(* ------------------------------------------------------------------------- *)
(* Substitutions. *)
(* ------------------------------------------------------------------------- *)
fun subst sub (atm as (p,tms)) : atom =
let
val tms' = Sharing.map (Subst.subst sub) tms
in
if Sharing.pointerEqual (tms',tms) then atm else (p,tms')
end;
(* ------------------------------------------------------------------------- *)
(* Matching. *)
(* ------------------------------------------------------------------------- *)
local
fun matchArg ((tm1,tm2),sub) = Subst.match sub tm1 tm2;
in
fun match sub (p1,tms1) (p2,tms2) =
let
val _ = (p1 = p2 andalso length tms1 = length tms2) orelse
raise Error "Atom.match"
in
foldl matchArg sub (zip tms1 tms2)
end;
end;
(* ------------------------------------------------------------------------- *)
(* Unification. *)
(* ------------------------------------------------------------------------- *)
local
fun unifyArg ((tm1,tm2),sub) = Subst.unify sub tm1 tm2;
in
fun unify sub (p1,tms1) (p2,tms2) =
let
val _ = (p1 = p2 andalso length tms1 = length tms2) orelse
raise Error "Atom.unify"
in
foldl unifyArg sub (zip tms1 tms2)
end;
end;
(* ------------------------------------------------------------------------- *)
(* The equality relation. *)
(* ------------------------------------------------------------------------- *)
val eqName = "=";
val eqArity = 2;
val eqRelation = (eqName,eqArity);
val mkEq = mkBinop eqName;
fun destEq x = destBinop eqName x;
fun isEq x = isBinop eqName x;
fun mkRefl tm = mkEq (tm,tm);
fun destRefl atm =
let
val (l,r) = destEq atm
val _ = l = r orelse raise Error "Atom.destRefl"
in
l
end;
fun isRefl x = can destRefl x;
fun sym atm =
let
val (l,r) = destEq atm
val _ = l <> r orelse raise Error "Atom.sym: refl"
in
mkEq (r,l)
end;
fun lhs atm = fst (destEq atm);
fun rhs atm = snd (destEq atm);
(* ------------------------------------------------------------------------- *)
(* Special support for terms with type annotations. *)
(* ------------------------------------------------------------------------- *)
fun typedSymbols ((_,tms) : atom) =
foldl (fn (tm,z) => Term.typedSymbols tm + z) 1 tms;
fun nonVarTypedSubterms (_,tms) =
let
fun addArg ((n,arg),acc) =
let
fun addTm ((path,tm),acc) = (n :: path, tm) :: acc
in
foldl addTm acc (Term.nonVarTypedSubterms arg)
end
in
foldl addArg [] (enumerate tms)
end;
(* ------------------------------------------------------------------------- *)
(* Parsing and pretty printing. *)
(* ------------------------------------------------------------------------- *)
val pp = Parser.ppMap Term.Fn Term.pp;
val toString = Parser.toString pp;
fun fromString s = Term.destFn (Term.fromString s);
val parse = Parser.parseQuotation Term.toString fromString;
end
structure AtomOrdered =
struct type t = Atom.atom val compare = Atom.compare end
structure AtomSet = ElementSet (AtomOrdered);
structure AtomMap = KeyMap (AtomOrdered);
end;
(**** Original file: Formula.sig ****)
(* ========================================================================= *)
(* FIRST ORDER LOGIC FORMULAS *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Formula =
sig
(* ------------------------------------------------------------------------- *)
(* A type of first order logic formulas. *)
(* ------------------------------------------------------------------------- *)
datatype formula =
True
| False
| Atom of Metis.Atom.atom
| Not of formula
| And of formula * formula
| Or of formula * formula
| Imp of formula * formula
| Iff of formula * formula
| Forall of Metis.Term.var * formula
| Exists of Metis.Term.var * formula
(* ------------------------------------------------------------------------- *)
(* Constructors and destructors. *)
(* ------------------------------------------------------------------------- *)
(* Booleans *)
val mkBoolean : bool -> formula
val destBoolean : formula -> bool
val isBoolean : formula -> bool
(* Functions *)
val functions : formula -> Metis.NameAritySet.set
val functionNames : formula -> Metis.NameSet.set
(* Relations *)
val relations : formula -> Metis.NameAritySet.set
val relationNames : formula -> Metis.NameSet.set
(* Atoms *)
val destAtom : formula -> Metis.Atom.atom
val isAtom : formula -> bool
(* Negations *)
val destNeg : formula -> formula
val isNeg : formula -> bool
val stripNeg : formula -> int * formula
(* Conjunctions *)
val listMkConj : formula list -> formula
val stripConj : formula -> formula list
val flattenConj : formula -> formula list
(* Disjunctions *)
val listMkDisj : formula list -> formula
val stripDisj : formula -> formula list
val flattenDisj : formula -> formula list
(* Equivalences *)
val listMkEquiv : formula list -> formula
val stripEquiv : formula -> formula list
val flattenEquiv : formula -> formula list
(* Universal quantification *)
val destForall : formula -> Metis.Term.var * formula
val isForall : formula -> bool
val listMkForall : Metis.Term.var list * formula -> formula
val stripForall : formula -> Metis.Term.var list * formula
(* Existential quantification *)
val destExists : formula -> Metis.Term.var * formula
val isExists : formula -> bool
val listMkExists : Metis.Term.var list * formula -> formula
val stripExists : formula -> Metis.Term.var list * formula
(* ------------------------------------------------------------------------- *)
(* The size of a formula in symbols. *)
(* ------------------------------------------------------------------------- *)
val symbols : formula -> int
(* ------------------------------------------------------------------------- *)
(* A total comparison function for formulas. *)
(* ------------------------------------------------------------------------- *)
val compare : formula * formula -> order
(* ------------------------------------------------------------------------- *)
(* Free variables. *)
(* ------------------------------------------------------------------------- *)
val freeIn : Metis.Term.var -> formula -> bool
val freeVars : formula -> Metis.NameSet.set
val specialize : formula -> formula
val generalize : formula -> formula
(* ------------------------------------------------------------------------- *)
(* Substitutions. *)
(* ------------------------------------------------------------------------- *)
val subst : Metis.Subst.subst -> formula -> formula
(* ------------------------------------------------------------------------- *)
(* The equality relation. *)
(* ------------------------------------------------------------------------- *)
val mkEq : Metis.Term.term * Metis.Term.term -> formula
val destEq : formula -> Metis.Term.term * Metis.Term.term
val isEq : formula -> bool
val mkNeq : Metis.Term.term * Metis.Term.term -> formula
val destNeq : formula -> Metis.Term.term * Metis.Term.term
val isNeq : formula -> bool
val mkRefl : Metis.Term.term -> formula
val destRefl : formula -> Metis.Term.term
val isRefl : formula -> bool
val sym : formula -> formula (* raises Error if given a refl *)
val lhs : formula -> Metis.Term.term
val rhs : formula -> Metis.Term.term
(* ------------------------------------------------------------------------- *)
(* Parsing and pretty-printing. *)
(* ------------------------------------------------------------------------- *)
type quotation = formula Metis.Parser.quotation
val pp : formula Metis.Parser.pp
val toString : formula -> string
val fromString : string -> formula
val parse : quotation -> formula
end
(**** Original file: Formula.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* FIRST ORDER LOGIC FORMULAS *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Formula :> Formula =
struct
open Useful;
(* ------------------------------------------------------------------------- *)
(* A type of first order logic formulas. *)
(* ------------------------------------------------------------------------- *)
datatype formula =
True
| False
| Atom of Atom.atom
| Not of formula
| And of formula * formula
| Or of formula * formula
| Imp of formula * formula
| Iff of formula * formula
| Forall of Term.var * formula
| Exists of Term.var * formula;
(* ------------------------------------------------------------------------- *)
(* Constructors and destructors. *)
(* ------------------------------------------------------------------------- *)
(* Booleans *)
fun mkBoolean true = True
| mkBoolean false = False;
fun destBoolean True = true
| destBoolean False = false
| destBoolean _ = raise Error "destBoolean";
val isBoolean = can destBoolean;
(* Functions *)
local
fun funcs fs [] = fs
| funcs fs (True :: fms) = funcs fs fms
| funcs fs (False :: fms) = funcs fs fms
| funcs fs (Atom atm :: fms) =
funcs (NameAritySet.union (Atom.functions atm) fs) fms
| funcs fs (Not p :: fms) = funcs fs (p :: fms)
| funcs fs (And (p,q) :: fms) = funcs fs (p :: q :: fms)
| funcs fs (Or (p,q) :: fms) = funcs fs (p :: q :: fms)
| funcs fs (Imp (p,q) :: fms) = funcs fs (p :: q :: fms)
| funcs fs (Iff (p,q) :: fms) = funcs fs (p :: q :: fms)
| funcs fs (Forall (_,p) :: fms) = funcs fs (p :: fms)
| funcs fs (Exists (_,p) :: fms) = funcs fs (p :: fms);
in
fun functions fm = funcs NameAritySet.empty [fm];
end;
local
fun funcs fs [] = fs
| funcs fs (True :: fms) = funcs fs fms
| funcs fs (False :: fms) = funcs fs fms
| funcs fs (Atom atm :: fms) =
funcs (NameSet.union (Atom.functionNames atm) fs) fms
| funcs fs (Not p :: fms) = funcs fs (p :: fms)
| funcs fs (And (p,q) :: fms) = funcs fs (p :: q :: fms)
| funcs fs (Or (p,q) :: fms) = funcs fs (p :: q :: fms)
| funcs fs (Imp (p,q) :: fms) = funcs fs (p :: q :: fms)
| funcs fs (Iff (p,q) :: fms) = funcs fs (p :: q :: fms)
| funcs fs (Forall (_,p) :: fms) = funcs fs (p :: fms)
| funcs fs (Exists (_,p) :: fms) = funcs fs (p :: fms);
in
fun functionNames fm = funcs NameSet.empty [fm];
end;
(* Relations *)
local
fun rels fs [] = fs
| rels fs (True :: fms) = rels fs fms
| rels fs (False :: fms) = rels fs fms
| rels fs (Atom atm :: fms) =
rels (NameAritySet.add fs (Atom.relation atm)) fms
| rels fs (Not p :: fms) = rels fs (p :: fms)
| rels fs (And (p,q) :: fms) = rels fs (p :: q :: fms)
| rels fs (Or (p,q) :: fms) = rels fs (p :: q :: fms)
| rels fs (Imp (p,q) :: fms) = rels fs (p :: q :: fms)
| rels fs (Iff (p,q) :: fms) = rels fs (p :: q :: fms)
| rels fs (Forall (_,p) :: fms) = rels fs (p :: fms)
| rels fs (Exists (_,p) :: fms) = rels fs (p :: fms);
in
fun relations fm = rels NameAritySet.empty [fm];
end;
local
fun rels fs [] = fs
| rels fs (True :: fms) = rels fs fms
| rels fs (False :: fms) = rels fs fms
| rels fs (Atom atm :: fms) = rels (NameSet.add fs (Atom.name atm)) fms
| rels fs (Not p :: fms) = rels fs (p :: fms)
| rels fs (And (p,q) :: fms) = rels fs (p :: q :: fms)
| rels fs (Or (p,q) :: fms) = rels fs (p :: q :: fms)
| rels fs (Imp (p,q) :: fms) = rels fs (p :: q :: fms)
| rels fs (Iff (p,q) :: fms) = rels fs (p :: q :: fms)
| rels fs (Forall (_,p) :: fms) = rels fs (p :: fms)
| rels fs (Exists (_,p) :: fms) = rels fs (p :: fms);
in
fun relationNames fm = rels NameSet.empty [fm];
end;
(* Atoms *)
fun destAtom (Atom atm) = atm
| destAtom _ = raise Error "Formula.destAtom";
val isAtom = can destAtom;
(* Negations *)
fun destNeg (Not p) = p
| destNeg _ = raise Error "Formula.destNeg";
val isNeg = can destNeg;
val stripNeg =
let
fun strip n (Not fm) = strip (n + 1) fm
| strip n fm = (n,fm)
in
strip 0
end;
(* Conjunctions *)
fun listMkConj fms =
case rev fms of [] => True | fm :: fms => foldl And fm fms;
local
fun strip cs (And (p,q)) = strip (p :: cs) q
| strip cs fm = rev (fm :: cs);
in
fun stripConj True = []
| stripConj fm = strip [] fm;
end;
val flattenConj =
let
fun flat acc [] = acc
| flat acc (And (p,q) :: fms) = flat acc (q :: p :: fms)
| flat acc (True :: fms) = flat acc fms
| flat acc (fm :: fms) = flat (fm :: acc) fms
in
fn fm => flat [] [fm]
end;
(* Disjunctions *)
fun listMkDisj fms =
case rev fms of [] => False | fm :: fms => foldl Or fm fms;
local
fun strip cs (Or (p,q)) = strip (p :: cs) q
| strip cs fm = rev (fm :: cs);
in
fun stripDisj False = []
| stripDisj fm = strip [] fm;
end;
val flattenDisj =
let
fun flat acc [] = acc
| flat acc (Or (p,q) :: fms) = flat acc (q :: p :: fms)
| flat acc (False :: fms) = flat acc fms
| flat acc (fm :: fms) = flat (fm :: acc) fms
in
fn fm => flat [] [fm]
end;
(* Equivalences *)
fun listMkEquiv fms =
case rev fms of [] => True | fm :: fms => foldl Iff fm fms;
local
fun strip cs (Iff (p,q)) = strip (p :: cs) q
| strip cs fm = rev (fm :: cs);
in
fun stripEquiv True = []
| stripEquiv fm = strip [] fm;
end;
val flattenEquiv =
let
fun flat acc [] = acc
| flat acc (Iff (p,q) :: fms) = flat acc (q :: p :: fms)
| flat acc (True :: fms) = flat acc fms
| flat acc (fm :: fms) = flat (fm :: acc) fms
in
fn fm => flat [] [fm]
end;
(* Universal quantifiers *)
fun destForall (Forall v_f) = v_f
| destForall _ = raise Error "destForall";
val isForall = can destForall;
fun listMkForall ([],body) = body
| listMkForall (v :: vs, body) = Forall (v, listMkForall (vs,body));
local
fun strip vs (Forall (v,b)) = strip (v :: vs) b
| strip vs tm = (rev vs, tm);
in
val stripForall = strip [];
end;
(* Existential quantifiers *)
fun destExists (Exists v_f) = v_f
| destExists _ = raise Error "destExists";
val isExists = can destExists;
fun listMkExists ([],body) = body
| listMkExists (v :: vs, body) = Exists (v, listMkExists (vs,body));
local
fun strip vs (Exists (v,b)) = strip (v :: vs) b
| strip vs tm = (rev vs, tm);
in
val stripExists = strip [];
end;
(* ------------------------------------------------------------------------- *)
(* The size of a formula in symbols. *)
(* ------------------------------------------------------------------------- *)
local
fun sz n [] = n
| sz n (True :: fms) = sz (n + 1) fms
| sz n (False :: fms) = sz (n + 1) fms
| sz n (Atom atm :: fms) = sz (n + Atom.symbols atm) fms
| sz n (Not p :: fms) = sz (n + 1) (p :: fms)
| sz n (And (p,q) :: fms) = sz (n + 1) (p :: q :: fms)
| sz n (Or (p,q) :: fms) = sz (n + 1) (p :: q :: fms)
| sz n (Imp (p,q) :: fms) = sz (n + 1) (p :: q :: fms)
| sz n (Iff (p,q) :: fms) = sz (n + 1) (p :: q :: fms)
| sz n (Forall (_,p) :: fms) = sz (n + 1) (p :: fms)
| sz n (Exists (_,p) :: fms) = sz (n + 1) (p :: fms);
in
fun symbols fm = sz 0 [fm];
end;
(* ------------------------------------------------------------------------- *)
(* A total comparison function for formulas. *)
(* ------------------------------------------------------------------------- *)
local
fun cmp [] = EQUAL
| cmp ((True,True) :: l) = cmp l
| cmp ((True,_) :: _) = LESS
| cmp ((_,True) :: _) = GREATER
| cmp ((False,False) :: l) = cmp l
| cmp ((False,_) :: _) = LESS
| cmp ((_,False) :: _) = GREATER
| cmp ((Atom atm1, Atom atm2) :: l) =
(case Atom.compare (atm1,atm2) of
LESS => LESS
| EQUAL => cmp l
| GREATER => GREATER)
| cmp ((Atom _, _) :: _) = LESS
| cmp ((_, Atom _) :: _) = GREATER
| cmp ((Not p1, Not p2) :: l) = cmp ((p1,p2) :: l)
| cmp ((Not _, _) :: _) = LESS
| cmp ((_, Not _) :: _) = GREATER
| cmp ((And (p1,q1), And (p2,q2)) :: l) = cmp ((p1,p2) :: (q1,q2) :: l)
| cmp ((And _, _) :: _) = LESS
| cmp ((_, And _) :: _) = GREATER
| cmp ((Or (p1,q1), Or (p2,q2)) :: l) = cmp ((p1,p2) :: (q1,q2) :: l)
| cmp ((Or _, _) :: _) = LESS
| cmp ((_, Or _) :: _) = GREATER
| cmp ((Imp (p1,q1), Imp (p2,q2)) :: l) = cmp ((p1,p2) :: (q1,q2) :: l)
| cmp ((Imp _, _) :: _) = LESS
| cmp ((_, Imp _) :: _) = GREATER
| cmp ((Iff (p1,q1), Iff (p2,q2)) :: l) = cmp ((p1,p2) :: (q1,q2) :: l)
| cmp ((Iff _, _) :: _) = LESS
| cmp ((_, Iff _) :: _) = GREATER
| cmp ((Forall (v1,p1), Forall (v2,p2)) :: l) =
(case Name.compare (v1,v2) of
LESS => LESS
| EQUAL => cmp ((p1,p2) :: l)
| GREATER => GREATER)
| cmp ((Forall _, Exists _) :: _) = LESS
| cmp ((Exists _, Forall _) :: _) = GREATER
| cmp ((Exists (v1,p1), Exists (v2,p2)) :: l) =
(case Name.compare (v1,v2) of
LESS => LESS
| EQUAL => cmp ((p1,p2) :: l)
| GREATER => GREATER);
in
fun compare fm1_fm2 = cmp [fm1_fm2];
end;
(* ------------------------------------------------------------------------- *)
(* Free variables. *)
(* ------------------------------------------------------------------------- *)
fun freeIn v =
let
fun f [] = false
| f (True :: fms) = f fms
| f (False :: fms) = f fms
| f (Atom atm :: fms) = Atom.freeIn v atm orelse f fms
| f (Not p :: fms) = f (p :: fms)
| f (And (p,q) :: fms) = f (p :: q :: fms)
| f (Or (p,q) :: fms) = f (p :: q :: fms)
| f (Imp (p,q) :: fms) = f (p :: q :: fms)
| f (Iff (p,q) :: fms) = f (p :: q :: fms)
| f (Forall (w,p) :: fms) = if v = w then f fms else f (p :: fms)
| f (Exists (w,p) :: fms) = if v = w then f fms else f (p :: fms)
in
fn fm => f [fm]
end;
local
fun fv vs [] = vs
| fv vs ((_,True) :: fms) = fv vs fms
| fv vs ((_,False) :: fms) = fv vs fms
| fv vs ((bv, Atom atm) :: fms) =
fv (NameSet.union vs (NameSet.difference (Atom.freeVars atm) bv)) fms
| fv vs ((bv, Not p) :: fms) = fv vs ((bv,p) :: fms)
| fv vs ((bv, And (p,q)) :: fms) = fv vs ((bv,p) :: (bv,q) :: fms)
| fv vs ((bv, Or (p,q)) :: fms) = fv vs ((bv,p) :: (bv,q) :: fms)
| fv vs ((bv, Imp (p,q)) :: fms) = fv vs ((bv,p) :: (bv,q) :: fms)
| fv vs ((bv, Iff (p,q)) :: fms) = fv vs ((bv,p) :: (bv,q) :: fms)
| fv vs ((bv, Forall (v,p)) :: fms) = fv vs ((NameSet.add bv v, p) :: fms)
| fv vs ((bv, Exists (v,p)) :: fms) = fv vs ((NameSet.add bv v, p) :: fms);
in
fun freeVars fm = fv NameSet.empty [(NameSet.empty,fm)];
end;
fun specialize fm = snd (stripForall fm);
fun generalize fm = listMkForall (NameSet.toList (freeVars fm), fm);
(* ------------------------------------------------------------------------- *)
(* Substitutions. *)
(* ------------------------------------------------------------------------- *)
local
fun substCheck sub fm = if Subst.null sub then fm else substFm sub fm
and substFm sub fm =
case fm of
True => fm
| False => fm
| Atom (p,tms) =>
let
val tms' = Sharing.map (Subst.subst sub) tms
in
if Sharing.pointerEqual (tms,tms') then fm else Atom (p,tms')
end
| Not p =>
let
val p' = substFm sub p
in
if Sharing.pointerEqual (p,p') then fm else Not p'
end
| And (p,q) => substConn sub fm And p q
| Or (p,q) => substConn sub fm Or p q
| Imp (p,q) => substConn sub fm Imp p q
| Iff (p,q) => substConn sub fm Iff p q
| Forall (v,p) => substQuant sub fm Forall v p
| Exists (v,p) => substQuant sub fm Exists v p
and substConn sub fm conn p q =
let
val p' = substFm sub p
and q' = substFm sub q
in
if Sharing.pointerEqual (p,p') andalso
Sharing.pointerEqual (q,q')
then fm
else conn (p',q')
end
and substQuant sub fm quant v p =
let
val v' =
let
fun f (w,s) =
if w = v then s
else
case Subst.peek sub w of
NONE => NameSet.add s w
| SOME tm => NameSet.union s (Term.freeVars tm)
val vars = freeVars p
val vars = NameSet.foldl f NameSet.empty vars
in
Term.variantPrime vars v
end
val sub =
if v = v' then Subst.remove sub (NameSet.singleton v)
else Subst.insert sub (v, Term.Var v')
val p' = substCheck sub p
in
if v = v' andalso Sharing.pointerEqual (p,p') then fm
else quant (v',p')
end;
in
val subst = substCheck;
end;
(* ------------------------------------------------------------------------- *)
(* The equality relation. *)
(* ------------------------------------------------------------------------- *)
fun mkEq a_b = Atom (Atom.mkEq a_b);
fun destEq fm = Atom.destEq (destAtom fm);
val isEq = can destEq;
fun mkNeq a_b = Not (mkEq a_b);
fun destNeq (Not fm) = destEq fm
| destNeq _ = raise Error "Formula.destNeq";
val isNeq = can destNeq;
fun mkRefl tm = Atom (Atom.mkRefl tm);
fun destRefl fm = Atom.destRefl (destAtom fm);
val isRefl = can destRefl;
fun sym fm = Atom (Atom.sym (destAtom fm));
fun lhs fm = fst (destEq fm);
fun rhs fm = snd (destEq fm);
(* ------------------------------------------------------------------------- *)
(* Parsing and pretty-printing. *)
(* ------------------------------------------------------------------------- *)
type quotation = formula Parser.quotation
val truthSymbol = "T"
and falsitySymbol = "F"
and conjunctionSymbol = "/\\"
and disjunctionSymbol = "\\/"
and implicationSymbol = "==>"
and equivalenceSymbol = "<=>"
and universalSymbol = "!"
and existentialSymbol = "?";
local
fun demote True = Term.Fn (truthSymbol,[])
| demote False = Term.Fn (falsitySymbol,[])
| demote (Atom (p,tms)) = Term.Fn (p,tms)
| demote (Not p) = Term.Fn (!Term.negation, [demote p])
| demote (And (p,q)) = Term.Fn (conjunctionSymbol, [demote p, demote q])
| demote (Or (p,q)) = Term.Fn (disjunctionSymbol, [demote p, demote q])
| demote (Imp (p,q)) = Term.Fn (implicationSymbol, [demote p, demote q])
| demote (Iff (p,q)) = Term.Fn (equivalenceSymbol, [demote p, demote q])
| demote (Forall (v,b)) = Term.Fn (universalSymbol, [Term.Var v, demote b])
| demote (Exists (v,b)) =
Term.Fn (existentialSymbol, [Term.Var v, demote b]);
in
fun pp ppstrm fm = Term.pp ppstrm (demote fm);
end;
val toString = Parser.toString pp;
local
fun isQuant [Term.Var _, _] = true
| isQuant _ = false;
fun promote (Term.Var v) = Atom (v,[])
| promote (Term.Fn (f,tms)) =
if f = truthSymbol andalso null tms then
True
else if f = falsitySymbol andalso null tms then
False
else if f = !Term.negation andalso length tms = 1 then
Not (promote (hd tms))
else if f = conjunctionSymbol andalso length tms = 2 then
And (promote (hd tms), promote (List.nth (tms,1)))
else if f = disjunctionSymbol andalso length tms = 2 then
Or (promote (hd tms), promote (List.nth (tms,1)))
else if f = implicationSymbol andalso length tms = 2 then
Imp (promote (hd tms), promote (List.nth (tms,1)))
else if f = equivalenceSymbol andalso length tms = 2 then
Iff (promote (hd tms), promote (List.nth (tms,1)))
else if f = universalSymbol andalso isQuant tms then
Forall (Term.destVar (hd tms), promote (List.nth (tms,1)))
else if f = existentialSymbol andalso isQuant tms then
Exists (Term.destVar (hd tms), promote (List.nth (tms,1)))
else
Atom (f,tms);
in
fun fromString s = promote (Term.fromString s);
end;
val parse = Parser.parseQuotation toString fromString;
end
end;
(**** Original file: Literal.sig ****)
(* ========================================================================= *)
(* FIRST ORDER LOGIC LITERALS *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Literal =
sig
(* ------------------------------------------------------------------------- *)
(* A type for storing first order logic literals. *)
(* ------------------------------------------------------------------------- *)
type polarity = bool
type literal = polarity * Metis.Atom.atom
(* ------------------------------------------------------------------------- *)
(* Constructors and destructors. *)
(* ------------------------------------------------------------------------- *)
val polarity : literal -> polarity
val atom : literal -> Metis.Atom.atom
val name : literal -> Metis.Atom.relationName
val arguments : literal -> Metis.Term.term list
val arity : literal -> int
val positive : literal -> bool
val negative : literal -> bool
val negate : literal -> literal
val relation : literal -> Metis.Atom.relation
val functions : literal -> Metis.NameAritySet.set
val functionNames : literal -> Metis.NameSet.set
(* Binary relations *)
val mkBinop : Metis.Atom.relationName -> polarity * Metis.Term.term * Metis.Term.term -> literal
val destBinop : Metis.Atom.relationName -> literal -> polarity * Metis.Term.term * Metis.Term.term
val isBinop : Metis.Atom.relationName -> literal -> bool
(* Formulas *)
val toFormula : literal -> Metis.Formula.formula
val fromFormula : Metis.Formula.formula -> literal
(* ------------------------------------------------------------------------- *)
(* The size of a literal in symbols. *)
(* ------------------------------------------------------------------------- *)
val symbols : literal -> int
(* ------------------------------------------------------------------------- *)
(* A total comparison function for literals. *)
(* ------------------------------------------------------------------------- *)
val compare : literal * literal -> order (* negative < positive *)
(* ------------------------------------------------------------------------- *)
(* Subterms. *)
(* ------------------------------------------------------------------------- *)
val subterm : literal -> Metis.Term.path -> Metis.Term.term
val subterms : literal -> (Metis.Term.path * Metis.Term.term) list
val replace : literal -> Metis.Term.path * Metis.Term.term -> literal
(* ------------------------------------------------------------------------- *)
(* Free variables. *)
(* ------------------------------------------------------------------------- *)
val freeIn : Metis.Term.var -> literal -> bool
val freeVars : literal -> Metis.NameSet.set
(* ------------------------------------------------------------------------- *)
(* Substitutions. *)
(* ------------------------------------------------------------------------- *)
val subst : Metis.Subst.subst -> literal -> literal
(* ------------------------------------------------------------------------- *)
(* Matching. *)
(* ------------------------------------------------------------------------- *)
val match : (* raises Error *)
Metis.Subst.subst -> literal -> literal -> Metis.Subst.subst
(* ------------------------------------------------------------------------- *)
(* Unification. *)
(* ------------------------------------------------------------------------- *)
val unify : (* raises Error *)
Metis.Subst.subst -> literal -> literal -> Metis.Subst.subst
(* ------------------------------------------------------------------------- *)
(* The equality relation. *)
(* ------------------------------------------------------------------------- *)
val mkEq : Metis.Term.term * Metis.Term.term -> literal
val destEq : literal -> Metis.Term.term * Metis.Term.term
val isEq : literal -> bool
val mkNeq : Metis.Term.term * Metis.Term.term -> literal
val destNeq : literal -> Metis.Term.term * Metis.Term.term
val isNeq : literal -> bool
val mkRefl : Metis.Term.term -> literal
val destRefl : literal -> Metis.Term.term
val isRefl : literal -> bool
val mkIrrefl : Metis.Term.term -> literal
val destIrrefl : literal -> Metis.Term.term
val isIrrefl : literal -> bool
(* The following work with both equalities and disequalities *)
val sym : literal -> literal (* raises Error if given a refl or irrefl *)
val lhs : literal -> Metis.Term.term
val rhs : literal -> Metis.Term.term
(* ------------------------------------------------------------------------- *)
(* Special support for terms with type annotations. *)
(* ------------------------------------------------------------------------- *)
val typedSymbols : literal -> int
val nonVarTypedSubterms : literal -> (Metis.Term.path * Metis.Term.term) list
(* ------------------------------------------------------------------------- *)
(* Parsing and pretty-printing. *)
(* ------------------------------------------------------------------------- *)
val pp : literal Metis.Parser.pp
val toString : literal -> string
val fromString : string -> literal
val parse : Metis.Term.term Metis.Parser.quotation -> literal
end
(**** Original file: Literal.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* FIRST ORDER LOGIC LITERALS *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Literal :> Literal =
struct
open Useful;
(* ------------------------------------------------------------------------- *)
(* A type for storing first order logic literals. *)
(* ------------------------------------------------------------------------- *)
type polarity = bool;
type literal = polarity * Atom.atom;
(* ------------------------------------------------------------------------- *)
(* Constructors and destructors. *)
(* ------------------------------------------------------------------------- *)
fun polarity ((pol,_) : literal) = pol;
fun atom ((_,atm) : literal) = atm;
fun name lit = Atom.name (atom lit);
fun arguments lit = Atom.arguments (atom lit);
fun arity lit = Atom.arity (atom lit);
fun positive lit = polarity lit;
fun negative lit = not (polarity lit);
fun negate (pol,atm) : literal = (not pol, atm)
fun relation lit = Atom.relation (atom lit);
fun functions lit = Atom.functions (atom lit);
fun functionNames lit = Atom.functionNames (atom lit);
(* Binary relations *)
fun mkBinop rel (pol,a,b) : literal = (pol, Atom.mkBinop rel (a,b));
fun destBinop rel ((pol,atm) : literal) =
case Atom.destBinop rel atm of (a,b) => (pol,a,b);
fun isBinop rel = can (destBinop rel);
(* Formulas *)
fun toFormula (true,atm) = Formula.Atom atm
| toFormula (false,atm) = Formula.Not (Formula.Atom atm);
fun fromFormula (Formula.Atom atm) = (true,atm)
| fromFormula (Formula.Not (Formula.Atom atm)) = (false,atm)
| fromFormula _ = raise Error "Literal.fromFormula";
(* ------------------------------------------------------------------------- *)
(* The size of a literal in symbols. *)
(* ------------------------------------------------------------------------- *)
fun symbols ((_,atm) : literal) = Atom.symbols atm;
(* ------------------------------------------------------------------------- *)
(* A total comparison function for literals. *)
(* ------------------------------------------------------------------------- *)
fun compare ((pol1,atm1),(pol2,atm2)) =
case boolCompare (pol1,pol2) of
LESS => GREATER
| EQUAL => Atom.compare (atm1,atm2)
| GREATER => LESS;
(* ------------------------------------------------------------------------- *)
(* Subterms. *)
(* ------------------------------------------------------------------------- *)
fun subterm lit path = Atom.subterm (atom lit) path;
fun subterms lit = Atom.subterms (atom lit);
fun replace (lit as (pol,atm)) path_tm =
let
val atm' = Atom.replace atm path_tm
in
if Sharing.pointerEqual (atm,atm') then lit else (pol,atm')
end;
(* ------------------------------------------------------------------------- *)
(* Free variables. *)
(* ------------------------------------------------------------------------- *)
fun freeIn v lit = Atom.freeIn v (atom lit);
fun freeVars lit = Atom.freeVars (atom lit);
(* ------------------------------------------------------------------------- *)
(* Substitutions. *)
(* ------------------------------------------------------------------------- *)
fun subst sub (lit as (pol,atm)) : literal =
let
val atm' = Atom.subst sub atm
in
if Sharing.pointerEqual (atm',atm) then lit else (pol,atm')
end;
(* ------------------------------------------------------------------------- *)
(* Matching. *)
(* ------------------------------------------------------------------------- *)
fun match sub ((pol1,atm1) : literal) (pol2,atm2) =
let
val _ = pol1 = pol2 orelse raise Error "Literal.match"
in
Atom.match sub atm1 atm2
end;
(* ------------------------------------------------------------------------- *)
(* Unification. *)
(* ------------------------------------------------------------------------- *)
fun unify sub ((pol1,atm1) : literal) (pol2,atm2) =
let
val _ = pol1 = pol2 orelse raise Error "Literal.unify"
in
Atom.unify sub atm1 atm2
end;
(* ------------------------------------------------------------------------- *)
(* The equality relation. *)
(* ------------------------------------------------------------------------- *)
fun mkEq l_r : literal = (true, Atom.mkEq l_r);
fun destEq ((true,atm) : literal) = Atom.destEq atm
| destEq (false,_) = raise Error "Literal.destEq";
val isEq = can destEq;
fun mkNeq l_r : literal = (false, Atom.mkEq l_r);
fun destNeq ((false,atm) : literal) = Atom.destEq atm
| destNeq (true,_) = raise Error "Literal.destNeq";
val isNeq = can destNeq;
fun mkRefl tm = (true, Atom.mkRefl tm);
fun destRefl (true,atm) = Atom.destRefl atm
| destRefl (false,_) = raise Error "Literal.destRefl";
val isRefl = can destRefl;
fun mkIrrefl tm = (false, Atom.mkRefl tm);
fun destIrrefl (true,_) = raise Error "Literal.destIrrefl"
| destIrrefl (false,atm) = Atom.destRefl atm;
val isIrrefl = can destIrrefl;
fun sym (pol,atm) : literal = (pol, Atom.sym atm);
fun lhs ((_,atm) : literal) = Atom.lhs atm;
fun rhs ((_,atm) : literal) = Atom.rhs atm;
(* ------------------------------------------------------------------------- *)
(* Special support for terms with type annotations. *)
(* ------------------------------------------------------------------------- *)
fun typedSymbols ((_,atm) : literal) = Atom.typedSymbols atm;
fun nonVarTypedSubterms ((_,atm) : literal) = Atom.nonVarTypedSubterms atm;
(* ------------------------------------------------------------------------- *)
(* Parsing and pretty-printing. *)
(* ------------------------------------------------------------------------- *)
val pp = Parser.ppMap toFormula Formula.pp;
val toString = Parser.toString pp;
fun fromString s = fromFormula (Formula.fromString s);
val parse = Parser.parseQuotation Term.toString fromString;
end
structure LiteralOrdered =
struct type t = Literal.literal val compare = Literal.compare end
structure LiteralSet =
struct
local
structure S = ElementSet (LiteralOrdered);
in
open S;
end;
fun negateMember lit set = member (Literal.negate lit) set;
val negate =
let
fun f (lit,set) = add set (Literal.negate lit)
in
foldl f empty
end;
val relations =
let
fun f (lit,set) = NameAritySet.add set (Literal.relation lit)
in
foldl f NameAritySet.empty
end;
val functions =
let
fun f (lit,set) = NameAritySet.union set (Literal.functions lit)
in
foldl f NameAritySet.empty
end;
val freeVars =
let
fun f (lit,set) = NameSet.union set (Literal.freeVars lit)
in
foldl f NameSet.empty
end;
val symbols =
let
fun f (lit,z) = Literal.symbols lit + z
in
foldl f 0
end;
val typedSymbols =
let
fun f (lit,z) = Literal.typedSymbols lit + z
in
foldl f 0
end;
fun subst sub lits =
let
fun substLit (lit,(eq,lits')) =
let
val lit' = Literal.subst sub lit
val eq = eq andalso Sharing.pointerEqual (lit,lit')
in
(eq, add lits' lit')
end
val (eq,lits') = foldl substLit (true,empty) lits
in
if eq then lits else lits'
end;
val pp =
Parser.ppMap
toList
(Parser.ppBracket "{" "}" (Parser.ppSequence "," Literal.pp));
end
structure LiteralMap = KeyMap (LiteralOrdered);
end;
(**** Original file: Thm.sig ****)
(* ========================================================================= *)
(* A LOGICAL KERNEL FOR FIRST ORDER CLAUSES *)
(* Copyright (c) 2001-2004 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Thm =
sig
(* ------------------------------------------------------------------------- *)
(* An abstract type of first order logic theorems. *)
(* ------------------------------------------------------------------------- *)
type clause = Metis.LiteralSet.set
datatype inferenceType =
Axiom
| Assume
| Subst
| Factor
| Resolve
| Refl
| Equality
type thm
type inference = inferenceType * thm list
(* ------------------------------------------------------------------------- *)
(* Theorem destructors. *)
(* ------------------------------------------------------------------------- *)
val clause : thm -> clause
val inference : thm -> inference
(* Tautologies *)
val isTautology : thm -> bool
(* Contradictions *)
val isContradiction : thm -> bool
(* Unit theorems *)
val destUnit : thm -> Metis.Literal.literal
val isUnit : thm -> bool
(* Unit equality theorems *)
val destUnitEq : thm -> Metis.Term.term * Metis.Term.term
val isUnitEq : thm -> bool
(* Literals *)
val member : Metis.Literal.literal -> thm -> bool
val negateMember : Metis.Literal.literal -> thm -> bool
(* ------------------------------------------------------------------------- *)
(* A total order. *)
(* ------------------------------------------------------------------------- *)
val compare : thm * thm -> order
val equal : thm -> thm -> bool
(* ------------------------------------------------------------------------- *)
(* Free variables. *)
(* ------------------------------------------------------------------------- *)
val freeIn : Metis.Term.var -> thm -> bool
val freeVars : thm -> Metis.NameSet.set
(* ------------------------------------------------------------------------- *)
(* Pretty-printing. *)
(* ------------------------------------------------------------------------- *)
val ppInferenceType : inferenceType Metis.Parser.pp
val inferenceTypeToString : inferenceType -> string
val pp : thm Metis.Parser.pp
val toString : thm -> string
(* ------------------------------------------------------------------------- *)
(* Primitive rules of inference. *)
(* ------------------------------------------------------------------------- *)
(* ------------------------------------------------------------------------- *)
(* *)
(* ----- axiom C *)
(* C *)
(* ------------------------------------------------------------------------- *)
val axiom : clause -> thm
(* ------------------------------------------------------------------------- *)
(* *)
(* ----------- assume L *)
(* L \/ ~L *)
(* ------------------------------------------------------------------------- *)
val assume : Metis.Literal.literal -> thm
(* ------------------------------------------------------------------------- *)
(* C *)
(* -------- subst s *)
(* C[s] *)
(* ------------------------------------------------------------------------- *)
val subst : Metis.Subst.subst -> thm -> thm
(* ------------------------------------------------------------------------- *)
(* L \/ C ~L \/ D *)
(* --------------------- resolve L *)
(* C \/ D *)
(* *)
(* The literal L must occur in the first theorem, and the literal ~L must *)
(* occur in the second theorem. *)
(* ------------------------------------------------------------------------- *)
val resolve : Metis.Literal.literal -> thm -> thm -> thm
(* ------------------------------------------------------------------------- *)
(* *)
(* --------- refl t *)
(* t = t *)
(* ------------------------------------------------------------------------- *)
val refl : Metis.Term.term -> thm
(* ------------------------------------------------------------------------- *)
(* *)
(* ------------------------ equality L p t *)
(* ~(s = t) \/ ~L \/ L' *)
(* *)
(* where s is the subterm of L at path p, and L' is L with the subterm at *)
(* path p being replaced by t. *)
(* ------------------------------------------------------------------------- *)
val equality : Metis.Literal.literal -> Metis.Term.path -> Metis.Term.term -> thm
end
(**** Original file: Thm.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* A LOGICAL KERNEL FOR FIRST ORDER CLAUSES *)
(* Copyright (c) 2001-2004 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Thm :> Thm =
struct
open Useful;
(* ------------------------------------------------------------------------- *)
(* An abstract type of first order logic theorems. *)
(* ------------------------------------------------------------------------- *)
type clause = LiteralSet.set;
datatype inferenceType =
Axiom
| Assume
| Subst
| Factor
| Resolve
| Refl
| Equality;
datatype thm = Thm of clause * (inferenceType * thm list);
type inference = inferenceType * thm list;
(* ------------------------------------------------------------------------- *)
(* Theorem destructors. *)
(* ------------------------------------------------------------------------- *)
fun clause (Thm (cl,_)) = cl;
fun inference (Thm (_,inf)) = inf;
(* Tautologies *)
local
fun chk (_,NONE) = NONE
| chk ((pol,atm), SOME set) =
if (pol andalso Atom.isRefl atm) orelse AtomSet.member atm set then NONE
else SOME (AtomSet.add set atm);
in
fun isTautology th =
case LiteralSet.foldl chk (SOME AtomSet.empty) (clause th) of
SOME _ => false
| NONE => true;
end;
(* Contradictions *)
fun isContradiction th = LiteralSet.null (clause th);
(* Unit theorems *)
fun destUnit (Thm (cl,_)) =
if LiteralSet.size cl = 1 then LiteralSet.pick cl
else raise Error "Thm.destUnit";
val isUnit = can destUnit;
(* Unit equality theorems *)
fun destUnitEq th = Literal.destEq (destUnit th);
val isUnitEq = can destUnitEq;
(* Literals *)
fun member lit (Thm (cl,_)) = LiteralSet.member lit cl;
fun negateMember lit (Thm (cl,_)) = LiteralSet.negateMember lit cl;
(* ------------------------------------------------------------------------- *)
(* A total order. *)
(* ------------------------------------------------------------------------- *)
fun compare (th1,th2) = LiteralSet.compare (clause th1, clause th2);
fun equal th1 th2 = LiteralSet.equal (clause th1) (clause th2);
(* ------------------------------------------------------------------------- *)
(* Free variables. *)
(* ------------------------------------------------------------------------- *)
fun freeIn v (Thm (cl,_)) = LiteralSet.exists (Literal.freeIn v) cl;
local
fun free (lit,set) = NameSet.union (Literal.freeVars lit) set;
in
fun freeVars (Thm (cl,_)) = LiteralSet.foldl free NameSet.empty cl;
end;
(* ------------------------------------------------------------------------- *)
(* Pretty-printing. *)
(* ------------------------------------------------------------------------- *)
fun inferenceTypeToString Axiom = "Axiom"
| inferenceTypeToString Assume = "Assume"
| inferenceTypeToString Subst = "Subst"
| inferenceTypeToString Factor = "Factor"
| inferenceTypeToString Resolve = "Resolve"
| inferenceTypeToString Refl = "Refl"
| inferenceTypeToString Equality = "Equality";
fun ppInferenceType ppstrm inf =
Parser.ppString ppstrm (inferenceTypeToString inf);
local
fun toFormula th =
Formula.listMkDisj
(map Literal.toFormula (LiteralSet.toList (clause th)));
in
fun pp ppstrm th =
let
open PP
in
begin_block ppstrm INCONSISTENT 3;
add_string ppstrm "|- ";
Formula.pp ppstrm (toFormula th);
end_block ppstrm
end;
end;
val toString = Parser.toString pp;
(* ------------------------------------------------------------------------- *)
(* Primitive rules of inference. *)
(* ------------------------------------------------------------------------- *)
(* ------------------------------------------------------------------------- *)
(* *)
(* ----- axiom C *)
(* C *)
(* ------------------------------------------------------------------------- *)
fun axiom cl = Thm (cl,(Axiom,[]));
(* ------------------------------------------------------------------------- *)
(* *)
(* ----------- assume L *)
(* L \/ ~L *)
(* ------------------------------------------------------------------------- *)
fun assume lit =
Thm (LiteralSet.fromList [lit, Literal.negate lit], (Assume,[]));
(* ------------------------------------------------------------------------- *)
(* C *)
(* -------- subst s *)
(* C[s] *)
(* ------------------------------------------------------------------------- *)
fun subst sub (th as Thm (cl,inf)) =
let
val cl' = LiteralSet.subst sub cl
in
if Sharing.pointerEqual (cl,cl') then th
else
case inf of
(Subst,_) => Thm (cl',inf)
| _ => Thm (cl',(Subst,[th]))
end;
(* ------------------------------------------------------------------------- *)
(* L \/ C ~L \/ D *)
(* --------------------- resolve L *)
(* C \/ D *)
(* *)
(* The literal L must occur in the first theorem, and the literal ~L must *)
(* occur in the second theorem. *)
(* ------------------------------------------------------------------------- *)
fun resolve lit (th1 as Thm (cl1,_)) (th2 as Thm (cl2,_)) =
let
val cl1' = LiteralSet.delete cl1 lit
and cl2' = LiteralSet.delete cl2 (Literal.negate lit)
in
Thm (LiteralSet.union cl1' cl2', (Resolve,[th1,th2]))
end;
(*DEBUG
val resolve = fn lit => fn pos => fn neg =>
resolve lit pos neg
handle Error err =>
raise Error ("Thm.resolve:\nlit = " ^ Literal.toString lit ^
"\npos = " ^ toString pos ^
"\nneg = " ^ toString neg ^ "\n" ^ err);
*)
(* ------------------------------------------------------------------------- *)
(* *)
(* --------- refl t *)
(* t = t *)
(* ------------------------------------------------------------------------- *)
fun refl tm = Thm (LiteralSet.singleton (true, Atom.mkRefl tm), (Refl,[]));
(* ------------------------------------------------------------------------- *)
(* *)
(* ------------------------ equality L p t *)
(* ~(s = t) \/ ~L \/ L' *)
(* *)
(* where s is the subterm of L at path p, and L' is L with the subterm at *)
(* path p being replaced by t. *)
(* ------------------------------------------------------------------------- *)
fun equality lit path t =
let
val s = Literal.subterm lit path
val lit' = Literal.replace lit (path,t)
val eqLit = Literal.mkNeq (s,t)
val cl = LiteralSet.fromList [eqLit, Literal.negate lit, lit']
in
Thm (cl,(Equality,[]))
end;
end
end;
(**** Original file: Proof.sig ****)
(* ========================================================================= *)
(* PROOFS IN FIRST ORDER LOGIC *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Proof =
sig
(* ------------------------------------------------------------------------- *)
(* A type of first order logic proofs. *)
(* ------------------------------------------------------------------------- *)
datatype inference =
Axiom of Metis.LiteralSet.set
| Assume of Metis.Atom.atom
| Subst of Metis.Subst.subst * Metis.Thm.thm
| Resolve of Metis.Atom.atom * Metis.Thm.thm * Metis.Thm.thm
| Refl of Metis.Term.term
| Equality of Metis.Literal.literal * Metis.Term.path * Metis.Term.term
type proof = (Metis.Thm.thm * inference) list
(* ------------------------------------------------------------------------- *)
(* Reconstructing single inferences. *)
(* ------------------------------------------------------------------------- *)
val inferenceType : inference -> Metis.Thm.inferenceType
val parents : inference -> Metis.Thm.thm list
val inferenceToThm : inference -> Metis.Thm.thm
val thmToInference : Metis.Thm.thm -> inference
(* ------------------------------------------------------------------------- *)
(* Reconstructing whole proofs. *)
(* ------------------------------------------------------------------------- *)
val proof : Metis.Thm.thm -> proof
(* ------------------------------------------------------------------------- *)
(* Printing. *)
(* ------------------------------------------------------------------------- *)
val ppInference : inference Metis.Parser.pp
val inferenceToString : inference -> string
val pp : proof Metis.Parser.pp
val toString : proof -> string
end
(**** Original file: Proof.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* PROOFS IN FIRST ORDER LOGIC *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Proof :> Proof =
struct
open Useful;
(* ------------------------------------------------------------------------- *)
(* A type of first order logic proofs. *)
(* ------------------------------------------------------------------------- *)
datatype inference =
Axiom of LiteralSet.set
| Assume of Atom.atom
| Subst of Subst.subst * Thm.thm
| Resolve of Atom.atom * Thm.thm * Thm.thm
| Refl of Term.term
| Equality of Literal.literal * Term.path * Term.term;
type proof = (Thm.thm * inference) list;
(* ------------------------------------------------------------------------- *)
(* Printing. *)
(* ------------------------------------------------------------------------- *)
fun inferenceType (Axiom _) = Thm.Axiom
| inferenceType (Assume _) = Thm.Assume
| inferenceType (Subst _) = Thm.Subst
| inferenceType (Resolve _) = Thm.Resolve
| inferenceType (Refl _) = Thm.Refl
| inferenceType (Equality _) = Thm.Equality;
local
fun ppAssume pp atm = (Parser.addBreak pp (1,0); Atom.pp pp atm);
fun ppSubst ppThm pp (sub,thm) =
(Parser.addBreak pp (1,0);
Parser.beginBlock pp Parser.Inconsistent 1;
Parser.addString pp "{";
Parser.ppBinop " =" Parser.ppString Subst.pp pp ("sub",sub);
Parser.addString pp ",";
Parser.addBreak pp (1,0);
Parser.ppBinop " =" Parser.ppString ppThm pp ("thm",thm);
Parser.addString pp "}";
Parser.endBlock pp);
fun ppResolve ppThm pp (res,pos,neg) =
(Parser.addBreak pp (1,0);
Parser.beginBlock pp Parser.Inconsistent 1;
Parser.addString pp "{";
Parser.ppBinop " =" Parser.ppString Atom.pp pp ("res",res);
Parser.addString pp ",";
Parser.addBreak pp (1,0);
Parser.ppBinop " =" Parser.ppString ppThm pp ("pos",pos);
Parser.addString pp ",";
Parser.addBreak pp (1,0);
Parser.ppBinop " =" Parser.ppString ppThm pp ("neg",neg);
Parser.addString pp "}";
Parser.endBlock pp);
fun ppRefl pp tm = (Parser.addBreak pp (1,0); Term.pp pp tm);
fun ppEquality pp (lit,path,res) =
(Parser.addBreak pp (1,0);
Parser.beginBlock pp Parser.Inconsistent 1;
Parser.addString pp "{";
Parser.ppBinop " =" Parser.ppString Literal.pp pp ("lit",lit);
Parser.addString pp ",";
Parser.addBreak pp (1,0);
Parser.ppBinop " =" Parser.ppString Term.ppPath pp ("path",path);
Parser.addString pp ",";
Parser.addBreak pp (1,0);
Parser.ppBinop " =" Parser.ppString Term.pp pp ("res",res);
Parser.addString pp "}";
Parser.endBlock pp);
fun ppInf ppAxiom ppThm pp inf =
let
val infString = Thm.inferenceTypeToString (inferenceType inf)
in
Parser.beginBlock pp Parser.Inconsistent (size infString + 1);
Parser.ppString pp infString;
case inf of
Axiom cl => ppAxiom pp cl
| Assume x => ppAssume pp x
| Subst x => ppSubst ppThm pp x
| Resolve x => ppResolve ppThm pp x
| Refl x => ppRefl pp x
| Equality x => ppEquality pp x;
Parser.endBlock pp
end;
fun ppAxiom pp cl =
(Parser.addBreak pp (1,0);
Parser.ppMap
LiteralSet.toList
(Parser.ppBracket "{" "}" (Parser.ppSequence "," Literal.pp)) pp cl);
in
val ppInference = ppInf ppAxiom Thm.pp;
fun pp p prf =
let
fun thmString n = "(" ^ Int.toString n ^ ")"
val prf = enumerate prf
fun ppThm p th =
let
val cl = Thm.clause th
fun pred (_,(th',_)) = LiteralSet.equal (Thm.clause th') cl
in
case List.find pred prf of
NONE => Parser.addString p "(?)"
| SOME (n,_) => Parser.addString p (thmString n)
end
fun ppStep (n,(th,inf)) =
let
val s = thmString n
in
Parser.beginBlock p Parser.Consistent (1 + size s);
Parser.addString p (s ^ " ");
Thm.pp p th;
Parser.addBreak p (2,0);
Parser.ppBracket "[" "]" (ppInf (K (K ())) ppThm) p inf;
Parser.endBlock p;
Parser.addNewline p
end
in
Parser.beginBlock p Parser.Consistent 0;
Parser.addString p "START OF PROOF";
Parser.addNewline p;
app ppStep prf;
Parser.addString p "END OF PROOF";
Parser.addNewline p;
Parser.endBlock p
end
(*DEBUG
handle Error err => raise Bug ("Proof.pp: shouldn't fail:\n" ^ err);
*)
end;
val inferenceToString = Parser.toString ppInference;
val toString = Parser.toString pp;
(* ------------------------------------------------------------------------- *)
(* Reconstructing single inferences. *)
(* ------------------------------------------------------------------------- *)
fun parents (Axiom _) = []
| parents (Assume _) = []
| parents (Subst (_,th)) = [th]
| parents (Resolve (_,th,th')) = [th,th']
| parents (Refl _) = []
| parents (Equality _) = [];
fun inferenceToThm (Axiom cl) = Thm.axiom cl
| inferenceToThm (Assume atm) = Thm.assume (true,atm)
| inferenceToThm (Subst (sub,th)) = Thm.subst sub th
| inferenceToThm (Resolve (atm,th,th')) = Thm.resolve (true,atm) th th'
| inferenceToThm (Refl tm) = Thm.refl tm
| inferenceToThm (Equality (lit,path,r)) = Thm.equality lit path r;
local
fun reconstructSubst cl cl' =
let
fun recon [] =
let
(*TRACE3
val () = Parser.ppTrace LiteralSet.pp "reconstructSubst: cl" cl
val () = Parser.ppTrace LiteralSet.pp "reconstructSubst: cl'" cl'
*)
in
raise Bug "can't reconstruct Subst rule"
end
| recon (([],sub) :: others) =
if LiteralSet.equal (LiteralSet.subst sub cl) cl' then sub
else recon others
| recon ((lit :: lits, sub) :: others) =
let
fun checkLit (lit',acc) =
case total (Literal.match sub lit) lit' of
NONE => acc
| SOME sub => (lits,sub) :: acc
in
recon (LiteralSet.foldl checkLit others cl')
end
in
Subst.normalize (recon [(LiteralSet.toList cl, Subst.empty)])
end
(*DEBUG
handle Error err =>
raise Bug ("Proof.recontructSubst: shouldn't fail:\n" ^ err);
*)
fun reconstructResolvant cl1 cl2 cl =
(if not (LiteralSet.subset cl1 cl) then
LiteralSet.pick (LiteralSet.difference cl1 cl)
else if not (LiteralSet.subset cl2 cl) then
Literal.negate (LiteralSet.pick (LiteralSet.difference cl2 cl))
else
(* A useless resolution, but we must reconstruct it anyway *)
let
val cl1' = LiteralSet.negate cl1
and cl2' = LiteralSet.negate cl2
val lits = LiteralSet.intersectList [cl1,cl1',cl2,cl2']
in
if not (LiteralSet.null lits) then LiteralSet.pick lits
else raise Bug "can't reconstruct Resolve rule"
end)
(*DEBUG
handle Error err =>
raise Bug ("Proof.recontructResolvant: shouldn't fail:\n" ^ err);
*)
fun reconstructEquality cl =
let
(*TRACE3
val () = Parser.ppTrace LiteralSet.pp "Proof.reconstructEquality: cl" cl
*)
fun sync s t path (f,a) (f',a') =
if f <> f' orelse length a <> length a' then NONE
else
case List.filter (op<> o snd) (enumerate (zip a a')) of
[(i,(tm,tm'))] =>
let
val path = i :: path
in
if tm = s andalso tm' = t then SOME (rev path)
else
case (tm,tm') of
(Term.Fn f_a, Term.Fn f_a') => sync s t path f_a f_a'
| _ => NONE
end
| _ => NONE
fun recon (neq,(pol,atm),(pol',atm')) =
if pol = pol' then NONE
else
let
val (s,t) = Literal.destNeq neq
val path =
if s <> t then sync s t [] atm atm'
else if atm <> atm' then NONE
else Atom.find (equal s) atm
in
case path of
SOME path => SOME ((pol',atm),path,t)
| NONE => NONE
end
val candidates =
case List.partition Literal.isNeq (LiteralSet.toList cl) of
([l1],[l2,l3]) => [(l1,l2,l3),(l1,l3,l2)]
| ([l1,l2],[l3]) => [(l1,l2,l3),(l1,l3,l2),(l2,l1,l3),(l2,l3,l1)]
| ([l1],[l2]) => [(l1,l1,l2),(l1,l2,l1)]
| _ => raise Bug "reconstructEquality: malformed"
(*TRACE3
val ppCands =
Parser.ppList (Parser.ppTriple Literal.pp Literal.pp Literal.pp)
val () = Parser.ppTrace ppCands
"Proof.reconstructEquality: candidates" candidates
*)
in
case first recon candidates of
SOME info => info
| NONE => raise Bug "can't reconstruct Equality rule"
end
(*DEBUG
handle Error err =>
raise Bug ("Proof.recontructEquality: shouldn't fail:\n" ^ err);
*)
fun reconstruct cl (Thm.Axiom,[]) = Axiom cl
| reconstruct cl (Thm.Assume,[]) =
(case LiteralSet.findl Literal.positive cl of
SOME (_,atm) => Assume atm
| NONE => raise Bug "malformed Assume inference")
| reconstruct cl (Thm.Subst,[th]) =
Subst (reconstructSubst (Thm.clause th) cl, th)
| reconstruct cl (Thm.Resolve,[th1,th2]) =
let
val cl1 = Thm.clause th1
and cl2 = Thm.clause th2
val (pol,atm) = reconstructResolvant cl1 cl2 cl
in
if pol then Resolve (atm,th1,th2) else Resolve (atm,th2,th1)
end
| reconstruct cl (Thm.Refl,[]) =
(case LiteralSet.findl (K true) cl of
SOME lit => Refl (Literal.destRefl lit)
| NONE => raise Bug "malformed Refl inference")
| reconstruct cl (Thm.Equality,[]) = Equality (reconstructEquality cl)
| reconstruct _ _ = raise Bug "malformed inference";
in
fun thmToInference th =
let
(*TRACE3
val () = Parser.ppTrace Thm.pp "Proof.thmToInference: th" th
*)
val cl = Thm.clause th
val thmInf = Thm.inference th
(*TRACE3
val ppThmInf = Parser.ppPair Thm.ppInferenceType (Parser.ppList Thm.pp)
val () = Parser.ppTrace ppThmInf "Proof.thmToInference: thmInf" thmInf
*)
val inf = reconstruct cl thmInf
(*TRACE3
val () = Parser.ppTrace ppInference "Proof.thmToInference: inf" inf
*)
(*DEBUG
val () =
let
val th' = inferenceToThm inf
in
if LiteralSet.equal (Thm.clause th') cl then ()
else
raise
Bug
("Proof.thmToInference: bad inference reconstruction:" ^
"\n th = " ^ Thm.toString th ^
"\n inf = " ^ inferenceToString inf ^
"\n inf th = " ^ Thm.toString th')
end
*)
in
inf
end
(*DEBUG
handle Error err =>
raise Bug ("Proof.thmToInference: shouldn't fail:\n" ^ err);
*)
end;
(* ------------------------------------------------------------------------- *)
(* Reconstructing whole proofs. *)
(* ------------------------------------------------------------------------- *)
local
fun thmCompare (th1,th2) =
LiteralSet.compare (Thm.clause th1, Thm.clause th2);
fun buildProof (th,(m,l)) =
if Map.inDomain th m then (m,l)
else
let
val (_,deps) = Thm.inference th
val (m,l) = foldl buildProof (m,l) deps
in
if Map.inDomain th m then (m,l)
else
let
val l = (th, thmToInference th) :: l
in
(Map.insert m (th,l), l)
end
end;
in
fun proof th =
let
(*TRACE3
val () = Parser.ppTrace Thm.pp "Proof.proof: th" th
*)
val (m,_) = buildProof (th, (Map.new thmCompare, []))
(*TRACE3
val () = Parser.ppTrace Parser.ppInt "Proof.proof: size" (Map.size m)
*)
in
case Map.peek m th of
SOME l => rev l
| NONE => raise Bug "Proof.proof"
end;
end;
end
end;
(**** Original file: Rule.sig ****)
(* ========================================================================= *)
(* DERIVED RULES FOR CREATING FIRST ORDER LOGIC THEOREMS *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Rule =
sig
(* ------------------------------------------------------------------------- *)
(* An equation consists of two terms (t,u) plus a theorem (stronger than) *)
(* t = u \/ C. *)
(* ------------------------------------------------------------------------- *)
type equation = (Metis.Term.term * Metis.Term.term) * Metis.Thm.thm
val ppEquation : equation Metis.Parser.pp
val equationToString : equation -> string
(* Returns t = u if the equation theorem contains this literal *)
val equationLiteral : equation -> Metis.Literal.literal option
val reflEqn : Metis.Term.term -> equation
val symEqn : equation -> equation
val transEqn : equation -> equation -> equation
(* ------------------------------------------------------------------------- *)
(* A conversion takes a term t and either: *)
(* 1. Returns a term u together with a theorem (stronger than) t = u \/ C. *)
(* 2. Raises an Error exception. *)
(* ------------------------------------------------------------------------- *)
type conv = Metis.Term.term -> Metis.Term.term * Metis.Thm.thm
val allConv : conv
val noConv : conv
val thenConv : conv -> conv -> conv
val orelseConv : conv -> conv -> conv
val tryConv : conv -> conv
val repeatConv : conv -> conv
val firstConv : conv list -> conv
val everyConv : conv list -> conv
val rewrConv : equation -> Metis.Term.path -> conv
val pathConv : conv -> Metis.Term.path -> conv
val subtermConv : conv -> int -> conv
val subtermsConv : conv -> conv (* All function arguments *)
(* ------------------------------------------------------------------------- *)
(* Applying a conversion to every subterm, with some traversal strategy. *)
(* ------------------------------------------------------------------------- *)
val bottomUpConv : conv -> conv
val topDownConv : conv -> conv
val repeatTopDownConv : conv -> conv (* useful for rewriting *)
(* ------------------------------------------------------------------------- *)
(* A literule (bad pun) takes a literal L and either: *)
(* 1. Returns a literal L' with a theorem (stronger than) ~L \/ L' \/ C. *)
(* 2. Raises an Error exception. *)
(* ------------------------------------------------------------------------- *)
type literule = Metis.Literal.literal -> Metis.Literal.literal * Metis.Thm.thm
val allLiterule : literule
val noLiterule : literule
val thenLiterule : literule -> literule -> literule
val orelseLiterule : literule -> literule -> literule
val tryLiterule : literule -> literule
val repeatLiterule : literule -> literule
val firstLiterule : literule list -> literule
val everyLiterule : literule list -> literule
val rewrLiterule : equation -> Metis.Term.path -> literule
val pathLiterule : conv -> Metis.Term.path -> literule
val argumentLiterule : conv -> int -> literule
val allArgumentsLiterule : conv -> literule
(* ------------------------------------------------------------------------- *)
(* A rule takes one theorem and either deduces another or raises an Error *)
(* exception. *)
(* ------------------------------------------------------------------------- *)
type rule = Metis.Thm.thm -> Metis.Thm.thm
val allRule : rule
val noRule : rule
val thenRule : rule -> rule -> rule
val orelseRule : rule -> rule -> rule
val tryRule : rule -> rule
val changedRule : rule -> rule
val repeatRule : rule -> rule
val firstRule : rule list -> rule
val everyRule : rule list -> rule
val literalRule : literule -> Metis.Literal.literal -> rule
val rewrRule : equation -> Metis.Literal.literal -> Metis.Term.path -> rule
val pathRule : conv -> Metis.Literal.literal -> Metis.Term.path -> rule
val literalsRule : literule -> Metis.LiteralSet.set -> rule
val allLiteralsRule : literule -> rule
val convRule : conv -> rule (* All arguments of all literals *)
(* ------------------------------------------------------------------------- *)
(* *)
(* --------- reflexivity *)
(* x = x *)
(* ------------------------------------------------------------------------- *)
val reflexivity : Metis.Thm.thm
(* ------------------------------------------------------------------------- *)
(* *)
(* --------------------- symmetry *)
(* ~(x = y) \/ y = x *)
(* ------------------------------------------------------------------------- *)
val symmetry : Metis.Thm.thm
(* ------------------------------------------------------------------------- *)
(* *)
(* --------------------------------- transitivity *)
(* ~(x = y) \/ ~(y = z) \/ x = z *)
(* ------------------------------------------------------------------------- *)
val transitivity : Metis.Thm.thm
(* ------------------------------------------------------------------------- *)
(* *)
(* ---------------------------------------------- functionCongruence (f,n) *)
(* ~(x0 = y0) \/ ... \/ ~(x{n-1} = y{n-1}) \/ *)
(* f x0 ... x{n-1} = f y0 ... y{n-1} *)
(* ------------------------------------------------------------------------- *)
val functionCongruence : Metis.Term.function -> Metis.Thm.thm
(* ------------------------------------------------------------------------- *)
(* *)
(* ---------------------------------------------- relationCongruence (R,n) *)
(* ~(x0 = y0) \/ ... \/ ~(x{n-1} = y{n-1}) \/ *)
(* ~R x0 ... x{n-1} \/ R y0 ... y{n-1} *)
(* ------------------------------------------------------------------------- *)
val relationCongruence : Metis.Atom.relation -> Metis.Thm.thm
(* ------------------------------------------------------------------------- *)
(* x = y \/ C *)
(* -------------- symEq (x = y) *)
(* y = x \/ C *)
(* ------------------------------------------------------------------------- *)
val symEq : Metis.Literal.literal -> rule
(* ------------------------------------------------------------------------- *)
(* ~(x = y) \/ C *)
(* ----------------- symNeq ~(x = y) *)
(* ~(y = x) \/ C *)
(* ------------------------------------------------------------------------- *)
val symNeq : Metis.Literal.literal -> rule
(* ------------------------------------------------------------------------- *)
(* sym (x = y) = symEq (x = y) /\ sym ~(x = y) = symNeq ~(x = y) *)
(* ------------------------------------------------------------------------- *)
val sym : Metis.Literal.literal -> rule
(* ------------------------------------------------------------------------- *)
(* ~(x = x) \/ C *)
(* ----------------- removeIrrefl *)
(* C *)
(* *)
(* where all irreflexive equalities. *)
(* ------------------------------------------------------------------------- *)
val removeIrrefl : rule
(* ------------------------------------------------------------------------- *)
(* x = y \/ y = x \/ C *)
(* ----------------------- removeSym *)
(* x = y \/ C *)
(* *)
(* where all duplicate copies of equalities and disequalities are removed. *)
(* ------------------------------------------------------------------------- *)
val removeSym : rule
(* ------------------------------------------------------------------------- *)
(* ~(v = t) \/ C *)
(* ----------------- expandAbbrevs *)
(* C[t/v] *)
(* *)
(* where t must not contain any occurrence of the variable v. *)
(* ------------------------------------------------------------------------- *)
val expandAbbrevs : rule
(* ------------------------------------------------------------------------- *)
(* simplify = isTautology + expandAbbrevs + removeSym *)
(* ------------------------------------------------------------------------- *)
val simplify : Metis.Thm.thm -> Metis.Thm.thm option
(* ------------------------------------------------------------------------- *)
(* C *)
(* -------- freshVars *)
(* C[s] *)
(* *)
(* where s is a renaming substitution chosen so that all of the variables in *)
(* C are replaced by fresh variables. *)
(* ------------------------------------------------------------------------- *)
val freshVars : rule
(* ------------------------------------------------------------------------- *)
(* C *)
(* ---------------------------- factor *)
(* C_s_1, C_s_2, ..., C_s_n *)
(* *)
(* where each s_i is a substitution that factors C, meaning that the theorem *)
(* *)
(* C_s_i = (removeIrrefl o removeSym o Metis.Thm.subst s_i) C *)
(* *)
(* has fewer literals than C. *)
(* *)
(* Also, if s is any substitution that factors C, then one of the s_i will *)
(* result in a theorem C_s_i that strictly subsumes the theorem C_s. *)
(* ------------------------------------------------------------------------- *)
val factor' : Metis.Thm.clause -> Metis.Subst.subst list
val factor : Metis.Thm.thm -> Metis.Thm.thm list
end
(**** Original file: Rule.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* DERIVED RULES FOR CREATING FIRST ORDER LOGIC THEOREMS *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Rule :> Rule =
struct
open Useful;
(* ------------------------------------------------------------------------- *)
(* *)
(* --------- reflexivity *)
(* x = x *)
(* ------------------------------------------------------------------------- *)
val reflexivity = Thm.refl (Term.Var "x");
(* ------------------------------------------------------------------------- *)
(* *)
(* --------------------- symmetry *)
(* ~(x = y) \/ y = x *)
(* ------------------------------------------------------------------------- *)
val symmetry =
let
val x = Term.Var "x"
and y = Term.Var "y"
val reflTh = reflexivity
val reflLit = Thm.destUnit reflTh
val eqTh = Thm.equality reflLit [0] y
in
Thm.resolve reflLit reflTh eqTh
end;
(* ------------------------------------------------------------------------- *)
(* *)
(* --------------------------------- transitivity *)
(* ~(x = y) \/ ~(y = z) \/ x = z *)
(* ------------------------------------------------------------------------- *)
val transitivity =
let
val x = Term.Var "x"
and y = Term.Var "y"
and z = Term.Var "z"
val eqTh = Thm.equality (Literal.mkEq (y,z)) [0] x
in
Thm.resolve (Literal.mkEq (y,x)) symmetry eqTh
end;
(* ------------------------------------------------------------------------- *)
(* x = y \/ C *)
(* -------------- symEq (x = y) *)
(* y = x \/ C *)
(* ------------------------------------------------------------------------- *)
fun symEq lit th =
let
val (x,y) = Literal.destEq lit
in
if x = y then th
else
let
val sub = Subst.fromList [("x",x),("y",y)]
val symTh = Thm.subst sub symmetry
in
Thm.resolve lit th symTh
end
end;
(* ------------------------------------------------------------------------- *)
(* An equation consists of two terms (t,u) plus a theorem (stronger than) *)
(* t = u \/ C. *)
(* ------------------------------------------------------------------------- *)
type equation = (Term.term * Term.term) * Thm.thm;
fun ppEquation pp (eqn as (_,th)) = Thm.pp pp th;
fun equationToString x = Parser.toString ppEquation x;
fun equationLiteral (t_u,th) =
let
val lit = Literal.mkEq t_u
in
if LiteralSet.member lit (Thm.clause th) then SOME lit else NONE
end;
fun reflEqn t = ((t,t), Thm.refl t);
fun symEqn (eqn as ((t,u), th)) =
if t = u then eqn
else
((u,t),
case equationLiteral eqn of
SOME t_u => symEq t_u th
| NONE => th);
fun transEqn (eqn1 as ((x,y), th1)) (eqn2 as ((_,z), th2)) =
if x = y then eqn2
else if y = z then eqn1
else if x = z then reflEqn x
else
((x,z),
case equationLiteral eqn1 of
NONE => th1
| SOME x_y =>
case equationLiteral eqn2 of
NONE => th2
| SOME y_z =>
let
val sub = Subst.fromList [("x",x),("y",y),("z",z)]
val th = Thm.subst sub transitivity
val th = Thm.resolve x_y th1 th
val th = Thm.resolve y_z th2 th
in
th
end);
(*DEBUG
val transEqn = fn eqn1 => fn eqn2 =>
transEqn eqn1 eqn2
handle Error err =>
raise Error ("Rule.transEqn:\neqn1 = " ^ equationToString eqn1 ^
"\neqn2 = " ^ equationToString eqn2 ^ "\n" ^ err);
*)
(* ------------------------------------------------------------------------- *)
(* A conversion takes a term t and either: *)
(* 1. Returns a term u together with a theorem (stronger than) t = u \/ C. *)
(* 2. Raises an Error exception. *)
(* ------------------------------------------------------------------------- *)
type conv = Term.term -> Term.term * Thm.thm;
fun allConv tm = (tm, Thm.refl tm);
val noConv : conv = fn _ => raise Error "noConv";
fun traceConv s conv tm =
let
val res as (tm',th) = conv tm
val () = print (s ^ ": " ^ Term.toString tm ^ " --> " ^
Term.toString tm' ^ " " ^ Thm.toString th ^ "\n")
in
res
end
handle Error err =>
(print (s ^ ": " ^ Term.toString tm ^ " --> Error: " ^ err ^ "\n");
raise Error (s ^ ": " ^ err));
fun thenConvTrans tm (tm',th1) (tm'',th2) =
let
val eqn1 = ((tm,tm'),th1)
and eqn2 = ((tm',tm''),th2)
val (_,th) = transEqn eqn1 eqn2
in
(tm'',th)
end;
fun thenConv conv1 conv2 tm =
let
val res1 as (tm',_) = conv1 tm
val res2 = conv2 tm'
in
thenConvTrans tm res1 res2
end;
fun orelseConv (conv1 : conv) conv2 tm = conv1 tm handle Error _ => conv2 tm;
fun tryConv conv = orelseConv conv allConv;
fun changedConv conv tm =
let
val res as (tm',_) = conv tm
in
if tm = tm' then raise Error "changedConv" else res
end;
fun repeatConv conv tm = tryConv (thenConv conv (repeatConv conv)) tm;
fun firstConv [] _ = raise Error "firstConv"
| firstConv [conv] tm = conv tm
| firstConv (conv :: convs) tm = orelseConv conv (firstConv convs) tm;
fun everyConv [] tm = allConv tm
| everyConv [conv] tm = conv tm
| everyConv (conv :: convs) tm = thenConv conv (everyConv convs) tm;
fun rewrConv (eqn as ((x,y), eqTh)) path tm =
if x = y then allConv tm
else if null path then (y,eqTh)
else
let
val reflTh = Thm.refl tm
val reflLit = Thm.destUnit reflTh
val th = Thm.equality reflLit (1 :: path) y
val th = Thm.resolve reflLit reflTh th
val th =
case equationLiteral eqn of
NONE => th
| SOME x_y => Thm.resolve x_y eqTh th
val tm' = Term.replace tm (path,y)
in
(tm',th)
end;
(*DEBUG
val rewrConv = fn eqn as ((x,y),eqTh) => fn path => fn tm =>
rewrConv eqn path tm
handle Error err =>
raise Error ("Rule.rewrConv:\nx = " ^ Term.toString x ^
"\ny = " ^ Term.toString y ^
"\neqTh = " ^ Thm.toString eqTh ^
"\npath = " ^ Term.pathToString path ^
"\ntm = " ^ Term.toString tm ^ "\n" ^ err);
*)
fun pathConv conv path tm =
let
val x = Term.subterm tm path
val (y,th) = conv x
in
rewrConv ((x,y),th) path tm
end;
fun subtermConv conv i = pathConv conv [i];
fun subtermsConv _ (tm as Term.Var _) = allConv tm
| subtermsConv conv (tm as Term.Fn (_,a)) =
everyConv (map (subtermConv conv) (interval 0 (length a))) tm;
(* ------------------------------------------------------------------------- *)
(* Applying a conversion to every subterm, with some traversal strategy. *)
(* ------------------------------------------------------------------------- *)
fun bottomUpConv conv tm =
thenConv (subtermsConv (bottomUpConv conv)) (repeatConv conv) tm;
fun topDownConv conv tm =
thenConv (repeatConv conv) (subtermsConv (topDownConv conv)) tm;
fun repeatTopDownConv conv =
let
fun f tm = thenConv (repeatConv conv) g tm
and g tm = thenConv (subtermsConv f) h tm
and h tm = tryConv (thenConv conv f) tm
in
f
end;
(*DEBUG
val repeatTopDownConv = fn conv => fn tm =>
repeatTopDownConv conv tm
handle Error err => raise Error ("repeatTopDownConv: " ^ err);
*)
(* ------------------------------------------------------------------------- *)
(* A literule (bad pun) takes a literal L and either: *)
(* 1. Returns a literal L' with a theorem (stronger than) ~L \/ L' \/ C. *)
(* 2. Raises an Error exception. *)
(* ------------------------------------------------------------------------- *)
type literule = Literal.literal -> Literal.literal * Thm.thm;
fun allLiterule lit = (lit, Thm.assume lit);
val noLiterule : literule = fn _ => raise Error "noLiterule";
fun thenLiterule literule1 literule2 lit =
let
val res1 as (lit',th1) = literule1 lit
val res2 as (lit'',th2) = literule2 lit'
in
if lit = lit' then res2
else if lit' = lit'' then res1
else if lit = lit'' then allLiterule lit
else
(lit'',
if not (Thm.member lit' th1) then th1
else if not (Thm.negateMember lit' th2) then th2
else Thm.resolve lit' th1 th2)
end;
fun orelseLiterule (literule1 : literule) literule2 lit =
literule1 lit handle Error _ => literule2 lit;
fun tryLiterule literule = orelseLiterule literule allLiterule;
fun changedLiterule literule lit =
let
val res as (lit',_) = literule lit
in
if lit = lit' then raise Error "changedLiterule" else res
end;
fun repeatLiterule literule lit =
tryLiterule (thenLiterule literule (repeatLiterule literule)) lit;
fun firstLiterule [] _ = raise Error "firstLiterule"
| firstLiterule [literule] lit = literule lit
| firstLiterule (literule :: literules) lit =
orelseLiterule literule (firstLiterule literules) lit;
fun everyLiterule [] lit = allLiterule lit
| everyLiterule [literule] lit = literule lit
| everyLiterule (literule :: literules) lit =
thenLiterule literule (everyLiterule literules) lit;
fun rewrLiterule (eqn as ((x,y),eqTh)) path lit =
if x = y then allLiterule lit
else
let
val th = Thm.equality lit path y
val th =
case equationLiteral eqn of
NONE => th
| SOME x_y => Thm.resolve x_y eqTh th
val lit' = Literal.replace lit (path,y)
in
(lit',th)
end;
(*DEBUG
val rewrLiterule = fn eqn => fn path => fn lit =>
rewrLiterule eqn path lit
handle Error err =>
raise Error ("Rule.rewrLiterule:\neqn = " ^ equationToString eqn ^
"\npath = " ^ Term.pathToString path ^
"\nlit = " ^ Literal.toString lit ^ "\n" ^ err);
*)
fun pathLiterule conv path lit =
let
val tm = Literal.subterm lit path
val (tm',th) = conv tm
in
rewrLiterule ((tm,tm'),th) path lit
end;
fun argumentLiterule conv i = pathLiterule conv [i];
fun allArgumentsLiterule conv lit =
everyLiterule
(map (argumentLiterule conv) (interval 0 (Literal.arity lit))) lit;
(* ------------------------------------------------------------------------- *)
(* A rule takes one theorem and either deduces another or raises an Error *)
(* exception. *)
(* ------------------------------------------------------------------------- *)
type rule = Thm.thm -> Thm.thm;
val allRule : rule = fn th => th;
val noRule : rule = fn _ => raise Error "noRule";
fun thenRule (rule1 : rule) (rule2 : rule) th = rule1 (rule2 th);
fun orelseRule (rule1 : rule) rule2 th = rule1 th handle Error _ => rule2 th;
fun tryRule rule = orelseRule rule allRule;
fun changedRule rule th =
let
val th' = rule th
in
if not (LiteralSet.equal (Thm.clause th) (Thm.clause th')) then th'
else raise Error "changedRule"
end;
fun repeatRule rule lit = tryRule (thenRule rule (repeatRule rule)) lit;
fun firstRule [] _ = raise Error "firstRule"
| firstRule [rule] th = rule th
| firstRule (rule :: rules) th = orelseRule rule (firstRule rules) th;
fun everyRule [] th = allRule th
| everyRule [rule] th = rule th
| everyRule (rule :: rules) th = thenRule rule (everyRule rules) th;
fun literalRule literule lit th =
let
val (lit',litTh) = literule lit
in
if lit = lit' then th
else if not (Thm.negateMember lit litTh) then litTh
else Thm.resolve lit th litTh
end;
(*DEBUG
val literalRule = fn literule => fn lit => fn th =>
literalRule literule lit th
handle Error err =>
raise Error ("Rule.literalRule:\nlit = " ^ Literal.toString lit ^
"\nth = " ^ Thm.toString th ^ "\n" ^ err);
*)
fun rewrRule eqTh lit path = literalRule (rewrLiterule eqTh path) lit;
fun pathRule conv lit path = literalRule (pathLiterule conv path) lit;
fun literalsRule literule =
let
fun f (lit,th) =
if Thm.member lit th then literalRule literule lit th else th
in
fn lits => fn th => LiteralSet.foldl f th lits
end;
fun allLiteralsRule literule th = literalsRule literule (Thm.clause th) th;
fun convRule conv = allLiteralsRule (allArgumentsLiterule conv);
(* ------------------------------------------------------------------------- *)
(* *)
(* ---------------------------------------------- functionCongruence (f,n) *)
(* ~(x0 = y0) \/ ... \/ ~(x{n-1} = y{n-1}) \/ *)
(* f x0 ... x{n-1} = f y0 ... y{n-1} *)
(* ------------------------------------------------------------------------- *)
fun functionCongruence (f,n) =
let
val xs = List.tabulate (n, fn i => Term.Var ("x" ^ Int.toString i))
and ys = List.tabulate (n, fn i => Term.Var ("y" ^ Int.toString i))
fun cong ((i,yi),(th,lit)) =
let
val path = [1,i]
val th = Thm.resolve lit th (Thm.equality lit path yi)
val lit = Literal.replace lit (path,yi)
in
(th,lit)
end
val reflTh = Thm.refl (Term.Fn (f,xs))
val reflLit = Thm.destUnit reflTh
in
fst (foldl cong (reflTh,reflLit) (enumerate ys))
end;
(* ------------------------------------------------------------------------- *)
(* *)
(* ---------------------------------------------- relationCongruence (R,n) *)
(* ~(x0 = y0) \/ ... \/ ~(x{n-1} = y{n-1}) \/ *)
(* ~R x0 ... x{n-1} \/ R y0 ... y{n-1} *)
(* ------------------------------------------------------------------------- *)
fun relationCongruence (R,n) =
let
val xs = List.tabulate (n, fn i => Term.Var ("x" ^ Int.toString i))
and ys = List.tabulate (n, fn i => Term.Var ("y" ^ Int.toString i))
fun cong ((i,yi),(th,lit)) =
let
val path = [i]
val th = Thm.resolve lit th (Thm.equality lit path yi)
val lit = Literal.replace lit (path,yi)
in
(th,lit)
end
val assumeLit = (false,(R,xs))
val assumeTh = Thm.assume assumeLit
in
fst (foldl cong (assumeTh,assumeLit) (enumerate ys))
end;
(* ------------------------------------------------------------------------- *)
(* ~(x = y) \/ C *)
(* ----------------- symNeq ~(x = y) *)
(* ~(y = x) \/ C *)
(* ------------------------------------------------------------------------- *)
fun symNeq lit th =
let
val (x,y) = Literal.destNeq lit
in
if x = y then th
else
let
val sub = Subst.fromList [("x",y),("y",x)]
val symTh = Thm.subst sub symmetry
in
Thm.resolve lit th symTh
end
end;
(* ------------------------------------------------------------------------- *)
(* sym (x = y) = symEq (x = y) /\ sym ~(x = y) = symNeq ~(x = y) *)
(* ------------------------------------------------------------------------- *)
fun sym (lit as (pol,_)) th = if pol then symEq lit th else symNeq lit th;
(* ------------------------------------------------------------------------- *)
(* ~(x = x) \/ C *)
(* ----------------- removeIrrefl *)
(* C *)
(* *)
(* where all irreflexive equalities. *)
(* ------------------------------------------------------------------------- *)
local
fun irrefl ((true,_),th) = th
| irrefl (lit as (false,atm), th) =
case total Atom.destRefl atm of
SOME x => Thm.resolve lit th (Thm.refl x)
| NONE => th;
in
fun removeIrrefl th = LiteralSet.foldl irrefl th (Thm.clause th);
end;
(* ------------------------------------------------------------------------- *)
(* x = y \/ y = x \/ C *)
(* ----------------------- removeSym *)
(* x = y \/ C *)
(* *)
(* where all duplicate copies of equalities and disequalities are removed. *)
(* ------------------------------------------------------------------------- *)
local
fun rem (lit as (pol,atm), eqs_th as (eqs,th)) =
case total Atom.sym atm of
NONE => eqs_th
| SOME atm' =>
if LiteralSet.member lit eqs then
(eqs, if pol then symEq lit th else symNeq lit th)
else
(LiteralSet.add eqs (pol,atm'), th);
in
fun removeSym th =
snd (LiteralSet.foldl rem (LiteralSet.empty,th) (Thm.clause th));
end;
(* ------------------------------------------------------------------------- *)
(* ~(v = t) \/ C *)
(* ----------------- expandAbbrevs *)
(* C[t/v] *)
(* *)
(* where t must not contain any occurrence of the variable v. *)
(* ------------------------------------------------------------------------- *)
local
fun expand lit =
let
val (x,y) = Literal.destNeq lit
in
if (Term.isTypedVar x orelse Term.isTypedVar y) andalso x <> y then
Subst.unify Subst.empty x y
else raise Error "expand"
end;
in
fun expandAbbrevs th =
case LiteralSet.firstl (total expand) (Thm.clause th) of
NONE => removeIrrefl th
| SOME sub => expandAbbrevs (Thm.subst sub th);
end;
(* ------------------------------------------------------------------------- *)
(* simplify = isTautology + expandAbbrevs + removeSym *)
(* ------------------------------------------------------------------------- *)
fun simplify th =
if Thm.isTautology th then NONE
else
let
val th' = th
val th' = expandAbbrevs th'
val th' = removeSym th'
in
if Thm.equal th th' then SOME th else simplify th'
end;
(* ------------------------------------------------------------------------- *)
(* C *)
(* -------- freshVars *)
(* C[s] *)
(* *)
(* where s is a renaming substitution chosen so that all of the variables in *)
(* C are replaced by fresh variables. *)
(* ------------------------------------------------------------------------- *)
fun freshVars th = Thm.subst (Subst.freshVars (Thm.freeVars th)) th;
(* ------------------------------------------------------------------------- *)
(* C *)
(* ---------------------------- factor *)
(* C_s_1, C_s_2, ..., C_s_n *)
(* *)
(* where each s_i is a substitution that factors C, meaning that the theorem *)
(* *)
(* C_s_i = (removeIrrefl o removeSym o Thm.subst s_i) C *)
(* *)
(* has fewer literals than C. *)
(* *)
(* Also, if s is any substitution that factors C, then one of the s_i will *)
(* result in a theorem C_s_i that strictly subsumes the theorem C_s. *)
(* ------------------------------------------------------------------------- *)
local
datatype edge =
FactorEdge of Atom.atom * Atom.atom
| ReflEdge of Term.term * Term.term;
fun ppEdge p (FactorEdge atm_atm') = Parser.ppPair Atom.pp Atom.pp p atm_atm'
| ppEdge p (ReflEdge tm_tm') = Parser.ppPair Term.pp Term.pp p tm_tm';
datatype joinStatus =
Joined
| Joinable of Subst.subst
| Apart;
fun joinEdge sub edge =
let
val result =
case edge of
FactorEdge (atm,atm') => total (Atom.unify sub atm) atm'
| ReflEdge (tm,tm') => total (Subst.unify sub tm) tm'
in
case result of
NONE => Apart
| SOME sub' =>
if Portable.pointerEqual (sub,sub') then Joined else Joinable sub'
end;
fun updateApart sub =
let
fun update acc [] = SOME acc
| update acc (edge :: edges) =
case joinEdge sub edge of
Joined => NONE
| Joinable _ => update (edge :: acc) edges
| Apart => update acc edges
in
update []
end;
fun addFactorEdge (pol,atm) ((pol',atm'),acc) =
if pol <> pol' then acc
else
let
val edge = FactorEdge (atm,atm')
in
case joinEdge Subst.empty edge of
Joined => raise Bug "addFactorEdge: joined"
| Joinable sub => (sub,edge) :: acc
| Apart => acc
end;
fun addReflEdge (false,_) acc = acc
| addReflEdge (true,atm) acc =
let
val edge = ReflEdge (Atom.destEq atm)
in
case joinEdge Subst.empty edge of
Joined => raise Bug "addRefl: joined"
| Joinable _ => edge :: acc
| Apart => acc
end;
fun addIrreflEdge (true,_) acc = acc
| addIrreflEdge (false,atm) acc =
let
val edge = ReflEdge (Atom.destEq atm)
in
case joinEdge Subst.empty edge of
Joined => raise Bug "addRefl: joined"
| Joinable sub => (sub,edge) :: acc
| Apart => acc
end;
fun init_edges acc _ [] =
let
fun init ((apart,sub,edge),(edges,acc)) =
(edge :: edges, (apart,sub,edges) :: acc)
in
snd (List.foldl init ([],[]) acc)
end
| init_edges acc apart ((sub,edge) :: sub_edges) =
let
(*DEBUG
val () = if not (Subst.null sub) then ()
else raise Bug "Rule.factor.init_edges: empty subst"
*)
val (acc,apart) =
case updateApart sub apart of
SOME apart' => ((apart',sub,edge) :: acc, edge :: apart)
| NONE => (acc,apart)
in
init_edges acc apart sub_edges
end;
fun mk_edges apart sub_edges [] = init_edges [] apart sub_edges
| mk_edges apart sub_edges (lit :: lits) =
let
val sub_edges = List.foldl (addFactorEdge lit) sub_edges lits
val (apart,sub_edges) =
case total Literal.sym lit of
NONE => (apart,sub_edges)
| SOME lit' =>
let
val apart = addReflEdge lit apart
val sub_edges = addIrreflEdge lit sub_edges
val sub_edges = List.foldl (addFactorEdge lit') sub_edges lits
in
(apart,sub_edges)
end
in
mk_edges apart sub_edges lits
end;
fun fact acc [] = acc
| fact acc ((_,sub,[]) :: others) = fact (sub :: acc) others
| fact acc ((apart, sub, edge :: edges) :: others) =
let
val others =
case joinEdge sub edge of
Joinable sub' =>
let
val others = (edge :: apart, sub, edges) :: others
in
case updateApart sub' apart of
NONE => others
| SOME apart' => (apart',sub',edges) :: others
end
| _ => (apart,sub,edges) :: others
in
fact acc others
end;
in
fun factor' cl =
let
(*TRACE6
val () = Parser.ppTrace LiteralSet.pp "Rule.factor': cl" cl
*)
val edges = mk_edges [] [] (LiteralSet.toList cl)
(*TRACE6
val ppEdgesSize = Parser.ppMap length Parser.ppInt
val ppEdgel = Parser.ppList ppEdge
val ppEdges = Parser.ppList (Parser.ppTriple ppEdgel Subst.pp ppEdgel)
val () = Parser.ppTrace ppEdgesSize "Rule.factor': |edges|" edges
val () = Parser.ppTrace ppEdges "Rule.factor': edges" edges
*)
val result = fact [] edges
(*TRACE6
val ppResult = Parser.ppList Subst.pp
val () = Parser.ppTrace ppResult "Rule.factor': result" result
*)
in
result
end;
end;
fun factor th =
let
fun fact sub = removeSym (Thm.subst sub th)
in
map fact (factor' (Thm.clause th))
end;
end
end;
(**** Original file: Normalize.sig ****)
(* ========================================================================= *)
(* NORMALIZING FORMULAS *)
(* Copyright (c) 2001-2007 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Normalize =
sig
(* ------------------------------------------------------------------------- *)
(* Negation normal form. *)
(* ------------------------------------------------------------------------- *)
val nnf : Metis.Formula.formula -> Metis.Formula.formula
(* ------------------------------------------------------------------------- *)
(* Conjunctive normal form. *)
(* ------------------------------------------------------------------------- *)
val cnf : Metis.Formula.formula -> Metis.Formula.formula list
end
(**** Original file: Normalize.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* NORMALIZING FORMULAS *)
(* Copyright (c) 2001-2007 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Normalize :> Normalize =
struct
open Useful;
(* ------------------------------------------------------------------------- *)
(* Counting the clauses that would be generated by conjunctive normal form. *)
(* ------------------------------------------------------------------------- *)
datatype count = Count of {positive : real, negative : real};
fun positive (Count {positive = p, ...}) = p;
fun negative (Count {negative = n, ...}) = n;
fun countNegate (Count {positive = p, negative = n}) =
Count {positive = n, negative = p};
fun countEqualish count1 count2 =
let
val Count {positive = p1, negative = n1} = count1
and Count {positive = p2, negative = n2} = count2
in
Real.abs (p1 - p2) < 0.5 andalso Real.abs (n1 - n2) < 0.5
end;
val countTrue = Count {positive = 0.0, negative = 1.0};
val countFalse = Count {positive = 1.0, negative = 0.0};
val countLiteral = Count {positive = 1.0, negative = 1.0};
fun countAnd2 (count1,count2) =
let
val Count {positive = p1, negative = n1} = count1
and Count {positive = p2, negative = n2} = count2
val p = p1 + p2
and n = n1 * n2
in
Count {positive = p, negative = n}
end;
fun countOr2 (count1,count2) =
let
val Count {positive = p1, negative = n1} = count1
and Count {positive = p2, negative = n2} = count2
val p = p1 * p2
and n = n1 + n2
in
Count {positive = p, negative = n}
end;
(*** Is this associative? ***)
fun countXor2 (count1,count2) =
let
val Count {positive = p1, negative = n1} = count1
and Count {positive = p2, negative = n2} = count2
val p = p1 * p2 + n1 * n2
and n = p1 * n2 + n1 * p2
in
Count {positive = p, negative = n}
end;
fun countDefinition body_count = countXor2 (countLiteral,body_count);
(* ------------------------------------------------------------------------- *)
(* A type of normalized formula. *)
(* ------------------------------------------------------------------------- *)
datatype formula =
True
| False
| Literal of NameSet.set * Literal.literal
| And of NameSet.set * count * formula Set.set
| Or of NameSet.set * count * formula Set.set
| Xor of NameSet.set * count * bool * formula Set.set
| Exists of NameSet.set * count * NameSet.set * formula
| Forall of NameSet.set * count * NameSet.set * formula;
fun compare f1_f2 =
case f1_f2 of
(True,True) => EQUAL
| (True,_) => LESS
| (_,True) => GREATER
| (False,False) => EQUAL
| (False,_) => LESS
| (_,False) => GREATER
| (Literal (_,l1), Literal (_,l2)) => Literal.compare (l1,l2)
| (Literal _, _) => LESS
| (_, Literal _) => GREATER
| (And (_,_,s1), And (_,_,s2)) => Set.compare (s1,s2)
| (And _, _) => LESS
| (_, And _) => GREATER
| (Or (_,_,s1), Or (_,_,s2)) => Set.compare (s1,s2)
| (Or _, _) => LESS
| (_, Or _) => GREATER
| (Xor (_,_,p1,s1), Xor (_,_,p2,s2)) =>
(case boolCompare (p1,p2) of
LESS => LESS
| EQUAL => Set.compare (s1,s2)
| GREATER => GREATER)
| (Xor _, _) => LESS
| (_, Xor _) => GREATER
| (Exists (_,_,n1,f1), Exists (_,_,n2,f2)) =>
(case NameSet.compare (n1,n2) of
LESS => LESS
| EQUAL => compare (f1,f2)
| GREATER => GREATER)
| (Exists _, _) => LESS
| (_, Exists _) => GREATER
| (Forall (_,_,n1,f1), Forall (_,_,n2,f2)) =>
(case NameSet.compare (n1,n2) of
LESS => LESS
| EQUAL => compare (f1,f2)
| GREATER => GREATER);
val empty = Set.empty compare;
val singleton = Set.singleton compare;
local
fun neg True = False
| neg False = True
| neg (Literal (fv,lit)) = Literal (fv, Literal.negate lit)
| neg (And (fv,c,s)) = Or (fv, countNegate c, neg_set s)
| neg (Or (fv,c,s)) = And (fv, countNegate c, neg_set s)
| neg (Xor (fv,c,p,s)) = Xor (fv, c, not p, s)
| neg (Exists (fv,c,n,f)) = Forall (fv, countNegate c, n, neg f)
| neg (Forall (fv,c,n,f)) = Exists (fv, countNegate c, n, neg f)
and neg_set s = Set.foldl neg_elt empty s
and neg_elt (f,s) = Set.add s (neg f);
in
val negate = neg;
val negateSet = neg_set;
end;
fun negateMember x s = Set.member (negate x) s;
local
fun member s x = negateMember x s;
in
fun negateDisjoint s1 s2 =
if Set.size s1 < Set.size s2 then not (Set.exists (member s2) s1)
else not (Set.exists (member s1) s2);
end;
fun polarity True = true
| polarity False = false
| polarity (Literal (_,(pol,_))) = not pol
| polarity (And _) = true
| polarity (Or _) = false
| polarity (Xor (_,_,pol,_)) = pol
| polarity (Exists _) = true
| polarity (Forall _) = false;
(*DEBUG
val polarity = fn f =>
let
val res1 = compare (f, negate f) = LESS
val res2 = polarity f
val _ = res1 = res2 orelse raise Bug "polarity"
in
res2
end;
*)
fun applyPolarity true fm = fm
| applyPolarity false fm = negate fm;
fun freeVars True = NameSet.empty
| freeVars False = NameSet.empty
| freeVars (Literal (fv,_)) = fv
| freeVars (And (fv,_,_)) = fv
| freeVars (Or (fv,_,_)) = fv
| freeVars (Xor (fv,_,_,_)) = fv
| freeVars (Exists (fv,_,_,_)) = fv
| freeVars (Forall (fv,_,_,_)) = fv;
fun freeIn v fm = NameSet.member v (freeVars fm);
val freeVarsSet =
let
fun free (fm,acc) = NameSet.union (freeVars fm) acc
in
Set.foldl free NameSet.empty
end;
fun count True = countTrue
| count False = countFalse
| count (Literal _) = countLiteral
| count (And (_,c,_)) = c
| count (Or (_,c,_)) = c
| count (Xor (_,c,p,_)) = if p then c else countNegate c
| count (Exists (_,c,_,_)) = c
| count (Forall (_,c,_,_)) = c;
val countAndSet =
let
fun countAnd (fm,c) = countAnd2 (count fm, c)
in
Set.foldl countAnd countTrue
end;
val countOrSet =
let
fun countOr (fm,c) = countOr2 (count fm, c)
in
Set.foldl countOr countFalse
end;
val countXorSet =
let
fun countXor (fm,c) = countXor2 (count fm, c)
in
Set.foldl countXor countFalse
end;
fun And2 (False,_) = False
| And2 (_,False) = False
| And2 (True,f2) = f2
| And2 (f1,True) = f1
| And2 (f1,f2) =
let
val (fv1,c1,s1) =
case f1 of
And fv_c_s => fv_c_s
| _ => (freeVars f1, count f1, singleton f1)
and (fv2,c2,s2) =
case f2 of
And fv_c_s => fv_c_s
| _ => (freeVars f2, count f2, singleton f2)
in
if not (negateDisjoint s1 s2) then False
else
let
val s = Set.union s1 s2
in
case Set.size s of
0 => True
| 1 => Set.pick s
| n =>
if n = Set.size s1 + Set.size s2 then
And (NameSet.union fv1 fv2, countAnd2 (c1,c2), s)
else
And (freeVarsSet s, countAndSet s, s)
end
end;
val AndList = foldl And2 True;
val AndSet = Set.foldl And2 True;
fun Or2 (True,_) = True
| Or2 (_,True) = True
| Or2 (False,f2) = f2
| Or2 (f1,False) = f1
| Or2 (f1,f2) =
let
val (fv1,c1,s1) =
case f1 of
Or fv_c_s => fv_c_s
| _ => (freeVars f1, count f1, singleton f1)
and (fv2,c2,s2) =
case f2 of
Or fv_c_s => fv_c_s
| _ => (freeVars f2, count f2, singleton f2)
in
if not (negateDisjoint s1 s2) then True
else
let
val s = Set.union s1 s2
in
case Set.size s of
0 => False
| 1 => Set.pick s
| n =>
if n = Set.size s1 + Set.size s2 then
Or (NameSet.union fv1 fv2, countOr2 (c1,c2), s)
else
Or (freeVarsSet s, countOrSet s, s)
end
end;
val OrList = foldl Or2 False;
val OrSet = Set.foldl Or2 False;
fun pushOr2 (f1,f2) =
let
val s1 = case f1 of And (_,_,s) => s | _ => singleton f1
and s2 = case f2 of And (_,_,s) => s | _ => singleton f2
fun g x1 (x2,acc) = And2 (Or2 (x1,x2), acc)
fun f (x1,acc) = Set.foldl (g x1) acc s2
in
Set.foldl f True s1
end;
val pushOrList = foldl pushOr2 False;
local
fun normalize fm =
let
val p = polarity fm
val fm = applyPolarity p fm
in
(freeVars fm, count fm, p, singleton fm)
end;
in
fun Xor2 (False,f2) = f2
| Xor2 (f1,False) = f1
| Xor2 (True,f2) = negate f2
| Xor2 (f1,True) = negate f1
| Xor2 (f1,f2) =
let
val (fv1,c1,p1,s1) = case f1 of Xor x => x | _ => normalize f1
and (fv2,c2,p2,s2) = case f2 of Xor x => x | _ => normalize f2
val s = Set.symmetricDifference s1 s2
val fm =
case Set.size s of
0 => False
| 1 => Set.pick s
| n =>
if n = Set.size s1 + Set.size s2 then
Xor (NameSet.union fv1 fv2, countXor2 (c1,c2), true, s)
else
Xor (freeVarsSet s, countXorSet s, true, s)
val p = p1 = p2
in
applyPolarity p fm
end;
end;
val XorList = foldl Xor2 False;
val XorSet = Set.foldl Xor2 False;
fun XorPolarityList (p,l) = applyPolarity p (XorList l);
fun XorPolaritySet (p,s) = applyPolarity p (XorSet s);
fun destXor (Xor (_,_,p,s)) =
let
val (fm1,s) = Set.deletePick s
val fm2 =
if Set.size s = 1 then applyPolarity p (Set.pick s)
else Xor (freeVarsSet s, countXorSet s, p, s)
in
(fm1,fm2)
end
| destXor _ = raise Error "destXor";
fun pushXor fm =
let
val (f1,f2) = destXor fm
val f1' = negate f1
and f2' = negate f2
in
And2 (Or2 (f1,f2), Or2 (f1',f2'))
end;
fun Exists1 (v,init_fm) =
let
fun exists_gen fm =
let
val fv = NameSet.delete (freeVars fm) v
val c = count fm
val n = NameSet.singleton v
in
Exists (fv,c,n,fm)
end
fun exists fm = if freeIn v fm then exists_free fm else fm
and exists_free (Or (_,_,s)) = OrList (Set.transform exists s)
| exists_free (fm as And (_,_,s)) =
let
val sv = Set.filter (freeIn v) s
in
if Set.size sv <> 1 then exists_gen fm
else
let
val fm = Set.pick sv
val s = Set.delete s fm
in
And2 (exists_free fm, AndSet s)
end
end
| exists_free (Exists (fv,c,n,f)) =
Exists (NameSet.delete fv v, c, NameSet.add n v, f)
| exists_free fm = exists_gen fm
in
exists init_fm
end;
fun ExistsList (vs,f) = foldl Exists1 f vs;
fun ExistsSet (n,f) = NameSet.foldl Exists1 f n;
fun Forall1 (v,init_fm) =
let
fun forall_gen fm =
let
val fv = NameSet.delete (freeVars fm) v
val c = count fm
val n = NameSet.singleton v
in
Forall (fv,c,n,fm)
end
fun forall fm = if freeIn v fm then forall_free fm else fm
and forall_free (And (_,_,s)) = AndList (Set.transform forall s)
| forall_free (fm as Or (_,_,s)) =
let
val sv = Set.filter (freeIn v) s
in
if Set.size sv <> 1 then forall_gen fm
else
let
val fm = Set.pick sv
val s = Set.delete s fm
in
Or2 (forall_free fm, OrSet s)
end
end
| forall_free (Forall (fv,c,n,f)) =
Forall (NameSet.delete fv v, c, NameSet.add n v, f)
| forall_free fm = forall_gen fm
in
forall init_fm
end;
fun ForallList (vs,f) = foldl Forall1 f vs;
fun ForallSet (n,f) = NameSet.foldl Forall1 f n;
local
fun subst_fv fvSub =
let
fun add_fv (v,s) = NameSet.union (NameMap.get fvSub v) s
in
NameSet.foldl add_fv NameSet.empty
end;
fun subst_rename (v,(avoid,bv,sub,domain,fvSub)) =
let
val v' = Term.variantPrime avoid v
val avoid = NameSet.add avoid v'
val bv = NameSet.add bv v'
val sub = Subst.insert sub (v, Term.Var v')
val domain = NameSet.add domain v
val fvSub = NameMap.insert fvSub (v, NameSet.singleton v')
in
(avoid,bv,sub,domain,fvSub)
end;
fun subst_check sub domain fvSub fm =
let
val domain = NameSet.intersect domain (freeVars fm)
in
if NameSet.null domain then fm
else subst_domain sub domain fvSub fm
end
and subst_domain sub domain fvSub fm =
case fm of
Literal (fv,lit) =>
let
val fv = NameSet.difference fv domain
val fv = NameSet.union fv (subst_fv fvSub domain)
val lit = Literal.subst sub lit
in
Literal (fv,lit)
end
| And (_,_,s) =>
AndList (Set.transform (subst_check sub domain fvSub) s)
| Or (_,_,s) =>
OrList (Set.transform (subst_check sub domain fvSub) s)
| Xor (_,_,p,s) =>
XorPolarityList (p, Set.transform (subst_check sub domain fvSub) s)
| Exists fv_c_n_f => subst_quant Exists sub domain fvSub fv_c_n_f
| Forall fv_c_n_f => subst_quant Forall sub domain fvSub fv_c_n_f
| _ => raise Bug "subst_domain"
and subst_quant quant sub domain fvSub (fv,c,bv,fm) =
let
val sub_fv = subst_fv fvSub domain
val fv = NameSet.union sub_fv (NameSet.difference fv domain)
val captured = NameSet.intersect bv sub_fv
val bv = NameSet.difference bv captured
val avoid = NameSet.union fv bv
val (_,bv,sub,domain,fvSub) =
NameSet.foldl subst_rename (avoid,bv,sub,domain,fvSub) captured
val fm = subst_domain sub domain fvSub fm
in
quant (fv,c,bv,fm)
end;
in
fun subst sub =
let
fun mk_dom (v,tm,(d,fv)) =
(NameSet.add d v, NameMap.insert fv (v, Term.freeVars tm))
val domain_fvSub = (NameSet.empty, NameMap.new ())
val (domain,fvSub) = Subst.foldl mk_dom domain_fvSub sub
in
subst_check sub domain fvSub
end;
end;
fun fromFormula fm =
case fm of
Formula.True => True
| Formula.False => False
| Formula.Atom atm => Literal (Atom.freeVars atm, (true,atm))
| Formula.Not p => negateFromFormula p
| Formula.And (p,q) => And2 (fromFormula p, fromFormula q)
| Formula.Or (p,q) => Or2 (fromFormula p, fromFormula q)
| Formula.Imp (p,q) => Or2 (negateFromFormula p, fromFormula q)
| Formula.Iff (p,q) => Xor2 (negateFromFormula p, fromFormula q)
| Formula.Forall (v,p) => Forall1 (v, fromFormula p)
| Formula.Exists (v,p) => Exists1 (v, fromFormula p)
and negateFromFormula fm =
case fm of
Formula.True => False
| Formula.False => True
| Formula.Atom atm => Literal (Atom.freeVars atm, (false,atm))
| Formula.Not p => fromFormula p
| Formula.And (p,q) => Or2 (negateFromFormula p, negateFromFormula q)
| Formula.Or (p,q) => And2 (negateFromFormula p, negateFromFormula q)
| Formula.Imp (p,q) => And2 (fromFormula p, negateFromFormula q)
| Formula.Iff (p,q) => Xor2 (fromFormula p, fromFormula q)
| Formula.Forall (v,p) => Exists1 (v, negateFromFormula p)
| Formula.Exists (v,p) => Forall1 (v, negateFromFormula p);
local
fun lastElt (s : formula Set.set) =
case Set.findr (K true) s of
NONE => raise Bug "lastElt: empty set"
| SOME fm => fm;
fun negateLastElt s =
let
val fm = lastElt s
in
Set.add (Set.delete s fm) (negate fm)
end;
fun form fm =
case fm of
True => Formula.True
| False => Formula.False
| Literal (_,lit) => Literal.toFormula lit
| And (_,_,s) => Formula.listMkConj (Set.transform form s)
| Or (_,_,s) => Formula.listMkDisj (Set.transform form s)
| Xor (_,_,p,s) =>
let
val s = if p then negateLastElt s else s
in
Formula.listMkEquiv (Set.transform form s)
end
| Exists (_,_,n,f) => Formula.listMkExists (NameSet.toList n, form f)
| Forall (_,_,n,f) => Formula.listMkForall (NameSet.toList n, form f);
in
val toFormula = form;
end;
val pp = Parser.ppMap toFormula Formula.pp;
val toString = Parser.toString pp;
(* ------------------------------------------------------------------------- *)
(* Negation normal form. *)
(* ------------------------------------------------------------------------- *)
fun nnf fm = toFormula (fromFormula fm);
(* ------------------------------------------------------------------------- *)
(* Simplifying with definitions. *)
(* ------------------------------------------------------------------------- *)
datatype simplify =
Simplify of
{formula : (formula,formula) Map.map,
andSet : (formula Set.set * formula) list,
orSet : (formula Set.set * formula) list,
xorSet : (formula Set.set * formula) list};
val simplifyEmpty =
Simplify {formula = Map.new compare, andSet = [], orSet = [], xorSet = []};
local
fun simpler fm s =
Set.size s <> 1 orelse
case Set.pick s of
True => false
| False => false
| Literal _ => false
| _ => true;
fun addSet set_defs body_def =
let
fun def_body_size (body,_) = Set.size body
val body_size = def_body_size body_def
val (body,_) = body_def
fun add acc [] = List.revAppend (acc,[body_def])
| add acc (l as (bd as (b,_)) :: bds) =
case Int.compare (def_body_size bd, body_size) of
LESS => List.revAppend (acc, body_def :: l)
| EQUAL => if Set.equal b body then List.revAppend (acc,l)
else add (bd :: acc) bds
| GREATER => add (bd :: acc) bds
in
add [] set_defs
end;
fun add simp (body,False) = add simp (negate body, True)
| add simp (True,_) = simp
| add (Simplify {formula,andSet,orSet,xorSet}) (And (_,_,s), def) =
let
val andSet = addSet andSet (s,def)
and orSet = addSet orSet (negateSet s, negate def)
in
Simplify
{formula = formula,
andSet = andSet, orSet = orSet, xorSet = xorSet}
end
| add (Simplify {formula,andSet,orSet,xorSet}) (Or (_,_,s), def) =
let
val orSet = addSet orSet (s,def)
and andSet = addSet andSet (negateSet s, negate def)
in
Simplify
{formula = formula,
andSet = andSet, orSet = orSet, xorSet = xorSet}
end
| add simp (Xor (_,_,p,s), def) =
let
val simp = addXorSet simp (s, applyPolarity p def)
in
case def of
True =>
let
fun addXorLiteral (fm as Literal _, simp) =
let
val s = Set.delete s fm
in
if not (simpler fm s) then simp
else addXorSet simp (s, applyPolarity (not p) fm)
end
| addXorLiteral (_,simp) = simp
in
Set.foldl addXorLiteral simp s
end
| _ => simp
end
| add (simp as Simplify {formula,andSet,orSet,xorSet}) (body,def) =
if Map.inDomain body formula then simp
else
let
val formula = Map.insert formula (body,def)
val formula = Map.insert formula (negate body, negate def)
in
Simplify
{formula = formula,
andSet = andSet, orSet = orSet, xorSet = xorSet}
end
and addXorSet (simp as Simplify {formula,andSet,orSet,xorSet}) (s,def) =
if Set.size s = 1 then add simp (Set.pick s, def)
else
let
val xorSet = addSet xorSet (s,def)
in
Simplify
{formula = formula,
andSet = andSet, orSet = orSet, xorSet = xorSet}
end;
in
fun simplifyAdd simp fm = add simp (fm,True);
end;
local
fun simplifySet set_defs set =
let
fun pred (s,_) = Set.subset s set
in
case List.find pred set_defs of
NONE => NONE
| SOME (s,f) => SOME (Set.add (Set.difference set s) f)
end;
in
fun simplify (Simplify {formula,andSet,orSet,xorSet}) =
let
fun simp fm = simp_top (simp_sub fm)
and simp_top (changed_fm as (_, And (_,_,s))) =
(case simplifySet andSet s of
NONE => changed_fm
| SOME s => simp_top (true, AndSet s))
| simp_top (changed_fm as (_, Or (_,_,s))) =
(case simplifySet orSet s of
NONE => changed_fm
| SOME s => simp_top (true, OrSet s))
| simp_top (changed_fm as (_, Xor (_,_,p,s))) =
(case simplifySet xorSet s of
NONE => changed_fm
| SOME s => simp_top (true, XorPolaritySet (p,s)))
| simp_top (changed_fm as (_,fm)) =
(case Map.peek formula fm of
NONE => changed_fm
| SOME fm => simp_top (true,fm))
and simp_sub fm =
case fm of
And (_,_,s) =>
let
val l = Set.transform simp s
val changed = List.exists fst l
val fm = if changed then AndList (map snd l) else fm
in
(changed,fm)
end
| Or (_,_,s) =>
let
val l = Set.transform simp s
val changed = List.exists fst l
val fm = if changed then OrList (map snd l) else fm
in
(changed,fm)
end
| Xor (_,_,p,s) =>
let
val l = Set.transform simp s
val changed = List.exists fst l
val fm = if changed then XorPolarityList (p, map snd l) else fm
in
(changed,fm)
end
| Exists (_,_,n,f) =>
let
val (changed,f) = simp f
val fm = if changed then ExistsSet (n,f) else fm
in
(changed,fm)
end
| Forall (_,_,n,f) =>
let
val (changed,f) = simp f
val fm = if changed then ForallSet (n,f) else fm
in
(changed,fm)
end
| _ => (false,fm);
in
fn fm => snd (simp fm)
end;
end;
(*TRACE2
val simplify = fn simp => fn fm =>
let
val fm' = simplify simp fm
val () = if compare (fm,fm') = EQUAL then ()
else (Parser.ppTrace pp "Normalize.simplify: fm" fm;
Parser.ppTrace pp "Normalize.simplify: fm'" fm')
in
fm'
end;
*)
(* ------------------------------------------------------------------------- *)
(* Basic conjunctive normal form. *)
(* ------------------------------------------------------------------------- *)
val newSkolemFunction =
let
val counter : int NameMap.map Unsynchronized.ref = Unsynchronized.ref (NameMap.new ())
in
fn n => CRITICAL (fn () =>
let
val Unsynchronized.ref m = counter
val i = Option.getOpt (NameMap.peek m n, 0)
val () = counter := NameMap.insert m (n, i + 1)
in
"skolem_" ^ n ^ (if i = 0 then "" else "_" ^ Int.toString i)
end)
end;
fun skolemize fv bv fm =
let
val fv = NameSet.transform Term.Var fv
fun mk (v,s) = Subst.insert s (v, Term.Fn (newSkolemFunction v, fv))
in
subst (NameSet.foldl mk Subst.empty bv) fm
end;
local
fun rename avoid fv bv fm =
let
val captured = NameSet.intersect avoid bv
in
if NameSet.null captured then fm
else
let
fun ren (v,(a,s)) =
let
val v' = Term.variantPrime a v
in
(NameSet.add a v', Subst.insert s (v, Term.Var v'))
end
val avoid = NameSet.union (NameSet.union avoid fv) bv
val (_,sub) = NameSet.foldl ren (avoid,Subst.empty) captured
in
subst sub fm
end
end;
fun cnf avoid fm =
(*TRACE5
let
val fm' = cnf' avoid fm
val () = Parser.ppTrace pp "Normalize.cnf: fm" fm
val () = Parser.ppTrace pp "Normalize.cnf: fm'" fm'
in
fm'
end
and cnf' avoid fm =
*)
case fm of
True => True
| False => False
| Literal _ => fm
| And (_,_,s) => AndList (Set.transform (cnf avoid) s)
| Or (_,_,s) => pushOrList (snd (Set.foldl cnfOr (avoid,[]) s))
| Xor _ => cnf avoid (pushXor fm)
| Exists (fv,_,n,f) => cnf avoid (skolemize fv n f)
| Forall (fv,_,n,f) => cnf avoid (rename avoid fv n f)
and cnfOr (fm,(avoid,acc)) =
let
val fm = cnf avoid fm
in
(NameSet.union (freeVars fm) avoid, fm :: acc)
end;
in
val basicCnf = cnf NameSet.empty;
end;
(* ------------------------------------------------------------------------- *)
(* Finding the formula definition that minimizes the number of clauses. *)
(* ------------------------------------------------------------------------- *)
local
type best = real * formula option;
fun minBreak countClauses fm best =
case fm of
True => best
| False => best
| Literal _ => best
| And (_,_,s) =>
minBreakSet countClauses countAnd2 countTrue AndSet s best
| Or (_,_,s) =>
minBreakSet countClauses countOr2 countFalse OrSet s best
| Xor (_,_,_,s) =>
minBreakSet countClauses countXor2 countFalse XorSet s best
| Exists (_,_,_,f) => minBreak countClauses f best
| Forall (_,_,_,f) => minBreak countClauses f best
and minBreakSet countClauses count2 count0 mkSet fmSet best =
let
fun cumulatives fms =
let
fun fwd (fm,(c1,s1,l)) =
let
val c1' = count2 (count fm, c1)
and s1' = Set.add s1 fm
in
(c1', s1', (c1,s1,fm) :: l)
end
fun bwd ((c1,s1,fm),(c2,s2,l)) =
let
val c2' = count2 (count fm, c2)
and s2' = Set.add s2 fm
in
(c2', s2', (c1,s1,fm,c2,s2) :: l)
end
val (c1,_,fms) = foldl fwd (count0,empty,[]) fms
val (c2,_,fms) = foldl bwd (count0,empty,[]) fms
val _ = countEqualish c1 c2 orelse raise Bug "cumulativeCounts"
in
fms
end
fun breakSing ((c1,_,fm,c2,_),best) =
let
val cFms = count2 (c1,c2)
fun countCls cFm = countClauses (count2 (cFms,cFm))
in
minBreak countCls fm best
end
val breakSet1 =
let
fun break c1 s1 fm c2 (best as (bcl,_)) =
if Set.null s1 then best
else
let
val cDef = countDefinition (count2 (c1, count fm))
val cFm = count2 (countLiteral,c2)
val cl = positive cDef + countClauses cFm
val better = cl < bcl - 0.5
in
if better then (cl, SOME (mkSet (Set.add s1 fm)))
else best
end
in
fn ((c1,s1,fm,c2,s2),best) =>
break c1 s1 fm c2 (break c2 s2 fm c1 best)
end
val fms = Set.toList fmSet
fun breakSet measure best =
let
val fms = sortMap (measure o count) Real.compare fms
in
foldl breakSet1 best (cumulatives fms)
end
val best = foldl breakSing best (cumulatives fms)
val best = breakSet positive best
val best = breakSet negative best
val best = breakSet countClauses best
in
best
end
in
fun minimumDefinition fm =
let
val countClauses = positive
val cl = countClauses (count fm)
in
if cl < 1.5 then NONE
else
let
val (cl',def) = minBreak countClauses fm (cl,NONE)
(*TRACE1
val () =
case def of
NONE => ()
| SOME d =>
Parser.ppTrace pp ("defCNF: before = " ^ Real.toString cl ^
", after = " ^ Real.toString cl' ^
", definition") d
*)
in
def
end
end;
end;
(* ------------------------------------------------------------------------- *)
(* Conjunctive normal form. *)
(* ------------------------------------------------------------------------- *)
val newDefinitionRelation =
let
val counter : int Unsynchronized.ref = Unsynchronized.ref 0
in
fn () => CRITICAL (fn () =>
let
val Unsynchronized.ref i = counter
val () = counter := i + 1
in
"defCNF_" ^ Int.toString i
end)
end;
fun newDefinition def =
let
val fv = freeVars def
val atm = (newDefinitionRelation (), NameSet.transform Term.Var fv)
val lit = Literal (fv,(true,atm))
in
Xor2 (lit,def)
end;
local
fun def_cnf acc [] = acc
| def_cnf acc ((prob,simp,fms) :: probs) =
def_cnf_problem acc prob simp fms probs
and def_cnf_problem acc prob _ [] probs = def_cnf (prob :: acc) probs
| def_cnf_problem acc prob simp (fm :: fms) probs =
def_cnf_formula acc prob simp (simplify simp fm) fms probs
and def_cnf_formula acc prob simp fm fms probs =
case fm of
True => def_cnf_problem acc prob simp fms probs
| False => def_cnf acc probs
| And (_,_,s) => def_cnf_problem acc prob simp (Set.toList s @ fms) probs
| Exists (fv,_,n,f) =>
def_cnf_formula acc prob simp (skolemize fv n f) fms probs
| Forall (_,_,_,f) => def_cnf_formula acc prob simp f fms probs
| _ =>
case minimumDefinition fm of
NONE =>
let
val prob = fm :: prob
and simp = simplifyAdd simp fm
in
def_cnf_problem acc prob simp fms probs
end
| SOME def =>
let
val def_fm = newDefinition def
and fms = fm :: fms
in
def_cnf_formula acc prob simp def_fm fms probs
end;
fun cnf_prob prob = toFormula (AndList (map basicCnf prob));
in
fun cnf fm =
let
val fm = fromFormula fm
(*TRACE2
val () = Parser.ppTrace pp "Normalize.cnf: fm" fm
*)
val probs = def_cnf [] [([],simplifyEmpty,[fm])]
in
map cnf_prob probs
end;
end;
end
end;
(**** Original file: Model.sig ****)
(* ========================================================================= *)
(* RANDOM FINITE MODELS *)
(* Copyright (c) 2003-2007 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Model =
sig
(* ------------------------------------------------------------------------- *)
(* The parts of the model that are fixed. *)
(* Note: a model of size N has integer elements 0...N-1. *)
(* ------------------------------------------------------------------------- *)
type fixed =
{size : int} ->
{functions : (Metis.Term.functionName * int list) -> int option,
relations : (Metis.Atom.relationName * int list) -> bool option}
val fixedMerge : fixed -> fixed -> fixed (* Prefers the second fixed *)
val fixedMergeList : fixed list -> fixed
val fixedPure : fixed (* : = *)
val fixedBasic : fixed (* id fst snd #1 #2 #3 <> *)
val fixedModulo : fixed (* <numerals> suc pre ~ + - * exp div mod *)
(* is_0 divides even odd *)
val fixedOverflowNum : fixed (* <numerals> suc pre + - * exp div mod *)
(* is_0 <= < >= > divides even odd *)
val fixedOverflowInt : fixed (* <numerals> suc pre + - * exp div mod *)
(* is_0 <= < >= > divides even odd *)
val fixedSet : fixed (* empty univ union intersect compl card in subset *)
(* ------------------------------------------------------------------------- *)
(* A type of random finite models. *)
(* ------------------------------------------------------------------------- *)
type parameters = {size : int, fixed : fixed}
type model
val new : parameters -> model
val size : model -> int
(* ------------------------------------------------------------------------- *)
(* Valuations. *)
(* ------------------------------------------------------------------------- *)
type valuation = int Metis.NameMap.map
val valuationEmpty : valuation
val valuationRandom : {size : int} -> Metis.NameSet.set -> valuation
val valuationFold :
{size : int} -> Metis.NameSet.set -> (valuation * 'a -> 'a) -> 'a -> 'a
(* ------------------------------------------------------------------------- *)
(* Interpreting terms and formulas in the model. *)
(* ------------------------------------------------------------------------- *)
val interpretTerm : model -> valuation -> Metis.Term.term -> int
val interpretAtom : model -> valuation -> Metis.Atom.atom -> bool
val interpretFormula : model -> valuation -> Metis.Formula.formula -> bool
val interpretLiteral : model -> valuation -> Metis.Literal.literal -> bool
val interpretClause : model -> valuation -> Metis.Thm.clause -> bool
(* ------------------------------------------------------------------------- *)
(* Check whether random groundings of a formula are true in the model. *)
(* Note: if it's cheaper, a systematic check will be performed instead. *)
(* ------------------------------------------------------------------------- *)
val checkAtom :
{maxChecks : int} -> model -> Metis.Atom.atom -> {T : int, F : int}
val checkFormula :
{maxChecks : int} -> model -> Metis.Formula.formula -> {T : int, F : int}
val checkLiteral :
{maxChecks : int} -> model -> Metis.Literal.literal -> {T : int, F : int}
val checkClause :
{maxChecks : int} -> model -> Metis.Thm.clause -> {T : int, F : int}
end
(**** Original file: Model.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* RANDOM FINITE MODELS *)
(* Copyright (c) 2003-2007 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Model :> Model =
struct
open Useful;
(* ------------------------------------------------------------------------- *)
(* Helper functions. *)
(* ------------------------------------------------------------------------- *)
fun intExp x y = exp op* x y 1;
fun natFromString "" = NONE
| natFromString "0" = SOME 0
| natFromString s =
case charToInt (String.sub (s,0)) of
NONE => NONE
| SOME 0 => NONE
| SOME d =>
let
fun parse 0 _ acc = SOME acc
| parse n i acc =
case charToInt (String.sub (s,i)) of
NONE => NONE
| SOME d => parse (n - 1) (i + 1) (10 * acc + d)
in
parse (size s - 1) 1 d
end;
fun projection (_,[]) = NONE
| projection ("#1", x :: _) = SOME x
| projection ("#2", _ :: x :: _) = SOME x
| projection ("#3", _ :: _ :: x :: _) = SOME x
| projection (func,args) =
let
val f = size func
and n = length args
val p =
if f < 2 orelse n <= 3 orelse String.sub (func,0) <> #"#" then NONE
else if f = 2 then
(case charToInt (String.sub (func,1)) of
NONE => NONE
| p as SOME d => if d <= 3 then NONE else p)
else if (n < intExp 10 (f - 2) handle Overflow => true) then NONE
else
(natFromString (String.extract (func,1,NONE))
handle Overflow => NONE)
in
case p of
NONE => NONE
| SOME k => if k > n then NONE else SOME (List.nth (args, k - 1))
end;
(* ------------------------------------------------------------------------- *)
(* The parts of the model that are fixed. *)
(* Note: a model of size N has integer elements 0...N-1. *)
(* ------------------------------------------------------------------------- *)
type fixedModel =
{functions : (Term.functionName * int list) -> int option,
relations : (Atom.relationName * int list) -> bool option};
type fixed = {size : int} -> fixedModel
fun fixedMerge fixed1 fixed2 parm =
let
val {functions = f1, relations = r1} = fixed1 parm
and {functions = f2, relations = r2} = fixed2 parm
fun functions x = case f2 x of NONE => f1 x | s => s
fun relations x = case r2 x of NONE => r1 x | s => s
in
{functions = functions, relations = relations}
end;
fun fixedMergeList [] = raise Bug "fixedMergeList: empty"
| fixedMergeList (f :: l) = foldl (uncurry fixedMerge) f l;
fun fixedPure {size = _} =
let
fun functions (":",[x,_]) = SOME x
| functions _ = NONE
fun relations (rel,[x,y]) =
if (rel,2) = Atom.eqRelation then SOME (x = y) else NONE
| relations _ = NONE
in
{functions = functions, relations = relations}
end;
fun fixedBasic {size = _} =
let
fun functions ("id",[x]) = SOME x
| functions ("fst",[x,_]) = SOME x
| functions ("snd",[_,x]) = SOME x
| functions func_args = projection func_args
fun relations ("<>",[x,y]) = SOME (x <> y)
| relations _ = NONE
in
{functions = functions, relations = relations}
end;
fun fixedModulo {size = N} =
let
fun mod_N k = k mod N
val one = mod_N 1
fun mult (x,y) = mod_N (x * y)
fun divides_N 0 = false
| divides_N x = N mod x = 0
val even_N = divides_N 2
fun functions (numeral,[]) =
Option.map mod_N (natFromString numeral handle Overflow => NONE)
| functions ("suc",[x]) = SOME (if x = N - 1 then 0 else x + 1)
| functions ("pre",[x]) = SOME (if x = 0 then N - 1 else x - 1)
| functions ("~",[x]) = SOME (if x = 0 then 0 else N - x)
| functions ("+",[x,y]) = SOME (mod_N (x + y))
| functions ("-",[x,y]) = SOME (if x < y then N + x - y else x - y)
| functions ("*",[x,y]) = SOME (mult (x,y))
| functions ("exp",[x,y]) = SOME (exp mult x y one)
| functions ("div",[x,y]) = if divides_N y then SOME (x div y) else NONE
| functions ("mod",[x,y]) = if divides_N y then SOME (x mod y) else NONE
| functions _ = NONE
fun relations ("is_0",[x]) = SOME (x = 0)
| relations ("divides",[x,y]) =
if x = 0 then SOME (y = 0)
else if divides_N x then SOME (y mod x = 0) else NONE
| relations ("even",[x]) = if even_N then SOME (x mod 2 = 0) else NONE
| relations ("odd",[x]) = if even_N then SOME (x mod 2 = 1) else NONE
| relations _ = NONE
in
{functions = functions, relations = relations}
end;
local
datatype onum = ONeg | ONum of int | OInf;
val zero = ONum 0
and one = ONum 1
and two = ONum 2;
fun suc (ONum x) = ONum (x + 1)
| suc v = v;
fun pre (ONum 0) = ONeg
| pre (ONum x) = ONum (x - 1)
| pre v = v;
fun neg ONeg = NONE
| neg (n as ONum 0) = SOME n
| neg _ = SOME ONeg;
fun add ONeg ONeg = SOME ONeg
| add ONeg (ONum y) = if y = 0 then SOME ONeg else NONE
| add ONeg OInf = NONE
| add (ONum x) ONeg = if x = 0 then SOME ONeg else NONE
| add (ONum x) (ONum y) = SOME (ONum (x + y))
| add (ONum _) OInf = SOME OInf
| add OInf ONeg = NONE
| add OInf (ONum _) = SOME OInf
| add OInf OInf = SOME OInf;
fun sub ONeg ONeg = NONE
| sub ONeg (ONum _) = SOME ONeg
| sub ONeg OInf = SOME ONeg
| sub (ONum _) ONeg = NONE
| sub (ONum x) (ONum y) = SOME (if x < y then ONeg else ONum (x - y))
| sub (ONum _) OInf = SOME ONeg
| sub OInf ONeg = SOME OInf
| sub OInf (ONum y) = if y = 0 then SOME OInf else NONE
| sub OInf OInf = NONE;
fun mult ONeg ONeg = NONE
| mult ONeg (ONum y) = SOME (if y = 0 then zero else ONeg)
| mult ONeg OInf = SOME ONeg
| mult (ONum x) ONeg = SOME (if x = 0 then zero else ONeg)
| mult (ONum x) (ONum y) = SOME (ONum (x * y))
| mult (ONum x) OInf = SOME (if x = 0 then zero else OInf)
| mult OInf ONeg = SOME ONeg
| mult OInf (ONum y) = SOME (if y = 0 then zero else OInf)
| mult OInf OInf = SOME OInf;
fun exp ONeg ONeg = NONE
| exp ONeg (ONum y) =
if y = 0 then SOME one else if y mod 2 = 0 then NONE else SOME ONeg
| exp ONeg OInf = NONE
| exp (ONum x) ONeg = NONE
| exp (ONum x) (ONum y) = SOME (ONum (intExp x y) handle Overflow => OInf)
| exp (ONum x) OInf =
SOME (if x = 0 then zero else if x = 1 then one else OInf)
| exp OInf ONeg = NONE
| exp OInf (ONum y) = SOME (if y = 0 then one else OInf)
| exp OInf OInf = SOME OInf;
fun odiv ONeg ONeg = NONE
| odiv ONeg (ONum y) = if y = 1 then SOME ONeg else NONE
| odiv ONeg OInf = NONE
| odiv (ONum _) ONeg = NONE
| odiv (ONum x) (ONum y) = if y = 0 then NONE else SOME (ONum (x div y))
| odiv (ONum _) OInf = SOME zero
| odiv OInf ONeg = NONE
| odiv OInf (ONum y) = if y = 1 then SOME OInf else NONE
| odiv OInf OInf = NONE;
fun omod ONeg ONeg = NONE
| omod ONeg (ONum y) = if y = 1 then SOME zero else NONE
| omod ONeg OInf = NONE
| omod (ONum _) ONeg = NONE
| omod (ONum x) (ONum y) = if y = 0 then NONE else SOME (ONum (x mod y))
| omod (x as ONum _) OInf = SOME x
| omod OInf ONeg = NONE
| omod OInf (ONum y) = if y = 1 then SOME OInf else NONE
| omod OInf OInf = NONE;
fun le ONeg ONeg = NONE
| le ONeg (ONum y) = SOME true
| le ONeg OInf = SOME true
| le (ONum _) ONeg = SOME false
| le (ONum x) (ONum y) = SOME (x <= y)
| le (ONum _) OInf = SOME true
| le OInf ONeg = SOME false
| le OInf (ONum _) = SOME false
| le OInf OInf = NONE;
fun lt x y = Option.map not (le y x);
fun ge x y = le y x;
fun gt x y = lt y x;
fun divides ONeg ONeg = NONE
| divides ONeg (ONum y) = if y = 0 then SOME true else NONE
| divides ONeg OInf = NONE
| divides (ONum x) ONeg =
if x = 0 then SOME false else if x = 1 then SOME true else NONE
| divides (ONum x) (ONum y) = SOME (Useful.divides x y)
| divides (ONum x) OInf =
if x = 0 then SOME false else if x = 1 then SOME true else NONE
| divides OInf ONeg = NONE
| divides OInf (ONum y) = SOME (y = 0)
| divides OInf OInf = NONE;
fun even n = divides two n;
fun odd n = Option.map not (even n);
fun fixedOverflow mk_onum dest_onum =
let
fun partial_dest_onum NONE = NONE
| partial_dest_onum (SOME n) = dest_onum n
fun functions (numeral,[]) =
(case (natFromString numeral handle Overflow => NONE) of
NONE => NONE
| SOME n => dest_onum (ONum n))
| functions ("suc",[x]) = dest_onum (suc (mk_onum x))
| functions ("pre",[x]) = dest_onum (pre (mk_onum x))
| functions ("~",[x]) = partial_dest_onum (neg (mk_onum x))
| functions ("+",[x,y]) =
partial_dest_onum (add (mk_onum x) (mk_onum y))
| functions ("-",[x,y]) =
partial_dest_onum (sub (mk_onum x) (mk_onum y))
| functions ("*",[x,y]) =
partial_dest_onum (mult (mk_onum x) (mk_onum y))
| functions ("exp",[x,y]) =
partial_dest_onum (exp (mk_onum x) (mk_onum y))
| functions ("div",[x,y]) =
partial_dest_onum (odiv (mk_onum x) (mk_onum y))
| functions ("mod",[x,y]) =
partial_dest_onum (omod (mk_onum x) (mk_onum y))
| functions _ = NONE
fun relations ("is_0",[x]) = SOME (mk_onum x = zero)
| relations ("<=",[x,y]) = le (mk_onum x) (mk_onum y)
| relations ("<",[x,y]) = lt (mk_onum x) (mk_onum y)
| relations (">=",[x,y]) = ge (mk_onum x) (mk_onum y)
| relations (">",[x,y]) = gt (mk_onum x) (mk_onum y)
| relations ("divides",[x,y]) = divides (mk_onum x) (mk_onum y)
| relations ("even",[x]) = even (mk_onum x)
| relations ("odd",[x]) = odd (mk_onum x)
| relations _ = NONE
in
{functions = functions, relations = relations}
end;
in
fun fixedOverflowNum {size = N} =
let
val oinf = N - 1
fun mk_onum x = if x = oinf then OInf else ONum x
fun dest_onum ONeg = NONE
| dest_onum (ONum x) = SOME (if x < oinf then x else oinf)
| dest_onum OInf = SOME oinf
in
fixedOverflow mk_onum dest_onum
end;
fun fixedOverflowInt {size = N} =
let
val oinf = N - 2
val oneg = N - 1
fun mk_onum x =
if x = oneg then ONeg else if x = oinf then OInf else ONum x
fun dest_onum ONeg = SOME oneg
| dest_onum (ONum x) = SOME (if x < oinf then x else oinf)
| dest_onum OInf = SOME oinf
in
fixedOverflow mk_onum dest_onum
end;
end;
fun fixedSet {size = N} =
let
val M =
let
fun f 0 acc = acc
| f x acc = f (x div 2) (acc + 1)
in
f N 0
end
val univ = IntSet.fromList (interval 0 M)
val mk_set =
let
fun f _ s 0 = s
| f k s x =
let
val s = if x mod 2 = 0 then s else IntSet.add s k
in
f (k + 1) s (x div 2)
end
in
f 0 IntSet.empty
end
fun dest_set s =
let
fun f 0 x = x
| f k x =
let
val k = k - 1
in
f k (if IntSet.member k s then 2 * x + 1 else 2 * x)
end
val x = case IntSet.findr (K true) s of NONE => 0 | SOME k => f k 1
in
if x < N then SOME x else NONE
end
fun functions ("empty",[]) = dest_set IntSet.empty
| functions ("univ",[]) = dest_set univ
| functions ("union",[x,y]) =
dest_set (IntSet.union (mk_set x) (mk_set y))
| functions ("intersect",[x,y]) =
dest_set (IntSet.intersect (mk_set x) (mk_set y))
| functions ("compl",[x]) =
dest_set (IntSet.difference univ (mk_set x))
| functions ("card",[x]) = SOME (IntSet.size (mk_set x))
| functions _ = NONE
fun relations ("in",[x,y]) = SOME (IntSet.member (x mod M) (mk_set y))
| relations ("subset",[x,y]) =
SOME (IntSet.subset (mk_set x) (mk_set y))
| relations _ = NONE
in
{functions = functions, relations = relations}
end;
(* ------------------------------------------------------------------------- *)
(* A type of random finite models. *)
(* ------------------------------------------------------------------------- *)
type parameters = {size : int, fixed : fixed};
datatype model =
Model of
{size : int,
fixed : fixedModel,
functions : (Term.functionName * int list, int) Map.map Unsynchronized.ref,
relations : (Atom.relationName * int list, bool) Map.map Unsynchronized.ref};
local
fun cmp ((n1,l1),(n2,l2)) =
case String.compare (n1,n2) of
LESS => LESS
| EQUAL => lexCompare Int.compare (l1,l2)
| GREATER => GREATER;
in
fun new {size = N, fixed} =
Model
{size = N,
fixed = fixed {size = N},
functions = Unsynchronized.ref (Map.new cmp),
relations = Unsynchronized.ref (Map.new cmp)};
end;
fun size (Model {size = s, ...}) = s;
(* ------------------------------------------------------------------------- *)
(* Valuations. *)
(* ------------------------------------------------------------------------- *)
type valuation = int NameMap.map;
val valuationEmpty : valuation = NameMap.new ();
fun valuationRandom {size = N} vs =
let
fun f (v,V) = NameMap.insert V (v, Portable.randomInt N)
in
NameSet.foldl f valuationEmpty vs
end;
fun valuationFold {size = N} vs f =
let
val vs = NameSet.toList vs
fun inc [] _ = NONE
| inc (v :: l) V =
case NameMap.peek V v of
NONE => raise Bug "Model.valuationFold"
| SOME k =>
let
val k = if k = N - 1 then 0 else k + 1
val V = NameMap.insert V (v,k)
in
if k = 0 then inc l V else SOME V
end
val zero = foldl (fn (v,V) => NameMap.insert V (v,0)) valuationEmpty vs
fun fold V acc =
let
val acc = f (V,acc)
in
case inc vs V of NONE => acc | SOME V => fold V acc
end
in
fold zero
end;
(* ------------------------------------------------------------------------- *)
(* Interpreting terms and formulas in the model. *)
(* ------------------------------------------------------------------------- *)
fun interpretTerm M V =
let
val Model {size = N, fixed, functions, ...} = M
val {functions = fixed_functions, ...} = fixed
fun interpret (Term.Var v) =
(case NameMap.peek V v of
NONE => raise Error "Model.interpretTerm: incomplete valuation"
| SOME i => i)
| interpret (tm as Term.Fn f_tms) =
let
val (f,tms) =
case Term.stripComb tm of
(_,[]) => f_tms
| (v as Term.Var _, tms) => (".", v :: tms)
| (Term.Fn (f,tms), tms') => (f, tms @ tms')
val elts = map interpret tms
val f_elts = (f,elts)
val Unsynchronized.ref funcs = functions
in
case Map.peek funcs f_elts of
SOME k => k
| NONE =>
let
val k =
case fixed_functions f_elts of
SOME k => k
| NONE => Portable.randomInt N
val () = functions := Map.insert funcs (f_elts,k)
in
k
end
end;
in
interpret
end;
fun interpretAtom M V (r,tms) =
let
val Model {fixed,relations,...} = M
val {relations = fixed_relations, ...} = fixed
val elts = map (interpretTerm M V) tms
val r_elts = (r,elts)
val Unsynchronized.ref rels = relations
in
case Map.peek rels r_elts of
SOME b => b
| NONE =>
let
val b =
case fixed_relations r_elts of
SOME b => b
| NONE => Portable.randomBool ()
val () = relations := Map.insert rels (r_elts,b)
in
b
end
end;
fun interpretFormula M =
let
val Model {size = N, ...} = M
fun interpret _ Formula.True = true
| interpret _ Formula.False = false
| interpret V (Formula.Atom atm) = interpretAtom M V atm
| interpret V (Formula.Not p) = not (interpret V p)
| interpret V (Formula.Or (p,q)) = interpret V p orelse interpret V q
| interpret V (Formula.And (p,q)) = interpret V p andalso interpret V q
| interpret V (Formula.Imp (p,q)) =
interpret V (Formula.Or (Formula.Not p, q))
| interpret V (Formula.Iff (p,q)) = interpret V p = interpret V q
| interpret V (Formula.Forall (v,p)) = interpret' V v p N
| interpret V (Formula.Exists (v,p)) =
interpret V (Formula.Not (Formula.Forall (v, Formula.Not p)))
and interpret' _ _ _ 0 = true
| interpret' V v p i =
let
val i = i - 1
val V' = NameMap.insert V (v,i)
in
interpret V' p andalso interpret' V v p i
end
in
interpret
end;
fun interpretLiteral M V (true,atm) = interpretAtom M V atm
| interpretLiteral M V (false,atm) = not (interpretAtom M V atm);
fun interpretClause M V cl = LiteralSet.exists (interpretLiteral M V) cl;
(* ------------------------------------------------------------------------- *)
(* Check whether random groundings of a formula are true in the model. *)
(* Note: if it's cheaper, a systematic check will be performed instead. *)
(* ------------------------------------------------------------------------- *)
local
fun checkGen freeVars interpret {maxChecks} M x =
let
val Model {size = N, ...} = M
fun score (V,{T,F}) =
if interpret M V x then {T = T + 1, F = F} else {T = T, F = F + 1}
val vs = freeVars x
fun randomCheck acc = score (valuationRandom {size = N} vs, acc)
val small =
intExp N (NameSet.size vs) <= maxChecks handle Overflow => false
in
if small then valuationFold {size = N} vs score {T = 0, F = 0}
else funpow maxChecks randomCheck {T = 0, F = 0}
end;
in
val checkAtom = checkGen Atom.freeVars interpretAtom;
val checkFormula = checkGen Formula.freeVars interpretFormula;
val checkLiteral = checkGen Literal.freeVars interpretLiteral;
val checkClause = checkGen LiteralSet.freeVars interpretClause;
end;
end
end;
(**** Original file: Problem.sig ****)
(* ========================================================================= *)
(* SOME SAMPLE PROBLEMS TO TEST PROOF PROCEDURES *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Problem =
sig
(* ------------------------------------------------------------------------- *)
(* Problems. *)
(* ------------------------------------------------------------------------- *)
type problem = Metis.Thm.clause list
val size : problem -> {clauses : int,
literals : int,
symbols : int,
typedSymbols : int}
val fromGoal : Metis.Formula.formula -> problem list
val toClauses : problem -> Metis.Formula.formula
val toString : problem -> string
(* ------------------------------------------------------------------------- *)
(* Categorizing problems. *)
(* ------------------------------------------------------------------------- *)
datatype propositional =
Propositional
| EffectivelyPropositional
| NonPropositional
datatype equality =
NonEquality
| Equality
| PureEquality
datatype horn =
Trivial
| Unit
| DoubleHorn
| Horn
| NegativeHorn
| NonHorn
type category =
{propositional : propositional,
equality : equality,
horn : horn}
val categorize : problem -> category
val categoryToString : category -> string
end
(**** Original file: Problem.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* SOME SAMPLE PROBLEMS TO TEST PROOF PROCEDURES *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Problem :> Problem =
struct
open Useful;
(* ------------------------------------------------------------------------- *)
(* Problems. *)
(* ------------------------------------------------------------------------- *)
type problem = Thm.clause list;
fun size cls =
{clauses = length cls,
literals = foldl (fn (cl,n) => n + LiteralSet.size cl) 0 cls,
symbols = foldl (fn (cl,n) => n + LiteralSet.symbols cl) 0 cls,
typedSymbols = foldl (fn (cl,n) => n + LiteralSet.typedSymbols cl) 0 cls};
fun checkFormula {models,checks} exp fm =
let
fun check 0 = true
| check n =
let
val N = 3 + Portable.randomInt 3
val M = Model.new {size = N, fixed = Model.fixedPure}
val {T,F} = Model.checkFormula {maxChecks = checks} M fm
in
(if exp then F = 0 else T = 0) andalso check (n - 1)
end
in
check models
end;
val checkGoal = checkFormula {models = 10, checks = 100} true;
val checkClauses = checkFormula {models = 10, checks = 100} false;
fun fromGoal goal =
let
fun fromLiterals fms = LiteralSet.fromList (map Literal.fromFormula fms)
fun fromClause fm = fromLiterals (Formula.stripDisj fm)
fun fromCnf fm = map fromClause (Formula.stripConj fm)
(*DEBUG
val () = if checkGoal goal then ()
else raise Error "goal failed the finite model test"
*)
val refute = Formula.Not (Formula.generalize goal)
(*TRACE2
val () = Parser.ppTrace Formula.pp "Problem.fromGoal: refute" refute
*)
val cnfs = Normalize.cnf refute
(*
val () =
let
fun check fm =
let
(*TRACE2
val () = Parser.ppTrace Formula.pp "Problem.fromGoal: cnf" fm
*)
in
if checkClauses fm then ()
else raise Error "cnf failed the finite model test"
end
in
app check cnfs
end
*)
in
map fromCnf cnfs
end;
fun toClauses cls =
let
fun formulize cl =
Formula.listMkDisj (LiteralSet.transform Literal.toFormula cl)
in
Formula.listMkConj (map formulize cls)
end;
fun toString cls = Formula.toString (toClauses cls);
(* ------------------------------------------------------------------------- *)
(* Categorizing problems. *)
(* ------------------------------------------------------------------------- *)
datatype propositional =
Propositional
| EffectivelyPropositional
| NonPropositional;
datatype equality =
NonEquality
| Equality
| PureEquality;
datatype horn =
Trivial
| Unit
| DoubleHorn
| Horn
| NegativeHorn
| NonHorn;
type category =
{propositional : propositional,
equality : equality,
horn : horn};
fun categorize cls =
let
val rels =
let
fun f (cl,set) = NameAritySet.union set (LiteralSet.relations cl)
in
List.foldl f NameAritySet.empty cls
end
val funs =
let
fun f (cl,set) = NameAritySet.union set (LiteralSet.functions cl)
in
List.foldl f NameAritySet.empty cls
end
val propositional =
if NameAritySet.allNullary rels then Propositional
else if NameAritySet.allNullary funs then EffectivelyPropositional
else NonPropositional
val equality =
if not (NameAritySet.member Atom.eqRelation rels) then NonEquality
else if NameAritySet.size rels = 1 then PureEquality
else Equality
val horn =
if List.exists LiteralSet.null cls then Trivial
else if List.all (fn cl => LiteralSet.size cl = 1) cls then Unit
else
let
fun pos cl = LiteralSet.count Literal.positive cl <= 1
fun neg cl = LiteralSet.count Literal.negative cl <= 1
in
case (List.all pos cls, List.all neg cls) of
(true,true) => DoubleHorn
| (true,false) => Horn
| (false,true) => NegativeHorn
| (false,false) => NonHorn
end
in
{propositional = propositional,
equality = equality,
horn = horn}
end;
fun categoryToString {propositional,equality,horn} =
(case propositional of
Propositional => "propositional"
| EffectivelyPropositional => "effectively propositional"
| NonPropositional => "non-propositional") ^
", " ^
(case equality of
NonEquality => "non-equality"
| Equality => "equality"
| PureEquality => "pure equality") ^
", " ^
(case horn of
Trivial => "trivial"
| Unit => "unit"
| DoubleHorn => "horn (and negative horn)"
| Horn => "horn"
| NegativeHorn => "negative horn"
| NonHorn => "non-horn");
end
end;
(**** Original file: TermNet.sig ****)
(* ========================================================================= *)
(* MATCHING AND UNIFICATION FOR SETS OF FIRST ORDER LOGIC TERMS *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature TermNet =
sig
(* ------------------------------------------------------------------------- *)
(* A type of term sets that can be efficiently matched and unified. *)
(* ------------------------------------------------------------------------- *)
type parameters = {fifo : bool}
type 'a termNet
(* ------------------------------------------------------------------------- *)
(* Basic operations. *)
(* ------------------------------------------------------------------------- *)
val new : parameters -> 'a termNet
val null : 'a termNet -> bool
val size : 'a termNet -> int
val insert : 'a termNet -> Metis.Term.term * 'a -> 'a termNet
val fromList : parameters -> (Metis.Term.term * 'a) list -> 'a termNet
val filter : ('a -> bool) -> 'a termNet -> 'a termNet
val toString : 'a termNet -> string
val pp : 'a Metis.Parser.pp -> 'a termNet Metis.Parser.pp
(* ------------------------------------------------------------------------- *)
(* Matching and unification queries. *)
(* *)
(* These function return OVER-APPROXIMATIONS! *)
(* Filter afterwards to get the precise set of satisfying values. *)
(* ------------------------------------------------------------------------- *)
val match : 'a termNet -> Metis.Term.term -> 'a list
val matched : 'a termNet -> Metis.Term.term -> 'a list
val unify : 'a termNet -> Metis.Term.term -> 'a list
end
(**** Original file: TermNet.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* MATCHING AND UNIFICATION FOR SETS OF FIRST ORDER LOGIC TERMS *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure TermNet :> TermNet =
struct
open Useful;
(* ------------------------------------------------------------------------- *)
(* Quotient terms *)
(* ------------------------------------------------------------------------- *)
datatype qterm = VAR | FN of NameArity.nameArity * qterm list;
fun termToQterm (Term.Var _) = VAR
| termToQterm (Term.Fn (f,l)) = FN ((f, length l), map termToQterm l);
local
fun qm [] = true
| qm ((VAR,_) :: rest) = qm rest
| qm ((FN _, VAR) :: _) = false
| qm ((FN (f,a), FN (g,b)) :: rest) = f = g andalso qm (zip a b @ rest);
in
fun matchQtermQterm qtm qtm' = qm [(qtm,qtm')];
end;
local
fun qm [] = true
| qm ((VAR,_) :: rest) = qm rest
| qm ((FN _, Term.Var _) :: _) = false
| qm ((FN ((f,n),a), Term.Fn (g,b)) :: rest) =
f = g andalso n = length b andalso qm (zip a b @ rest);
in
fun matchQtermTerm qtm tm = qm [(qtm,tm)];
end;
local
fun qn qsub [] = SOME qsub
| qn qsub ((Term.Var v, qtm) :: rest) =
(case NameMap.peek qsub v of
NONE => qn (NameMap.insert qsub (v,qtm)) rest
| SOME qtm' => if qtm = qtm' then qn qsub rest else NONE)
| qn _ ((Term.Fn _, VAR) :: _) = NONE
| qn qsub ((Term.Fn (f,a), FN ((g,n),b)) :: rest) =
if f = g andalso length a = n then qn qsub (zip a b @ rest) else NONE;
in
fun matchTermQterm qsub tm qtm = qn qsub [(tm,qtm)];
end;
local
fun qv VAR x = x
| qv x VAR = x
| qv (FN (f,a)) (FN (g,b)) =
let
val _ = f = g orelse raise Error "TermNet.qv"
in
FN (f, zipwith qv a b)
end;
fun qu qsub [] = qsub
| qu qsub ((VAR, _) :: rest) = qu qsub rest
| qu qsub ((qtm, Term.Var v) :: rest) =
let
val qtm =
case NameMap.peek qsub v of NONE => qtm | SOME qtm' => qv qtm qtm'
in
qu (NameMap.insert qsub (v,qtm)) rest
end
| qu qsub ((FN ((f,n),a), Term.Fn (g,b)) :: rest) =
if f = g andalso n = length b then qu qsub (zip a b @ rest)
else raise Error "TermNet.qu";
in
fun unifyQtermQterm qtm qtm' = total (qv qtm) qtm';
fun unifyQtermTerm qsub qtm tm = total (qu qsub) [(qtm,tm)];
end;
local
fun qtermToTerm VAR = Term.Var ""
| qtermToTerm (FN ((f,_),l)) = Term.Fn (f, map qtermToTerm l);
in
val ppQterm = Parser.ppMap qtermToTerm Term.pp;
end;
(* ------------------------------------------------------------------------- *)
(* A type of term sets that can be efficiently matched and unified. *)
(* ------------------------------------------------------------------------- *)
type parameters = {fifo : bool};
datatype 'a net =
RESULT of 'a list
| SINGLE of qterm * 'a net
| MULTIPLE of 'a net option * 'a net NameArityMap.map;
datatype 'a termNet = NET of parameters * int * (int * (int * 'a) net) option;
(* ------------------------------------------------------------------------- *)
(* Basic operations. *)
(* ------------------------------------------------------------------------- *)
fun new parm = NET (parm,0,NONE);
local
fun computeSize (RESULT l) = length l
| computeSize (SINGLE (_,n)) = computeSize n
| computeSize (MULTIPLE (vs,fs)) =
NameArityMap.foldl
(fn (_,n,acc) => acc + computeSize n)
(case vs of SOME n => computeSize n | NONE => 0)
fs;
in
fun netSize NONE = NONE
| netSize (SOME n) = SOME (computeSize n, n);
end;
fun size (NET (_,_,NONE)) = 0
| size (NET (_, _, SOME (i,_))) = i;
fun null net = size net = 0;
fun singles qtms a = foldr SINGLE a qtms;
local
fun pre NONE = (0,NONE)
| pre (SOME (i,n)) = (i, SOME n);
fun add (RESULT l) [] (RESULT l') = RESULT (l @ l')
| add a (input1 as qtm :: qtms) (SINGLE (qtm',n)) =
if qtm = qtm' then SINGLE (qtm, add a qtms n)
else add a input1 (add n [qtm'] (MULTIPLE (NONE, NameArityMap.new ())))
| add a (VAR :: qtms) (MULTIPLE (vs,fs)) =
MULTIPLE (SOME (oadd a qtms vs), fs)
| add a (FN (f,l) :: qtms) (MULTIPLE (vs,fs)) =
let
val n = NameArityMap.peek fs f
in
MULTIPLE (vs, NameArityMap.insert fs (f, oadd a (l @ qtms) n))
end
| add _ _ _ = raise Bug "TermNet.insert: Match"
and oadd a qtms NONE = singles qtms a
| oadd a qtms (SOME n) = add a qtms n;
fun ins a qtm (i,n) = SOME (i + 1, oadd (RESULT [a]) [qtm] n);
in
fun insert (NET (p,k,n)) (tm,a) =
NET (p, k + 1, ins (k,a) (termToQterm tm) (pre n))
handle Error _ => raise Bug "TermNet.insert: should never fail";
end;
fun fromList parm l = foldl (fn (tm_a,n) => insert n tm_a) (new parm) l;
fun filter pred =
let
fun filt (RESULT l) =
(case List.filter (fn (_,a) => pred a) l of
[] => NONE
| l => SOME (RESULT l))
| filt (SINGLE (qtm,n)) =
(case filt n of
NONE => NONE
| SOME n => SOME (SINGLE (qtm,n)))
| filt (MULTIPLE (vs,fs)) =
let
val vs = Option.mapPartial filt vs
val fs = NameArityMap.mapPartial (fn (_,n) => filt n) fs
in
if not (Option.isSome vs) andalso NameArityMap.null fs then NONE
else SOME (MULTIPLE (vs,fs))
end
in
fn net as NET (_,_,NONE) => net
| NET (p, k, SOME (_,n)) => NET (p, k, netSize (filt n))
end
handle Error _ => raise Bug "TermNet.filter: should never fail";
fun toString net = "TermNet[" ^ Int.toString (size net) ^ "]";
(* ------------------------------------------------------------------------- *)
(* Specialized fold operations to support matching and unification. *)
(* ------------------------------------------------------------------------- *)
local
fun norm (0 :: ks, (f as (_,n)) :: fs, qtms) =
let
val (a,qtms) = revDivide qtms n
in
addQterm (FN (f,a)) (ks,fs,qtms)
end
| norm stack = stack
and addQterm qtm (ks,fs,qtms) =
let
val ks = case ks of [] => [] | k :: ks => (k - 1) :: ks
in
norm (ks, fs, qtm :: qtms)
end
and addFn (f as (_,n)) (ks,fs,qtms) = norm (n :: ks, f :: fs, qtms);
in
val stackEmpty = ([],[],[]);
val stackAddQterm = addQterm;
val stackAddFn = addFn;
fun stackValue ([],[],[qtm]) = qtm
| stackValue _ = raise Bug "TermNet.stackValue";
end;
local
fun fold _ acc [] = acc
| fold inc acc ((0,stack,net) :: rest) =
fold inc (inc (stackValue stack, net, acc)) rest
| fold inc acc ((n, stack, SINGLE (qtm,net)) :: rest) =
fold inc acc ((n - 1, stackAddQterm qtm stack, net) :: rest)
| fold inc acc ((n, stack, MULTIPLE (v,fns)) :: rest) =
let
val n = n - 1
val rest =
case v of
NONE => rest
| SOME net => (n, stackAddQterm VAR stack, net) :: rest
fun getFns (f as (_,k), net, x) =
(k + n, stackAddFn f stack, net) :: x
in
fold inc acc (NameArityMap.foldr getFns rest fns)
end
| fold _ _ _ = raise Bug "TermNet.foldTerms.fold";
in
fun foldTerms inc acc net = fold inc acc [(1,stackEmpty,net)];
end;
fun foldEqualTerms pat inc acc =
let
fun fold ([],net) = inc (pat,net,acc)
| fold (pat :: pats, SINGLE (qtm,net)) =
if pat = qtm then fold (pats,net) else acc
| fold (VAR :: pats, MULTIPLE (v,_)) =
(case v of NONE => acc | SOME net => fold (pats,net))
| fold (FN (f,a) :: pats, MULTIPLE (_,fns)) =
(case NameArityMap.peek fns f of
NONE => acc
| SOME net => fold (a @ pats, net))
| fold _ = raise Bug "TermNet.foldEqualTerms.fold";
in
fn net => fold ([pat],net)
end;
local
fun fold _ acc [] = acc
| fold inc acc (([],stack,net) :: rest) =
fold inc (inc (stackValue stack, net, acc)) rest
| fold inc acc ((VAR :: pats, stack, net) :: rest) =
let
fun harvest (qtm,n,l) = (pats, stackAddQterm qtm stack, n) :: l
in
fold inc acc (foldTerms harvest rest net)
end
| fold inc acc ((pat :: pats, stack, SINGLE (qtm,net)) :: rest) =
(case unifyQtermQterm pat qtm of
NONE => fold inc acc rest
| SOME qtm =>
fold inc acc ((pats, stackAddQterm qtm stack, net) :: rest))
| fold
inc acc
(((pat as FN (f,a)) :: pats, stack, MULTIPLE (v,fns)) :: rest) =
let
val rest =
case v of
NONE => rest
| SOME net => (pats, stackAddQterm pat stack, net) :: rest
val rest =
case NameArityMap.peek fns f of
NONE => rest
| SOME net => (a @ pats, stackAddFn f stack, net) :: rest
in
fold inc acc rest
end
| fold _ _ _ = raise Bug "TermNet.foldUnifiableTerms.fold";
in
fun foldUnifiableTerms pat inc acc net =
fold inc acc [([pat],stackEmpty,net)];
end;
(* ------------------------------------------------------------------------- *)
(* Matching and unification queries. *)
(* *)
(* These function return OVER-APPROXIMATIONS! *)
(* Filter afterwards to get the precise set of satisfying values. *)
(* ------------------------------------------------------------------------- *)
local
fun idwise ((m,_),(n,_)) = Int.compare (m,n);
fun fifoize ({fifo, ...} : parameters) l = if fifo then sort idwise l else l;
in
fun finally parm l = map snd (fifoize parm l);
end;
local
fun mat acc [] = acc
| mat acc ((RESULT l, []) :: rest) = mat (l @ acc) rest
| mat acc ((SINGLE (qtm,n), tm :: tms) :: rest) =
mat acc (if matchQtermTerm qtm tm then (n,tms) :: rest else rest)
| mat acc ((MULTIPLE (vs,fs), tm :: tms) :: rest) =
let
val rest = case vs of NONE => rest | SOME n => (n,tms) :: rest
val rest =
case tm of
Term.Var _ => rest
| Term.Fn (f,l) =>
case NameArityMap.peek fs (f, length l) of
NONE => rest
| SOME n => (n, l @ tms) :: rest
in
mat acc rest
end
| mat _ _ = raise Bug "TermNet.match: Match";
in
fun match (NET (_,_,NONE)) _ = []
| match (NET (p, _, SOME (_,n))) tm =
finally p (mat [] [(n,[tm])])
handle Error _ => raise Bug "TermNet.match: should never fail";
end;
local
fun unseenInc qsub v tms (qtm,net,rest) =
(NameMap.insert qsub (v,qtm), net, tms) :: rest;
fun seenInc qsub tms (_,net,rest) = (qsub,net,tms) :: rest;
fun mat acc [] = acc
| mat acc ((_, RESULT l, []) :: rest) = mat (l @ acc) rest
| mat acc ((qsub, SINGLE (qtm,net), tm :: tms) :: rest) =
(case matchTermQterm qsub tm qtm of
NONE => mat acc rest
| SOME qsub => mat acc ((qsub,net,tms) :: rest))
| mat acc ((qsub, net as MULTIPLE _, Term.Var v :: tms) :: rest) =
(case NameMap.peek qsub v of
NONE => mat acc (foldTerms (unseenInc qsub v tms) rest net)
| SOME qtm => mat acc (foldEqualTerms qtm (seenInc qsub tms) rest net))
| mat acc ((qsub, MULTIPLE (_,fns), Term.Fn (f,a) :: tms) :: rest) =
let
val rest =
case NameArityMap.peek fns (f, length a) of
NONE => rest
| SOME net => (qsub, net, a @ tms) :: rest
in
mat acc rest
end
| mat _ _ = raise Bug "TermNet.matched.mat";
in
fun matched (NET (_,_,NONE)) _ = []
| matched (NET (parm, _, SOME (_,net))) tm =
finally parm (mat [] [(NameMap.new (), net, [tm])])
handle Error _ => raise Bug "TermNet.matched: should never fail";
end;
local
fun inc qsub v tms (qtm,net,rest) =
(NameMap.insert qsub (v,qtm), net, tms) :: rest;
fun mat acc [] = acc
| mat acc ((_, RESULT l, []) :: rest) = mat (l @ acc) rest
| mat acc ((qsub, SINGLE (qtm,net), tm :: tms) :: rest) =
(case unifyQtermTerm qsub qtm tm of
NONE => mat acc rest
| SOME qsub => mat acc ((qsub,net,tms) :: rest))
| mat acc ((qsub, net as MULTIPLE _, Term.Var v :: tms) :: rest) =
(case NameMap.peek qsub v of
NONE => mat acc (foldTerms (inc qsub v tms) rest net)
| SOME qtm => mat acc (foldUnifiableTerms qtm (inc qsub v tms) rest net))
| mat acc ((qsub, MULTIPLE (v,fns), Term.Fn (f,a) :: tms) :: rest) =
let
val rest = case v of NONE => rest | SOME net => (qsub,net,tms) :: rest
val rest =
case NameArityMap.peek fns (f, length a) of
NONE => rest
| SOME net => (qsub, net, a @ tms) :: rest
in
mat acc rest
end
| mat _ _ = raise Bug "TermNet.unify.mat";
in
fun unify (NET (_,_,NONE)) _ = []
| unify (NET (parm, _, SOME (_,net))) tm =
finally parm (mat [] [(NameMap.new (), net, [tm])])
handle Error _ => raise Bug "TermNet.unify: should never fail";
end;
(* ------------------------------------------------------------------------- *)
(* Pretty printing. *)
(* ------------------------------------------------------------------------- *)
local
fun inc (qtm, RESULT l, acc) =
foldl (fn ((n,a),acc) => (n,(qtm,a)) :: acc) acc l
| inc _ = raise Bug "TermNet.pp.inc";
fun toList (NET (_,_,NONE)) = []
| toList (NET (parm, _, SOME (_,net))) =
finally parm (foldTerms inc [] net);
in
fun pp ppA =
Parser.ppMap toList (Parser.ppList (Parser.ppBinop " |->" ppQterm ppA));
end;
end
end;
(**** Original file: AtomNet.sig ****)
(* ========================================================================= *)
(* MATCHING AND UNIFICATION FOR SETS OF FIRST ORDER LOGIC ATOMS *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature AtomNet =
sig
(* ------------------------------------------------------------------------- *)
(* A type of atom sets that can be efficiently matched and unified. *)
(* ------------------------------------------------------------------------- *)
type parameters = {fifo : bool}
type 'a atomNet
(* ------------------------------------------------------------------------- *)
(* Basic operations. *)
(* ------------------------------------------------------------------------- *)
val new : parameters -> 'a atomNet
val size : 'a atomNet -> int
val insert : 'a atomNet -> Metis.Atom.atom * 'a -> 'a atomNet
val fromList : parameters -> (Metis.Atom.atom * 'a) list -> 'a atomNet
val filter : ('a -> bool) -> 'a atomNet -> 'a atomNet
val toString : 'a atomNet -> string
val pp : 'a Metis.Parser.pp -> 'a atomNet Metis.Parser.pp
(* ------------------------------------------------------------------------- *)
(* Matching and unification queries. *)
(* *)
(* These function return OVER-APPROXIMATIONS! *)
(* Filter afterwards to get the precise set of satisfying values. *)
(* ------------------------------------------------------------------------- *)
val match : 'a atomNet -> Metis.Atom.atom -> 'a list
val matched : 'a atomNet -> Metis.Atom.atom -> 'a list
val unify : 'a atomNet -> Metis.Atom.atom -> 'a list
end
(**** Original file: AtomNet.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* MATCHING AND UNIFICATION FOR SETS OF FIRST ORDER LOGIC ATOMS *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure AtomNet :> AtomNet =
struct
open Useful;
(* ------------------------------------------------------------------------- *)
(* Helper functions. *)
(* ------------------------------------------------------------------------- *)
fun atomToTerm atom = Term.Fn atom;
fun termToAtom (Term.Var _) = raise Bug "AtomNet.termToAtom"
| termToAtom (Term.Fn atom) = atom;
(* ------------------------------------------------------------------------- *)
(* A type of atom sets that can be efficiently matched and unified. *)
(* ------------------------------------------------------------------------- *)
type parameters = TermNet.parameters;
type 'a atomNet = 'a TermNet.termNet;
(* ------------------------------------------------------------------------- *)
(* Basic operations. *)
(* ------------------------------------------------------------------------- *)
val new = TermNet.new;
val size = TermNet.size;
fun insert net (atm,a) = TermNet.insert net (atomToTerm atm, a);
fun fromList parm l = foldl (fn (atm_a,n) => insert n atm_a) (new parm) l;
val filter = TermNet.filter;
fun toString net = "AtomNet[" ^ Int.toString (size net) ^ "]";
val pp = TermNet.pp;
(* ------------------------------------------------------------------------- *)
(* Matching and unification queries. *)
(* *)
(* These function return OVER-APPROXIMATIONS! *)
(* Filter afterwards to get the precise set of satisfying values. *)
(* ------------------------------------------------------------------------- *)
fun match net atm = TermNet.match net (atomToTerm atm);
fun matched net atm = TermNet.matched net (atomToTerm atm);
fun unify net atm = TermNet.unify net (atomToTerm atm);
end
end;
(**** Original file: LiteralNet.sig ****)
(* ========================================================================= *)
(* MATCHING AND UNIFICATION FOR SETS OF FIRST ORDER LOGIC LITERALS *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature LiteralNet =
sig
(* ------------------------------------------------------------------------- *)
(* A type of literal sets that can be efficiently matched and unified. *)
(* ------------------------------------------------------------------------- *)
type parameters = {fifo : bool}
type 'a literalNet
(* ------------------------------------------------------------------------- *)
(* Basic operations. *)
(* ------------------------------------------------------------------------- *)
val new : parameters -> 'a literalNet
val size : 'a literalNet -> int
val profile : 'a literalNet -> {positive : int, negative : int}
val insert : 'a literalNet -> Metis.Literal.literal * 'a -> 'a literalNet
val fromList : parameters -> (Metis.Literal.literal * 'a) list -> 'a literalNet
val filter : ('a -> bool) -> 'a literalNet -> 'a literalNet
val toString : 'a literalNet -> string
val pp : 'a Metis.Parser.pp -> 'a literalNet Metis.Parser.pp
(* ------------------------------------------------------------------------- *)
(* Matching and unification queries. *)
(* *)
(* These function return OVER-APPROXIMATIONS! *)
(* Filter afterwards to get the precise set of satisfying values. *)
(* ------------------------------------------------------------------------- *)
val match : 'a literalNet -> Metis.Literal.literal -> 'a list
val matched : 'a literalNet -> Metis.Literal.literal -> 'a list
val unify : 'a literalNet -> Metis.Literal.literal -> 'a list
end
(**** Original file: LiteralNet.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* MATCHING AND UNIFICATION FOR SETS OF FIRST ORDER LOGIC LITERALS *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure LiteralNet :> LiteralNet =
struct
open Useful;
(* ------------------------------------------------------------------------- *)
(* A type of literal sets that can be efficiently matched and unified. *)
(* ------------------------------------------------------------------------- *)
type parameters = AtomNet.parameters;
type 'a literalNet =
{positive : 'a AtomNet.atomNet,
negative : 'a AtomNet.atomNet};
(* ------------------------------------------------------------------------- *)
(* Basic operations. *)
(* ------------------------------------------------------------------------- *)
fun new parm = {positive = AtomNet.new parm, negative = AtomNet.new parm};
local
fun pos ({positive,...} : 'a literalNet) = AtomNet.size positive;
fun neg ({negative,...} : 'a literalNet) = AtomNet.size negative;
in
fun size net = pos net + neg net;
fun profile net = {positive = pos net, negative = neg net};
end;
fun insert {positive,negative} ((true,atm),a) =
{positive = AtomNet.insert positive (atm,a), negative = negative}
| insert {positive,negative} ((false,atm),a) =
{positive = positive, negative = AtomNet.insert negative (atm,a)};
fun fromList parm l = foldl (fn (lit_a,n) => insert n lit_a) (new parm) l;
fun filter pred {positive,negative} =
{positive = AtomNet.filter pred positive,
negative = AtomNet.filter pred negative};
fun toString net = "LiteralNet[" ^ Int.toString (size net) ^ "]";
fun pp ppA =
Parser.ppMap
(fn {positive,negative} => (positive,negative))
(Parser.ppBinop " + NEGATIVE" (AtomNet.pp ppA) (AtomNet.pp ppA));
(* ------------------------------------------------------------------------- *)
(* Matching and unification queries. *)
(* *)
(* These function return OVER-APPROXIMATIONS! *)
(* Filter afterwards to get the precise set of satisfying values. *)
(* ------------------------------------------------------------------------- *)
fun match ({positive,...} : 'a literalNet) (true,atm) =
AtomNet.match positive atm
| match {negative,...} (false,atm) = AtomNet.match negative atm;
fun matched ({positive,...} : 'a literalNet) (true,atm) =
AtomNet.matched positive atm
| matched {negative,...} (false,atm) = AtomNet.matched negative atm;
fun unify ({positive,...} : 'a literalNet) (true,atm) =
AtomNet.unify positive atm
| unify {negative,...} (false,atm) = AtomNet.unify negative atm;
end
end;
(**** Original file: Subsume.sig ****)
(* ========================================================================= *)
(* SUBSUMPTION CHECKING FOR FIRST ORDER LOGIC CLAUSES *)
(* Copyright (c) 2002-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Subsume =
sig
(* ------------------------------------------------------------------------- *)
(* A type of clause sets that supports efficient subsumption checking. *)
(* ------------------------------------------------------------------------- *)
type 'a subsume
val new : unit -> 'a subsume
val size : 'a subsume -> int
val insert : 'a subsume -> Metis.Thm.clause * 'a -> 'a subsume
val filter : ('a -> bool) -> 'a subsume -> 'a subsume
val pp : 'a subsume Metis.Parser.pp
val toString : 'a subsume -> string
(* ------------------------------------------------------------------------- *)
(* Subsumption checking. *)
(* ------------------------------------------------------------------------- *)
val subsumes :
(Metis.Thm.clause * Metis.Subst.subst * 'a -> bool) -> 'a subsume -> Metis.Thm.clause ->
(Metis.Thm.clause * Metis.Subst.subst * 'a) option
val isSubsumed : 'a subsume -> Metis.Thm.clause -> bool
val strictlySubsumes : (* exclude subsuming clauses with more literals *)
(Metis.Thm.clause * Metis.Subst.subst * 'a -> bool) -> 'a subsume -> Metis.Thm.clause ->
(Metis.Thm.clause * Metis.Subst.subst * 'a) option
val isStrictlySubsumed : 'a subsume -> Metis.Thm.clause -> bool
(* ------------------------------------------------------------------------- *)
(* Single clause versions. *)
(* ------------------------------------------------------------------------- *)
val clauseSubsumes : Metis.Thm.clause -> Metis.Thm.clause -> Metis.Subst.subst option
val clauseStrictlySubsumes : Metis.Thm.clause -> Metis.Thm.clause -> Metis.Subst.subst option
end
(**** Original file: Subsume.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* SUBSUMPTION CHECKING FOR FIRST ORDER LOGIC CLAUSES *)
(* Copyright (c) 2002-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Subsume :> Subsume =
struct
open Useful;
(* ------------------------------------------------------------------------- *)
(* Helper functions. *)
(* ------------------------------------------------------------------------- *)
fun findRest pred =
let
fun f _ [] = NONE
| f ys (x :: xs) =
if pred x then SOME (x, List.revAppend (ys,xs)) else f (x :: ys) xs
in
f []
end;
local
fun addSym (lit,acc) =
case total Literal.sym lit of
NONE => acc
| SOME lit => lit :: acc
in
fun clauseSym lits = List.foldl addSym lits lits;
end;
fun sortClause cl =
let
val lits = LiteralSet.toList cl
in
sortMap Literal.typedSymbols (revCompare Int.compare) lits
end;
fun incompatible lit =
let
val lits = clauseSym [lit]
in
fn lit' => not (List.exists (can (Literal.unify Subst.empty lit')) lits)
end;
(* ------------------------------------------------------------------------- *)
(* Clause ids and lengths. *)
(* ------------------------------------------------------------------------- *)
type clauseId = int;
type clauseLength = int;
local
type idSet = (clauseId * clauseLength) Set.set;
fun idCompare ((id1,len1),(id2,len2)) =
case Int.compare (len1,len2) of
LESS => LESS
| EQUAL => Int.compare (id1,id2)
| GREATER => GREATER;
in
val idSetEmpty : idSet = Set.empty idCompare;
fun idSetAdd (id_len,set) : idSet = Set.add set id_len;
fun idSetAddMax max (id_len as (_,len), set) : idSet =
if len <= max then Set.add set id_len else set;
fun idSetIntersect set1 set2 : idSet = Set.intersect set1 set2;
end;
(* ------------------------------------------------------------------------- *)
(* A type of clause sets that supports efficient subsumption checking. *)
(* ------------------------------------------------------------------------- *)
datatype 'a subsume =
Subsume of
{empty : (Thm.clause * Subst.subst * 'a) list,
unit : (Literal.literal * Thm.clause * 'a) LiteralNet.literalNet,
nonunit :
{nextId : clauseId,
clauses : (Literal.literal list * Thm.clause * 'a) IntMap.map,
fstLits : (clauseId * clauseLength) LiteralNet.literalNet,
sndLits : (clauseId * clauseLength) LiteralNet.literalNet}};
fun new () =
Subsume
{empty = [],
unit = LiteralNet.new {fifo = false},
nonunit =
{nextId = 0,
clauses = IntMap.new (),
fstLits = LiteralNet.new {fifo = false},
sndLits = LiteralNet.new {fifo = false}}};
fun size (Subsume {empty, unit, nonunit = {clauses,...}}) =
length empty + LiteralNet.size unit + IntMap.size clauses;
fun insert (Subsume {empty,unit,nonunit}) (cl',a) =
case sortClause cl' of
[] =>
let
val empty = (cl',Subst.empty,a) :: empty
in
Subsume {empty = empty, unit = unit, nonunit = nonunit}
end
| [lit] =>
let
val unit = LiteralNet.insert unit (lit,(lit,cl',a))
in
Subsume {empty = empty, unit = unit, nonunit = nonunit}
end
| fstLit :: (nonFstLits as sndLit :: otherLits) =>
let
val {nextId,clauses,fstLits,sndLits} = nonunit
val id_length = (nextId, LiteralSet.size cl')
val fstLits = LiteralNet.insert fstLits (fstLit,id_length)
val (sndLit,otherLits) =
case findRest (incompatible fstLit) nonFstLits of
SOME sndLit_otherLits => sndLit_otherLits
| NONE => (sndLit,otherLits)
val sndLits = LiteralNet.insert sndLits (sndLit,id_length)
val lits' = otherLits @ [fstLit,sndLit]
val clauses = IntMap.insert clauses (nextId,(lits',cl',a))
val nextId = nextId + 1
val nonunit = {nextId = nextId, clauses = clauses,
fstLits = fstLits, sndLits = sndLits}
in
Subsume {empty = empty, unit = unit, nonunit = nonunit}
end;
fun filter pred (Subsume {empty,unit,nonunit}) =
let
val empty = List.filter (pred o #3) empty
val unit = LiteralNet.filter (pred o #3) unit
val nonunit =
let
val {nextId,clauses,fstLits,sndLits} = nonunit
val clauses' = IntMap.filter (pred o #3 o snd) clauses
in
if IntMap.size clauses = IntMap.size clauses' then nonunit
else
let
fun predId (id,_) = IntMap.inDomain id clauses'
val fstLits = LiteralNet.filter predId fstLits
and sndLits = LiteralNet.filter predId sndLits
in
{nextId = nextId, clauses = clauses',
fstLits = fstLits, sndLits = sndLits}
end
end
in
Subsume {empty = empty, unit = unit, nonunit = nonunit}
end;
fun toString subsume = "Subsume{" ^ Int.toString (size subsume) ^ "}";
fun pp p = Parser.ppMap toString Parser.ppString p;
(* ------------------------------------------------------------------------- *)
(* Subsumption checking. *)
(* ------------------------------------------------------------------------- *)
local
fun matchLit lit' (lit,acc) =
case total (Literal.match Subst.empty lit') lit of
SOME sub => sub :: acc
| NONE => acc;
in
fun genClauseSubsumes pred cl' lits' cl a =
let
fun mkSubsl acc sub [] = SOME (sub, sortMap length Int.compare acc)
| mkSubsl acc sub (lit' :: lits') =
case List.foldl (matchLit lit') [] cl of
[] => NONE
| [sub'] =>
(case total (Subst.union sub) sub' of
NONE => NONE
| SOME sub => mkSubsl acc sub lits')
| subs => mkSubsl (subs :: acc) sub lits'
fun search [] = NONE
| search ((sub,[]) :: others) =
let
val x = (cl',sub,a)
in
if pred x then SOME x else search others
end
| search ((_, [] :: _) :: others) = search others
| search ((sub, (sub' :: subs) :: subsl) :: others) =
let
val others = (sub, subs :: subsl) :: others
in
case total (Subst.union sub) sub' of
NONE => search others
| SOME sub => search ((sub,subsl) :: others)
end
in
case mkSubsl [] Subst.empty lits' of
NONE => NONE
| SOME sub_subsl => search [sub_subsl]
end;
end;
local
fun emptySubsumes pred empty = List.find pred empty;
fun unitSubsumes pred unit =
let
fun subLit lit =
let
fun subUnit (lit',cl',a) =
case total (Literal.match Subst.empty lit') lit of
NONE => NONE
| SOME sub =>
let
val x = (cl',sub,a)
in
if pred x then SOME x else NONE
end
in
first subUnit (LiteralNet.match unit lit)
end
in
first subLit
end;
fun nonunitSubsumes pred nonunit max cl =
let
val addId = case max of NONE => idSetAdd | SOME n => idSetAddMax n
fun subLit lits (lit,acc) =
List.foldl addId acc (LiteralNet.match lits lit)
val {nextId = _, clauses, fstLits, sndLits} = nonunit
fun subCl' (id,_) =
let
val (lits',cl',a) = IntMap.get clauses id
in
genClauseSubsumes pred cl' lits' cl a
end
val fstCands = List.foldl (subLit fstLits) idSetEmpty cl
val sndCands = List.foldl (subLit sndLits) idSetEmpty cl
val cands = idSetIntersect fstCands sndCands
in
Set.firstl subCl' cands
end;
fun genSubsumes pred (Subsume {empty,unit,nonunit}) max cl =
case emptySubsumes pred empty of
s as SOME _ => s
| NONE =>
if max = SOME 0 then NONE
else
let
val cl = clauseSym (LiteralSet.toList cl)
in
case unitSubsumes pred unit cl of
s as SOME _ => s
| NONE =>
if max = SOME 1 then NONE
else nonunitSubsumes pred nonunit max cl
end;
in
fun subsumes pred subsume cl = genSubsumes pred subsume NONE cl;
fun strictlySubsumes pred subsume cl =
genSubsumes pred subsume (SOME (LiteralSet.size cl)) cl;
end;
(*TRACE4
val subsumes = fn pred => fn subsume => fn cl =>
let
val ppCl = LiteralSet.pp
val ppSub = Subst.pp
val () = Parser.ppTrace ppCl "Subsume.subsumes: cl" cl
val result = subsumes pred subsume cl
val () =
case result of
NONE => trace "Subsume.subsumes: not subsumed\n"
| SOME (cl,sub,_) =>
(Parser.ppTrace ppCl "Subsume.subsumes: subsuming cl" cl;
Parser.ppTrace ppSub "Subsume.subsumes: subsuming sub" sub)
in
result
end;
val strictlySubsumes = fn pred => fn subsume => fn cl =>
let
val ppCl = LiteralSet.pp
val ppSub = Subst.pp
val () = Parser.ppTrace ppCl "Subsume.strictlySubsumes: cl" cl
val result = strictlySubsumes pred subsume cl
val () =
case result of
NONE => trace "Subsume.subsumes: not subsumed\n"
| SOME (cl,sub,_) =>
(Parser.ppTrace ppCl "Subsume.subsumes: subsuming cl" cl;
Parser.ppTrace ppSub "Subsume.subsumes: subsuming sub" sub)
in
result
end;
*)
fun isSubsumed subs cl = Option.isSome (subsumes (K true) subs cl);
fun isStrictlySubsumed subs cl =
Option.isSome (strictlySubsumes (K true) subs cl);
(* ------------------------------------------------------------------------- *)
(* Single clause versions. *)
(* ------------------------------------------------------------------------- *)
fun clauseSubsumes cl' cl =
let
val lits' = sortClause cl'
and lits = clauseSym (LiteralSet.toList cl)
in
case genClauseSubsumes (K true) cl' lits' lits () of
SOME (_,sub,()) => SOME sub
| NONE => NONE
end;
fun clauseStrictlySubsumes cl' cl =
if LiteralSet.size cl' > LiteralSet.size cl then NONE
else clauseSubsumes cl' cl;
end
end;
(**** Original file: KnuthBendixOrder.sig ****)
(* ========================================================================= *)
(* THE KNUTH-BENDIX TERM ORDERING *)
(* Copyright (c) 2002-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature KnuthBendixOrder =
sig
(* ------------------------------------------------------------------------- *)
(* The weight of all constants must be at least 1, and there must be at most *)
(* one unary function with weight 0. *)
(* ------------------------------------------------------------------------- *)
type kbo =
{weight : Metis.Term.function -> int,
precedence : Metis.Term.function * Metis.Term.function -> order}
val default : kbo
val compare : kbo -> Metis.Term.term * Metis.Term.term -> order option
end
(**** Original file: KnuthBendixOrder.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* KNUTH-BENDIX TERM ORDERING CONSTRAINTS *)
(* Copyright (c) 2002-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure KnuthBendixOrder :> KnuthBendixOrder =
struct
open Useful;
(* ------------------------------------------------------------------------- *)
(* Helper functions. *)
(* ------------------------------------------------------------------------- *)
fun firstNotEqual f l =
case List.find op<> l of
SOME (x,y) => f x y
| NONE => raise Bug "firstNotEqual";
(* ------------------------------------------------------------------------- *)
(* The weight of all constants must be at least 1, and there must be at most *)
(* one unary function with weight 0. *)
(* ------------------------------------------------------------------------- *)
type kbo =
{weight : Term.function -> int,
precedence : Term.function * Term.function -> order};
(* Default weight = uniform *)
val uniformWeight : Term.function -> int = K 1;
(* Default precedence = by arity *)
val arityPrecedence : Term.function * Term.function -> order =
fn ((f1,n1),(f2,n2)) =>
case Int.compare (n1,n2) of
LESS => LESS
| EQUAL => String.compare (f1,f2)
| GREATER => GREATER;
(* The default order *)
val default = {weight = uniformWeight, precedence = arityPrecedence};
(* ------------------------------------------------------------------------- *)
(* Term weight-1 represented as a linear function of the weight-1 of the *)
(* variables in the term (plus a constant). *)
(* *)
(* Note that the conditions on weight functions ensure that all weights are *)
(* at least 1, so all weight-1s are at least 0. *)
(* ------------------------------------------------------------------------- *)
datatype weight = Weight of int NameMap.map * int;
val weightEmpty : int NameMap.map = NameMap.new ();
val weightZero = Weight (weightEmpty,0);
fun weightIsZero (Weight (m,c)) = c = 0 andalso NameMap.null m;
fun weightNeg (Weight (m,c)) = Weight (NameMap.transform ~ m, ~c);
local
fun add (n1,n2) =
let
val n = n1 + n2
in
if n = 0 then NONE else SOME n
end;
in
fun weightAdd (Weight (m1,c1)) (Weight (m2,c2)) =
Weight (NameMap.union add m1 m2, c1 + c2);
end;
fun weightSubtract w1 w2 = weightAdd w1 (weightNeg w2);
fun weightMult 0 _ = weightZero
| weightMult 1 w = w
| weightMult k (Weight (m,c)) =
let
fun mult n = k * n
in
Weight (NameMap.transform mult m, k * c)
end;
fun weightTerm weight =
let
fun wt m c [] = Weight (m,c)
| wt m c (Term.Var v :: tms) =
let
val n = Option.getOpt (NameMap.peek m v, 0)
in
wt (NameMap.insert m (v, n + 1)) (c + 1) tms
end
| wt m c (Term.Fn (f,a) :: tms) =
wt m (c + weight (f, length a)) (a @ tms)
in
fn tm => wt weightEmpty ~1 [tm]
end;
fun weightIsVar v (Weight (m,c)) =
c = 0 andalso NameMap.size m = 1 andalso NameMap.peek m v = SOME 1;
fun weightConst (Weight (_,c)) = c;
fun weightVars (Weight (m,_)) =
NameMap.foldl (fn (v,_,s) => NameSet.add s v) NameSet.empty m;
val weightsVars =
List.foldl (fn (w,s) => NameSet.union (weightVars w) s) NameSet.empty;
fun weightVarList w = NameSet.toList (weightVars w);
fun weightNumVars (Weight (m,_)) = NameMap.size m;
fun weightNumVarsWithPositiveCoeff (Weight (m,_)) =
NameMap.foldl (fn (_,n,z) => if n > 0 then z + 1 else z) 0 m;
fun weightCoeff var (Weight (m,_)) = Option.getOpt (NameMap.peek m var, 0);
fun weightCoeffs varList w = map (fn var => weightCoeff var w) varList;
fun weightCoeffSum (Weight (m,_)) = NameMap.foldl (fn (_,n,z) => n + z) 0 m;
fun weightLowerBound (w as Weight (m,c)) =
if NameMap.exists (fn (_,n) => n < 0) m then NONE else SOME c;
fun weightNoLowerBound w = not (Option.isSome (weightLowerBound w));
fun weightAlwaysPositive w =
case weightLowerBound w of NONE => false | SOME n => n > 0;
fun weightUpperBound (w as Weight (m,c)) =
if NameMap.exists (fn (_,n) => n > 0) m then NONE else SOME c;
fun weightNoUpperBound w = not (Option.isSome (weightUpperBound w));
fun weightAlwaysNegative w =
case weightUpperBound w of NONE => false | SOME n => n < 0;
fun weightGcd (w as Weight (m,c)) =
NameMap.foldl (fn (_,i,k) => gcd i k) (Int.abs c) m;
fun ppWeightList pp =
let
fun coeffToString n =
if n < 0 then "~" ^ coeffToString (~n)
else if n = 1 then ""
else Int.toString n
fun pp_tm pp ("",n) = Parser.ppInt pp n
| pp_tm pp (v,n) = Parser.ppString pp (coeffToString n ^ v)
in
fn [] => Parser.ppInt pp 0
| tms => Parser.ppSequence " +" pp_tm pp tms
end;
fun ppWeight pp (Weight (m,c)) =
let
val l = NameMap.toList m
val l = if c = 0 then l else l @ [("",c)]
in
ppWeightList pp l
end;
val weightToString = Parser.toString ppWeight;
(* ------------------------------------------------------------------------- *)
(* The Knuth-Bendix term order. *)
(* ------------------------------------------------------------------------- *)
datatype kboOrder = Less | Equal | Greater | SignOf of weight;
fun kboOrder {weight,precedence} =
let
fun weightDifference tm1 tm2 =
let
val w1 = weightTerm weight tm1
and w2 = weightTerm weight tm2
in
weightSubtract w2 w1
end
fun weightLess tm1 tm2 =
let
val w = weightDifference tm1 tm2
in
if weightIsZero w then precedenceLess tm1 tm2
else weightDiffLess w tm1 tm2
end
and weightDiffLess w tm1 tm2 =
case weightLowerBound w of
NONE => false
| SOME 0 => precedenceLess tm1 tm2
| SOME n => n > 0
and precedenceLess (Term.Fn (f1,a1)) (Term.Fn (f2,a2)) =
(case precedence ((f1, length a1), (f2, length a2)) of
LESS => true
| EQUAL => firstNotEqual weightLess (zip a1 a2)
| GREATER => false)
| precedenceLess _ _ = false
fun weightDiffGreater w tm1 tm2 = weightDiffLess (weightNeg w) tm2 tm1
fun weightCmp tm1 tm2 =
let
val w = weightDifference tm1 tm2
in
if weightIsZero w then precedenceCmp tm1 tm2
else if weightDiffLess w tm1 tm2 then Less
else if weightDiffGreater w tm1 tm2 then Greater
else SignOf w
end
and precedenceCmp (Term.Fn (f1,a1)) (Term.Fn (f2,a2)) =
(case precedence ((f1, length a1), (f2, length a2)) of
LESS => Less
| EQUAL => firstNotEqual weightCmp (zip a1 a2)
| GREATER => Greater)
| precedenceCmp _ _ = raise Bug "kboOrder.precendenceCmp"
in
fn (tm1,tm2) => if tm1 = tm2 then Equal else weightCmp tm1 tm2
end;
fun compare kbo tm1_tm2 =
case kboOrder kbo tm1_tm2 of
Less => SOME LESS
| Equal => SOME EQUAL
| Greater => SOME GREATER
| SignOf _ => NONE;
(*TRACE7
val compare = fn kbo => fn (tm1,tm2) =>
let
val () = Parser.ppTrace Term.pp "KnuthBendixOrder.compare: tm1" tm1
val () = Parser.ppTrace Term.pp "KnuthBendixOrder.compare: tm2" tm2
val result = compare kbo (tm1,tm2)
val () =
case result of
NONE => trace "KnuthBendixOrder.compare: result = Incomparable\n"
| SOME x =>
Parser.ppTrace Parser.ppOrder "KnuthBendixOrder.compare: result" x
in
result
end;
*)
end
end;
(**** Original file: Rewrite.sig ****)
(* ========================================================================= *)
(* ORDERED REWRITING FOR FIRST ORDER TERMS *)
(* Copyright (c) 2003-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Rewrite =
sig
(* ------------------------------------------------------------------------- *)
(* A type of rewrite systems. *)
(* ------------------------------------------------------------------------- *)
datatype orient = LeftToRight | RightToLeft
type reductionOrder = Metis.Term.term * Metis.Term.term -> order option
type equationId = int
type equation = Metis.Rule.equation
type rewrite
(* ------------------------------------------------------------------------- *)
(* Basic operations. *)
(* ------------------------------------------------------------------------- *)
val new : reductionOrder -> rewrite
val peek : rewrite -> equationId -> (equation * orient option) option
val size : rewrite -> int
val equations : rewrite -> equation list
val toString : rewrite -> string
val pp : rewrite Metis.Parser.pp
(* ------------------------------------------------------------------------- *)
(* Add equations into the system. *)
(* ------------------------------------------------------------------------- *)
val add : rewrite -> equationId * equation -> rewrite
val addList : rewrite -> (equationId * equation) list -> rewrite
(* ------------------------------------------------------------------------- *)
(* Rewriting (the order must be a refinement of the rewrite order). *)
(* ------------------------------------------------------------------------- *)
val rewrConv : rewrite -> reductionOrder -> Metis.Rule.conv
val rewriteConv : rewrite -> reductionOrder -> Metis.Rule.conv
val rewriteLiteralsRule :
rewrite -> reductionOrder -> Metis.LiteralSet.set -> Metis.Rule.rule
val rewriteRule : rewrite -> reductionOrder -> Metis.Rule.rule
val rewrIdConv : rewrite -> reductionOrder -> equationId -> Metis.Rule.conv
val rewriteIdConv : rewrite -> reductionOrder -> equationId -> Metis.Rule.conv
val rewriteIdLiteralsRule :
rewrite -> reductionOrder -> equationId -> Metis.LiteralSet.set -> Metis.Rule.rule
val rewriteIdRule : rewrite -> reductionOrder -> equationId -> Metis.Rule.rule
(* ------------------------------------------------------------------------- *)
(* Inter-reduce the equations in the system. *)
(* ------------------------------------------------------------------------- *)
val reduce' : rewrite -> rewrite * equationId list
val reduce : rewrite -> rewrite
val isReduced : rewrite -> bool
(* ------------------------------------------------------------------------- *)
(* Rewriting as a derived rule. *)
(* ------------------------------------------------------------------------- *)
val rewrite : equation list -> Metis.Thm.thm -> Metis.Thm.thm
val orderedRewrite : reductionOrder -> equation list -> Metis.Thm.thm -> Metis.Thm.thm
end
(**** Original file: Rewrite.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* ORDERED REWRITING FOR FIRST ORDER TERMS *)
(* Copyright (c) 2003-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Rewrite :> Rewrite =
struct
open Useful;
(* ------------------------------------------------------------------------- *)
(* A type of rewrite systems. *)
(* ------------------------------------------------------------------------- *)
datatype orient = LeftToRight | RightToLeft;
type reductionOrder = Term.term * Term.term -> order option;
type equationId = int;
type equation = Rule.equation;
datatype rewrite =
Rewrite of
{order : reductionOrder,
known : (equation * orient option) IntMap.map,
redexes : (equationId * orient) TermNet.termNet,
subterms : (equationId * bool * Term.path) TermNet.termNet,
waiting : IntSet.set};
fun updateWaiting rw waiting =
let
val Rewrite {order, known, redexes, subterms, waiting = _} = rw
in
Rewrite
{order = order, known = known, redexes = redexes,
subterms = subterms, waiting = waiting}
end;
fun deleteWaiting (rw as Rewrite {waiting,...}) id =
updateWaiting rw (IntSet.delete waiting id);
(* ------------------------------------------------------------------------- *)
(* Basic operations *)
(* ------------------------------------------------------------------------- *)
fun new order =
Rewrite
{order = order,
known = IntMap.new (),
redexes = TermNet.new {fifo = false},
subterms = TermNet.new {fifo = false},
waiting = IntSet.empty};
fun peek (Rewrite {known,...}) id = IntMap.peek known id;
fun size (Rewrite {known,...}) = IntMap.size known;
fun equations (Rewrite {known,...}) =
IntMap.foldr (fn (_,(eqn,_),eqns) => eqn :: eqns) [] known;
val pp = Parser.ppMap equations (Parser.ppList Rule.ppEquation);
(*DEBUG
local
fun orientOptionToString ort =
case ort of
SOME LeftToRight => "-->"
| SOME RightToLeft => "<--"
| NONE => "<->";
open Parser;
fun ppEq p ((x_y,_),ort) =
ppBinop (" " ^ orientOptionToString ort) Term.pp Term.pp p x_y;
fun ppField f ppA p a =
(beginBlock p Inconsistent 2;
addString p (f ^ " =");
addBreak p (1,0);
ppA p a;
endBlock p);
val ppKnown =
ppField "known" (ppMap IntMap.toList (ppList (ppPair ppInt ppEq)));
val ppRedexes =
ppField
"redexes"
(TermNet.pp
(ppPair ppInt (ppMap (orientOptionToString o SOME) ppString)));
val ppSubterms =
ppField
"subterms"
(TermNet.pp
(ppMap
(fn (i,l,p) => (i, (if l then 0 else 1) :: p))
(ppPair ppInt Term.ppPath)));
val ppWaiting = ppField "waiting" (ppMap (IntSet.toList) (ppList ppInt));
in
fun pp p (Rewrite {known,redexes,subterms,waiting,...}) =
(beginBlock p Inconsistent 2;
addString p "Rewrite";
addBreak p (1,0);
beginBlock p Inconsistent 1;
addString p "{";
ppKnown p known;
(*TRACE5
addString p ",";
addBreak p (1,0);
ppRedexes p redexes;
addString p ",";
addBreak p (1,0);
ppSubterms p subterms;
addString p ",";
addBreak p (1,0);
ppWaiting p waiting;
*)
endBlock p;
addString p "}";
endBlock p);
end;
*)
val toString = Parser.toString pp;
(* ------------------------------------------------------------------------- *)
(* Debug functions. *)
(* ------------------------------------------------------------------------- *)
fun termReducible order known id =
let
fun eqnRed ((l,r),_) tm =
case total (Subst.match Subst.empty l) tm of
NONE => false
| SOME sub =>
order (tm, Subst.subst (Subst.normalize sub) r) = SOME GREATER
fun knownRed tm (eqnId,(eqn,ort)) =
eqnId <> id andalso
((ort <> SOME RightToLeft andalso eqnRed eqn tm) orelse
(ort <> SOME LeftToRight andalso eqnRed (Rule.symEqn eqn) tm))
fun termRed tm = IntMap.exists (knownRed tm) known orelse subtermRed tm
and subtermRed (Term.Var _) = false
| subtermRed (Term.Fn (_,tms)) = List.exists termRed tms
in
termRed
end;
fun literalReducible order known id lit =
List.exists (termReducible order known id) (Literal.arguments lit);
fun literalsReducible order known id lits =
LiteralSet.exists (literalReducible order known id) lits;
fun thmReducible order known id th =
literalsReducible order known id (Thm.clause th);
(* ------------------------------------------------------------------------- *)
(* Add equations into the system. *)
(* ------------------------------------------------------------------------- *)
fun orderToOrient (SOME EQUAL) = raise Error "Rewrite.orient: reflexive"
| orderToOrient (SOME GREATER) = SOME LeftToRight
| orderToOrient (SOME LESS) = SOME RightToLeft
| orderToOrient NONE = NONE;
local
fun ins redexes redex id ort = TermNet.insert redexes (redex,(id,ort));
in
fun addRedexes id (((l,r),_),ort) redexes =
case ort of
SOME LeftToRight => ins redexes l id LeftToRight
| SOME RightToLeft => ins redexes r id RightToLeft
| NONE => ins (ins redexes l id LeftToRight) r id RightToLeft;
end;
fun add (rw as Rewrite {known,...}) (id,eqn) =
if IntMap.inDomain id known then rw
else
let
val Rewrite {order,redexes,subterms,waiting, ...} = rw
val ort = orderToOrient (order (fst eqn))
val known = IntMap.insert known (id,(eqn,ort))
val redexes = addRedexes id (eqn,ort) redexes
val waiting = IntSet.add waiting id
val rw =
Rewrite
{order = order, known = known, redexes = redexes,
subterms = subterms, waiting = waiting}
(*TRACE5
val () = Parser.ppTrace pp "Rewrite.add: result" rw
*)
in
rw
end;
val addList = foldl (fn (eqn,rw) => add rw eqn);
(* ------------------------------------------------------------------------- *)
(* Rewriting (the order must be a refinement of the rewrite order). *)
(* ------------------------------------------------------------------------- *)
local
fun reorder ((i,_),(j,_)) = Int.compare (j,i);
in
fun matchingRedexes redexes tm = sort reorder (TermNet.match redexes tm);
end;
fun wellOriented NONE _ = true
| wellOriented (SOME LeftToRight) LeftToRight = true
| wellOriented (SOME RightToLeft) RightToLeft = true
| wellOriented _ _ = false;
fun redexResidue LeftToRight ((l_r,_) : equation) = l_r
| redexResidue RightToLeft ((l,r),_) = (r,l);
fun orientedEquation LeftToRight eqn = eqn
| orientedEquation RightToLeft eqn = Rule.symEqn eqn;
fun rewrIdConv' order known redexes id tm =
let
fun rewr (id',lr) =
let
val _ = id <> id' orelse raise Error "same theorem"
val (eqn,ort) = IntMap.get known id'
val _ = wellOriented ort lr orelse raise Error "orientation"
val (l,r) = redexResidue lr eqn
val sub = Subst.normalize (Subst.match Subst.empty l tm)
val tm' = Subst.subst sub r
val _ = Option.isSome ort orelse
order (tm,tm') = SOME GREATER orelse
raise Error "order"
val (_,th) = orientedEquation lr eqn
in
(tm', Thm.subst sub th)
end
in
case first (total rewr) (matchingRedexes redexes tm) of
NONE => raise Error "Rewrite.rewrIdConv: no matching rewrites"
| SOME res => res
end;
fun rewriteIdConv' order known redexes id =
if IntMap.null known then Rule.allConv
else Rule.repeatTopDownConv (rewrIdConv' order known redexes id);
fun mkNeqConv order lit =
let
val (l,r) = Literal.destNeq lit
in
case order (l,r) of
NONE => raise Error "incomparable"
| SOME LESS =>
let
val sub = Subst.fromList [("x",l),("y",r)]
val th = Thm.subst sub Rule.symmetry
in
fn tm => if tm = r then (l,th) else raise Error "mkNeqConv: RL"
end
| SOME EQUAL => raise Error "irreflexive"
| SOME GREATER =>
let
val th = Thm.assume lit
in
fn tm => if tm = l then (r,th) else raise Error "mkNeqConv: LR"
end
end;
datatype neqConvs = NeqConvs of Rule.conv LiteralMap.map;
val neqConvsEmpty = NeqConvs (LiteralMap.new ());
fun neqConvsNull (NeqConvs m) = LiteralMap.null m;
fun neqConvsAdd order (neq as NeqConvs m) lit =
case total (mkNeqConv order) lit of
NONE => NONE
| SOME conv => SOME (NeqConvs (LiteralMap.insert m (lit,conv)));
fun mkNeqConvs order =
let
fun add (lit,(neq,lits)) =
case neqConvsAdd order neq lit of
SOME neq => (neq,lits)
| NONE => (neq, LiteralSet.add lits lit)
in
LiteralSet.foldl add (neqConvsEmpty,LiteralSet.empty)
end;
fun neqConvsDelete (NeqConvs m) lit = NeqConvs (LiteralMap.delete m lit);
fun neqConvsToConv (NeqConvs m) =
Rule.firstConv (LiteralMap.foldr (fn (_,c,l) => c :: l) [] m);
fun neqConvsFoldl f b (NeqConvs m) =
LiteralMap.foldl (fn (l,_,z) => f (l,z)) b m;
fun neqConvsRewrIdLiterule order known redexes id neq =
if IntMap.null known andalso neqConvsNull neq then Rule.allLiterule
else
let
val neq_conv = neqConvsToConv neq
val rewr_conv = rewrIdConv' order known redexes id
val conv = Rule.orelseConv neq_conv rewr_conv
val conv = Rule.repeatTopDownConv conv
in
Rule.allArgumentsLiterule conv
end;
fun rewriteIdEqn' order known redexes id (eqn as (l_r,th)) =
let
val (neq,_) = mkNeqConvs order (Thm.clause th)
val literule = neqConvsRewrIdLiterule order known redexes id neq
val (strongEqn,lit) =
case Rule.equationLiteral eqn of
NONE => (true, Literal.mkEq l_r)
| SOME lit => (false,lit)
val (lit',litTh) = literule lit
in
if lit = lit' then eqn
else
(Literal.destEq lit',
if strongEqn then th
else if not (Thm.negateMember lit litTh) then litTh
else Thm.resolve lit th litTh)
end
(*DEBUG
handle Error err => raise Error ("Rewrite.rewriteIdEqn':\n" ^ err);
*)
fun rewriteIdLiteralsRule' order known redexes id lits th =
let
val mk_literule = neqConvsRewrIdLiterule order known redexes id
fun rewr_neq_lit (lit, acc as (changed,neq,lits,th)) =
let
val neq = neqConvsDelete neq lit
val (lit',litTh) = mk_literule neq lit
in
if lit = lit' then acc
else
let
val th = Thm.resolve lit th litTh
in
case neqConvsAdd order neq lit' of
SOME neq => (true,neq,lits,th)
| NONE => (changed, neq, LiteralSet.add lits lit', th)
end
end
fun rewr_neq_lits neq lits th =
let
val (changed,neq,lits,th) =
neqConvsFoldl rewr_neq_lit (false,neq,lits,th) neq
in
if changed then rewr_neq_lits neq lits th
else (neq,lits,th)
end
val (neq,lits) = mkNeqConvs order lits
val (neq,lits,th) = rewr_neq_lits neq lits th
val rewr_literule = mk_literule neq
fun rewr_lit (lit,th) =
if Thm.member lit th then Rule.literalRule rewr_literule lit th
else th
in
LiteralSet.foldl rewr_lit th lits
end;
fun rewriteIdRule' order known redexes id th =
rewriteIdLiteralsRule' order known redexes id (Thm.clause th) th;
(*DEBUG
val rewriteIdRule' = fn order => fn known => fn redexes => fn id => fn th =>
let
(*TRACE6
val () = Parser.ppTrace Thm.pp "Rewrite.rewriteIdRule': th" th
*)
val result = rewriteIdRule' order known redexes id th
(*TRACE6
val () = Parser.ppTrace Thm.pp "Rewrite.rewriteIdRule': result" result
*)
val _ = not (thmReducible order known id result) orelse
raise Bug "rewriteIdRule: should be normalized"
in
result
end
handle Error err => raise Error ("Rewrite.rewriteIdRule:\n" ^ err);
*)
fun rewrIdConv (Rewrite {known,redexes,...}) order =
rewrIdConv' order known redexes;
fun rewrConv rewrite order = rewrIdConv rewrite order ~1;
fun rewriteIdConv (Rewrite {known,redexes,...}) order =
rewriteIdConv' order known redexes;
fun rewriteConv rewrite order = rewriteIdConv rewrite order ~1;
fun rewriteIdLiteralsRule (Rewrite {known,redexes,...}) order =
rewriteIdLiteralsRule' order known redexes;
fun rewriteLiteralsRule rewrite order =
rewriteIdLiteralsRule rewrite order ~1;
fun rewriteIdRule (Rewrite {known,redexes,...}) order =
rewriteIdRule' order known redexes;
fun rewriteRule rewrite order = rewriteIdRule rewrite order ~1;
(* ------------------------------------------------------------------------- *)
(* Inter-reduce the equations in the system. *)
(* ------------------------------------------------------------------------- *)
fun addSubterms id (((l,r),_) : equation) subterms =
let
fun addSubterm b ((path,tm),net) = TermNet.insert net (tm,(id,b,path))
val subterms = foldl (addSubterm true) subterms (Term.subterms l)
val subterms = foldl (addSubterm false) subterms (Term.subterms r)
in
subterms
end;
fun sameRedexes NONE _ _ = false
| sameRedexes (SOME LeftToRight) (l0,_) (l,_) = l0 = l
| sameRedexes (SOME RightToLeft) (_,r0) (_,r) = r0 = r;
fun redexResidues NONE (l,r) = [(l,r,false),(r,l,false)]
| redexResidues (SOME LeftToRight) (l,r) = [(l,r,true)]
| redexResidues (SOME RightToLeft) (l,r) = [(r,l,true)];
fun findReducibles order known subterms id =
let
fun checkValidRewr (l,r,ord) id' left path =
let
val (((x,y),_),_) = IntMap.get known id'
val tm = Term.subterm (if left then x else y) path
val sub = Subst.match Subst.empty l tm
in
if ord then ()
else
let
val tm' = Subst.subst (Subst.normalize sub) r
in
if order (tm,tm') = SOME GREATER then ()
else raise Error "order"
end
end
fun addRed lr ((id',left,path),todo) =
if id <> id' andalso not (IntSet.member id' todo) andalso
can (checkValidRewr lr id' left) path
then IntSet.add todo id'
else todo
fun findRed (lr as (l,_,_), todo) =
List.foldl (addRed lr) todo (TermNet.matched subterms l)
in
List.foldl findRed
end;
fun reduce1 new id (eqn0,ort0) (rpl,spl,todo,rw,changed) =
let
val (eq0,_) = eqn0
val Rewrite {order,known,redexes,subterms,waiting} = rw
val eqn as (eq,_) = rewriteIdEqn' order known redexes id eqn0
val identical = eq = eq0
val same_redexes = identical orelse sameRedexes ort0 eq0 eq
val rpl = if same_redexes then rpl else IntSet.add rpl id
val spl = if new orelse identical then spl else IntSet.add spl id
val changed =
if not new andalso identical then changed else IntSet.add changed id
val ort =
if same_redexes then SOME ort0 else total orderToOrient (order eq)
in
case ort of
NONE =>
let
val known = IntMap.delete known id
val rw =
Rewrite
{order = order, known = known, redexes = redexes,
subterms = subterms, waiting = waiting}
in
(rpl,spl,todo,rw,changed)
end
| SOME ort =>
let
val todo =
if not new andalso same_redexes then todo
else
findReducibles
order known subterms id todo (redexResidues ort eq)
val known =
if identical then known else IntMap.insert known (id,(eqn,ort))
val redexes =
if same_redexes then redexes
else addRedexes id (eqn,ort) redexes
val subterms =
if new orelse not identical then addSubterms id eqn subterms
else subterms
val rw =
Rewrite
{order = order, known = known, redexes = redexes,
subterms = subterms, waiting = waiting}
in
(rpl,spl,todo,rw,changed)
end
end;
fun pick known set =
let
fun oriented id =
case IntMap.peek known id of
SOME (x as (_, SOME _)) => SOME (id,x)
| _ => NONE
fun any id =
case IntMap.peek known id of SOME x => SOME (id,x) | _ => NONE
in
case IntSet.firstl oriented set of
x as SOME _ => x
| NONE => IntSet.firstl any set
end;
local
fun cleanRedexes known redexes rpl =
if IntSet.null rpl then redexes
else
let
fun filt (id,_) = not (IntSet.member id rpl)
fun addReds (id,reds) =
case IntMap.peek known id of
NONE => reds
| SOME eqn_ort => addRedexes id eqn_ort reds
val redexes = TermNet.filter filt redexes
val redexes = IntSet.foldl addReds redexes rpl
in
redexes
end;
fun cleanSubterms known subterms spl =
if IntSet.null spl then subterms
else
let
fun filt (id,_,_) = not (IntSet.member id spl)
fun addSubtms (id,subtms) =
case IntMap.peek known id of
NONE => subtms
| SOME (eqn,_) => addSubterms id eqn subtms
val subterms = TermNet.filter filt subterms
val subterms = IntSet.foldl addSubtms subterms spl
in
subterms
end;
in
fun rebuild rpl spl rw =
let
(*TRACE5
val ppPl = Parser.ppMap IntSet.toList (Parser.ppList Parser.ppInt)
val () = Parser.ppTrace ppPl "Rewrite.rebuild: rpl" rpl
val () = Parser.ppTrace ppPl "Rewrite.rebuild: spl" spl
*)
val Rewrite {order,known,redexes,subterms,waiting} = rw
val redexes = cleanRedexes known redexes rpl
val subterms = cleanSubterms known subterms spl
in
Rewrite
{order = order, known = known, redexes = redexes,
subterms = subterms, waiting = waiting}
end;
end;
fun reduceAcc (rpl, spl, todo, rw as Rewrite {known,waiting,...}, changed) =
case pick known todo of
SOME (id,eqn_ort) =>
let
val todo = IntSet.delete todo id
in
reduceAcc (reduce1 false id eqn_ort (rpl,spl,todo,rw,changed))
end
| NONE =>
case pick known waiting of
SOME (id,eqn_ort) =>
let
val rw = deleteWaiting rw id
in
reduceAcc (reduce1 true id eqn_ort (rpl,spl,todo,rw,changed))
end
| NONE => (rebuild rpl spl rw, IntSet.toList changed);
fun isReduced (Rewrite {waiting,...}) = IntSet.null waiting;
fun reduce' rw =
if isReduced rw then (rw,[])
else reduceAcc (IntSet.empty,IntSet.empty,IntSet.empty,rw,IntSet.empty);
(*DEBUG
val reduce' = fn rw =>
let
(*TRACE4
val () = Parser.ppTrace pp "Rewrite.reduce': rw" rw
*)
val Rewrite {known,order,...} = rw
val result as (Rewrite {known = known', ...}, _) = reduce' rw
(*TRACE4
val ppResult = Parser.ppPair pp (Parser.ppList Parser.ppInt)
val () = Parser.ppTrace ppResult "Rewrite.reduce': result" result
*)
val ths = map (fn (id,((_,th),_)) => (id,th)) (IntMap.toList known')
val _ =
not (List.exists (uncurry (thmReducible order known')) ths) orelse
raise Bug "Rewrite.reduce': not fully reduced"
in
result
end
handle Error err => raise Bug ("Rewrite.reduce': shouldn't fail\n" ^ err);
*)
fun reduce rw = fst (reduce' rw);
(* ------------------------------------------------------------------------- *)
(* Rewriting as a derived rule. *)
(* ------------------------------------------------------------------------- *)
local
fun addEqn (id_eqn,rw) = add rw id_eqn;
in
fun orderedRewrite order ths =
let
val rw = foldl addEqn (new order) (enumerate ths)
in
rewriteRule rw order
end;
end;
val rewrite = orderedRewrite (K (SOME GREATER));
end
end;
(**** Original file: Units.sig ****)
(* ========================================================================= *)
(* A STORE FOR UNIT THEOREMS *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Units =
sig
(* ------------------------------------------------------------------------- *)
(* A type of unit store. *)
(* ------------------------------------------------------------------------- *)
type unitThm = Metis.Literal.literal * Metis.Thm.thm
type units
(* ------------------------------------------------------------------------- *)
(* Basic operations. *)
(* ------------------------------------------------------------------------- *)
val empty : units
val size : units -> int
val toString : units -> string
val pp : units Metis.Parser.pp
(* ------------------------------------------------------------------------- *)
(* Add units into the store. *)
(* ------------------------------------------------------------------------- *)
val add : units -> unitThm -> units
val addList : units -> unitThm list -> units
(* ------------------------------------------------------------------------- *)
(* Matching. *)
(* ------------------------------------------------------------------------- *)
val match : units -> Metis.Literal.literal -> (unitThm * Metis.Subst.subst) option
(* ------------------------------------------------------------------------- *)
(* Reducing by repeated matching and resolution. *)
(* ------------------------------------------------------------------------- *)
val reduce : units -> Metis.Rule.rule
end
(**** Original file: Units.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* A STORE FOR UNIT THEOREMS *)
(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Units :> Units =
struct
open Useful;
(* ------------------------------------------------------------------------- *)
(* A type of unit store. *)
(* ------------------------------------------------------------------------- *)
type unitThm = Literal.literal * Thm.thm;
datatype units = Units of unitThm LiteralNet.literalNet;
(* ------------------------------------------------------------------------- *)
(* Basic operations. *)
(* ------------------------------------------------------------------------- *)
val empty = Units (LiteralNet.new {fifo = false});
fun size (Units net) = LiteralNet.size net;
fun toString units = "U{" ^ Int.toString (size units) ^ "}";
val pp = Parser.ppMap toString Parser.ppString;
(* ------------------------------------------------------------------------- *)
(* Add units into the store. *)
(* ------------------------------------------------------------------------- *)
fun add (units as Units net) (uTh as (lit,th)) =
let
val net = LiteralNet.insert net (lit,uTh)
in
case total Literal.sym lit of
NONE => Units net
| SOME (lit' as (pol,_)) =>
let
val th' = (if pol then Rule.symEq else Rule.symNeq) lit th
val net = LiteralNet.insert net (lit',(lit',th'))
in
Units net
end
end;
val addList = foldl (fn (th,u) => add u th);
(* ------------------------------------------------------------------------- *)
(* Matching. *)
(* ------------------------------------------------------------------------- *)
fun match (Units net) lit =
let
fun check (uTh as (lit',_)) =
case total (Literal.match Subst.empty lit') lit of
NONE => NONE
| SOME sub => SOME (uTh,sub)
in
first check (LiteralNet.match net lit)
end;
(* ------------------------------------------------------------------------- *)
(* Reducing by repeated matching and resolution. *)
(* ------------------------------------------------------------------------- *)
fun reduce units =
let
fun red1 (lit,news_th) =
case total Literal.destIrrefl lit of
SOME tm =>
let
val (news,th) = news_th
val th = Thm.resolve lit th (Thm.refl tm)
in
(news,th)
end
| NONE =>
let
val lit' = Literal.negate lit
in
case match units lit' of
NONE => news_th
| SOME ((_,rth),sub) =>
let
val (news,th) = news_th
val rth = Thm.subst sub rth
val th = Thm.resolve lit th rth
val new = LiteralSet.delete (Thm.clause rth) lit'
val news = LiteralSet.union new news
in
(news,th)
end
end
fun red (news,th) =
if LiteralSet.null news then th
else red (LiteralSet.foldl red1 (LiteralSet.empty,th) news)
in
fn th => Rule.removeSym (red (Thm.clause th, th))
end;
end
end;
(**** Original file: Clause.sig ****)
(* ========================================================================= *)
(* CLAUSE = ID + THEOREM *)
(* Copyright (c) 2002-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Clause =
sig
(* ------------------------------------------------------------------------- *)
(* A type of clause. *)
(* ------------------------------------------------------------------------- *)
datatype literalOrder =
NoLiteralOrder
| UnsignedLiteralOrder
| PositiveLiteralOrder
type parameters =
{ordering : Metis.KnuthBendixOrder.kbo,
orderLiterals : literalOrder,
orderTerms : bool}
type clauseId = int
type clauseInfo = {parameters : parameters, id : clauseId, thm : Metis.Thm.thm}
type clause
(* ------------------------------------------------------------------------- *)
(* Basic operations. *)
(* ------------------------------------------------------------------------- *)
val default : parameters
val newId : unit -> clauseId
val mk : clauseInfo -> clause
val dest : clause -> clauseInfo
val id : clause -> clauseId
val thm : clause -> Metis.Thm.thm
val equalThms : clause -> clause -> bool
val literals : clause -> Metis.Thm.clause
val isTautology : clause -> bool
val isContradiction : clause -> bool
(* ------------------------------------------------------------------------- *)
(* The term ordering is used to cut down inferences. *)
(* ------------------------------------------------------------------------- *)
val largestLiterals : clause -> Metis.LiteralSet.set
val largestEquations :
clause -> (Metis.Literal.literal * Metis.Rewrite.orient * Metis.Term.term) list
val largestSubterms :
clause -> (Metis.Literal.literal * Metis.Term.path * Metis.Term.term) list
val allSubterms : clause -> (Metis.Literal.literal * Metis.Term.path * Metis.Term.term) list
(* ------------------------------------------------------------------------- *)
(* Subsumption. *)
(* ------------------------------------------------------------------------- *)
val subsumes : clause Metis.Subsume.subsume -> clause -> bool
(* ------------------------------------------------------------------------- *)
(* Simplifying rules: these preserve the clause id. *)
(* ------------------------------------------------------------------------- *)
val freshVars : clause -> clause
val simplify : clause -> clause option
val reduce : Metis.Units.units -> clause -> clause
val rewrite : Metis.Rewrite.rewrite -> clause -> clause
(* ------------------------------------------------------------------------- *)
(* Inference rules: these generate new clause ids. *)
(* ------------------------------------------------------------------------- *)
val factor : clause -> clause list
val resolve : clause * Metis.Literal.literal -> clause * Metis.Literal.literal -> clause
val paramodulate :
clause * Metis.Literal.literal * Metis.Rewrite.orient * Metis.Term.term ->
clause * Metis.Literal.literal * Metis.Term.path * Metis.Term.term -> clause
(* ------------------------------------------------------------------------- *)
(* Pretty printing. *)
(* ------------------------------------------------------------------------- *)
val showId : bool Unsynchronized.ref
val pp : clause Metis.Parser.pp
end
(**** Original file: Clause.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* CLAUSE = ID + THEOREM *)
(* Copyright (c) 2002-2004 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Clause :> Clause =
struct
open Useful;
(* ------------------------------------------------------------------------- *)
(* Helper functions. *)
(* ------------------------------------------------------------------------- *)
val newId =
let
val r = Unsynchronized.ref 0
in
fn () => CRITICAL (fn () =>
case r of Unsynchronized.ref n => let val () = r := n + 1 in n end)
end;
(* ------------------------------------------------------------------------- *)
(* A type of clause. *)
(* ------------------------------------------------------------------------- *)
datatype literalOrder =
NoLiteralOrder
| UnsignedLiteralOrder
| PositiveLiteralOrder;
type parameters =
{ordering : KnuthBendixOrder.kbo,
orderLiterals : literalOrder,
orderTerms : bool};
type clauseId = int;
type clauseInfo = {parameters : parameters, id : clauseId, thm : Thm.thm};
datatype clause = Clause of clauseInfo;
(* ------------------------------------------------------------------------- *)
(* Pretty printing. *)
(* ------------------------------------------------------------------------- *)
val showId = Unsynchronized.ref false;
local
val ppIdThm = Parser.ppPair Parser.ppInt Thm.pp;
in
fun pp p (Clause {id,thm,...}) =
if !showId then ppIdThm p (id,thm) else Thm.pp p thm;
end;
(* ------------------------------------------------------------------------- *)
(* Basic operations. *)
(* ------------------------------------------------------------------------- *)
val default : parameters =
{ordering = KnuthBendixOrder.default,
orderLiterals = UnsignedLiteralOrder, (*LCP: changed from PositiveLiteralOrder*)
orderTerms = true};
fun mk info = Clause info
fun dest (Clause info) = info;
fun id (Clause {id = i, ...}) = i;
fun thm (Clause {thm = th, ...}) = th;
fun equalThms cl cl' = Thm.equal (thm cl) (thm cl');
fun new parameters thm =
Clause {parameters = parameters, id = newId (), thm = thm};
fun literals cl = Thm.clause (thm cl);
fun isTautology (Clause {thm,...}) = Thm.isTautology thm;
fun isContradiction (Clause {thm,...}) = Thm.isContradiction thm;
(* ------------------------------------------------------------------------- *)
(* The term ordering is used to cut down inferences. *)
(* ------------------------------------------------------------------------- *)
fun strictlyLess ordering x_y =
case KnuthBendixOrder.compare ordering x_y of
SOME LESS => true
| _ => false;
fun isLargerTerm ({ordering,orderTerms,...} : parameters) l_r =
not orderTerms orelse not (strictlyLess ordering l_r);
local
fun atomToTerms atm =
case total Atom.destEq atm of
NONE => [Term.Fn atm]
| SOME (l,r) => [l,r];
fun notStrictlyLess ordering (xs,ys) =
let
fun less x = List.exists (fn y => strictlyLess ordering (x,y)) ys
in
not (List.all less xs)
end;
in
fun isLargerLiteral ({ordering,orderLiterals,...} : parameters) lits =
case orderLiterals of
NoLiteralOrder => K true
| UnsignedLiteralOrder =>
let
fun addLit ((_,atm),acc) = atomToTerms atm @ acc
val tms = LiteralSet.foldl addLit [] lits
in
fn (_,atm') => notStrictlyLess ordering (atomToTerms atm', tms)
end
| PositiveLiteralOrder =>
case LiteralSet.findl (K true) lits of
NONE => K true
| SOME (pol,_) =>
let
fun addLit ((p,atm),acc) =
if p = pol then atomToTerms atm @ acc else acc
val tms = LiteralSet.foldl addLit [] lits
in
fn (pol',atm') =>
if pol <> pol' then pol
else notStrictlyLess ordering (atomToTerms atm', tms)
end;
end;
fun largestLiterals (Clause {parameters,thm,...}) =
let
val litSet = Thm.clause thm
val isLarger = isLargerLiteral parameters litSet
fun addLit (lit,s) = if isLarger lit then LiteralSet.add s lit else s
in
LiteralSet.foldr addLit LiteralSet.empty litSet
end;
(*TRACE6
val largestLiterals = fn cl =>
let
val ppResult = LiteralSet.pp
val () = Parser.ppTrace pp "Clause.largestLiterals: cl" cl
val result = largestLiterals cl
val () = Parser.ppTrace ppResult "Clause.largestLiterals: result" result
in
result
end;
*)
fun largestEquations (cl as Clause {parameters,...}) =
let
fun addEq lit ort (l_r as (l,_)) acc =
if isLargerTerm parameters l_r then (lit,ort,l) :: acc else acc
fun addLit (lit,acc) =
case total Literal.destEq lit of
NONE => acc
| SOME (l,r) =>
let
val acc = addEq lit Rewrite.RightToLeft (r,l) acc
val acc = addEq lit Rewrite.LeftToRight (l,r) acc
in
acc
end
in
LiteralSet.foldr addLit [] (largestLiterals cl)
end;
local
fun addLit (lit,acc) =
let
fun addTm ((path,tm),acc) = (lit,path,tm) :: acc
in
foldl addTm acc (Literal.nonVarTypedSubterms lit)
end;
in
fun largestSubterms cl = LiteralSet.foldl addLit [] (largestLiterals cl);
fun allSubterms cl = LiteralSet.foldl addLit [] (literals cl);
end;
(* ------------------------------------------------------------------------- *)
(* Subsumption. *)
(* ------------------------------------------------------------------------- *)
fun subsumes (subs : clause Subsume.subsume) cl =
Subsume.isStrictlySubsumed subs (literals cl);
(* ------------------------------------------------------------------------- *)
(* Simplifying rules: these preserve the clause id. *)
(* ------------------------------------------------------------------------- *)
fun freshVars (Clause {parameters,id,thm}) =
Clause {parameters = parameters, id = id, thm = Rule.freshVars thm};
fun simplify (Clause {parameters,id,thm}) =
case Rule.simplify thm of
NONE => NONE
| SOME thm => SOME (Clause {parameters = parameters, id = id, thm = thm});
fun reduce units (Clause {parameters,id,thm}) =
Clause {parameters = parameters, id = id, thm = Units.reduce units thm};
fun rewrite rewr (cl as Clause {parameters,id,thm}) =
let
fun simp th =
let
val {ordering,...} = parameters
val cmp = KnuthBendixOrder.compare ordering
in
Rewrite.rewriteIdRule rewr cmp id th
end
(*TRACE4
val () = Parser.ppTrace Rewrite.pp "Clause.rewrite: rewr" rewr
val () = Parser.ppTrace Parser.ppInt "Clause.rewrite: id" id
val () = Parser.ppTrace pp "Clause.rewrite: cl" cl
*)
val thm =
case Rewrite.peek rewr id of
NONE => simp thm
| SOME ((_,thm),_) => if Rewrite.isReduced rewr then thm else simp thm
val result = Clause {parameters = parameters, id = id, thm = thm}
(*TRACE4
val () = Parser.ppTrace pp "Clause.rewrite: result" result
*)
in
result
end
(*DEBUG
handle Error err => raise Error ("Clause.rewrite:\n" ^ err);
*)
(* ------------------------------------------------------------------------- *)
(* Inference rules: these generate new clause ids. *)
(* ------------------------------------------------------------------------- *)
fun factor (cl as Clause {parameters,thm,...}) =
let
val lits = largestLiterals cl
fun apply sub = new parameters (Thm.subst sub thm)
in
map apply (Rule.factor' lits)
end;
(*TRACE5
val factor = fn cl =>
let
val () = Parser.ppTrace pp "Clause.factor: cl" cl
val result = factor cl
val () = Parser.ppTrace (Parser.ppList pp) "Clause.factor: result" result
in
result
end;
*)
fun resolve (cl1,lit1) (cl2,lit2) =
let
(*TRACE5
val () = Parser.ppTrace pp "Clause.resolve: cl1" cl1
val () = Parser.ppTrace Literal.pp "Clause.resolve: lit1" lit1
val () = Parser.ppTrace pp "Clause.resolve: cl2" cl2
val () = Parser.ppTrace Literal.pp "Clause.resolve: lit2" lit2
*)
val Clause {parameters, thm = th1, ...} = cl1
and Clause {thm = th2, ...} = cl2
val sub = Literal.unify Subst.empty lit1 (Literal.negate lit2)
(*TRACE5
val () = Parser.ppTrace Subst.pp "Clause.resolve: sub" sub
*)
val lit1 = Literal.subst sub lit1
val lit2 = Literal.negate lit1
val th1 = Thm.subst sub th1
and th2 = Thm.subst sub th2
val _ = isLargerLiteral parameters (Thm.clause th1) lit1 orelse
(*TRACE5
(trace "Clause.resolve: th1 violates ordering\n"; false) orelse
*)
raise Error "resolve: clause1: ordering constraints"
val _ = isLargerLiteral parameters (Thm.clause th2) lit2 orelse
(*TRACE5
(trace "Clause.resolve: th2 violates ordering\n"; false) orelse
*)
raise Error "resolve: clause2: ordering constraints"
val th = Thm.resolve lit1 th1 th2
(*TRACE5
val () = Parser.ppTrace Thm.pp "Clause.resolve: th" th
*)
val cl = Clause {parameters = parameters, id = newId (), thm = th}
(*TRACE5
val () = Parser.ppTrace pp "Clause.resolve: cl" cl
*)
in
cl
end;
fun paramodulate (cl1,lit1,ort,tm1) (cl2,lit2,path,tm2) =
let
(*TRACE5
val () = Parser.ppTrace pp "Clause.paramodulate: cl1" cl1
val () = Parser.ppTrace Literal.pp "Clause.paramodulate: lit1" lit1
val () = Parser.ppTrace pp "Clause.paramodulate: cl2" cl2
val () = Parser.ppTrace Literal.pp "Clause.paramodulate: lit2" lit2
*)
val Clause {parameters, thm = th1, ...} = cl1
and Clause {thm = th2, ...} = cl2
val sub = Subst.unify Subst.empty tm1 tm2
val lit1 = Literal.subst sub lit1
and lit2 = Literal.subst sub lit2
and th1 = Thm.subst sub th1
and th2 = Thm.subst sub th2
val _ = isLargerLiteral parameters (Thm.clause th1) lit1 orelse
(*TRACE5
(trace "Clause.paramodulate: cl1 ordering\n"; false) orelse
*)
raise Error "paramodulate: with clause: ordering constraints"
val _ = isLargerLiteral parameters (Thm.clause th2) lit2 orelse
(*TRACE5
(trace "Clause.paramodulate: cl2 ordering\n"; false) orelse
*)
raise Error "paramodulate: into clause: ordering constraints"
val eqn = (Literal.destEq lit1, th1)
val eqn as (l_r,_) =
case ort of
Rewrite.LeftToRight => eqn
| Rewrite.RightToLeft => Rule.symEqn eqn
val _ = isLargerTerm parameters l_r orelse
(*TRACE5
(trace "Clause.paramodulate: eqn ordering\n"; false) orelse
*)
raise Error "paramodulate: equation: ordering constraints"
val th = Rule.rewrRule eqn lit2 path th2
(*TRACE5
val () = Parser.ppTrace Thm.pp "Clause.paramodulate: th" th
*)
in
Clause {parameters = parameters, id = newId (), thm = th}
end;
end
end;
(**** Original file: Active.sig ****)
(* ========================================================================= *)
(* THE ACTIVE SET OF CLAUSES *)
(* Copyright (c) 2002-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Active =
sig
(* ------------------------------------------------------------------------- *)
(* A type of active clause sets. *)
(* ------------------------------------------------------------------------- *)
type simplify = {subsume : bool, reduce : bool, rewrite : bool}
type parameters =
{clause : Metis.Clause.parameters,
prefactor : simplify,
postfactor : simplify}
type active
(* ------------------------------------------------------------------------- *)
(* Basic operations. *)
(* ------------------------------------------------------------------------- *)
val default : parameters
val size : active -> int
val saturated : active -> Metis.Clause.clause list
(* ------------------------------------------------------------------------- *)
(* Create a new active clause set and initialize clauses. *)
(* ------------------------------------------------------------------------- *)
val new : parameters -> Metis.Thm.thm list -> active * Metis.Clause.clause list
(* ------------------------------------------------------------------------- *)
(* Add a clause into the active set and deduce all consequences. *)
(* ------------------------------------------------------------------------- *)
val add : active -> Metis.Clause.clause -> active * Metis.Clause.clause list
(* ------------------------------------------------------------------------- *)
(* Pretty printing. *)
(* ------------------------------------------------------------------------- *)
val pp : active Metis.Parser.pp
end
(**** Original file: Active.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* THE ACTIVE SET OF CLAUSES *)
(* Copyright (c) 2002-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Active :> Active =
struct
open Useful;
(* ------------------------------------------------------------------------- *)
(* Helper functions. *)
(* ------------------------------------------------------------------------- *)
local
fun allFactors red =
let
fun allClause cl = List.all red (cl :: Clause.factor cl)
in
List.all allClause
end;
fun allResolutions red =
let
fun allClause2 cl_lit cl =
let
fun allLiteral2 lit =
case total (Clause.resolve cl_lit) (cl,lit) of
NONE => true
| SOME cl => allFactors red [cl]
in
LiteralSet.all allLiteral2 (Clause.literals cl)
end
fun allClause1 allCls cl =
let
val cl = Clause.freshVars cl
fun allLiteral1 lit = List.all (allClause2 (cl,lit)) allCls
in
LiteralSet.all allLiteral1 (Clause.literals cl)
end
in
fn [] => true
| allCls as cl :: cls =>
allClause1 allCls cl andalso allResolutions red cls
end;
fun allParamodulations red cls =
let
fun allClause2 cl_lit_ort_tm cl =
let
fun allLiteral2 lit =
let
val para = Clause.paramodulate cl_lit_ort_tm
fun allSubterms (path,tm) =
case total para (cl,lit,path,tm) of
NONE => true
| SOME cl => allFactors red [cl]
in
List.all allSubterms (Literal.nonVarTypedSubterms lit)
end
in
LiteralSet.all allLiteral2 (Clause.literals cl)
end
fun allClause1 cl =
let
val cl = Clause.freshVars cl
fun allLiteral1 lit =
let
fun allCl2 x = List.all (allClause2 x) cls
in
case total Literal.destEq lit of
NONE => true
| SOME (l,r) =>
allCl2 (cl,lit,Rewrite.LeftToRight,l) andalso
allCl2 (cl,lit,Rewrite.RightToLeft,r)
end
in
LiteralSet.all allLiteral1 (Clause.literals cl)
end
in
List.all allClause1 cls
end;
fun redundant {subsume,reduce,rewrite} =
let
fun simp cl =
case Clause.simplify cl of
NONE => true
| SOME cl =>
Subsume.isStrictlySubsumed subsume (Clause.literals cl) orelse
let
val cl' = cl
val cl' = Clause.reduce reduce cl'
val cl' = Clause.rewrite rewrite cl'
in
not (Clause.equalThms cl cl') andalso simp cl'
end
in
simp
end;
in
fun isSaturated ordering subs cls =
let
(*TRACE2
val ppCls = Parser.ppList Clause.pp
val () = Parser.ppTrace ppCls "Active.checkSaturated: clauses" cls
*)
val red = Units.empty
val rw = Rewrite.new (KnuthBendixOrder.compare ordering)
val red = redundant {subsume = subs, reduce = red, rewrite = rw}
in
allFactors red cls andalso
allResolutions red cls andalso
allParamodulations red cls
end;
fun checkSaturated ordering subs cls =
if isSaturated ordering subs cls then () else raise Bug "unsaturated";
end;
(* ------------------------------------------------------------------------- *)
(* A type of active clause sets. *)
(* ------------------------------------------------------------------------- *)
type simplify = {subsume : bool, reduce : bool, rewrite : bool};
type parameters =
{clause : Clause.parameters,
prefactor : simplify,
postfactor : simplify};
datatype active =
Active of
{parameters : parameters,
clauses : Clause.clause IntMap.map,
units : Units.units,
rewrite : Rewrite.rewrite,
subsume : Clause.clause Subsume.subsume,
literals : (Clause.clause * Literal.literal) LiteralNet.literalNet,
equations :
(Clause.clause * Literal.literal * Rewrite.orient * Term.term)
TermNet.termNet,
subterms :
(Clause.clause * Literal.literal * Term.path * Term.term)
TermNet.termNet,
allSubterms : (Clause.clause * Term.term) TermNet.termNet};
fun getSubsume (Active {subsume = s, ...}) = s;
fun setRewrite active rewrite =
let
val Active
{parameters,clauses,units,subsume,literals,equations,
subterms,allSubterms,...} = active
in
Active
{parameters = parameters, clauses = clauses, units = units,
rewrite = rewrite, subsume = subsume, literals = literals,
equations = equations, subterms = subterms, allSubterms = allSubterms}
end;
(* ------------------------------------------------------------------------- *)
(* Basic operations. *)
(* ------------------------------------------------------------------------- *)
val maxSimplify : simplify = {subsume = true, reduce = true, rewrite = true};
val default : parameters =
{clause = Clause.default,
prefactor = maxSimplify,
postfactor = maxSimplify};
fun empty parameters =
let
val {clause,...} = parameters
val {ordering,...} = clause
in
Active
{parameters = parameters,
clauses = IntMap.new (),
units = Units.empty,
rewrite = Rewrite.new (KnuthBendixOrder.compare ordering),
subsume = Subsume.new (),
literals = LiteralNet.new {fifo = false},
equations = TermNet.new {fifo = false},
subterms = TermNet.new {fifo = false},
allSubterms = TermNet.new {fifo = false}}
end;
fun size (Active {clauses,...}) = IntMap.size clauses;
fun clauses (Active {clauses = cls, ...}) =
let
fun add (_,cl,acc) = cl :: acc
in
IntMap.foldr add [] cls
end;
fun saturated active =
let
fun remove (cl,(cls,subs)) =
let
val lits = Clause.literals cl
in
if Subsume.isStrictlySubsumed subs lits then (cls,subs)
else (cl :: cls, Subsume.insert subs (lits,()))
end
val cls = clauses active
val (cls,_) = foldl remove ([], Subsume.new ()) cls
val (cls,subs) = foldl remove ([], Subsume.new ()) cls
(*DEBUG
val Active {parameters,...} = active
val {clause,...} = parameters
val {ordering,...} = clause
val () = checkSaturated ordering subs cls
*)
in
cls
end;
(* ------------------------------------------------------------------------- *)
(* Pretty printing. *)
(* ------------------------------------------------------------------------- *)
val pp =
let
fun toStr active = "Active{" ^ Int.toString (size active) ^ "}"
in
Parser.ppMap toStr Parser.ppString
end;
(*DEBUG
local
open Parser;
fun ppField f ppA p a =
(beginBlock p Inconsistent 2;
addString p (f ^ " =");
addBreak p (1,0);
ppA p a;
endBlock p);
val ppClauses =
ppField "clauses"
(Parser.ppMap IntMap.toList
(Parser.ppList (Parser.ppPair Parser.ppInt Clause.pp)));
val ppRewrite = ppField "rewrite" Rewrite.pp;
val ppSubterms =
ppField "subterms"
(TermNet.pp
(Parser.ppMap (fn (c,l,p,t) => ((Clause.id c, l, p), t))
(Parser.ppPair
(Parser.ppTriple Parser.ppInt Literal.pp Term.ppPath)
Term.pp)));
in
fun pp p (Active {clauses,rewrite,subterms,...}) =
(beginBlock p Inconsistent 2;
addString p "Active";
addBreak p (1,0);
beginBlock p Inconsistent 1;
addString p "{";
ppClauses p clauses;
addString p ",";
addBreak p (1,0);
ppRewrite p rewrite;
(*TRACE5
addString p ",";
addBreak p (1,0);
ppSubterms p subterms;
*)
endBlock p;
addString p "}";
endBlock p);
end;
*)
val toString = Parser.toString pp;
(* ------------------------------------------------------------------------- *)
(* Simplify clauses. *)
(* ------------------------------------------------------------------------- *)
fun simplify simp units rewr subs =
let
val {subsume = s, reduce = r, rewrite = w} = simp
fun rewrite cl =
let
val cl' = Clause.rewrite rewr cl
in
if Clause.equalThms cl cl' then SOME cl else Clause.simplify cl'
end
in
fn cl =>
case Clause.simplify cl of
NONE => NONE
| SOME cl =>
case (if w then rewrite cl else SOME cl) of
NONE => NONE
| SOME cl =>
let
val cl = if r then Clause.reduce units cl else cl
in
if s andalso Clause.subsumes subs cl then NONE else SOME cl
end
end;
(*DEBUG
val simplify = fn simp => fn units => fn rewr => fn subs => fn cl =>
let
fun traceCl s = Parser.ppTrace Clause.pp ("Active.simplify: " ^ s)
(*TRACE4
val ppClOpt = Parser.ppOption Clause.pp
val () = traceCl "cl" cl
*)
val cl' = simplify simp units rewr subs cl
(*TRACE4
val () = Parser.ppTrace ppClOpt "Active.simplify: cl'" cl'
*)
val () =
case cl' of
NONE => ()
| SOME cl' =>
case
(case simplify simp units rewr subs cl' of
NONE => SOME ("away", K ())
| SOME cl'' =>
if Clause.equalThms cl' cl'' then NONE
else SOME ("further", fn () => traceCl "cl''" cl'')) of
NONE => ()
| SOME (e,f) =>
let
val () = traceCl "cl" cl
val () = traceCl "cl'" cl'
val () = f ()
in
raise
Bug
("Active.simplify: clause should have been simplified "^e)
end
in
cl'
end;
*)
fun simplifyActive simp active =
let
val Active {units,rewrite,subsume,...} = active
in
simplify simp units rewrite subsume
end;
(* ------------------------------------------------------------------------- *)
(* Add a clause into the active set. *)
(* ------------------------------------------------------------------------- *)
fun addUnit units cl =
let
val th = Clause.thm cl
in
case total Thm.destUnit th of
SOME lit => Units.add units (lit,th)
| NONE => units
end;
fun addRewrite rewrite cl =
let
val th = Clause.thm cl
in
case total Thm.destUnitEq th of
SOME l_r => Rewrite.add rewrite (Clause.id cl, (l_r,th))
| NONE => rewrite
end;
fun addSubsume subsume cl = Subsume.insert subsume (Clause.literals cl, cl);
fun addLiterals literals cl =
let
fun add (lit as (_,atm), literals) =
if Atom.isEq atm then literals
else LiteralNet.insert literals (lit,(cl,lit))
in
LiteralSet.foldl add literals (Clause.largestLiterals cl)
end;
fun addEquations equations cl =
let
fun add ((lit,ort,tm),equations) =
TermNet.insert equations (tm,(cl,lit,ort,tm))
in
foldl add equations (Clause.largestEquations cl)
end;
fun addSubterms subterms cl =
let
fun add ((lit,path,tm),subterms) =
TermNet.insert subterms (tm,(cl,lit,path,tm))
in
foldl add subterms (Clause.largestSubterms cl)
end;
fun addAllSubterms allSubterms cl =
let
fun add ((_,_,tm),allSubterms) =
TermNet.insert allSubterms (tm,(cl,tm))
in
foldl add allSubterms (Clause.allSubterms cl)
end;
fun addClause active cl =
let
val Active
{parameters,clauses,units,rewrite,subsume,literals,
equations,subterms,allSubterms} = active
val clauses = IntMap.insert clauses (Clause.id cl, cl)
and subsume = addSubsume subsume cl
and literals = addLiterals literals cl
and equations = addEquations equations cl
and subterms = addSubterms subterms cl
and allSubterms = addAllSubterms allSubterms cl
in
Active
{parameters = parameters, clauses = clauses, units = units,
rewrite = rewrite, subsume = subsume, literals = literals,
equations = equations, subterms = subterms,
allSubterms = allSubterms}
end;
fun addFactorClause active cl =
let
val Active
{parameters,clauses,units,rewrite,subsume,literals,
equations,subterms,allSubterms} = active
val units = addUnit units cl
and rewrite = addRewrite rewrite cl
in
Active
{parameters = parameters, clauses = clauses, units = units,
rewrite = rewrite, subsume = subsume, literals = literals,
equations = equations, subterms = subterms, allSubterms = allSubterms}
end;
(* ------------------------------------------------------------------------- *)
(* Derive (unfactored) consequences of a clause. *)
(* ------------------------------------------------------------------------- *)
fun deduceResolution literals cl (lit as (_,atm), acc) =
let
fun resolve (cl_lit,acc) =
case total (Clause.resolve cl_lit) (cl,lit) of
SOME cl' => cl' :: acc
| NONE => acc
(*TRACE4
val () = Parser.ppTrace Literal.pp "Active.deduceResolution: lit" lit
*)
in
if Atom.isEq atm then acc
else foldl resolve acc (LiteralNet.unify literals (Literal.negate lit))
end;
fun deduceParamodulationWith subterms cl ((lit,ort,tm),acc) =
let
fun para (cl_lit_path_tm,acc) =
case total (Clause.paramodulate (cl,lit,ort,tm)) cl_lit_path_tm of
SOME cl' => cl' :: acc
| NONE => acc
in
foldl para acc (TermNet.unify subterms tm)
end;
fun deduceParamodulationInto equations cl ((lit,path,tm),acc) =
let
fun para (cl_lit_ort_tm,acc) =
case total (Clause.paramodulate cl_lit_ort_tm) (cl,lit,path,tm) of
SOME cl' => cl' :: acc
| NONE => acc
in
foldl para acc (TermNet.unify equations tm)
end;
fun deduce active cl =
let
val Active {parameters,literals,equations,subterms,...} = active
val lits = Clause.largestLiterals cl
val eqns = Clause.largestEquations cl
val subtms =
if TermNet.null equations then [] else Clause.largestSubterms cl
val acc = []
val acc = LiteralSet.foldl (deduceResolution literals cl) acc lits
val acc = foldl (deduceParamodulationWith subterms cl) acc eqns
val acc = foldl (deduceParamodulationInto equations cl) acc subtms
in
rev acc
end;
(* ------------------------------------------------------------------------- *)
(* Extract clauses from the active set that can be simplified. *)
(* ------------------------------------------------------------------------- *)
local
fun clause_rewritables active =
let
val Active {clauses,rewrite,...} = active
fun rewr (id,cl,ids) =
let
val cl' = Clause.rewrite rewrite cl
in
if Clause.equalThms cl cl' then ids else IntSet.add ids id
end
in
IntMap.foldr rewr IntSet.empty clauses
end;
fun orderedRedexResidues (((l,r),_),ort) =
case ort of
NONE => []
| SOME Rewrite.LeftToRight => [(l,r,true)]
| SOME Rewrite.RightToLeft => [(r,l,true)];
fun unorderedRedexResidues (((l,r),_),ort) =
case ort of
NONE => [(l,r,false),(r,l,false)]
| SOME _ => [];
fun rewrite_rewritables active rewr_ids =
let
val Active {parameters,rewrite,clauses,allSubterms,...} = active
val {clause = {ordering,...}, ...} = parameters
val order = KnuthBendixOrder.compare ordering
fun addRewr (id,acc) =
if IntMap.inDomain id clauses then IntSet.add acc id else acc
fun addReduce ((l,r,ord),acc) =
let
fun isValidRewr tm =
case total (Subst.match Subst.empty l) tm of
NONE => false
| SOME sub =>
ord orelse
let
val tm' = Subst.subst (Subst.normalize sub) r
in
order (tm,tm') = SOME GREATER
end
fun addRed ((cl,tm),acc) =
let
(*TRACE5
val () = Parser.ppTrace Clause.pp "Active.addRed: cl" cl
val () = Parser.ppTrace Term.pp "Active.addRed: tm" tm
*)
val id = Clause.id cl
in
if IntSet.member id acc then acc
else if not (isValidRewr tm) then acc
else IntSet.add acc id
end
(*TRACE5
val () = Parser.ppTrace Term.pp "Active.addReduce: l" l
val () = Parser.ppTrace Term.pp "Active.addReduce: r" r
val () = Parser.ppTrace Parser.ppBool "Active.addReduce: ord" ord
*)
in
List.foldl addRed acc (TermNet.matched allSubterms l)
end
fun addEquation redexResidues (id,acc) =
case Rewrite.peek rewrite id of
NONE => acc
| SOME eqn_ort => List.foldl addReduce acc (redexResidues eqn_ort)
val addOrdered = addEquation orderedRedexResidues
val addUnordered = addEquation unorderedRedexResidues
val ids = IntSet.empty
val ids = List.foldl addRewr ids rewr_ids
val ids = List.foldl addOrdered ids rewr_ids
val ids = List.foldl addUnordered ids rewr_ids
in
ids
end;
fun choose_clause_rewritables active ids = size active <= length ids
fun rewritables active ids =
if choose_clause_rewritables active ids then clause_rewritables active
else rewrite_rewritables active ids;
(*DEBUG
val rewritables = fn active => fn ids =>
let
val clause_ids = clause_rewritables active
val rewrite_ids = rewrite_rewritables active ids
val () =
if IntSet.equal rewrite_ids clause_ids then ()
else
let
val ppIdl = Parser.ppList Parser.ppInt
val ppIds = Parser.ppMap IntSet.toList ppIdl
val () = Parser.ppTrace pp "Active.rewritables: active" active
val () = Parser.ppTrace ppIdl "Active.rewritables: ids" ids
val () = Parser.ppTrace ppIds
"Active.rewritables: clause_ids" clause_ids
val () = Parser.ppTrace ppIds
"Active.rewritables: rewrite_ids" rewrite_ids
in
raise Bug "Active.rewritables: ~(rewrite_ids SUBSET clause_ids)"
end
in
if choose_clause_rewritables active ids then clause_ids else rewrite_ids
end;
*)
fun delete active ids =
if IntSet.null ids then active
else
let
fun idPred id = not (IntSet.member id ids)
fun clausePred cl = idPred (Clause.id cl)
val Active
{parameters,clauses,units,rewrite,subsume,literals,
equations,subterms,allSubterms} = active
val clauses = IntMap.filter (idPred o fst) clauses
and subsume = Subsume.filter clausePred subsume
and literals = LiteralNet.filter (clausePred o #1) literals
and equations = TermNet.filter (clausePred o #1) equations
and subterms = TermNet.filter (clausePred o #1) subterms
and allSubterms = TermNet.filter (clausePred o fst) allSubterms
in
Active
{parameters = parameters, clauses = clauses, units = units,
rewrite = rewrite, subsume = subsume, literals = literals,
equations = equations, subterms = subterms,
allSubterms = allSubterms}
end;
in
fun extract_rewritables (active as Active {clauses,rewrite,...}) =
if Rewrite.isReduced rewrite then (active,[])
else
let
(*TRACE3
val () = trace "Active.extract_rewritables: inter-reducing\n"
*)
val (rewrite,ids) = Rewrite.reduce' rewrite
val active = setRewrite active rewrite
val ids = rewritables active ids
val cls = IntSet.transform (IntMap.get clauses) ids
(*TRACE3
val ppCls = Parser.ppList Clause.pp
val () = Parser.ppTrace ppCls "Active.extract_rewritables: cls" cls
*)
in
(delete active ids, cls)
end
(*DEBUG
handle Error err =>
raise Bug ("Active.extract_rewritables: shouldn't fail\n" ^ err);
*)
end;
(* ------------------------------------------------------------------------- *)
(* Factor clauses. *)
(* ------------------------------------------------------------------------- *)
local
fun prefactor_simplify active subsume =
let
val Active {parameters,units,rewrite,...} = active
val {prefactor,...} = parameters
in
simplify prefactor units rewrite subsume
end;
fun postfactor_simplify active subsume =
let
val Active {parameters,units,rewrite,...} = active
val {postfactor,...} = parameters
in
simplify postfactor units rewrite subsume
end;
val sort_utilitywise =
let
fun utility cl =
case LiteralSet.size (Clause.literals cl) of
0 => ~1
| 1 => if Thm.isUnitEq (Clause.thm cl) then 0 else 1
| n => n
in
sortMap utility Int.compare
end;
fun factor_add (cl, active_subsume_acc as (active,subsume,acc)) =
case postfactor_simplify active subsume cl of
NONE => active_subsume_acc
| SOME cl =>
let
val active = addFactorClause active cl
and subsume = addSubsume subsume cl
and acc = cl :: acc
in
(active,subsume,acc)
end;
fun factor1 (cl, active_subsume_acc as (active,subsume,_)) =
case prefactor_simplify active subsume cl of
NONE => active_subsume_acc
| SOME cl =>
let
val cls = sort_utilitywise (cl :: Clause.factor cl)
in
foldl factor_add active_subsume_acc cls
end;
fun factor' active acc [] = (active, rev acc)
| factor' active acc cls =
let
val cls = sort_utilitywise cls
val subsume = getSubsume active
val (active,_,acc) = foldl factor1 (active,subsume,acc) cls
val (active,cls) = extract_rewritables active
in
factor' active acc cls
end;
in
fun factor active cls = factor' active [] cls;
end;
(*TRACE4
val factor = fn active => fn cls =>
let
val ppCls = Parser.ppList Clause.pp
val () = Parser.ppTrace ppCls "Active.factor: cls" cls
val (active,cls') = factor active cls
val () = Parser.ppTrace ppCls "Active.factor: cls'" cls'
in
(active,cls')
end;
*)
(* ------------------------------------------------------------------------- *)
(* Create a new active clause set and initialize clauses. *)
(* ------------------------------------------------------------------------- *)
fun new parameters ths =
let
val {clause,...} = parameters
fun mk_clause th =
Clause.mk {parameters = clause, id = Clause.newId (), thm = th}
val cls = map mk_clause ths
in
factor (empty parameters) cls
end;
(* ------------------------------------------------------------------------- *)
(* Add a clause into the active set and deduce all consequences. *)
(* ------------------------------------------------------------------------- *)
fun add active cl =
case simplifyActive maxSimplify active cl of
NONE => (active,[])
| SOME cl' =>
if Clause.isContradiction cl' then (active,[cl'])
else if not (Clause.equalThms cl cl') then factor active [cl']
else
let
(*TRACE3
val () = Parser.ppTrace Clause.pp "Active.add: cl" cl
*)
val active = addClause active cl
val cl = Clause.freshVars cl
val cls = deduce active cl
val (active,cls) = factor active cls
(*TRACE2
val ppCls = Parser.ppList Clause.pp
val () = Parser.ppTrace ppCls "Active.add: cls" cls
*)
in
(active,cls)
end;
end
end;
(**** Original file: Waiting.sig ****)
(* ========================================================================= *)
(* THE WAITING SET OF CLAUSES *)
(* Copyright (c) 2002-2007 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Waiting =
sig
(* ------------------------------------------------------------------------- *)
(* A type of waiting sets of clauses. *)
(* ------------------------------------------------------------------------- *)
type parameters =
{symbolsWeight : real,
literalsWeight : real,
modelsWeight : real,
modelChecks : int,
models : Metis.Model.parameters list}
type waiting
type distance
(* ------------------------------------------------------------------------- *)
(* Basic operations. *)
(* ------------------------------------------------------------------------- *)
val default : parameters
val new : parameters -> Metis.Clause.clause list -> waiting
val size : waiting -> int
val pp : waiting Metis.Parser.pp
(* ------------------------------------------------------------------------- *)
(* Adding new clauses. *)
(* ------------------------------------------------------------------------- *)
val add : waiting -> distance * Metis.Clause.clause list -> waiting
(* ------------------------------------------------------------------------- *)
(* Removing the lightest clause. *)
(* ------------------------------------------------------------------------- *)
val remove : waiting -> ((distance * Metis.Clause.clause) * waiting) option
end
(**** Original file: Waiting.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* THE WAITING SET OF CLAUSES *)
(* Copyright (c) 2002-2007 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Waiting :> Waiting =
struct
open Useful;
(* ------------------------------------------------------------------------- *)
(* A type of waiting sets of clauses. *)
(* ------------------------------------------------------------------------- *)
(* The parameter type controls the heuristics for clause selection. *)
(* Increasing any of the *Weight parameters will favour clauses with low *)
(* values of that field. *)
(* Note that there is an extra parameter of inference distance from the *)
(* starting axioms (a.k.a. time) which has a fixed weight of 1, so all *)
(* the other parameters should be set relative to this baseline. *)
(* The first two parameters, symbolsWeight and literalsWeight, control the *)
(* time:weight ratio, i.e., whether to favour clauses derived in a few *)
(* steps from the axioms (time) or whether to favour small clauses (weight). *)
(* Small can be a combination of low number of symbols (the symbolWeight *)
(* parameter) or literals (the literalsWeight parameter). *)
(* modelsWeight controls the semantic guidance. Increasing this parameter *)
(* favours clauses that return false more often when interpreted *)
(* modelChecks times over the given list of models. *)
type parameters =
{symbolsWeight : real,
literalsWeight : real,
modelsWeight : real,
modelChecks : int,
models : Model.parameters list};
type distance = real;
type weight = real;
datatype waiting =
Waiting of
{parameters : parameters,
clauses : (weight * (distance * Clause.clause)) Heap.heap,
models : Model.model list};
(* ------------------------------------------------------------------------- *)
(* Basic operations. *)
(* ------------------------------------------------------------------------- *)
val default : parameters =
{symbolsWeight = 1.0,
literalsWeight = 0.0,
modelsWeight = 0.0,
modelChecks = 20,
models = []};
fun size (Waiting {clauses,...}) = Heap.size clauses;
val pp =
Parser.ppMap
(fn w => "Waiting{" ^ Int.toString (size w) ^ "}")
Parser.ppString;
(*DEBUG
val pp =
Parser.ppMap
(fn Waiting {clauses,...} =>
map (fn (w,(_,cl)) => (w, Clause.id cl, cl)) (Heap.toList clauses))
(Parser.ppList (Parser.ppTriple Parser.ppReal Parser.ppInt Clause.pp));
*)
(* ------------------------------------------------------------------------- *)
(* Clause weights. *)
(* ------------------------------------------------------------------------- *)
local
fun clauseSymbols cl = Real.fromInt (LiteralSet.typedSymbols cl);
fun clauseLiterals cl = Real.fromInt (LiteralSet.size cl);
fun clauseSat modelChecks models cl =
let
fun g {T,F} = (Real.fromInt T / Real.fromInt (T + F)) + 1.0
fun f (m,z) = g (Model.checkClause {maxChecks = modelChecks} m cl) * z
in
foldl f 1.0 models
end;
fun priority cl = 1e~12 * Real.fromInt (Clause.id cl);
in
fun clauseWeight (parm : parameters) models dist cl =
let
(*TRACE3
val () = Parser.ppTrace Clause.pp "Waiting.clauseWeight: cl" cl
*)
val {symbolsWeight,literalsWeight,modelsWeight,modelChecks,...} = parm
val lits = Clause.literals cl
val symbolsW = Math.pow (clauseSymbols lits, symbolsWeight)
val literalsW = Math.pow (clauseLiterals lits, literalsWeight)
val modelsW = Math.pow (clauseSat modelChecks models lits, modelsWeight)
(*TRACE4
val () = trace ("Waiting.clauseWeight: dist = " ^
Real.toString dist ^ "\n")
val () = trace ("Waiting.clauseWeight: symbolsW = " ^
Real.toString symbolsW ^ "\n")
val () = trace ("Waiting.clauseWeight: literalsW = " ^
Real.toString literalsW ^ "\n")
val () = trace ("Waiting.clauseWeight: modelsW = " ^
Real.toString modelsW ^ "\n")
*)
val weight = dist * symbolsW * literalsW * modelsW + priority cl
(*TRACE3
val () = trace ("Waiting.clauseWeight: weight = " ^
Real.toString weight ^ "\n")
*)
in
weight
end;
end;
(* ------------------------------------------------------------------------- *)
(* Adding new clauses. *)
(* ------------------------------------------------------------------------- *)
fun add waiting (_,[]) = waiting
| add waiting (dist,cls) =
let
(*TRACE3
val () = Parser.ppTrace pp "Waiting.add: waiting" waiting
val () = Parser.ppTrace (Parser.ppList Clause.pp) "Waiting.add: cls" cls
*)
val Waiting {parameters,clauses,models} = waiting
val dist = dist + Math.ln (Real.fromInt (length cls))
val weight = clauseWeight parameters models dist
fun f (cl,acc) = Heap.add acc (weight cl, (dist,cl))
val clauses = foldl f clauses cls
val waiting =
Waiting {parameters = parameters, clauses = clauses, models = models}
(*TRACE3
val () = Parser.ppTrace pp "Waiting.add: waiting" waiting
*)
in
waiting
end;
local
fun cmp ((w1,_),(w2,_)) = Real.compare (w1,w2);
fun empty parameters =
let
val clauses = Heap.new cmp
and models = map Model.new (#models parameters)
in
Waiting {parameters = parameters, clauses = clauses, models = models}
end;
in
fun new parameters cls = add (empty parameters) (0.0,cls);
end;
(* ------------------------------------------------------------------------- *)
(* Removing the lightest clause. *)
(* ------------------------------------------------------------------------- *)
fun remove (Waiting {parameters,clauses,models}) =
if Heap.null clauses then NONE
else
let
val ((_,dcl),clauses) = Heap.remove clauses
val waiting =
Waiting
{parameters = parameters, clauses = clauses, models = models}
in
SOME (dcl,waiting)
end;
end
end;
(**** Original file: Resolution.sig ****)
(* ========================================================================= *)
(* THE RESOLUTION PROOF PROCEDURE *)
(* Copyright (c) 2001-2007 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Resolution =
sig
(* ------------------------------------------------------------------------- *)
(* A type of resolution proof procedures. *)
(* ------------------------------------------------------------------------- *)
type parameters =
{active : Metis.Active.parameters,
waiting : Metis.Waiting.parameters}
type resolution
(* ------------------------------------------------------------------------- *)
(* Basic operations. *)
(* ------------------------------------------------------------------------- *)
val default : parameters
val new : parameters -> Metis.Thm.thm list -> resolution
val active : resolution -> Metis.Active.active
val waiting : resolution -> Metis.Waiting.waiting
val pp : resolution Metis.Parser.pp
(* ------------------------------------------------------------------------- *)
(* The main proof loop. *)
(* ------------------------------------------------------------------------- *)
datatype decision =
Contradiction of Metis.Thm.thm
| Satisfiable of Metis.Thm.thm list
datatype state =
Decided of decision
| Undecided of resolution
val iterate : resolution -> state
val loop : resolution -> decision
end
(**** Original file: Resolution.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* THE RESOLUTION PROOF PROCEDURE *)
(* Copyright (c) 2001-2007 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Resolution :> Resolution =
struct
open Useful;
(* ------------------------------------------------------------------------- *)
(* Parameters. *)
(* ------------------------------------------------------------------------- *)
type parameters =
{active : Active.parameters,
waiting : Waiting.parameters};
datatype resolution =
Resolution of
{parameters : parameters,
active : Active.active,
waiting : Waiting.waiting};
(* ------------------------------------------------------------------------- *)
(* Basic operations. *)
(* ------------------------------------------------------------------------- *)
val default : parameters =
{active = Active.default,
waiting = Waiting.default};
fun new parameters ths =
let
val {active = activeParm, waiting = waitingParm} = parameters
val (active,cls) = Active.new activeParm ths (* cls = factored ths *)
val waiting = Waiting.new waitingParm cls
in
Resolution {parameters = parameters, active = active, waiting = waiting}
end;
fun active (Resolution {active = a, ...}) = a;
fun waiting (Resolution {waiting = w, ...}) = w;
val pp =
Parser.ppMap
(fn Resolution {active,waiting,...} =>
"Resolution(" ^ Int.toString (Active.size active) ^
"<-" ^ Int.toString (Waiting.size waiting) ^ ")")
Parser.ppString;
(* ------------------------------------------------------------------------- *)
(* The main proof loop. *)
(* ------------------------------------------------------------------------- *)
datatype decision =
Contradiction of Thm.thm
| Satisfiable of Thm.thm list;
datatype state =
Decided of decision
| Undecided of resolution;
fun iterate resolution =
let
val Resolution {parameters,active,waiting} = resolution
(*TRACE2
val () = Parser.ppTrace Active.pp "Resolution.iterate: active" active
val () = Parser.ppTrace Waiting.pp "Resolution.iterate: waiting" waiting
*)
in
case Waiting.remove waiting of
NONE =>
Decided (Satisfiable (map Clause.thm (Active.saturated active)))
| SOME ((d,cl),waiting) =>
if Clause.isContradiction cl then
Decided (Contradiction (Clause.thm cl))
else
let
(*TRACE1
val () = Parser.ppTrace Clause.pp "Resolution.iterate: cl" cl
*)
val (active,cls) = Active.add active cl
val waiting = Waiting.add waiting (d,cls)
in
Undecided
(Resolution
{parameters = parameters, active = active, waiting = waiting})
end
end;
fun loop resolution =
case iterate resolution of
Decided decision => decision
| Undecided resolution => loop resolution;
end
end;
(**** Original file: Tptp.sig ****)
(* ========================================================================= *)
(* THE TPTP PROBLEM FILE FORMAT (TPTP v2) *)
(* Copyright (c) 2001-2007 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Tptp =
sig
(* ------------------------------------------------------------------------- *)
(* Mapping TPTP functions and relations to different names. *)
(* ------------------------------------------------------------------------- *)
val functionMapping : {name : string, arity : int, tptp : string} list Unsynchronized.ref
val relationMapping : {name : string, arity : int, tptp : string} list Unsynchronized.ref
(* ------------------------------------------------------------------------- *)
(* TPTP literals. *)
(* ------------------------------------------------------------------------- *)
datatype literal =
Boolean of bool
| Literal of Metis.Literal.literal
val negate : literal -> literal
val literalFunctions : literal -> Metis.NameAritySet.set
val literalRelation : literal -> Metis.Atom.relation option
val literalFreeVars : literal -> Metis.NameSet.set
(* ------------------------------------------------------------------------- *)
(* TPTP formulas. *)
(* ------------------------------------------------------------------------- *)
datatype formula =
CnfFormula of {name : string, role : string, clause : literal list}
| FofFormula of {name : string, role : string, formula : Metis.Formula.formula}
val formulaFunctions : formula -> Metis.NameAritySet.set
val formulaRelations : formula -> Metis.NameAritySet.set
val formulaFreeVars : formula -> Metis.NameSet.set
val formulaIsConjecture : formula -> bool
val ppFormula : formula Metis.Parser.pp
val parseFormula : char Metis.Stream.stream -> formula Metis.Stream.stream
val formulaToString : formula -> string
val formulaFromString : string -> formula
(* ------------------------------------------------------------------------- *)
(* TPTP problems. *)
(* ------------------------------------------------------------------------- *)
datatype goal =
Cnf of Metis.Problem.problem
| Fof of Metis.Formula.formula
type problem = {comments : string list, formulas : formula list}
val read : {filename : string} -> problem
val write : {filename : string} -> problem -> unit
val hasConjecture : problem -> bool
val toGoal : problem -> goal
val fromProblem : Metis.Problem.problem -> problem
val prove : {filename : string} -> bool
(* ------------------------------------------------------------------------- *)
(* TSTP proofs. *)
(* ------------------------------------------------------------------------- *)
val ppProof : Metis.Proof.proof Metis.Parser.pp
val proofToString : Metis.Proof.proof -> string
end
(**** Original file: Tptp.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
nonfix ++ -- RL mem union subset;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
(* ========================================================================= *)
(* THE TPTP PROBLEM FILE FORMAT (TPTP v2) *)
(* Copyright (c) 2001-2007 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Tptp :> Tptp =
struct
open Useful;
(* ------------------------------------------------------------------------- *)
(* Constants. *)
(* ------------------------------------------------------------------------- *)
val ROLE_NEGATED_CONJECTURE = "negated_conjecture"
and ROLE_CONJECTURE = "conjecture";
(* ------------------------------------------------------------------------- *)
(* Helper functions. *)
(* ------------------------------------------------------------------------- *)
fun isHdTlString hp tp s =
let
fun ct 0 = true
| ct i = tp (String.sub (s,i)) andalso ct (i - 1)
val n = size s
in
n > 0 andalso hp (String.sub (s,0)) andalso ct (n - 1)
end;
(* ------------------------------------------------------------------------- *)
(* Mapping TPTP functions and relations to different names. *)
(* ------------------------------------------------------------------------- *)
val functionMapping = Unsynchronized.ref
[(* Mapping TPTP functions to infix symbols *)
{name = "*", arity = 2, tptp = "multiply"},
{name = "/", arity = 2, tptp = "divide"},
{name = "+", arity = 2, tptp = "add"},
{name = "-", arity = 2, tptp = "subtract"},
{name = "::", arity = 2, tptp = "cons"},
{name = ",", arity = 2, tptp = "pair"},
(* Expanding HOL symbols to TPTP alphanumerics *)
{name = ":", arity = 2, tptp = "has_type"},
{name = ".", arity = 2, tptp = "apply"},
{name = "<=", arity = 0, tptp = "less_equal"}];
val relationMapping = Unsynchronized.ref
[(* Mapping TPTP relations to infix symbols *)
{name = "=", arity = 2, tptp = "="},
{name = "==", arity = 2, tptp = "equalish"},
{name = "<=", arity = 2, tptp = "less_equal"},
{name = "<", arity = 2, tptp = "less_than"},
(* Expanding HOL symbols to TPTP alphanumerics *)
{name = "{}", arity = 1, tptp = "bool"}];
fun mappingToTptp x =
let
fun mk ({name,arity,tptp},m) = NameArityMap.insert m ((name,arity),tptp)
in
foldl mk (NameArityMap.new ()) x
end;
fun mappingFromTptp x =
let
fun mk ({name,arity,tptp},m) = NameArityMap.insert m ((tptp,arity),name)
in
foldl mk (NameArityMap.new ()) x
end;
fun findMapping mapping (name_arity as (n,_)) =
Option.getOpt (NameArityMap.peek mapping name_arity, n);
fun mapTerm functionMap =
let
val mapName = findMapping functionMap
fun mapTm (tm as Term.Var _) = tm
| mapTm (Term.Fn (f,a)) = Term.Fn (mapName (f, length a), map mapTm a)
in
mapTm
end;
fun mapAtom {functionMap,relationMap} (p,a) =
(findMapping relationMap (p, length a), map (mapTerm functionMap) a);
fun mapFof maps =
let
open Formula
fun form True = True
| form False = False
| form (Atom a) = Atom (mapAtom maps a)
| form (Not p) = Not (form p)
| form (And (p,q)) = And (form p, form q)
| form (Or (p,q)) = Or (form p, form q)
| form (Imp (p,q)) = Imp (form p, form q)
| form (Iff (p,q)) = Iff (form p, form q)
| form (Forall (v,p)) = Forall (v, form p)
| form (Exists (v,p)) = Exists (v, form p)
in
form
end;
(* ------------------------------------------------------------------------- *)
(* Comments. *)
(* ------------------------------------------------------------------------- *)
fun mkComment "" = "%"
| mkComment line = "% " ^ line;
fun destComment "" = ""
| destComment l =
let
val _ = String.sub (l,0) = #"%" orelse raise Error "destComment"
val n = if size l >= 2 andalso String.sub (l,1) = #" " then 2 else 1
in
String.extract (l,n,NONE)
end;
val isComment = can destComment;
(* ------------------------------------------------------------------------- *)
(* TPTP literals. *)
(* ------------------------------------------------------------------------- *)
datatype literal =
Boolean of bool
| Literal of Literal.literal;
fun negate (Boolean b) = (Boolean (not b))
| negate (Literal l) = (Literal (Literal.negate l));
fun literalFunctions (Boolean _) = NameAritySet.empty
| literalFunctions (Literal lit) = Literal.functions lit;
fun literalRelation (Boolean _) = NONE
| literalRelation (Literal lit) = SOME (Literal.relation lit);
fun literalToFormula (Boolean true) = Formula.True
| literalToFormula (Boolean false) = Formula.False
| literalToFormula (Literal lit) = Literal.toFormula lit;
fun literalFromFormula Formula.True = Boolean true
| literalFromFormula Formula.False = Boolean false
| literalFromFormula fm = Literal (Literal.fromFormula fm);
fun literalFreeVars (Boolean _) = NameSet.empty
| literalFreeVars (Literal lit) = Literal.freeVars lit;
fun literalSubst sub lit =
case lit of
Boolean _ => lit
| Literal l => Literal (Literal.subst sub l);
fun mapLiteral maps lit =
case lit of
Boolean _ => lit
| Literal (p,a) => Literal (p, mapAtom maps a);
fun destLiteral (Literal l) = l
| destLiteral _ = raise Error "destLiteral";
(* ------------------------------------------------------------------------- *)
(* Printing formulas using TPTP syntax. *)
(* ------------------------------------------------------------------------- *)
val ppVar = Parser.ppString;
local
fun term pp (Term.Var v) = ppVar pp v
| term pp (Term.Fn (c,[])) = Parser.addString pp c
| term pp (Term.Fn (f,tms)) =
(Parser.beginBlock pp Parser.Inconsistent 2;
Parser.addString pp (f ^ "(");
Parser.ppSequence "," term pp tms;
Parser.addString pp ")";
Parser.endBlock pp);
in
fun ppTerm pp tm =
(Parser.beginBlock pp Parser.Inconsistent 0;
term pp tm;
Parser.endBlock pp);
end;
fun ppAtom pp atm = ppTerm pp (Term.Fn atm);
local
open Formula;
fun fof pp (fm as And _) = assoc_binary pp ("&", stripConj fm)
| fof pp (fm as Or _) = assoc_binary pp ("|", stripDisj fm)
| fof pp (Imp a_b) = nonassoc_binary pp ("=>",a_b)
| fof pp (Iff a_b) = nonassoc_binary pp ("<=>",a_b)
| fof pp fm = unitary pp fm
and nonassoc_binary pp (s,a_b) =
Parser.ppBinop (" " ^ s) unitary unitary pp a_b
and assoc_binary pp (s,l) = Parser.ppSequence (" " ^ s) unitary pp l
and unitary pp fm =
if isForall fm then quantified pp ("!", stripForall fm)
else if isExists fm then quantified pp ("?", stripExists fm)
else if atom pp fm then ()
else if isNeg fm then
let
fun pr () = (Parser.addString pp "~"; Parser.addBreak pp (1,0))
val (n,fm) = Formula.stripNeg fm
in
Parser.beginBlock pp Parser.Inconsistent 2;
funpow n pr ();
unitary pp fm;
Parser.endBlock pp
end
else
(Parser.beginBlock pp Parser.Inconsistent 1;
Parser.addString pp "(";
fof pp fm;
Parser.addString pp ")";
Parser.endBlock pp)
and quantified pp (q,(vs,fm)) =
(Parser.beginBlock pp Parser.Inconsistent 2;
Parser.addString pp (q ^ " ");
Parser.beginBlock pp Parser.Inconsistent (String.size q);
Parser.addString pp "[";
Parser.ppSequence "," ppVar pp vs;
Parser.addString pp "] :";
Parser.endBlock pp;
Parser.addBreak pp (1,0);
unitary pp fm;
Parser.endBlock pp)
and atom pp True = (Parser.addString pp "$true"; true)
| atom pp False = (Parser.addString pp "$false"; true)
| atom pp fm =
case total destEq fm of
SOME a_b => (Parser.ppBinop " =" ppTerm ppTerm pp a_b; true)
| NONE =>
case total destNeq fm of
SOME a_b => (Parser.ppBinop " !=" ppTerm ppTerm pp a_b; true)
| NONE => case fm of Atom atm => (ppAtom pp atm; true) | _ => false;
in
fun ppFof pp fm =
(Parser.beginBlock pp Parser.Inconsistent 0;
fof pp fm;
Parser.endBlock pp);
end;
(* ------------------------------------------------------------------------- *)
(* TPTP clauses. *)
(* ------------------------------------------------------------------------- *)
type clause = literal list;
val clauseFunctions =
let
fun funcs (lit,acc) = NameAritySet.union (literalFunctions lit) acc
in
foldl funcs NameAritySet.empty
end;
val clauseRelations =
let
fun rels (lit,acc) =
case literalRelation lit of
NONE => acc
| SOME r => NameAritySet.add acc r
in
foldl rels NameAritySet.empty
end;
val clauseFreeVars =
let
fun fvs (lit,acc) = NameSet.union (literalFreeVars lit) acc
in
foldl fvs NameSet.empty
end;
fun clauseSubst sub lits = map (literalSubst sub) lits;
fun mapClause maps lits = map (mapLiteral maps) lits;
fun clauseToFormula lits = Formula.listMkDisj (map literalToFormula lits);
fun clauseFromFormula fm = map literalFromFormula (Formula.stripDisj fm);
fun clauseFromLiteralSet cl =
clauseFromFormula
(Formula.listMkDisj (LiteralSet.transform Literal.toFormula cl));
fun clauseFromThm th = clauseFromLiteralSet (Thm.clause th);
val ppClause = Parser.ppMap clauseToFormula ppFof;
(* ------------------------------------------------------------------------- *)
(* TPTP formulas. *)
(* ------------------------------------------------------------------------- *)
datatype formula =
CnfFormula of {name : string, role : string, clause : clause}
| FofFormula of {name : string, role : string, formula : Formula.formula};
fun destCnfFormula (CnfFormula x) = x
| destCnfFormula _ = raise Error "destCnfFormula";
val isCnfFormula = can destCnfFormula;
fun destFofFormula (FofFormula x) = x
| destFofFormula _ = raise Error "destFofFormula";
val isFofFormula = can destFofFormula;
fun formulaFunctions (CnfFormula {clause,...}) = clauseFunctions clause
| formulaFunctions (FofFormula {formula,...}) = Formula.functions formula;
fun formulaRelations (CnfFormula {clause,...}) = clauseRelations clause
| formulaRelations (FofFormula {formula,...}) = Formula.relations formula;
fun formulaFreeVars (CnfFormula {clause,...}) = clauseFreeVars clause
| formulaFreeVars (FofFormula {formula,...}) = Formula.freeVars formula;
fun mapFormula maps (CnfFormula {name,role,clause}) =
CnfFormula {name = name, role = role, clause = mapClause maps clause}
| mapFormula maps (FofFormula {name,role,formula}) =
FofFormula {name = name, role = role, formula = mapFof maps formula};
val formulasFunctions =
let
fun funcs (fm,acc) = NameAritySet.union (formulaFunctions fm) acc
in
foldl funcs NameAritySet.empty
end;
val formulasRelations =
let
fun rels (fm,acc) = NameAritySet.union (formulaRelations fm) acc
in
foldl rels NameAritySet.empty
end;
fun formulaIsConjecture (CnfFormula {role,...}) = role = ROLE_NEGATED_CONJECTURE
| formulaIsConjecture (FofFormula {role,...}) = role = ROLE_CONJECTURE;
local
open Parser;
infixr 8 ++
infixr 7 >>
infixr 6 ||
datatype token =
AlphaNum of string
| Punct of char
| Quote of string;
fun isAlphaNum #"_" = true
| isAlphaNum c = Char.isAlphaNum c;
local
val alphaNumToken = atLeastOne (some isAlphaNum) >> (AlphaNum o implode);
val punctToken =
let
val punctChars = "<>=-*+/\\?@|!$%&#^:;~()[]{}.,"
in
some (Char.contains punctChars) >> Punct
end;
val quoteToken =
let
val escapeParser =
exact #"'" >> singleton ||
exact #"\\" >> singleton
fun stopOn #"'" = true
| stopOn #"\n" = true
| stopOn _ = false
val quotedParser =
exact #"\\" ++ escapeParser >> op:: ||
some (not o stopOn) >> singleton
in
exact #"'" ++ many quotedParser ++ exact #"'" >>
(fn (_,(l,_)) => Quote (implode (List.concat l)))
end;
val lexToken = alphaNumToken || punctToken || quoteToken;
val space = many (some Char.isSpace) >> K ();
in
val lexer = (space ++ lexToken ++ space) >> (fn ((),(tok,())) => tok);
end;
fun someAlphaNum p =
maybe (fn AlphaNum s => if p s then SOME s else NONE | _ => NONE);
fun alphaNumParser s = someAlphaNum (equal s) >> K ();
fun isLower s = Char.isLower (String.sub (s,0));
val lowerParser = someAlphaNum isLower;
val upperParser = someAlphaNum (fn s => Char.isUpper (String.sub (s,0)));
val stringParser = lowerParser || upperParser;
val numberParser = someAlphaNum (List.all Char.isDigit o explode);
fun somePunct p =
maybe (fn Punct c => if p c then SOME c else NONE | _ => NONE);
fun punctParser c = somePunct (equal c) >> K ();
fun quoteParser p =
let
fun q s = if p s then s else "'" ^ s ^ "'"
in
maybe (fn Quote s => SOME (q s) | _ => NONE)
end;
local
fun f [] = raise Bug "symbolParser"
| f [x] = x
| f (h :: t) = (h ++ f t) >> K ();
in
fun symbolParser s = f (map punctParser (explode s));
end;
val definedParser =
punctParser #"$" ++ someAlphaNum (K true) >> (fn ((),s) => "$" ^ s);
val systemParser =
punctParser #"$" ++ punctParser #"$" ++ someAlphaNum (K true) >>
(fn ((),((),s)) => "$$" ^ s);
val nameParser = stringParser || numberParser || quoteParser (K false);
val roleParser = lowerParser;
local
fun isProposition s = isHdTlString Char.isLower isAlphaNum s;
in
val propositionParser =
someAlphaNum isProposition ||
definedParser || systemParser || quoteParser isProposition;
end;
local
fun isFunction s = isHdTlString Char.isLower isAlphaNum s;
in
val functionParser =
someAlphaNum isFunction ||
definedParser || systemParser || quoteParser isFunction;
end;
local
fun isConstant s =
isHdTlString Char.isLower isAlphaNum s orelse
isHdTlString Char.isDigit Char.isDigit s;
in
val constantParser =
someAlphaNum isConstant ||
definedParser || systemParser || quoteParser isConstant;
end;
val varParser = upperParser;
val varListParser =
(punctParser #"[" ++ varParser ++
many ((punctParser #"," ++ varParser) >> snd) ++
punctParser #"]") >>
(fn ((),(h,(t,()))) => h :: t);
fun termParser input =
((functionArgumentsParser >> Term.Fn) ||
nonFunctionArgumentsTermParser) input
and functionArgumentsParser input =
((functionParser ++ punctParser #"(" ++ termParser ++
many ((punctParser #"," ++ termParser) >> snd) ++
punctParser #")") >>
(fn (f,((),(t,(ts,())))) => (f, t :: ts))) input
and nonFunctionArgumentsTermParser input =
((varParser >> Term.Var) ||
(constantParser >> (fn n => Term.Fn (n,[])))) input
val binaryAtomParser =
((punctParser #"=" ++ termParser) >>
(fn ((),r) => fn l => Literal.mkEq (l,r))) ||
((symbolParser "!=" ++ termParser) >>
(fn ((),r) => fn l => Literal.mkNeq (l,r)));
val maybeBinaryAtomParser =
optional binaryAtomParser >>
(fn SOME f => (fn a => f (Term.Fn a))
| NONE => (fn a => (true,a)));
val literalAtomParser =
((functionArgumentsParser ++ maybeBinaryAtomParser) >>
(fn (a,f) => f a)) ||
((nonFunctionArgumentsTermParser ++ binaryAtomParser) >>
(fn (a,f) => f a)) ||
(propositionParser >>
(fn n => (true,(n,[]))));
val atomParser =
literalAtomParser >>
(fn (pol,("$true",[])) => Boolean pol
| (pol,("$false",[])) => Boolean (not pol)
| (pol,("$equal",[a,b])) => Literal (pol, Atom.mkEq (a,b))
| lit => Literal lit);
val literalParser =
((punctParser #"~" ++ atomParser) >> (negate o snd)) ||
atomParser;
val disjunctionParser =
(literalParser ++ many ((punctParser #"|" ++ literalParser) >> snd)) >>
(fn (h,t) => h :: t);
val clauseParser =
((punctParser #"(" ++ disjunctionParser ++ punctParser #")") >>
(fn ((),(c,())) => c)) ||
disjunctionParser;
(*
An exact transcription of the fof_formula syntax from
TPTP-v3.2.0/Documents/SyntaxBNF,
fun fofFormulaParser input =
(binaryFormulaParser || unitaryFormulaParser) input
and binaryFormulaParser input =
(nonAssocBinaryFormulaParser || assocBinaryFormulaParser) input
and nonAssocBinaryFormulaParser input =
((unitaryFormulaParser ++ binaryConnectiveParser ++
unitaryFormulaParser) >>
(fn (f,(c,g)) => c (f,g))) input
and binaryConnectiveParser input =
((symbolParser "<=>" >> K Formula.Iff) ||
(symbolParser "=>" >> K Formula.Imp) ||
(symbolParser "<=" >> K (fn (f,g) => Formula.Imp (g,f))) ||
(symbolParser "<~>" >> K (Formula.Not o Formula.Iff)) ||
(symbolParser "~|" >> K (Formula.Not o Formula.Or)) ||
(symbolParser "~&" >> K (Formula.Not o Formula.And))) input
and assocBinaryFormulaParser input =
(orFormulaParser || andFormulaParser) input
and orFormulaParser input =
((unitaryFormulaParser ++
atLeastOne ((punctParser #"|" ++ unitaryFormulaParser) >> snd)) >>
(fn (f,fs) => Formula.listMkDisj (f :: fs))) input
and andFormulaParser input =
((unitaryFormulaParser ++
atLeastOne ((punctParser #"&" ++ unitaryFormulaParser) >> snd)) >>
(fn (f,fs) => Formula.listMkConj (f :: fs))) input
and unitaryFormulaParser input =
(quantifiedFormulaParser ||
unaryFormulaParser ||
((punctParser #"(" ++ fofFormulaParser ++ punctParser #")") >>
(fn ((),(f,())) => f)) ||
(atomParser >>
(fn Boolean b => Formula.mkBoolean b
| Literal l => Literal.toFormula l))) input
and quantifiedFormulaParser input =
((quantifierParser ++ varListParser ++ punctParser #":" ++
unitaryFormulaParser) >>
(fn (q,(v,((),f))) => q (v,f))) input
and quantifierParser input =
((punctParser #"!" >> K Formula.listMkForall) ||
(punctParser #"?" >> K Formula.listMkExists)) input
and unaryFormulaParser input =
((unaryConnectiveParser ++ unitaryFormulaParser) >>
(fn (c,f) => c f)) input
and unaryConnectiveParser input =
(punctParser #"~" >> K Formula.Not) input;
*)
(*
This version is supposed to be equivalent to the spec version above,
but uses closures to avoid reparsing prefixes.
*)
fun fofFormulaParser input =
((unitaryFormulaParser ++ optional binaryFormulaParser) >>
(fn (f,NONE) => f | (f, SOME t) => t f)) input
and binaryFormulaParser input =
(nonAssocBinaryFormulaParser || assocBinaryFormulaParser) input
and nonAssocBinaryFormulaParser input =
((binaryConnectiveParser ++ unitaryFormulaParser) >>
(fn (c,g) => fn f => c (f,g))) input
and binaryConnectiveParser input =
((symbolParser "<=>" >> K Formula.Iff) ||
(symbolParser "=>" >> K Formula.Imp) ||
(symbolParser "<=" >> K (fn (f,g) => Formula.Imp (g,f))) ||
(symbolParser "<~>" >> K (Formula.Not o Formula.Iff)) ||
(symbolParser "~|" >> K (Formula.Not o Formula.Or)) ||
(symbolParser "~&" >> K (Formula.Not o Formula.And))) input
and assocBinaryFormulaParser input =
(orFormulaParser || andFormulaParser) input
and orFormulaParser input =
(atLeastOne ((punctParser #"|" ++ unitaryFormulaParser) >> snd) >>
(fn fs => fn f => Formula.listMkDisj (f :: fs))) input
and andFormulaParser input =
(atLeastOne ((punctParser #"&" ++ unitaryFormulaParser) >> snd) >>
(fn fs => fn f => Formula.listMkConj (f :: fs))) input
and unitaryFormulaParser input =
(quantifiedFormulaParser ||
unaryFormulaParser ||
((punctParser #"(" ++ fofFormulaParser ++ punctParser #")") >>
(fn ((),(f,())) => f)) ||
(atomParser >>
(fn Boolean b => Formula.mkBoolean b
| Literal l => Literal.toFormula l))) input
and quantifiedFormulaParser input =
((quantifierParser ++ varListParser ++ punctParser #":" ++
unitaryFormulaParser) >>
(fn (q,(v,((),f))) => q (v,f))) input
and quantifierParser input =
((punctParser #"!" >> K Formula.listMkForall) ||
(punctParser #"?" >> K Formula.listMkExists)) input
and unaryFormulaParser input =
((unaryConnectiveParser ++ unitaryFormulaParser) >>
(fn (c,f) => c f)) input
and unaryConnectiveParser input =
(punctParser #"~" >> K Formula.Not) input;
val cnfParser =
(alphaNumParser "cnf" ++ punctParser #"(" ++
nameParser ++ punctParser #"," ++
roleParser ++ punctParser #"," ++
clauseParser ++ punctParser #")" ++
punctParser #".") >>
(fn ((),((),(n,((),(r,((),(c,((),())))))))) =>
CnfFormula {name = n, role = r, clause = c});
val fofParser =
(alphaNumParser "fof" ++ punctParser #"(" ++
nameParser ++ punctParser #"," ++
roleParser ++ punctParser #"," ++
fofFormulaParser ++ punctParser #")" ++
punctParser #".") >>
(fn ((),((),(n,((),(r,((),(f,((),())))))))) =>
FofFormula {name = n, role = r, formula = f});
val formulaParser = cnfParser || fofParser;
fun parseChars parser chars =
let
val tokens = Parser.everything (lexer >> singleton) chars
in
Parser.everything (parser >> singleton) tokens
end;
fun canParseString parser s =
let
val chars = Stream.fromString s
in
case Stream.toList (parseChars parser chars) of
[_] => true
| _ => false
end
handle NoParse => false;
in
val parseFormula = parseChars formulaParser;
val isTptpRelation = canParseString functionParser
and isTptpProposition = canParseString propositionParser
and isTptpFunction = canParseString functionParser
and isTptpConstant = canParseString constantParser;
end;
fun formulaFromString s =
case Stream.toList (parseFormula (Stream.fromList (explode s))) of
[fm] => fm
| _ => raise Parser.NoParse;
local
local
fun explodeAlpha s = List.filter Char.isAlpha (explode s);
in
fun normTptpName s n =
case explodeAlpha n of
[] => s
| c :: cs => implode (Char.toLower c :: cs);
fun normTptpVar s n =
case explodeAlpha n of
[] => s
| c :: cs => implode (Char.toUpper c :: cs);
end;
fun normTptpFunc (n,0) = if isTptpConstant n then n else normTptpName "c" n
| normTptpFunc (n,_) = if isTptpFunction n then n else normTptpName "f" n;
fun normTptpRel (n,0) = if isTptpProposition n then n else normTptpName "p" n
| normTptpRel (n,_) = if isTptpRelation n then n else normTptpName "r" n;
fun mkMap set norm mapping =
let
val mapping = mappingToTptp mapping
fun mk (n_r,(a,m)) =
case NameArityMap.peek mapping n_r of
SOME t => (a, NameArityMap.insert m (n_r,t))
| NONE =>
let
val t = norm n_r
val (n,_) = n_r
val t = if t = n then n else Term.variantNum a t
in
(NameSet.add a t, NameArityMap.insert m (n_r,t))
end
val avoid =
let
fun mk ((n,r),s) =
let
val n = Option.getOpt (NameArityMap.peek mapping (n,r), n)
in
NameSet.add s n
end
in
NameAritySet.foldl mk NameSet.empty set
end
in
snd (NameAritySet.foldl mk (avoid, NameArityMap.new ()) set)
end;
fun mkTptpVar a v = Term.variantNum a (normTptpVar "V" v);
fun isTptpVar v = mkTptpVar NameSet.empty v = v;
fun alphaFormula fm =
let
fun addVar v a s =
let
val v' = mkTptpVar a v
val a = NameSet.add a v'
and s = if v = v' then s else Subst.insert s (v, Term.Var v')
in
(v',(a,s))
end
fun initVar (v,(a,s)) = snd (addVar v a s)
open Formula
fun alpha _ _ True = True
| alpha _ _ False = False
| alpha _ s (Atom atm) = Atom (Atom.subst s atm)
| alpha a s (Not p) = Not (alpha a s p)
| alpha a s (And (p,q)) = And (alpha a s p, alpha a s q)
| alpha a s (Or (p,q)) = Or (alpha a s p, alpha a s q)
| alpha a s (Imp (p,q)) = Imp (alpha a s p, alpha a s q)
| alpha a s (Iff (p,q)) = Iff (alpha a s p, alpha a s q)
| alpha a s (Forall (v,p)) =
let val (v,(a,s)) = addVar v a s in Forall (v, alpha a s p) end
| alpha a s (Exists (v,p)) =
let val (v,(a,s)) = addVar v a s in Exists (v, alpha a s p) end
val fvs = formulaFreeVars fm
val (avoid,fvs) = NameSet.partition isTptpVar fvs
val (avoid,sub) = NameSet.foldl initVar (avoid,Subst.empty) fvs
(*TRACE5
val () = Parser.ppTrace Subst.pp "Tptp.alpha: sub" sub
*)
in
case fm of
CnfFormula {name,role,clause} =>
CnfFormula {name = name, role = role, clause = clauseSubst sub clause}
| FofFormula {name,role,formula} =>
FofFormula {name = name, role = role, formula = alpha avoid sub formula}
end;
fun formulaToTptp maps fm = alphaFormula (mapFormula maps fm);
in
fun formulasToTptp formulas =
let
val funcs = formulasFunctions formulas
and rels = formulasRelations formulas
val functionMap = mkMap funcs normTptpFunc (!functionMapping)
and relationMap = mkMap rels normTptpRel (!relationMapping)
val maps = {functionMap = functionMap, relationMap = relationMap}
in
map (formulaToTptp maps) formulas
end;
end;
fun formulasFromTptp formulas =
let
val functionMap = mappingFromTptp (!functionMapping)
and relationMap = mappingFromTptp (!relationMapping)
val maps = {functionMap = functionMap, relationMap = relationMap}
in
map (mapFormula maps) formulas
end;
local
fun ppGen ppX pp (gen,name,role,x) =
(Parser.beginBlock pp Parser.Inconsistent (size gen + 1);
Parser.addString pp (gen ^ "(" ^ name ^ ",");
Parser.addBreak pp (1,0);
Parser.addString pp (role ^ ",");
Parser.addBreak pp (1,0);
Parser.beginBlock pp Parser.Consistent 1;
Parser.addString pp "(";
ppX pp x;
Parser.addString pp ")";
Parser.endBlock pp;
Parser.addString pp ").";
Parser.endBlock pp);
in
fun ppFormula pp (CnfFormula {name,role,clause}) =
ppGen ppClause pp ("cnf",name,role,clause)
| ppFormula pp (FofFormula {name,role,formula}) =
ppGen ppFof pp ("fof",name,role,formula);
end;
val formulaToString = Parser.toString ppFormula;
(* ------------------------------------------------------------------------- *)
(* TPTP problems. *)
(* ------------------------------------------------------------------------- *)
datatype goal =
Cnf of Problem.problem
| Fof of Formula.formula;
type problem = {comments : string list, formulas : formula list};
local
fun stripComments acc strm =
case strm of
Stream.NIL => (rev acc, Stream.NIL)
| Stream.CONS (line,rest) =>
case total destComment line of
SOME s => stripComments (s :: acc) (rest ())
| NONE => (rev acc, Stream.filter (not o isComment) strm);
in
fun read {filename} =
let
val lines = Stream.fromTextFile {filename = filename}
val lines = Stream.map chomp lines
val (comments,lines) = stripComments [] lines
val chars = Stream.concat (Stream.map Stream.fromString lines)
val formulas = Stream.toList (parseFormula chars)
val formulas = formulasFromTptp formulas
in
{comments = comments, formulas = formulas}
end;
end;
(* Quick testing
installPP Term.pp;
installPP Formula.pp;
val () = Term.isVarName := (fn s => Char.isUpper (String.sub (s,0)));
val TPTP_DIR = "/Users/Joe/ptr/tptp/tptp/";
val num1 = read {filename = TPTP_DIR ^ "NUM/NUM001-1.tptp"};
val lcl9 = read {filename = TPTP_DIR ^ "LCL/LCL009-1.tptp"};
val set11 = read {filename = TPTP_DIR ^ "SET/SET011+3.tptp"};
val swc128 = read {filename = TPTP_DIR ^ "SWC/SWC128-1.tptp"};
*)
local
fun mkCommentLine comment = mkComment comment ^ "\n";
fun formulaStream [] () = Stream.NIL
| formulaStream (h :: t) () =
Stream.CONS ("\n" ^ formulaToString h, formulaStream t);
in
fun write {filename} {comments,formulas} =
Stream.toTextFile
{filename = filename}
(Stream.append
(Stream.map mkCommentLine (Stream.fromList comments))
(formulaStream (formulasToTptp formulas)));
end;
(* ------------------------------------------------------------------------- *)
(* Converting TPTP problems to goal formulas. *)
(* ------------------------------------------------------------------------- *)
fun isCnfProblem ({formulas,...} : problem) =
let
val cnf = List.exists isCnfFormula formulas
and fof = List.exists isFofFormula formulas
in
case (cnf,fof) of
(false,false) => raise Error "TPTP problem has no formulas"
| (true,true) => raise Error "TPTP problem has both cnf and fof formulas"
| (cnf,_) => cnf
end;
fun hasConjecture ({formulas,...} : problem) =
List.exists formulaIsConjecture formulas;
local
fun cnfFormulaToClause (CnfFormula {clause,...}) =
if mem (Boolean true) clause then NONE
else
let
val lits = List.mapPartial (total destLiteral) clause
in
SOME (LiteralSet.fromList lits)
end
| cnfFormulaToClause (FofFormula _) = raise Bug "cnfFormulaToClause";
fun fofFormulaToGoal (FofFormula {formula,role,...}, {axioms,goals}) =
let
val fm = Formula.generalize formula
in
if role = ROLE_CONJECTURE then
{axioms = axioms, goals = fm :: goals}
else
{axioms = fm :: axioms, goals = goals}
end
| fofFormulaToGoal (CnfFormula _, _) = raise Bug "fofFormulaToGoal";
in
fun toGoal (prob as {formulas,...}) =
if isCnfProblem prob then
Cnf (List.mapPartial cnfFormulaToClause formulas)
else
Fof
let
val axioms_goals = {axioms = [], goals = []}
val axioms_goals = List.foldl fofFormulaToGoal axioms_goals formulas
in
case axioms_goals of
{axioms, goals = []} =>
Formula.Imp (Formula.listMkConj axioms, Formula.False)
| {axioms = [], goals} => Formula.listMkConj goals
| {axioms,goals} =>
Formula.Imp (Formula.listMkConj axioms, Formula.listMkConj goals)
end;
end;
local
fun fromClause cl n =
let
val name = "clause_" ^ Int.toString n
val role = ROLE_NEGATED_CONJECTURE
val clause = clauseFromLiteralSet cl
in
(CnfFormula {name = name, role = role, clause = clause}, n + 1)
end;
in
fun fromProblem prob =
let
val comments = []
and (formulas,_) = maps fromClause prob 0
in
{comments = comments, formulas = formulas}
end;
end;
local
fun refute cls =
let
val res = Resolution.new Resolution.default (map Thm.axiom cls)
in
case Resolution.loop res of
Resolution.Contradiction _ => true
| Resolution.Satisfiable _ => false
end;
in
fun prove filename =
let
val tptp = read filename
val problems =
case toGoal tptp of
Cnf prob => [prob]
| Fof goal => Problem.fromGoal goal
in
List.all refute problems
end;
end;
(* ------------------------------------------------------------------------- *)
(* TSTP proofs. *)
(* ------------------------------------------------------------------------- *)
local
fun ppAtomInfo pp atm =
case total Atom.destEq atm of
SOME (a,b) => ppAtom pp ("$equal",[a,b])
| NONE => ppAtom pp atm;
fun ppLiteralInfo pp (pol,atm) =
if pol then ppAtomInfo pp atm
else
(Parser.beginBlock pp Parser.Inconsistent 2;
Parser.addString pp "~";
Parser.addBreak pp (1,0);
ppAtomInfo pp atm;
Parser.endBlock pp);
val ppAssumeInfo = Parser.ppBracket "(" ")" ppAtomInfo;
val ppSubstInfo =
Parser.ppMap
Subst.toList
(Parser.ppSequence ","
(Parser.ppBracket "[" "]"
(Parser.ppBinop "," ppVar (Parser.ppBracket "(" ")" ppTerm))));
val ppResolveInfo = Parser.ppBracket "(" ")" ppAtomInfo;
val ppReflInfo = Parser.ppBracket "(" ")" ppTerm;
fun ppEqualityInfo pp (lit,path,res) =
(Parser.ppBracket "(" ")" ppLiteralInfo pp lit;
Parser.addString pp ",";
Parser.addBreak pp (1,0);
Term.ppPath pp path;
Parser.addString pp ",";
Parser.addBreak pp (1,0);
Parser.ppBracket "(" ")" ppTerm pp res);
fun ppInfInfo pp inf =
case inf of
Proof.Axiom _ => raise Bug "ppInfInfo"
| Proof.Assume atm => ppAssumeInfo pp atm
| Proof.Subst (sub,_) => ppSubstInfo pp sub
| Proof.Resolve (res,_,_) => ppResolveInfo pp res
| Proof.Refl tm => ppReflInfo pp tm
| Proof.Equality x => ppEqualityInfo pp x;
in
fun ppProof p prf =
let
fun thmString n = Int.toString n
val prf = enumerate prf
fun ppThm p th =
let
val cl = Thm.clause th
fun pred (_,(th',_)) = LiteralSet.equal (Thm.clause th') cl
in
case List.find pred prf of
NONE => Parser.addString p "(?)"
| SOME (n,_) => Parser.addString p (thmString n)
end
fun ppInf p inf =
let
val name = Thm.inferenceTypeToString (Proof.inferenceType inf)
val name = String.map Char.toLower name
in
Parser.addString p (name ^ ",");
Parser.addBreak p (1,0);
Parser.ppBracket "[" "]" ppInfInfo p inf;
case Proof.parents inf of
[] => ()
| ths =>
(Parser.addString p ",";
Parser.addBreak p (1,0);
Parser.ppList ppThm p ths)
end
fun ppTaut p inf =
(Parser.addString p "tautology,";
Parser.addBreak p (1,0);
Parser.ppBracket "[" "]" ppInf p inf)
fun ppStepInfo p (n,(th,inf)) =
let
val is_axiom = case inf of Proof.Axiom _ => true | _ => false
val name = thmString n
val role =
if is_axiom then "axiom"
else if Thm.isContradiction th then "theorem"
else "plain"
val cl = clauseFromThm th
in
Parser.addString p (name ^ ",");
Parser.addBreak p (1,0);
Parser.addString p (role ^ ",");
Parser.addBreak p (1,0);
Parser.ppBracket "(" ")" ppClause p cl;
if is_axiom then ()
else
let
val is_tautology = null (Proof.parents inf)
in
Parser.addString p ",";
Parser.addBreak p (1,0);
if is_tautology then
Parser.ppBracket "introduced(" ")" ppTaut p inf
else
Parser.ppBracket "inference(" ")" ppInf p inf
end
end
fun ppStep p step =
(Parser.ppBracket "cnf(" ")" ppStepInfo p step;
Parser.addString p ".";
Parser.addNewline p)
in
Parser.beginBlock p Parser.Consistent 0;
app (ppStep p) prf;
Parser.endBlock p
end
(*DEBUG
handle Error err => raise Bug ("Tptp.ppProof: shouldn't fail:\n" ^ err);
*)
end;
val proofToString = Parser.toString ppProof;
end
end;
print_depth 10;