(* $Id: metis.ML,v 1.8 2007/11/13 17:29:28 paulson Exp $ *) (******************************************************************) (* 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: Random.sig ****) (* Random -- random number generator *) signature Random = sig type generator val newgenseed : real -> generator val newgen : unit -> generator val random : generator -> real val randomlist : int * generator -> real list val range : int * int -> generator -> int val rangelist : int * int -> int * generator -> int list end (* [generator] is the type of random number generators, here the linear congruential generators from Paulson 1991, 1996. [newgenseed seed] returns a random number generator with the given seed. [newgen ()] returns a random number generator, taking the seed from the system clock. [random gen] returns a random number in the interval [0..1). [randomlist (n, gen)] returns a list of n random numbers in the interval [0,1). [range (min, max) gen] returns an integral random number in the range [min, max). Raises Fail if min > max. [rangelist (min, max) (n, gen)] returns a list of n integral random numbers in the range [min, max). Raises Fail if min > max. *) (**** Original file: Random.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 -- Moscow ML library 1995-04-23, 1999-02-24 *) structure Random :> Random = struct type generator = {seedref : real ref} (* Generating random numbers. Paulson, page 96 *) val a = 16807.0 val m = 2147483647.0 fun nextrand seed = let val t = a*seed in t - m * real(floor(t/m)) end fun newgenseed seed = {seedref = ref (nextrand seed)}; fun newgen () = newgenseed (Time.toReal (Time.now ())); fun random {seedref} = CRITICAL (fn () => (seedref := nextrand (! seedref); ! seedref / m)); fun randomlist (n, {seedref}) = CRITICAL (fn () => let val seed0 = ! seedref fun h 0 seed res = (seedref := seed; res) | h i seed res = h (i-1) (nextrand seed) (seed / m :: res) in h n seed0 [] end); fun range (min, max) = if min > max then raise Fail "Random.range: empty range" else fn {seedref} => CRITICAL (fn () => (seedref := nextrand (! seedref); min + (floor(real(max-min) * ! seedref / m)))); fun rangelist (min, max) = if min > max then raise Fail "Random.rangelist: empty range" else fn (n, {seedref}) => CRITICAL (fn () => let val seed0 = ! seedref fun h 0 seed res = (seedref := seed; res) | h i seed res = h (i-1) (nextrand seed) (min + floor(real(max-min) * seed / m) :: res) in h n seed0 [] end) end 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. *) (* ------------------------------------------------------------------------- *) (* ------------------------------------------------------------------------- *) (* Generating random values. *) (* ------------------------------------------------------------------------- *) local val gen = Random.newgenseed 1.0; in fun randomInt max = Random.range (0,max) gen; fun randomReal () = Random.random gen; end; fun randomBool () = randomInt 2 = 0; fun randomWord () = let val h = Word.fromInt (randomInt 65536) and l = Word.fromInt (randomInt 65536) in Word.orb (Word.<< (h,0w16), l) end; 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 ref, back: int ref, size: int} (* fixed size of element array *) with fun is_empty (QUEUE{front=ref ~1, back=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=ref ~1, back=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 ref with fun mk_indent_stack() = Istack (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 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 ref, (* Processed *) Ublocks : block_info list ref} (* Unprocessed *) | E of {Pend : int ref, Uend : int ref} | BR of {Distance_to_next_break : int 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 ref -> unit, (* increment circular buffer index *) space_left : int ref, (* remaining columns on page *) left_index : int ref, (* insertion index *) right_index : int ref, (* output index *) left_sum : int ref, (* size of strings and spaces inserted *) right_sum : int 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 = ref linewidth, left_index = ref 0, right_index = ref 0, left_sum = ref 0, right_sum = 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 = ref [], Ublocks = ref []}) = raise Fail "PP-error: print_BB" | print_BB (PPS{the_indent_stack,linewidth,space_left=ref sp_left,...}, {Pblocks as ref({How_to_indent=CONSISTENT,Block_size, Block_offset}::rst), Ublocks=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=ref sp_left,...}, {Pblocks as ref({Block_size,Block_offset,...}::rst),Ublocks=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=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 = ref 0, Uend = 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 = ref [], Ublocks = ref []}) => true | (BB _) => false | (E {Pend = ref 0, Uend = 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 = ref [], Ublocks = ref []} => raise Fail "PP-error: BB_size" | {Pblocks as ref(_::_),Ublocks=ref[]} => POS | {Ublocks, ...} => last_size (!Ublocks)) | token_size (E{Pend = ref 0, Uend = ref 0}) = raise Fail "PP-error: token_size.E" | token_size (E{Pend = 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 = ref [], Ublocks = ref []}) => (update(the_token_buffer,!left_index, initial_token_value); ++left_index) | (BB _) => () | (E {Pend = ref 0, Uend = 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 = ref (~(!right_sum)), Block_offset = offset, How_to_indent = style}::(!Ublocks) | _ => (update(the_token_buffer, !right_index, BB{Pblocks = ref [], Ublocks = ref [{Block_size = 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 = ref 1, Uend = 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 = ref 1, Pend = 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 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 = 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 ref[{Block_size,...}:block_info],...}) = (pop_bottom_delim_stack dstack; Block_size := INFINITY) | set (_,BB {Ublocks = 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 = 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) 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 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 = 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 = 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 = 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 ref; fun delay f = Lazy (ref (Thunk f)); fun force (Lazy (ref (Value v))) = v | force (Lazy (s as 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 = 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 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 = 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 ref (* The negation symbol *) val negation : Metis.Name.name ref (* Binder symbols *) val binders : Metis.Name.name list ref (* Bracket symbols *) val brackets : (Metis.Name.name * Metis.Name.name) list 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 ref = 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 ref = ref "~"; (* Binder symbols *) val binders : Name.name list ref = ref ["\\","!","?","?!"]; (* Bracket symbols *) val brackets : (Name.name * Name.name) list ref = 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 ref = ref (NameMap.new ()) in fn n => CRITICAL (fn () => let val 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 ref = ref 0 in fn () => CRITICAL (fn () => let val 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 ref, relations : (Atom.relationName * int list, bool) Map.map 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 = ref (Map.new cmp), relations = 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 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 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 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 = ref 0 in fn () => CRITICAL (fn () => case r of 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 = 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 ref val relationMapping : {name : string, arity : int, tptp : string} list 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 = 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 = 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;