--- a/src/Tools/Metis/metis.ML Mon Sep 13 21:19:13 2010 +0200
+++ b/src/Tools/Metis/metis.ML Mon Sep 13 21:21:45 2010 +0200
@@ -1,3 +1,19 @@
+(*
+ This file was generated by the "make-metis" script. A few changes were done
+ manually on the script's output; these are marked as follows:
+
+ MODIFIED by Jasmin Blanchette
+
+ Some of these changes are needed so that the ML files compiles at all. Others
+ are old tweaks by Lawrence C. Paulson that are needed, if nothing else, for
+ backward compatibility. The BSD License is used with Joe Hurd's kind
+ permission. Extract from a September 13, 2010 email written by Joe Hurd:
+
+ I hereby give permission to the Isabelle team to release Metis as part
+ of Isabelle, with the Metis code covered under the Isabelle BSD
+ license.
+*)
+
(******************************************************************)
(* GENERATED FILE -- DO NOT EDIT -- GENERATED FILE -- DO NOT EDIT *)
(* GENERATED FILE -- DO NOT EDIT -- GENERATED FILE -- DO NOT EDIT *)
@@ -8,11 +24,95 @@
structure Metis = struct structure Word = Word structure Array = Array end;
+(**** Original file: Random.sig ****)
+
+(* Title: Tools/random_word.ML
+ Author: Makarius
+
+Simple generator for pseudo-random numbers, using unboxed word
+arithmetic only. Unprotected concurrency introduces some true
+randomness.
+*)
+
+signature Random =
+sig
+
+ val nextWord : unit -> word
+
+ val nextBool : unit -> bool
+
+ val nextInt : int -> int (* k -> [0,k) *)
+
+ val nextReal : unit -> real (* () -> [0,1) *)
+
+end;
+
+(**** Original file: Random.sml ****)
+
+structure Metis = struct open Metis
+(* Metis-specific ML environment *)
+nonfix ++ -- RL;
+val explode = String.explode;
+val implode = String.implode;
+val print = TextIO.print;
+val foldl = List.foldl;
+val foldr = List.foldr;
+
+(* Title: Tools/random_word.ML
+ Author: Makarius
+
+Simple generator for pseudo-random numbers, using unboxed word
+arithmetic only. Unprotected concurrency introduces some true
+randomness.
+*)
+
+structure Random :> Random =
+struct
+
+(* random words: 0w0 <= result <= max_word *)
+
+(*minimum length of unboxed words on all supported ML platforms*)
+val _ = Word.wordSize >= 30
+ orelse raise Fail ("Bad platform word size");
+
+val max_word = 0wx3FFFFFFF;
+val top_bit = 0wx20000000;
+
+(*multiplier according to Borosh and Niederreiter (for modulus = 2^30),
+ see http://random.mat.sbg.ac.at/~charly/server/server.html*)
+val a = 0w777138309;
+fun step x = Word.andb (a * x + 0w1, max_word);
+
+fun change r f = r := f (!r);
+local val rand = (*Unsynchronized.*)Unsynchronized.ref 0w1
+in fun nextWord () = ((*Unsynchronized.*)change rand step; ! rand) end;
+
+(*NB: higher bits are more random than lower ones*)
+fun nextBool () = Word.andb (nextWord (), top_bit) = 0w0;
+
+
+(* random integers: 0 <= result < k *)
+
+val max_int = Word.toInt max_word;
+
+fun nextInt k =
+ if k <= 0 orelse k > max_int then raise Fail ("next_int: out of range")
+ else if k = max_int then Word.toInt (nextWord ())
+ else Word.toInt (Word.mod (nextWord (), Word.fromInt k));
+
+(* random reals: 0.0 <= result < 1.0 *)
+
+val scaling = real max_int + 1.0;
+fun nextReal () = real (Word.toInt (nextWord ())) / scaling;
+
+end;
+end;
+
(**** Original file: Portable.sig ****)
(* ========================================================================= *)
(* ML SPECIFIC FUNCTIONS *)
-(* Copyright (c) 2001-2007 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001-2007 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Portable =
@@ -37,12 +137,6 @@
val time : ('a -> 'b) -> 'a -> 'b
(* ------------------------------------------------------------------------- *)
-(* Critical section markup (multiprocessing) *)
-(* ------------------------------------------------------------------------- *)
-
-val CRITICAL: (unit -> 'a) -> 'a
-
-(* ------------------------------------------------------------------------- *)
(* Generating random values. *)
(* ------------------------------------------------------------------------- *)
@@ -56,11 +150,11 @@
end
-(**** Original file: PortableIsabelle.sml ****)
+(**** Original file: PortablePolyml.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -68,7 +162,8 @@
val foldr = List.foldr;
(* ========================================================================= *)
-(* Isabelle ML SPECIFIC FUNCTIONS *)
+(* POLY/ML SPECIFIC FUNCTIONS *)
+(* Copyright (c) 2008 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Portable :> Portable =
@@ -78,36 +173,65 @@
(* The ML implementation. *)
(* ------------------------------------------------------------------------- *)
-val ml = ml_system;
+val ml = "polyml";
(* ------------------------------------------------------------------------- *)
(* 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;
+fun pointerEqual (x : 'a, y : 'a) = PolyML.pointerEq(x,y);
+
+(* ------------------------------------------------------------------------- *)
+(* Timing function applications. *)
+(* ------------------------------------------------------------------------- *)
+
+fun time f x =
+ let
+ fun p t =
+ let
+ val s = Time.fmt 3 t
+ in
+ case size (List.last (String.fields (fn x => x = #".") s)) of
+ 3 => s
+ | 2 => s ^ "0"
+ | 1 => s ^ "00"
+ | _ => raise Fail "Portable.time"
+ end
+
+ val c = Timer.startCPUTimer ()
+
+ val r = Timer.startRealTimer ()
+
+ fun pt () =
+ let
+ val {usr,sys} = Timer.checkCPUTimer c
+ val real = Timer.checkRealTimer r
+ in
+ print
+ ("User: " ^ p usr ^ " System: " ^ p sys ^
+ " Real: " ^ p real ^ "\n")
+ end
+
+ val y = f x handle e => (pt (); raise e)
+
+ val () = pt ()
+ in
+ y
+ end;
(* ------------------------------------------------------------------------- *)
(* Generating random values. *)
(* ------------------------------------------------------------------------- *)
-val randomWord = Random_Word.next_word;
-val randomBool = Random_Word.next_bool;
-fun randomInt n = Random_Word.next_int 0 (n - 1);
-val randomReal = Random_Word.next_real;
-
-end;
+val randomWord = Random.nextWord;
+
+val randomBool = Random.nextBool;
+
+val randomInt = Random.nextInt;
+
+val randomReal = Random.nextReal;
+
+end
(* ------------------------------------------------------------------------- *)
(* Quotations a la Moscow ML. *)
@@ -116,868 +240,11 @@
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;
-val explode = String.explode;
-val implode = String.implode;
-val print = TextIO.print;
-val foldl = List.foldl;
-val foldr = List.foldr;
-
-(* ========================================================================= *)
-(* PP -- pretty-printing -- from the SML/NJ library *)
-(* *)
-(* Modified for Moscow ML from SML/NJ Library version 0.2 *)
-(* *)
-(* COPYRIGHT (c) 1992 by AT&T Bell Laboratories. *)
-(* *)
-(* STANDARD ML OF NEW JERSEY COPYRIGHT NOTICE, LICENSE AND DISCLAIMER. *)
-(* *)
-(* Permission to use, copy, modify, and distribute this software and its *)
-(* documentation for any purpose and without fee is hereby granted, *)
-(* provided that the above copyright notice appear in all copies and that *)
-(* both the copyright notice and this permission notice and warranty *)
-(* disclaimer appear in supporting documentation, and that the name of *)
-(* AT&T Bell Laboratories or any AT&T entity not be used in advertising *)
-(* or publicity pertaining to distribution of the software without *)
-(* specific, written prior permission. *)
-(* *)
-(* AT&T disclaims all warranties with regard to this software, including *)
-(* all implied warranties of merchantability and fitness. In no event *)
-(* shall AT&T be liable for any special, indirect or consequential *)
-(* damages or any damages whatsoever resulting from loss of use, data or *)
-(* profits, whether in an action of contract, negligence or other *)
-(* tortious action, arising out of or in connection with the use or *)
-(* performance of this software. *)
-(* ========================================================================= *)
-
-structure PP :> PP =
-struct
-
-open Array
-infix 9 sub
-
-(* the queue library, formerly in unit Ppqueue *)
-
-datatype Qend = Qback | Qfront
-
-exception QUEUE_FULL
-exception QUEUE_EMPTY
-exception REQUESTED_QUEUE_SIZE_TOO_SMALL
-
-local
- fun ++ i n = (i + 1) mod n
- fun -- i n = (i - 1) mod n
-in
-
-abstype 'a queue = QUEUE of {elems: 'a array, (* the contents *)
- front: int Unsynchronized.ref,
- back: int Unsynchronized.ref,
- size: int} (* fixed size of element array *)
-with
-
- fun is_empty (QUEUE{front=Unsynchronized.ref ~1, back=Unsynchronized.ref ~1,...}) = true
- | is_empty _ = false
-
- fun mk_queue n init_val =
- if (n < 2)
- then raise REQUESTED_QUEUE_SIZE_TOO_SMALL
- else QUEUE{elems=array(n, init_val), front=Unsynchronized.ref ~1, back=Unsynchronized.ref ~1, size=n}
-
- fun clear_queue (QUEUE{front,back,...}) = (front := ~1; back := ~1)
-
- fun queue_at Qfront (QUEUE{elems,front,...}) = elems sub !front
- | queue_at Qback (QUEUE{elems,back,...}) = elems sub !back
-
- fun en_queue Qfront item (Q as QUEUE{elems,front,back,size}) =
- if (is_empty Q)
- then (front := 0; back := 0;
- update(elems,0,item))
- else let val i = --(!front) size
- in if (i = !back)
- then raise QUEUE_FULL
- else (update(elems,i,item); front := i)
- end
- | en_queue Qback item (Q as QUEUE{elems,front,back,size}) =
- if (is_empty Q)
- then (front := 0; back := 0;
- update(elems,0,item))
- else let val i = ++(!back) size
- in if (i = !front)
- then raise QUEUE_FULL
- else (update(elems,i,item); back := i)
- end
-
- fun de_queue Qfront (Q as QUEUE{front,back,size,...}) =
- if (!front = !back) (* unitary queue *)
- then clear_queue Q
- else front := ++(!front) size
- | de_queue Qback (Q as QUEUE{front,back,size,...}) =
- if (!front = !back)
- then clear_queue Q
- else back := --(!back) size
-
-end (* abstype queue *)
-end (* local *)
-
-
-val magic: 'a -> 'a = fn x => x
-
-(* exception PP_FAIL of string *)
-
-datatype break_style = CONSISTENT | INCONSISTENT
-
-datatype break_info
- = FITS
- | PACK_ONTO_LINE of int
- | ONE_PER_LINE of int
-
-(* Some global values *)
-val INFINITY = 999999
-
-abstype indent_stack = Istack of break_info list Unsynchronized.ref
-with
- fun mk_indent_stack() = Istack (Unsynchronized.ref([]:break_info list))
- fun clear_indent_stack (Istack stk) = (stk := ([]:break_info list))
- fun top (Istack stk) =
- case !stk
- of nil => raise Fail "PP-error: top: badly formed block"
- | x::_ => x
- fun push (x,(Istack stk)) = stk := x::(!stk)
- fun pop (Istack stk) =
- case !stk
- of nil => raise Fail "PP-error: pop: badly formed block"
- | _::rest => stk := rest
-end
-
-(* The delim_stack is used to compute the size of blocks. It is
- a stack of indices into the token buffer. The indices only point to
- BBs, Es, and BRs. We push BBs and Es onto the stack until a BR
- is encountered. Then we compute sizes and pop. When we encounter
- a BR in the middle of a block, we compute the Distance_to_next_break
- of the previous BR in the block, if there was one.
-
- We need to be able to delete from the bottom of the delim_stack, so
- we use a queue, treated with a stack discipline, i.e., we only add
- items at the head of the queue, but can delete from the front or
- back of the queue.
-*)
-abstype delim_stack = Dstack of int queue
-with
- fun new_delim_stack i = Dstack(mk_queue i ~1)
- fun reset_delim_stack (Dstack q) = clear_queue q
-
- fun pop_delim_stack (Dstack d) = de_queue Qfront d
- fun pop_bottom_delim_stack (Dstack d) = de_queue Qback d
-
- fun push_delim_stack(i,Dstack d) = en_queue Qfront i d
- fun top_delim_stack (Dstack d) = queue_at Qfront d
- fun bottom_delim_stack (Dstack d) = queue_at Qback d
- fun delim_stack_is_empty (Dstack d) = is_empty d
-end
-
-
-type block_info = { Block_size : int Unsynchronized.ref,
- Block_offset : int,
- How_to_indent : break_style }
-
-
-(* Distance_to_next_break includes Number_of_blanks. Break_offset is
- a local offset for the break. BB represents a sequence of contiguous
- Begins. E represents a sequence of contiguous Ends.
-*)
-datatype pp_token
- = S of {String : string, Length : int}
- | BB of {Pblocks : block_info list Unsynchronized.ref, (* Processed *)
- Ublocks : block_info list Unsynchronized.ref} (* Unprocessed *)
- | E of {Pend : int Unsynchronized.ref, Uend : int Unsynchronized.ref}
- | BR of {Distance_to_next_break : int Unsynchronized.ref,
- Number_of_blanks : int,
- Break_offset : int}
-
-
-(* The initial values in the token buffer *)
-val initial_token_value = S{String = "", Length = 0}
-
-(* type ppstream = General.ppstream; *)
-datatype ppstream_ =
- PPS of
- {consumer : string -> unit,
- linewidth : int,
- flush : unit -> unit,
- the_token_buffer : pp_token array,
- the_delim_stack : delim_stack,
- the_indent_stack : indent_stack,
- ++ : int Unsynchronized.ref -> unit, (* increment circular buffer index *)
- space_left : int Unsynchronized.ref, (* remaining columns on page *)
- left_index : int Unsynchronized.ref, (* insertion index *)
- right_index : int Unsynchronized.ref, (* output index *)
- left_sum : int Unsynchronized.ref, (* size of strings and spaces inserted *)
- right_sum : int Unsynchronized.ref} (* size of strings and spaces printed *)
-
-type ppstream = ppstream_
-
-type ppconsumer = {consumer : string -> unit,
- linewidth : int,
- flush : unit -> unit}
-
-fun mk_ppstream {consumer,linewidth,flush} =
- if (linewidth<5)
- then raise Fail "PP-error: linewidth too_small"
- else let val buf_size = 3*linewidth
- in magic(
- PPS{consumer = consumer,
- linewidth = linewidth,
- flush = flush,
- the_token_buffer = array(buf_size, initial_token_value),
- the_delim_stack = new_delim_stack buf_size,
- the_indent_stack = mk_indent_stack (),
- ++ = fn i => i := ((!i + 1) mod buf_size),
- space_left = Unsynchronized.ref linewidth,
- left_index = Unsynchronized.ref 0, right_index = Unsynchronized.ref 0,
- left_sum = Unsynchronized.ref 0, right_sum = Unsynchronized.ref 0}
- ) : ppstream
- end
-
-fun dest_ppstream(pps : ppstream) =
- let val PPS{consumer,linewidth,flush, ...} = magic pps
- in {consumer=consumer,linewidth=linewidth,flush=flush} end
-
-local
- val space = " "
- fun mk_space (0,s) = String.concat s
- | mk_space (n,s) = mk_space((n-1), (space::s))
- val space_table = Vector.tabulate(100, fn i => mk_space(i,[]))
- fun nspaces n = Vector.sub(space_table, n)
- handle General.Subscript =>
- if n < 0
- then ""
- else let val n2 = n div 2
- val n2_spaces = nspaces n2
- val extra = if (n = (2*n2)) then "" else space
- in String.concat [n2_spaces, n2_spaces, extra]
- end
-in
- fun cr_indent (ofn, i) = ofn ("\n"^(nspaces i))
- fun indent (ofn,i) = ofn (nspaces i)
-end
-
-
-(* Print a the first member of a contiguous sequence of Begins. If there
- are "processed" Begins, then take the first off the list. If there are
- no processed Begins, take the last member off the "unprocessed" list.
- This works because the unprocessed list is treated as a stack, the
- processed list as a FIFO queue. How can an item on the unprocessed list
- be printable? Because of what goes on in add_string. See there for details.
-*)
-
-fun print_BB (_,{Pblocks = Unsynchronized.ref [], Ublocks = Unsynchronized.ref []}) =
- raise Fail "PP-error: print_BB"
- | print_BB (PPS{the_indent_stack,linewidth,space_left=Unsynchronized.ref sp_left,...},
- {Pblocks as Unsynchronized.ref({How_to_indent=CONSISTENT,Block_size,
- Block_offset}::rst),
- Ublocks=Unsynchronized.ref[]}) =
- (push ((if (!Block_size > sp_left)
- then ONE_PER_LINE (linewidth - (sp_left - Block_offset))
- else FITS),
- the_indent_stack);
- Pblocks := rst)
- | print_BB(PPS{the_indent_stack,linewidth,space_left=Unsynchronized.ref sp_left,...},
- {Pblocks as Unsynchronized.ref({Block_size,Block_offset,...}::rst),Ublocks=Unsynchronized.ref[]}) =
- (push ((if (!Block_size > sp_left)
- then PACK_ONTO_LINE (linewidth - (sp_left - Block_offset))
- else FITS),
- the_indent_stack);
- Pblocks := rst)
- | print_BB (PPS{the_indent_stack, linewidth, space_left=Unsynchronized.ref sp_left,...},
- {Ublocks,...}) =
- let fun pr_end_Ublock [{How_to_indent=CONSISTENT,Block_size,Block_offset}] l =
- (push ((if (!Block_size > sp_left)
- then ONE_PER_LINE (linewidth - (sp_left - Block_offset))
- else FITS),
- the_indent_stack);
- List.rev l)
- | pr_end_Ublock [{Block_size,Block_offset,...}] l =
- (push ((if (!Block_size > sp_left)
- then PACK_ONTO_LINE (linewidth - (sp_left - Block_offset))
- else FITS),
- the_indent_stack);
- List.rev l)
- | pr_end_Ublock (a::rst) l = pr_end_Ublock rst (a::l)
- | pr_end_Ublock _ _ =
- raise Fail "PP-error: print_BB: internal error"
- in Ublocks := pr_end_Ublock(!Ublocks) []
- end
-
-
-(* Uend should always be 0 when print_E is called. *)
-fun print_E (_,{Pend = Unsynchronized.ref 0, Uend = Unsynchronized.ref 0}) =
- raise Fail "PP-error: print_E"
- | print_E (istack,{Pend, ...}) =
- let fun pop_n_times 0 = ()
- | pop_n_times n = (pop istack; pop_n_times(n-1))
- in pop_n_times(!Pend); Pend := 0
- end
-
-
-(* "cursor" is how many spaces across the page we are. *)
-
-fun print_token(PPS{consumer,space_left,...}, S{String,Length}) =
- (consumer String;
- space_left := (!space_left) - Length)
- | print_token(ppstrm,BB b) = print_BB(ppstrm,b)
- | print_token(PPS{the_indent_stack,...},E e) =
- print_E (the_indent_stack,e)
- | print_token (PPS{the_indent_stack,space_left,consumer,linewidth,...},
- BR{Distance_to_next_break,Number_of_blanks,Break_offset}) =
- (case (top the_indent_stack)
- of FITS =>
- (space_left := (!space_left) - Number_of_blanks;
- indent (consumer,Number_of_blanks))
- | (ONE_PER_LINE cursor) =>
- let val new_cursor = cursor + Break_offset
- in space_left := linewidth - new_cursor;
- cr_indent (consumer,new_cursor)
- end
- | (PACK_ONTO_LINE cursor) =>
- if (!Distance_to_next_break > (!space_left))
- then let val new_cursor = cursor + Break_offset
- in space_left := linewidth - new_cursor;
- cr_indent(consumer,new_cursor)
- end
- else (space_left := !space_left - Number_of_blanks;
- indent (consumer,Number_of_blanks)))
-
-
-fun clear_ppstream(pps : ppstream) =
- let val PPS{the_token_buffer, the_delim_stack,
- the_indent_stack,left_sum, right_sum,
- left_index, right_index,space_left,linewidth,...}
- = magic pps
- val buf_size = 3*linewidth
- fun set i =
- if (i = buf_size)
- then ()
- else (update(the_token_buffer,i,initial_token_value);
- set (i+1))
- in set 0;
- clear_indent_stack the_indent_stack;
- reset_delim_stack the_delim_stack;
- left_sum := 0; right_sum := 0;
- left_index := 0; right_index := 0;
- space_left := linewidth
- end
-
-
-(* Move insertion head to right unless adding a BB and already at a BB,
- or unless adding an E and already at an E.
-*)
-fun BB_inc_right_index(PPS{the_token_buffer, right_index, ++,...})=
- case (the_token_buffer sub (!right_index))
- of (BB _) => ()
- | _ => ++right_index
-
-fun E_inc_right_index(PPS{the_token_buffer,right_index, ++,...})=
- case (the_token_buffer sub (!right_index))
- of (E _) => ()
- | _ => ++right_index
-
-
-fun pointers_coincide(PPS{left_index,right_index,the_token_buffer,...}) =
- (!left_index = !right_index) andalso
- (case (the_token_buffer sub (!left_index))
- of (BB {Pblocks = Unsynchronized.ref [], Ublocks = Unsynchronized.ref []}) => true
- | (BB _) => false
- | (E {Pend = Unsynchronized.ref 0, Uend = Unsynchronized.ref 0}) => true
- | (E _) => false
- | _ => true)
-
-fun advance_left (ppstrm as PPS{consumer,left_index,left_sum,
- the_token_buffer,++,...},
- instr) =
- let val NEG = ~1
- val POS = 0
- fun inc_left_sum (BR{Number_of_blanks, ...}) =
- left_sum := (!left_sum) + Number_of_blanks
- | inc_left_sum (S{Length, ...}) = left_sum := (!left_sum) + Length
- | inc_left_sum _ = ()
-
- fun last_size [{Block_size, ...}:block_info] = !Block_size
- | last_size (_::rst) = last_size rst
- | last_size _ = raise Fail "PP-error: last_size: internal error"
- fun token_size (S{Length, ...}) = Length
- | token_size (BB b) =
- (case b
- of {Pblocks = Unsynchronized.ref [], Ublocks = Unsynchronized.ref []} =>
- raise Fail "PP-error: BB_size"
- | {Pblocks as Unsynchronized.ref(_::_),Ublocks=Unsynchronized.ref[]} => POS
- | {Ublocks, ...} => last_size (!Ublocks))
- | token_size (E{Pend = Unsynchronized.ref 0, Uend = Unsynchronized.ref 0}) =
- raise Fail "PP-error: token_size.E"
- | token_size (E{Pend = Unsynchronized.ref 0, ...}) = NEG
- | token_size (E _) = POS
- | token_size (BR {Distance_to_next_break, ...}) = !Distance_to_next_break
- fun loop (instr) =
- if (token_size instr < 0) (* synchronization point; cannot advance *)
- then ()
- else (print_token(ppstrm,instr);
- inc_left_sum instr;
- if (pointers_coincide ppstrm)
- then ()
- else (* increment left index *)
-
- (* When this is evaluated, we know that the left_index has not yet
- caught up to the right_index. If we are at a BB or an E, we can
- increment left_index if there is no work to be done, i.e., all Begins
- or Ends have been dealt with. Also, we should do some housekeeping and
- clear the buffer at left_index, otherwise we can get errors when
- left_index catches up to right_index and we reset the indices to 0.
- (We might find ourselves adding a BB to an "old" BB, with the result
- that the index is not pushed onto the delim_stack. This can lead to
- mangled output.)
- *)
- (case (the_token_buffer sub (!left_index))
- of (BB {Pblocks = Unsynchronized.ref [], Ublocks = Unsynchronized.ref []}) =>
- (update(the_token_buffer,!left_index,
- initial_token_value);
- ++left_index)
- | (BB _) => ()
- | (E {Pend = Unsynchronized.ref 0, Uend = Unsynchronized.ref 0}) =>
- (update(the_token_buffer,!left_index,
- initial_token_value);
- ++left_index)
- | (E _) => ()
- | _ => ++left_index;
- loop (the_token_buffer sub (!left_index))))
- in loop instr
- end
-
-
-fun begin_block (pps : ppstream) style offset =
- let val ppstrm = magic pps : ppstream_
- val PPS{the_token_buffer, the_delim_stack,left_index,
- left_sum, right_index, right_sum,...}
- = ppstrm
- in
- (if (delim_stack_is_empty the_delim_stack)
- then (left_index := 0;
- left_sum := 1;
- right_index := 0;
- right_sum := 1)
- else BB_inc_right_index ppstrm;
- case (the_token_buffer sub (!right_index))
- of (BB {Ublocks, ...}) =>
- Ublocks := {Block_size = Unsynchronized.ref (~(!right_sum)),
- Block_offset = offset,
- How_to_indent = style}::(!Ublocks)
- | _ => (update(the_token_buffer, !right_index,
- BB{Pblocks = Unsynchronized.ref [],
- Ublocks = Unsynchronized.ref [{Block_size = Unsynchronized.ref (~(!right_sum)),
- Block_offset = offset,
- How_to_indent = style}]});
- push_delim_stack (!right_index, the_delim_stack)))
- end
-
-fun end_block(pps : ppstream) =
- let val ppstrm = magic pps : ppstream_
- val PPS{the_token_buffer,the_delim_stack,right_index,...}
- = ppstrm
- in
- if (delim_stack_is_empty the_delim_stack)
- then print_token(ppstrm,(E{Pend = Unsynchronized.ref 1, Uend = Unsynchronized.ref 0}))
- else (E_inc_right_index ppstrm;
- case (the_token_buffer sub (!right_index))
- of (E{Uend, ...}) => Uend := !Uend + 1
- | _ => (update(the_token_buffer,!right_index,
- E{Uend = Unsynchronized.ref 1, Pend = Unsynchronized.ref 0});
- push_delim_stack (!right_index, the_delim_stack)))
- end
-
-local
- fun check_delim_stack(PPS{the_token_buffer,the_delim_stack,right_sum,...}) =
- let fun check k =
- if (delim_stack_is_empty the_delim_stack)
- then ()
- else case(the_token_buffer sub (top_delim_stack the_delim_stack))
- of (BB{Ublocks as Unsynchronized.ref ((b as {Block_size, ...})::rst),
- Pblocks}) =>
- if (k>0)
- then (Block_size := !right_sum + !Block_size;
- Pblocks := b :: (!Pblocks);
- Ublocks := rst;
- if (List.length rst = 0)
- then pop_delim_stack the_delim_stack
- else ();
- check(k-1))
- else ()
- | (E{Pend,Uend}) =>
- (Pend := (!Pend) + (!Uend);
- Uend := 0;
- pop_delim_stack the_delim_stack;
- check(k + !Pend))
- | (BR{Distance_to_next_break, ...}) =>
- (Distance_to_next_break :=
- !right_sum + !Distance_to_next_break;
- pop_delim_stack the_delim_stack;
- if (k>0)
- then check k
- else ())
- | _ => raise Fail "PP-error: check_delim_stack.catchall"
- in check 0
- end
-in
-
- fun add_break (pps : ppstream) (n, break_offset) =
- let val ppstrm = magic pps : ppstream_
- val PPS{the_token_buffer,the_delim_stack,left_index,
- right_index,left_sum,right_sum, ++, ...}
- = ppstrm
- in
- (if (delim_stack_is_empty the_delim_stack)
- then (left_index := 0; right_index := 0;
- left_sum := 1; right_sum := 1)
- else ++right_index;
- update(the_token_buffer, !right_index,
- BR{Distance_to_next_break = Unsynchronized.ref (~(!right_sum)),
- Number_of_blanks = n,
- Break_offset = break_offset});
- check_delim_stack ppstrm;
- right_sum := (!right_sum) + n;
- push_delim_stack (!right_index,the_delim_stack))
- end
-
- fun flush_ppstream0(pps : ppstream) =
- let val ppstrm = magic pps : ppstream_
- val PPS{the_delim_stack,the_token_buffer, flush, left_index,...}
- = ppstrm
- in
- (if (delim_stack_is_empty the_delim_stack)
- then ()
- else (check_delim_stack ppstrm;
- advance_left(ppstrm, the_token_buffer sub (!left_index)));
- flush())
- end
-
-end (* local *)
-
-
-fun flush_ppstream ppstrm =
- (flush_ppstream0 ppstrm;
- clear_ppstream ppstrm)
-
-fun add_string (pps : ppstream) s =
- let val ppstrm = magic pps : ppstream_
- val PPS{the_token_buffer,the_delim_stack,consumer,
- right_index,right_sum,left_sum,
- left_index,space_left,++,...}
- = ppstrm
- fun fnl [{Block_size, ...}:block_info] = Block_size := INFINITY
- | fnl (_::rst) = fnl rst
- | fnl _ = raise Fail "PP-error: fnl: internal error"
-
- fun set(dstack,BB{Ublocks as Unsynchronized.ref[{Block_size,...}:block_info],...}) =
- (pop_bottom_delim_stack dstack;
- Block_size := INFINITY)
- | set (_,BB {Ublocks = Unsynchronized.ref(_::rst), ...}) = fnl rst
- | set (dstack, E{Pend,Uend}) =
- (Pend := (!Pend) + (!Uend);
- Uend := 0;
- pop_bottom_delim_stack dstack)
- | set (dstack,BR{Distance_to_next_break,...}) =
- (pop_bottom_delim_stack dstack;
- Distance_to_next_break := INFINITY)
- | set _ = raise (Fail "PP-error: add_string.set")
-
- fun check_stream () =
- if ((!right_sum - !left_sum) > !space_left)
- then if (delim_stack_is_empty the_delim_stack)
- then ()
- else let val i = bottom_delim_stack the_delim_stack
- in if (!left_index = i)
- then set (the_delim_stack, the_token_buffer sub i)
- else ();
- advance_left(ppstrm,
- the_token_buffer sub (!left_index));
- if (pointers_coincide ppstrm)
- then ()
- else check_stream ()
- end
- else ()
-
- val slen = String.size s
- val S_token = S{String = s, Length = slen}
-
- in if (delim_stack_is_empty the_delim_stack)
- then print_token(ppstrm,S_token)
- else (++right_index;
- update(the_token_buffer, !right_index, S_token);
- right_sum := (!right_sum)+slen;
- check_stream ())
- end
-
-
-(* Derived form. The +2 is for peace of mind *)
-fun add_newline (pps : ppstream) =
- let val PPS{linewidth, ...} = magic pps
- in add_break pps (linewidth+2,0) end
-
-(* Derived form. Builds a ppstream, sends pretty printing commands called in
- f to the ppstream, then flushes ppstream.
-*)
-
-fun with_pp ppconsumer ppfn =
- let val ppstrm = mk_ppstream ppconsumer
- in ppfn ppstrm;
- flush_ppstream0 ppstrm
- end
- handle Fail msg =>
- (TextIO.print (">>>> Pretty-printer failure: " ^ msg ^ "\n"))
-
-fun pp_to_string linewidth ppfn ob =
- let val l = Unsynchronized.ref ([]:string list)
- fun attach s = l := (s::(!l))
- in with_pp {consumer = attach, linewidth=linewidth, flush = fn()=>()}
- (fn ppstrm => ppfn ppstrm ob);
- String.concat(List.rev(!l))
- end
-end
-end;
-
(**** Original file: Useful.sig ****)
(* ========================================================================= *)
(* ML UTILITY FUNCTIONS *)
-(* Copyright (c) 2001-2005 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Useful =
@@ -991,8 +258,6 @@
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
@@ -1023,10 +288,6 @@
val exp : ('a * 'a -> 'a) -> 'a -> int -> 'a -> 'a
-val equal : ''a -> ''a -> bool
-
-val notEqual : ''a -> ''a -> bool
-
(* ------------------------------------------------------------------------- *)
(* Pairs. *)
(* ------------------------------------------------------------------------- *)
@@ -1060,6 +321,33 @@
val mwhile : ('a -> bool) -> ('a -> 's -> 'a * 's) -> 'a -> 's -> 'a * 's
(* ------------------------------------------------------------------------- *)
+(* Equality. *)
+(* ------------------------------------------------------------------------- *)
+
+val equal : ''a -> ''a -> bool
+
+val notEqual : ''a -> ''a -> bool
+
+val listEqual : ('a -> 'a -> bool) -> 'a list -> '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 (* false < true *)
+
+(* ------------------------------------------------------------------------- *)
(* Lists: note we count elements from 0. *)
(* ------------------------------------------------------------------------- *)
@@ -1073,15 +361,11 @@
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 zipWith : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
val zip : 'a list -> 'b list -> ('a * 'b) list
@@ -1091,6 +375,24 @@
val cart : 'a list -> 'b list -> ('a * 'b) list
+val takeWhile : ('a -> bool) -> 'a list -> 'a list
+
+val dropWhile : ('a -> bool) -> 'a list -> 'a list
+
+val divideWhile : ('a -> bool) -> 'a list -> 'a list * 'a list
+
+val groups : ('a * 's -> bool * 's) -> 's -> 'a list -> 'a list list
+
+val groupsBy : ('a * 'a -> bool) -> 'a list -> 'a list list
+
+val groupsByFst : (''a * 'b) list -> (''a * 'b list) list
+
+val groupsOf : int -> 'a list -> 'a list list
+
+val index : ('a -> bool) -> 'a list -> int option
+
+val enumerate : 'a list -> (int * 'a) list
+
val divide : 'a list -> int -> 'a list * 'a list (* Subscript *)
val revDivide : 'a list -> int -> 'a list * 'a list (* Subscript *)
@@ -1122,23 +424,6 @@
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. *)
(* ------------------------------------------------------------------------- *)
@@ -1186,12 +471,24 @@
val split : string -> string -> string list
+val capitalize : string -> string
+
val mkPrefix : string -> string -> string
val destPrefix : string -> string -> string
val isPrefix : string -> string -> bool
+val stripPrefix : (char -> bool) -> string -> string
+
+val mkSuffix : string -> string -> string
+
+val destSuffix : string -> string -> string
+
+val isSuffix : string -> string -> bool
+
+val stripSuffix : (char -> bool) -> string -> string
+
(* ------------------------------------------------------------------------- *)
(* Tables. *)
(* ------------------------------------------------------------------------- *)
@@ -1248,9 +545,11 @@
val date : unit -> string
+val readDirectory : {directory : string} -> {filename : string} list
+
val readTextFile : {filename : string} -> string
-val writeTextFile : {filename : string, contents : string} -> unit
+val writeTextFile : {contents : string, filename : string} -> unit
(* ------------------------------------------------------------------------- *)
(* Profiling and error reporting. *)
@@ -1258,6 +557,8 @@
val try : ('a -> 'b) -> 'a -> 'b
+val chat : string -> unit
+
val warn : string -> unit
val die : string -> 'exit
@@ -1274,7 +575,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -1283,43 +584,62 @@
(* ========================================================================= *)
(* ML UTILITY FUNCTIONS *)
-(* Copyright (c) 2001-2004 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Useful :> Useful =
struct
(* ------------------------------------------------------------------------- *)
-(* Exceptions *)
+(* 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 errorToStringOption err =
+ case err of
+ Error message => SOME ("Error: " ^ message)
+ | _ => NONE;
+
+(*mlton
+val () = MLton.Exn.addExnMessager errorToStringOption;
+*)
+
+fun errorToString err =
+ case errorToStringOption err of
+ SOME s => "\n" ^ s ^ "\n"
+ | NONE => raise Bug "errorToString: not an Error exception";
+
+fun bugToStringOption err =
+ case err of
+ Bug message => SOME ("Bug: " ^ message)
+ | _ => NONE;
+
+(*mlton
+val () = MLton.Exn.addExnMessager bugToStringOption;
+*)
+
+fun bugToString err =
+ case bugToStringOption err of
+ SOME s => "\n" ^ s ^ "\n"
+ | NONE => 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 *)
+(* ------------------------------------------------------------------------- *)
+(* Tracing. *)
(* ------------------------------------------------------------------------- *)
val tracePrint = Unsynchronized.ref print;
-fun trace message = !tracePrint message;
-
-(* ------------------------------------------------------------------------- *)
-(* Combinators *)
+fun trace mesg = !tracePrint mesg;
+
+(* ------------------------------------------------------------------------- *)
+(* Combinators. *)
(* ------------------------------------------------------------------------- *)
fun C f x y = f y x;
@@ -1343,12 +663,8 @@
f
end;
-val equal = fn x => fn y => x = y;
-
-val notEqual = fn x => fn y => x <> y;
-
-(* ------------------------------------------------------------------------- *)
-(* Pairs *)
+(* ------------------------------------------------------------------------- *)
+(* Pairs. *)
(* ------------------------------------------------------------------------- *)
fun fst (x,_) = x;
@@ -1366,7 +682,7 @@
val op## = fn (f,g) => fn (x,y) => (f x, g y);
(* ------------------------------------------------------------------------- *)
-(* State transformers *)
+(* State transformers. *)
(* ------------------------------------------------------------------------- *)
val unit : 'a -> 's -> 'a * 's = pair;
@@ -1380,118 +696,21 @@
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;
+(* Equality. *)
+(* ------------------------------------------------------------------------- *)
+
+val equal = fn x => fn y => x = y;
+
+val notEqual = fn x => fn y => x <> y;
+
+fun listEqual xEq =
+ let
+ fun xsEq [] [] = true
+ | xsEq (x1 :: xs1) (x2 :: xs2) = xEq x1 x2 andalso xsEq xs1 xs2
+ | xsEq _ _ = false
+ in
+ xsEq
+ end;
(* ------------------------------------------------------------------------- *)
(* Comparisons. *)
@@ -1527,11 +746,196 @@
| optionCompare _ (_,NONE) = GREATER
| optionCompare cmp (SOME x, SOME y) = cmp (x,y);
-fun boolCompare (true,false) = LESS
- | boolCompare (false,true) = GREATER
+fun boolCompare (false,true) = LESS
+ | boolCompare (true,false) = GREATER
| boolCompare _ = EQUAL;
(* ------------------------------------------------------------------------- *)
+(* 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 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 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;
+
+fun takeWhile p =
+ let
+ fun f acc [] = rev acc
+ | f acc (x :: xs) = if p x then f (x :: acc) xs else rev acc
+ in
+ f []
+ end;
+
+fun dropWhile p =
+ let
+ fun f [] = []
+ | f (l as x :: xs) = if p x then f xs else l
+ in
+ f
+ end;
+
+fun divideWhile p =
+ let
+ fun f acc [] = (rev acc, [])
+ | f acc (l as x :: xs) = if p x then f (x :: acc) xs else (rev acc, l)
+ in
+ f []
+ end;
+
+fun groups f =
+ let
+ fun group acc row x l =
+ case l of
+ [] =>
+ let
+ val acc = if null row then acc else rev row :: acc
+ in
+ rev acc
+ end
+ | h :: t =>
+ let
+ val (eor,x) = f (h,x)
+ in
+ if eor then group (rev row :: acc) [h] x t
+ else group acc (h :: row) x t
+ end
+ in
+ group [] []
+ end;
+
+fun groupsBy eq =
+ let
+ fun f (x_y as (x,_)) = (not (eq x_y), x)
+ in
+ fn [] => []
+ | h :: t =>
+ case groups f h t of
+ [] => [[h]]
+ | hs :: ts => (h :: hs) :: ts
+ end;
+
+local
+ fun fstEq ((x,_),(y,_)) = x = y;
+
+ fun collapse l = (fst (hd l), map snd l);
+in
+ fun groupsByFst l = map collapse (groupsBy fstEq l);
+end;
+
+fun groupsOf n =
+ let
+ fun f (_,i) = if i = 1 then (true,n) else (false, i - 1)
+ in
+ groups f (n + 1)
+ end;
+
+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 enumerate l = fst (maps (fn x => fn m => ((m, x), m + 1)) l 0);
+
+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;
+
+(* ------------------------------------------------------------------------- *)
(* Sorting and searching. *)
(* ------------------------------------------------------------------------- *)
@@ -1584,7 +988,7 @@
| l as [_] => l
| h :: t => mergePairs (findRuns [] h [] t)
end;
-
+
fun sortMap _ _ [] = []
| sortMap _ _ (l as [_]) = l
| sortMap f cmp xs =
@@ -1622,49 +1026,49 @@
end;
local
- fun both f g n = f n andalso g n;
-
- fun next f = let fun nx x = if f x then x else nx (x + 1) in nx end;
-
- fun looking res 0 _ _ = rev res
- | looking res n f x =
- let
- val p = next f x
- val res' = p :: res
- val f' = both f (not o divides p)
- in
- looking res' (n - 1) f' (p + 1)
- end;
-
- fun calcPrimes n = looking [] n (K true) 2
-
- val primesList = Unsynchronized.ref (calcPrimes 10);
-in
- fun primes n = CRITICAL (fn () =>
- if length (!primesList) <= n then List.take (!primesList,n)
+ fun calcPrimes ps n i =
+ if List.exists (fn p => divides p i) ps then calcPrimes ps n (i + 1)
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;
+ val ps = ps @ [i]
+ and n = n - 1
+ in
+ if n = 0 then ps else calcPrimes ps n (i + 1)
+ end;
+
+ val primesList = Unsynchronized.ref [2];
+in
+ fun primes n =
+ let
+ val Unsynchronized.ref ps = primesList
+
+ val k = n - length ps
+ in
+ if k <= 0 then List.take (ps,n)
+ else
+ let
+ val ps = calcPrimes ps k (List.last ps + 1)
+
+ val () = primesList := ps
+ in
+ ps
+ end
+ end;
+end;
+
+fun primesUpTo n =
+ let
+ fun f k =
+ let
+ val l = primes k
+
+ val p = List.last l
+ in
+ if p < n then f (2 * k) else takeWhile (fn j => j <= n) l
+ end
+ in
+ f 8
+ end;
(* ------------------------------------------------------------------------- *)
(* Strings. *)
@@ -1732,7 +1136,8 @@
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;
+fun join _ [] = ""
+ | join s (h :: t) = foldl (fn (x,y) => y ^ s ^ x) h t;
local
fun match [] l = SOME l
@@ -1755,23 +1160,58 @@
end;
end;
-(***
-fun pluralize {singular,plural} = fn 1 => singular | _ => plural;
-***)
+fun capitalize s =
+ if s = "" then s
+ else str (Char.toUpper (String.sub (s,0))) ^ String.extract (s,1,NONE);
fun mkPrefix p s = p ^ s;
fun destPrefix p =
let
- fun check s = String.isPrefix p s orelse raise Error "destPrefix"
+ fun check s =
+ if String.isPrefix p s then ()
+ else raise Error "destPrefix"
val sizeP = size p
in
- fn s => (check s; String.extract (s,sizeP,NONE))
+ fn s =>
+ let
+ val () = check s
+ in
+ String.extract (s,sizeP,NONE)
+ end
end;
fun isPrefix p = can (destPrefix p);
+fun stripPrefix pred s =
+ Substring.string (Substring.dropl pred (Substring.full s));
+
+fun mkSuffix p s = s ^ p;
+
+fun destSuffix p =
+ let
+ fun check s =
+ if String.isSuffix p s then ()
+ else raise Error "destSuffix"
+
+ val sizeP = size p
+ in
+ fn s =>
+ let
+ val () = check s
+
+ val sizeS = size s
+ in
+ String.substring (s, 0, sizeS - sizeP)
+ end
+ end;
+
+fun isSuffix p = can (destSuffix p);
+
+fun stripSuffix pred s =
+ Substring.string (Substring.dropr pred (Substring.full s));
+
(* ------------------------------------------------------------------------- *)
(* Tables. *)
(* ------------------------------------------------------------------------- *)
@@ -1790,13 +1230,20 @@
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));
+ zipWith pad column
+ end;
+
+local
+ fun alignTab aligns rows =
+ case aligns of
+ [] => map (K "") rows
+ | [{leftAlign = true, padChar = #" "}] => map hd rows
+ | align :: aligns =>
+ alignColumn align (map hd rows) (alignTab aligns (map tl rows));
+in
+ fun alignTable aligns rows =
+ if null rows then [] else alignTab aligns rows;
+end;
(* ------------------------------------------------------------------------- *)
(* Reals. *)
@@ -1839,22 +1286,22 @@
local
val generator = Unsynchronized.ref 0
in
- fun newInt () = CRITICAL (fn () =>
+ fun newInt () =
let
val n = !generator
val () = generator := n + 1
in
n
- end);
+ end;
fun newInts 0 = []
- | newInts k = CRITICAL (fn () =>
+ | newInts k =
let
val n = !generator
val () = generator := n + k
in
interval n k
- end);
+ end;
end;
fun withRef (r,new) f x =
@@ -1884,17 +1331,43 @@
fun date () = Date.fmt "%d/%m/%Y" (Date.fromTimeLocal (Time.now ()));
+fun readDirectory {directory = dir} =
+ let
+ val dirStrm = OS.FileSys.openDir dir
+
+ fun readAll acc =
+ case OS.FileSys.readDir dirStrm of
+ NONE => acc
+ | SOME file =>
+ let
+ val filename = OS.Path.joinDirFile {dir = dir, file = file}
+
+ val acc = {filename = filename} :: acc
+ in
+ readAll acc
+ end
+
+ val filenames = readAll []
+
+ val () = OS.FileSys.closeDir dirStrm
+ in
+ rev filenames
+ end;
+
fun readTextFile {filename} =
let
open TextIO
+
val h = openIn filename
+
val contents = inputAll h
+
val () = closeIn h
in
contents
end;
-fun writeTextFile {filename,contents} =
+fun writeTextFile {contents,filename} =
let
open TextIO
val h = openOut filename
@@ -1905,11 +1378,13 @@
end;
(* ------------------------------------------------------------------------- *)
-(* Profiling *)
-(* ------------------------------------------------------------------------- *)
-
-local
- fun err x s = TextIO.output (TextIO.stdErr, x ^ ": " ^ s ^ "\n");
+(* Profiling and error reporting. *)
+(* ------------------------------------------------------------------------- *)
+
+fun chat s = TextIO.output (TextIO.stdErr, s ^ "\n");
+
+local
+ fun err x s = chat (x ^ ": " ^ s);
in
fun try f x = f x
handle e as Error _ => (err "try" (errorToString e); raise e)
@@ -1959,7 +1434,7 @@
(* ========================================================================= *)
(* SUPPORT FOR LAZY EVALUATION *)
-(* Copyright (c) 2007 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2007 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Lazy =
@@ -1967,6 +1442,8 @@
type 'a lazy
+val quickly : 'a -> 'a lazy
+
val delay : (unit -> 'a) -> 'a lazy
val force : 'a lazy -> 'a
@@ -1979,7 +1456,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -1988,7 +1465,7 @@
(* ========================================================================= *)
(* SUPPORT FOR LAZY EVALUATION *)
-(* Copyright (c) 2007 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2007 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Lazy :> Lazy =
@@ -2000,16 +1477,21 @@
datatype 'a lazy = Lazy of 'a thunk Unsynchronized.ref;
+fun quickly v = Lazy (Unsynchronized.ref (Value v));
+
fun delay f = Lazy (Unsynchronized.ref (Thunk f));
-fun force (Lazy (Unsynchronized.ref (Value v))) = v
- | force (Lazy (s as Unsynchronized.ref (Thunk f))) =
- let
- val v = f ()
- val () = s := Value v
- in
- v
- end;
+fun force (Lazy s) =
+ case !s of
+ Value v => v
+ | Thunk f =>
+ let
+ val v = f ()
+
+ val () = s := Value v
+ in
+ v
+ end;
fun memoize f =
let
@@ -2021,11 +1503,370 @@
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 -> 'b stream) -> '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 -> 'b stream) -> 's ->
+ 'a stream -> 'b stream
+
+val mapConcat : ('a -> 'b stream) -> 'a stream -> 'b stream
+
+val mapsConcat :
+ ('a -> 's -> 'b stream * 's) -> ('s -> 'b stream) -> 's ->
+ 'a stream -> 'b stream
+
+(* ------------------------------------------------------------------------- *)
+(* Stream operations. *)
+(* ------------------------------------------------------------------------- *)
+
+val memoize : 'a stream -> 'a stream
+
+val listConcat : 'a list stream -> 'a stream
+
+val concatList : 'a stream list -> '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;
+val explode = String.explode;
+val implode = String.implode;
+val print = TextIO.print;
+val foldl = List.foldl;
+val foldr = List.foldr;
+
+(* ========================================================================= *)
+(* 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 stream type. *)
+(* ------------------------------------------------------------------------- *)
+
+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, m o t)
+ in
+ m
+ end;
+
+fun maps f g =
+ let
+ fun mm s Nil = g s
+ | mm s (Cons (x,xs)) =
+ let
+ val (y,s') = f x s
+ in
+ Cons (y, mm s' o 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 g =
+ let
+ fun mp s Nil = g s
+ | mp s (Cons (h,t)) =
+ let
+ val (h,s) = f h s
+ in
+ case h of
+ NONE => mp s (t ())
+ | SOME h => Cons (h, fn () => mp s (t ()))
+ end
+ in
+ mp
+ end;
+
+fun mapConcat f =
+ let
+ fun mc Nil = Nil
+ | mc (Cons (h,t)) = append (f h) (fn () => mc (t ()))
+ in
+ mc
+ end;
+
+fun mapsConcat f g =
+ let
+ fun mc s Nil = g s
+ | mc s (Cons (h,t)) =
+ let
+ val (l,s) = f h s
+ in
+ append l (fn () => mc s (t ()))
+ end
+ in
+ mc
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Stream operations. *)
+(* ------------------------------------------------------------------------- *)
+
+fun memoize Nil = Nil
+ | memoize (Cons (h,t)) = Cons (h, Lazy.memoize (fn () => memoize (t ())));
+
+fun concatList [] = Nil
+ | concatList (h :: t) = append h (fn () => concatList 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 listConcat s = concat (map fromList s);
+
+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: Ordered.sig ****)
(* ========================================================================= *)
(* ORDERED TYPES *)
-(* Copyright (c) 2004-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2004-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Ordered =
@@ -2061,7 +1902,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -2070,51 +1911,3377 @@
(* ========================================================================= *)
(* ORDERED TYPES *)
-(* Copyright (c) 2004-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2004-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure IntOrdered =
struct type t = int val compare = Int.compare end;
+structure IntPairOrdered =
+struct
+
+type t = int * int;
+
+fun compare ((i1,j1),(i2,j2)) =
+ case Int.compare (i1,i2) of
+ LESS => LESS
+ | EQUAL => Int.compare (j1,j2)
+ | GREATER => GREATER;
+
+end;
+
structure StringOrdered =
struct type t = string val compare = String.compare end;
end;
+(**** Original file: Map.sig ****)
+
+(* ========================================================================= *)
+(* FINITE MAPS IMPLEMENTED WITH RANDOMLY BALANCED TREES *)
+(* Copyright (c) 2004 Joe Hurd, distributed under the BSD License *)
+(* ========================================================================= *)
+
+signature Map =
+sig
+
+(* ------------------------------------------------------------------------- *)
+(* A type of finite maps. *)
+(* ------------------------------------------------------------------------- *)
+
+type ('key,'a) map
+
+(* ------------------------------------------------------------------------- *)
+(* Constructors. *)
+(* ------------------------------------------------------------------------- *)
+
+val new : ('key * 'key -> order) -> ('key,'a) map
+
+val singleton : ('key * 'key -> order) -> 'key * 'a -> ('key,'a) map
+
+(* ------------------------------------------------------------------------- *)
+(* Map size. *)
+(* ------------------------------------------------------------------------- *)
+
+val null : ('key,'a) map -> bool
+
+val size : ('key,'a) map -> int
+
+(* ------------------------------------------------------------------------- *)
+(* Querying. *)
+(* ------------------------------------------------------------------------- *)
+
+val peekKey : ('key,'a) map -> 'key -> ('key * 'a) option
+
+val peek : ('key,'a) map -> 'key -> 'a option
+
+val get : ('key,'a) map -> 'key -> 'a (* raises Error *)
+
+val pick : ('key,'a) map -> 'key * 'a (* an arbitrary key/value pair *)
+
+val nth : ('key,'a) map -> int -> 'key * 'a (* in the range [0,size-1] *)
+
+val random : ('key,'a) map -> 'key * 'a
+
+(* ------------------------------------------------------------------------- *)
+(* Adding. *)
+(* ------------------------------------------------------------------------- *)
+
+val insert : ('key,'a) map -> 'key * 'a -> ('key,'a) map
+
+val insertList : ('key,'a) map -> ('key * 'a) list -> ('key,'a) map
+
+(* ------------------------------------------------------------------------- *)
+(* Removing. *)
+(* ------------------------------------------------------------------------- *)
+
+val delete : ('key,'a) map -> 'key -> ('key,'a) map (* must be present *)
+
+val remove : ('key,'a) map -> 'key -> ('key,'a) map
+
+val deletePick : ('key,'a) map -> ('key * 'a) * ('key,'a) map
+
+val deleteNth : ('key,'a) map -> int -> ('key * 'a) * ('key,'a) map
+
+val deleteRandom : ('key,'a) map -> ('key * 'a) * ('key,'a) map
+
+(* ------------------------------------------------------------------------- *)
+(* Joining (all join operations prefer keys in the second map). *)
+(* ------------------------------------------------------------------------- *)
+
+val merge :
+ {first : 'key * 'a -> 'c option,
+ second : 'key * 'b -> 'c option,
+ both : ('key * 'a) * ('key * 'b) -> 'c option} ->
+ ('key,'a) map -> ('key,'b) map -> ('key,'c) map
+
+val union :
+ (('key * 'a) * ('key * 'a) -> 'a option) ->
+ ('key,'a) map -> ('key,'a) map -> ('key,'a) map
+
+val intersect :
+ (('key * 'a) * ('key * 'b) -> 'c option) ->
+ ('key,'a) map -> ('key,'b) map -> ('key,'c) map
+
+(* ------------------------------------------------------------------------- *)
+(* Set operations on the domain. *)
+(* ------------------------------------------------------------------------- *)
+
+val inDomain : 'key -> ('key,'a) map -> bool
+
+val unionDomain : ('key,'a) map -> ('key,'a) map -> ('key,'a) map
+
+val unionListDomain : ('key,'a) map list -> ('key,'a) map
+
+val intersectDomain : ('key,'a) map -> ('key,'a) map -> ('key,'a) map
+
+val intersectListDomain : ('key,'a) map list -> ('key,'a) map
+
+val differenceDomain : ('key,'a) map -> ('key,'a) map -> ('key,'a) map
+
+val symmetricDifferenceDomain : ('key,'a) map -> ('key,'a) map -> ('key,'a) map
+
+val equalDomain : ('key,'a) map -> ('key,'a) map -> bool
+
+val subsetDomain : ('key,'a) map -> ('key,'a) map -> bool
+
+val disjointDomain : ('key,'a) map -> ('key,'a) map -> bool
+
+(* ------------------------------------------------------------------------- *)
+(* Mapping and folding. *)
+(* ------------------------------------------------------------------------- *)
+
+val mapPartial : ('key * 'a -> 'b option) -> ('key,'a) map -> ('key,'b) 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 filter : ('key * 'a -> bool) -> ('key,'a) map -> ('key,'a) map
+
+val partition :
+ ('key * 'a -> bool) -> ('key,'a) map -> ('key,'a) map * ('key,'a) map
+
+val foldl : ('key * 'a * 's -> 's) -> 's -> ('key,'a) map -> 's
+
+val foldr : ('key * 'a * 's -> 's) -> 's -> ('key,'a) map -> 's
+
+(* ------------------------------------------------------------------------- *)
+(* Searching. *)
+(* ------------------------------------------------------------------------- *)
+
+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 count : ('key * 'a -> bool) -> ('key,'a) map -> int
+
+(* ------------------------------------------------------------------------- *)
+(* Comparing. *)
+(* ------------------------------------------------------------------------- *)
+
+val compare : ('a * 'a -> order) -> ('key,'a) map * ('key,'a) map -> order
+
+val equal : ('a -> 'a -> bool) -> ('key,'a) map -> ('key,'a) map -> bool
+
+(* ------------------------------------------------------------------------- *)
+(* Converting to and from lists. *)
+(* ------------------------------------------------------------------------- *)
+
+val keys : ('key,'a) map -> 'key list
+
+val values : ('key,'a) map -> 'a list
+
+val toList : ('key,'a) map -> ('key * 'a) list
+
+val fromList : ('key * 'key -> order) -> ('key * 'a) list -> ('key,'a) map
+
+(* ------------------------------------------------------------------------- *)
+(* Pretty-printing. *)
+(* ------------------------------------------------------------------------- *)
+
+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: Map.sml ****)
+
+structure Metis = struct open Metis
+(* Metis-specific ML environment *)
+nonfix ++ -- RL;
+val explode = String.explode;
+val implode = String.implode;
+val print = TextIO.print;
+val foldl = List.foldl;
+val foldr = List.foldr;
+
+(* ========================================================================= *)
+(* FINITE MAPS IMPLEMENTED WITH RANDOMLY BALANCED TREES *)
+(* Copyright (c) 2004 Joe Hurd, distributed under the BSD License *)
+(* ========================================================================= *)
+
+structure Map :> Map =
+struct
+
+(* ------------------------------------------------------------------------- *)
+(* Importing useful functionality. *)
+(* ------------------------------------------------------------------------- *)
+
+exception Bug = Useful.Bug;
+
+exception Error = Useful.Error;
+
+val pointerEqual = Portable.pointerEqual;
+
+val K = Useful.K;
+
+val randomInt = Portable.randomInt;
+
+val randomWord = Portable.randomWord;
+
+(* ------------------------------------------------------------------------- *)
+(* Converting a comparison function to an equality function. *)
+(* ------------------------------------------------------------------------- *)
+
+fun equalKey compareKey key1 key2 = compareKey (key1,key2) = EQUAL;
+
+(* ------------------------------------------------------------------------- *)
+(* Priorities. *)
+(* ------------------------------------------------------------------------- *)
+
+type priority = Word.word;
+
+val randomPriority = randomWord;
+
+val comparePriority = Word.compare;
+
+(* ------------------------------------------------------------------------- *)
+(* Priority search trees. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype ('key,'value) tree =
+ E
+ | T of ('key,'value) node
+
+and ('key,'value) node =
+ Node of
+ {size : int,
+ priority : priority,
+ left : ('key,'value) tree,
+ key : 'key,
+ value : 'value,
+ right : ('key,'value) tree};
+
+fun lowerPriorityNode node1 node2 =
+ let
+ val Node {priority = p1, ...} = node1
+ and Node {priority = p2, ...} = node2
+ in
+ comparePriority (p1,p2) = LESS
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Tree debugging functions. *)
+(* ------------------------------------------------------------------------- *)
+
+(*BasicDebug
+local
+ fun checkSizes tree =
+ case tree of
+ E => 0
+ | T (Node {size,left,right,...}) =>
+ let
+ val l = checkSizes left
+ and r = checkSizes right
+
+ val () = if l + 1 + r = size then () else raise Bug "wrong size"
+ in
+ size
+ end;
+
+ fun checkSorted compareKey x tree =
+ case tree of
+ E => x
+ | T (Node {left,key,right,...}) =>
+ let
+ val x = checkSorted compareKey x left
+
+ val () =
+ case x of
+ NONE => ()
+ | SOME k =>
+ case compareKey (k,key) of
+ LESS => ()
+ | EQUAL => raise Bug "duplicate keys"
+ | GREATER => raise Bug "unsorted"
+
+ val x = SOME key
+ in
+ checkSorted compareKey x right
+ end;
+
+ fun checkPriorities compareKey tree =
+ case tree of
+ E => NONE
+ | T node =>
+ let
+ val Node {left,right,...} = node
+
+ val () =
+ case checkPriorities compareKey left of
+ NONE => ()
+ | SOME lnode =>
+ if not (lowerPriorityNode node lnode) then ()
+ else raise Bug "left child has greater priority"
+
+ val () =
+ case checkPriorities compareKey right of
+ NONE => ()
+ | SOME rnode =>
+ if not (lowerPriorityNode node rnode) then ()
+ else raise Bug "right child has greater priority"
+ in
+ SOME node
+ end;
+in
+ fun treeCheckInvariants compareKey tree =
+ let
+ val _ = checkSizes tree
+
+ val _ = checkSorted compareKey NONE tree
+
+ val _ = checkPriorities compareKey tree
+ in
+ tree
+ end
+ handle Error err => raise Bug err;
+end;
+*)
+
+(* ------------------------------------------------------------------------- *)
+(* Tree operations. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeNew () = E;
+
+fun nodeSize (Node {size = x, ...}) = x;
+
+fun treeSize tree =
+ case tree of
+ E => 0
+ | T x => nodeSize x;
+
+fun mkNode priority left key value right =
+ let
+ val size = treeSize left + 1 + treeSize right
+ in
+ Node
+ {size = size,
+ priority = priority,
+ left = left,
+ key = key,
+ value = value,
+ right = right}
+ end;
+
+fun mkTree priority left key value right =
+ let
+ val node = mkNode priority left key value right
+ in
+ T node
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Extracting the left and right spines of a tree. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeLeftSpine acc tree =
+ case tree of
+ E => acc
+ | T node => nodeLeftSpine acc node
+
+and nodeLeftSpine acc node =
+ let
+ val Node {left,...} = node
+ in
+ treeLeftSpine (node :: acc) left
+ end;
+
+fun treeRightSpine acc tree =
+ case tree of
+ E => acc
+ | T node => nodeRightSpine acc node
+
+and nodeRightSpine acc node =
+ let
+ val Node {right,...} = node
+ in
+ treeRightSpine (node :: acc) right
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Singleton trees. *)
+(* ------------------------------------------------------------------------- *)
+
+fun mkNodeSingleton priority key value =
+ let
+ val size = 1
+ and left = E
+ and right = E
+ in
+ Node
+ {size = size,
+ priority = priority,
+ left = left,
+ key = key,
+ value = value,
+ right = right}
+ end;
+
+fun nodeSingleton (key,value) =
+ let
+ val priority = randomPriority ()
+ in
+ mkNodeSingleton priority key value
+ end;
+
+fun treeSingleton key_value =
+ let
+ val node = nodeSingleton key_value
+ in
+ T node
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Appending two trees, where every element of the first tree is less than *)
+(* every element of the second tree. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeAppend tree1 tree2 =
+ case tree1 of
+ E => tree2
+ | T node1 =>
+ case tree2 of
+ E => tree1
+ | T node2 =>
+ if lowerPriorityNode node1 node2 then
+ let
+ val Node {priority,left,key,value,right,...} = node2
+
+ val left = treeAppend tree1 left
+ in
+ mkTree priority left key value right
+ end
+ else
+ let
+ val Node {priority,left,key,value,right,...} = node1
+
+ val right = treeAppend right tree2
+ in
+ mkTree priority left key value right
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Appending two trees and a node, where every element of the first tree is *)
+(* less than the node, which in turn is less than every element of the *)
+(* second tree. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeCombine left node right =
+ let
+ val left_node = treeAppend left (T node)
+ in
+ treeAppend left_node right
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Searching a tree for a value. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treePeek compareKey pkey tree =
+ case tree of
+ E => NONE
+ | T node => nodePeek compareKey pkey node
+
+and nodePeek compareKey pkey node =
+ let
+ val Node {left,key,value,right,...} = node
+ in
+ case compareKey (pkey,key) of
+ LESS => treePeek compareKey pkey left
+ | EQUAL => SOME value
+ | GREATER => treePeek compareKey pkey right
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Tree paths. *)
+(* ------------------------------------------------------------------------- *)
+
+(* Generating a path by searching a tree for a key/value pair *)
+
+fun treePeekPath compareKey pkey path tree =
+ case tree of
+ E => (path,NONE)
+ | T node => nodePeekPath compareKey pkey path node
+
+and nodePeekPath compareKey pkey path node =
+ let
+ val Node {left,key,right,...} = node
+ in
+ case compareKey (pkey,key) of
+ LESS => treePeekPath compareKey pkey ((true,node) :: path) left
+ | EQUAL => (path, SOME node)
+ | GREATER => treePeekPath compareKey pkey ((false,node) :: path) right
+ end;
+
+(* A path splits a tree into left/right components *)
+
+fun addSidePath ((wentLeft,node),(leftTree,rightTree)) =
+ let
+ val Node {priority,left,key,value,right,...} = node
+ in
+ if wentLeft then (leftTree, mkTree priority rightTree key value right)
+ else (mkTree priority left key value leftTree, rightTree)
+ end;
+
+fun addSidesPath left_right = List.foldl addSidePath left_right;
+
+fun mkSidesPath path = addSidesPath (E,E) path;
+
+(* Updating the subtree at a path *)
+
+local
+ fun updateTree ((wentLeft,node),tree) =
+ let
+ val Node {priority,left,key,value,right,...} = node
+ in
+ if wentLeft then mkTree priority tree key value right
+ else mkTree priority left key value tree
+ end;
+in
+ fun updateTreePath tree = List.foldl updateTree tree;
+end;
+
+(* Inserting a new node at a path position *)
+
+fun insertNodePath node =
+ let
+ fun insert left_right path =
+ case path of
+ [] =>
+ let
+ val (left,right) = left_right
+ in
+ treeCombine left node right
+ end
+ | (step as (_,snode)) :: rest =>
+ if lowerPriorityNode snode node then
+ let
+ val left_right = addSidePath (step,left_right)
+ in
+ insert left_right rest
+ end
+ else
+ let
+ val (left,right) = left_right
+
+ val tree = treeCombine left node right
+ in
+ updateTreePath tree path
+ end
+ in
+ insert (E,E)
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Using a key to split a node into three components: the keys comparing *)
+(* less than the supplied key, an optional equal key, and the keys comparing *)
+(* greater. *)
+(* ------------------------------------------------------------------------- *)
+
+fun nodePartition compareKey pkey node =
+ let
+ val (path,pnode) = nodePeekPath compareKey pkey [] node
+ in
+ case pnode of
+ NONE =>
+ let
+ val (left,right) = mkSidesPath path
+ in
+ (left,NONE,right)
+ end
+ | SOME node =>
+ let
+ val Node {left,key,value,right,...} = node
+
+ val (left,right) = addSidesPath (left,right) path
+ in
+ (left, SOME (key,value), right)
+ end
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Searching a tree for a key/value pair. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treePeekKey compareKey pkey tree =
+ case tree of
+ E => NONE
+ | T node => nodePeekKey compareKey pkey node
+
+and nodePeekKey compareKey pkey node =
+ let
+ val Node {left,key,value,right,...} = node
+ in
+ case compareKey (pkey,key) of
+ LESS => treePeekKey compareKey pkey left
+ | EQUAL => SOME (key,value)
+ | GREATER => treePeekKey compareKey pkey right
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Inserting new key/values into the tree. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeInsert compareKey key_value tree =
+ let
+ val (key,value) = key_value
+
+ val (path,inode) = treePeekPath compareKey key [] tree
+ in
+ case inode of
+ NONE =>
+ let
+ val node = nodeSingleton (key,value)
+ in
+ insertNodePath node path
+ end
+ | SOME node =>
+ let
+ val Node {size,priority,left,right,...} = node
+
+ val node =
+ Node
+ {size = size,
+ priority = priority,
+ left = left,
+ key = key,
+ value = value,
+ right = right}
+ in
+ updateTreePath (T node) path
+ end
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Deleting key/value pairs: it raises an exception if the supplied key is *)
+(* not present. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeDelete compareKey dkey tree =
+ case tree of
+ E => raise Bug "Map.delete: element not found"
+ | T node => nodeDelete compareKey dkey node
+
+and nodeDelete compareKey dkey node =
+ let
+ val Node {size,priority,left,key,value,right} = node
+ in
+ case compareKey (dkey,key) of
+ LESS =>
+ let
+ val size = size - 1
+ and left = treeDelete compareKey dkey left
+
+ val node =
+ Node
+ {size = size,
+ priority = priority,
+ left = left,
+ key = key,
+ value = value,
+ right = right}
+ in
+ T node
+ end
+ | EQUAL => treeAppend left right
+ | GREATER =>
+ let
+ val size = size - 1
+ and right = treeDelete compareKey dkey right
+
+ val node =
+ Node
+ {size = size,
+ priority = priority,
+ left = left,
+ key = key,
+ value = value,
+ right = right}
+ in
+ T node
+ end
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Partial map is the basic operation for preserving tree structure. *)
+(* It applies its argument function to the elements *in order*. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeMapPartial f tree =
+ case tree of
+ E => E
+ | T node => nodeMapPartial f node
+
+and nodeMapPartial f (Node {priority,left,key,value,right,...}) =
+ let
+ val left = treeMapPartial f left
+ and vo = f (key,value)
+ and right = treeMapPartial f right
+ in
+ case vo of
+ NONE => treeAppend left right
+ | SOME value => mkTree priority left key value right
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Mapping tree values. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeMap f tree =
+ case tree of
+ E => E
+ | T node => T (nodeMap f node)
+
+and nodeMap f node =
+ let
+ val Node {size,priority,left,key,value,right} = node
+
+ val left = treeMap f left
+ and value = f (key,value)
+ and right = treeMap f right
+ in
+ Node
+ {size = size,
+ priority = priority,
+ left = left,
+ key = key,
+ value = value,
+ right = right}
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Merge is the basic operation for joining two trees. Note that the merged *)
+(* key is always the one from the second map. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeMerge compareKey f1 f2 fb tree1 tree2 =
+ case tree1 of
+ E => treeMapPartial f2 tree2
+ | T node1 =>
+ case tree2 of
+ E => treeMapPartial f1 tree1
+ | T node2 => nodeMerge compareKey f1 f2 fb node1 node2
+
+and nodeMerge compareKey f1 f2 fb node1 node2 =
+ let
+ val Node {priority,left,key,value,right,...} = node2
+
+ val (l,kvo,r) = nodePartition compareKey key node1
+
+ val left = treeMerge compareKey f1 f2 fb l left
+ and right = treeMerge compareKey f1 f2 fb r right
+
+ val vo =
+ case kvo of
+ NONE => f2 (key,value)
+ | SOME kv => fb (kv,(key,value))
+ in
+ case vo of
+ NONE => treeAppend left right
+ | SOME value =>
+ let
+ val node = mkNodeSingleton priority key value
+ in
+ treeCombine left node right
+ end
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* A union operation on trees. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeUnion compareKey f f2 tree1 tree2 =
+ case tree1 of
+ E => tree2
+ | T node1 =>
+ case tree2 of
+ E => tree1
+ | T node2 => nodeUnion compareKey f f2 node1 node2
+
+and nodeUnion compareKey f f2 node1 node2 =
+ if pointerEqual (node1,node2) then nodeMapPartial f2 node1
+ else
+ let
+ val Node {priority,left,key,value,right,...} = node2
+
+ val (l,kvo,r) = nodePartition compareKey key node1
+
+ val left = treeUnion compareKey f f2 l left
+ and right = treeUnion compareKey f f2 r right
+
+ val vo =
+ case kvo of
+ NONE => SOME value
+ | SOME kv => f (kv,(key,value))
+ in
+ case vo of
+ NONE => treeAppend left right
+ | SOME value =>
+ let
+ val node = mkNodeSingleton priority key value
+ in
+ treeCombine left node right
+ end
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* An intersect operation on trees. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeIntersect compareKey f t1 t2 =
+ case t1 of
+ E => E
+ | T n1 =>
+ case t2 of
+ E => E
+ | T n2 => nodeIntersect compareKey f n1 n2
+
+and nodeIntersect compareKey f n1 n2 =
+ let
+ val Node {priority,left,key,value,right,...} = n2
+
+ val (l,kvo,r) = nodePartition compareKey key n1
+
+ val left = treeIntersect compareKey f l left
+ and right = treeIntersect compareKey f r right
+
+ val vo =
+ case kvo of
+ NONE => NONE
+ | SOME kv => f (kv,(key,value))
+ in
+ case vo of
+ NONE => treeAppend left right
+ | SOME value => mkTree priority left key value right
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* A union operation on trees which simply chooses the second value. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeUnionDomain compareKey tree1 tree2 =
+ case tree1 of
+ E => tree2
+ | T node1 =>
+ case tree2 of
+ E => tree1
+ | T node2 =>
+ if pointerEqual (node1,node2) then tree2
+ else nodeUnionDomain compareKey node1 node2
+
+and nodeUnionDomain compareKey node1 node2 =
+ let
+ val Node {priority,left,key,value,right,...} = node2
+
+ val (l,_,r) = nodePartition compareKey key node1
+
+ val left = treeUnionDomain compareKey l left
+ and right = treeUnionDomain compareKey r right
+
+ val node = mkNodeSingleton priority key value
+ in
+ treeCombine left node right
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* An intersect operation on trees which simply chooses the second value. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeIntersectDomain compareKey tree1 tree2 =
+ case tree1 of
+ E => E
+ | T node1 =>
+ case tree2 of
+ E => E
+ | T node2 =>
+ if pointerEqual (node1,node2) then tree2
+ else nodeIntersectDomain compareKey node1 node2
+
+and nodeIntersectDomain compareKey node1 node2 =
+ let
+ val Node {priority,left,key,value,right,...} = node2
+
+ val (l,kvo,r) = nodePartition compareKey key node1
+
+ val left = treeIntersectDomain compareKey l left
+ and right = treeIntersectDomain compareKey r right
+ in
+ if Option.isSome kvo then mkTree priority left key value right
+ else treeAppend left right
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* A difference operation on trees. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeDifferenceDomain compareKey t1 t2 =
+ case t1 of
+ E => E
+ | T n1 =>
+ case t2 of
+ E => t1
+ | T n2 => nodeDifferenceDomain compareKey n1 n2
+
+and nodeDifferenceDomain compareKey n1 n2 =
+ if pointerEqual (n1,n2) then E
+ else
+ let
+ val Node {priority,left,key,value,right,...} = n1
+
+ val (l,kvo,r) = nodePartition compareKey key n2
+
+ val left = treeDifferenceDomain compareKey left l
+ and right = treeDifferenceDomain compareKey right r
+ in
+ if Option.isSome kvo then treeAppend left right
+ else mkTree priority left key value right
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* A subset operation on trees. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeSubsetDomain compareKey tree1 tree2 =
+ case tree1 of
+ E => true
+ | T node1 =>
+ case tree2 of
+ E => false
+ | T node2 => nodeSubsetDomain compareKey node1 node2
+
+and nodeSubsetDomain compareKey node1 node2 =
+ pointerEqual (node1,node2) orelse
+ let
+ val Node {size,left,key,right,...} = node1
+ in
+ size <= nodeSize node2 andalso
+ let
+ val (l,kvo,r) = nodePartition compareKey key node2
+ in
+ Option.isSome kvo andalso
+ treeSubsetDomain compareKey left l andalso
+ treeSubsetDomain compareKey right r
+ end
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Picking an arbitrary key/value pair from a tree. *)
+(* ------------------------------------------------------------------------- *)
+
+fun nodePick node =
+ let
+ val Node {key,value,...} = node
+ in
+ (key,value)
+ end;
+
+fun treePick tree =
+ case tree of
+ E => raise Bug "Map.treePick"
+ | T node => nodePick node;
+
+(* ------------------------------------------------------------------------- *)
+(* Removing an arbitrary key/value pair from a tree. *)
+(* ------------------------------------------------------------------------- *)
+
+fun nodeDeletePick node =
+ let
+ val Node {left,key,value,right,...} = node
+ in
+ ((key,value), treeAppend left right)
+ end;
+
+fun treeDeletePick tree =
+ case tree of
+ E => raise Bug "Map.treeDeletePick"
+ | T node => nodeDeletePick node;
+
+(* ------------------------------------------------------------------------- *)
+(* Finding the nth smallest key/value (counting from 0). *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeNth n tree =
+ case tree of
+ E => raise Bug "Map.treeNth"
+ | T node => nodeNth n node
+
+and nodeNth n node =
+ let
+ val Node {left,key,value,right,...} = node
+
+ val k = treeSize left
+ in
+ if n = k then (key,value)
+ else if n < k then treeNth n left
+ else treeNth (n - (k + 1)) right
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Removing the nth smallest key/value (counting from 0). *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeDeleteNth n tree =
+ case tree of
+ E => raise Bug "Map.treeDeleteNth"
+ | T node => nodeDeleteNth n node
+
+and nodeDeleteNth n node =
+ let
+ val Node {size,priority,left,key,value,right} = node
+
+ val k = treeSize left
+ in
+ if n = k then ((key,value), treeAppend left right)
+ else if n < k then
+ let
+ val (key_value,left) = treeDeleteNth n left
+
+ val size = size - 1
+
+ val node =
+ Node
+ {size = size,
+ priority = priority,
+ left = left,
+ key = key,
+ value = value,
+ right = right}
+ in
+ (key_value, T node)
+ end
+ else
+ let
+ val n = n - (k + 1)
+
+ val (key_value,right) = treeDeleteNth n right
+
+ val size = size - 1
+
+ val node =
+ Node
+ {size = size,
+ priority = priority,
+ left = left,
+ key = key,
+ value = value,
+ right = right}
+ in
+ (key_value, T node)
+ end
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Iterators. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype ('key,'value) iterator =
+ LR of ('key * 'value) * ('key,'value) tree * ('key,'value) node list
+ | RL of ('key * 'value) * ('key,'value) tree * ('key,'value) node list;
+
+fun fromSpineLR nodes =
+ case nodes of
+ [] => NONE
+ | Node {key,value,right,...} :: nodes =>
+ SOME (LR ((key,value),right,nodes));
+
+fun fromSpineRL nodes =
+ case nodes of
+ [] => NONE
+ | Node {key,value,left,...} :: nodes =>
+ SOME (RL ((key,value),left,nodes));
+
+fun addLR nodes tree = fromSpineLR (treeLeftSpine nodes tree);
+
+fun addRL nodes tree = fromSpineRL (treeRightSpine nodes tree);
+
+fun treeMkIterator tree = addLR [] tree;
+
+fun treeMkRevIterator tree = addRL [] tree;
+
+fun readIterator iter =
+ case iter of
+ LR (key_value,_,_) => key_value
+ | RL (key_value,_,_) => key_value;
+
+fun advanceIterator iter =
+ case iter of
+ LR (_,tree,nodes) => addLR nodes tree
+ | RL (_,tree,nodes) => addRL nodes tree;
+
+fun foldIterator f acc io =
+ case io of
+ NONE => acc
+ | SOME iter =>
+ let
+ val (key,value) = readIterator iter
+ in
+ foldIterator f (f (key,value,acc)) (advanceIterator iter)
+ end;
+
+fun findIterator pred io =
+ case io of
+ NONE => NONE
+ | SOME iter =>
+ let
+ val key_value = readIterator iter
+ in
+ if pred key_value then SOME key_value
+ else findIterator pred (advanceIterator iter)
+ end;
+
+fun firstIterator f io =
+ case io of
+ NONE => NONE
+ | SOME iter =>
+ let
+ val key_value = readIterator iter
+ in
+ case f key_value of
+ NONE => firstIterator f (advanceIterator iter)
+ | s => s
+ end;
+
+fun compareIterator compareKey compareValue io1 io2 =
+ case (io1,io2) of
+ (NONE,NONE) => EQUAL
+ | (NONE, SOME _) => LESS
+ | (SOME _, NONE) => GREATER
+ | (SOME i1, SOME i2) =>
+ let
+ val (k1,v1) = readIterator i1
+ and (k2,v2) = readIterator i2
+ in
+ case compareKey (k1,k2) of
+ LESS => LESS
+ | EQUAL =>
+ (case compareValue (v1,v2) of
+ LESS => LESS
+ | EQUAL =>
+ let
+ val io1 = advanceIterator i1
+ and io2 = advanceIterator i2
+ in
+ compareIterator compareKey compareValue io1 io2
+ end
+ | GREATER => GREATER)
+ | GREATER => GREATER
+ end;
+
+fun equalIterator equalKey equalValue io1 io2 =
+ case (io1,io2) of
+ (NONE,NONE) => true
+ | (NONE, SOME _) => false
+ | (SOME _, NONE) => false
+ | (SOME i1, SOME i2) =>
+ let
+ val (k1,v1) = readIterator i1
+ and (k2,v2) = readIterator i2
+ in
+ equalKey k1 k2 andalso
+ equalValue v1 v2 andalso
+ let
+ val io1 = advanceIterator i1
+ and io2 = advanceIterator i2
+ in
+ equalIterator equalKey equalValue io1 io2
+ end
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* A type of finite maps. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype ('key,'value) map =
+ Map of ('key * 'key -> order) * ('key,'value) tree;
+
+(* ------------------------------------------------------------------------- *)
+(* Map debugging functions. *)
+(* ------------------------------------------------------------------------- *)
+
+(*BasicDebug
+fun checkInvariants s m =
+ let
+ val Map (compareKey,tree) = m
+
+ val _ = treeCheckInvariants compareKey tree
+ in
+ m
+ end
+ handle Bug bug => raise Bug (s ^ "\n" ^ "Map.checkInvariants: " ^ bug);
+*)
+
+(* ------------------------------------------------------------------------- *)
+(* Constructors. *)
+(* ------------------------------------------------------------------------- *)
+
+fun new compareKey =
+ let
+ val tree = treeNew ()
+ in
+ Map (compareKey,tree)
+ end;
+
+fun singleton compareKey key_value =
+ let
+ val tree = treeSingleton key_value
+ in
+ Map (compareKey,tree)
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Map size. *)
+(* ------------------------------------------------------------------------- *)
+
+fun size (Map (_,tree)) = treeSize tree;
+
+fun null m = size m = 0;
+
+(* ------------------------------------------------------------------------- *)
+(* Querying. *)
+(* ------------------------------------------------------------------------- *)
+
+fun peekKey (Map (compareKey,tree)) key = treePeekKey compareKey key tree;
+
+fun peek (Map (compareKey,tree)) key = treePeek compareKey key tree;
+
+fun inDomain key m = Option.isSome (peek m key);
+
+fun get m key =
+ case peek m key of
+ NONE => raise Error "Map.get: element not found"
+ | SOME value => value;
+
+fun pick (Map (_,tree)) = treePick tree;
+
+fun nth (Map (_,tree)) n = treeNth n tree;
+
+fun random m =
+ let
+ val n = size m
+ in
+ if n = 0 then raise Bug "Map.random: empty"
+ else nth m (randomInt n)
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Adding. *)
+(* ------------------------------------------------------------------------- *)
+
+fun insert (Map (compareKey,tree)) key_value =
+ let
+ val tree = treeInsert compareKey key_value tree
+ in
+ Map (compareKey,tree)
+ end;
+
+(*BasicDebug
+val insert = fn m => fn kv =>
+ checkInvariants "Map.insert: result"
+ (insert (checkInvariants "Map.insert: input" m) kv);
+*)
+
+fun insertList m =
+ let
+ fun ins (key_value,acc) = insert acc key_value
+ in
+ List.foldl ins m
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Removing. *)
+(* ------------------------------------------------------------------------- *)
+
+fun delete (Map (compareKey,tree)) dkey =
+ let
+ val tree = treeDelete compareKey dkey tree
+ in
+ Map (compareKey,tree)
+ end;
+
+(*BasicDebug
+val delete = fn m => fn k =>
+ checkInvariants "Map.delete: result"
+ (delete (checkInvariants "Map.delete: input" m) k);
+*)
+
+fun remove m key = if inDomain key m then delete m key else m;
+
+fun deletePick (Map (compareKey,tree)) =
+ let
+ val (key_value,tree) = treeDeletePick tree
+ in
+ (key_value, Map (compareKey,tree))
+ end;
+
+(*BasicDebug
+val deletePick = fn m =>
+ let
+ val (kv,m) = deletePick (checkInvariants "Map.deletePick: input" m)
+ in
+ (kv, checkInvariants "Map.deletePick: result" m)
+ end;
+*)
+
+fun deleteNth (Map (compareKey,tree)) n =
+ let
+ val (key_value,tree) = treeDeleteNth n tree
+ in
+ (key_value, Map (compareKey,tree))
+ end;
+
+(*BasicDebug
+val deleteNth = fn m => fn n =>
+ let
+ val (kv,m) = deleteNth (checkInvariants "Map.deleteNth: input" m) n
+ in
+ (kv, checkInvariants "Map.deleteNth: result" m)
+ end;
+*)
+
+fun deleteRandom m =
+ let
+ val n = size m
+ in
+ if n = 0 then raise Bug "Map.deleteRandom: empty"
+ else deleteNth m (randomInt n)
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Joining (all join operations prefer keys in the second map). *)
+(* ------------------------------------------------------------------------- *)
+
+fun merge {first,second,both} (Map (compareKey,tree1)) (Map (_,tree2)) =
+ let
+ val tree = treeMerge compareKey first second both tree1 tree2
+ in
+ Map (compareKey,tree)
+ end;
+
+(*BasicDebug
+val merge = fn f => fn m1 => fn m2 =>
+ checkInvariants "Map.merge: result"
+ (merge f
+ (checkInvariants "Map.merge: input 1" m1)
+ (checkInvariants "Map.merge: input 2" m2));
+*)
+
+fun union f (Map (compareKey,tree1)) (Map (_,tree2)) =
+ let
+ fun f2 kv = f (kv,kv)
+
+ val tree = treeUnion compareKey f f2 tree1 tree2
+ in
+ Map (compareKey,tree)
+ end;
+
+(*BasicDebug
+val union = fn f => fn m1 => fn m2 =>
+ checkInvariants "Map.union: result"
+ (union f
+ (checkInvariants "Map.union: input 1" m1)
+ (checkInvariants "Map.union: input 2" m2));
+*)
+
+fun intersect f (Map (compareKey,tree1)) (Map (_,tree2)) =
+ let
+ val tree = treeIntersect compareKey f tree1 tree2
+ in
+ Map (compareKey,tree)
+ end;
+
+(*BasicDebug
+val intersect = fn f => fn m1 => fn m2 =>
+ checkInvariants "Map.intersect: result"
+ (intersect f
+ (checkInvariants "Map.intersect: input 1" m1)
+ (checkInvariants "Map.intersect: input 2" m2));
+*)
+
+(* ------------------------------------------------------------------------- *)
+(* Iterators over maps. *)
+(* ------------------------------------------------------------------------- *)
+
+fun mkIterator (Map (_,tree)) = treeMkIterator tree;
+
+fun mkRevIterator (Map (_,tree)) = treeMkRevIterator tree;
+
+(* ------------------------------------------------------------------------- *)
+(* Mapping and folding. *)
+(* ------------------------------------------------------------------------- *)
+
+fun mapPartial f (Map (compareKey,tree)) =
+ let
+ val tree = treeMapPartial f tree
+ in
+ Map (compareKey,tree)
+ end;
+
+(*BasicDebug
+val mapPartial = fn f => fn m =>
+ checkInvariants "Map.mapPartial: result"
+ (mapPartial f (checkInvariants "Map.mapPartial: input" m));
+*)
+
+fun map f (Map (compareKey,tree)) =
+ let
+ val tree = treeMap f tree
+ in
+ Map (compareKey,tree)
+ end;
+
+(*BasicDebug
+val map = fn f => fn m =>
+ checkInvariants "Map.map: result"
+ (map f (checkInvariants "Map.map: input" m));
+*)
+
+fun transform f = map (fn (_,value) => f value);
+
+fun filter pred =
+ let
+ fun f (key_value as (_,value)) =
+ if pred key_value then SOME value else NONE
+ in
+ mapPartial f
+ end;
+
+fun partition p =
+ let
+ fun np x = not (p x)
+ in
+ fn m => (filter p m, filter np m)
+ end;
+
+fun foldl f b m = foldIterator f b (mkIterator m);
+
+fun foldr f b m = foldIterator f b (mkRevIterator m);
+
+fun app f m = foldl (fn (key,value,()) => f (key,value)) () m;
+
+(* ------------------------------------------------------------------------- *)
+(* Searching. *)
+(* ------------------------------------------------------------------------- *)
+
+fun findl p m = findIterator p (mkIterator m);
+
+fun findr p m = findIterator p (mkRevIterator m);
+
+fun firstl f m = firstIterator f (mkIterator m);
+
+fun firstr f m = firstIterator f (mkRevIterator m);
+
+fun exists p m = Option.isSome (findl p m);
+
+fun all p =
+ let
+ fun np x = not (p x)
+ in
+ fn m => not (exists np m)
+ end;
+
+fun count pred =
+ let
+ fun f (k,v,acc) = if pred (k,v) then acc + 1 else acc
+ in
+ foldl f 0
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Comparing. *)
+(* ------------------------------------------------------------------------- *)
+
+fun compare compareValue (m1,m2) =
+ if pointerEqual (m1,m2) then EQUAL
+ else
+ case Int.compare (size m1, size m2) of
+ LESS => LESS
+ | EQUAL =>
+ let
+ val Map (compareKey,_) = m1
+
+ val io1 = mkIterator m1
+ and io2 = mkIterator m2
+ in
+ compareIterator compareKey compareValue io1 io2
+ end
+ | GREATER => GREATER;
+
+fun equal equalValue m1 m2 =
+ pointerEqual (m1,m2) orelse
+ (size m1 = size m2 andalso
+ let
+ val Map (compareKey,_) = m1
+
+ val io1 = mkIterator m1
+ and io2 = mkIterator m2
+ in
+ equalIterator (equalKey compareKey) equalValue io1 io2
+ end);
+
+(* ------------------------------------------------------------------------- *)
+(* Set operations on the domain. *)
+(* ------------------------------------------------------------------------- *)
+
+fun unionDomain (Map (compareKey,tree1)) (Map (_,tree2)) =
+ let
+ val tree = treeUnionDomain compareKey tree1 tree2
+ in
+ Map (compareKey,tree)
+ end;
+
+(*BasicDebug
+val unionDomain = fn m1 => fn m2 =>
+ checkInvariants "Map.unionDomain: result"
+ (unionDomain
+ (checkInvariants "Map.unionDomain: input 1" m1)
+ (checkInvariants "Map.unionDomain: input 2" m2));
+*)
+
+local
+ fun uncurriedUnionDomain (m,acc) = unionDomain acc m;
+in
+ fun unionListDomain ms =
+ case ms of
+ [] => raise Bug "Map.unionListDomain: no sets"
+ | m :: ms => List.foldl uncurriedUnionDomain m ms;
+end;
+
+fun intersectDomain (Map (compareKey,tree1)) (Map (_,tree2)) =
+ let
+ val tree = treeIntersectDomain compareKey tree1 tree2
+ in
+ Map (compareKey,tree)
+ end;
+
+(*BasicDebug
+val intersectDomain = fn m1 => fn m2 =>
+ checkInvariants "Map.intersectDomain: result"
+ (intersectDomain
+ (checkInvariants "Map.intersectDomain: input 1" m1)
+ (checkInvariants "Map.intersectDomain: input 2" m2));
+*)
+
+local
+ fun uncurriedIntersectDomain (m,acc) = intersectDomain acc m;
+in
+ fun intersectListDomain ms =
+ case ms of
+ [] => raise Bug "Map.intersectListDomain: no sets"
+ | m :: ms => List.foldl uncurriedIntersectDomain m ms;
+end;
+
+fun differenceDomain (Map (compareKey,tree1)) (Map (_,tree2)) =
+ let
+ val tree = treeDifferenceDomain compareKey tree1 tree2
+ in
+ Map (compareKey,tree)
+ end;
+
+(*BasicDebug
+val differenceDomain = fn m1 => fn m2 =>
+ checkInvariants "Map.differenceDomain: result"
+ (differenceDomain
+ (checkInvariants "Map.differenceDomain: input 1" m1)
+ (checkInvariants "Map.differenceDomain: input 2" m2));
+*)
+
+fun symmetricDifferenceDomain m1 m2 =
+ unionDomain (differenceDomain m1 m2) (differenceDomain m2 m1);
+
+fun equalDomain m1 m2 = equal (K (K true)) m1 m2;
+
+fun subsetDomain (Map (compareKey,tree1)) (Map (_,tree2)) =
+ treeSubsetDomain compareKey tree1 tree2;
+
+fun disjointDomain m1 m2 = null (intersectDomain m1 m2);
+
+(* ------------------------------------------------------------------------- *)
+(* Converting to and from lists. *)
+(* ------------------------------------------------------------------------- *)
+
+fun keys m = foldr (fn (key,_,l) => key :: l) [] m;
+
+fun values m = foldr (fn (_,value,l) => value :: l) [] m;
+
+fun toList m = foldr (fn (key,value,l) => (key,value) :: l) [] m;
+
+fun fromList compareKey l =
+ let
+ val m = new compareKey
+ in
+ insertList m l
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Pretty-printing. *)
+(* ------------------------------------------------------------------------- *)
+
+fun toString m = "<" ^ (if null m then "" else Int.toString (size m)) ^ ">";
+
+end
+end;
+
+(**** Original file: KeyMap.sig ****)
+
+(* ========================================================================= *)
+(* FINITE MAPS WITH A FIXED KEY TYPE *)
+(* Copyright (c) 2004 Joe Hurd, distributed under the BSD License *)
+(* ========================================================================= *)
+
+signature KeyMap =
+sig
+
+(* ------------------------------------------------------------------------- *)
+(* A type of map keys. *)
+(* ------------------------------------------------------------------------- *)
+
+type key
+
+(* ------------------------------------------------------------------------- *)
+(* A type of finite maps. *)
+(* ------------------------------------------------------------------------- *)
+
+type 'a map
+
+(* ------------------------------------------------------------------------- *)
+(* Constructors. *)
+(* ------------------------------------------------------------------------- *)
+
+val new : unit -> 'a map
+
+val singleton : key * 'a -> 'a map
+
+(* ------------------------------------------------------------------------- *)
+(* Map size. *)
+(* ------------------------------------------------------------------------- *)
+
+val null : 'a map -> bool
+
+val size : 'a map -> int
+
+(* ------------------------------------------------------------------------- *)
+(* Querying. *)
+(* ------------------------------------------------------------------------- *)
+
+val peekKey : 'a map -> key -> (key * 'a) option
+
+val peek : 'a map -> key -> 'a option
+
+val get : 'a map -> key -> 'a (* raises Error *)
+
+val pick : 'a map -> key * 'a (* an arbitrary key/value pair *)
+
+val nth : 'a map -> int -> key * 'a (* in the range [0,size-1] *)
+
+val random : 'a map -> key * 'a
+
+(* ------------------------------------------------------------------------- *)
+(* Adding. *)
+(* ------------------------------------------------------------------------- *)
+
+val insert : 'a map -> key * 'a -> 'a map
+
+val insertList : 'a map -> (key * 'a) list -> 'a map
+
+(* ------------------------------------------------------------------------- *)
+(* Removing. *)
+(* ------------------------------------------------------------------------- *)
+
+val delete : 'a map -> key -> 'a map (* must be present *)
+
+val remove : 'a map -> key -> 'a map
+
+val deletePick : 'a map -> (key * 'a) * 'a map
+
+val deleteNth : 'a map -> int -> (key * 'a) * 'a map
+
+val deleteRandom : 'a map -> (key * 'a) * 'a map
+
+(* ------------------------------------------------------------------------- *)
+(* Joining (all join operations prefer keys in the second map). *)
+(* ------------------------------------------------------------------------- *)
+
+val merge :
+ {first : key * 'a -> 'c option,
+ second : key * 'b -> 'c option,
+ both : (key * 'a) * (key * 'b) -> 'c option} ->
+ 'a map -> 'b map -> 'c map
+
+val union :
+ ((key * 'a) * (key * 'a) -> 'a option) ->
+ 'a map -> 'a map -> 'a map
+
+val intersect :
+ ((key * 'a) * (key * 'b) -> 'c option) ->
+ 'a map -> 'b map -> 'c map
+
+(* ------------------------------------------------------------------------- *)
+(* Set operations on the domain. *)
+(* ------------------------------------------------------------------------- *)
+
+val inDomain : key -> 'a map -> bool
+
+val unionDomain : 'a map -> 'a map -> 'a map
+
+val unionListDomain : 'a map list -> 'a map
+
+val intersectDomain : 'a map -> 'a map -> 'a map
+
+val intersectListDomain : 'a map list -> 'a map
+
+val differenceDomain : 'a map -> 'a map -> 'a map
+
+val symmetricDifferenceDomain : 'a map -> 'a map -> 'a map
+
+val equalDomain : 'a map -> 'a map -> bool
+
+val subsetDomain : 'a map -> 'a map -> bool
+
+val disjointDomain : 'a map -> 'a map -> bool
+
+(* ------------------------------------------------------------------------- *)
+(* Mapping and folding. *)
+(* ------------------------------------------------------------------------- *)
+
+val mapPartial : (key * 'a -> 'b option) -> 'a map -> 'b 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 filter : (key * 'a -> bool) -> 'a map -> 'a map
+
+val partition :
+ (key * 'a -> bool) -> 'a map -> 'a map * 'a map
+
+val foldl : (key * 'a * 's -> 's) -> 's -> 'a map -> 's
+
+val foldr : (key * 'a * 's -> 's) -> 's -> 'a map -> 's
+
+(* ------------------------------------------------------------------------- *)
+(* Searching. *)
+(* ------------------------------------------------------------------------- *)
+
+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 count : (key * 'a -> bool) -> 'a map -> int
+
+(* ------------------------------------------------------------------------- *)
+(* Comparing. *)
+(* ------------------------------------------------------------------------- *)
+
+val compare : ('a * 'a -> order) -> 'a map * 'a map -> order
+
+val equal : ('a -> 'a -> bool) -> 'a map -> 'a map -> bool
+
+(* ------------------------------------------------------------------------- *)
+(* Converting to and from lists. *)
+(* ------------------------------------------------------------------------- *)
+
+val keys : 'a map -> key list
+
+val values : 'a map -> 'a list
+
+val toList : 'a map -> (key * 'a) list
+
+val fromList : (key * 'a) list -> 'a map
+
+(* ------------------------------------------------------------------------- *)
+(* Pretty-printing. *)
+(* ------------------------------------------------------------------------- *)
+
+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 Joe Hurd, distributed under the BSD License *)
+(* ========================================================================= *)
+
+functor KeyMap (Key : Ordered) :> KeyMap where type key = Key.t =
+struct
+
+(* ------------------------------------------------------------------------- *)
+(* Importing from the input signature. *)
+(* ------------------------------------------------------------------------- *)
+
+open Metis; (* MODIFIED by Jasmin Blanchette *)
+
+type key = Key.t;
+
+val compareKey = Key.compare;
+
+(* ------------------------------------------------------------------------- *)
+(* Importing useful functionality. *)
+(* ------------------------------------------------------------------------- *)
+
+exception Bug = Useful.Bug;
+
+exception Error = Useful.Error;
+
+val pointerEqual = Portable.pointerEqual;
+
+val K = Useful.K;
+
+val randomInt = Portable.randomInt;
+
+val randomWord = Portable.randomWord;
+
+(* ------------------------------------------------------------------------- *)
+(* Converting a comparison function to an equality function. *)
+(* ------------------------------------------------------------------------- *)
+
+fun equalKey key1 key2 = compareKey (key1,key2) = EQUAL;
+
+(* ------------------------------------------------------------------------- *)
+(* Priorities. *)
+(* ------------------------------------------------------------------------- *)
+
+type priority = Word.word;
+
+val randomPriority = randomWord;
+
+val comparePriority = Word.compare;
+
+(* ------------------------------------------------------------------------- *)
+(* Priority search trees. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype 'value tree =
+ E
+ | T of 'value node
+
+and 'value node =
+ Node of
+ {size : int,
+ priority : priority,
+ left : 'value tree,
+ key : key,
+ value : 'value,
+ right : 'value tree};
+
+fun lowerPriorityNode node1 node2 =
+ let
+ val Node {priority = p1, ...} = node1
+ and Node {priority = p2, ...} = node2
+ in
+ comparePriority (p1,p2) = LESS
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Tree debugging functions. *)
+(* ------------------------------------------------------------------------- *)
+
+(*BasicDebug
+local
+ fun checkSizes tree =
+ case tree of
+ E => 0
+ | T (Node {size,left,right,...}) =>
+ let
+ val l = checkSizes left
+ and r = checkSizes right
+
+ val () = if l + 1 + r = size then () else raise Bug "wrong size"
+ in
+ size
+ end;
+
+ fun checkSorted x tree =
+ case tree of
+ E => x
+ | T (Node {left,key,right,...}) =>
+ let
+ val x = checkSorted x left
+
+ val () =
+ case x of
+ NONE => ()
+ | SOME k =>
+ case compareKey (k,key) of
+ LESS => ()
+ | EQUAL => raise Bug "duplicate keys"
+ | GREATER => raise Bug "unsorted"
+
+ val x = SOME key
+ in
+ checkSorted x right
+ end;
+
+ fun checkPriorities tree =
+ case tree of
+ E => NONE
+ | T node =>
+ let
+ val Node {left,right,...} = node
+
+ val () =
+ case checkPriorities left of
+ NONE => ()
+ | SOME lnode =>
+ if not (lowerPriorityNode node lnode) then ()
+ else raise Bug "left child has greater priority"
+
+ val () =
+ case checkPriorities right of
+ NONE => ()
+ | SOME rnode =>
+ if not (lowerPriorityNode node rnode) then ()
+ else raise Bug "right child has greater priority"
+ in
+ SOME node
+ end;
+in
+ fun treeCheckInvariants tree =
+ let
+ val _ = checkSizes tree
+
+ val _ = checkSorted NONE tree
+
+ val _ = checkPriorities tree
+ in
+ tree
+ end
+ handle Error err => raise Bug err;
+end;
+*)
+
+(* ------------------------------------------------------------------------- *)
+(* Tree operations. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeNew () = E;
+
+fun nodeSize (Node {size = x, ...}) = x;
+
+fun treeSize tree =
+ case tree of
+ E => 0
+ | T x => nodeSize x;
+
+fun mkNode priority left key value right =
+ let
+ val size = treeSize left + 1 + treeSize right
+ in
+ Node
+ {size = size,
+ priority = priority,
+ left = left,
+ key = key,
+ value = value,
+ right = right}
+ end;
+
+fun mkTree priority left key value right =
+ let
+ val node = mkNode priority left key value right
+ in
+ T node
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Extracting the left and right spines of a tree. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeLeftSpine acc tree =
+ case tree of
+ E => acc
+ | T node => nodeLeftSpine acc node
+
+and nodeLeftSpine acc node =
+ let
+ val Node {left,...} = node
+ in
+ treeLeftSpine (node :: acc) left
+ end;
+
+fun treeRightSpine acc tree =
+ case tree of
+ E => acc
+ | T node => nodeRightSpine acc node
+
+and nodeRightSpine acc node =
+ let
+ val Node {right,...} = node
+ in
+ treeRightSpine (node :: acc) right
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Singleton trees. *)
+(* ------------------------------------------------------------------------- *)
+
+fun mkNodeSingleton priority key value =
+ let
+ val size = 1
+ and left = E
+ and right = E
+ in
+ Node
+ {size = size,
+ priority = priority,
+ left = left,
+ key = key,
+ value = value,
+ right = right}
+ end;
+
+fun nodeSingleton (key,value) =
+ let
+ val priority = randomPriority ()
+ in
+ mkNodeSingleton priority key value
+ end;
+
+fun treeSingleton key_value =
+ let
+ val node = nodeSingleton key_value
+ in
+ T node
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Appending two trees, where every element of the first tree is less than *)
+(* every element of the second tree. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeAppend tree1 tree2 =
+ case tree1 of
+ E => tree2
+ | T node1 =>
+ case tree2 of
+ E => tree1
+ | T node2 =>
+ if lowerPriorityNode node1 node2 then
+ let
+ val Node {priority,left,key,value,right,...} = node2
+
+ val left = treeAppend tree1 left
+ in
+ mkTree priority left key value right
+ end
+ else
+ let
+ val Node {priority,left,key,value,right,...} = node1
+
+ val right = treeAppend right tree2
+ in
+ mkTree priority left key value right
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Appending two trees and a node, where every element of the first tree is *)
+(* less than the node, which in turn is less than every element of the *)
+(* second tree. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeCombine left node right =
+ let
+ val left_node = treeAppend left (T node)
+ in
+ treeAppend left_node right
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Searching a tree for a value. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treePeek pkey tree =
+ case tree of
+ E => NONE
+ | T node => nodePeek pkey node
+
+and nodePeek pkey node =
+ let
+ val Node {left,key,value,right,...} = node
+ in
+ case compareKey (pkey,key) of
+ LESS => treePeek pkey left
+ | EQUAL => SOME value
+ | GREATER => treePeek pkey right
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Tree paths. *)
+(* ------------------------------------------------------------------------- *)
+
+(* Generating a path by searching a tree for a key/value pair *)
+
+fun treePeekPath pkey path tree =
+ case tree of
+ E => (path,NONE)
+ | T node => nodePeekPath pkey path node
+
+and nodePeekPath pkey path node =
+ let
+ val Node {left,key,right,...} = node
+ in
+ case compareKey (pkey,key) of
+ LESS => treePeekPath pkey ((true,node) :: path) left
+ | EQUAL => (path, SOME node)
+ | GREATER => treePeekPath pkey ((false,node) :: path) right
+ end;
+
+(* A path splits a tree into left/right components *)
+
+fun addSidePath ((wentLeft,node),(leftTree,rightTree)) =
+ let
+ val Node {priority,left,key,value,right,...} = node
+ in
+ if wentLeft then (leftTree, mkTree priority rightTree key value right)
+ else (mkTree priority left key value leftTree, rightTree)
+ end;
+
+fun addSidesPath left_right = List.foldl addSidePath left_right;
+
+fun mkSidesPath path = addSidesPath (E,E) path;
+
+(* Updating the subtree at a path *)
+
+local
+ fun updateTree ((wentLeft,node),tree) =
+ let
+ val Node {priority,left,key,value,right,...} = node
+ in
+ if wentLeft then mkTree priority tree key value right
+ else mkTree priority left key value tree
+ end;
+in
+ fun updateTreePath tree = List.foldl updateTree tree;
+end;
+
+(* Inserting a new node at a path position *)
+
+fun insertNodePath node =
+ let
+ fun insert left_right path =
+ case path of
+ [] =>
+ let
+ val (left,right) = left_right
+ in
+ treeCombine left node right
+ end
+ | (step as (_,snode)) :: rest =>
+ if lowerPriorityNode snode node then
+ let
+ val left_right = addSidePath (step,left_right)
+ in
+ insert left_right rest
+ end
+ else
+ let
+ val (left,right) = left_right
+
+ val tree = treeCombine left node right
+ in
+ updateTreePath tree path
+ end
+ in
+ insert (E,E)
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Using a key to split a node into three components: the keys comparing *)
+(* less than the supplied key, an optional equal key, and the keys comparing *)
+(* greater. *)
+(* ------------------------------------------------------------------------- *)
+
+fun nodePartition pkey node =
+ let
+ val (path,pnode) = nodePeekPath pkey [] node
+ in
+ case pnode of
+ NONE =>
+ let
+ val (left,right) = mkSidesPath path
+ in
+ (left,NONE,right)
+ end
+ | SOME node =>
+ let
+ val Node {left,key,value,right,...} = node
+
+ val (left,right) = addSidesPath (left,right) path
+ in
+ (left, SOME (key,value), right)
+ end
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Searching a tree for a key/value pair. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treePeekKey pkey tree =
+ case tree of
+ E => NONE
+ | T node => nodePeekKey pkey node
+
+and nodePeekKey pkey node =
+ let
+ val Node {left,key,value,right,...} = node
+ in
+ case compareKey (pkey,key) of
+ LESS => treePeekKey pkey left
+ | EQUAL => SOME (key,value)
+ | GREATER => treePeekKey pkey right
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Inserting new key/values into the tree. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeInsert key_value tree =
+ let
+ val (key,value) = key_value
+
+ val (path,inode) = treePeekPath key [] tree
+ in
+ case inode of
+ NONE =>
+ let
+ val node = nodeSingleton (key,value)
+ in
+ insertNodePath node path
+ end
+ | SOME node =>
+ let
+ val Node {size,priority,left,right,...} = node
+
+ val node =
+ Node
+ {size = size,
+ priority = priority,
+ left = left,
+ key = key,
+ value = value,
+ right = right}
+ in
+ updateTreePath (T node) path
+ end
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Deleting key/value pairs: it raises an exception if the supplied key is *)
+(* not present. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeDelete dkey tree =
+ case tree of
+ E => raise Bug "KeyMap.delete: element not found"
+ | T node => nodeDelete dkey node
+
+and nodeDelete dkey node =
+ let
+ val Node {size,priority,left,key,value,right} = node
+ in
+ case compareKey (dkey,key) of
+ LESS =>
+ let
+ val size = size - 1
+ and left = treeDelete dkey left
+
+ val node =
+ Node
+ {size = size,
+ priority = priority,
+ left = left,
+ key = key,
+ value = value,
+ right = right}
+ in
+ T node
+ end
+ | EQUAL => treeAppend left right
+ | GREATER =>
+ let
+ val size = size - 1
+ and right = treeDelete dkey right
+
+ val node =
+ Node
+ {size = size,
+ priority = priority,
+ left = left,
+ key = key,
+ value = value,
+ right = right}
+ in
+ T node
+ end
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Partial map is the basic operation for preserving tree structure. *)
+(* It applies its argument function to the elements *in order*. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeMapPartial f tree =
+ case tree of
+ E => E
+ | T node => nodeMapPartial f node
+
+and nodeMapPartial f (Node {priority,left,key,value,right,...}) =
+ let
+ val left = treeMapPartial f left
+ and vo = f (key,value)
+ and right = treeMapPartial f right
+ in
+ case vo of
+ NONE => treeAppend left right
+ | SOME value => mkTree priority left key value right
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Mapping tree values. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeMap f tree =
+ case tree of
+ E => E
+ | T node => T (nodeMap f node)
+
+and nodeMap f node =
+ let
+ val Node {size,priority,left,key,value,right} = node
+
+ val left = treeMap f left
+ and value = f (key,value)
+ and right = treeMap f right
+ in
+ Node
+ {size = size,
+ priority = priority,
+ left = left,
+ key = key,
+ value = value,
+ right = right}
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Merge is the basic operation for joining two trees. Note that the merged *)
+(* key is always the one from the second map. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeMerge f1 f2 fb tree1 tree2 =
+ case tree1 of
+ E => treeMapPartial f2 tree2
+ | T node1 =>
+ case tree2 of
+ E => treeMapPartial f1 tree1
+ | T node2 => nodeMerge f1 f2 fb node1 node2
+
+and nodeMerge f1 f2 fb node1 node2 =
+ let
+ val Node {priority,left,key,value,right,...} = node2
+
+ val (l,kvo,r) = nodePartition key node1
+
+ val left = treeMerge f1 f2 fb l left
+ and right = treeMerge f1 f2 fb r right
+
+ val vo =
+ case kvo of
+ NONE => f2 (key,value)
+ | SOME kv => fb (kv,(key,value))
+ in
+ case vo of
+ NONE => treeAppend left right
+ | SOME value =>
+ let
+ val node = mkNodeSingleton priority key value
+ in
+ treeCombine left node right
+ end
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* A op union operation on trees. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeUnion f f2 tree1 tree2 =
+ case tree1 of
+ E => tree2
+ | T node1 =>
+ case tree2 of
+ E => tree1
+ | T node2 => nodeUnion f f2 node1 node2
+
+and nodeUnion f f2 node1 node2 =
+ if pointerEqual (node1,node2) then nodeMapPartial f2 node1
+ else
+ let
+ val Node {priority,left,key,value,right,...} = node2
+
+ val (l,kvo,r) = nodePartition key node1
+
+ val left = treeUnion f f2 l left
+ and right = treeUnion f f2 r right
+
+ val vo =
+ case kvo of
+ NONE => SOME value
+ | SOME kv => f (kv,(key,value))
+ in
+ case vo of
+ NONE => treeAppend left right
+ | SOME value =>
+ let
+ val node = mkNodeSingleton priority key value
+ in
+ treeCombine left node right
+ end
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* An intersect operation on trees. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeIntersect f t1 t2 =
+ case t1 of
+ E => E
+ | T n1 =>
+ case t2 of
+ E => E
+ | T n2 => nodeIntersect f n1 n2
+
+and nodeIntersect f n1 n2 =
+ let
+ val Node {priority,left,key,value,right,...} = n2
+
+ val (l,kvo,r) = nodePartition key n1
+
+ val left = treeIntersect f l left
+ and right = treeIntersect f r right
+
+ val vo =
+ case kvo of
+ NONE => NONE
+ | SOME kv => f (kv,(key,value))
+ in
+ case vo of
+ NONE => treeAppend left right
+ | SOME value => mkTree priority left key value right
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* A op union operation on trees which simply chooses the second value. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeUnionDomain tree1 tree2 =
+ case tree1 of
+ E => tree2
+ | T node1 =>
+ case tree2 of
+ E => tree1
+ | T node2 =>
+ if pointerEqual (node1,node2) then tree2
+ else nodeUnionDomain node1 node2
+
+and nodeUnionDomain node1 node2 =
+ let
+ val Node {priority,left,key,value,right,...} = node2
+
+ val (l,_,r) = nodePartition key node1
+
+ val left = treeUnionDomain l left
+ and right = treeUnionDomain r right
+
+ val node = mkNodeSingleton priority key value
+ in
+ treeCombine left node right
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* An intersect operation on trees which simply chooses the second value. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeIntersectDomain tree1 tree2 =
+ case tree1 of
+ E => E
+ | T node1 =>
+ case tree2 of
+ E => E
+ | T node2 =>
+ if pointerEqual (node1,node2) then tree2
+ else nodeIntersectDomain node1 node2
+
+and nodeIntersectDomain node1 node2 =
+ let
+ val Node {priority,left,key,value,right,...} = node2
+
+ val (l,kvo,r) = nodePartition key node1
+
+ val left = treeIntersectDomain l left
+ and right = treeIntersectDomain r right
+ in
+ if Option.isSome kvo then mkTree priority left key value right
+ else treeAppend left right
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* A difference operation on trees. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeDifferenceDomain t1 t2 =
+ case t1 of
+ E => E
+ | T n1 =>
+ case t2 of
+ E => t1
+ | T n2 => nodeDifferenceDomain n1 n2
+
+and nodeDifferenceDomain n1 n2 =
+ if pointerEqual (n1,n2) then E
+ else
+ let
+ val Node {priority,left,key,value,right,...} = n1
+
+ val (l,kvo,r) = nodePartition key n2
+
+ val left = treeDifferenceDomain left l
+ and right = treeDifferenceDomain right r
+ in
+ if Option.isSome kvo then treeAppend left right
+ else mkTree priority left key value right
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* A op subset operation on trees. *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeSubsetDomain tree1 tree2 =
+ case tree1 of
+ E => true
+ | T node1 =>
+ case tree2 of
+ E => false
+ | T node2 => nodeSubsetDomain node1 node2
+
+and nodeSubsetDomain node1 node2 =
+ pointerEqual (node1,node2) orelse
+ let
+ val Node {size,left,key,right,...} = node1
+ in
+ size <= nodeSize node2 andalso
+ let
+ val (l,kvo,r) = nodePartition key node2
+ in
+ Option.isSome kvo andalso
+ treeSubsetDomain left l andalso
+ treeSubsetDomain right r
+ end
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Picking an arbitrary key/value pair from a tree. *)
+(* ------------------------------------------------------------------------- *)
+
+fun nodePick node =
+ let
+ val Node {key,value,...} = node
+ in
+ (key,value)
+ end;
+
+fun treePick tree =
+ case tree of
+ E => raise Bug "KeyMap.treePick"
+ | T node => nodePick node;
+
+(* ------------------------------------------------------------------------- *)
+(* Removing an arbitrary key/value pair from a tree. *)
+(* ------------------------------------------------------------------------- *)
+
+fun nodeDeletePick node =
+ let
+ val Node {left,key,value,right,...} = node
+ in
+ ((key,value), treeAppend left right)
+ end;
+
+fun treeDeletePick tree =
+ case tree of
+ E => raise Bug "KeyMap.treeDeletePick"
+ | T node => nodeDeletePick node;
+
+(* ------------------------------------------------------------------------- *)
+(* Finding the nth smallest key/value (counting from 0). *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeNth n tree =
+ case tree of
+ E => raise Bug "KeyMap.treeNth"
+ | T node => nodeNth n node
+
+and nodeNth n node =
+ let
+ val Node {left,key,value,right,...} = node
+
+ val k = treeSize left
+ in
+ if n = k then (key,value)
+ else if n < k then treeNth n left
+ else treeNth (n - (k + 1)) right
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Removing the nth smallest key/value (counting from 0). *)
+(* ------------------------------------------------------------------------- *)
+
+fun treeDeleteNth n tree =
+ case tree of
+ E => raise Bug "KeyMap.treeDeleteNth"
+ | T node => nodeDeleteNth n node
+
+and nodeDeleteNth n node =
+ let
+ val Node {size,priority,left,key,value,right} = node
+
+ val k = treeSize left
+ in
+ if n = k then ((key,value), treeAppend left right)
+ else if n < k then
+ let
+ val (key_value,left) = treeDeleteNth n left
+
+ val size = size - 1
+
+ val node =
+ Node
+ {size = size,
+ priority = priority,
+ left = left,
+ key = key,
+ value = value,
+ right = right}
+ in
+ (key_value, T node)
+ end
+ else
+ let
+ val n = n - (k + 1)
+
+ val (key_value,right) = treeDeleteNth n right
+
+ val size = size - 1
+
+ val node =
+ Node
+ {size = size,
+ priority = priority,
+ left = left,
+ key = key,
+ value = value,
+ right = right}
+ in
+ (key_value, T node)
+ end
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Iterators. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype 'value iterator =
+ LR of (key * 'value) * 'value tree * 'value node list
+ | RL of (key * 'value) * 'value tree * 'value node list;
+
+fun fromSpineLR nodes =
+ case nodes of
+ [] => NONE
+ | Node {key,value,right,...} :: nodes =>
+ SOME (LR ((key,value),right,nodes));
+
+fun fromSpineRL nodes =
+ case nodes of
+ [] => NONE
+ | Node {key,value,left,...} :: nodes =>
+ SOME (RL ((key,value),left,nodes));
+
+fun addLR nodes tree = fromSpineLR (treeLeftSpine nodes tree);
+
+fun addRL nodes tree = fromSpineRL (treeRightSpine nodes tree);
+
+fun treeMkIterator tree = addLR [] tree;
+
+fun treeMkRevIterator tree = addRL [] tree;
+
+fun readIterator iter =
+ case iter of
+ LR (key_value,_,_) => key_value
+ | RL (key_value,_,_) => key_value;
+
+fun advanceIterator iter =
+ case iter of
+ LR (_,tree,nodes) => addLR nodes tree
+ | RL (_,tree,nodes) => addRL nodes tree;
+
+fun foldIterator f acc io =
+ case io of
+ NONE => acc
+ | SOME iter =>
+ let
+ val (key,value) = readIterator iter
+ in
+ foldIterator f (f (key,value,acc)) (advanceIterator iter)
+ end;
+
+fun findIterator pred io =
+ case io of
+ NONE => NONE
+ | SOME iter =>
+ let
+ val key_value = readIterator iter
+ in
+ if pred key_value then SOME key_value
+ else findIterator pred (advanceIterator iter)
+ end;
+
+fun firstIterator f io =
+ case io of
+ NONE => NONE
+ | SOME iter =>
+ let
+ val key_value = readIterator iter
+ in
+ case f key_value of
+ NONE => firstIterator f (advanceIterator iter)
+ | s => s
+ end;
+
+fun compareIterator compareValue io1 io2 =
+ case (io1,io2) of
+ (NONE,NONE) => EQUAL
+ | (NONE, SOME _) => LESS
+ | (SOME _, NONE) => GREATER
+ | (SOME i1, SOME i2) =>
+ let
+ val (k1,v1) = readIterator i1
+ and (k2,v2) = readIterator i2
+ in
+ case compareKey (k1,k2) of
+ LESS => LESS
+ | EQUAL =>
+ (case compareValue (v1,v2) of
+ LESS => LESS
+ | EQUAL =>
+ let
+ val io1 = advanceIterator i1
+ and io2 = advanceIterator i2
+ in
+ compareIterator compareValue io1 io2
+ end
+ | GREATER => GREATER)
+ | GREATER => GREATER
+ end;
+
+fun equalIterator equalValue io1 io2 =
+ case (io1,io2) of
+ (NONE,NONE) => true
+ | (NONE, SOME _) => false
+ | (SOME _, NONE) => false
+ | (SOME i1, SOME i2) =>
+ let
+ val (k1,v1) = readIterator i1
+ and (k2,v2) = readIterator i2
+ in
+ equalKey k1 k2 andalso
+ equalValue v1 v2 andalso
+ let
+ val io1 = advanceIterator i1
+ and io2 = advanceIterator i2
+ in
+ equalIterator equalValue io1 io2
+ end
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* A type of finite maps. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype 'value map =
+ Map of 'value tree;
+
+(* ------------------------------------------------------------------------- *)
+(* Map debugging functions. *)
+(* ------------------------------------------------------------------------- *)
+
+(*BasicDebug
+fun checkInvariants s m =
+ let
+ val Map tree = m
+
+ val _ = treeCheckInvariants tree
+ in
+ m
+ end
+ handle Bug bug => raise Bug (s ^ "\n" ^ "KeyMap.checkInvariants: " ^ bug);
+*)
+
+(* ------------------------------------------------------------------------- *)
+(* Constructors. *)
+(* ------------------------------------------------------------------------- *)
+
+fun new () =
+ let
+ val tree = treeNew ()
+ in
+ Map tree
+ end;
+
+fun singleton key_value =
+ let
+ val tree = treeSingleton key_value
+ in
+ Map tree
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Map size. *)
+(* ------------------------------------------------------------------------- *)
+
+fun size (Map tree) = treeSize tree;
+
+fun null m = size m = 0;
+
+(* ------------------------------------------------------------------------- *)
+(* Querying. *)
+(* ------------------------------------------------------------------------- *)
+
+fun peekKey (Map tree) key = treePeekKey key tree;
+
+fun peek (Map tree) key = treePeek key tree;
+
+fun inDomain key m = Option.isSome (peek m key);
+
+fun get m key =
+ case peek m key of
+ NONE => raise Error "KeyMap.get: element not found"
+ | SOME value => value;
+
+fun pick (Map tree) = treePick tree;
+
+fun nth (Map tree) n = treeNth n tree;
+
+fun random m =
+ let
+ val n = size m
+ in
+ if n = 0 then raise Bug "KeyMap.random: empty"
+ else nth m (randomInt n)
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Adding. *)
+(* ------------------------------------------------------------------------- *)
+
+fun insert (Map tree) key_value =
+ let
+ val tree = treeInsert key_value tree
+ in
+ Map tree
+ end;
+
+(*BasicDebug
+val insert = fn m => fn kv =>
+ checkInvariants "KeyMap.insert: result"
+ (insert (checkInvariants "KeyMap.insert: input" m) kv);
+*)
+
+fun insertList m =
+ let
+ fun ins (key_value,acc) = insert acc key_value
+ in
+ List.foldl ins m
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Removing. *)
+(* ------------------------------------------------------------------------- *)
+
+fun delete (Map tree) dkey =
+ let
+ val tree = treeDelete dkey tree
+ in
+ Map tree
+ end;
+
+(*BasicDebug
+val delete = fn m => fn k =>
+ checkInvariants "KeyMap.delete: result"
+ (delete (checkInvariants "KeyMap.delete: input" m) k);
+*)
+
+fun remove m key = if inDomain key m then delete m key else m;
+
+fun deletePick (Map tree) =
+ let
+ val (key_value,tree) = treeDeletePick tree
+ in
+ (key_value, Map tree)
+ end;
+
+(*BasicDebug
+val deletePick = fn m =>
+ let
+ val (kv,m) = deletePick (checkInvariants "KeyMap.deletePick: input" m)
+ in
+ (kv, checkInvariants "KeyMap.deletePick: result" m)
+ end;
+*)
+
+fun deleteNth (Map tree) n =
+ let
+ val (key_value,tree) = treeDeleteNth n tree
+ in
+ (key_value, Map tree)
+ end;
+
+(*BasicDebug
+val deleteNth = fn m => fn n =>
+ let
+ val (kv,m) = deleteNth (checkInvariants "KeyMap.deleteNth: input" m) n
+ in
+ (kv, checkInvariants "KeyMap.deleteNth: result" m)
+ end;
+*)
+
+fun deleteRandom m =
+ let
+ val n = size m
+ in
+ if n = 0 then raise Bug "KeyMap.deleteRandom: empty"
+ else deleteNth m (randomInt n)
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Joining (all join operations prefer keys in the second map). *)
+(* ------------------------------------------------------------------------- *)
+
+fun merge {first,second,both} (Map tree1) (Map tree2) =
+ let
+ val tree = treeMerge first second both tree1 tree2
+ in
+ Map tree
+ end;
+
+(*BasicDebug
+val merge = fn f => fn m1 => fn m2 =>
+ checkInvariants "KeyMap.merge: result"
+ (merge f
+ (checkInvariants "KeyMap.merge: input 1" m1)
+ (checkInvariants "KeyMap.merge: input 2" m2));
+*)
+
+fun op union f (Map tree1) (Map tree2) =
+ let
+ fun f2 kv = f (kv,kv)
+
+ val tree = treeUnion f f2 tree1 tree2
+ in
+ Map tree
+ end;
+
+(*BasicDebug
+val op union = fn f => fn m1 => fn m2 =>
+ checkInvariants "KeyMap.union: result"
+ (union f
+ (checkInvariants "KeyMap.union: input 1" m1)
+ (checkInvariants "KeyMap.union: input 2" m2));
+*)
+
+fun intersect f (Map tree1) (Map tree2) =
+ let
+ val tree = treeIntersect f tree1 tree2
+ in
+ Map tree
+ end;
+
+(*BasicDebug
+val intersect = fn f => fn m1 => fn m2 =>
+ checkInvariants "KeyMap.intersect: result"
+ (intersect f
+ (checkInvariants "KeyMap.intersect: input 1" m1)
+ (checkInvariants "KeyMap.intersect: input 2" m2));
+*)
+
+(* ------------------------------------------------------------------------- *)
+(* Iterators over maps. *)
+(* ------------------------------------------------------------------------- *)
+
+fun mkIterator (Map tree) = treeMkIterator tree;
+
+fun mkRevIterator (Map tree) = treeMkRevIterator tree;
+
+(* ------------------------------------------------------------------------- *)
+(* Mapping and folding. *)
+(* ------------------------------------------------------------------------- *)
+
+fun mapPartial f (Map tree) =
+ let
+ val tree = treeMapPartial f tree
+ in
+ Map tree
+ end;
+
+(*BasicDebug
+val mapPartial = fn f => fn m =>
+ checkInvariants "KeyMap.mapPartial: result"
+ (mapPartial f (checkInvariants "KeyMap.mapPartial: input" m));
+*)
+
+fun map f (Map tree) =
+ let
+ val tree = treeMap f tree
+ in
+ Map tree
+ end;
+
+(*BasicDebug
+val map = fn f => fn m =>
+ checkInvariants "KeyMap.map: result"
+ (map f (checkInvariants "KeyMap.map: input" m));
+*)
+
+fun transform f = map (fn (_,value) => f value);
+
+fun filter pred =
+ let
+ fun f (key_value as (_,value)) =
+ if pred key_value then SOME value else NONE
+ in
+ mapPartial f
+ end;
+
+fun partition p =
+ let
+ fun np x = not (p x)
+ in
+ fn m => (filter p m, filter np m)
+ end;
+
+fun foldl f b m = foldIterator f b (mkIterator m);
+
+fun foldr f b m = foldIterator f b (mkRevIterator m);
+
+fun app f m = foldl (fn (key,value,()) => f (key,value)) () m;
+
+(* ------------------------------------------------------------------------- *)
+(* Searching. *)
+(* ------------------------------------------------------------------------- *)
+
+fun findl p m = findIterator p (mkIterator m);
+
+fun findr p m = findIterator p (mkRevIterator m);
+
+fun firstl f m = firstIterator f (mkIterator m);
+
+fun firstr f m = firstIterator f (mkRevIterator m);
+
+fun exists p m = Option.isSome (findl p m);
+
+fun all p =
+ let
+ fun np x = not (p x)
+ in
+ fn m => not (exists np m)
+ end;
+
+fun count pred =
+ let
+ fun f (k,v,acc) = if pred (k,v) then acc + 1 else acc
+ in
+ foldl f 0
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Comparing. *)
+(* ------------------------------------------------------------------------- *)
+
+fun compare compareValue (m1,m2) =
+ if pointerEqual (m1,m2) then EQUAL
+ else
+ case Int.compare (size m1, size m2) of
+ LESS => LESS
+ | EQUAL =>
+ let
+ val Map _ = m1
+
+ val io1 = mkIterator m1
+ and io2 = mkIterator m2
+ in
+ compareIterator compareValue io1 io2
+ end
+ | GREATER => GREATER;
+
+fun equal equalValue m1 m2 =
+ pointerEqual (m1,m2) orelse
+ (size m1 = size m2 andalso
+ let
+ val Map _ = m1
+
+ val io1 = mkIterator m1
+ and io2 = mkIterator m2
+ in
+ equalIterator equalValue io1 io2
+ end);
+
+(* ------------------------------------------------------------------------- *)
+(* Set operations on the domain. *)
+(* ------------------------------------------------------------------------- *)
+
+fun unionDomain (Map tree1) (Map tree2) =
+ let
+ val tree = treeUnionDomain tree1 tree2
+ in
+ Map tree
+ end;
+
+(*BasicDebug
+val unionDomain = fn m1 => fn m2 =>
+ checkInvariants "KeyMap.unionDomain: result"
+ (unionDomain
+ (checkInvariants "KeyMap.unionDomain: input 1" m1)
+ (checkInvariants "KeyMap.unionDomain: input 2" m2));
+*)
+
+local
+ fun uncurriedUnionDomain (m,acc) = unionDomain acc m;
+in
+ fun unionListDomain ms =
+ case ms of
+ [] => raise Bug "KeyMap.unionListDomain: no sets"
+ | m :: ms => List.foldl uncurriedUnionDomain m ms;
+end;
+
+fun intersectDomain (Map tree1) (Map tree2) =
+ let
+ val tree = treeIntersectDomain tree1 tree2
+ in
+ Map tree
+ end;
+
+(*BasicDebug
+val intersectDomain = fn m1 => fn m2 =>
+ checkInvariants "KeyMap.intersectDomain: result"
+ (intersectDomain
+ (checkInvariants "KeyMap.intersectDomain: input 1" m1)
+ (checkInvariants "KeyMap.intersectDomain: input 2" m2));
+*)
+
+local
+ fun uncurriedIntersectDomain (m,acc) = intersectDomain acc m;
+in
+ fun intersectListDomain ms =
+ case ms of
+ [] => raise Bug "KeyMap.intersectListDomain: no sets"
+ | m :: ms => List.foldl uncurriedIntersectDomain m ms;
+end;
+
+fun differenceDomain (Map tree1) (Map tree2) =
+ let
+ val tree = treeDifferenceDomain tree1 tree2
+ in
+ Map tree
+ end;
+
+(*BasicDebug
+val differenceDomain = fn m1 => fn m2 =>
+ checkInvariants "KeyMap.differenceDomain: result"
+ (differenceDomain
+ (checkInvariants "KeyMap.differenceDomain: input 1" m1)
+ (checkInvariants "KeyMap.differenceDomain: input 2" m2));
+*)
+
+fun symmetricDifferenceDomain m1 m2 =
+ unionDomain (differenceDomain m1 m2) (differenceDomain m2 m1);
+
+fun equalDomain m1 m2 = equal (K (K true)) m1 m2;
+
+fun subsetDomain (Map tree1) (Map tree2) =
+ treeSubsetDomain tree1 tree2;
+
+fun disjointDomain m1 m2 = null (intersectDomain m1 m2);
+
+(* ------------------------------------------------------------------------- *)
+(* Converting to and from lists. *)
+(* ------------------------------------------------------------------------- *)
+
+fun keys m = foldr (fn (key,_,l) => key :: l) [] m;
+
+fun values m = foldr (fn (_,value,l) => value :: l) [] m;
+
+fun toList m = foldr (fn (key,value,l) => (key,value) :: l) [] m;
+
+fun fromList l =
+ let
+ val m = new ()
+ in
+ insertList m l
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Pretty-printing. *)
+(* ------------------------------------------------------------------------- *)
+
+fun toString m = "<" ^ (if null m then "" else Int.toString (size m)) ^ ">";
+
+end
+
+structure IntMap =
+KeyMap (Metis.IntOrdered); (* MODIFIED by Jasmin Blanchette *)
+
+structure IntPairMap =
+KeyMap (Metis.IntPairOrdered); (* MODIFIED by Jasmin Blanchette *)
+
+structure StringMap =
+KeyMap (Metis.StringOrdered); (* MODIFIED by Jasmin Blanchette *)
+
(**** Original file: Set.sig ****)
(* ========================================================================= *)
-(* FINITE SETS *)
-(* Copyright (c) 2004-2006 Joe Hurd, distributed under the BSD License *)
+(* FINITE SETS IMPLEMENTED WITH RANDOMLY BALANCED TREES *)
+(* Copyright (c) 2004 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Set =
sig
(* ------------------------------------------------------------------------- *)
-(* Finite sets *)
+(* A type of finite sets. *)
(* ------------------------------------------------------------------------- *)
type 'elt set
-val comparison : 'elt set -> ('elt * 'elt -> order)
+(* ------------------------------------------------------------------------- *)
+(* Constructors. *)
+(* ------------------------------------------------------------------------- *)
val empty : ('elt * 'elt -> order) -> 'elt set
val singleton : ('elt * 'elt -> order) -> 'elt -> 'elt set
+(* ------------------------------------------------------------------------- *)
+(* Set size. *)
+(* ------------------------------------------------------------------------- *)
+
val null : 'elt set -> bool
val size : 'elt set -> int
+(* ------------------------------------------------------------------------- *)
+(* Querying. *)
+(* ------------------------------------------------------------------------- *)
+
+val peek : 'elt set -> 'elt -> 'elt option
+
val member : 'elt -> 'elt set -> bool
+val pick : 'elt set -> 'elt (* an arbitrary element *)
+
+val nth : 'elt set -> int -> 'elt (* in the range [0,size-1] *)
+
+val random : 'elt set -> 'elt
+
+(* ------------------------------------------------------------------------- *)
+(* Adding. *)
+(* ------------------------------------------------------------------------- *)
+
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 *)
+(* ------------------------------------------------------------------------- *)
+(* Removing. *)
+(* ------------------------------------------------------------------------- *)
+
+val delete : 'elt set -> 'elt -> 'elt set (* must be present *)
+
+val remove : 'elt set -> 'elt -> 'elt set
+
+val deletePick : 'elt set -> 'elt * 'elt set
+
+val deleteNth : 'elt set -> int -> 'elt * 'elt set
+
+val deleteRandom : 'elt set -> 'elt * 'elt set
+
+(* ------------------------------------------------------------------------- *)
+(* Joining. *)
+(* ------------------------------------------------------------------------- *)
val union : 'elt set -> 'elt set -> 'elt set
@@ -2128,22 +5295,24 @@
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
+(* ------------------------------------------------------------------------- *)
+(* Mapping and folding. *)
+(* ------------------------------------------------------------------------- *)
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 app : ('elt -> unit) -> 'elt set -> unit
val foldl : ('elt * 's -> 's) -> 's -> 'elt set -> 's
val foldr : ('elt * 's -> 's) -> 's -> 'elt set -> 's
+(* ------------------------------------------------------------------------- *)
+(* Searching. *)
+(* ------------------------------------------------------------------------- *)
+
val findl : ('elt -> bool) -> 'elt set -> 'elt option
val findr : ('elt -> bool) -> 'elt set -> 'elt option
@@ -2156,27 +5325,45 @@
val all : ('elt -> bool) -> 'elt set -> bool
-val map : ('elt -> 'a) -> 'elt set -> ('elt * 'a) list
+val count : ('elt -> bool) -> 'elt set -> int
+
+(* ------------------------------------------------------------------------- *)
+(* Comparing. *)
+(* ------------------------------------------------------------------------- *)
+
+val compare : 'elt set * 'elt set -> order
+
+val equal : 'elt set -> 'elt set -> bool
+
+val subset : 'elt set -> 'elt set -> bool
+
+val disjoint : 'elt set -> 'elt set -> bool
+
+(* ------------------------------------------------------------------------- *)
+(* Converting to and from lists. *)
+(* ------------------------------------------------------------------------- *)
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
+(* ------------------------------------------------------------------------- *)
+(* Converting to and from maps. *)
+(* ------------------------------------------------------------------------- *)
+
+type ('elt,'a) map = ('elt,'a) Metis.Map.map
+
+val mapPartial : ('elt -> 'a option) -> 'elt set -> ('elt,'a) map
+
+val map : ('elt -> 'a) -> 'elt set -> ('elt,'a) map
+
+val domain : ('elt,'a) map -> 'elt set
+
+(* ------------------------------------------------------------------------- *)
+(* Pretty-printing. *)
+(* ------------------------------------------------------------------------- *)
val toString : 'elt set -> string
@@ -2196,11 +5383,11 @@
end
-(**** Original file: RandomSet.sml ****)
+(**** Original file: Set.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -2209,667 +5396,414 @@
(* ========================================================================= *)
(* 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;
-val explode = String.explode;
-val implode = String.implode;
-val print = TextIO.print;
-val foldl = List.foldl;
-val foldr = List.foldr;
-
-(* ========================================================================= *)
-(* FINITE SETS *)
-(* Copyright (c) 2004-2006 Joe Hurd, distributed under the BSD License *)
-(* ========================================================================= *)
-
-structure Set = RandomSet;
+(* Copyright (c) 2004 Joe Hurd, distributed under the BSD License *)
+(* ========================================================================= *)
+
+structure Set :> Set =
+struct
+
+(* ------------------------------------------------------------------------- *)
+(* A type of finite sets. *)
+(* ------------------------------------------------------------------------- *)
+
+type ('elt,'a) map = ('elt,'a) Map.map;
+
+datatype 'elt set = Set of ('elt,unit) map;
+
+(* ------------------------------------------------------------------------- *)
+(* Converting to and from maps. *)
+(* ------------------------------------------------------------------------- *)
+
+fun dest (Set m) = m;
+
+fun mapPartial f =
+ let
+ fun mf (elt,()) = f elt
+ in
+ fn Set m => Map.mapPartial mf m
+ end;
+
+fun map f =
+ let
+ fun mf (elt,()) = f elt
+ in
+ fn Set m => Map.map mf m
+ end;
+
+fun domain m = Set (Map.transform (fn _ => ()) m);
+
+(* ------------------------------------------------------------------------- *)
+(* Constructors. *)
+(* ------------------------------------------------------------------------- *)
+
+fun empty cmp = Set (Map.new cmp);
+
+fun singleton cmp elt = Set (Map.singleton cmp (elt,()));
+
+(* ------------------------------------------------------------------------- *)
+(* Set size. *)
+(* ------------------------------------------------------------------------- *)
+
+fun null (Set m) = Map.null m;
+
+fun size (Set m) = Map.size m;
+
+(* ------------------------------------------------------------------------- *)
+(* Querying. *)
+(* ------------------------------------------------------------------------- *)
+
+fun peek (Set m) elt =
+ case Map.peekKey m elt of
+ SOME (elt,()) => SOME elt
+ | NONE => NONE;
+
+fun member elt (Set m) = Map.inDomain elt m;
+
+fun pick (Set m) =
+ let
+ val (elt,_) = Map.pick m
+ in
+ elt
+ end;
+
+fun nth (Set m) n =
+ let
+ val (elt,_) = Map.nth m n
+ in
+ elt
+ end;
+
+fun random (Set m) =
+ let
+ val (elt,_) = Map.random m
+ in
+ elt
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Adding. *)
+(* ------------------------------------------------------------------------- *)
+
+fun add (Set m) elt =
+ let
+ val m = Map.insert m (elt,())
+ in
+ Set m
+ end;
+
+local
+ fun uncurriedAdd (elt,set) = add set elt;
+in
+ fun addList set = List.foldl uncurriedAdd set;
+end;
+
+(* ------------------------------------------------------------------------- *)
+(* Removing. *)
+(* ------------------------------------------------------------------------- *)
+
+fun delete (Set m) elt =
+ let
+ val m = Map.delete m elt
+ in
+ Set m
+ end;
+
+fun remove (Set m) elt =
+ let
+ val m = Map.remove m elt
+ in
+ Set m
+ end;
+
+fun deletePick (Set m) =
+ let
+ val ((elt,()),m) = Map.deletePick m
+ in
+ (elt, Set m)
+ end;
+
+fun deleteNth (Set m) n =
+ let
+ val ((elt,()),m) = Map.deleteNth m n
+ in
+ (elt, Set m)
+ end;
+
+fun deleteRandom (Set m) =
+ let
+ val ((elt,()),m) = Map.deleteRandom m
+ in
+ (elt, Set m)
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Joining. *)
+(* ------------------------------------------------------------------------- *)
+
+fun union (Set m1) (Set m2) = Set (Map.unionDomain m1 m2);
+
+fun unionList sets =
+ let
+ val ms = List.map dest sets
+ in
+ Set (Map.unionListDomain ms)
+ end;
+
+fun intersect (Set m1) (Set m2) = Set (Map.intersectDomain m1 m2);
+
+fun intersectList sets =
+ let
+ val ms = List.map dest sets
+ in
+ Set (Map.intersectListDomain ms)
+ end;
+
+fun difference (Set m1) (Set m2) =
+ Set (Map.differenceDomain m1 m2);
+
+fun symmetricDifference (Set m1) (Set m2) =
+ Set (Map.symmetricDifferenceDomain m1 m2);
+
+(* ------------------------------------------------------------------------- *)
+(* Mapping and folding. *)
+(* ------------------------------------------------------------------------- *)
+
+fun filter pred =
+ let
+ fun mpred (elt,()) = pred elt
+ in
+ fn Set m => Set (Map.filter mpred m)
+ end;
+
+fun partition pred =
+ let
+ fun mpred (elt,()) = pred elt
+ in
+ fn Set m =>
+ let
+ val (m1,m2) = Map.partition mpred m
+ in
+ (Set m1, Set m2)
+ end
+ end;
+
+fun app f =
+ let
+ fun mf (elt,()) = f elt
+ in
+ fn Set m => Map.app mf m
+ end;
+
+fun foldl f =
+ let
+ fun mf (elt,(),acc) = f (elt,acc)
+ in
+ fn acc => fn Set m => Map.foldl mf acc m
+ end;
+
+fun foldr f =
+ let
+ fun mf (elt,(),acc) = f (elt,acc)
+ in
+ fn acc => fn Set m => Map.foldr mf acc m
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Searching. *)
+(* ------------------------------------------------------------------------- *)
+
+fun findl p =
+ let
+ fun mp (elt,()) = p elt
+ in
+ fn Set m =>
+ case Map.findl mp m of
+ SOME (elt,()) => SOME elt
+ | NONE => NONE
+ end;
+
+fun findr p =
+ let
+ fun mp (elt,()) = p elt
+ in
+ fn Set m =>
+ case Map.findr mp m of
+ SOME (elt,()) => SOME elt
+ | NONE => NONE
+ end;
+
+fun firstl f =
+ let
+ fun mf (elt,()) = f elt
+ in
+ fn Set m => Map.firstl mf m
+ end;
+
+fun firstr f =
+ let
+ fun mf (elt,()) = f elt
+ in
+ fn Set m => Map.firstr mf m
+ end;
+
+fun exists p =
+ let
+ fun mp (elt,()) = p elt
+ in
+ fn Set m => Map.exists mp m
+ end;
+
+fun all p =
+ let
+ fun mp (elt,()) = p elt
+ in
+ fn Set m => Map.all mp m
+ end;
+
+fun count p =
+ let
+ fun mp (elt,()) = p elt
+ in
+ fn Set m => Map.count mp m
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Comparing. *)
+(* ------------------------------------------------------------------------- *)
+
+fun compareValue ((),()) = EQUAL;
+
+fun equalValue () () = true;
+
+fun compare (Set m1, Set m2) = Map.compare compareValue (m1,m2);
+
+fun equal (Set m1) (Set m2) = Map.equal equalValue m1 m2;
+
+fun subset (Set m1) (Set m2) = Map.subsetDomain m1 m2;
+
+fun disjoint (Set m1) (Set m2) = Map.disjointDomain m1 m2;
+
+(* ------------------------------------------------------------------------- *)
+(* Converting to and from lists. *)
+(* ------------------------------------------------------------------------- *)
+
+fun transform f =
+ let
+ fun inc (x,l) = f x :: l
+ in
+ foldr inc []
+ end;
+
+fun toList (Set m) = Map.keys m;
+
+fun fromList cmp elts = addList (empty cmp) elts;
+
+(* ------------------------------------------------------------------------- *)
+(* Pretty-printing. *)
+(* ------------------------------------------------------------------------- *)
+
+fun toString set =
+ "{" ^ (if null set then "" else Int.toString (size set)) ^ "}";
+
+(* ------------------------------------------------------------------------- *)
+(* Iterators over sets *)
+(* ------------------------------------------------------------------------- *)
+
+type 'elt iterator = ('elt,unit) Map.iterator;
+
+fun mkIterator (Set m) = Map.mkIterator m;
+
+fun mkRevIterator (Set m) = Map.mkRevIterator m;
+
+fun readIterator iter =
+ let
+ val (elt,()) = Map.readIterator iter
+ in
+ elt
+ end;
+
+fun advanceIterator iter = Map.advanceIterator iter;
+
+end
end;
(**** Original file: ElementSet.sig ****)
(* ========================================================================= *)
(* FINITE SETS WITH A FIXED ELEMENT TYPE *)
-(* Copyright (c) 2004-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2004 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature ElementSet =
sig
+(* ------------------------------------------------------------------------- *)
+(* A type of set elements. *)
+(* ------------------------------------------------------------------------- *)
+
type element
(* ------------------------------------------------------------------------- *)
-(* Finite sets *)
+(* A type of finite sets. *)
(* ------------------------------------------------------------------------- *)
type set
+(* ------------------------------------------------------------------------- *)
+(* Constructors. *)
+(* ------------------------------------------------------------------------- *)
+
val empty : set
val singleton : element -> set
+(* ------------------------------------------------------------------------- *)
+(* Set size. *)
+(* ------------------------------------------------------------------------- *)
+
val null : set -> bool
val size : set -> int
+(* ------------------------------------------------------------------------- *)
+(* Querying. *)
+(* ------------------------------------------------------------------------- *)
+
+val peek : set -> element -> element option
+
val member : element -> set -> bool
+val pick : set -> element (* an arbitrary element *)
+
+val nth : set -> int -> element (* in the range [0,size-1] *)
+
+val random : set -> element
+
+(* ------------------------------------------------------------------------- *)
+(* Adding. *)
+(* ------------------------------------------------------------------------- *)
+
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 *)
+(* ------------------------------------------------------------------------- *)
+(* Removing. *)
+(* ------------------------------------------------------------------------- *)
+
+val delete : set -> element -> set (* must be present *)
+
+val remove : set -> element -> set
+
+val deletePick : set -> element * set
+
+val deleteNth : set -> int -> element * set
+
+val deleteRandom : set -> element * set
+
+(* ------------------------------------------------------------------------- *)
+(* Joining. *)
+(* ------------------------------------------------------------------------- *)
val union : set -> set -> set
@@ -2883,22 +5817,24 @@
val symmetricDifference : set -> set -> set
-val disjoint : set -> set -> bool
-
-val subset : set -> set -> bool
-
-val equal : set -> set -> bool
+(* ------------------------------------------------------------------------- *)
+(* Mapping and folding. *)
+(* ------------------------------------------------------------------------- *)
val filter : (element -> bool) -> set -> set
val partition : (element -> bool) -> set -> set * set
-val count : (element -> bool) -> set -> int
+val app : (element -> unit) -> set -> unit
val foldl : (element * 's -> 's) -> 's -> set -> 's
val foldr : (element * 's -> 's) -> 's -> set -> 's
+(* ------------------------------------------------------------------------- *)
+(* Searching. *)
+(* ------------------------------------------------------------------------- *)
+
val findl : (element -> bool) -> set -> element option
val findr : (element -> bool) -> set -> element option
@@ -2911,27 +5847,45 @@
val all : (element -> bool) -> set -> bool
-val map : (element -> 'a) -> set -> (element * 'a) list
+val count : (element -> bool) -> set -> int
+
+(* ------------------------------------------------------------------------- *)
+(* Comparing. *)
+(* ------------------------------------------------------------------------- *)
+
+val compare : set * set -> order
+
+val equal : set -> set -> bool
+
+val subset : set -> set -> bool
+
+val disjoint : set -> set -> bool
+
+(* ------------------------------------------------------------------------- *)
+(* Converting to and from lists. *)
+(* ------------------------------------------------------------------------- *)
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
+(* ------------------------------------------------------------------------- *)
+(* Converting to and from maps. *)
+(* ------------------------------------------------------------------------- *)
+
+type 'a map
+
+val mapPartial : (element -> 'a option) -> set -> 'a map
+
+val map : (element -> 'a) -> set -> 'a map
+
+val domain : 'a map -> set
+
+(* ------------------------------------------------------------------------- *)
+(* Pretty-printing. *)
+(* ------------------------------------------------------------------------- *)
val toString : set -> string
@@ -2955,1128 +5909,369 @@
(* ========================================================================= *)
(* 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;
+(* Copyright (c) 2004 Joe Hurd, distributed under the BSD License *)
+(* ========================================================================= *)
+
+functor ElementSet (KM : KeyMap) :> ElementSet
+where type element = KM.key and type 'a map = 'a KM.map =
+struct
+
+(* ------------------------------------------------------------------------- *)
+(* A type of set elements. *)
+(* ------------------------------------------------------------------------- *)
+
+type element = KM.key;
+
+(* ------------------------------------------------------------------------- *)
+(* A type of finite sets. *)
+(* ------------------------------------------------------------------------- *)
+
+type 'a map = 'a KM.map;
+
+datatype set = Set of unit map;
+
+(* ------------------------------------------------------------------------- *)
+(* Converting to and from maps. *)
+(* ------------------------------------------------------------------------- *)
+
+fun dest (Set m) = m;
+
+fun mapPartial f =
+ let
+ fun mf (elt,()) = f elt
+ in
+ fn Set m => KM.mapPartial mf m
+ end;
+
+fun map f =
+ let
+ fun mf (elt,()) = f elt
+ in
+ fn Set m => KM.map mf m
+ end;
+
+fun domain m = Set (KM.transform (fn _ => ()) m);
+
+(* ------------------------------------------------------------------------- *)
+(* Constructors. *)
+(* ------------------------------------------------------------------------- *)
+
+val empty = Set (KM.new ());
+
+fun singleton elt = Set (KM.singleton (elt,()));
+
+(* ------------------------------------------------------------------------- *)
+(* Set size. *)
+(* ------------------------------------------------------------------------- *)
+
+fun null (Set m) = KM.null m;
+
+fun size (Set m) = KM.size m;
+
+(* ------------------------------------------------------------------------- *)
+(* Querying. *)
+(* ------------------------------------------------------------------------- *)
+
+fun peek (Set m) elt =
+ case KM.peekKey m elt of
+ SOME (elt,()) => SOME elt
+ | NONE => NONE;
+
+fun member elt (Set m) = KM.inDomain elt m;
+
+fun pick (Set m) =
+ let
+ val (elt,_) = KM.pick m
+ in
+ elt
+ end;
+
+fun nth (Set m) n =
+ let
+ val (elt,_) = KM.nth m n
+ in
+ elt
+ end;
+
+fun random (Set m) =
+ let
+ val (elt,_) = KM.random m
+ in
+ elt
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Adding. *)
+(* ------------------------------------------------------------------------- *)
+
+fun add (Set m) elt =
+ let
+ val m = KM.insert m (elt,())
+ in
+ Set m
+ end;
+
+local
+ fun uncurriedAdd (elt,set) = add set elt;
+in
+ fun addList set = List.foldl uncurriedAdd set;
+end;
+
+(* ------------------------------------------------------------------------- *)
+(* Removing. *)
+(* ------------------------------------------------------------------------- *)
+
+fun delete (Set m) elt =
+ let
+ val m = KM.delete m elt
+ in
+ Set m
+ end;
+
+fun remove (Set m) elt =
+ let
+ val m = KM.remove m elt
+ in
+ Set m
+ end;
+
+fun deletePick (Set m) =
+ let
+ val ((elt,()),m) = KM.deletePick m
+ in
+ (elt, Set m)
+ end;
+
+fun deleteNth (Set m) n =
+ let
+ val ((elt,()),m) = KM.deleteNth m n
+ in
+ (elt, Set m)
+ end;
+
+fun deleteRandom (Set m) =
+ let
+ val ((elt,()),m) = KM.deleteRandom m
+ in
+ (elt, Set m)
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Joining. *)
+(* ------------------------------------------------------------------------- *)
+
+fun op union (Set m1) (Set m2) = Set (KM.unionDomain m1 m2);
+
+fun unionList sets =
+ let
+ val ms = List.map dest sets
+ in
+ Set (KM.unionListDomain ms)
+ end;
+
+fun intersect (Set m1) (Set m2) = Set (KM.intersectDomain m1 m2);
+
+fun intersectList sets =
+ let
+ val ms = List.map dest sets
+ in
+ Set (KM.intersectListDomain ms)
+ end;
+
+fun difference (Set m1) (Set m2) =
+ Set (KM.differenceDomain m1 m2);
+
+fun symmetricDifference (Set m1) (Set m2) =
+ Set (KM.symmetricDifferenceDomain m1 m2);
+
+(* ------------------------------------------------------------------------- *)
+(* Mapping and folding. *)
+(* ------------------------------------------------------------------------- *)
+
+fun filter pred =
+ let
+ fun mpred (elt,()) = pred elt
+ in
+ fn Set m => Set (KM.filter mpred m)
+ end;
+
+fun partition pred =
+ let
+ fun mpred (elt,()) = pred elt
+ in
+ fn Set m =>
+ let
+ val (m1,m2) = KM.partition mpred m
+ in
+ (Set m1, Set m2)
+ end
+ end;
+
+fun app f =
+ let
+ fun mf (elt,()) = f elt
+ in
+ fn Set m => KM.app mf m
+ end;
+
+fun foldl f =
+ let
+ fun mf (elt,(),acc) = f (elt,acc)
+ in
+ fn acc => fn Set m => KM.foldl mf acc m
+ end;
+
+fun foldr f =
+ let
+ fun mf (elt,(),acc) = f (elt,acc)
+ in
+ fn acc => fn Set m => KM.foldr mf acc m
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Searching. *)
+(* ------------------------------------------------------------------------- *)
+
+fun findl p =
+ let
+ fun mp (elt,()) = p elt
+ in
+ fn Set m =>
+ case KM.findl mp m of
+ SOME (elt,()) => SOME elt
+ | NONE => NONE
+ end;
+
+fun findr p =
+ let
+ fun mp (elt,()) = p elt
+ in
+ fn Set m =>
+ case KM.findr mp m of
+ SOME (elt,()) => SOME elt
+ | NONE => NONE
+ end;
+
+fun firstl f =
+ let
+ fun mf (elt,()) = f elt
+ in
+ fn Set m => KM.firstl mf m
+ end;
+
+fun firstr f =
+ let
+ fun mf (elt,()) = f elt
+ in
+ fn Set m => KM.firstr mf m
+ end;
+
+fun exists p =
+ let
+ fun mp (elt,()) = p elt
+ in
+ fn Set m => KM.exists mp m
+ end;
+
+fun all p =
+ let
+ fun mp (elt,()) = p elt
+ in
+ fn Set m => KM.all mp m
+ end;
+
+fun count p =
+ let
+ fun mp (elt,()) = p elt
+ in
+ fn Set m => KM.count mp m
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Comparing. *)
+(* ------------------------------------------------------------------------- *)
+
+fun compareValue ((),()) = EQUAL;
+
+fun equalValue () () = true;
+
+fun compare (Set m1, Set m2) = KM.compare compareValue (m1,m2);
+
+fun equal (Set m1) (Set m2) = KM.equal equalValue m1 m2;
+
+fun op subset (Set m1) (Set m2) = KM.subsetDomain m1 m2;
+
+fun disjoint (Set m1) (Set m2) = KM.disjointDomain m1 m2;
+
+(* ------------------------------------------------------------------------- *)
+(* Converting to and from lists. *)
+(* ------------------------------------------------------------------------- *)
+
+fun transform f =
+ let
+ fun inc (x,l) = f x :: l
+ in
+ foldr inc []
+ end;
+
+fun toList (Set m) = KM.keys m;
+
+fun fromList elts = addList empty elts;
+
+(* ------------------------------------------------------------------------- *)
+(* Pretty-printing. *)
+(* ------------------------------------------------------------------------- *)
+
+fun toString set =
+ "{" ^ (if null set then "" else Int.toString (size set)) ^ "}";
(* ------------------------------------------------------------------------- *)
(* 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;
+type iterator = unit KM.iterator;
+
+fun mkIterator (Set m) = KM.mkIterator m;
+
+fun mkRevIterator (Set m) = KM.mkRevIterator m;
+
+fun readIterator iter =
+ let
+ val (elt,()) = KM.readIterator iter
+ in
+ elt
+ end;
+
+fun advanceIterator iter = KM.advanceIterator iter;
+
+end
structure IntSet =
-ElementSet (IntOrdered);
+ElementSet (IntMap);
+
+structure IntPairSet =
+ElementSet (IntPairMap);
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;
-val explode = String.explode;
-val implode = String.implode;
-val print = TextIO.print;
-val foldl = List.foldl;
-val foldr = List.foldr;
-
-(* ========================================================================= *)
-(* 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;
-val explode = String.explode;
-val implode = String.implode;
-val print = TextIO.print;
-val foldl = List.foldl;
-val foldr = List.foldr;
-
-(* ========================================================================= *)
-(* 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;
+ElementSet (StringMap);
(**** Original file: Sharing.sig ****)
(* ========================================================================= *)
(* PRESERVING SHARING OF ML VALUES *)
-(* Copyright (c) 2005-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2005-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Sharing =
sig
(* ------------------------------------------------------------------------- *)
-(* Pointer equality. *)
-(* ------------------------------------------------------------------------- *)
-
-val pointerEqual : 'a * 'a -> bool
+(* Option operations. *)
+(* ------------------------------------------------------------------------- *)
+
+val mapOption : ('a -> 'a) -> 'a option -> 'a option
+
+val mapsOption : ('a -> 's -> 'a * 's) -> 'a option -> 's -> 'a option * 's
(* ------------------------------------------------------------------------- *)
(* List operations. *)
@@ -4084,6 +6279,12 @@
val map : ('a -> 'a) -> 'a list -> 'a list
+val revMap : ('a -> 'a) -> 'a list -> 'a list
+
+val maps : ('a -> 's -> 'a * 's) -> 'a list -> 's -> 'a list * 's
+
+val revMaps : ('a -> 's -> 'a * 's) -> 'a list -> 's -> 'a list * 's
+
val updateNth : int * 'a -> 'a list -> 'a list
val setify : ''a list -> ''a list
@@ -4106,7 +6307,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -4115,7 +6316,7 @@
(* ========================================================================= *)
(* PRESERVING SHARING OF ML VALUES *)
-(* Copyright (c) 2005-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2005-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Sharing :> Sharing =
@@ -4123,13 +6324,31 @@
infix ==
-(* ------------------------------------------------------------------------- *)
-(* Pointer equality. *)
-(* ------------------------------------------------------------------------- *)
-
-val pointerEqual = Portable.pointerEqual;
-
-val op== = pointerEqual;
+val op== = Portable.pointerEqual;
+
+(* ------------------------------------------------------------------------- *)
+(* Option operations. *)
+(* ------------------------------------------------------------------------- *)
+
+fun mapOption f xo =
+ case xo of
+ SOME x =>
+ let
+ val y = f x
+ in
+ if x == y then xo else SOME y
+ end
+ | NONE => xo;
+
+fun mapsOption f xo acc =
+ case xo of
+ SOME x =>
+ let
+ val (y,acc) = f x acc
+ in
+ if x == y then (xo,acc) else (SOME y, acc)
+ end
+ | NONE => (xo,acc);
(* ------------------------------------------------------------------------- *)
(* List operations. *)
@@ -4137,17 +6356,78 @@
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 m ys ys_xs xs =
+ case xs of
+ [] => List.revAppend ys_xs
+ | x :: xs =>
+ let
+ val y = f x
+ val ys = y :: ys
+ val ys_xs = if x == y then ys_xs else (ys,xs)
+ in
+ m ys ys_xs xs
+ end
+ in
+ fn xs => m [] ([],xs) xs
+ end;
+
+fun maps f =
+ let
+ fun m acc ys ys_xs xs =
+ case xs of
+ [] => (List.revAppend ys_xs, acc)
+ | x :: xs =>
+ let
+ val (y,acc) = f x acc
+ val ys = y :: ys
+ val ys_xs = if x == y then ys_xs else (ys,xs)
+ in
+ m acc ys ys_xs xs
+ end
+ in
+ fn xs => fn acc => m acc [] ([],xs) xs
+ end;
+
+local
+ fun revTails acc xs =
+ case xs of
+ [] => acc
+ | x :: xs' => revTails ((x,xs) :: acc) xs';
+in
+ fun revMap f =
+ let
+ fun m ys same xxss =
+ case xxss of
+ [] => ys
+ | (x,xs) :: xxss =>
+ let
+ val y = f x
+ val same = same andalso x == y
+ val ys = if same then xs else y :: ys
+ in
+ m ys same xxss
+ end
+ in
+ fn xs => m [] true (revTails [] xs)
+ end;
+
+ fun revMaps f =
+ let
+ fun m acc ys same xxss =
+ case xxss of
+ [] => (ys,acc)
+ | (x,xs) :: xxss =>
+ let
+ val (y,acc) = f x acc
+ val same = same andalso x == y
+ val ys = if same then xs else y :: ys
+ in
+ m acc ys same xxss
+ end
+ in
+ fn xs => fn acc => m acc [] true (revTails [] xs)
+ end;
+end;
fun updateNth (n,x) l =
let
@@ -4194,329 +6474,11 @@
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;
-val explode = String.explode;
-val implode = String.implode;
-val print = TextIO.print;
-val foldl = List.foldl;
-val foldr = List.foldr;
-
-(* ========================================================================= *)
-(* 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 *)
+(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Heap =
@@ -4550,7 +6512,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -4559,7 +6521,7 @@
(* ========================================================================= *)
(* A HEAP DATATYPE FOR ML *)
-(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Heap :> Heap =
@@ -4622,12 +6584,12 @@
end;
fun toStream h =
- if null h then Stream.NIL
+ if null h then Stream.Nil
else
let
val (x,h) = remove h
in
- Stream.CONS (x, fn () => toStream h)
+ Stream.Cons (x, fn () => toStream h)
end;
fun toString h =
@@ -4636,89 +6598,1345 @@
end
end;
-(**** Original file: Parser.sig ****)
-
-(* ========================================================================= *)
-(* PARSING AND PRETTY PRINTING *)
-(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
-(* ========================================================================= *)
-
-signature Parser =
+(**** Original file: Print.sig ****)
+
+(* ========================================================================= *)
+(* PRETTY-PRINTING *)
+(* Copyright (c) 2001-2008 Joe Hurd, distributed under the BSD License *)
+(* ========================================================================= *)
+
+signature Print =
sig
(* ------------------------------------------------------------------------- *)
-(* Pretty printing for built-in types *)
-(* ------------------------------------------------------------------------- *)
-
-type ppstream = Metis.PP.ppstream
+(* A type of pretty-printers. *)
+(* ------------------------------------------------------------------------- *)
datatype breakStyle = Consistent | Inconsistent
-type 'a pp = ppstream -> 'a -> unit
-
-val lineLength : int Unsynchronized.ref
-
-val beginBlock : ppstream -> breakStyle -> int -> unit
-
-val endBlock : ppstream -> unit
-
-val addString : ppstream -> string -> unit
-
-val addBreak : ppstream -> int * int -> unit
-
-val addNewline : ppstream -> unit
+datatype ppStep =
+ BeginBlock of breakStyle * int
+ | EndBlock
+ | AddString of string
+ | AddBreak of int
+ | AddNewline
+
+type ppstream = ppStep Metis.Stream.stream
+
+type 'a pp = 'a -> ppstream
+
+(* ------------------------------------------------------------------------- *)
+(* Pretty-printer primitives. *)
+(* ------------------------------------------------------------------------- *)
+
+val beginBlock : breakStyle -> int -> ppstream
+
+val endBlock : ppstream
+
+val addString : string -> ppstream
+
+val addBreak : int -> ppstream
+
+val addNewline : ppstream
+
+val skip : ppstream
+
+val sequence : ppstream -> ppstream -> ppstream
+
+val duplicate : int -> ppstream -> ppstream
+
+val program : ppstream list -> ppstream
+
+val stream : ppstream Metis.Stream.stream -> ppstream
+
+val block : breakStyle -> int -> ppstream -> ppstream
+
+val blockProgram : breakStyle -> int -> ppstream list -> ppstream
+
+val bracket : string -> string -> ppstream -> ppstream
+
+val field : string -> ppstream -> ppstream
+
+val record : (string * ppstream) list -> ppstream
+
+(* ------------------------------------------------------------------------- *)
+(* Pretty-printer combinators. *)
+(* ------------------------------------------------------------------------- *)
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 ppOp : string -> ppstream
+
+val ppOp2 : string -> 'a pp -> 'b pp -> ('a * 'b) pp
+
+val ppOp3 : string -> string -> 'a pp -> 'b pp -> 'c pp -> ('a * 'b * 'c) pp
+
+val ppOpList : string -> 'a pp -> 'a list pp
+
+val ppOpStream : string -> 'a pp -> 'a Metis.Stream.stream pp
+
+(* ------------------------------------------------------------------------- *)
+(* Pretty-printers for common types. *)
+(* ------------------------------------------------------------------------- *)
val ppChar : char pp
val ppString : string pp
+val ppEscapeString : {escape : char list} -> string pp
+
val ppUnit : unit pp
val ppBool : bool pp
val ppInt : int pp
+val ppPrettyInt : int pp
+
val ppReal : real pp
+val ppPercent : real pp
+
val ppOrder : order pp
val ppList : 'a pp -> 'a list pp
+val ppStream : 'a pp -> 'a Metis.Stream.stream 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:
+val ppBreakStyle : breakStyle pp
+
+val ppPpStep : ppStep pp
+
+val ppPpstream : ppstream pp
+
+(* ------------------------------------------------------------------------- *)
+(* Pretty-printing infix operators. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype infixes =
+ Infixes of
+ {token : string,
+ precedence : int,
+ leftAssoc : bool} list
+
+val tokensInfixes : infixes -> StringSet.set (* MODIFIED by Jasmin Blanchette *)
+
+val layerInfixes :
+ infixes ->
+ {tokens : {leftSpaces : int, token : string, rightSpaces : int} list,
+ leftAssoc : bool} list
+
+val ppInfixes :
+ infixes -> ('a -> (string * 'a * 'a) option) -> ('a * bool) pp ->
+ ('a * bool) pp
+
+(* ------------------------------------------------------------------------- *)
+(* Executing pretty-printers to generate lines. *)
+(* ------------------------------------------------------------------------- *)
+
+val execute : {lineLength : int} -> ppstream -> string Metis.Stream.stream
+
+(* ------------------------------------------------------------------------- *)
+(* Executing pretty-printers with a global line length. *)
+(* ------------------------------------------------------------------------- *)
+
+val lineLength : int Unsynchronized.ref
+
+val toString : 'a pp -> 'a -> string
+
+val toStream : 'a pp -> 'a -> string Metis.Stream.stream
+
+val trace : 'a pp -> string -> 'a -> unit
+
+end
+
+(**** Original file: Print.sml ****)
+
+structure Metis = struct open Metis
+(* Metis-specific ML environment *)
+nonfix ++ -- RL;
+val explode = String.explode;
+val implode = String.implode;
+val print = TextIO.print;
+val foldl = List.foldl;
+val foldr = List.foldr;
+
+(* ========================================================================= *)
+(* PRETTY-PRINTING *)
+(* Copyright (c) 2001-2008 Joe Hurd, distributed under the BSD License *)
+(* ========================================================================= *)
+
+structure Print :> Print =
+struct
+
+open Useful;
+
+(* ------------------------------------------------------------------------- *)
+(* Constants. *)
+(* ------------------------------------------------------------------------- *)
+
+val initialLineLength = 75;
+
+(* ------------------------------------------------------------------------- *)
+(* Helper functions. *)
+(* ------------------------------------------------------------------------- *)
+
+fun revAppend xs s =
+ case xs of
+ [] => s ()
+ | x :: xs => revAppend xs (K (Stream.Cons (x,s)));
+
+fun revConcat strm =
+ case strm of
+ Stream.Nil => Stream.Nil
+ | Stream.Cons (h,t) => revAppend h (revConcat o t);
+
+local
+ fun join current prev = (prev ^ "\n", current);
+in
+ fun joinNewline strm =
+ case strm of
+ Stream.Nil => Stream.Nil
+ | Stream.Cons (h,t) => Stream.maps join Stream.singleton h (t ());
+end;
+
+local
+ fun calcSpaces n = nChars #" " n;
+
+ val cachedSpaces = Vector.tabulate (initialLineLength,calcSpaces);
+in
+ fun nSpaces n =
+ if n < initialLineLength then Vector.sub (cachedSpaces,n)
+ else calcSpaces n;
+end;
+
+(* ------------------------------------------------------------------------- *)
+(* A type of pretty-printers. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype breakStyle = Consistent | Inconsistent;
+
+datatype ppStep =
+ BeginBlock of breakStyle * int
+ | EndBlock
+ | AddString of string
+ | AddBreak of int
+ | AddNewline;
+
+type ppstream = ppStep Stream.stream;
+
+type 'a pp = 'a -> ppstream;
+
+fun breakStyleToString style =
+ case style of
+ Consistent => "Consistent"
+ | Inconsistent => "Inconsistent";
+
+fun ppStepToString step =
+ case step of
+ BeginBlock _ => "BeginBlock"
+ | EndBlock => "EndBlock"
+ | AddString _ => "AddString"
+ | AddBreak _ => "AddBreak"
+ | AddNewline => "AddNewline";
+
+(* ------------------------------------------------------------------------- *)
+(* Pretty-printer primitives. *)
+(* ------------------------------------------------------------------------- *)
+
+fun beginBlock style indent = Stream.singleton (BeginBlock (style,indent));
+
+val endBlock = Stream.singleton EndBlock;
+
+fun addString s = Stream.singleton (AddString s);
+
+fun addBreak spaces = Stream.singleton (AddBreak spaces);
+
+val addNewline = Stream.singleton AddNewline;
+
+val skip : ppstream = Stream.Nil;
+
+fun sequence pp1 pp2 : ppstream = Stream.append pp1 (K pp2);
+
+local
+ fun dup pp n () = if n = 1 then pp else Stream.append pp (dup pp (n - 1));
+in
+ fun duplicate n pp = if n = 0 then skip else dup pp n ();
+end;
+
+val program : ppstream list -> ppstream = Stream.concatList;
+
+val stream : ppstream Stream.stream -> ppstream = Stream.concat;
+
+fun block style indent pp = program [beginBlock style indent, pp, endBlock];
+
+fun blockProgram style indent pps = block style indent (program pps);
+
+fun bracket l r pp =
+ blockProgram Inconsistent (size l)
+ [addString l,
+ pp,
+ addString r];
+
+fun field f pp =
+ blockProgram Inconsistent 2
+ [addString (f ^ " ="),
+ addBreak 1,
+ pp];
+
+val record =
+ let
+ val sep = sequence (addString ",") (addBreak 1)
+
+ fun recordField (f,pp) = field f pp
+
+ fun sepField f = sequence sep (recordField f)
+
+ fun fields [] = []
+ | fields (f :: fs) = recordField f :: map sepField fs
+ in
+ bracket "{" "}" o blockProgram Consistent 0 o fields
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Pretty-printer combinators. *)
+(* ------------------------------------------------------------------------- *)
+
+fun ppMap f ppB a : ppstream = ppB (f a);
+
+fun ppBracket l r ppA a = bracket l r (ppA a);
+
+fun ppOp s = sequence (if s = "" then skip else addString s) (addBreak 1);
+
+fun ppOp2 ab ppA ppB (a,b) =
+ blockProgram Inconsistent 0
+ [ppA a,
+ ppOp ab,
+ ppB b];
+
+fun ppOp3 ab bc ppA ppB ppC (a,b,c) =
+ blockProgram Inconsistent 0
+ [ppA a,
+ ppOp ab,
+ ppB b,
+ ppOp bc,
+ ppC c];
+
+fun ppOpList s ppA =
+ let
+ fun ppOpA a = sequence (ppOp s) (ppA a)
+ in
+ fn [] => skip
+ | h :: t => blockProgram Inconsistent 0 (ppA h :: map ppOpA t)
+ end;
+
+fun ppOpStream s ppA =
+ let
+ fun ppOpA a = sequence (ppOp s) (ppA a)
+ in
+ fn Stream.Nil => skip
+ | Stream.Cons (h,t) =>
+ blockProgram Inconsistent 0
+ [ppA h,
+ Stream.concat (Stream.map ppOpA (t ()))]
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Pretty-printers for common types. *)
+(* ------------------------------------------------------------------------- *)
+
+fun ppChar c = addString (str c);
+
+val ppString = addString;
+
+fun ppEscapeString {escape} =
+ let
+ val escapeMap = map (fn c => (c, "\\" ^ str c)) escape
+
+ fun escapeChar c =
+ case c of
+ #"\\" => "\\\\"
+ | #"\n" => "\\n"
+ | #"\t" => "\\t"
+ | _ =>
+ case List.find (equal c o fst) escapeMap of
+ SOME (_,s) => s
+ | NONE => str c
+ in
+ fn s => addString (String.translate escapeChar s)
+ end;
+
+val ppUnit : unit pp = K (addString "()");
+
+fun ppBool b = addString (if b then "true" else "false");
+
+fun ppInt i = addString (Int.toString i);
+
+local
+ val ppNeg = addString "~"
+ and ppSep = addString ","
+ and ppZero = addString "0"
+ and ppZeroZero = addString "00";
+
+ fun ppIntBlock i =
+ if i < 10 then sequence ppZeroZero (ppInt i)
+ else if i < 100 then sequence ppZero (ppInt i)
+ else ppInt i;
+
+ fun ppIntBlocks i =
+ if i < 1000 then ppInt i
+ else sequence (ppIntBlocks (i div 1000))
+ (sequence ppSep (ppIntBlock (i mod 1000)));
+in
+ fun ppPrettyInt i =
+ if i < 0 then sequence ppNeg (ppIntBlocks (~i))
+ else ppIntBlocks i;
+end;
+
+fun ppReal r = addString (Real.toString r);
+
+fun ppPercent p = addString (percentToString p);
+
+fun ppOrder x =
+ addString
+ (case x of
+ LESS => "Less"
+ | EQUAL => "Equal"
+ | GREATER => "Greater");
+
+fun ppList ppA = ppBracket "[" "]" (ppOpList "," ppA);
+
+fun ppStream ppA = ppBracket "[" "]" (ppOpStream "," ppA);
+
+fun ppOption ppA ao =
+ case ao of
+ SOME a => ppA a
+ | NONE => addString "-";
+
+fun ppPair ppA ppB = ppBracket "(" ")" (ppOp2 "," ppA ppB);
+
+fun ppTriple ppA ppB ppC = ppBracket "(" ")" (ppOp3 "," "," ppA ppB ppC);
+
+fun ppBreakStyle style = addString (breakStyleToString style);
+
+fun ppPpStep step =
+ let
+ val cmd = ppStepToString step
+ in
+ blockProgram Inconsistent 2
+ (addString cmd ::
+ (case step of
+ BeginBlock style_indent =>
+ [addBreak 1,
+ ppPair ppBreakStyle ppInt style_indent]
+ | EndBlock => []
+ | AddString s =>
+ [addBreak 1,
+ addString ("\"" ^ s ^ "\"")]
+ | AddBreak n =>
+ [addBreak 1,
+ ppInt n]
+ | AddNewline => []))
+ end;
+
+val ppPpstream = ppStream ppPpStep;
+
+(* ------------------------------------------------------------------------- *)
+(* Pretty-printing infix operators. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype infixes =
+ Infixes of
+ {token : string,
+ precedence : int,
+ leftAssoc : bool} list;
+
+local
+ fun chop l =
+ case l of
+ #" " :: l => let val (n,l) = chop l in (n + 1, l) end
+ | _ => (0,l);
+in
+ fun opSpaces tok =
+ let
+ val tok = explode tok
+ val (r,tok) = chop (rev tok)
+ val (l,tok) = chop (rev tok)
+ val tok = implode tok
+ in
+ {leftSpaces = l, token = tok, rightSpaces = r}
+ end;
+end;
+
+fun ppOpSpaces {leftSpaces,token,rightSpaces} =
+ let
+ val leftSpacesToken =
+ if leftSpaces = 0 then token else nSpaces leftSpaces ^ token
+ in
+ sequence
+ (addString leftSpacesToken)
+ (addBreak rightSpaces)
+ end;
+
+local
+ fun new t l acc = {tokens = [opSpaces t], leftAssoc = l} :: acc;
+
+ fun add t l acc =
+ case acc of
+ [] => raise Bug "Print.layerInfixOps.layer"
+ | {tokens = ts, leftAssoc = l'} :: acc =>
+ if l = l' then {tokens = opSpaces t :: ts, leftAssoc = l} :: acc
+ else raise Bug "Print.layerInfixOps: mixed assocs";
+
+ fun layer ({token = t, precedence = p, leftAssoc = l}, (acc,p')) =
+ let
+ val acc = if p = p' then add t l acc else new t l acc
+ in
+ (acc,p)
+ end;
+in
+ fun layerInfixes (Infixes i) =
+ case sortMap #precedence Int.compare i of
+ [] => []
+ | {token = t, precedence = p, leftAssoc = l} :: i =>
+ let
+ val acc = new t l []
+
+ val (acc,_) = List.foldl layer (acc,p) i
+ in
+ acc
+ end;
+end;
+
+val tokensLayeredInfixes =
+ let
+ fun addToken ({leftSpaces = _, token = t, rightSpaces = _}, s) =
+ StringSet.add s t
+
+ fun addTokens ({tokens = t, leftAssoc = _}, s) =
+ List.foldl addToken s t
+ in
+ List.foldl addTokens StringSet.empty
+ end;
+
+val tokensInfixes = tokensLayeredInfixes o layerInfixes;
+
+local
+ val mkTokenMap =
+ let
+ fun add (token,m) =
+ let
+ val {leftSpaces = _, token = t, rightSpaces = _} = token
+ in
+ StringMap.insert m (t, ppOpSpaces token)
+ end
+ in
+ List.foldl add (StringMap.new ())
+ end;
+in
+ fun ppGenInfix {tokens,leftAssoc} =
+ let
+ val tokenMap = mkTokenMap tokens
+ in
+ fn dest => fn ppSub =>
+ let
+ fun dest' tm =
+ case dest tm of
+ NONE => NONE
+ | SOME (t,a,b) =>
+ case StringMap.peek tokenMap t of
+ NONE => NONE
+ | SOME p => SOME (p,a,b)
+
+ fun ppGo (tmr as (tm,r)) =
+ case dest' tm of
+ NONE => ppSub tmr
+ | SOME (p,a,b) =>
+ program
+ [(if leftAssoc then ppGo else ppSub) (a,true),
+ p,
+ (if leftAssoc then ppSub else ppGo) (b,r)]
+ in
+ fn tmr as (tm,_) =>
+ if Option.isSome (dest' tm) then
+ block Inconsistent 0 (ppGo tmr)
+ else
+ ppSub tmr
+ end
+ end;
+end
+
+fun ppInfixes ops =
+ let
+ val layeredOps = layerInfixes ops
+
+ val toks = tokensLayeredInfixes layeredOps
+
+ val iprinters = List.map ppGenInfix 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,_,_) => StringSet.member x toks
+ | NONE => false
+
+ fun subpr (tmr as (tm,_)) =
+ if isOp tm then
+ blockProgram Inconsistent 1
+ [addString "(",
+ printer subpr (tm,false),
+ addString ")"]
+ else
+ ppSub tmr
+ in
+ fn tmr => block Inconsistent 0 (printer subpr tmr)
+ end
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Executing pretty-printers to generate lines. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype blockBreakStyle =
+ InconsistentBlock
+ | ConsistentBlock
+ | BreakingBlock;
+
+datatype block =
+ Block of
+ {indent : int,
+ style : blockBreakStyle,
+ size : int,
+ chunks : chunk list}
+
+and chunk =
+ StringChunk of {size : int, string : string}
+ | BreakChunk of int
+ | BlockChunk of block;
+
+datatype state =
+ State of
+ {blocks : block list,
+ lineIndent : int,
+ lineSize : int};
+
+val initialIndent = 0;
+
+val initialStyle = Inconsistent;
+
+fun liftStyle style =
+ case style of
+ Inconsistent => InconsistentBlock
+ | Consistent => ConsistentBlock;
+
+fun breakStyle style =
+ case style of
+ ConsistentBlock => BreakingBlock
+ | _ => style;
+
+fun sizeBlock (Block {size,...}) = size;
+
+fun sizeChunk chunk =
+ case chunk of
+ StringChunk {size,...} => size
+ | BreakChunk spaces => spaces
+ | BlockChunk block => sizeBlock block;
+
+val splitChunks =
+ let
+ fun split _ [] = NONE
+ | split acc (chunk :: chunks) =
+ case chunk of
+ BreakChunk _ => SOME (rev acc, chunks)
+ | _ => split (chunk :: acc) chunks
+ in
+ split []
+ end;
+
+val sizeChunks = List.foldl (fn (c,z) => sizeChunk c + z) 0;
+
+local
+ fun render acc [] = acc
+ | render acc (chunk :: chunks) =
+ case chunk of
+ StringChunk {string = s, ...} => render (acc ^ s) chunks
+ | BreakChunk n => render (acc ^ nSpaces n) chunks
+ | BlockChunk (Block {chunks = l, ...}) =>
+ render acc (List.revAppend (l,chunks));
+in
+ fun renderChunks indent chunks = render (nSpaces indent) (rev chunks);
+
+ fun renderChunk indent chunk = renderChunks indent [chunk];
+end;
+
+fun isEmptyBlock block =
+ let
+ val Block {indent = _, style = _, size, chunks} = block
+
+ val empty = null chunks
+
+(*BasicDebug
+ val _ = not empty orelse size = 0 orelse
+ raise Bug "Print.isEmptyBlock: bad size"
+*)
+ in
+ empty
+ end;
+
+fun checkBlock ind block =
+ let
+ val Block {indent, style = _, size, chunks} = block
+ val _ = indent >= ind orelse raise Bug "Print.checkBlock: bad indents"
+ val size' = checkChunks indent chunks
+ val _ = size = size' orelse raise Bug "Print.checkBlock: wrong size"
+ in
+ size
+ end
+
+and checkChunks ind chunks =
+ case chunks of
+ [] => 0
+ | chunk :: chunks => checkChunk ind chunk + checkChunks ind chunks
+
+and checkChunk ind chunk =
+ case chunk of
+ StringChunk {size,...} => size
+ | BreakChunk spaces => spaces
+ | BlockChunk block => checkBlock ind block;
+
+val checkBlocks =
+ let
+ fun check ind blocks =
+ case blocks of
+ [] => 0
+ | block :: blocks =>
+ let
+ val Block {indent,...} = block
+ in
+ checkBlock ind block + check indent blocks
+ end
+ in
+ check initialIndent o rev
+ end;
+
+val initialBlock =
+ let
+ val indent = initialIndent
+ val style = liftStyle initialStyle
+ val size = 0
+ val chunks = []
+ in
+ Block
+ {indent = indent,
+ style = style,
+ size = size,
+ chunks = chunks}
+ end;
+
+val initialState =
+ let
+ val blocks = [initialBlock]
+ val lineIndent = initialIndent
+ val lineSize = 0
+ in
+ State
+ {blocks = blocks,
+ lineIndent = lineIndent,
+ lineSize = lineSize}
+ end;
+
+(*BasicDebug
+fun checkState state =
+ (let
+ val State {blocks, lineIndent = _, lineSize} = state
+ val lineSize' = checkBlocks blocks
+ val _ = lineSize = lineSize' orelse
+ raise Error "wrong lineSize"
+ in
+ ()
+ end
+ handle Error err => raise Bug err)
+ handle Bug bug => raise Bug ("Print.checkState: " ^ bug);
+*)
+
+fun isFinalState state =
+ let
+ val State {blocks,lineIndent,lineSize} = state
+ in
+ case blocks of
+ [] => raise Bug "Print.isFinalState: no block"
+ | [block] => isEmptyBlock block
+ | _ :: _ :: _ => false
+ end;
+
+local
+ fun renderBreak lineIndent (chunks,lines) =
+ let
+ val line = renderChunks lineIndent chunks
+
+ val lines = line :: lines
+ in
+ lines
+ end;
+
+ fun renderBreaks lineIndent lineIndent' breaks lines =
+ case rev breaks of
+ [] => raise Bug "Print.renderBreaks"
+ | c :: cs =>
+ let
+ val lines = renderBreak lineIndent (c,lines)
+ in
+ List.foldl (renderBreak lineIndent') lines cs
+ end;
+
+ fun splitAllChunks cumulatingChunks =
+ let
+ fun split chunks =
+ case splitChunks chunks of
+ SOME (prefix,chunks) => prefix :: split chunks
+ | NONE => [List.concat (chunks :: cumulatingChunks)]
+ in
+ split
+ end;
+
+ fun mkBreak style cumulatingChunks chunks =
+ case splitChunks chunks of
+ NONE => NONE
+ | SOME (chunks,broken) =>
+ let
+ val breaks =
+ case style of
+ InconsistentBlock =>
+ [List.concat (broken :: cumulatingChunks)]
+ | _ => splitAllChunks cumulatingChunks broken
+ in
+ SOME (breaks,chunks)
+ end;
+
+ fun naturalBreak blocks =
+ case blocks of
+ [] => Right ([],[])
+ | block :: blocks =>
+ case naturalBreak blocks of
+ Left (breaks,blocks,lineIndent,lineSize) =>
+ let
+ val Block {size,...} = block
+
+ val blocks = block :: blocks
+
+ val lineSize = lineSize + size
+ in
+ Left (breaks,blocks,lineIndent,lineSize)
+ end
+ | Right (cumulatingChunks,blocks) =>
+ let
+ val Block {indent,style,size,chunks} = block
+
+ val style = breakStyle style
+ in
+ case mkBreak style cumulatingChunks chunks of
+ SOME (breaks,chunks) =>
+ let
+ val size = sizeChunks chunks
+
+ val block =
+ Block
+ {indent = indent,
+ style = style,
+ size = size,
+ chunks = chunks}
+
+ val blocks = block :: blocks
+
+ val lineIndent = indent
+
+ val lineSize = size
+ in
+ Left (breaks,blocks,lineIndent,lineSize)
+ end
+ | NONE =>
+ let
+ val cumulatingChunks = chunks :: cumulatingChunks
+
+ val size = 0
+
+ val chunks = []
+
+ val block =
+ Block
+ {indent = indent,
+ style = style,
+ size = size,
+ chunks = chunks}
+
+ val blocks = block :: blocks
+ in
+ Right (cumulatingChunks,blocks)
+ end
+ end;
+
+ fun forceBreakBlock cumulatingChunks block =
+ let
+ val Block {indent, style, size = _, chunks} = block
+
+ val style = breakStyle style
+
+ val break =
+ case mkBreak style cumulatingChunks chunks of
+ SOME (breaks,chunks) =>
+ let
+ val lineSize = sizeChunks chunks
+ val lineIndent = indent
+ in
+ SOME (breaks,chunks,lineIndent,lineSize)
+ end
+ | NONE => forceBreakChunks cumulatingChunks chunks
+ in
+ case break of
+ SOME (breaks,chunks,lineIndent,lineSize) =>
+ let
+ val size = lineSize
+
+ val block =
+ Block
+ {indent = indent,
+ style = style,
+ size = size,
+ chunks = chunks}
+ in
+ SOME (breaks,block,lineIndent,lineSize)
+ end
+ | NONE => NONE
+ end
+
+ and forceBreakChunks cumulatingChunks chunks =
+ case chunks of
+ [] => NONE
+ | chunk :: chunks =>
+ case forceBreakChunk (chunks :: cumulatingChunks) chunk of
+ SOME (breaks,chunk,lineIndent,lineSize) =>
+ let
+ val chunks = [chunk]
+ in
+ SOME (breaks,chunks,lineIndent,lineSize)
+ end
+ | NONE =>
+ case forceBreakChunks cumulatingChunks chunks of
+ SOME (breaks,chunks,lineIndent,lineSize) =>
+ let
+ val chunks = chunk :: chunks
+
+ val lineSize = lineSize + sizeChunk chunk
+ in
+ SOME (breaks,chunks,lineIndent,lineSize)
+ end
+ | NONE => NONE
+
+ and forceBreakChunk cumulatingChunks chunk =
+ case chunk of
+ StringChunk _ => NONE
+ | BreakChunk _ => raise Bug "Print.forceBreakChunk: BreakChunk"
+ | BlockChunk block =>
+ case forceBreakBlock cumulatingChunks block of
+ SOME (breaks,block,lineIndent,lineSize) =>
+ let
+ val chunk = BlockChunk block
+ in
+ SOME (breaks,chunk,lineIndent,lineSize)
+ end
+ | NONE => NONE;
+
+ fun forceBreak cumulatingChunks blocks' blocks =
+ case blocks of
+ [] => NONE
+ | block :: blocks =>
+ let
+ val cumulatingChunks =
+ case cumulatingChunks of
+ [] => raise Bug "Print.forceBreak: null cumulatingChunks"
+ | _ :: cumulatingChunks => cumulatingChunks
+
+ val blocks' =
+ case blocks' of
+ [] => raise Bug "Print.forceBreak: null blocks'"
+ | _ :: blocks' => blocks'
+ in
+ case forceBreakBlock cumulatingChunks block of
+ SOME (breaks,block,lineIndent,lineSize) =>
+ let
+ val blocks = block :: blocks'
+ in
+ SOME (breaks,blocks,lineIndent,lineSize)
+ end
+ | NONE =>
+ case forceBreak cumulatingChunks blocks' blocks of
+ SOME (breaks,blocks,lineIndent,lineSize) =>
+ let
+ val blocks = block :: blocks
+
+ val Block {size,...} = block
+
+ val lineSize = lineSize + size
+ in
+ SOME (breaks,blocks,lineIndent,lineSize)
+ end
+ | NONE => NONE
+ end;
+
+ fun normalize lineLength lines state =
+ let
+ val State {blocks,lineIndent,lineSize} = state
+ in
+ if lineIndent + lineSize <= lineLength then (lines,state)
+ else
+ let
+ val break =
+ case naturalBreak blocks of
+ Left break => SOME break
+ | Right (c,b) => forceBreak c b blocks
+ in
+ case break of
+ SOME (breaks,blocks,lineIndent',lineSize) =>
+ let
+ val lines = renderBreaks lineIndent lineIndent' breaks lines
+
+ val state =
+ State
+ {blocks = blocks,
+ lineIndent = lineIndent',
+ lineSize = lineSize}
+ in
+ normalize lineLength lines state
+ end
+ | NONE => (lines,state)
+ end
+ end;
+
+(*BasicDebug
+ val normalize = fn lineLength => fn lines => fn state =>
+ let
+ val () = checkState state
+ in
+ normalize lineLength lines state
+ end
+ handle Bug bug =>
+ raise Bug ("Print.normalize: before normalize:\n" ^ bug)
+*)
+
+ fun executeBeginBlock (style,ind) lines state =
+ let
+ val State {blocks,lineIndent,lineSize} = state
+
+ val Block {indent,...} =
+ case blocks of
+ [] => raise Bug "Print.executeBeginBlock: no block"
+ | block :: _ => block
+
+ val indent = indent + ind
+
+ val style = liftStyle style
+
+ val size = 0
+
+ val chunks = []
+
+ val block =
+ Block
+ {indent = indent,
+ style = style,
+ size = size,
+ chunks = chunks}
+
+ val blocks = block :: blocks
+
+ val state =
+ State
+ {blocks = blocks,
+ lineIndent = lineIndent,
+ lineSize = lineSize}
+ in
+ (lines,state)
+ end;
+
+ fun executeEndBlock lines state =
+ let
+ val State {blocks,lineIndent,lineSize} = state
+
+ val (lineSize,blocks) =
+ case blocks of
+ [] => raise Bug "Print.executeEndBlock: no block"
+ | topBlock :: blocks =>
+ let
+ val Block
+ {indent = topIndent,
+ style = topStyle,
+ size = topSize,
+ chunks = topChunks} = topBlock
+ in
+ case topChunks of
+ [] => (lineSize,blocks)
+ | headTopChunks :: tailTopChunks =>
+ let
+ val (lineSize,topSize,topChunks) =
+ case headTopChunks of
+ BreakChunk spaces =>
+ let
+ val lineSize = lineSize - spaces
+ and topSize = topSize - spaces
+ and topChunks = tailTopChunks
+ in
+ (lineSize,topSize,topChunks)
+ end
+ | _ => (lineSize,topSize,topChunks)
+
+ val topBlock =
+ Block
+ {indent = topIndent,
+ style = topStyle,
+ size = topSize,
+ chunks = topChunks}
+ in
+ case blocks of
+ [] => raise Error "Print.executeEndBlock: no block"
+ | block :: blocks =>
+ let
+ val Block {indent,style,size,chunks} = block
+
+ val size = size + topSize
+
+ val chunks = BlockChunk topBlock :: chunks
+
+ val block =
+ Block
+ {indent = indent,
+ style = style,
+ size = size,
+ chunks = chunks}
+
+ val blocks = block :: blocks
+ in
+ (lineSize,blocks)
+ end
+ end
+ end
+
+ val state =
+ State
+ {blocks = blocks,
+ lineIndent = lineIndent,
+ lineSize = lineSize}
+ in
+ (lines,state)
+ end;
+
+ fun executeAddString lineLength s lines state =
+ let
+ val State {blocks,lineIndent,lineSize} = state
+
+ val n = size s
+
+ val blocks =
+ case blocks of
+ [] => raise Bug "Print.executeAddString: no block"
+ | Block {indent,style,size,chunks} :: blocks =>
+ let
+ val size = size + n
+
+ val chunk = StringChunk {size = n, string = s}
+
+ val chunks = chunk :: chunks
+
+ val block =
+ Block
+ {indent = indent,
+ style = style,
+ size = size,
+ chunks = chunks}
+
+ val blocks = block :: blocks
+ in
+ blocks
+ end
+
+ val lineSize = lineSize + n
+
+ val state =
+ State
+ {blocks = blocks,
+ lineIndent = lineIndent,
+ lineSize = lineSize}
+ in
+ normalize lineLength lines state
+ end;
+
+ fun executeAddBreak lineLength spaces lines state =
+ let
+ val State {blocks,lineIndent,lineSize} = state
+
+ val (blocks,lineSize) =
+ case blocks of
+ [] => raise Bug "Print.executeAddBreak: no block"
+ | Block {indent,style,size,chunks} :: blocks' =>
+ case chunks of
+ [] => (blocks,lineSize)
+ | chunk :: chunks' =>
+ let
+ val spaces =
+ case style of
+ BreakingBlock => lineLength + 1
+ | _ => spaces
+
+ val size = size + spaces
+
+ val chunks =
+ case chunk of
+ BreakChunk k => BreakChunk (k + spaces) :: chunks'
+ | _ => BreakChunk spaces :: chunks
+
+ val block =
+ Block
+ {indent = indent,
+ style = style,
+ size = size,
+ chunks = chunks}
+
+ val blocks = block :: blocks'
+
+ val lineSize = lineSize + spaces
+ in
+ (blocks,lineSize)
+ end
+
+ val state =
+ State
+ {blocks = blocks,
+ lineIndent = lineIndent,
+ lineSize = lineSize}
+ in
+ normalize lineLength lines state
+ end;
+
+ fun executeBigBreak lineLength lines state =
+ executeAddBreak lineLength (lineLength + 1) lines state;
+
+ fun executeAddNewline lineLength lines state =
+ let
+ val (lines,state) = executeAddString lineLength "" lines state
+ val (lines,state) = executeBigBreak lineLength lines state
+ in
+ executeAddString lineLength "" lines state
+ end;
+
+ fun final lineLength lines state =
+ let
+ val lines =
+ if isFinalState state then lines
+ else
+ let
+ val (lines,state) = executeBigBreak lineLength lines state
+
+(*BasicDebug
+ val _ = isFinalState state orelse raise Bug "Print.final"
+*)
+ in
+ lines
+ end
+ in
+ if null lines then Stream.Nil else Stream.singleton lines
+ end;
+in
+ fun execute {lineLength} =
+ let
+ fun advance step state =
+ let
+ val lines = []
+ in
+ case step of
+ BeginBlock style_ind => executeBeginBlock style_ind lines state
+ | EndBlock => executeEndBlock lines state
+ | AddString s => executeAddString lineLength s lines state
+ | AddBreak spaces => executeAddBreak lineLength spaces lines state
+ | AddNewline => executeAddNewline lineLength lines state
+ end
+
+(*BasicDebug
+ val advance = fn step => fn state =>
+ let
+ val (lines,state) = advance step state
+ val () = checkState state
+ in
+ (lines,state)
+ end
+ handle Bug bug =>
+ raise Bug ("Print.advance: after " ^ ppStepToString step ^
+ " command:\n" ^ bug)
+*)
+ in
+ revConcat o Stream.maps advance (final lineLength []) initialState
+ end;
+end;
+
+(* ------------------------------------------------------------------------- *)
+(* Executing pretty-printers with a global line length. *)
+(* ------------------------------------------------------------------------- *)
+
+val lineLength = Unsynchronized.ref initialLineLength;
+
+fun toStream ppA a =
+ Stream.map (fn s => s ^ "\n")
+ (execute {lineLength = !lineLength} (ppA a));
+
+fun toString ppA a =
+ case execute {lineLength = !lineLength} (ppA a) of
+ Stream.Nil => ""
+ | Stream.Cons (h,t) => Stream.foldl (fn (s,z) => z ^ "\n" ^ s) h (t ());
+
+fun trace ppX nameX x =
+ Useful.trace (toString (ppOp2 " =" ppString ppX) (nameX,x) ^ "\n");
+
+end
+end;
+
+(**** Original file: Parse.sig ****)
+
+(* ========================================================================= *)
+(* PARSING *)
+(* Copyright (c) 2001 Joe Hurd, distributed under the BSD License *)
+(* ========================================================================= *)
+
+signature Parse =
+sig
+
+(* ------------------------------------------------------------------------- *)
+(* A "cannot parse" exception. *)
+(* ------------------------------------------------------------------------- *)
+
+exception NoParse
+
+(* ------------------------------------------------------------------------- *)
+(* Recursive descent parsing combinators. *)
+(* ------------------------------------------------------------------------- *)
+
+(*
+ 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
@@ -4741,12 +7959,12 @@
val optional : ('a -> 'b * 'a) -> 'a -> 'b option * 'a
-(* Stream based parsers *)
+(* ------------------------------------------------------------------------- *)
+(* 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
@@ -4755,26 +7973,49 @@
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
+(* ------------------------------------------------------------------------- *)
+(* Parsing whole streams. *)
+(* ------------------------------------------------------------------------- *)
+
+val fromStream : ('a,'b) parser -> 'a Metis.Stream.stream -> 'b
+
+val fromList : ('a,'b) parser -> 'a list -> 'b
+
+val everything : ('a, 'b list) parser -> 'a Metis.Stream.stream -> 'b Metis.Stream.stream
+
+(* ------------------------------------------------------------------------- *)
+(* Parsing lines of text. *)
+(* ------------------------------------------------------------------------- *)
+
+val initialize :
+ {lines : string Metis.Stream.stream} ->
+ {chars : char list Metis.Stream.stream,
+ parseErrorLocation : unit -> string}
+
+val exactChar : char -> (char,unit) parser
+
+val exactCharList : char list -> (char,unit) parser
+
+val exactString : string -> (char,unit) parser
+
+val escapeString : {escape : char list} -> (char,string) parser
+
+val manySpace : (char,unit) parser
+
+val atLeastOneSpace : (char,unit) parser
+
+val fromString : (char,'a) parser -> string -> 'a
+
+(* ------------------------------------------------------------------------- *)
+(* Infix operators. *)
+(* ------------------------------------------------------------------------- *)
val parseInfixes :
- infixities -> (string * 'a * 'a -> 'a) -> (string,'a) parser ->
+ Metis.Print.infixes -> (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 *)
+(* ------------------------------------------------------------------------- *)
+(* Quotations. *)
(* ------------------------------------------------------------------------- *)
type 'a quotation = 'a Metis.frag list
@@ -4783,11 +8024,11 @@
end
-(**** Original file: Parser.sml ****)
+(**** Original file: Parse.sml ****)
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -4795,12 +8036,14 @@
val foldr = List.foldr;
(* ========================================================================= *)
-(* PARSER COMBINATORS *)
-(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
-(* ========================================================================= *)
-
-structure Parser :> Parser =
-struct
+(* PARSING *)
+(* Copyright (c) 2001 Joe Hurd, distributed under the BSD License *)
+(* ========================================================================= *)
+
+structure Parse :> Parse =
+struct
+
+open Useful;
infixr 9 >>++
infixr 8 ++
@@ -4808,137 +8051,15 @@
infixr 6 ||
(* ------------------------------------------------------------------------- *)
-(* Helper functions. *)
-(* ------------------------------------------------------------------------- *)
-
-exception Bug = Useful.Bug;
-
-val trace = Useful.trace
-and equal = Useful.equal
-and I = Useful.I
-and K = Useful.K
-and C = Useful.C
-and fst = Useful.fst
-and snd = Useful.snd
-and pair = Useful.pair
-and curry = Useful.curry
-and funpow = Useful.funpow
-and mem = Useful.mem
-and sortMap = Useful.sortMap;
-
-(* ------------------------------------------------------------------------- *)
-(* Pretty printing for built-in types *)
-(* ------------------------------------------------------------------------- *)
-
-type ppstream = PP.ppstream
-
-datatype breakStyle = Consistent | Inconsistent
-
-type 'a pp = PP.ppstream -> 'a -> unit;
-
-val lineLength = Unsynchronized.ref 75;
-
-fun beginBlock pp Consistent = PP.begin_block pp PP.CONSISTENT
- | beginBlock pp Inconsistent = PP.begin_block pp PP.INCONSISTENT;
-
-val endBlock = PP.end_block
-and addString = PP.add_string
-and addBreak = PP.add_break
-and addNewline = PP.add_newline;
-
-fun ppMap f ppA (ppstrm : PP.ppstream) x : unit = ppA ppstrm (f x);
-
-fun ppBracket l r ppA pp a =
- let
- val ln = size l
- in
- beginBlock pp Inconsistent ln;
- if ln = 0 then () else addString pp l;
- ppA pp a;
- if r = "" then () else addString pp r;
- endBlock pp
- end;
-
-fun ppSequence sep ppA pp =
- let
- fun ppX x = (addString pp sep; addBreak pp (1,0); ppA pp x)
- in
- fn [] => ()
- | h :: t =>
- (beginBlock pp Inconsistent 0;
- ppA pp h;
- app ppX t;
- endBlock pp)
- end;
-
-fun ppBinop s ppA ppB pp (a,b) =
- (beginBlock pp Inconsistent 0;
- ppA pp a;
- if s = "" then () else addString pp s;
- addBreak pp (1,0);
- ppB pp b;
- endBlock pp);
-
-fun ppTrinop ab bc ppA ppB ppC pp (a,b,c) =
- (beginBlock pp Inconsistent 0;
- ppA pp a;
- if ab = "" then () else addString pp ab;
- addBreak pp (1,0);
- ppB pp b;
- if bc = "" then () else addString pp bc;
- addBreak pp (1,0);
- ppC pp c;
- endBlock pp);
-
-(* Pretty-printers for common types *)
-
-fun ppString pp s =
- (beginBlock pp Inconsistent 0;
- addString pp s;
- endBlock pp);
-
-val ppUnit = ppMap (fn () => "()") ppString;
-
-val ppChar = ppMap str ppString;
-
-val ppBool = ppMap (fn true => "true" | false => "false") ppString;
-
-val ppInt = ppMap Int.toString ppString;
-
-val ppReal = ppMap Real.toString ppString;
-
-val ppOrder =
- let
- fun f LESS = "Less"
- | f EQUAL = "Equal"
- | f GREATER = "Greater"
- in
- ppMap f ppString
- end;
-
-fun ppList ppA = ppBracket "[" "]" (ppSequence "," ppA);
-
-fun ppOption _ pp NONE = ppString pp "-"
- | ppOption ppA pp (SOME a) = ppA pp a;
-
-fun ppPair ppA ppB = ppBracket "(" ")" (ppBinop "," ppA ppB);
-
-fun ppTriple ppA ppB ppC = ppBracket "(" ")" (ppTrinop "," "," ppA ppB ppC);
-
-(* Keep eta expanded to evaluate lineLength when supplied with a *)
-fun toString ppA a = PP.pp_to_string (!lineLength) ppA a;
-
-fun fromString toS = ppMap toS ppString;
-
-fun ppTrace ppX nameX x =
- trace (toString (ppBinop " =" ppString ppX) (nameX,x) ^ "\n");
-
-(* ------------------------------------------------------------------------- *)
-(* Generic. *)
+(* A "cannot parse" exception. *)
(* ------------------------------------------------------------------------- *)
exception NoParse;
+(* ------------------------------------------------------------------------- *)
+(* Recursive descent parsing combinators. *)
+(* ------------------------------------------------------------------------- *)
+
val error : 'a -> 'b * 'a = fn _ => raise NoParse;
fun op ++ (parser1,parser2) input =
@@ -4981,7 +8102,7 @@
let
fun sparser l = parser >> (fn x => x :: l)
in
- mmany sparser [] >> rev
+ mmany sparser [] >> rev
end;
fun atLeastOne p = (p ++ many p) >> op::;
@@ -4991,191 +8112,179 @@
fun optional p = (p >> SOME) || (nothing >> K NONE);
(* ------------------------------------------------------------------------- *)
-(* Stream-based. *)
+(* Stream-based parsers. *)
(* ------------------------------------------------------------------------- *)
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)) =
+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 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);
+(* ------------------------------------------------------------------------- *)
+(* Parsing whole streams. *)
+(* ------------------------------------------------------------------------- *)
+
+fun fromStream parser input =
+ let
+ val (res,_) = (parser ++ finished >> fst) input
+ in
+ res
+ end;
+
+fun fromList parser l = fromStream parser (Stream.fromList l);
+
+fun everything parser =
+ let
+ fun parserOption input =
+ SOME (parser input)
+ handle e as NoParse => if Stream.null input then NONE else raise e
+
+ fun parserList input =
+ case parserOption input of
+ NONE => Stream.Nil
+ | SOME (result,input) =>
+ Stream.append (Stream.fromList result) (fn () => parserList input)
+ in
+ parserList
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Parsing lines of text. *)
+(* ------------------------------------------------------------------------- *)
+
+fun initialize {lines} =
+ let
+ val lastLine = Unsynchronized.ref (~1,"","","")
+
+ val chars =
+ let
+ fun saveLast line =
+ let
+ val Unsynchronized.ref (n,_,l2,l3) = lastLine
+ val () = lastLine := (n + 1, l2, l3, line)
+ in
+ explode line
+ end
+ in
+ Stream.memoize (Stream.map saveLast lines)
+ end
+
+ fun parseErrorLocation () =
+ let
+ val Unsynchronized.ref (n,l1,l2,l3) = lastLine
+ in
+ (if n <= 0 then "at start"
+ else "around line " ^ Int.toString n) ^
+ chomp (":\n" ^ l1 ^ l2 ^ l3)
+ end
+ in
+ {chars = chars,
+ parseErrorLocation = parseErrorLocation}
+ end;
+
+fun exactChar (c : char) = some (equal c) >> K ();
+
+fun exactCharList cs =
+ case cs of
+ [] => nothing
+ | c :: cs => (exactChar c ++ exactCharList cs) >> snd;
+
+fun exactString s = exactCharList (explode s);
+
+fun escapeString {escape} =
+ let
+ fun isEscape c = mem c escape
+
+ fun isNormal c =
+ case c of
+ #"\\" => false
+ | #"\n" => false
+ | #"\t" => false
+ | _ => not (isEscape c)
+
+ val escapeParser =
+ (exactChar #"\\" >> K #"\\") ||
+ (exactChar #"n" >> K #"\n") ||
+ (exactChar #"t" >> K #"\t") ||
+ some isEscape
+
+ val charParser =
+ ((exactChar #"\\" ++ escapeParser) >> snd) ||
+ some isNormal
+ in
+ many charParser >> implode
+ end;
+
+local
+ val isSpace = Char.isSpace;
+
+ val space = some isSpace;
+in
+ val manySpace = many space >> K ();
+
+ val atLeastOneSpace = atLeastOne space >> K ();
+end;
+
+fun fromString parser s = fromList parser (explode s);
+
+(* ------------------------------------------------------------------------- *)
+(* Infix operators. *)
+(* ------------------------------------------------------------------------- *)
fun parseGenInfix update sof toks parse inp =
let
- val (e, rest) = parse inp
-
+ 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
+ Stream.Nil => NONE
+ | Stream.Cons (h_t as (h,_)) =>
+ if StringSet.member 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;
+local
+ fun add ({leftSpaces = _, token = t, rightSpaces = _}, s) = StringSet.add s t;
+
+ fun parse leftAssoc toks con =
+ let
+ val update =
+ if leftAssoc then (fn f => fn t => fn a => fn b => con (t, f a, b))
+ else (fn f => fn t => fn a => fn b => f (con (t, a, b)))
+ in
+ parseGenInfix update I toks
+ end;
+in
+ fun parseLayeredInfixes {tokens,leftAssoc} =
+ let
+ val toks = List.foldl add StringSet.empty tokens
+ in
+ parse leftAssoc toks
+ end;
+end;
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
+ val layeredOps = Print.layerInfixes ops
+
+ val iparsers = List.map parseLayeredInfixes 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 *)
+(* ------------------------------------------------------------------------- *)
+(* Quotations. *)
(* ------------------------------------------------------------------------- *)
type 'a quotation = 'a frag list;
@@ -5197,7 +8306,7 @@
(* ========================================================================= *)
(* PROCESSING COMMAND LINE OPTIONS *)
-(* Copyright (c) 2003-2004 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2003-2004 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Options =
@@ -5293,7 +8402,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -5302,7 +8411,7 @@
(* ========================================================================= *)
(* PROCESSING COMMAND LINE OPTIONS *)
-(* Copyright (c) 2003-2004 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2003-2004 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Options :> Options =
@@ -5418,9 +8527,10 @@
description = "no more options",
processor = fn _ => raise Fail "basicOptions: --"},
{switches = ["-?","-h","--help"], arguments = [],
- description = "display all options and exit",
+ description = "display option information and exit",
processor = fn _ => raise OptionExit
- {message = SOME "displaying all options", usage = true, success = true}},
+ {message = SOME "displaying option information",
+ usage = true, success = true}},
{switches = ["-v", "--version"], arguments = [],
description = "display version information",
processor = fn _ => raise Fail "basicOptions: -v, --version"}];
@@ -5429,8 +8539,9 @@
(* All the command line options of a program *)
(* ------------------------------------------------------------------------- *)
-type allOptions = {name : string, version : string, header : string,
- footer : string, options : opt list};
+type allOptions =
+ {name : string, version : string, header : string,
+ footer : string, options : opt list};
(* ------------------------------------------------------------------------- *)
(* Usage information *)
@@ -5547,17 +8658,47 @@
(* ========================================================================= *)
(* NAMES *)
-(* Copyright (c) 2004-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2004 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Name =
sig
-type name = string
+(* ------------------------------------------------------------------------- *)
+(* A type of names. *)
+(* ------------------------------------------------------------------------- *)
+
+type name = string (* MODIFIED by Jasmin Blanchette *)
+
+(* ------------------------------------------------------------------------- *)
+(* A total ordering. *)
+(* ------------------------------------------------------------------------- *)
val compare : name * name -> order
-val pp : name Metis.Parser.pp
+val equal : name -> name -> bool
+
+(* ------------------------------------------------------------------------- *)
+(* Fresh names. *)
+(* ------------------------------------------------------------------------- *)
+
+val newName : unit -> name
+
+val newNames : int -> name list
+
+val variantPrime : (name -> bool) -> name -> name
+
+val variantNum : (name -> bool) -> name -> name
+
+(* ------------------------------------------------------------------------- *)
+(* Parsing and pretty printing. *)
+(* ------------------------------------------------------------------------- *)
+
+val pp : name Metis.Print.pp
+
+val toString : name -> string
+
+val fromString : string -> name
end
@@ -5565,7 +8706,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -5574,43 +8715,176 @@
(* ========================================================================= *)
(* NAMES *)
-(* Copyright (c) 2004-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2004 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Name :> Name =
struct
+open Useful;
+
+(* ------------------------------------------------------------------------- *)
+(* A type of names. *)
+(* ------------------------------------------------------------------------- *)
+
type name = string;
+(* ------------------------------------------------------------------------- *)
+(* A total ordering. *)
+(* ------------------------------------------------------------------------- *)
+
val compare = String.compare;
-val pp = Parser.ppString;
+fun equal n1 n2 = n1 = n2;
+
+(* ------------------------------------------------------------------------- *)
+(* Fresh variables. *)
+(* ------------------------------------------------------------------------- *)
+
+local
+ val prefix = "_";
+
+ fun numName i = mkPrefix prefix (Int.toString i);
+in
+ fun newName () = numName (newInt ());
+
+ fun newNames n = map numName (newInts n);
+end;
+
+fun variantPrime acceptable =
+ let
+ fun variant n = if acceptable n then n else variant (n ^ "'")
+ in
+ variant
+ end;
+
+local
+ fun isDigitOrPrime #"'" = true
+ | isDigitOrPrime c = Char.isDigit c;
+in
+ fun variantNum acceptable n =
+ if acceptable n then n
+ else
+ let
+ val n = stripSuffix isDigitOrPrime n
+
+ fun variant i =
+ let
+ val n_i = n ^ Int.toString i
+ in
+ if acceptable n_i then n_i else variant (i + 1)
+ end
+ in
+ variant 0
+ end;
+end;
+
+(* ------------------------------------------------------------------------- *)
+(* Parsing and pretty printing. *)
+(* ------------------------------------------------------------------------- *)
+
+val pp = Print.ppString;
+
+fun toString s : string = s;
+
+fun fromString s : name = s;
end
structure NameOrdered =
struct type t = Name.name val compare = Name.compare end
+structure NameMap = KeyMap (NameOrdered);
+
structure NameSet =
struct
local
- structure S = ElementSet (NameOrdered);
+ structure S = ElementSet (NameMap);
in
open S;
end;
val pp =
- Parser.ppMap
+ Print.ppMap
toList
- (Parser.ppBracket "{" "}" (Parser.ppSequence "," Name.pp));
-
-end
-
-structure NameMap = KeyMap (NameOrdered);
-
-structure NameArity =
-struct
+ (Print.ppBracket "{" "}" (Print.ppOpList "," Name.pp));
+
+end
+end;
+
+(**** Original file: NameArity.sig ****)
+
+(* ========================================================================= *)
+(* NAME/ARITY PAIRS *)
+(* Copyright (c) 2004-2006 Joe Hurd, distributed under the BSD License *)
+(* ========================================================================= *)
+
+signature NameArity =
+sig
+
+(* ------------------------------------------------------------------------- *)
+(* A type of name/arity pairs. *)
+(* ------------------------------------------------------------------------- *)
+
+type nameArity = Metis.Name.name * int
+
+val name : nameArity -> Metis.Name.name
+
+val arity : nameArity -> int
+
+(* ------------------------------------------------------------------------- *)
+(* Testing for different arities. *)
+(* ------------------------------------------------------------------------- *)
+
+val nary : int -> nameArity -> bool
+
+val nullary : nameArity -> bool
+
+val unary : nameArity -> bool
+
+val binary : nameArity -> bool
+
+val ternary : nameArity -> bool
+
+(* ------------------------------------------------------------------------- *)
+(* A total ordering. *)
+(* ------------------------------------------------------------------------- *)
+
+val compare : nameArity * nameArity -> order
+
+val equal : nameArity -> nameArity -> bool
+
+(* ------------------------------------------------------------------------- *)
+(* Parsing and pretty printing. *)
+(* ------------------------------------------------------------------------- *)
+
+val pp : nameArity Metis.Print.pp
+
+end
+
+(**** Original file: NameArity.sml ****)
+
+structure Metis = struct open Metis
+(* Metis-specific ML environment *)
+nonfix ++ -- RL;
+val explode = String.explode;
+val implode = String.implode;
+val print = TextIO.print;
+val foldl = List.foldl;
+val foldr = List.foldr;
+
+(* ========================================================================= *)
+(* NAME/ARITY PAIRS *)
+(* Copyright (c) 2004-2006 Joe Hurd, distributed under the BSD License *)
+(* ========================================================================= *)
+
+structure NameArity :> NameArity =
+struct
+
+(* ------------------------------------------------------------------------- *)
+(* A type of name/arity pairs. *)
+(* ------------------------------------------------------------------------- *)
type nameArity = Name.name * int;
@@ -5618,6 +8892,10 @@
fun arity ((_,i) : nameArity) = i;
+(* ------------------------------------------------------------------------- *)
+(* Testing for different arities. *)
+(* ------------------------------------------------------------------------- *)
+
fun nary i n_i = arity n_i = i;
val nullary = nary 0
@@ -5625,24 +8903,56 @@
and binary = nary 2
and ternary = nary 3;
+(* ------------------------------------------------------------------------- *)
+(* A total ordering. *)
+(* ------------------------------------------------------------------------- *)
+
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;
+fun equal (n1,i1) (n2,i2) = i1 = i2 andalso Name.equal n1 n2;
+
+(* ------------------------------------------------------------------------- *)
+(* Parsing and pretty printing. *)
+(* ------------------------------------------------------------------------- *)
+
+fun pp (n,i) =
+ Print.blockProgram Print.Inconsistent 0
+ [Name.pp n,
+ Print.addString "/",
+ Print.ppInt i];
end
structure NameArityOrdered =
struct type t = NameArity.nameArity val compare = NameArity.compare end
+structure NameArityMap =
+struct
+
+ local
+ structure S = KeyMap (NameArityOrdered);
+ in
+ open S;
+ end;
+
+ fun compose m1 m2 =
+ let
+ fun pk ((_,a),n) = peek m2 (n,a)
+ in
+ mapPartial pk m1
+ end;
+
+end
+
structure NameAritySet =
struct
local
- structure S = ElementSet (NameArityOrdered);
+ structure S = ElementSet (NameArityMap);
in
open S;
end;
@@ -5650,20 +8960,18 @@
val allNullary = all NameArity.nullary;
val pp =
- Parser.ppMap
+ Print.ppMap
toList
- (Parser.ppBracket "{" "}" (Parser.ppSequence "," NameArity.pp));
-
-end
-
-structure NameArityMap = KeyMap (NameArityOrdered);
+ (Print.ppBracket "{" "}" (Print.ppOpList "," NameArity.pp));
+
+end
end;
(**** Original file: Term.sig ****)
(* ========================================================================= *)
(* FIRST ORDER LOGIC TERMS *)
-(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Term =
@@ -5743,6 +9051,8 @@
val compare : term * term -> order
+val equal : term -> term -> bool
+
(* ------------------------------------------------------------------------- *)
(* Subterms. *)
(* ------------------------------------------------------------------------- *)
@@ -5757,7 +9067,7 @@
val find : (term -> bool) -> term -> path option
-val ppPath : path Metis.Parser.pp
+val ppPath : path Metis.Print.pp
val pathToString : path -> string
@@ -5769,6 +9079,8 @@
val freeVars : term -> Metis.NameSet.set
+val freeVarsList : term list -> Metis.NameSet.set
+
(* ------------------------------------------------------------------------- *)
(* Fresh variables. *)
(* ------------------------------------------------------------------------- *)
@@ -5785,6 +9097,10 @@
(* Special support for terms with type annotations. *)
(* ------------------------------------------------------------------------- *)
+val hasTypeFunctionName : functionName
+
+val hasTypeFunction : function
+
val isTypedVar : term -> bool
val typedSymbols : term -> int
@@ -5795,15 +9111,17 @@
(* 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
+val appName : Metis.Name.name
+
+val mkApp : term * term -> term
+
+val destApp : term -> term * term
+
+val isApp : term -> bool
+
+val listMkApp : term * term list -> term
+
+val stripApp : term -> term * term list
(* ------------------------------------------------------------------------- *)
(* Parsing and pretty printing. *)
@@ -5811,23 +9129,23 @@
(* Infix symbols *)
-val infixes : Metis.Parser.infixities Unsynchronized.ref
+val infixes : Metis.Print.infixes Unsynchronized.ref
(* The negation symbol *)
-val negation : Metis.Name.name Unsynchronized.ref
+val negation : string Unsynchronized.ref
(* Binder symbols *)
-val binders : Metis.Name.name list Unsynchronized.ref
+val binders : string list Unsynchronized.ref
(* Bracket symbols *)
-val brackets : (Metis.Name.name * Metis.Name.name) list Unsynchronized.ref
+val brackets : (string * string) list Unsynchronized.ref
(* Pretty printing *)
-val pp : term Metis.Parser.pp
+val pp : term Metis.Print.pp
val toString : term -> string
@@ -5835,7 +9153,7 @@
val fromString : string -> term
-val parse : term Metis.Parser.quotation -> term
+val parse : term Metis.Parse.quotation -> term
end
@@ -5843,7 +9161,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -5852,7 +9170,7 @@
(* ========================================================================= *)
(* FIRST ORDER LOGIC TERMS *)
-(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Term :> Term =
@@ -5861,24 +9179,6 @@
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. *)
(* ------------------------------------------------------------------------- *)
@@ -5905,7 +9205,7 @@
val isVar = can destVar;
-fun equalVar v (Var v') = v = v'
+fun equalVar v (Var v') = Name.equal v v'
| equalVar _ _ = false;
(* Functions *)
@@ -5954,7 +9254,7 @@
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"
+ if Name.equal 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);
@@ -5981,27 +9281,37 @@
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 (tm1 :: tms1) (tm2 :: tms2) =
+ let
+ val tm1_tm2 = (tm1,tm2)
+ in
+ if Portable.pointerEqual tm1_tm2 then cmp tms1 tms2
+ else
+ case tm1_tm2 of
+ (Var v1, Var v2) =>
+ (case Name.compare (v1,v2) of
+ LESS => LESS
+ | EQUAL => cmp tms1 tms2
+ | GREATER => GREATER)
+ | (Var _, Fn _) => LESS
+ | (Fn _, Var _) => GREATER
+ | (Fn (f1,a1), Fn (f2,a2)) =>
+ (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)
+ end
| cmp _ _ = raise Bug "Term.compare";
in
fun compare (tm1,tm2) = cmp [tm1] [tm2];
end;
+fun equal tm1 tm2 = compare (tm1,tm2) = EQUAL;
+
(* ------------------------------------------------------------------------- *)
(* Subterms. *)
(* ------------------------------------------------------------------------- *)
@@ -6030,7 +9340,7 @@
fun subterms tm = subtms [([],tm)] [];
end;
-fun replace tm ([],res) = if res = tm then tm else res
+fun replace tm ([],res) = if equal res tm then tm else res
| replace tm (h :: t, res) =
case tm of
Var _ => raise Error "Term.replace: Var"
@@ -6041,7 +9351,7 @@
val arg = List.nth (tms,h)
val arg' = replace arg (t,res)
in
- if Sharing.pointerEqual (arg',arg) then tm
+ if Portable.pointerEqual (arg',arg) then tm
else Fn (func, updateNth (h,arg') tms)
end;
@@ -6063,9 +9373,9 @@
fn tm => search [([],tm)]
end;
-val ppPath = Parser.ppList Parser.ppInt;
-
-val pathToString = Parser.toString ppPath;
+val ppPath = Print.ppList Print.ppInt;
+
+val pathToString = Print.toString ppPath;
(* ------------------------------------------------------------------------- *)
(* Free variables. *)
@@ -6073,7 +9383,7 @@
local
fun free _ [] = false
- | free v (Var w :: tms) = v = w orelse free v tms
+ | free v (Var w :: tms) = Name.equal v w orelse free v tms
| free v (Fn (_,args) :: tms) = free v (args @ tms);
in
fun freeIn v tm = free v [tm];
@@ -6084,77 +9394,100 @@
| 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];
+ val freeVarsList = free NameSet.empty;
+
+ fun freeVars tm = freeVarsList [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;
+fun newVar () = Var (Name.newName ());
+
+fun newVars n = map Var (Name.newNames n);
+
+local
+ fun avoidAcceptable avoid n = not (NameSet.member n avoid);
+in
+ fun variantPrime avoid = Name.variantPrime (avoidAcceptable avoid);
+
+ fun variantNum avoid = Name.variantNum (avoidAcceptable avoid);
+end;
(* ------------------------------------------------------------------------- *)
(* Special support for terms with type annotations. *)
(* ------------------------------------------------------------------------- *)
-fun isTypedVar (Var _) = true
- | isTypedVar (Fn (":", [Var _, _])) = true
- | isTypedVar (Fn _) = false;
+val hasTypeFunctionName = Name.fromString ":";
+
+val hasTypeFunction = (hasTypeFunctionName,2);
+
+fun destFnHasType ((f,a) : functionName * term list) =
+ if not (Name.equal f hasTypeFunctionName) then
+ raise Error "Term.destFnHasType"
+ else
+ case a of
+ [tm,ty] => (tm,ty)
+ | _ => raise Error "Term.destFnHasType";
+
+val isFnHasType = can destFnHasType;
+
+fun isTypedVar tm =
+ case tm of
+ Var _ => true
+ | Fn func =>
+ case total destFnHasType func of
+ SOME (Var _, _) => true
+ | _ => 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);
+ | sz n (tm :: tms) =
+ case tm of
+ Var _ => sz (n + 1) tms
+ | Fn func =>
+ case total destFnHasType func of
+ SOME (tm,_) => sz n (tm :: tms)
+ | NONE =>
+ let
+ val (_,a) = func
+ in
+ sz (n + 1) (a @ tms)
+ end;
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;
+ | subtms ((path,tm) :: rest) acc =
+ case tm of
+ Var _ => subtms rest acc
+ | Fn func =>
+ case total destFnHasType func of
+ SOME (t,_) =>
+ (case t of
+ Var _ => subtms rest acc
+ | Fn _ =>
+ let
+ val acc = (rev path, tm) :: acc
+ val rest = (0 :: path, t) :: rest
+ in
+ subtms rest acc
+ end)
+ | NONE =>
+ let
+ fun f (n,arg) = (n :: path, arg)
+
+ val (_,args) = func
+
+ val acc = (rev path, tm) :: acc
+
+ val rest = map f (enumerate args) @ rest
+ in
+ subtms rest acc
+ end;
in
fun nonVarTypedSubterms tm = subtms [([],tm)] [];
end;
@@ -6163,20 +9496,37 @@
(* 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;
+val appName = Name.fromString ".";
+
+fun mkFnApp (fTm,aTm) = (appName, [fTm,aTm]);
+
+fun mkApp f_a = Fn (mkFnApp f_a);
+
+fun destFnApp ((f,a) : Name.name * term list) =
+ if not (Name.equal f appName) then raise Error "Term.destFnApp"
+ else
+ case a of
+ [fTm,aTm] => (fTm,aTm)
+ | _ => raise Error "Term.destFnApp";
+
+val isFnApp = can destFnApp;
+
+fun destApp tm =
+ case tm of
+ Var _ => raise Error "Term.destApp"
+ | Fn func => destFnApp func;
+
+val isApp = can destApp;
+
+fun listMkApp (f,l) = foldl mkApp f l;
+
+local
+ fun strip tms tm =
+ case total destApp tm of
+ SOME (f,a) => strip (a :: tms) f
+ | NONE => (tm,tms);
+in
+ fun stripApp tm = strip [] tm;
end;
(* ------------------------------------------------------------------------- *)
@@ -6185,185 +9535,204 @@
(* Operators parsed and printed infix *)
-val infixes : Parser.infixities Unsynchronized.ref = Unsynchronized.ref
- [(* ML symbols *)
- {token = " / ", precedence = 7, leftAssoc = true},
- {token = " div ", precedence = 7, leftAssoc = true},
- {token = " mod ", precedence = 7, leftAssoc = true},
- {token = " * ", precedence = 7, leftAssoc = true},
- {token = " + ", precedence = 6, leftAssoc = true},
- {token = " - ", precedence = 6, leftAssoc = true},
- {token = " ^ ", precedence = 6, leftAssoc = true},
- {token = " @ ", precedence = 5, leftAssoc = false},
- {token = " :: ", precedence = 5, leftAssoc = false},
- {token = " = ", precedence = 4, leftAssoc = true},
- {token = " <> ", precedence = 4, leftAssoc = true},
- {token = " <= ", precedence = 4, leftAssoc = true},
- {token = " < ", precedence = 4, leftAssoc = true},
- {token = " >= ", precedence = 4, leftAssoc = true},
- {token = " > ", precedence = 4, leftAssoc = true},
- {token = " o ", precedence = 3, leftAssoc = true},
- {token = " -> ", precedence = 2, leftAssoc = false}, (* inferred prec *)
- {token = " : ", precedence = 1, leftAssoc = false}, (* inferred prec *)
- {token = ", ", precedence = 0, leftAssoc = false}, (* inferred prec *)
-
- (* Logical connectives *)
- {token = " /\\ ", precedence = ~1, leftAssoc = false},
- {token = " \\/ ", precedence = ~2, leftAssoc = false},
- {token = " ==> ", precedence = ~3, leftAssoc = false},
- {token = " <=> ", precedence = ~4, leftAssoc = false},
-
- (* Other symbols *)
- {token = " . ", precedence = 9, leftAssoc = true}, (* function app *)
- {token = " ** ", precedence = 8, leftAssoc = true},
- {token = " ++ ", precedence = 6, leftAssoc = true},
- {token = " -- ", precedence = 6, leftAssoc = true},
- {token = " == ", precedence = 4, leftAssoc = true}];
+val infixes =
+ (Unsynchronized.ref o Print.Infixes)
+ [(* ML symbols *)
+ {token = " / ", precedence = 7, leftAssoc = true},
+ {token = " div ", precedence = 7, leftAssoc = true},
+ {token = " mod ", precedence = 7, leftAssoc = true},
+ {token = " * ", precedence = 7, leftAssoc = true},
+ {token = " + ", precedence = 6, leftAssoc = true},
+ {token = " - ", precedence = 6, leftAssoc = true},
+ {token = " ^ ", precedence = 6, leftAssoc = true},
+ {token = " @ ", precedence = 5, leftAssoc = false},
+ {token = " :: ", precedence = 5, leftAssoc = false},
+ {token = " = ", precedence = 4, leftAssoc = true},
+ {token = " <> ", precedence = 4, leftAssoc = true},
+ {token = " <= ", precedence = 4, leftAssoc = true},
+ {token = " < ", precedence = 4, leftAssoc = true},
+ {token = " >= ", precedence = 4, leftAssoc = true},
+ {token = " > ", precedence = 4, leftAssoc = true},
+ {token = " o ", precedence = 3, leftAssoc = true},
+ {token = " -> ", precedence = 2, leftAssoc = false}, (* inferred prec *)
+ {token = " : ", precedence = 1, leftAssoc = false}, (* inferred prec *)
+ {token = ", ", precedence = 0, leftAssoc = false}, (* inferred prec *)
+
+ (* Logical connectives *)
+ {token = " /\\ ", precedence = ~1, leftAssoc = false},
+ {token = " \\/ ", precedence = ~2, leftAssoc = false},
+ {token = " ==> ", precedence = ~3, leftAssoc = false},
+ {token = " <=> ", precedence = ~4, leftAssoc = false},
+
+ (* Other symbols *)
+ {token = " . ", precedence = 9, leftAssoc = true}, (* function app *)
+ {token = " ** ", precedence = 8, leftAssoc = true},
+ {token = " ++ ", precedence = 6, leftAssoc = true},
+ {token = " -- ", precedence = 6, leftAssoc = true},
+ {token = " == ", precedence = 4, leftAssoc = true}];
(* The negation symbol *)
-val negation : Name.name Unsynchronized.ref = Unsynchronized.ref "~";
+val negation : string Unsynchronized.ref = Unsynchronized.ref "~";
(* Binder symbols *)
-val binders : Name.name list Unsynchronized.ref = Unsynchronized.ref ["\\","!","?","?!"];
+val binders : string list Unsynchronized.ref = Unsynchronized.ref ["\\","!","?","?!"];
(* Bracket symbols *)
-val brackets : (Name.name * Name.name) list Unsynchronized.ref = Unsynchronized.ref [("[","]"),("{","}")];
+val brackets : (string * string) list Unsynchronized.ref = Unsynchronized.ref [("[","]"),("{","}")];
(* Pretty printing *)
-local
- open Parser;
-in
- fun pp inputPpstrm inputTerm =
- let
- val quants = !binders
- and iOps = !infixes
- and neg = !negation
- and bracks = !brackets
-
- val bracks = map (fn (b1,b2) => (b1 ^ b2, b1, b2)) bracks
-
- val bTokens = map #2 bracks @ map #3 bracks
-
- val iTokens = infixTokens iOps
-
- fun destI (Fn (f,[a,b])) =
- if mem f iTokens then SOME (f,a,b) else NONE
- | destI _ = NONE
-
- val iPrinter = ppInfixes iOps destI
-
- val specialTokens = neg :: quants @ ["$","(",")"] @ bTokens @ iTokens
-
- fun vName bv s = NameSet.member s bv
-
- fun checkVarName bv s = if vName bv s then s else "$" ^ s
-
- fun varName bv = ppMap (checkVarName bv) ppString
-
- fun checkFunctionName bv s =
- if mem s specialTokens orelse vName bv s then "(" ^ s ^ ")" else s
-
- fun functionName bv = ppMap (checkFunctionName bv) ppString
-
- fun isI tm = Option.isSome (destI tm)
-
- fun stripNeg (tm as Fn (f,[a])) =
- if f <> neg then (0,tm)
+fun pp 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 = Print.tokensInfixes iOps
+
+ fun destI tm =
+ case tm of
+ Fn (f,[a,b]) =>
+ let
+ val f = Name.toString f
+ in
+ if StringSet.member f iTokens then SOME (f,a,b) else NONE
+ end
+ | _ => NONE
+
+ val iPrinter = Print.ppInfixes iOps destI
+
+ val specialTokens =
+ StringSet.addList iTokens (neg :: quants @ ["$","(",")"] @ bTokens)
+
+ fun vName bv s = StringSet.member s bv
+
+ fun checkVarName bv n =
+ let
+ val s = Name.toString n
+ in
+ if vName bv s then s else "$" ^ s
+ end
+
+ fun varName bv = Print.ppMap (checkVarName bv) Print.ppString
+
+ fun checkFunctionName bv n =
+ let
+ val s = Name.toString n
+ in
+ if StringSet.member s specialTokens orelse vName bv s then
+ "(" ^ s ^ ")"
+ else
+ s
+ end
+
+ fun functionName bv = Print.ppMap (checkFunctionName bv) Print.ppString
+
+ fun isI tm = Option.isSome (destI tm)
+
+ fun stripNeg tm =
+ case tm of
+ Fn (f,[a]) =>
+ if Name.toString 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;
+ | _ => (0,tm)
+
+ val destQuant =
+ let
+ fun dest q (Fn (q', [Var v, body])) =
+ if Name.toString 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])) =
+ let
+ val s = Name.toString b
+ in
+ case List.find (fn (n,_,_) => n = s) bracks of
+ NONE => NONE
+ | SOME (_,b1,b2) => SOME (b1,tm,b2)
+ end
+ | destBrack _ = NONE
+
+ fun isBrack tm = Option.isSome (destBrack tm)
+
+ fun functionArgument bv tm =
+ Print.sequence
+ (Print.addBreak 1)
+ (if isBrack tm then customBracket bv tm
+ else if isVar tm orelse isConst tm then basic bv tm
+ else bracket bv tm)
+
+ and basic bv (Var v) = varName bv v
+ | basic bv (Fn (f,args)) =
+ Print.blockProgram Print.Inconsistent 2
+ (functionName bv f :: map (functionArgument bv) args)
+
+ and customBracket bv tm =
+ case destBrack tm of
+ SOME (b1,tm,b2) => Print.ppBracket b1 b2 (term bv) tm
+ | NONE => basic bv tm
+
+ and innerQuant bv tm =
+ case destQuant tm of
+ NONE => term bv tm
+ | SOME (q,v,vs,tm) =>
+ let
+ val bv = StringSet.addList bv (map Name.toString (v :: vs))
+ in
+ Print.program
+ [Print.addString q,
+ varName bv v,
+ Print.program
+ (map (Print.sequence (Print.addBreak 1) o varName bv) vs),
+ Print.addString ".",
+ Print.addBreak 1,
+ innerQuant bv tm]
+ end
+
+ and quantifier bv tm =
+ if not (isQuant tm) then customBracket bv tm
+ else Print.block Print.Inconsistent 2 (innerQuant bv tm)
+
+ and molecule bv (tm,r) =
+ let
+ val (n,tm) = stripNeg tm
+ in
+ Print.blockProgram Print.Inconsistent n
+ [Print.duplicate n (Print.addString neg),
+ if isI tm orelse (r andalso isQuant tm) then bracket bv tm
+ else quantifier bv tm]
+ end
+
+ and term bv tm = iPrinter (molecule bv) (tm,false)
+
+ and bracket bv tm = Print.ppBracket "(" ")" (term bv) tm
+ in
+ term StringSet.empty
+ end inputTerm;
+
+val toString = Print.toString pp;
(* Parsing *)
local
- open Parser;
+ open Parse;
infixr 9 >>++
infixr 8 ++
@@ -6383,7 +9752,7 @@
val symbolToken =
let
fun isNeg c = str c = !negation
-
+
val symbolChars = explode "<>=-*+/\\?@|!$%&#^:;~"
fun isSymbol c = mem c symbolChars
@@ -6424,42 +9793,50 @@
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 vName bv s = StringSet.member s bv
+
+ val iTokens = Print.tokensInfixes iOps
+
+ val iParser =
+ parseInfixes iOps (fn (f,a,b) => Fn (Name.fromString f, [a,b]))
+
+ val specialTokens =
+ StringSet.addList iTokens (neg :: quants @ ["$"] @ bTokens)
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)
+ some (vName bv) ||
+ (some (Useful.equal "$") ++ some possibleVarName) >> snd
+
+ fun fName bv s =
+ not (StringSet.member s specialTokens) andalso not (vName bv s)
fun functionName bv =
- Parser.some (fName bv) ||
- (exact "(" ++ any ++ exact ")") >> (fn (_,(s,_)) => s)
+ some (fName bv) ||
+ (some (Useful.equal "(") ++ any ++ some (Useful.equal ")")) >>
+ (fn (_,(s,_)) => s)
fun basic bv tokens =
let
- val var = varName bv >> Var
-
- val const = functionName bv >> (fn f => Fn (f,[]))
+ val var = varName bv >> (Var o Name.fromString)
+
+ val const =
+ functionName bv >> (fn f => Fn (Name.fromString f, []))
fun bracket (ab,a,b) =
- (exact a ++ term bv ++ exact b) >>
- (fn (_,(tm,_)) => if ab = "()" then tm else Fn (ab,[tm]))
+ (some (Useful.equal a) ++ term bv ++ some (Useful.equal b)) >>
+ (fn (_,(tm,_)) =>
+ if ab = "()" then tm else Fn (Name.fromString ab, [tm]))
fun quantifier q =
let
- fun bind (v,t) = Fn (q, [Var v, t])
+ fun bind (v,t) =
+ Fn (Name.fromString q, [Var (Name.fromString v), t])
in
- (exact q ++ atLeastOne (some possibleVarName) ++
- exact ".") >>++
+ (some (Useful.equal q) ++
+ atLeastOne (some possibleVarName) ++
+ some (Useful.equal ".")) >>++
(fn (_,(vs,_)) =>
- term (NameSet.addList bv vs) >>
+ term (StringSet.addList bv vs) >>
(fn body => foldr bind body vs))
end
in
@@ -6471,18 +9848,20 @@
and molecule bv tokens =
let
- val negations = many (exact neg) >> length
+ val negations = many (some (Useful.equal neg)) >> length
val function =
- (functionName bv ++ many (basic bv)) >> Fn || basic bv
+ (functionName bv ++ many (basic bv)) >>
+ (fn (f,args) => Fn (Name.fromString f, args)) ||
+ basic bv
in
(negations ++ function) >>
- (fn (n,tm) => funpow n (fn t => Fn (neg,[t])) tm)
+ (fn (n,tm) => funpow n (fn t => Fn (Name.fromString neg, [t])) tm)
end tokens
and term bv tokens = iParser (molecule bv) tokens
in
- term NameSet.empty
+ term StringSet.empty
end inputStream;
in
fun fromString input =
@@ -6495,15 +9874,14 @@
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;
+ | _ => raise Error "Term.fromString"
+ end;
+end;
+
+local
+ val antiquotedTermToString = Print.toString (Print.ppBracket "(" ")" pp);
+in
+ val parse = Parse.parseQuotation antiquotedTermToString fromString;
end;
end
@@ -6511,16 +9889,16 @@
structure TermOrdered =
struct type t = Term.term val compare = Term.compare end
-structure TermSet = ElementSet (TermOrdered);
-
structure TermMap = KeyMap (TermOrdered);
+
+structure TermSet = ElementSet (TermMap);
end;
(**** Original file: Subst.sig ****)
(* ========================================================================= *)
(* FIRST ORDER LOGIC SUBSTITUTIONS *)
-(* Copyright (c) 2002-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2002-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Subst =
@@ -6548,8 +9926,6 @@
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
@@ -6558,7 +9934,7 @@
val foldr : (Metis.Term.var * Metis.Term.term * 'a -> 'a) -> 'a -> subst -> 'a
-val pp : subst Metis.Parser.pp
+val pp : subst Metis.Print.pp
val toString : subst -> string
@@ -6591,7 +9967,13 @@
val compose : subst -> subst -> subst
(* ------------------------------------------------------------------------- *)
-(* Substitutions can be inverted iff they are renaming substitutions. *)
+(* Creating the union of two compatible substitutions. *)
+(* ------------------------------------------------------------------------- *)
+
+val union : subst -> subst -> subst (* raises Error *)
+
+(* ------------------------------------------------------------------------- *)
+(* Substitutions can be inverted iff they are renaming substitutions. *)
(* ------------------------------------------------------------------------- *)
val invert : subst -> subst (* raises Error *)
@@ -6605,6 +9987,22 @@
val freshVars : Metis.NameSet.set -> subst
(* ------------------------------------------------------------------------- *)
+(* Free variables. *)
+(* ------------------------------------------------------------------------- *)
+
+val redexes : subst -> Metis.NameSet.set
+
+val residueFreeVars : subst -> Metis.NameSet.set
+
+val freeVars : subst -> Metis.NameSet.set
+
+(* ------------------------------------------------------------------------- *)
+(* Functions. *)
+(* ------------------------------------------------------------------------- *)
+
+val functions : subst -> Metis.NameAritySet.set
+
+(* ------------------------------------------------------------------------- *)
(* Matching for first order logic terms. *)
(* ------------------------------------------------------------------------- *)
@@ -6622,7 +10020,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -6631,7 +10029,7 @@
(* ========================================================================= *)
(* FIRST ORDER LOGIC SUBSTITUTIONS *)
-(* Copyright (c) 2002-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2002-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Subst :> Subst =
@@ -6661,16 +10059,6 @@
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);
@@ -6679,12 +10067,12 @@
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;
+fun pp sub =
+ Print.ppBracket "<[" "]>"
+ (Print.ppOpList "," (Print.ppOp2 " |->" Name.pp Term.pp))
+ (toList sub);
+
+val toString = Print.toString pp;
(* ------------------------------------------------------------------------- *)
(* Normalizing removes identity substitutions. *)
@@ -6709,13 +10097,13 @@
let
fun tmSub (tm as Term.Var v) =
(case peek sub v of
- SOME tm' => if Sharing.pointerEqual (tm,tm') then tm else tm'
+ SOME tm' => if Portable.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
+ if Portable.pointerEqual (args,args') then tm
else Term.Fn (f,args')
end
in
@@ -6758,7 +10146,22 @@
end;
(* ------------------------------------------------------------------------- *)
-(* Substitutions can be inverted iff they are renaming substitutions. *)
+(* Creating the union of two compatible substitutions. *)
+(* ------------------------------------------------------------------------- *)
+
+local
+ fun compatible ((_,tm1),(_,tm2)) =
+ if Term.equal 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;
+
+(* ------------------------------------------------------------------------- *)
+(* Substitutions can be inverted iff they are renaming substitutions. *)
(* ------------------------------------------------------------------------- *)
local
@@ -6784,6 +10187,42 @@
end;
(* ------------------------------------------------------------------------- *)
+(* Free variables. *)
+(* ------------------------------------------------------------------------- *)
+
+val redexes =
+ let
+ fun add (v,_,s) = NameSet.add s v
+ in
+ foldl add NameSet.empty
+ end;
+
+val residueFreeVars =
+ let
+ fun add (_,t,s) = NameSet.union s (Term.freeVars t)
+ in
+ foldl add NameSet.empty
+ end;
+
+val freeVars =
+ let
+ fun add (v,t,s) = NameSet.union (NameSet.add s v) (Term.freeVars t)
+ in
+ foldl add NameSet.empty
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Functions. *)
+(* ------------------------------------------------------------------------- *)
+
+val functions =
+ let
+ fun add (_,t,s) = NameAritySet.union s (Term.functions t)
+ in
+ foldl add NameAritySet.empty
+ end;
+
+(* ------------------------------------------------------------------------- *)
(* Matching for first order logic terms. *)
(* ------------------------------------------------------------------------- *)
@@ -6795,13 +10234,13 @@
case peek sub v of
NONE => insert sub (v,tm)
| SOME tm' =>
- if tm = tm' then sub
+ if Term.equal 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
+ if Name.equal 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";
@@ -6828,7 +10267,7 @@
| 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
+ if Name.equal f1 f2 andalso length args1 = length args2 then
solve sub (zip args1 args2 @ rest)
else
raise Error "Subst.unify: different structure";
@@ -6843,7 +10282,7 @@
(* ========================================================================= *)
(* FIRST ORDER LOGIC ATOMS *)
-(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Atom =
@@ -6895,6 +10334,8 @@
val compare : atom * atom -> order
+val equal : atom -> atom -> bool
+
(* ------------------------------------------------------------------------- *)
(* Subterms. *)
(* ------------------------------------------------------------------------- *)
@@ -6937,6 +10378,8 @@
(* The equality relation. *)
(* ------------------------------------------------------------------------- *)
+val eqRelationName : relationName
+
val eqRelation : relation
val mkEq : Metis.Term.term * Metis.Term.term -> atom
@@ -6969,13 +10412,13 @@
(* Parsing and pretty printing. *)
(* ------------------------------------------------------------------------- *)
-val pp : atom Metis.Parser.pp
+val pp : atom Metis.Print.pp
val toString : atom -> string
val fromString : string -> atom
-val parse : Metis.Term.term Metis.Parser.quotation -> atom
+val parse : Metis.Term.term Metis.Parse.quotation -> atom
end
@@ -6983,7 +10426,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -6992,7 +10435,7 @@
(* ========================================================================= *)
(* FIRST ORDER LOGIC ATOMS *)
-(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Atom :> Atom =
@@ -7041,7 +10484,7 @@
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"
+ if Name.equal 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);
@@ -7062,6 +10505,8 @@
| EQUAL => lexCompare Term.compare (tms1,tms2)
| GREATER => GREATER;
+fun equal atm1 atm2 = compare (atm1,atm2) = EQUAL;
+
(* ------------------------------------------------------------------------- *)
(* Subterms. *)
(* ------------------------------------------------------------------------- *)
@@ -7086,7 +10531,7 @@
val tm = List.nth (tms,h)
val tm' = Term.replace tm (t,res)
in
- if Sharing.pointerEqual (tm,tm') then atm
+ if Portable.pointerEqual (tm,tm') then atm
else (rel, updateNth (h,tm') tms)
end;
@@ -7121,7 +10566,7 @@
let
val tms' = Sharing.map (Subst.subst sub) tms
in
- if Sharing.pointerEqual (tms',tms) then atm else (p,tms')
+ if Portable.pointerEqual (tms',tms) then atm else (p,tms')
end;
(* ------------------------------------------------------------------------- *)
@@ -7133,7 +10578,7 @@
in
fun match sub (p1,tms1) (p2,tms2) =
let
- val _ = (p1 = p2 andalso length tms1 = length tms2) orelse
+ val _ = (Name.equal p1 p2 andalso length tms1 = length tms2) orelse
raise Error "Atom.match"
in
foldl matchArg sub (zip tms1 tms2)
@@ -7149,7 +10594,7 @@
in
fun unify sub (p1,tms1) (p2,tms2) =
let
- val _ = (p1 = p2 andalso length tms1 = length tms2) orelse
+ val _ = (Name.equal p1 p2 andalso length tms1 = length tms2) orelse
raise Error "Atom.unify"
in
foldl unifyArg sub (zip tms1 tms2)
@@ -7160,24 +10605,24 @@
(* 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;
+val eqRelationName = Name.fromString "=";
+
+val eqRelationArity = 2;
+
+val eqRelation = (eqRelationName,eqRelationArity);
+
+val mkEq = mkBinop eqRelationName;
+
+fun destEq x = destBinop eqRelationName x;
+
+fun isEq x = isBinop eqRelationName x;
fun mkRefl tm = mkEq (tm,tm);
fun destRefl atm =
let
val (l,r) = destEq atm
- val _ = l = r orelse raise Error "Atom.destRefl"
+ val _ = Term.equal l r orelse raise Error "Atom.destRefl"
in
l
end;
@@ -7187,7 +10632,7 @@
fun sym atm =
let
val (l,r) = destEq atm
- val _ = l <> r orelse raise Error "Atom.sym: refl"
+ val _ = not (Term.equal l r) orelse raise Error "Atom.sym: refl"
in
mkEq (r,l)
end;
@@ -7219,29 +10664,29 @@
(* Parsing and pretty printing. *)
(* ------------------------------------------------------------------------- *)
-val pp = Parser.ppMap Term.Fn Term.pp;
-
-val toString = Parser.toString pp;
+val pp = Print.ppMap Term.Fn Term.pp;
+
+val toString = Print.toString pp;
fun fromString s = Term.destFn (Term.fromString s);
-val parse = Parser.parseQuotation Term.toString fromString;
+val parse = Parse.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);
+
+structure AtomSet = ElementSet (AtomMap);
end;
(**** Original file: Formula.sig ****)
(* ========================================================================= *)
(* FIRST ORDER LOGIC FORMULAS *)
-(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Formula =
@@ -7275,6 +10720,10 @@
val isBoolean : formula -> bool
+val isTrue : formula -> bool
+
+val isFalse : formula -> bool
+
(* Functions *)
val functions : formula -> Metis.NameAritySet.set
@@ -7333,6 +10782,8 @@
val listMkForall : Metis.Term.var list * formula -> formula
+val setMkForall : Metis.NameSet.set * formula -> formula
+
val stripForall : formula -> Metis.Term.var list * formula
(* Existential quantification *)
@@ -7343,6 +10794,8 @@
val listMkExists : Metis.Term.var list * formula -> formula
+val setMkExists : Metis.NameSet.set * formula -> formula
+
val stripExists : formula -> Metis.Term.var list * formula
(* ------------------------------------------------------------------------- *)
@@ -7357,6 +10810,8 @@
val compare : formula * formula -> order
+val equal : formula -> formula -> bool
+
(* ------------------------------------------------------------------------- *)
(* Free variables. *)
(* ------------------------------------------------------------------------- *)
@@ -7365,6 +10820,8 @@
val freeVars : formula -> Metis.NameSet.set
+val freeVarsList : formula list -> Metis.NameSet.set
+
val specialize : formula -> formula
val generalize : formula -> formula
@@ -7404,12 +10861,18 @@
val rhs : formula -> Metis.Term.term
(* ------------------------------------------------------------------------- *)
+(* Splitting goals. *)
+(* ------------------------------------------------------------------------- *)
+
+val splitGoal : formula -> formula list
+
+(* ------------------------------------------------------------------------- *)
(* Parsing and pretty-printing. *)
(* ------------------------------------------------------------------------- *)
-type quotation = formula Metis.Parser.quotation
-
-val pp : formula Metis.Parser.pp
+type quotation = formula Metis.Parse.quotation
+
+val pp : formula Metis.Print.pp
val toString : formula -> string
@@ -7423,7 +10886,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -7432,7 +10895,7 @@
(* ========================================================================= *)
(* FIRST ORDER LOGIC FORMULAS *)
-(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Formula :> Formula =
@@ -7471,6 +10934,16 @@
val isBoolean = can destBoolean;
+fun isTrue fm =
+ case fm of
+ True => true
+ | _ => false;
+
+fun isFalse fm =
+ case fm of
+ False => true
+ | _ => false;
+
(* Functions *)
local
@@ -7643,6 +11116,8 @@
fun listMkForall ([],body) = body
| listMkForall (v :: vs, body) = Forall (v, listMkForall (vs,body));
+fun setMkForall (vs,body) = NameSet.foldr Forall body vs;
+
local
fun strip vs (Forall (v,b)) = strip (v :: vs) b
| strip vs tm = (rev vs, tm);
@@ -7660,6 +11135,8 @@
fun listMkExists ([],body) = body
| listMkExists (v :: vs, body) = Exists (v, listMkExists (vs,body));
+fun setMkExists (vs,body) = NameSet.foldr Exists body vs;
+
local
fun strip vs (Exists (v,b)) = strip (v :: vs) b
| strip vs tm = (rev vs, tm);
@@ -7693,50 +11170,56 @@
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);
+ | cmp (f1_f2 :: fs) =
+ if Portable.pointerEqual f1_f2 then cmp fs
+ else
+ case f1_f2 of
+ (True,True) => cmp fs
+ | (True,_) => LESS
+ | (_,True) => GREATER
+ | (False,False) => cmp fs
+ | (False,_) => LESS
+ | (_,False) => GREATER
+ | (Atom atm1, Atom atm2) =>
+ (case Atom.compare (atm1,atm2) of
+ LESS => LESS
+ | EQUAL => cmp fs
+ | GREATER => GREATER)
+ | (Atom _, _) => LESS
+ | (_, Atom _) => GREATER
+ | (Not p1, Not p2) => cmp ((p1,p2) :: fs)
+ | (Not _, _) => LESS
+ | (_, Not _) => GREATER
+ | (And (p1,q1), And (p2,q2)) => cmp ((p1,p2) :: (q1,q2) :: fs)
+ | (And _, _) => LESS
+ | (_, And _) => GREATER
+ | (Or (p1,q1), Or (p2,q2)) => cmp ((p1,p2) :: (q1,q2) :: fs)
+ | (Or _, _) => LESS
+ | (_, Or _) => GREATER
+ | (Imp (p1,q1), Imp (p2,q2)) => cmp ((p1,p2) :: (q1,q2) :: fs)
+ | (Imp _, _) => LESS
+ | (_, Imp _) => GREATER
+ | (Iff (p1,q1), Iff (p2,q2)) => cmp ((p1,p2) :: (q1,q2) :: fs)
+ | (Iff _, _) => LESS
+ | (_, Iff _) => GREATER
+ | (Forall (v1,p1), Forall (v2,p2)) =>
+ (case Name.compare (v1,v2) of
+ LESS => LESS
+ | EQUAL => cmp ((p1,p2) :: fs)
+ | GREATER => GREATER)
+ | (Forall _, Exists _) => LESS
+ | (Exists _, Forall _) => GREATER
+ | (Exists (v1,p1), Exists (v2,p2)) =>
+ (case Name.compare (v1,v2) of
+ LESS => LESS
+ | EQUAL => cmp ((p1,p2) :: fs)
+ | GREATER => GREATER);
in
fun compare fm1_fm2 = cmp [fm1_fm2];
end;
+fun equal fm1 fm2 = compare (fm1,fm2) = EQUAL;
+
(* ------------------------------------------------------------------------- *)
(* Free variables. *)
(* ------------------------------------------------------------------------- *)
@@ -7752,8 +11235,10 @@
| 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)
+ | f (Forall (w,p) :: fms) =
+ if Name.equal v w then f fms else f (p :: fms)
+ | f (Exists (w,p) :: fms) =
+ if Name.equal v w then f fms else f (p :: fms)
in
fn fm => f [fm]
end;
@@ -7771,8 +11256,12 @@
| 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)];
+
+ fun add (fm,vs) = fv vs [(NameSet.empty,fm)];
+in
+ fun freeVars fm = add (fm,NameSet.empty);
+
+ fun freeVarsList fms = List.foldl add NameSet.empty fms;
end;
fun specialize fm = snd (stripForall fm);
@@ -7794,13 +11283,13 @@
let
val tms' = Sharing.map (Subst.subst sub) tms
in
- if Sharing.pointerEqual (tms,tms') then fm else Atom (p,tms')
+ if Portable.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'
+ if Portable.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
@@ -7814,8 +11303,8 @@
val p' = substFm sub p
and q' = substFm sub q
in
- if Sharing.pointerEqual (p,p') andalso
- Sharing.pointerEqual (q,q')
+ if Portable.pointerEqual (p,p') andalso
+ Portable.pointerEqual (q,q')
then fm
else conn (p',q')
end
@@ -7825,12 +11314,12 @@
val v' =
let
fun f (w,s) =
- if w = v then s
+ if Name.equal 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
@@ -7838,12 +11327,12 @@
end
val sub =
- if v = v' then Subst.remove sub (NameSet.singleton v)
+ if Name.equal 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
+ if Name.equal v v' andalso Portable.pointerEqual (p,p') then fm
else quant (v',p')
end;
in
@@ -7883,34 +11372,39 @@
(* 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,[])
+type quotation = formula Parse.quotation;
+
+val truthName = Name.fromString "T"
+and falsityName = Name.fromString "F"
+and conjunctionName = Name.fromString "/\\"
+and disjunctionName = Name.fromString "\\/"
+and implicationName = Name.fromString "==>"
+and equivalenceName = Name.fromString "<=>"
+and universalName = Name.fromString "!"
+and existentialName = Name.fromString "?";
+
+local
+ fun demote True = Term.Fn (truthName,[])
+ | demote False = Term.Fn (falsityName,[])
| 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 (Not p) =
+ let
+ val Unsynchronized.ref s = Term.negation
+ in
+ Term.Fn (Name.fromString s, [demote p])
+ end
+ | demote (And (p,q)) = Term.Fn (conjunctionName, [demote p, demote q])
+ | demote (Or (p,q)) = Term.Fn (disjunctionName, [demote p, demote q])
+ | demote (Imp (p,q)) = Term.Fn (implicationName, [demote p, demote q])
+ | demote (Iff (p,q)) = Term.Fn (equivalenceName, [demote p, demote q])
+ | demote (Forall (v,b)) = Term.Fn (universalName, [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;
+ Term.Fn (existentialName, [Term.Var v, demote b]);
+in
+ fun pp fm = Term.pp (demote fm);
+end;
+
+val toString = Print.toString pp;
local
fun isQuant [Term.Var _, _] = true
@@ -7918,23 +11412,23 @@
fun promote (Term.Var v) = Atom (v,[])
| promote (Term.Fn (f,tms)) =
- if f = truthSymbol andalso null tms then
+ if Name.equal f truthName andalso null tms then
True
- else if f = falsitySymbol andalso null tms then
+ else if Name.equal f falsityName andalso null tms then
False
- else if f = !Term.negation andalso length tms = 1 then
+ else if Name.toString f = !Term.negation andalso length tms = 1 then
Not (promote (hd tms))
- else if f = conjunctionSymbol andalso length tms = 2 then
+ else if Name.equal f conjunctionName andalso length tms = 2 then
And (promote (hd tms), promote (List.nth (tms,1)))
- else if f = disjunctionSymbol andalso length tms = 2 then
+ else if Name.equal f disjunctionName andalso length tms = 2 then
Or (promote (hd tms), promote (List.nth (tms,1)))
- else if f = implicationSymbol andalso length tms = 2 then
+ else if Name.equal f implicationName andalso length tms = 2 then
Imp (promote (hd tms), promote (List.nth (tms,1)))
- else if f = equivalenceSymbol andalso length tms = 2 then
+ else if Name.equal f equivalenceName andalso length tms = 2 then
Iff (promote (hd tms), promote (List.nth (tms,1)))
- else if f = universalSymbol andalso isQuant tms then
+ else if Name.equal f universalName andalso isQuant tms then
Forall (Term.destVar (hd tms), promote (List.nth (tms,1)))
- else if f = existentialSymbol andalso isQuant tms then
+ else if Name.equal f existentialName andalso isQuant tms then
Exists (Term.destVar (hd tms), promote (List.nth (tms,1)))
else
Atom (f,tms);
@@ -7942,16 +11436,71 @@
fun fromString s = promote (Term.fromString s);
end;
-val parse = Parser.parseQuotation toString fromString;
-
-end
+val parse = Parse.parseQuotation toString fromString;
+
+(* ------------------------------------------------------------------------- *)
+(* Splitting goals. *)
+(* ------------------------------------------------------------------------- *)
+
+local
+ fun add_asms asms goal =
+ if null asms then goal else Imp (listMkConj (rev asms), goal);
+
+ fun add_var_asms asms v goal = add_asms asms (Forall (v,goal));
+
+ fun split asms pol fm =
+ case (pol,fm) of
+ (* Positive splittables *)
+ (true,True) => []
+ | (true, Not f) => split asms false f
+ | (true, And (f1,f2)) => split asms true f1 @ split (f1 :: asms) true f2
+ | (true, Or (f1,f2)) => split (Not f1 :: asms) true f2
+ | (true, Imp (f1,f2)) => split (f1 :: asms) true f2
+ | (true, Iff (f1,f2)) =>
+ split (f1 :: asms) true f2 @ split (f2 :: asms) true f1
+ | (true, Forall (v,f)) => map (add_var_asms asms v) (split [] true f)
+ (* Negative splittables *)
+ | (false,False) => []
+ | (false, Not f) => split asms true f
+ | (false, And (f1,f2)) => split (f1 :: asms) false f2
+ | (false, Or (f1,f2)) =>
+ split asms false f1 @ split (Not f1 :: asms) false f2
+ | (false, Imp (f1,f2)) => split asms true f1 @ split (f1 :: asms) false f2
+ | (false, Iff (f1,f2)) =>
+ split (f1 :: asms) false f2 @ split (f2 :: asms) false f1
+ | (false, Exists (v,f)) => map (add_var_asms asms v) (split [] false f)
+ (* Unsplittables *)
+ | _ => [add_asms asms (if pol then fm else Not fm)];
+in
+ fun splitGoal fm = split [] true fm;
+end;
+
+(*MetisTrace3
+val splitGoal = fn fm =>
+ let
+ val result = splitGoal fm
+ val () = Print.trace pp "Formula.splitGoal: fm" fm
+ val () = Print.trace (Print.ppList pp) "Formula.splitGoal: result" result
+ in
+ result
+ end;
+*)
+
+end
+
+structure FormulaOrdered =
+struct type t = Formula.formula val compare = Formula.compare end
+
+structure FormulaMap = KeyMap (FormulaOrdered);
+
+structure FormulaSet = ElementSet (FormulaMap);
end;
(**** Original file: Literal.sig ****)
(* ========================================================================= *)
(* FIRST ORDER LOGIC LITERALS *)
-(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Literal =
@@ -8017,6 +11566,8 @@
val compare : literal * literal -> order (* negative < positive *)
+val equal : literal -> literal -> bool
+
(* ------------------------------------------------------------------------- *)
(* Subterms. *)
(* ------------------------------------------------------------------------- *)
@@ -8103,13 +11654,13 @@
(* Parsing and pretty-printing. *)
(* ------------------------------------------------------------------------- *)
-val pp : literal Metis.Parser.pp
+val pp : literal Metis.Print.pp
val toString : literal -> string
val fromString : string -> literal
-val parse : Metis.Term.term Metis.Parser.quotation -> literal
+val parse : Metis.Term.term Metis.Parse.quotation -> literal
end
@@ -8117,7 +11668,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -8126,7 +11677,7 @@
(* ========================================================================= *)
(* FIRST ORDER LOGIC LITERALS *)
-(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Literal :> Literal =
@@ -8196,11 +11747,9 @@
(* 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;
+val compare = prodCompare boolCompare Atom.compare;
+
+fun equal (p1,atm1) (p2,atm2) = p1 = p2 andalso Atom.equal atm1 atm2;
(* ------------------------------------------------------------------------- *)
(* Subterms. *)
@@ -8214,7 +11763,7 @@
let
val atm' = Atom.replace atm path_tm
in
- if Sharing.pointerEqual (atm,atm') then lit else (pol,atm')
+ if Portable.pointerEqual (atm,atm') then lit else (pol,atm')
end;
(* ------------------------------------------------------------------------- *)
@@ -8233,7 +11782,7 @@
let
val atm' = Atom.subst sub atm
in
- if Sharing.pointerEqual (atm',atm) then lit else (pol,atm')
+ if Portable.pointerEqual (atm',atm) then lit else (pol,atm')
end;
(* ------------------------------------------------------------------------- *)
@@ -8308,24 +11857,26 @@
(* Parsing and pretty-printing. *)
(* ------------------------------------------------------------------------- *)
-val pp = Parser.ppMap toFormula Formula.pp;
-
-val toString = Parser.toString pp;
+val pp = Print.ppMap toFormula Formula.pp;
+
+val toString = Print.toString pp;
fun fromString s = fromFormula (Formula.fromString s);
-val parse = Parser.parseQuotation Term.toString fromString;
+val parse = Parse.parseQuotation Term.toString fromString;
end
structure LiteralOrdered =
struct type t = Literal.literal val compare = Literal.compare end
+structure LiteralMap = KeyMap (LiteralOrdered);
+
structure LiteralSet =
struct
local
- structure S = ElementSet (LiteralOrdered);
+ structure S = ElementSet (LiteralMap);
in
open S;
end;
@@ -8353,6 +11904,8 @@
foldl f NameAritySet.empty
end;
+ fun freeIn v = exists (Literal.freeIn v);
+
val freeVars =
let
fun f (lit,set) = NameSet.union set (Literal.freeVars lit)
@@ -8360,6 +11913,13 @@
foldl f NameSet.empty
end;
+ val freeVarsList =
+ let
+ fun f (lits,set) = NameSet.union set (freeVars lits)
+ in
+ List.foldl f NameSet.empty
+ end;
+
val symbols =
let
fun f (lit,z) = Literal.symbols lit + z
@@ -8379,31 +11939,42 @@
fun substLit (lit,(eq,lits')) =
let
val lit' = Literal.subst sub lit
- val eq = eq andalso Sharing.pointerEqual (lit,lit')
+ val eq = eq andalso Portable.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;
+ fun conjoin set =
+ Formula.listMkConj (List.map Literal.toFormula (toList set));
+
+ fun disjoin set =
+ Formula.listMkDisj (List.map Literal.toFormula (toList set));
+
val pp =
- Parser.ppMap
+ Print.ppMap
toList
- (Parser.ppBracket "{" "}" (Parser.ppSequence "," Literal.pp));
-
-end
-
-structure LiteralMap = KeyMap (LiteralOrdered);
+ (Print.ppBracket "{" "}" (Print.ppOpList "," Literal.pp));
+
+end
+
+structure LiteralSetOrdered =
+struct type t = LiteralSet.set val compare = LiteralSet.compare end
+
+structure LiteralSetMap = KeyMap (LiteralSetOrdered);
+
+structure LiteralSetSet = ElementSet (LiteralSetMap);
end;
(**** Original file: Thm.sig ****)
(* ========================================================================= *)
-(* A LOGICAL KERNEL FOR FIRST ORDER CLAUSES *)
-(* Copyright (c) 2001-2004 Joe Hurd, distributed under the BSD License *)
+(* A LOGICAL KERNEL FOR FIRST ORDER CLAUSAL THEOREMS *)
+(* Copyright (c) 2001 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Thm =
@@ -8413,6 +11984,12 @@
(* An abstract type of first order logic theorems. *)
(* ------------------------------------------------------------------------- *)
+type thm
+
+(* ------------------------------------------------------------------------- *)
+(* Theorem destructors. *)
+(* ------------------------------------------------------------------------- *)
+
type clause = Metis.LiteralSet.set
datatype inferenceType =
@@ -8424,14 +12001,8 @@
| Refl
| Equality
-type thm
-
type inference = inferenceType * thm list
-(* ------------------------------------------------------------------------- *)
-(* Theorem destructors. *)
-(* ------------------------------------------------------------------------- *)
-
val clause : thm -> clause
val inference : thm -> inference
@@ -8482,11 +12053,11 @@
(* Pretty-printing. *)
(* ------------------------------------------------------------------------- *)
-val ppInferenceType : inferenceType Metis.Parser.pp
+val ppInferenceType : inferenceType Metis.Print.pp
val inferenceTypeToString : inferenceType -> string
-val pp : thm Metis.Parser.pp
+val pp : thm Metis.Print.pp
val toString : thm -> string
@@ -8554,7 +12125,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -8562,8 +12133,8 @@
val foldr = List.foldr;
(* ========================================================================= *)
-(* A LOGICAL KERNEL FOR FIRST ORDER CLAUSES *)
-(* Copyright (c) 2001-2004 Joe Hurd, distributed under the BSD License *)
+(* A LOGICAL KERNEL FOR FIRST ORDER CLAUSAL THEOREMS *)
+(* Copyright (c) 2001 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Thm :> Thm =
@@ -8648,13 +12219,9 @@
(* 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;
+fun freeIn v (Thm (cl,_)) = LiteralSet.freeIn v cl;
+
+fun freeVars (Thm (cl,_)) = LiteralSet.freeVars cl;
(* ------------------------------------------------------------------------- *)
(* Pretty-printing. *)
@@ -8668,26 +12235,21 @@
| inferenceTypeToString Refl = "Refl"
| inferenceTypeToString Equality = "Equality";
-fun ppInferenceType ppstrm inf =
- Parser.ppString ppstrm (inferenceTypeToString inf);
+fun ppInferenceType inf =
+ Print.ppString (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;
+ fun pp th =
+ Print.blockProgram Print.Inconsistent 3
+ [Print.addString "|- ",
+ Formula.pp (toFormula th)];
+end;
+
+val toString = Print.toString pp;
(* ------------------------------------------------------------------------- *)
(* Primitive rules of inference. *)
@@ -8720,7 +12282,7 @@
let
val cl' = LiteralSet.subst sub cl
in
- if Sharing.pointerEqual (cl,cl') then th
+ if Portable.pointerEqual (cl,cl') then th
else
case inf of
(Subst,_) => Thm (cl',inf)
@@ -8744,7 +12306,7 @@
Thm (LiteralSet.union cl1' cl2', (Resolve,[th1,th2]))
end;
-(*DEBUG
+(*MetisDebug
val resolve = fn lit => fn pos => fn neg =>
resolve lit pos neg
handle Error err =>
@@ -8790,7 +12352,7 @@
(* ========================================================================= *)
(* PROOFS IN FIRST ORDER LOGIC *)
-(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Proof =
@@ -8829,14 +12391,22 @@
val proof : Metis.Thm.thm -> proof
(* ------------------------------------------------------------------------- *)
+(* Free variables. *)
+(* ------------------------------------------------------------------------- *)
+
+val freeIn : Metis.Term.var -> proof -> bool
+
+val freeVars : proof -> Metis.NameSet.set
+
+(* ------------------------------------------------------------------------- *)
(* Printing. *)
(* ------------------------------------------------------------------------- *)
-val ppInference : inference Metis.Parser.pp
+val ppInference : inference Metis.Print.pp
val inferenceToString : inference -> string
-val pp : proof Metis.Parser.pp
+val pp : proof Metis.Print.pp
val toString : proof -> string
@@ -8846,7 +12416,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -8855,7 +12425,7 @@
(* ========================================================================= *)
(* PROOFS IN FIRST ORDER LOGIC *)
-(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Proof :> Proof =
@@ -8889,120 +12459,117 @@
| 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 =
+ fun ppAssume atm = Print.sequence (Print.addBreak 1) (Atom.pp atm);
+
+ fun ppSubst ppThm (sub,thm) =
+ Print.sequence (Print.addBreak 1)
+ (Print.blockProgram Print.Inconsistent 1
+ [Print.addString "{",
+ Print.ppOp2 " =" Print.ppString Subst.pp ("sub",sub),
+ Print.addString ",",
+ Print.addBreak 1,
+ Print.ppOp2 " =" Print.ppString ppThm ("thm",thm),
+ Print.addString "}"]);
+
+ fun ppResolve ppThm (res,pos,neg) =
+ Print.sequence (Print.addBreak 1)
+ (Print.blockProgram Print.Inconsistent 1
+ [Print.addString "{",
+ Print.ppOp2 " =" Print.ppString Atom.pp ("res",res),
+ Print.addString ",",
+ Print.addBreak 1,
+ Print.ppOp2 " =" Print.ppString ppThm ("pos",pos),
+ Print.addString ",",
+ Print.addBreak 1,
+ Print.ppOp2 " =" Print.ppString ppThm ("neg",neg),
+ Print.addString "}"]);
+
+ fun ppRefl tm = Print.sequence (Print.addBreak 1) (Term.pp tm);
+
+ fun ppEquality (lit,path,res) =
+ Print.sequence (Print.addBreak 1)
+ (Print.blockProgram Print.Inconsistent 1
+ [Print.addString "{",
+ Print.ppOp2 " =" Print.ppString Literal.pp ("lit",lit),
+ Print.addString ",",
+ Print.addBreak 1,
+ Print.ppOp2 " =" Print.ppString Term.ppPath ("path",path),
+ Print.addString ",",
+ Print.addBreak 1,
+ Print.ppOp2 " =" Print.ppString Term.pp ("res",res),
+ Print.addString "}"]);
+
+ fun ppInf ppAxiom ppThm 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);
+ Print.block Print.Inconsistent 2
+ (Print.sequence
+ (Print.addString infString)
+ (case inf of
+ Axiom cl => ppAxiom cl
+ | Assume x => ppAssume x
+ | Subst x => ppSubst ppThm x
+ | Resolve x => ppResolve ppThm x
+ | Refl x => ppRefl x
+ | Equality x => ppEquality x))
+ end;
+
+ fun ppAxiom cl =
+ Print.sequence
+ (Print.addBreak 1)
+ (Print.ppMap
+ LiteralSet.toList
+ (Print.ppBracket "{" "}" (Print.ppOpList "," Literal.pp)) cl);
in
val ppInference = ppInf ppAxiom Thm.pp;
- fun pp p prf =
+ fun pp prf =
let
fun thmString n = "(" ^ Int.toString n ^ ")"
-
+
val prf = enumerate prf
- fun ppThm p th =
+ fun ppThm th =
+ Print.addString
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)
+ NONE => "(?)"
+ | SOME (n,_) => 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
+ Print.sequence
+ (Print.blockProgram Print.Consistent (1 + size s)
+ [Print.addString (s ^ " "),
+ Thm.pp th,
+ Print.addBreak 2,
+ Print.ppBracket "[" "]" (ppInf (K Print.skip) ppThm) inf])
+ Print.addNewline
+ end
+ in
+ Print.blockProgram Print.Consistent 0
+ [Print.addString "START OF PROOF",
+ Print.addNewline,
+ Print.program (map ppStep prf),
+ Print.addString "END OF PROOF"]
+ end
+(*MetisDebug
handle Error err => raise Bug ("Proof.pp: shouldn't fail:\n" ^ err);
*)
end;
-val inferenceToString = Parser.toString ppInference;
-
-val toString = Parser.toString pp;
+val inferenceToString = Print.toString ppInference;
+
+val toString = Print.toString pp;
(* ------------------------------------------------------------------------- *)
(* Reconstructing single inferences. *)
@@ -9027,9 +12594,9 @@
let
fun recon [] =
let
-(*TRACE3
- val () = Parser.ppTrace LiteralSet.pp "reconstructSubst: cl" cl
- val () = Parser.ppTrace LiteralSet.pp "reconstructSubst: cl'" cl'
+(*MetisTrace3
+ val () = Print.trace LiteralSet.pp "reconstructSubst: cl" cl
+ val () = Print.trace LiteralSet.pp "reconstructSubst: cl'" cl'
*)
in
raise Bug "can't reconstruct Subst rule"
@@ -9049,7 +12616,7 @@
in
Subst.normalize (recon [(LiteralSet.toList cl, Subst.empty)])
end
-(*DEBUG
+(*MetisDebug
handle Error err =>
raise Bug ("Proof.recontructSubst: shouldn't fail:\n" ^ err);
*)
@@ -9069,32 +12636,37 @@
if not (LiteralSet.null lits) then LiteralSet.pick lits
else raise Bug "can't reconstruct Resolve rule"
end)
-(*DEBUG
+(*MetisDebug
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
+(*MetisTrace3
+ val () = Print.trace 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
+ if not (Name.equal f f' andalso 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
+ let
+ val itms = enumerate (zip a a')
+ in
+ case List.filter (not o uncurry Term.equal o snd) itms of
+ [(i,(tm,tm'))] =>
+ let
+ val path = i :: path
+ in
+ if Term.equal tm s andalso Term.equal 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
+ end
fun recon (neq,(pol,atm),(pol',atm')) =
if pol = pol' then NONE
@@ -9103,9 +12675,9 @@
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
+ if not (Term.equal s t) then sync s t [] atm atm'
+ else if not (Atom.equal atm atm') then NONE
+ else Atom.find (Term.equal s) atm
in
case path of
SOME path => SOME ((pol',atm),path,t)
@@ -9119,10 +12691,10 @@
| ([l1],[l2]) => [(l1,l1,l2),(l1,l2,l1)]
| _ => raise Bug "reconstructEquality: malformed"
-(*TRACE3
+(*MetisTrace3
val ppCands =
- Parser.ppList (Parser.ppTriple Literal.pp Literal.pp Literal.pp)
- val () = Parser.ppTrace ppCands
+ Print.ppList (Print.ppTriple Literal.pp Literal.pp Literal.pp)
+ val () = Print.trace ppCands
"Proof.reconstructEquality: candidates" candidates
*)
in
@@ -9130,7 +12702,7 @@
SOME info => info
| NONE => raise Bug "can't reconstruct Equality rule"
end
-(*DEBUG
+(*MetisDebug
handle Error err =>
raise Bug ("Proof.recontructEquality: shouldn't fail:\n" ^ err);
*)
@@ -9159,25 +12731,25 @@
in
fun thmToInference th =
let
-(*TRACE3
- val () = Parser.ppTrace Thm.pp "Proof.thmToInference: th" th
+(*MetisTrace3
+ val () = Print.trace 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
+(*MetisTrace3
+ val ppThmInf = Print.ppPair Thm.ppInferenceType (Print.ppList Thm.pp)
+ val () = Print.trace ppThmInf "Proof.thmToInference: thmInf" thmInf
*)
val inf = reconstruct cl thmInf
-(*TRACE3
- val () = Parser.ppTrace ppInference "Proof.thmToInference: inf" inf
-*)
-(*DEBUG
+(*MetisTrace3
+ val () = Print.trace ppInference "Proof.thmToInference: inf" inf
+*)
+(*MetisDebug
val () =
let
val th' = inferenceToThm inf
@@ -9195,7 +12767,7 @@
in
inf
end
-(*DEBUG
+(*MetisDebug
handle Error err =>
raise Bug ("Proof.thmToInference: shouldn't fail:\n" ^ err);
*)
@@ -9206,40 +12778,101 @@
(* ------------------------------------------------------------------------- *)
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;
+ val emptyThms : Thm.thm LiteralSetMap.map = LiteralSetMap.new ();
+
+ fun addThms (th,ths) =
+ let
+ val cl = Thm.clause th
+ in
+ if LiteralSetMap.inDomain cl ths then ths
+ else
+ let
+ val (_,pars) = Thm.inference th
+ val ths = List.foldl addThms ths pars
+ in
+ if LiteralSetMap.inDomain cl ths then ths
+ else LiteralSetMap.insert ths (cl,th)
+ end
+ end;
+
+ fun mkThms th = addThms (th,emptyThms);
+
+ fun addProof (th,(ths,acc)) =
+ let
+ val cl = Thm.clause th
+ in
+ case LiteralSetMap.peek ths cl of
+ NONE => (ths,acc)
+ | SOME th =>
+ let
+ val (_,pars) = Thm.inference th
+ val (ths,acc) = List.foldl addProof (ths,acc) pars
+ val ths = LiteralSetMap.delete ths cl
+ val acc = (th, thmToInference th) :: acc
+ in
+ (ths,acc)
+ end
+ end;
+
+ fun mkProof ths th =
+ let
+ val (ths,acc) = addProof (th,(ths,[]))
+(*MetisTrace4
+ val () = Print.trace Print.ppInt "Proof.proof: unnecessary clauses" (LiteralSetMap.size ths)
+*)
+ in
+ rev acc
+ 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;
+(*MetisTrace3
+ val () = Print.trace Thm.pp "Proof.proof: th" th
+*)
+ val ths = mkThms th
+ val infs = mkProof ths th
+(*MetisTrace3
+ val () = Print.trace Print.ppInt "Proof.proof: size" (length infs)
+*)
+ in
+ infs
+ end;
+end;
+
+(* ------------------------------------------------------------------------- *)
+(* Free variables. *)
+(* ------------------------------------------------------------------------- *)
+
+fun freeIn v =
+ let
+ fun free th_inf =
+ case th_inf of
+ (_, Axiom lits) => LiteralSet.freeIn v lits
+ | (_, Assume atm) => Atom.freeIn v atm
+ | (th, Subst _) => Thm.freeIn v th
+ | (_, Resolve _) => false
+ | (_, Refl tm) => Term.freeIn v tm
+ | (_, Equality (lit,_,tm)) =>
+ Literal.freeIn v lit orelse Term.freeIn v tm
+ in
+ List.exists free
+ end;
+
+val freeVars =
+ let
+ fun inc (th_inf,set) =
+ NameSet.union set
+ (case th_inf of
+ (_, Axiom lits) => LiteralSet.freeVars lits
+ | (_, Assume atm) => Atom.freeVars atm
+ | (th, Subst _) => Thm.freeVars th
+ | (_, Resolve _) => NameSet.empty
+ | (_, Refl tm) => Term.freeVars tm
+ | (_, Equality (lit,_,tm)) =>
+ NameSet.union (Literal.freeVars lit) (Term.freeVars tm))
+ in
+ List.foldl inc NameSet.empty
+ end;
end
end;
@@ -9248,7 +12881,7 @@
(* ========================================================================= *)
(* DERIVED RULES FOR CREATING FIRST ORDER LOGIC THEOREMS *)
-(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Rule =
@@ -9261,7 +12894,7 @@
type equation = (Metis.Term.term * Metis.Term.term) * Metis.Thm.thm
-val ppEquation : equation Metis.Parser.pp
+val ppEquation : equation Metis.Print.pp
val equationToString : equation -> string
@@ -9391,6 +13024,8 @@
(* x = x *)
(* ------------------------------------------------------------------------- *)
+val reflexivityRule : Metis.Term.term -> Metis.Thm.thm
+
val reflexivity : Metis.Thm.thm
(* ------------------------------------------------------------------------- *)
@@ -9399,6 +13034,8 @@
(* ~(x = y) \/ y = x *)
(* ------------------------------------------------------------------------- *)
+val symmetryRule : Metis.Term.term -> Metis.Term.term -> Metis.Thm.thm
+
val symmetry : Metis.Thm.thm
(* ------------------------------------------------------------------------- *)
@@ -9521,7 +13158,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -9530,7 +13167,7 @@
(* ========================================================================= *)
(* DERIVED RULES FOR CREATING FIRST ORDER LOGIC THEOREMS *)
-(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Rule :> Rule =
@@ -9539,12 +13176,33 @@
open Useful;
(* ------------------------------------------------------------------------- *)
+(* Variable names. *)
+(* ------------------------------------------------------------------------- *)
+
+val xVarName = Name.fromString "x";
+val xVar = Term.Var xVarName;
+
+val yVarName = Name.fromString "y";
+val yVar = Term.Var yVarName;
+
+val zVarName = Name.fromString "z";
+val zVar = Term.Var zVarName;
+
+fun xIVarName i = Name.fromString ("x" ^ Int.toString i);
+fun xIVar i = Term.Var (xIVarName i);
+
+fun yIVarName i = Name.fromString ("y" ^ Int.toString i);
+fun yIVar i = Term.Var (yIVarName i);
+
+(* ------------------------------------------------------------------------- *)
(* *)
(* --------- reflexivity *)
(* x = x *)
(* ------------------------------------------------------------------------- *)
-val reflexivity = Thm.refl (Term.Var "x");
+fun reflexivityRule x = Thm.refl x;
+
+val reflexivity = reflexivityRule xVar;
(* ------------------------------------------------------------------------- *)
(* *)
@@ -9552,17 +13210,17 @@
(* ~(x = y) \/ y = x *)
(* ------------------------------------------------------------------------- *)
-val symmetry =
- let
- val x = Term.Var "x"
- and y = Term.Var "y"
- val reflTh = reflexivity
+fun symmetryRule x y =
+ let
+ val reflTh = reflexivityRule x
val reflLit = Thm.destUnit reflTh
val eqTh = Thm.equality reflLit [0] y
in
Thm.resolve reflLit reflTh eqTh
end;
+val symmetry = symmetryRule xVar yVar;
+
(* ------------------------------------------------------------------------- *)
(* *)
(* --------------------------------- transitivity *)
@@ -9571,12 +13229,9 @@
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
+ val eqTh = Thm.equality (Literal.mkEq (yVar,zVar)) [0] xVar
+ in
+ Thm.resolve (Literal.mkEq (yVar,xVar)) symmetry eqTh
end;
(* ------------------------------------------------------------------------- *)
@@ -9589,10 +13244,10 @@
let
val (x,y) = Literal.destEq lit
in
- if x = y then th
+ if Term.equal x y then th
else
let
- val sub = Subst.fromList [("x",x),("y",y)]
+ val sub = Subst.fromList [(xVarName,x),(yVarName,y)]
val symTh = Thm.subst sub symmetry
in
Thm.resolve lit th symTh
@@ -9606,9 +13261,9 @@
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 ppEquation (_,th) = Thm.pp th;
+
+val equationToString = Print.toString ppEquation;
fun equationLiteral (t_u,th) =
let
@@ -9620,7 +13275,7 @@
fun reflEqn t = ((t,t), Thm.refl t);
fun symEqn (eqn as ((t,u), th)) =
- if t = u then eqn
+ if Term.equal t u then eqn
else
((u,t),
case equationLiteral eqn of
@@ -9628,9 +13283,9 @@
| 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
+ if Term.equal x y then eqn2
+ else if Term.equal y z then eqn1
+ else if Term.equal x z then reflEqn x
else
((x,z),
case equationLiteral eqn1 of
@@ -9640,7 +13295,7 @@
NONE => th2
| SOME y_z =>
let
- val sub = Subst.fromList [("x",x),("y",y),("z",z)]
+ val sub = Subst.fromList [(xVarName,x),(yVarName,y),(zVarName,z)]
val th = Thm.subst sub transitivity
val th = Thm.resolve x_y th1 th
val th = Thm.resolve y_z th2 th
@@ -9648,7 +13303,7 @@
th
end);
-(*DEBUG
+(*MetisDebug
val transEqn = fn eqn1 => fn eqn2 =>
transEqn eqn1 eqn2
handle Error err =>
@@ -9679,7 +13334,7 @@
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)
@@ -9719,7 +13374,7 @@
| everyConv (conv :: convs) tm = thenConv conv (everyConv convs) tm;
fun rewrConv (eqn as ((x,y), eqTh)) path tm =
- if x = y then allConv tm
+ if Term.equal x y then allConv tm
else if null path then (y,eqTh)
else
let
@@ -9736,7 +13391,7 @@
(tm',th)
end;
-(*DEBUG
+(*MetisDebug
val rewrConv = fn eqn as ((x,y),eqTh) => fn path => fn tm =>
rewrConv eqn path tm
handle Error err =>
@@ -9780,7 +13435,7 @@
f
end;
-(*DEBUG
+(*MetisDebug
val repeatTopDownConv = fn conv => fn tm =>
repeatTopDownConv conv tm
handle Error err => raise Error ("repeatTopDownConv: " ^ err);
@@ -9803,9 +13458,9 @@
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
+ if Literal.equal lit lit' then res2
+ else if Literal.equal lit' lit'' then res1
+ else if Literal.equal lit lit'' then allLiterule lit
else
(lit'',
if not (Thm.member lit' th1) then th1
@@ -9839,7 +13494,7 @@
thenLiterule literule (everyLiterule literules) lit;
fun rewrLiterule (eqn as ((x,y),eqTh)) path lit =
- if x = y then allLiterule lit
+ if Term.equal x y then allLiterule lit
else
let
val th = Thm.equality lit path y
@@ -9852,7 +13507,7 @@
(lit',th)
end;
-(*DEBUG
+(*MetisDebug
val rewrLiterule = fn eqn => fn path => fn lit =>
rewrLiterule eqn path lit
handle Error err =>
@@ -9914,12 +13569,12 @@
let
val (lit',litTh) = literule lit
in
- if lit = lit' then th
+ if Literal.equal lit lit' then th
else if not (Thm.negateMember lit litTh) then litTh
else Thm.resolve lit th litTh
end;
-(*DEBUG
+(*MetisDebug
val literalRule = fn literule => fn lit => fn th =>
literalRule literule lit th
handle Error err =>
@@ -9942,7 +13597,7 @@
fun allLiteralsRule literule th = literalsRule literule (Thm.clause th) th;
fun convRule conv = allLiteralsRule (allArgumentsLiterule conv);
-
+
(* ------------------------------------------------------------------------- *)
(* *)
(* ---------------------------------------------- functionCongruence (f,n) *)
@@ -9952,8 +13607,8 @@
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))
+ val xs = List.tabulate (n,xIVar)
+ and ys = List.tabulate (n,yIVar)
fun cong ((i,yi),(th,lit)) =
let
@@ -9979,8 +13634,8 @@
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))
+ val xs = List.tabulate (n,xIVar)
+ and ys = List.tabulate (n,yIVar)
fun cong ((i,yi),(th,lit)) =
let
@@ -10007,10 +13662,10 @@
let
val (x,y) = Literal.destNeq lit
in
- if x = y then th
+ if Term.equal x y then th
else
let
- val sub = Subst.fromList [("x",y),("y",x)]
+ val sub = Subst.fromList [(xVarName,y),(yVarName,x)]
val symTh = Thm.subst sub symmetry
in
Thm.resolve lit th symTh
@@ -10075,10 +13730,12 @@
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"
+ val _ = Term.isTypedVar x orelse Term.isTypedVar y orelse
+ raise Error "Rule.expandAbbrevs: no vars"
+ val _ = not (Term.equal x y) orelse
+ raise Error "Rule.expandAbbrevs: equal vars"
+ in
+ Subst.unify Subst.empty x y
end;
in
fun expandAbbrevs th =
@@ -10133,8 +13790,8 @@
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';
+ fun ppEdge (FactorEdge atm_atm') = Print.ppPair Atom.pp Atom.pp atm_atm'
+ | ppEdge (ReflEdge tm_tm') = Print.ppPair Term.pp Term.pp tm_tm';
datatype joinStatus =
Joined
@@ -10209,7 +13866,7 @@
end
| init_edges acc apart ((sub,edge) :: sub_edges) =
let
-(*DEBUG
+(*MetisDebug
val () = if not (Subst.null sub) then ()
else raise Bug "Rule.factor.init_edges: empty subst"
*)
@@ -10262,21 +13919,21 @@
in
fun factor' cl =
let
-(*TRACE6
- val () = Parser.ppTrace LiteralSet.pp "Rule.factor': cl" cl
+(*MetisTrace6
+ val () = Print.trace 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
+(*MetisTrace6
+ val ppEdgesSize = Print.ppMap length Print.ppInt
+ val ppEdgel = Print.ppList ppEdge
+ val ppEdges = Print.ppList (Print.ppTriple ppEdgel Subst.pp ppEdgel)
+ val () = Print.trace ppEdgesSize "Rule.factor': |edges|" edges
+ val () = Print.trace ppEdges "Rule.factor': edges" edges
*)
val result = fact [] edges
-(*TRACE6
- val ppResult = Parser.ppList Subst.pp
- val () = Parser.ppTrace ppResult "Rule.factor': result" result
+(*MetisTrace6
+ val ppResult = Print.ppList Subst.pp
+ val () = Print.trace ppResult "Rule.factor': result" result
*)
in
result
@@ -10297,7 +13954,7 @@
(* ========================================================================= *)
(* NORMALIZING FORMULAS *)
-(* Copyright (c) 2001-2007 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001-2009 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Normalize =
@@ -10310,10 +13967,44 @@
val nnf : Metis.Formula.formula -> Metis.Formula.formula
(* ------------------------------------------------------------------------- *)
+(* Conjunctive normal form derivations. *)
+(* ------------------------------------------------------------------------- *)
+
+type thm
+
+datatype inference =
+ Axiom of Metis.Formula.formula
+ | Definition of string * Metis.Formula.formula
+ | Simplify of thm * thm list
+ | Conjunct of thm
+ | Specialize of thm
+ | Skolemize of thm
+ | Clausify of thm
+
+val mkAxiom : Metis.Formula.formula -> thm
+
+val destThm : thm -> Metis.Formula.formula * inference
+
+val proveThms :
+ thm list -> (Metis.Formula.formula * inference * Metis.Formula.formula list) list
+
+val toStringInference : inference -> string
+
+val ppInference : inference Metis.Print.pp
+
+(* ------------------------------------------------------------------------- *)
(* Conjunctive normal form. *)
(* ------------------------------------------------------------------------- *)
-val cnf : Metis.Formula.formula -> Metis.Formula.formula list
+type cnf
+
+val initialCnf : cnf
+
+val addCnf : thm -> cnf -> (Metis.Thm.clause * thm) list * cnf
+
+val proveCnf : thm list -> (Metis.Thm.clause * thm) list
+
+val cnf : Metis.Formula.formula -> Metis.Thm.clause list
end
@@ -10321,7 +14012,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -10330,7 +14021,7 @@
(* ========================================================================= *)
(* NORMALIZING FORMULAS *)
-(* Copyright (c) 2001-2007 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001-2007 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Normalize :> Normalize =
@@ -10339,38 +14030,102 @@
open Useful;
(* ------------------------------------------------------------------------- *)
+(* Constants. *)
+(* ------------------------------------------------------------------------- *)
+
+val prefix = "FOFtoCNF";
+
+val skolemPrefix = "skolem" ^ prefix;
+
+val definitionPrefix = "definition" ^ prefix;
+
+(* ------------------------------------------------------------------------- *)
+(* Storing huge real numbers as their log. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype logReal = LogReal of real;
+
+fun compareLogReal (LogReal logX, LogReal logY) =
+ Real.compare (logX,logY);
+
+val zeroLogReal = LogReal ~1.0;
+
+val oneLogReal = LogReal 0.0;
+
+local
+ fun isZero logX = logX < 0.0;
+
+ (* Assume logX >= logY >= 0.0 *)
+ fun add logX logY = logX + Math.ln (1.0 + Math.exp (logY - logX));
+in
+ fun isZeroLogReal (LogReal logX) = isZero logX;
+
+ fun multiplyLogReal (LogReal logX) (LogReal logY) =
+ if isZero logX orelse isZero logY then zeroLogReal
+ else LogReal (logX + logY);
+
+ fun addLogReal (lx as LogReal logX) (ly as LogReal logY) =
+ if isZero logX then ly
+ else if isZero logY then lx
+ else if logX < logY then LogReal (add logY logX)
+ else LogReal (add logX logY);
+
+ fun withinRelativeLogReal logDelta (LogReal logX) (LogReal logY) =
+ isZero logX orelse
+ (not (isZero logY) andalso logX < logY + logDelta);
+end;
+
+fun toStringLogReal (LogReal logX) = Real.toString logX;
+
+(* ------------------------------------------------------------------------- *)
(* 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;
+val countLogDelta = 0.01;
+
+datatype count = Count of {positive : logReal, negative : logReal};
+
+fun countCompare (count1,count2) =
+ let
+ val Count {positive = p1, negative = _} = count1
+ and Count {positive = p2, negative = _} = count2
+ in
+ compareLogReal (p1,p2)
+ end;
fun countNegate (Count {positive = p, negative = n}) =
Count {positive = n, negative = p};
+fun countLeqish count1 count2 =
+ let
+ val Count {positive = p1, negative = _} = count1
+ and Count {positive = p2, negative = _} = count2
+ in
+ withinRelativeLogReal countLogDelta p1 p2
+ end;
+
+(*MetisDebug
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};
+ countLeqish count1 count2 andalso
+ countLeqish count2 count1;
+
+fun countEquivish count1 count2 =
+ countEqualish count1 count2 andalso
+ countEqualish (countNegate count1) (countNegate count2);
+*)
+
+val countTrue = Count {positive = zeroLogReal, negative = oneLogReal};
+
+val countFalse = Count {positive = oneLogReal, negative = zeroLogReal};
+
+val countLiteral = Count {positive = oneLogReal, negative = oneLogReal};
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
+ val p = addLogReal p1 p2
+ and n = multiplyLogReal n1 n2
in
Count {positive = p, negative = n}
end;
@@ -10379,25 +14134,36 @@
let
val Count {positive = p1, negative = n1} = count1
and Count {positive = p2, negative = n2} = count2
- val p = p1 * p2
- and n = n1 + n2
+ val p = multiplyLogReal p1 p2
+ and n = addLogReal n1 n2
in
Count {positive = p, negative = n}
end;
-(*** Is this associative? ***)
+(* Whether countXor2 is associative or not is an open question. *)
+
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
+ val p = addLogReal (multiplyLogReal p1 p2) (multiplyLogReal n1 n2)
+ and n = addLogReal (multiplyLogReal p1 n2) (multiplyLogReal n1 p2)
in
Count {positive = p, negative = n}
end;
fun countDefinition body_count = countXor2 (countLiteral,body_count);
+val countToString =
+ let
+ val rToS = toStringLogReal
+ in
+ fn Count {positive = p, negative = n} =>
+ "(+" ^ rToS p ^ ",-" ^ rToS n ^ ")"
+ end;
+
+val ppCount = Print.ppMap countToString Print.ppString;
+
(* ------------------------------------------------------------------------- *)
(* A type of normalized formula. *)
(* ------------------------------------------------------------------------- *)
@@ -10413,41 +14179,43 @@
| 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);
+ if Portable.pointerEqual f1_f2 then EQUAL
+ else
+ 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;
@@ -10491,7 +14259,7 @@
| polarity (Exists _) = true
| polarity (Forall _) = false;
-(*DEBUG
+(*MetisDebug
val polarity = fn f =>
let
val res1 = compare (f, negate f) = LESS
@@ -10585,7 +14353,7 @@
end
end;
-val AndList = foldl And2 True;
+val AndList = List.foldl And2 True;
val AndSet = Set.foldl And2 True;
@@ -10621,7 +14389,7 @@
end
end;
-val OrList = foldl Or2 False;
+val OrList = List.foldl Or2 False;
val OrSet = Set.foldl Or2 False;
@@ -10631,12 +14399,13 @@
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;
+val pushOrList = List.foldl pushOr2 False;
local
fun normalize fm =
@@ -10674,7 +14443,7 @@
end;
end;
-val XorList = foldl Xor2 False;
+val XorList = List.foldl Xor2 False;
val XorSet = Set.foldl Xor2 False;
@@ -10736,7 +14505,7 @@
exists init_fm
end;
-fun ExistsList (vs,f) = foldl Exists1 f vs;
+fun ExistsList (vs,f) = List.foldl Exists1 f vs;
fun ExistsSet (n,f) = NameSet.foldl Exists1 f n;
@@ -10774,10 +14543,12 @@
forall init_fm
end;
-fun ForallList (vs,f) = foldl Forall1 f vs;
+fun ForallList (vs,f) = List.foldl Forall1 f vs;
fun ForallSet (n,f) = NameSet.foldl Forall1 f n;
+fun generalize f = ForallSet (freeVars f, f);
+
local
fun subst_fv fvSub =
let
@@ -10910,9 +14681,20 @@
val toFormula = form;
end;
-val pp = Parser.ppMap toFormula Formula.pp;
-
-val toString = Parser.toString pp;
+fun toLiteral (Literal (_,lit)) = lit
+ | toLiteral _ = raise Error "Normalize.toLiteral";
+
+local
+ fun addLiteral (l,s) = LiteralSet.add s (toLiteral l);
+in
+ fun toClause False = LiteralSet.empty
+ | toClause (Or (_,_,s)) = Set.foldl addLiteral LiteralSet.empty s
+ | toClause l = LiteralSet.singleton (toLiteral l);
+end;
+
+val pp = Print.ppMap toFormula Formula.pp;
+
+val toString = Print.toString pp;
(* ------------------------------------------------------------------------- *)
(* Negation normal form. *)
@@ -10921,224 +14703,30 @@
fun nnf fm = toFormula (fromFormula fm);
(* ------------------------------------------------------------------------- *)
-(* Simplifying with definitions. *)
-(* ------------------------------------------------------------------------- *)
-
-datatype simplify =
- Simplify of
- {formula : (formula,formula) Map.map,
- andSet : (formula Set.set * formula) list,
- orSet : (formula Set.set * formula) list,
- xorSet : (formula Set.set * formula) list};
-
-val simplifyEmpty =
- Simplify {formula = Map.new compare, andSet = [], orSet = [], xorSet = []};
-
-local
- fun simpler fm s =
- Set.size s <> 1 orelse
- case Set.pick s of
- True => false
- | False => false
- | Literal _ => false
- | _ => true;
-
- fun addSet set_defs body_def =
- let
- fun def_body_size (body,_) = Set.size body
-
- val body_size = def_body_size body_def
-
- val (body,_) = body_def
-
- fun add acc [] = List.revAppend (acc,[body_def])
- | add acc (l as (bd as (b,_)) :: bds) =
- case Int.compare (def_body_size bd, body_size) of
- LESS => List.revAppend (acc, body_def :: l)
- | EQUAL => if Set.equal b body then List.revAppend (acc,l)
- else add (bd :: acc) bds
- | GREATER => add (bd :: acc) bds
- in
- add [] set_defs
- end;
-
- fun add simp (body,False) = add simp (negate body, True)
- | add simp (True,_) = simp
- | add (Simplify {formula,andSet,orSet,xorSet}) (And (_,_,s), def) =
- let
- val andSet = addSet andSet (s,def)
- and orSet = addSet orSet (negateSet s, negate def)
- in
- Simplify
- {formula = formula,
- andSet = andSet, orSet = orSet, xorSet = xorSet}
- end
- | add (Simplify {formula,andSet,orSet,xorSet}) (Or (_,_,s), def) =
- let
- val orSet = addSet orSet (s,def)
- and andSet = addSet andSet (negateSet s, negate def)
- in
- Simplify
- {formula = formula,
- andSet = andSet, orSet = orSet, xorSet = xorSet}
- end
- | add simp (Xor (_,_,p,s), def) =
- let
- val simp = addXorSet simp (s, applyPolarity p def)
- in
- case def of
- True =>
- let
- fun addXorLiteral (fm as Literal _, simp) =
- let
- val s = Set.delete s fm
- in
- if not (simpler fm s) then simp
- else addXorSet simp (s, applyPolarity (not p) fm)
- end
- | addXorLiteral (_,simp) = simp
- in
- Set.foldl addXorLiteral simp s
- end
- | _ => simp
- end
- | add (simp as Simplify {formula,andSet,orSet,xorSet}) (body,def) =
- if Map.inDomain body formula then simp
- else
- let
- val formula = Map.insert formula (body,def)
- val formula = Map.insert formula (negate body, negate def)
- in
- Simplify
- {formula = formula,
- andSet = andSet, orSet = orSet, xorSet = xorSet}
- end
-
- and addXorSet (simp as Simplify {formula,andSet,orSet,xorSet}) (s,def) =
- if Set.size s = 1 then add simp (Set.pick s, def)
- else
- let
- val xorSet = addSet xorSet (s,def)
- in
- Simplify
- {formula = formula,
- andSet = andSet, orSet = orSet, xorSet = xorSet}
- end;
-in
- fun simplifyAdd simp fm = add simp (fm,True);
-end;
-
-local
- fun simplifySet set_defs set =
- let
- fun pred (s,_) = Set.subset s set
- in
- case List.find pred set_defs of
- NONE => NONE
- | SOME (s,f) => SOME (Set.add (Set.difference set s) f)
- end;
-in
- fun simplify (Simplify {formula,andSet,orSet,xorSet}) =
- let
- fun simp fm = simp_top (simp_sub fm)
-
- and simp_top (changed_fm as (_, And (_,_,s))) =
- (case simplifySet andSet s of
- NONE => changed_fm
- | SOME s => simp_top (true, AndSet s))
- | simp_top (changed_fm as (_, Or (_,_,s))) =
- (case simplifySet orSet s of
- NONE => changed_fm
- | SOME s => simp_top (true, OrSet s))
- | simp_top (changed_fm as (_, Xor (_,_,p,s))) =
- (case simplifySet xorSet s of
- NONE => changed_fm
- | SOME s => simp_top (true, XorPolaritySet (p,s)))
- | simp_top (changed_fm as (_,fm)) =
- (case Map.peek formula fm of
- NONE => changed_fm
- | SOME fm => simp_top (true,fm))
-
- and simp_sub fm =
- case fm of
- And (_,_,s) =>
- let
- val l = Set.transform simp s
- val changed = List.exists fst l
- val fm = if changed then AndList (map snd l) else fm
- in
- (changed,fm)
- end
- | Or (_,_,s) =>
- let
- val l = Set.transform simp s
- val changed = List.exists fst l
- val fm = if changed then OrList (map snd l) else fm
- in
- (changed,fm)
- end
- | Xor (_,_,p,s) =>
- let
- val l = Set.transform simp s
- val changed = List.exists fst l
- val fm = if changed then XorPolarityList (p, map snd l) else fm
- in
- (changed,fm)
- end
- | Exists (_,_,n,f) =>
- let
- val (changed,f) = simp f
- val fm = if changed then ExistsSet (n,f) else fm
- in
- (changed,fm)
- end
- | Forall (_,_,n,f) =>
- let
- val (changed,f) = simp f
- val fm = if changed then ForallSet (n,f) else fm
- in
- (changed,fm)
- end
- | _ => (false,fm);
- in
- fn fm => snd (simp fm)
- end;
-end;
-
-(*TRACE2
-val simplify = fn simp => fn fm =>
- let
- val fm' = simplify simp fm
- val () = if compare (fm,fm') = EQUAL then ()
- else (Parser.ppTrace pp "Normalize.simplify: fm" fm;
- Parser.ppTrace pp "Normalize.simplify: fm'" fm')
- in
- fm'
- end;
-*)
-
-(* ------------------------------------------------------------------------- *)
(* Basic conjunctive normal form. *)
(* ------------------------------------------------------------------------- *)
val newSkolemFunction =
let
- val counter : int NameMap.map Unsynchronized.ref = Unsynchronized.ref (NameMap.new ())
- in
- fn n => CRITICAL (fn () =>
- let
- val Unsynchronized.ref m = counter
- val i = Option.getOpt (NameMap.peek m n, 0)
- val () = counter := NameMap.insert m (n, i + 1)
- in
- "skolem_" ^ n ^ (if i = 0 then "" else "_" ^ Int.toString i)
- end)
+ val counter : int StringMap.map Unsynchronized.ref = Unsynchronized.ref (StringMap.new ())
+ in
+ fn n =>
+ let
+ val Unsynchronized.ref m = counter
+ val s = Name.toString n
+ val i = Option.getOpt (StringMap.peek m s, 0)
+ val () = counter := StringMap.insert m (s, i + 1)
+ val i = if i = 0 then "" else "_" ^ Int.toString i
+ val s = skolemPrefix ^ "_" ^ s ^ i
+ in
+ Name.fromString s
+ 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
@@ -11158,7 +14746,7 @@
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
@@ -11167,35 +14755,43 @@
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'
+ fun cnfFm avoid fm =
+(*MetisTrace5
+ let
+ val fm' = cnfFm' avoid fm
+ val () = Print.trace pp "Normalize.cnfFm: fm" fm
+ val () = Print.trace pp "Normalize.cnfFm: fm'" fm'
in
fm'
end
- and cnf' avoid fm =
+ and cnfFm' 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;
+ | And (_,_,s) => AndList (Set.transform (cnfFm avoid) s)
+ | Or (fv,_,s) =>
+ let
+ val avoid = NameSet.union avoid fv
+ val (fms,_) = Set.foldl cnfOr ([],avoid) s
+ in
+ pushOrList fms
+ end
+ | Xor _ => cnfFm avoid (pushXor fm)
+ | Exists (fv,_,n,f) => cnfFm avoid (skolemize fv n f)
+ | Forall (fv,_,n,f) => cnfFm avoid (rename avoid fv n f)
+
+ and cnfOr (fm,(fms,avoid)) =
+ let
+ val fm = cnfFm avoid fm
+ val fms = fm :: fms
+ val avoid = NameSet.union avoid (freeVars fm)
+ in
+ (fms,avoid)
+ end;
+in
+ val basicCnf = cnfFm NameSet.empty;
end;
(* ------------------------------------------------------------------------- *)
@@ -11203,7 +14799,7 @@
(* ------------------------------------------------------------------------- *)
local
- type best = real * formula option;
+ type best = count * formula option;
fun minBreak countClauses fm best =
case fm of
@@ -11218,7 +14814,7 @@
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 =
@@ -11242,7 +14838,11 @@
val (c1,_,fms) = foldl fwd (count0,empty,[]) fms
val (c2,_,fms) = foldl bwd (count0,empty,[]) fms
- val _ = countEqualish c1 c2 orelse raise Bug "cumulativeCounts"
+(*MetisDebug
+ val _ = countEquivish c1 c2 orelse
+ raise Bug ("cumulativeCounts: c1 = " ^ countToString c1 ^
+ ", c2 = " ^ countToString c2)
+*)
in
fms
end
@@ -11250,6 +14850,7 @@
fun breakSing ((c1,_,fm,c2,_),best) =
let
val cFms = count2 (c1,c2)
+
fun countCls cFm = countClauses (count2 (cFms,cFm))
in
minBreak countCls fm best
@@ -11261,13 +14862,13 @@
if Set.null s1 then best
else
let
- val cDef = countDefinition (count2 (c1, count fm))
+ val cDef = countDefinition (countXor2 (c1, count fm))
val cFm = count2 (countLiteral,c2)
- val cl = positive cDef + countClauses cFm
- val better = cl < bcl - 0.5
+ val cl = countAnd2 (cDef, countClauses cFm)
+ val noBetter = countLeqish bcl cl
in
- if better then (cl, SOME (mkSet (Set.add s1 fm)))
- else best
+ if noBetter then best
+ else (cl, SOME (mkSet (Set.add s1 fm)))
end
in
fn ((c1,s1,fm,c2,s2),best) =>
@@ -11278,14 +14879,14 @@
fun breakSet measure best =
let
- val fms = sortMap (measure o count) Real.compare fms
+ val fms = sortMap (measure o count) countCompare 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 I best
+ val best = breakSet countNegate best
val best = breakSet countClauses best
in
best
@@ -11293,21 +14894,20 @@
in
fun minimumDefinition fm =
let
- val countClauses = positive
- val cl = countClauses (count fm)
- in
- if cl < 1.5 then NONE
+ val cl = count fm
+ in
+ if countLeqish cl countLiteral then NONE
else
let
- val (cl',def) = minBreak countClauses fm (cl,NONE)
-(*TRACE1
+ val (cl',def) = minBreak I fm (cl,NONE)
+(*MetisTrace1
val () =
case def of
NONE => ()
| SOME d =>
- Parser.ppTrace pp ("defCNF: before = " ^ Real.toString cl ^
- ", after = " ^ Real.toString cl' ^
- ", definition") d
+ Print.trace pp ("defCNF: before = " ^ countToString cl ^
+ ", after = " ^ countToString cl' ^
+ ", definition") d
*)
in
def
@@ -11316,78 +14916,493 @@
end;
(* ------------------------------------------------------------------------- *)
-(* Conjunctive normal form. *)
+(* Conjunctive normal form derivations. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype thm = Thm of formula * inference
+
+and inference =
+ Axiom of Formula.formula
+ | Definition of string * Formula.formula
+ | Simplify of thm * thm list
+ | Conjunct of thm
+ | Specialize of thm
+ | Skolemize of thm
+ | Clausify of thm;
+
+fun parentsInference inf =
+ case inf of
+ Axiom _ => []
+ | Definition _ => []
+ | Simplify (th,ths) => th :: ths
+ | Conjunct th => [th]
+ | Specialize th => [th]
+ | Skolemize th => [th]
+ | Clausify th => [th];
+
+fun compareThm (Thm (fm1,_), Thm (fm2,_)) = compare (fm1,fm2);
+
+fun parentsThm (Thm (_,inf)) = parentsInference inf;
+
+fun mkAxiom fm = Thm (fromFormula fm, Axiom fm);
+
+fun destThm (Thm (fm,inf)) = (toFormula fm, inf);
+
+local
+ val emptyProved : (thm,Formula.formula) Map.map = Map.new compareThm;
+
+ fun isProved proved th = Map.inDomain th proved;
+
+ fun isUnproved proved th = not (isProved proved th);
+
+ fun lookupProved proved th =
+ case Map.peek proved th of
+ SOME fm => fm
+ | NONE => raise Bug "Normalize.lookupProved";
+
+ fun prove acc proved ths =
+ case ths of
+ [] => rev acc
+ | th :: ths' =>
+ if isProved proved th then prove acc proved ths'
+ else
+ let
+ val pars = parentsThm th
+
+ val deps = List.filter (isUnproved proved) pars
+ in
+ if null deps then
+ let
+ val (fm,inf) = destThm th
+
+ val fms = map (lookupProved proved) pars
+
+ val acc = (fm,inf,fms) :: acc
+
+ val proved = Map.insert proved (th,fm)
+ in
+ prove acc proved ths'
+ end
+ else
+ let
+ val ths = deps @ ths
+ in
+ prove acc proved ths
+ end
+ end;
+in
+ val proveThms = prove [] emptyProved;
+end;
+
+fun toStringInference inf =
+ case inf of
+ Axiom _ => "Axiom"
+ | Definition _ => "Definition"
+ | Simplify _ => "Simplify"
+ | Conjunct _ => "Conjunct"
+ | Specialize _ => "Specialize"
+ | Skolemize _ => "Skolemize"
+ | Clausify _ => "Clausify";
+
+val ppInference = Print.ppMap toStringInference Print.ppString;
+
+(* ------------------------------------------------------------------------- *)
+(* Simplifying with definitions. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype simplify =
+ Simp of
+ {formula : (formula, formula * thm) Map.map,
+ andSet : (formula Set.set * formula * thm) list,
+ orSet : (formula Set.set * formula * thm) list,
+ xorSet : (formula Set.set * formula * thm) list};
+
+val simplifyEmpty =
+ Simp
+ {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,th) = add simp (negate body, True, th)
+ | add simp (True,_,_) = simp
+ | add (Simp {formula,andSet,orSet,xorSet}) (And (_,_,s), def, th) =
+ let
+ val andSet = addSet andSet (s,def,th)
+ and orSet = addSet orSet (negateSet s, negate def, th)
+ in
+ Simp
+ {formula = formula,
+ andSet = andSet,
+ orSet = orSet,
+ xorSet = xorSet}
+ end
+ | add (Simp {formula,andSet,orSet,xorSet}) (Or (_,_,s), def, th) =
+ let
+ val orSet = addSet orSet (s,def,th)
+ and andSet = addSet andSet (negateSet s, negate def, th)
+ in
+ Simp
+ {formula = formula,
+ andSet = andSet,
+ orSet = orSet,
+ xorSet = xorSet}
+ end
+ | add simp (Xor (_,_,p,s), def, th) =
+ let
+ val simp = addXorSet simp (s, applyPolarity p def, th)
+ 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, th)
+ end
+ | addXorLiteral (_,simp) = simp
+ in
+ Set.foldl addXorLiteral simp s
+ end
+ | _ => simp
+ end
+ | add (simp as Simp {formula,andSet,orSet,xorSet}) (body,def,th) =
+ if Map.inDomain body formula then simp
+ else
+ let
+ val formula = Map.insert formula (body,(def,th))
+ val formula = Map.insert formula (negate body, (negate def, th))
+ in
+ Simp
+ {formula = formula,
+ andSet = andSet,
+ orSet = orSet,
+ xorSet = xorSet}
+ end
+
+ and addXorSet (simp as Simp {formula,andSet,orSet,xorSet}) (s,def,th) =
+ if Set.size s = 1 then add simp (Set.pick s, def, th)
+ else
+ let
+ val xorSet = addSet xorSet (s,def,th)
+ in
+ Simp
+ {formula = formula,
+ andSet = andSet,
+ orSet = orSet,
+ xorSet = xorSet}
+ end;
+in
+ fun simplifyAdd simp (th as Thm (fm,_)) = add simp (fm,True,th);
+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,th) =>
+ let
+ val set = Set.add (Set.difference set s) f
+ in
+ SOME (set,th)
+ end
+ end;
+in
+ fun simplify (Simp {formula,andSet,orSet,xorSet}) =
+ let
+ fun simp fm inf =
+ case simp_sub fm inf of
+ NONE => simp_top fm inf
+ | SOME (fm,inf) => try_simp_top fm inf
+
+ and try_simp_top fm inf =
+ case simp_top fm inf of
+ NONE => SOME (fm,inf)
+ | x => x
+
+ and simp_top fm inf =
+ case fm of
+ And (_,_,s) =>
+ (case simplifySet andSet s of
+ NONE => NONE
+ | SOME (s,th) =>
+ let
+ val fm = AndSet s
+ val inf = th :: inf
+ in
+ try_simp_top fm inf
+ end)
+ | Or (_,_,s) =>
+ (case simplifySet orSet s of
+ NONE => NONE
+ | SOME (s,th) =>
+ let
+ val fm = OrSet s
+ val inf = th :: inf
+ in
+ try_simp_top fm inf
+ end)
+ | Xor (_,_,p,s) =>
+ (case simplifySet xorSet s of
+ NONE => NONE
+ | SOME (s,th) =>
+ let
+ val fm = XorPolaritySet (p,s)
+ val inf = th :: inf
+ in
+ try_simp_top fm inf
+ end)
+ | _ =>
+ (case Map.peek formula fm of
+ NONE => NONE
+ | SOME (fm,th) =>
+ let
+ val inf = th :: inf
+ in
+ try_simp_top fm inf
+ end)
+
+ and simp_sub fm inf =
+ case fm of
+ And (_,_,s) =>
+ (case simp_set s inf of
+ NONE => NONE
+ | SOME (l,inf) => SOME (AndList l, inf))
+ | Or (_,_,s) =>
+ (case simp_set s inf of
+ NONE => NONE
+ | SOME (l,inf) => SOME (OrList l, inf))
+ | Xor (_,_,p,s) =>
+ (case simp_set s inf of
+ NONE => NONE
+ | SOME (l,inf) => SOME (XorPolarityList (p,l), inf))
+ | Exists (_,_,n,f) =>
+ (case simp f inf of
+ NONE => NONE
+ | SOME (f,inf) => SOME (ExistsSet (n,f), inf))
+ | Forall (_,_,n,f) =>
+ (case simp f inf of
+ NONE => NONE
+ | SOME (f,inf) => SOME (ForallSet (n,f), inf))
+ | _ => NONE
+
+ and simp_set s inf =
+ let
+ val (changed,l,inf) = Set.foldr simp_set_elt (false,[],inf) s
+ in
+ if changed then SOME (l,inf) else NONE
+ end
+
+ and simp_set_elt (fm,(changed,l,inf)) =
+ case simp fm inf of
+ NONE => (changed, fm :: l, inf)
+ | SOME (fm,inf) => (true, fm :: l, inf)
+ in
+ fn th as Thm (fm,_) =>
+ case simp fm [] of
+ SOME (fm,ths) =>
+ let
+ val inf = Simplify (th,ths)
+ in
+ Thm (fm,inf)
+ end
+ | NONE => th
+ end;
+end;
+
+(*MetisTrace2
+val simplify = fn simp => fn th as Thm (fm,_) =>
+ let
+ val th' as Thm (fm',_) = simplify simp th
+ val () = if compare (fm,fm') = EQUAL then ()
+ else (Print.trace pp "Normalize.simplify: fm" fm;
+ Print.trace pp "Normalize.simplify: fm'" fm')
+ in
+ th'
+ end;
+*)
+
+(* ------------------------------------------------------------------------- *)
+(* Definitions. *)
(* ------------------------------------------------------------------------- *)
val newDefinitionRelation =
let
val counter : int Unsynchronized.ref = Unsynchronized.ref 0
in
- fn () => CRITICAL (fn () =>
- let
- val Unsynchronized.ref i = counter
- val () = counter := i + 1
- in
- "defCNF_" ^ Int.toString i
- end)
+ fn () =>
+ let
+ val Unsynchronized.ref i = counter
+ val () = counter := i + 1
+ in
+ definitionPrefix ^ "_" ^ 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 =
+ val rel = newDefinitionRelation ()
+ val atm = (Name.fromString rel, NameSet.transform Term.Var fv)
+ val fm = Formula.Iff (Formula.Atom atm, toFormula def)
+ val fm = Formula.setMkForall (fv,fm)
+ val inf = Definition (rel,fm)
+ val lit = Literal (fv,(false,atm))
+ val fm = Xor2 (lit,def)
+ in
+ Thm (fm,inf)
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Definitional conjunctive normal form. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype cnf =
+ ConsistentCnf of simplify
+ | InconsistentCnf;
+
+val initialCnf = ConsistentCnf simplifyEmpty;
+
+local
+ fun def_cnf_inconsistent th =
+ let
+ val cls = [(LiteralSet.empty,th)]
+ in
+ (cls,InconsistentCnf)
+ end;
+
+ fun def_cnf_clause inf (fm,acc) =
+ let
+ val cl = toClause fm
+ val th = Thm (fm,inf)
+ in
+ (cl,th) :: acc
+ end
+(*MetisDebug
+ handle Error err =>
+ (Print.trace pp "Normalize.addCnf.def_cnf_clause: fm" fm;
+ raise Bug ("Normalize.addCnf.def_cnf_clause: " ^ err));
+*)
+
+ fun def_cnf cls simp ths =
+ case ths of
+ [] => (cls, ConsistentCnf simp)
+ | th :: ths => def_cnf_formula cls simp (simplify simp th) ths
+
+ and def_cnf_formula cls simp (th as Thm (fm,_)) ths =
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
+ True => def_cnf cls simp ths
+ | False => def_cnf_inconsistent th
+ | And (_,_,s) =>
+ let
+ fun add (f,z) = Thm (f, Conjunct th) :: z
+ in
+ def_cnf cls simp (Set.foldr add ths s)
+ end
| 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
+ let
+ val th = Thm (skolemize fv n f, Skolemize th)
+ in
+ def_cnf_formula cls simp th ths
+ end
+ | Forall (_,_,_,f) =>
+ let
+ val th = Thm (f, Specialize th)
+ in
+ def_cnf_formula cls simp th ths
+ end
| _ =>
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
+ SOME def =>
+ let
+ val ths = th :: ths
+ val th = newDefinition def
+ in
+ def_cnf_formula cls simp th ths
+ end
+ | NONE =>
+ let
+ val simp = simplifyAdd simp th
+
+ val fm = basicCnf fm
+
+ val inf = Clausify th
+ in
+ case fm of
+ True => def_cnf cls simp ths
+ | False => def_cnf_inconsistent (Thm (fm,inf))
+ | And (_,_,s) =>
+ let
+ val inf = Conjunct (Thm (fm,inf))
+ val cls = Set.foldl (def_cnf_clause inf) cls s
+ in
+ def_cnf cls simp ths
+ end
+ | fm => def_cnf (def_cnf_clause inf (fm,cls)) simp ths
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;
+in
+ fun addCnf th cnf =
+ case cnf of
+ ConsistentCnf simp => def_cnf [] simp [th]
+ | InconsistentCnf => ([],cnf);
+end;
+
+local
+ fun add (th,(cls,cnf)) =
+ let
+ val (cls',cnf) = addCnf th cnf
+ in
+ (cls' @ cls, cnf)
+ end;
+in
+ fun proveCnf ths =
+ let
+ val (cls,_) = List.foldl add ([],initialCnf) ths
+ in
+ rev cls
+ end;
+end;
+
+fun cnf fm =
+ let
+ val cls = proveCnf [mkAxiom fm]
+ in
+ map fst cls
+ end;
end
end;
@@ -11396,40 +15411,198 @@
(* ========================================================================= *)
(* RANDOM FINITE MODELS *)
-(* Copyright (c) 2003-2007 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2003 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Model =
sig
(* ------------------------------------------------------------------------- *)
+(* Model size. *)
+(* ------------------------------------------------------------------------- *)
+
+type size = {size : int}
+
+(* ------------------------------------------------------------------------- *)
+(* A model of size N has integer elements 0...N-1. *)
+(* ------------------------------------------------------------------------- *)
+
+type element = int
+
+val zeroElement : element
+
+val incrementElement : size -> element -> element option
+
+(* ------------------------------------------------------------------------- *)
(* 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 *)
+(* ------------------------------------------------------------------------- *)
+
+type fixedFunction = size -> element list -> element option
+
+type fixedRelation = size -> element list -> bool option
+
+datatype fixed =
+ Fixed of
+ {functions : fixedFunction Metis.NameArityMap.map,
+ relations : fixedRelation Metis.NameArityMap.map}
+
+val emptyFixed : fixed
+
+val unionFixed : fixed -> fixed -> fixed
+
+val getFunctionFixed : fixed -> Metis.NameArity.nameArity -> fixedFunction
+
+val getRelationFixed : fixed -> Metis.NameArity.nameArity -> fixedRelation
+
+val insertFunctionFixed : fixed -> Metis.NameArity.nameArity * fixedFunction -> fixed
+
+val insertRelationFixed : fixed -> Metis.NameArity.nameArity * fixedRelation -> fixed
+
+val unionListFixed : fixed list -> fixed
+
+val basicFixed : fixed (* interprets equality and hasType *)
+
+(* ------------------------------------------------------------------------- *)
+(* Renaming fixed model parts. *)
+(* ------------------------------------------------------------------------- *)
+
+type fixedMap =
+ {functionMap : Metis.Name.name Metis.NameArityMap.map,
+ relationMap : Metis.Name.name Metis.NameArityMap.map}
+
+val mapFixed : fixedMap -> fixed -> fixed
+
+val ppFixedMap : fixedMap Metis.Print.pp
+
+(* ------------------------------------------------------------------------- *)
+(* Standard fixed model parts. *)
+(* ------------------------------------------------------------------------- *)
+
+(* Projections *)
+
+val projectionMin : int
+
+val projectionMax : int
+
+val projectionName : int -> Metis.Name.name
+
+val projectionFixed : fixed
+
+(* Arithmetic *)
+
+val numeralMin : int
+
+val numeralMax : int
+
+val numeralName : int -> Metis.Name.name
+
+val addName : Metis.Name.name
+
+val divName : Metis.Name.name
+
+val dividesName : Metis.Name.name
+
+val evenName : Metis.Name.name
+
+val expName : Metis.Name.name
+
+val geName : Metis.Name.name
+
+val gtName : Metis.Name.name
+
+val isZeroName : Metis.Name.name
+
+val leName : Metis.Name.name
+
+val ltName : Metis.Name.name
+
+val modName : Metis.Name.name
+
+val multName : Metis.Name.name
+
+val negName : Metis.Name.name
+
+val oddName : Metis.Name.name
+
+val preName : Metis.Name.name
+
+val subName : Metis.Name.name
+
+val sucName : Metis.Name.name
+
+val modularFixed : fixed
+
+val overflowFixed : fixed
+
+(* Sets *)
+
+val cardName : Metis.Name.name
+
+val complementName : Metis.Name.name
+
+val differenceName : Metis.Name.name
+
+val emptyName : Metis.Name.name
+
+val memberName : Metis.Name.name
+
+val insertName : Metis.Name.name
+
+val intersectName : Metis.Name.name
+
+val singletonName : Metis.Name.name
+
+val subsetName : Metis.Name.name
+
+val symmetricDifferenceName : Metis.Name.name
+
+val unionName : Metis.Name.name
+
+val universeName : Metis.Name.name
+
+val setFixed : fixed
+
+(* Lists *)
+
+val appendName : Metis.Name.name
+
+val consName : Metis.Name.name
+
+val lengthName : Metis.Name.name
+
+val nilName : Metis.Name.name
+
+val nullName : Metis.Name.name
+
+val tailName : Metis.Name.name
+
+val listFixed : fixed
+
+(* ------------------------------------------------------------------------- *)
+(* Valuations. *)
+(* ------------------------------------------------------------------------- *)
+
+type valuation
+
+val emptyValuation : valuation
+
+val zeroValuation : Metis.NameSet.set -> valuation
+
+val constantValuation : element -> Metis.NameSet.set -> valuation
+
+val peekValuation : valuation -> Metis.Name.name -> element option
+
+val getValuation : valuation -> Metis.Name.name -> element
+
+val insertValuation : valuation -> Metis.Name.name * element -> valuation
+
+val randomValuation : {size : int} -> Metis.NameSet.set -> valuation
+
+val incrementValuation :
+ {size : int} -> Metis.NameSet.set -> valuation -> valuation option
+
+val foldValuation :
+ {size : int} -> Metis.NameSet.set -> (valuation * 'a -> 'a) -> 'a -> 'a
(* ------------------------------------------------------------------------- *)
(* A type of random finite models. *)
@@ -11439,28 +15612,21 @@
type model
+val default : parameters
+
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 interpretFunction : model -> Metis.Term.functionName * element list -> element
+
+val interpretRelation : model -> Metis.Atom.relationName * element list -> bool
+
+val interpretTerm : model -> valuation -> Metis.Term.term -> element
val interpretAtom : model -> valuation -> Metis.Atom.atom -> bool
@@ -11475,17 +15641,49 @@
(* Note: if it's cheaper, a systematic check will be performed instead. *)
(* ------------------------------------------------------------------------- *)
+val check :
+ (model -> valuation -> 'a -> bool) -> {maxChecks : int option} -> model ->
+ Metis.NameSet.set -> 'a -> {T : int, F : int}
+
val checkAtom :
- {maxChecks : int} -> model -> Metis.Atom.atom -> {T : int, F : int}
+ {maxChecks : int option} -> model -> Metis.Atom.atom -> {T : int, F : int}
val checkFormula :
- {maxChecks : int} -> model -> Metis.Formula.formula -> {T : int, F : int}
+ {maxChecks : int option} -> model -> Metis.Formula.formula -> {T : int, F : int}
val checkLiteral :
- {maxChecks : int} -> model -> Metis.Literal.literal -> {T : int, F : int}
+ {maxChecks : int option} -> model -> Metis.Literal.literal -> {T : int, F : int}
val checkClause :
- {maxChecks : int} -> model -> Metis.Thm.clause -> {T : int, F : int}
+ {maxChecks : int option} -> model -> Metis.Thm.clause -> {T : int, F : int}
+
+(* ------------------------------------------------------------------------- *)
+(* Updating the model. *)
+(* ------------------------------------------------------------------------- *)
+
+val updateFunction :
+ model -> (Metis.Term.functionName * element list) * element -> unit
+
+val updateRelation :
+ model -> (Metis.Atom.relationName * element list) * bool -> unit
+
+(* ------------------------------------------------------------------------- *)
+(* Choosing a random perturbation to make a formula true in the model. *)
+(* ------------------------------------------------------------------------- *)
+
+val perturbTerm : model -> valuation -> Metis.Term.term * element list -> unit
+
+val perturbAtom : model -> valuation -> Metis.Atom.atom * bool -> unit
+
+val perturbLiteral : model -> valuation -> Metis.Literal.literal -> unit
+
+val perturbClause : model -> valuation -> Metis.Thm.clause -> unit
+
+(* ------------------------------------------------------------------------- *)
+(* Pretty printing. *)
+(* ------------------------------------------------------------------------- *)
+
+val pp : model Metis.Print.pp
end
@@ -11493,7 +15691,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -11502,7 +15700,7 @@
(* ========================================================================= *)
(* RANDOM FINITE MODELS *)
-(* Copyright (c) 2003-2007 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2003 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Model :> Model =
@@ -11511,378 +15709,912 @@
open Useful;
(* ------------------------------------------------------------------------- *)
+(* Constants. *)
+(* ------------------------------------------------------------------------- *)
+
+val maxSpace = 1000;
+
+(* ------------------------------------------------------------------------- *)
(* 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
+val multInt =
+ case Int.maxInt of
+ NONE => (fn x => fn y => SOME (x * y))
+ | SOME m =>
+ let
+ val m = Real.floor (Math.sqrt (Real.fromInt m))
+ in
+ fn x => fn y => if x <= m andalso y <= m then SOME (x * y) else NONE
+ end;
+
+local
+ fun iexp x y acc =
+ if y mod 2 = 0 then iexp' x y acc
+ else
+ case multInt acc x of
+ SOME acc => iexp' x y acc
+ | NONE => NONE
+
+ and iexp' x y acc =
+ if y = 1 then SOME acc
+ else
+ let
+ val y = y div 2
+ in
+ case multInt x x of
+ SOME x => iexp x y acc
+ | NONE => NONE
+ end;
+in
+ fun expInt x y =
+ if y <= 1 then
+ if y = 0 then SOME 1
+ else if y = 1 then SOME x
+ else raise Bug "expInt: negative exponent"
+ else if x <= 1 then
+ if 0 <= x then SOME x
+ else raise Bug "expInt: negative exponand"
+ else iexp x y 1;
+end;
+
+fun boolToInt true = 1
+ | boolToInt false = 0;
+
+fun intToBool 1 = true
+ | intToBool 0 = false
+ | intToBool _ = raise Bug "Model.intToBool";
+
+fun minMaxInterval i j = interval i (1 + j - i);
+
+(* ------------------------------------------------------------------------- *)
+(* Model size. *)
+(* ------------------------------------------------------------------------- *)
+
+type size = {size : int};
+
+(* ------------------------------------------------------------------------- *)
+(* A model of size N has integer elements 0...N-1. *)
+(* ------------------------------------------------------------------------- *)
+
+type element = int;
+
+val zeroElement = 0;
+
+fun incrementElement {size = N} i =
+ let
+ val i = i + 1
+ in
+ if i = N then NONE else SOME i
+ end;
+
+fun elementListSpace {size = N} arity =
+ case expInt N arity 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))
+ | s as SOME m => if m <= maxSpace then s else NONE;
+
+fun elementListIndex {size = N} =
+ let
+ fun f acc elts =
+ case elts of
+ [] => acc
+ | elt :: elts => f (N * acc + elt) elts
+ in
+ f 0
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}
+(* ------------------------------------------------------------------------- *)
+
+type fixedFunction = size -> element list -> element option;
+
+type fixedRelation = size -> element list -> bool option;
+
+datatype fixed =
+ Fixed of
+ {functions : fixedFunction NameArityMap.map,
+ relations : fixedRelation NameArityMap.map};
+
+val uselessFixedFunction : fixedFunction = K (K NONE);
+
+val uselessFixedRelation : fixedRelation = K (K NONE);
+
+val emptyFunctions : fixedFunction NameArityMap.map = NameArityMap.new ();
+
+val emptyRelations : fixedRelation NameArityMap.map = NameArityMap.new ();
+
+fun fixed0 f sz elts =
+ case elts of
+ [] => f sz
+ | _ => raise Bug "Model.fixed0: wrong arity";
+
+fun fixed1 f sz elts =
+ case elts of
+ [x] => f sz x
+ | _ => raise Bug "Model.fixed1: wrong arity";
+
+fun fixed2 f sz elts =
+ case elts of
+ [x,y] => f sz x y
+ | _ => raise Bug "Model.fixed2: wrong arity";
+
+val emptyFixed =
+ let
+ val fns = emptyFunctions
+ and rels = emptyRelations
+ in
+ Fixed
+ {functions = fns,
+ relations = rels}
+ end;
+
+fun peekFunctionFixed fix name_arity =
+ let
+ val Fixed {functions = fns, ...} = fix
+ in
+ NameArityMap.peek fns name_arity
+ end;
+
+fun peekRelationFixed fix name_arity =
+ let
+ val Fixed {relations = rels, ...} = fix
+ in
+ NameArityMap.peek rels name_arity
+ end;
+
+fun getFunctionFixed fix name_arity =
+ case peekFunctionFixed fix name_arity of
+ SOME f => f
+ | NONE => uselessFixedFunction;
+
+fun getRelationFixed fix name_arity =
+ case peekRelationFixed fix name_arity of
+ SOME rel => rel
+ | NONE => uselessFixedRelation;
+
+fun insertFunctionFixed fix name_arity_fn =
+ let
+ val Fixed {functions = fns, relations = rels} = fix
+
+ val fns = NameArityMap.insert fns name_arity_fn
+ in
+ Fixed
+ {functions = fns,
+ relations = rels}
+ end;
+
+fun insertRelationFixed fix name_arity_rel =
+ let
+ val Fixed {functions = fns, relations = rels} = fix
+
+ val rels = NameArityMap.insert rels name_arity_rel
+ in
+ Fixed
+ {functions = fns,
+ relations = rels}
+ end;
+
+local
+ fun union _ = raise Bug "Model.unionFixed: nameArity clash";
+in
+ fun unionFixed fix1 fix2 =
+ let
+ val Fixed {functions = fns1, relations = rels1} = fix1
+ and Fixed {functions = fns2, relations = rels2} = fix2
+
+ val fns = NameArityMap.union union fns1 fns2
+
+ val rels = NameArityMap.union union rels1 rels2
+ in
+ Fixed
+ {functions = fns,
+ relations = rels}
+ end;
+end;
+
+val unionListFixed =
+ let
+ fun union (fix,acc) = unionFixed acc fix
+ in
+ List.foldl union emptyFixed
+ end;
+
+local
+ fun hasTypeFn _ elts =
+ case elts of
+ [x,_] => SOME x
+ | _ => raise Bug "Model.hasTypeFn: wrong arity";
+
+ fun eqRel _ elts =
+ case elts of
+ [x,y] => SOME (x = y)
+ | _ => raise Bug "Model.eqRel: wrong arity";
+in
+ val basicFixed =
+ let
+ val fns = NameArityMap.singleton (Term.hasTypeFunction,hasTypeFn)
+
+ val rels = NameArityMap.singleton (Atom.eqRelation,eqRel)
+ in
+ Fixed
+ {functions = fns,
+ relations = rels}
+ end;
+end;
+
+(* ------------------------------------------------------------------------- *)
+(* Renaming fixed model parts. *)
+(* ------------------------------------------------------------------------- *)
+
+type fixedMap =
+ {functionMap : Name.name NameArityMap.map,
+ relationMap : Name.name NameArityMap.map};
+
+fun mapFixed fixMap fix =
+ let
+ val {functionMap = fnMap, relationMap = relMap} = fixMap
+ and Fixed {functions = fns, relations = rels} = fix
+
+ val fns = NameArityMap.compose fnMap fns
+
+ val rels = NameArityMap.compose relMap rels
+ in
+ Fixed
+ {functions = fns,
+ relations = rels}
+ end;
+
+local
+ fun mkEntry tag (na,n) = (tag,na,n);
+
+ fun mkList tag m = map (mkEntry tag) (NameArityMap.toList m);
+
+ fun ppEntry (tag,source_arity,target) =
+ Print.blockProgram Print.Inconsistent 2
+ [Print.addString tag,
+ Print.addBreak 1,
+ NameArity.pp source_arity,
+ Print.addString " ->",
+ Print.addBreak 1,
+ Name.pp target];
+in
+ fun ppFixedMap fixMap =
+ let
+ val {functionMap = fnMap, relationMap = relMap} = fixMap
+ in
+ case mkList "function" fnMap @ mkList "relation" relMap of
+ [] => Print.skip
+ | entry :: entries =>
+ Print.blockProgram Print.Consistent 0
+ (ppEntry entry ::
+ map (Print.sequence Print.addNewline o ppEntry) entries)
+ end;
+end;
+
+(* ------------------------------------------------------------------------- *)
+(* Standard fixed model parts. *)
+(* ------------------------------------------------------------------------- *)
+
+(* Projections *)
+
+val projectionMin = 1
+and projectionMax = 9;
+
+val projectionList = minMaxInterval projectionMin projectionMax;
+
+fun projectionName i =
+ let
+ val _ = projectionMin <= i orelse
+ raise Bug "Model.projectionName: less than projectionMin"
+
+ val _ = i <= projectionMax orelse
+ raise Bug "Model.projectionName: greater than projectionMax"
+ in
+ Name.fromString ("project" ^ Int.toString i)
+ end;
+
+fun projectionFn i _ elts = SOME (List.nth (elts, i - 1));
+
+fun arityProjectionFixed arity =
+ let
+ fun mkProj i = ((projectionName i, arity), projectionFn i)
+
+ fun addProj i acc =
+ if i > arity then acc
+ else addProj (i + 1) (NameArityMap.insert acc (mkProj i))
+
+ val fns = addProj projectionMin emptyFunctions
+
+ val rels = emptyRelations
+ in
+ Fixed
+ {functions = fns,
+ relations = rels}
+ end;
+
+val projectionFixed =
+ unionListFixed (map arityProjectionFixed projectionList);
+
+(* Arithmetic *)
+
+val numeralMin = ~100
+and numeralMax = 100;
+
+val numeralList = minMaxInterval numeralMin numeralMax;
+
+fun numeralName i =
+ let
+ val _ = numeralMin <= i orelse
+ raise Bug "Model.numeralName: less than numeralMin"
+
+ val _ = i <= numeralMax orelse
+ raise Bug "Model.numeralName: greater than numeralMax"
+
+ val s = if i < 0 then "negative" ^ Int.toString (~i) else Int.toString i
+ in
+ Name.fromString s
+ end;
+
+val addName = Name.fromString "+"
+and divName = Name.fromString "div"
+and dividesName = Name.fromString "divides"
+and evenName = Name.fromString "even"
+and expName = Name.fromString "exp"
+and geName = Name.fromString ">="
+and gtName = Name.fromString ">"
+and isZeroName = Name.fromString "isZero"
+and leName = Name.fromString "<="
+and ltName = Name.fromString "<"
+and modName = Name.fromString "mod"
+and multName = Name.fromString "*"
+and negName = Name.fromString "~"
+and oddName = Name.fromString "odd"
+and preName = Name.fromString "pre"
+and subName = Name.fromString "-"
+and sucName = Name.fromString "suc";
+
+local
+ (* Support *)
+
+ fun modN {size = N} x = x mod N;
+
+ fun oneN sz = modN sz 1;
+
+ fun multN sz (x,y) = modN sz (x * y);
+
+ (* Functions *)
+
+ fun numeralFn i sz = SOME (modN sz i);
+
+ fun addFn sz x y = SOME (modN sz (x + y));
+
+ fun divFn {size = N} x y =
+ let
+ val y = if y = 0 then N else y
+ in
+ SOME (x div y)
+ end;
+
+ fun expFn sz x y = SOME (exp (multN sz) x y (oneN sz));
+
+ fun modFn {size = N} x y =
+ let
+ val y = if y = 0 then N else y
+ in
+ SOME (x mod y)
+ end;
+
+ fun multFn sz x y = SOME (multN sz (x,y));
+
+ fun negFn {size = N} x = SOME (if x = 0 then 0 else N - x);
+
+ fun preFn {size = N} x = SOME (if x = 0 then N - 1 else x - 1);
+
+ fun subFn {size = N} x y = SOME (if x < y then N + x - y else x - y);
+
+ fun sucFn {size = N} x = SOME (if x = N - 1 then 0 else x + 1);
+
+ (* Relations *)
+
+ fun dividesRel _ x y = SOME (divides x y);
+
+ fun evenRel _ x = SOME (x mod 2 = 0);
+
+ fun geRel _ x y = SOME (x >= y);
+
+ fun gtRel _ x y = SOME (x > y);
+
+ fun isZeroRel _ x = SOME (x = 0);
+
+ fun leRel _ x y = SOME (x <= y);
+
+ fun ltRel _ x y = SOME (x < y);
+
+ fun oddRel _ x = SOME (x mod 2 = 1);
+in
+ val modularFixed =
+ let
+ val fns =
+ NameArityMap.fromList
+ (map (fn i => ((numeralName i,0), fixed0 (numeralFn i)))
+ numeralList @
+ [((addName,2), fixed2 addFn),
+ ((divName,2), fixed2 divFn),
+ ((expName,2), fixed2 expFn),
+ ((modName,2), fixed2 modFn),
+ ((multName,2), fixed2 multFn),
+ ((negName,1), fixed1 negFn),
+ ((preName,1), fixed1 preFn),
+ ((subName,2), fixed2 subFn),
+ ((sucName,1), fixed1 sucFn)])
+
+ val rels =
+ NameArityMap.fromList
+ [((dividesName,2), fixed2 dividesRel),
+ ((evenName,1), fixed1 evenRel),
+ ((geName,2), fixed2 geRel),
+ ((gtName,2), fixed2 gtRel),
+ ((isZeroName,1), fixed1 isZeroRel),
+ ((leName,2), fixed2 leRel),
+ ((ltName,2), fixed2 ltRel),
+ ((oddName,1), fixed1 oddRel)]
+ in
+ Fixed
+ {functions = fns,
+ relations = rels}
+ end;
+end;
+
+local
+ (* Support *)
+
+ fun cutN {size = N} x = if x >= N then N - 1 else x;
+
+ fun oneN sz = cutN sz 1;
+
+ fun multN sz (x,y) = cutN sz (x * y);
+
+ (* Functions *)
+
+ fun numeralFn i sz = if i < 0 then NONE else SOME (cutN sz i);
+
+ fun addFn sz x y = SOME (cutN sz (x + y));
+
+ fun divFn _ x y = if y = 0 then NONE else SOME (x div y);
+
+ fun expFn sz x y = SOME (exp (multN sz) x y (oneN sz));
+
+ fun modFn {size = N} x y =
+ if y = 0 orelse x = N - 1 then NONE else SOME (x mod y);
+
+ fun multFn sz x y = SOME (multN sz (x,y));
+
+ fun negFn _ x = if x = 0 then SOME 0 else NONE;
+
+ fun preFn _ x = if x = 0 then NONE else SOME (x - 1);
+
+ fun subFn {size = N} x y =
+ if y = 0 then SOME x
+ else if x = N - 1 orelse x < y then NONE
+ else SOME (x - y);
+
+ fun sucFn sz x = SOME (cutN sz (x + 1));
+
+ (* Relations *)
+
+ fun dividesRel {size = N} x y =
+ if x = 1 orelse y = 0 then SOME true
+ else if x = 0 then SOME false
+ else if y = N - 1 then NONE
+ else SOME (divides x y);
+
+ fun evenRel {size = N} x =
+ if x = N - 1 then NONE else SOME (x mod 2 = 0);
+
+ fun geRel {size = N} y x =
+ if x = N - 1 then if y = N - 1 then NONE else SOME false
+ else if y = N - 1 then SOME true else SOME (x <= y);
+
+ fun gtRel {size = N} y x =
+ if x = N - 1 then if y = N - 1 then NONE else SOME false
+ else if y = N - 1 then SOME true else SOME (x < y);
+
+ fun isZeroRel _ x = SOME (x = 0);
+
+ fun leRel {size = N} x y =
+ if x = N - 1 then if y = N - 1 then NONE else SOME false
+ else if y = N - 1 then SOME true else SOME (x <= y);
+
+ fun ltRel {size = N} x y =
+ if x = N - 1 then if y = N - 1 then NONE else SOME false
+ else if y = N - 1 then SOME true else SOME (x < y);
+
+ fun oddRel {size = N} x =
+ if x = N - 1 then NONE else SOME (x mod 2 = 1);
+in
+ val overflowFixed =
+ let
+ val fns =
+ NameArityMap.fromList
+ (map (fn i => ((numeralName i,0), fixed0 (numeralFn i)))
+ numeralList @
+ [((addName,2), fixed2 addFn),
+ ((divName,2), fixed2 divFn),
+ ((expName,2), fixed2 expFn),
+ ((modName,2), fixed2 modFn),
+ ((multName,2), fixed2 multFn),
+ ((negName,1), fixed1 negFn),
+ ((preName,1), fixed1 preFn),
+ ((subName,2), fixed2 subFn),
+ ((sucName,1), fixed1 sucFn)])
+
+ val rels =
+ NameArityMap.fromList
+ [((dividesName,2), fixed2 dividesRel),
+ ((evenName,1), fixed1 evenRel),
+ ((geName,2), fixed2 geRel),
+ ((gtName,2), fixed2 gtRel),
+ ((isZeroName,1), fixed1 isZeroRel),
+ ((leName,2), fixed2 leRel),
+ ((ltName,2), fixed2 ltRel),
+ ((oddName,1), fixed1 oddRel)]
+ in
+ Fixed
+ {functions = fns,
+ relations = rels}
+ end;
+end;
+
+(* Sets *)
+
+val cardName = Name.fromString "card"
+and complementName = Name.fromString "complement"
+and differenceName = Name.fromString "difference"
+and emptyName = Name.fromString "empty"
+and memberName = Name.fromString "member"
+and insertName = Name.fromString "insert"
+and intersectName = Name.fromString "intersect"
+and singletonName = Name.fromString "singleton"
+and subsetName = Name.fromString "subset"
+and symmetricDifferenceName = Name.fromString "symmetricDifference"
+and unionName = Name.fromString "union"
+and universeName = Name.fromString "universe";
+
+local
+ (* Support *)
+
+ fun eltN {size = N} =
+ let
+ fun f 0 acc = acc
+ | f x acc = f (x div 2) (acc + 1)
+ in
+ f N ~1
+ end;
+
+ fun posN i = Word.<< (0w1, Word.fromInt i);
+
+ fun univN sz = Word.- (posN (eltN sz), 0w1);
+
+ fun setN sz x = Word.andb (Word.fromInt x, univN sz);
+
+ (* Functions *)
+
+ fun cardFn sz x =
+ let
+ fun f 0w0 acc = acc
+ | f s acc =
+ let
+ val acc = if Word.andb (s,0w1) = 0w0 then acc else acc + 1
+ in
+ f (Word.>> (s,0w1)) acc
+ end
+ in
+ SOME (f (setN sz x) 0)
+ end;
+
+ fun complementFn sz x = SOME (Word.toInt (Word.xorb (univN sz, setN sz x)));
+
+ fun differenceFn sz x y =
+ let
+ val x = setN sz x
+ and y = setN sz y
+ in
+ SOME (Word.toInt (Word.andb (x, Word.notb y)))
+ end;
+
+ fun emptyFn _ = SOME 0;
+
+ fun insertFn sz x y =
+ let
+ val x = x mod eltN sz
+ and y = setN sz y
+ in
+ SOME (Word.toInt (Word.orb (posN x, y)))
+ end;
+
+ fun intersectFn sz x y =
+ SOME (Word.toInt (Word.andb (setN sz x, setN sz y)));
+
+ fun singletonFn sz x =
+ let
+ val x = x mod eltN sz
+ in
+ SOME (Word.toInt (posN x))
+ end;
+
+ fun symmetricDifferenceFn sz x y =
+ let
+ val x = setN sz x
+ and y = setN sz y
+ in
+ SOME (Word.toInt (Word.xorb (x,y)))
+ end;
+
+ fun unionFn sz x y =
+ SOME (Word.toInt (Word.orb (setN sz x, setN sz y)));
+
+ fun universeFn sz = SOME (Word.toInt (univN sz));
+
+ (* Relations *)
+
+ fun memberRel sz x y =
+ let
+ val x = x mod eltN sz
+ and y = setN sz y
+ in
+ SOME (Word.andb (posN x, y) <> 0w0)
+ end;
+
+ fun subsetRel sz x y =
+ let
+ val x = setN sz x
+ and y = setN sz y
+ in
+ SOME (Word.andb (x, Word.notb y) = 0w0)
+ end;
+in
+ val setFixed =
+ let
+ val fns =
+ NameArityMap.fromList
+ [((cardName,1), fixed1 cardFn),
+ ((complementName,1), fixed1 complementFn),
+ ((differenceName,2), fixed2 differenceFn),
+ ((emptyName,0), fixed0 emptyFn),
+ ((insertName,2), fixed2 insertFn),
+ ((intersectName,2), fixed2 intersectFn),
+ ((singletonName,1), fixed1 singletonFn),
+ ((symmetricDifferenceName,2), fixed2 symmetricDifferenceFn),
+ ((unionName,2), fixed2 unionFn),
+ ((universeName,0), fixed0 universeFn)]
+
+ val rels =
+ NameArityMap.fromList
+ [((memberName,2), fixed2 memberRel),
+ ((subsetName,2), fixed2 subsetRel)]
+ in
+ Fixed
+ {functions = fns,
+ relations = rels}
+ end;
+end;
+
+(* Lists *)
+
+val appendName = Name.fromString "@"
+and consName = Name.fromString "::"
+and lengthName = Name.fromString "length"
+and nilName = Name.fromString "nil"
+and nullName = Name.fromString "null"
+and tailName = Name.fromString "tail";
+
+local
+ val baseFix =
+ let
+ val fix = unionFixed projectionFixed overflowFixed
+
+ val sucFn = getFunctionFixed fix (sucName,1)
+
+ fun suc2Fn sz _ x = sucFn sz [x]
+ in
+ insertFunctionFixed fix ((sucName,2), fixed2 suc2Fn)
+ end;
+
+ val fixMap =
+ {functionMap = NameArityMap.fromList
+ [((appendName,2),addName),
+ ((consName,2),sucName),
+ ((lengthName,1), projectionName 1),
+ ((nilName,0), numeralName 0),
+ ((tailName,1),preName)],
+ relationMap = NameArityMap.fromList
+ [((nullName,1),isZeroName)]};
+
+in
+ val listFixed = mapFixed fixMap baseFix;
+end;
+
+(* ------------------------------------------------------------------------- *)
+(* Valuations. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype valuation = Valuation of element NameMap.map;
+
+val emptyValuation = Valuation (NameMap.new ());
+
+fun insertValuation (Valuation m) v_i = Valuation (NameMap.insert m v_i);
+
+fun peekValuation (Valuation m) v = NameMap.peek m v;
+
+fun constantValuation i =
+ let
+ fun add (v,V) = insertValuation V (v,i)
+ in
+ NameSet.foldl add emptyValuation
+ end;
+
+val zeroValuation = constantValuation zeroElement;
+
+fun getValuation V v =
+ case peekValuation V v of
+ SOME i => i
+ | NONE => raise Error "Model.getValuation: incomplete valuation";
+
+fun randomValuation {size = N} vs =
+ let
+ fun f (v,V) = insertValuation V (v, Portable.randomInt N)
+ in
+ NameSet.foldl f emptyValuation vs
+ end;
+
+fun incrementValuation N vars =
+ let
+ fun inc vs V =
+ case vs of
+ [] => NONE
+ | v :: vs =>
+ let
+ val (carry,i) =
+ case incrementElement N (getValuation V v) of
+ SOME i => (false,i)
+ | NONE => (true,zeroElement)
+
+ val V = insertValuation V (v,i)
+ in
+ if carry then inc vs V else SOME V
+ end
+ in
+ inc (NameSet.toList vars)
+ end;
+
+fun foldValuation N vars f =
+ let
+ val inc = incrementValuation N vars
+
+ fun fold V acc =
+ let
+ val acc = f (V,acc)
+ in
+ case inc V of
+ NONE => acc
+ | SOME V => fold V acc
+ end
+
+ val zero = zeroValuation vars
+ in
+ fold zero
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* A type of random finite mapping Z^n -> Z. *)
+(* ------------------------------------------------------------------------- *)
+
+val UNKNOWN = ~1;
+
+datatype table =
+ ForgetfulTable
+ | ArrayTable of int Array.array;
+
+fun newTable N arity =
+ case elementListSpace {size = N} arity of
+ NONE => ForgetfulTable
+ | SOME space => ArrayTable (Array.array (space,UNKNOWN));
+
+local
+ fun randomResult R = Portable.randomInt R;
+in
+ fun lookupTable N R table elts =
+ case table of
+ ForgetfulTable => randomResult R
+ | ArrayTable a =>
+ let
+ val i = elementListIndex {size = N} elts
+
+ val r = Array.sub (a,i)
+ in
+ if r <> UNKNOWN then r
+ else
+ let
+ val r = randomResult R
+
+ val () = Array.update (a,i,r)
+ in
+ r
+ end
+ end;
+end;
+
+fun updateTable N table (elts,r) =
+ case table of
+ ForgetfulTable => ()
+ | ArrayTable a =>
+ let
+ val i = elementListIndex {size = N} elts
+
+ val () = Array.update (a,i,r)
+ in
+ ()
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* A type of random finite mappings name * arity -> Z^arity -> Z. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype tables =
+ Tables of
+ {domainSize : int,
+ rangeSize : int,
+ tableMap : table NameArityMap.map Unsynchronized.ref};
+
+fun newTables N R =
+ Tables
+ {domainSize = N,
+ rangeSize = R,
+ tableMap = Unsynchronized.ref (NameArityMap.new ())};
+
+fun getTables tables n_a =
+ let
+ val Tables {domainSize = N, rangeSize = _, tableMap = tm} = tables
+
+ val Unsynchronized.ref m = tm
+ in
+ case NameArityMap.peek m n_a of
+ SOME t => t
+ | NONE =>
+ let
+ val (_,a) = n_a
+
+ val t = newTable N a
+
+ val m = NameArityMap.insert m (n_a,t)
+
+ val () = tm := m
+ in
+ t
+ end
+ end;
+
+fun lookupTables tables (n,elts) =
+ let
+ val Tables {domainSize = N, rangeSize = R, ...} = tables
+
+ val a = length elts
+
+ val table = getTables tables (n,a)
+ in
+ lookupTable N R table elts
+ end;
+
+fun updateTables tables ((n,elts),r) =
+ let
+ val Tables {domainSize = N, ...} = tables
+
+ val a = length elts
+
+ val table = getTables tables (n,a)
+ in
+ updateTable N table (elts,r)
end;
(* ------------------------------------------------------------------------- *)
@@ -11894,166 +16626,153 @@
datatype model =
Model of
{size : int,
- fixed : fixedModel,
- functions : (Term.functionName * int list, int) Map.map Unsynchronized.ref,
- relations : (Atom.relationName * int list, bool) Map.map Unsynchronized.ref};
-
-local
- fun cmp ((n1,l1),(n2,l2)) =
- case String.compare (n1,n2) of
- LESS => LESS
- | EQUAL => lexCompare Int.compare (l1,l2)
- | GREATER => GREATER;
-in
- fun new {size = N, fixed} =
+ fixedFunctions : (element list -> element option) NameArityMap.map,
+ fixedRelations : (element list -> bool option) NameArityMap.map,
+ randomFunctions : tables,
+ randomRelations : tables};
+
+fun new {size = N, fixed} =
+ let
+ val Fixed {functions = fns, relations = rels} = fixed
+
+ val fixFns = NameArityMap.transform (fn f => f {size = N}) fns
+ and fixRels = NameArityMap.transform (fn r => r {size = N}) rels
+
+ val rndFns = newTables N N
+ and rndRels = newTables N 2
+ in
Model
{size = N,
- fixed = fixed {size = N},
- functions = Unsynchronized.ref (Map.new cmp),
- relations = Unsynchronized.ref (Map.new cmp)};
-end;
-
-fun size (Model {size = s, ...}) = s;
-
-(* ------------------------------------------------------------------------- *)
-(* Valuations. *)
-(* ------------------------------------------------------------------------- *)
-
-type valuation = int NameMap.map;
-
-val valuationEmpty : valuation = NameMap.new ();
-
-fun valuationRandom {size = N} vs =
- let
- fun f (v,V) = NameMap.insert V (v, Portable.randomInt N)
- in
- NameSet.foldl f valuationEmpty vs
- end;
-
-fun valuationFold {size = N} vs f =
- let
- val vs = NameSet.toList vs
-
- fun inc [] _ = NONE
- | inc (v :: l) V =
- case NameMap.peek V v of
- NONE => raise Bug "Model.valuationFold"
- | SOME k =>
- let
- val k = if k = N - 1 then 0 else k + 1
- val V = NameMap.insert V (v,k)
- in
- if k = 0 then inc l V else SOME V
- end
-
- val zero = foldl (fn (v,V) => NameMap.insert V (v,0)) valuationEmpty vs
-
- fun fold V acc =
- let
- val acc = f (V,acc)
- in
- case inc vs V of NONE => acc | SOME V => fold V acc
- end
- in
- fold zero
- end;
+ fixedFunctions = fixFns,
+ fixedRelations = fixRels,
+ randomFunctions = rndFns,
+ randomRelations = rndRels}
+ end;
+
+fun size (Model {size = N, ...}) = N;
+
+fun peekFixedFunction M (n,elts) =
+ let
+ val Model {fixedFunctions = fixFns, ...} = M
+ in
+ case NameArityMap.peek fixFns (n, length elts) of
+ NONE => NONE
+ | SOME fixFn => fixFn elts
+ end;
+
+fun isFixedFunction M n_elts = Option.isSome (peekFixedFunction M n_elts);
+
+fun peekFixedRelation M (n,elts) =
+ let
+ val Model {fixedRelations = fixRels, ...} = M
+ in
+ case NameArityMap.peek fixRels (n, length elts) of
+ NONE => NONE
+ | SOME fixRel => fixRel elts
+ end;
+
+fun isFixedRelation M n_elts = Option.isSome (peekFixedRelation M n_elts);
+
+(* A default model *)
+
+val defaultSize = 8;
+
+val defaultFixed =
+ unionListFixed
+ [basicFixed,
+ projectionFixed,
+ modularFixed,
+ setFixed,
+ listFixed];
+
+val default = {size = defaultSize, fixed = defaultFixed};
+
+(* ------------------------------------------------------------------------- *)
+(* Taking apart terms to interpret them. *)
+(* ------------------------------------------------------------------------- *)
+
+fun destTerm tm =
+ case tm of
+ Term.Var _ => tm
+ | Term.Fn f_tms =>
+ case Term.stripApp tm of
+ (_,[]) => tm
+ | (v as Term.Var _, tms) => Term.Fn (Term.appName, v :: tms)
+ | (Term.Fn (f,tms), tms') => Term.Fn (f, tms @ tms');
(* ------------------------------------------------------------------------- *)
(* Interpreting terms and formulas in the model. *)
(* ------------------------------------------------------------------------- *)
+fun interpretFunction M n_elts =
+ case peekFixedFunction M n_elts of
+ SOME r => r
+ | NONE =>
+ let
+ val Model {randomFunctions = rndFns, ...} = M
+ in
+ lookupTables rndFns n_elts
+ end;
+
+fun interpretRelation M n_elts =
+ case peekFixedRelation M n_elts of
+ SOME r => r
+ | NONE =>
+ let
+ val Model {randomRelations = rndRels, ...} = M
+ in
+ intToBool (lookupTables rndRels n_elts)
+ end;
+
fun interpretTerm M V =
let
- val Model {size = N, fixed, functions, ...} = M
- val {functions = fixed_functions, ...} = fixed
-
- fun interpret (Term.Var v) =
- (case NameMap.peek V v of
- NONE => raise Error "Model.interpretTerm: incomplete valuation"
- | SOME i => i)
- | interpret (tm as Term.Fn f_tms) =
- let
- val (f,tms) =
- case Term.stripComb tm of
- (_,[]) => f_tms
- | (v as Term.Var _, tms) => (".", v :: tms)
- | (Term.Fn (f,tms), tms') => (f, tms @ tms')
- val elts = map interpret tms
- val f_elts = (f,elts)
- val Unsynchronized.ref funcs = functions
- in
- case Map.peek funcs f_elts of
- SOME k => k
- | NONE =>
- let
- val k =
- case fixed_functions f_elts of
- SOME k => k
- | NONE => Portable.randomInt N
-
- val () = functions := Map.insert funcs (f_elts,k)
- in
- k
- end
- end;
+ fun interpret tm =
+ case destTerm tm of
+ Term.Var v => getValuation V v
+ | Term.Fn (f,tms) => interpretFunction M (f, map interpret tms)
in
interpret
end;
fun interpretAtom M V (r,tms) =
- let
- val Model {fixed,relations,...} = M
- val {relations = fixed_relations, ...} = fixed
-
- val elts = map (interpretTerm M V) tms
- val r_elts = (r,elts)
- val Unsynchronized.ref rels = relations
- in
- case Map.peek rels r_elts of
- SOME b => b
- | NONE =>
- let
- val b =
- case fixed_relations r_elts of
- SOME b => b
- | NONE => Portable.randomBool ()
-
- val () = relations := Map.insert rels (r_elts,b)
- in
- b
- end
- end;
+ interpretRelation M (r, map (interpretTerm M V) tms);
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 =
+ val N = size M
+
+ fun interpret V fm =
+ case fm of
+ Formula.True => true
+ | Formula.False => false
+ | Formula.Atom atm => interpretAtom M V atm
+ | Formula.Not p => not (interpret V p)
+ | Formula.Or (p,q) => interpret V p orelse interpret V q
+ | Formula.And (p,q) => interpret V p andalso interpret V q
+ | Formula.Imp (p,q) => interpret V (Formula.Or (Formula.Not p, q))
+ | Formula.Iff (p,q) => interpret V p = interpret V q
+ | Formula.Forall (v,p) => interpret' V p v N
+ | Formula.Exists (v,p) =>
+ interpret V (Formula.Not (Formula.Forall (v, Formula.Not p)))
+
+ and interpret' V fm v i =
+ i = 0 orelse
let
val i = i - 1
- val V' = NameMap.insert V (v,i)
- in
- interpret V' p andalso interpret' V v p i
+ val V' = insertValuation V (v,i)
+ in
+ interpret V' fm andalso interpret' V fm v 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 interpretLiteral M V (pol,atm) =
+ let
+ val b = interpretAtom M V atm
+ in
+ if pol then b else not b
+ end;
fun interpretClause M V cl = LiteralSet.exists (interpretLiteral M V) cl;
@@ -12062,33 +16781,199 @@
(* 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;
+fun check interpret {maxChecks} M fv x =
+ let
+ val N = size M
+
+ fun score (V,{T,F}) =
+ if interpret M V x then {T = T + 1, F = F} else {T = T, F = F + 1}
+
+ fun randomCheck acc = score (randomValuation {size = N} fv, acc)
+
+ val maxChecks =
+ case maxChecks of
+ NONE => maxChecks
+ | SOME m =>
+ case expInt N (NameSet.size fv) of
+ SOME n => if n <= m then NONE else maxChecks
+ | NONE => maxChecks
+ in
+ case maxChecks of
+ SOME m => funpow m randomCheck {T = 0, F = 0}
+ | NONE => foldValuation {size = N} fv score {T = 0, F = 0}
+ end;
+
+fun checkAtom maxChecks M atm =
+ check interpretAtom maxChecks M (Atom.freeVars atm) atm;
+
+fun checkFormula maxChecks M fm =
+ check interpretFormula maxChecks M (Formula.freeVars fm) fm;
+
+fun checkLiteral maxChecks M lit =
+ check interpretLiteral maxChecks M (Literal.freeVars lit) lit;
+
+fun checkClause maxChecks M cl =
+ check interpretClause maxChecks M (LiteralSet.freeVars cl) cl;
+
+(* ------------------------------------------------------------------------- *)
+(* Updating the model. *)
+(* ------------------------------------------------------------------------- *)
+
+fun updateFunction M func_elts_elt =
+ let
+ val Model {randomFunctions = rndFns, ...} = M
+
+ val () = updateTables rndFns func_elts_elt
+ in
+ ()
+ end;
+
+fun updateRelation M (rel_elts,pol) =
+ let
+ val Model {randomRelations = rndRels, ...} = M
+
+ val () = updateTables rndRels (rel_elts, boolToInt pol)
+ in
+ ()
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* A type of terms with interpretations embedded in the subterms. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype modelTerm =
+ ModelVar
+ | ModelFn of Term.functionName * modelTerm list * int list;
+
+fun modelTerm M V =
+ let
+ fun modelTm tm =
+ case destTerm tm of
+ Term.Var v => (ModelVar, getValuation V v)
+ | Term.Fn (f,tms) =>
+ let
+ val (tms,xs) = unzip (map modelTm tms)
+ in
+ (ModelFn (f,tms,xs), interpretFunction M (f,xs))
+ end
+ in
+ modelTm
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Perturbing the model. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype perturbation =
+ FunctionPerturbation of (Term.functionName * element list) * element
+ | RelationPerturbation of (Atom.relationName * element list) * bool;
+
+fun perturb M pert =
+ case pert of
+ FunctionPerturbation func_elts_elt => updateFunction M func_elts_elt
+ | RelationPerturbation rel_elts_pol => updateRelation M rel_elts_pol;
+
+local
+ fun pertTerm _ [] _ acc = acc
+ | pertTerm M target tm acc =
+ case tm of
+ ModelVar => acc
+ | ModelFn (func,tms,xs) =>
+ let
+ fun onTarget ys = mem (interpretFunction M (func,ys)) target
+
+ val func_xs = (func,xs)
+
+ val acc =
+ if isFixedFunction M func_xs then acc
+ else
+ let
+ fun add (y,acc) = FunctionPerturbation (func_xs,y) :: acc
+ in
+ foldl add acc target
+ end
+ in
+ pertTerms M onTarget tms xs acc
+ end
+
+ and pertTerms M onTarget =
+ let
+ val N = size M
+
+ fun filterElements pred =
+ let
+ fun filt 0 acc = acc
+ | filt i acc =
+ let
+ val i = i - 1
+ val acc = if pred i then i :: acc else acc
+ in
+ filt i acc
+ end
+ in
+ filt N []
+ end
+
+ fun pert _ [] [] acc = acc
+ | pert ys (tm :: tms) (x :: xs) acc =
+ let
+ fun pred y =
+ y <> x andalso onTarget (List.revAppend (ys, y :: xs))
+
+ val target = filterElements pred
+
+ val acc = pertTerm M target tm acc
+ in
+ pert (x :: ys) tms xs acc
+ end
+ | pert _ _ _ _ = raise Bug "Model.pertTerms.pert"
+ in
+ pert []
+ end;
+
+ fun pertAtom M V target (rel,tms) acc =
+ let
+ fun onTarget ys = interpretRelation M (rel,ys) = target
+
+ val (tms,xs) = unzip (map (modelTerm M V) tms)
+
+ val rel_xs = (rel,xs)
+
+ val acc =
+ if isFixedRelation M rel_xs then acc
+ else RelationPerturbation (rel_xs,target) :: acc
+ in
+ pertTerms M onTarget tms xs acc
+ end;
+
+ fun pertLiteral M V ((pol,atm),acc) = pertAtom M V pol atm acc;
+
+ fun pertClause M V cl acc = LiteralSet.foldl (pertLiteral M V) acc cl;
+
+ fun pickPerturb M perts =
+ if null perts then ()
+ else perturb M (List.nth (perts, Portable.randomInt (length perts)));
+in
+ fun perturbTerm M V (tm,target) =
+ pickPerturb M (pertTerm M target (fst (modelTerm M V tm)) []);
+
+ fun perturbAtom M V (atm,target) =
+ pickPerturb M (pertAtom M V target atm []);
+
+ fun perturbLiteral M V lit = pickPerturb M (pertLiteral M V (lit,[]));
+
+ fun perturbClause M V cl = pickPerturb M (pertClause M V cl []);
+end;
+
+(* ------------------------------------------------------------------------- *)
+(* Pretty printing. *)
+(* ------------------------------------------------------------------------- *)
+
+fun pp M =
+ Print.program
+ [Print.addString "Model{",
+ Print.ppInt (size M),
+ Print.addString "}"];
end
end;
@@ -12096,8 +16981,8 @@
(**** Original file: Problem.sig ****)
(* ========================================================================= *)
-(* SOME SAMPLE PROBLEMS TO TEST PROOF PROCEDURES *)
-(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
+(* CNF PROBLEMS *)
+(* Copyright (c) 2001-2008 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Problem =
@@ -12107,16 +16992,22 @@
(* Problems. *)
(* ------------------------------------------------------------------------- *)
-type problem = Metis.Thm.clause list
+type problem =
+ {axioms : Metis.Thm.clause list,
+ conjecture : 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 freeVars : problem -> Metis.NameSet.set
+
+val toClauses : problem -> Metis.Thm.clause list
+
+val toFormula : problem -> Metis.Formula.formula
+
+val toGoal : problem -> Metis.Formula.formula
val toString : problem -> string
@@ -12157,7 +17048,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -12165,8 +17056,8 @@
val foldr = List.foldr;
(* ========================================================================= *)
-(* SOME SAMPLE PROBLEMS TO TEST PROOF PROCEDURES *)
-(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
+(* CNF PROBLEMS *)
+(* Copyright (c) 2001-2008 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Problem :> Problem =
@@ -12178,83 +17069,56 @@
(* 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);
+type problem =
+ {axioms : Thm.clause list,
+ conjecture : Thm.clause list};
+
+fun toClauses {axioms,conjecture} = axioms @ conjecture;
+
+fun size prob =
+ let
+ fun lits (cl,n) = n + LiteralSet.size cl
+
+ fun syms (cl,n) = n + LiteralSet.symbols cl
+
+ fun typedSyms (cl,n) = n + LiteralSet.typedSymbols cl
+
+ val cls = toClauses prob
+ in
+ {clauses = length cls,
+ literals = foldl lits 0 cls,
+ symbols = foldl syms 0 cls,
+ typedSymbols = foldl typedSyms 0 cls}
+ end;
+
+fun freeVars {axioms,conjecture} =
+ NameSet.union
+ (LiteralSet.freeVarsList axioms)
+ (LiteralSet.freeVarsList conjecture);
+
+local
+ fun clauseToFormula cl =
+ Formula.listMkDisj (LiteralSet.transform Literal.toFormula cl);
+in
+ fun toFormula prob =
+ Formula.listMkConj (map clauseToFormula (toClauses prob));
+
+ fun toGoal {axioms,conjecture} =
+ let
+ val clToFm = Formula.generalize o clauseToFormula
+ val clsToFm = Formula.listMkConj o map clToFm
+
+ val fm = Formula.False
+ val fm =
+ if null conjecture then fm
+ else Formula.Imp (clsToFm conjecture, fm)
+ val fm = Formula.Imp (clsToFm axioms, fm)
+ in
+ fm
+ end;
+end;
+
+fun toString prob = Formula.toString (toFormula prob);
(* ------------------------------------------------------------------------- *)
(* Categorizing problems. *)
@@ -12283,8 +17147,10 @@
equality : equality,
horn : horn};
-fun categorize cls =
- let
+fun categorize prob =
+ let
+ val cls = toClauses prob
+
val rels =
let
fun f (cl,set) = NameAritySet.union set (LiteralSet.relations cl)
@@ -12355,7 +17221,7 @@
(* ========================================================================= *)
(* MATCHING AND UNIFICATION FOR SETS OF FIRST ORDER LOGIC TERMS *)
-(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature TermNet =
@@ -12387,7 +17253,7 @@
val toString : 'a termNet -> string
-val pp : 'a Metis.Parser.pp -> 'a termNet Metis.Parser.pp
+val pp : 'a Metis.Print.pp -> 'a termNet Metis.Print.pp
(* ------------------------------------------------------------------------- *)
(* Matching and unification queries. *)
@@ -12408,7 +17274,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -12417,7 +17283,7 @@
(* ========================================================================= *)
(* MATCHING AND UNIFICATION FOR SETS OF FIRST ORDER LOGIC TERMS *)
-(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure TermNet :> TermNet =
@@ -12426,29 +17292,65 @@
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);
+(* Anonymous variables. *)
+(* ------------------------------------------------------------------------- *)
+
+val anonymousName = Name.fromString "_";
+val anonymousVar = Term.Var anonymousName;
+
+(* ------------------------------------------------------------------------- *)
+(* Quotient terms. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype qterm =
+ Var
+ | Fn of NameArity.nameArity * qterm list;
+
+local
+ fun cmp [] = EQUAL
+ | cmp (q1_q2 :: qs) =
+ if Portable.pointerEqual q1_q2 then cmp qs
+ else
+ case q1_q2 of
+ (Var,Var) => EQUAL
+ | (Var, Fn _) => LESS
+ | (Fn _, Var) => GREATER
+ | (Fn f1, Fn f2) => fnCmp f1 f2 qs
+
+ and fnCmp (n1,q1) (n2,q2) qs =
+ case NameArity.compare (n1,n2) of
+ LESS => LESS
+ | EQUAL => cmp (zip q1 q2 @ qs)
+ | GREATER => GREATER;
+in
+ fun compareQterm q1_q2 = cmp [q1_q2];
+
+ fun compareFnQterm (f1,f2) = fnCmp f1 f2 [];
+end;
+
+fun equalQterm q1 q2 = compareQterm (q1,q2) = EQUAL;
+
+fun equalFnQterm f1 f2 = compareFnQterm (f1,f2) = EQUAL;
+
+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);
+ | qm ((Var,_) :: rest) = qm rest
+ | qm ((Fn _, Var) :: _) = false
+ | qm ((Fn (f,a), Fn (g,b)) :: rest) =
+ NameArity.equal 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);
+ | qm ((Var,_) :: rest) = qm rest
+ | qm ((Fn _, Term.Var _) :: _) = false
+ | qm ((Fn ((f,n),a), Term.Fn (g,b)) :: rest) =
+ Name.equal f g andalso n = length b andalso qm (zip a b @ rest);
in
fun matchQtermTerm qtm tm = qm [(qtm,tm)];
end;
@@ -12458,26 +17360,27 @@
| 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;
+ | SOME qtm' => if equalQterm 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 Name.equal 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)
+ fun qv Var x = x
+ | qv x Var = x
+ | qv (Fn (f,a)) (Fn (g,b)) =
+ let
+ val _ = NameArity.equal 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 ((Var, _) :: rest) = qu qsub rest
| qu qsub ((qtm, Term.Var v) :: rest) =
let
val qtm =
@@ -12485,8 +17388,8 @@
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)
+ | qu qsub ((Fn ((f,n),a), Term.Fn (g,b)) :: rest) =
+ if Name.equal 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';
@@ -12495,10 +17398,10 @@
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;
+ fun qtermToTerm Var = anonymousVar
+ | qtermToTerm (Fn ((f,_),l)) = Term.Fn (f, map qtermToTerm l);
+in
+ val ppQterm = Print.ppMap qtermToTerm Term.pp;
end;
(* ------------------------------------------------------------------------- *)
@@ -12508,22 +17411,22 @@
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;
+ 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)) =
+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)
@@ -12533,38 +17436,38 @@
| netSize (SOME n) = SOME (computeSize n, n);
end;
-fun size (NET (_,_,NONE)) = 0
- | size (NET (_, _, SOME (i,_))) = i;
+fun size (Net (_,_,NONE)) = 0
+ | size (Net (_, _, SOME (i,_))) = i;
fun null net = size net = 0;
-fun singles qtms a = foldr SINGLE a qtms;
+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)) =
+ fun add (Result l) [] (Result l') = Result (l @ l')
+ | add a (input1 as qtm :: qtms) (Single (qtm',n)) =
+ if equalQterm 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))
+ 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))
+ 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;
@@ -12572,26 +17475,26 @@
fun filter pred =
let
- fun filt (RESULT l) =
+ fun filt (Result l) =
(case List.filter (fn (_,a) => pred a) l of
[] => NONE
- | l => SOME (RESULT l))
- | filt (SINGLE (qtm,n)) =
+ | l => SOME (Result l))
+ | filt (Single (qtm,n)) =
(case filt n of
NONE => NONE
- | SOME n => SOME (SINGLE (qtm,n)))
- | filt (MULTIPLE (vs,fs)) =
+ | 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))
+ 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";
@@ -12606,7 +17509,7 @@
let
val (a,qtms) = revDivide qtms n
in
- addQterm (FN (f,a)) (ks,fs,qtms)
+ addQterm (Fn (f,a)) (ks,fs,qtms)
end
| norm stack = stack
@@ -12620,7 +17523,7 @@
and addFn (f as (_,n)) (ks,fs,qtms) = norm (n :: ks, f :: fs, qtms);
in
val stackEmpty = ([],[],[]);
-
+
val stackAddQterm = addQterm;
val stackAddFn = addFn;
@@ -12633,16 +17536,16 @@
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, stack, Single (qtm,net)) :: rest) =
fold inc acc ((n - 1, stackAddQterm qtm stack, net) :: rest)
- | fold inc acc ((n, stack, MULTIPLE (v,fns)) :: 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
+ | SOME net => (n, stackAddQterm Var stack, net) :: rest
fun getFns (f as (_,k), net, x) =
(k + n, stackAddFn f stack, net) :: x
@@ -12657,11 +17560,11 @@
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,_)) =
+ | fold (pat :: pats, Single (qtm,net)) =
+ if equalQterm 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)) =
+ | fold (Fn (f,a) :: pats, Multiple (_,fns)) =
(case NameArityMap.peek fns f of
NONE => acc
| SOME net => fold (a @ pats, net))
@@ -12674,20 +17577,20 @@
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) =
+ | 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) =
+ | 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) =
+ (((pat as Fn (f,a)) :: pats, stack, Multiple (v,fns)) :: rest) =
let
val rest =
case v of
@@ -12724,10 +17627,10 @@
local
fun mat acc [] = acc
- | mat acc ((RESULT l, []) :: rest) = mat (l @ acc) rest
- | mat acc ((SINGLE (qtm,n), tm :: tms) :: rest) =
+ | 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) =
+ | mat acc ((Multiple (vs,fs), tm :: tms) :: rest) =
let
val rest = case vs of NONE => rest | SOME n => (n,tms) :: rest
@@ -12743,8 +17646,8 @@
end
| mat _ _ = raise Bug "TermNet.match: Match";
in
- fun match (NET (_,_,NONE)) _ = []
- | match (NET (p, _, SOME (_,n))) tm =
+ 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;
@@ -12756,16 +17659,16 @@
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) =
+ | 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) =
+ | 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) =
+ | mat acc ((qsub, Multiple (_,fns), Term.Fn (f,a) :: tms) :: rest) =
let
val rest =
case NameArityMap.peek fns (f, length a) of
@@ -12776,8 +17679,8 @@
end
| mat _ _ = raise Bug "TermNet.matched.mat";
in
- fun matched (NET (_,_,NONE)) _ = []
- | matched (NET (parm, _, SOME (_,net))) tm =
+ 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;
@@ -12787,16 +17690,16 @@
(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) =
+ | 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) =
+ | 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) =
+ | 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
@@ -12809,8 +17712,8 @@
end
| mat _ _ = raise Bug "TermNet.unify.mat";
in
- fun unify (NET (_,_,NONE)) _ = []
- | unify (NET (parm, _, SOME (_,net))) tm =
+ 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;
@@ -12820,16 +17723,16 @@
(* ------------------------------------------------------------------------- *)
local
- fun inc (qtm, RESULT l, acc) =
+ 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))) =
+
+ 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));
+ Print.ppMap toList (Print.ppList (Print.ppOp2 " |->" ppQterm ppA));
end;
end
@@ -12839,7 +17742,7 @@
(* ========================================================================= *)
(* MATCHING AND UNIFICATION FOR SETS OF FIRST ORDER LOGIC ATOMS *)
-(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature AtomNet =
@@ -12869,7 +17772,7 @@
val toString : 'a atomNet -> string
-val pp : 'a Metis.Parser.pp -> 'a atomNet Metis.Parser.pp
+val pp : 'a Metis.Print.pp -> 'a atomNet Metis.Print.pp
(* ------------------------------------------------------------------------- *)
(* Matching and unification queries. *)
@@ -12890,7 +17793,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -12899,7 +17802,7 @@
(* ========================================================================= *)
(* MATCHING AND UNIFICATION FOR SETS OF FIRST ORDER LOGIC ATOMS *)
-(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure AtomNet :> AtomNet =
@@ -12962,7 +17865,7 @@
(* ========================================================================= *)
(* MATCHING AND UNIFICATION FOR SETS OF FIRST ORDER LOGIC LITERALS *)
-(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature LiteralNet =
@@ -12994,7 +17897,7 @@
val toString : 'a literalNet -> string
-val pp : 'a Metis.Parser.pp -> 'a literalNet Metis.Parser.pp
+val pp : 'a Metis.Print.pp -> 'a literalNet Metis.Print.pp
(* ------------------------------------------------------------------------- *)
(* Matching and unification queries. *)
@@ -13015,7 +17918,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -13024,7 +17927,7 @@
(* ========================================================================= *)
(* MATCHING AND UNIFICATION FOR SETS OF FIRST ORDER LOGIC LITERALS *)
-(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure LiteralNet :> LiteralNet =
@@ -13072,9 +17975,9 @@
fun toString net = "LiteralNet[" ^ Int.toString (size net) ^ "]";
fun pp ppA =
- Parser.ppMap
+ Print.ppMap
(fn {positive,negative} => (positive,negative))
- (Parser.ppBinop " + NEGATIVE" (AtomNet.pp ppA) (AtomNet.pp ppA));
+ (Print.ppOp2 " + NEGATIVE" (AtomNet.pp ppA) (AtomNet.pp ppA));
(* ------------------------------------------------------------------------- *)
(* Matching and unification queries. *)
@@ -13102,7 +18005,7 @@
(* ========================================================================= *)
(* SUBSUMPTION CHECKING FOR FIRST ORDER LOGIC CLAUSES *)
-(* Copyright (c) 2002-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2002-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Subsume =
@@ -13122,7 +18025,7 @@
val filter : ('a -> bool) -> 'a subsume -> 'a subsume
-val pp : 'a subsume Metis.Parser.pp
+val pp : 'a subsume Metis.Print.pp
val toString : 'a subsume -> string
@@ -13156,7 +18059,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -13165,7 +18068,7 @@
(* ========================================================================= *)
(* SUBSUMPTION CHECKING FOR FIRST ORDER LOGIC CLAUSES *)
-(* Copyright (c) 2002-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2002-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Subsume :> Subsume =
@@ -13324,7 +18227,7 @@
fun toString subsume = "Subsume{" ^ Int.toString (size subsume) ^ "}";
-fun pp p = Parser.ppMap toString Parser.ppString p;
+fun pp subsume = Print.ppMap toString Print.ppString subsume;
(* ------------------------------------------------------------------------- *)
(* Subsumption checking. *)
@@ -13439,19 +18342,19 @@
genSubsumes pred subsume (SOME (LiteralSet.size cl)) cl;
end;
-(*TRACE4
+(*MetisTrace4
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 () = Print.trace 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)
+ (Print.trace ppCl "Subsume.subsumes: subsuming cl" cl;
+ Print.trace ppSub "Subsume.subsumes: subsuming sub" sub)
in
result
end;
@@ -13460,14 +18363,14 @@
let
val ppCl = LiteralSet.pp
val ppSub = Subst.pp
- val () = Parser.ppTrace ppCl "Subsume.strictlySubsumes: cl" cl
+ val () = Print.trace 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)
+ (Print.trace ppCl "Subsume.subsumes: subsuming cl" cl;
+ Print.trace ppSub "Subsume.subsumes: subsuming sub" sub)
in
result
end;
@@ -13503,7 +18406,7 @@
(* ========================================================================= *)
(* THE KNUTH-BENDIX TERM ORDERING *)
-(* Copyright (c) 2002-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2002-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature KnuthBendixOrder =
@@ -13528,7 +18431,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -13537,7 +18440,7 @@
(* ========================================================================= *)
(* KNUTH-BENDIX TERM ORDERING CONSTRAINTS *)
-(* Copyright (c) 2002-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2002-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure KnuthBendixOrder :> KnuthBendixOrder =
@@ -13549,10 +18452,12 @@
(* Helper functions. *)
(* ------------------------------------------------------------------------- *)
-fun firstNotEqual f l =
- case List.find op<> l of
+fun notEqualTerm (x,y) = not (Term.equal x y);
+
+fun firstNotEqualTerm f l =
+ case List.find notEqualTerm l of
SOME (x,y) => f x y
- | NONE => raise Bug "firstNotEqual";
+ | NONE => raise Bug "firstNotEqualTerm";
(* ------------------------------------------------------------------------- *)
(* The weight of all constants must be at least 1, and there must be at most *)
@@ -13573,7 +18478,7 @@
fn ((f1,n1),(f2,n2)) =>
case Int.compare (n1,n2) of
LESS => LESS
- | EQUAL => String.compare (f1,f2)
+ | EQUAL => Name.compare (f1,f2)
| GREATER => GREATER;
(* The default order *)
@@ -13599,7 +18504,7 @@
fun weightNeg (Weight (m,c)) = Weight (NameMap.transform ~ m, ~c);
local
- fun add (n1,n2) =
+ fun add ((_,n1),(_,n2)) =
let
val n = n1 + n2
in
@@ -13612,15 +18517,6 @@
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)
@@ -13636,80 +18532,41 @@
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)) =
+(*MetisDebug
+val ppWeightList =
+ let
+ fun ppCoeff n =
+ if n < 0 then Print.sequence (Print.addString "~") (ppCoeff (~n))
+ else if n = 1 then Print.skip
+ else Print.ppInt n
+
+ fun pp_tm (NONE,n) = Print.ppInt n
+ | pp_tm (SOME v, n) = Print.sequence (ppCoeff n) (Name.pp v)
+ in
+ fn [] => Print.ppInt 0
+ | tms => Print.ppOpList " +" pp_tm tms
+ end;
+
+fun ppWeight (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;
+ val l = map (fn (v,n) => (SOME v, n)) l
+ val l = if c = 0 then l else l @ [(NONE,c)]
+ in
+ ppWeightList l
+ end;
+
+val weightToString = Print.toString ppWeight;
+*)
(* ------------------------------------------------------------------------- *)
(* The Knuth-Bendix term order. *)
(* ------------------------------------------------------------------------- *)
-datatype kboOrder = Less | Equal | Greater | SignOf of weight;
-
-fun kboOrder {weight,precedence} =
+fun compare {weight,precedence} =
let
fun weightDifference tm1 tm2 =
let
@@ -13736,7 +18593,7 @@
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)
+ | EQUAL => firstNotEqualTerm weightLess (zip a1 a2)
| GREATER => false)
| precedenceLess _ _ = false
@@ -13747,39 +18604,33 @@
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
+ else if weightDiffLess w tm1 tm2 then SOME LESS
+ else if weightDiffGreater w tm1 tm2 then SOME GREATER
+ else NONE
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)
+ LESS => SOME LESS
+ | EQUAL => firstNotEqualTerm weightCmp (zip a1 a2)
+ | GREATER => SOME 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
+ fn (tm1,tm2) =>
+ if Term.equal tm1 tm2 then SOME EQUAL else weightCmp tm1 tm2
+ end;
+
+(*MetisTrace7
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 () = Print.trace Term.pp "KnuthBendixOrder.compare: tm1" tm1
+ val () = Print.trace 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
+ Print.trace Print.ppOrder "KnuthBendixOrder.compare: result" x
in
result
end;
@@ -13792,18 +18643,30 @@
(* ========================================================================= *)
(* ORDERED REWRITING FOR FIRST ORDER TERMS *)
-(* Copyright (c) 2003-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2003-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Rewrite =
sig
(* ------------------------------------------------------------------------- *)
-(* A type of rewrite systems. *)
+(* Orientations of equations. *)
(* ------------------------------------------------------------------------- *)
datatype orient = LeftToRight | RightToLeft
+val toStringOrient : orient -> string
+
+val ppOrient : orient Metis.Print.pp
+
+val toStringOrientOption : orient option -> string
+
+val ppOrientOption : orient option Metis.Print.pp
+
+(* ------------------------------------------------------------------------- *)
+(* A type of rewrite systems. *)
+(* ------------------------------------------------------------------------- *)
+
type reductionOrder = Metis.Term.term * Metis.Term.term -> order option
type equationId = int
@@ -13826,7 +18689,7 @@
val toString : rewrite -> string
-val pp : rewrite Metis.Parser.pp
+val pp : rewrite Metis.Print.pp
(* ------------------------------------------------------------------------- *)
(* Add equations into the system. *)
@@ -13882,7 +18745,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -13891,7 +18754,7 @@
(* ========================================================================= *)
(* ORDERED REWRITING FOR FIRST ORDER TERMS *)
-(* Copyright (c) 2003-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2003-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Rewrite :> Rewrite =
@@ -13900,11 +18763,29 @@
open Useful;
(* ------------------------------------------------------------------------- *)
-(* A type of rewrite systems. *)
+(* Orientations of equations. *)
(* ------------------------------------------------------------------------- *)
datatype orient = LeftToRight | RightToLeft;
+fun toStringOrient ort =
+ case ort of
+ LeftToRight => "-->"
+ | RightToLeft => "<--";
+
+val ppOrient = Print.ppMap toStringOrient Print.ppString;
+
+fun toStringOrientOption orto =
+ case orto of
+ SOME ort => toStringOrient ort
+ | NONE => "<->";
+
+val ppOrientOption = Print.ppMap toStringOrientOption Print.ppString;
+
+(* ------------------------------------------------------------------------- *)
+(* A type of rewrite systems. *)
+(* ------------------------------------------------------------------------- *)
+
type reductionOrder = Term.term * Term.term -> order option;
type equationId = int;
@@ -13950,72 +18831,63 @@
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 pp = Print.ppMap equations (Print.ppList Rule.ppEquation);
+
+(*MetisTrace1
+local
+ fun ppEq ((x_y,_),ort) =
+ Print.ppOp2 (" " ^ toStringOrientOption ort) Term.pp Term.pp x_y;
+
+ fun ppField f ppA a =
+ Print.blockProgram Print.Inconsistent 2
+ [Print.addString (f ^ " ="),
+ Print.addBreak 1,
+ ppA a];
val ppKnown =
- ppField "known" (ppMap IntMap.toList (ppList (ppPair ppInt ppEq)));
+ ppField "known"
+ (Print.ppMap IntMap.toList
+ (Print.ppList (Print.ppPair Print.ppInt ppEq)));
val ppRedexes =
- ppField
- "redexes"
- (TermNet.pp
- (ppPair ppInt (ppMap (orientOptionToString o SOME) ppString)));
+ ppField "redexes"
+ (TermNet.pp (Print.ppPair Print.ppInt ppOrient));
val ppSubterms =
- ppField
- "subterms"
+ ppField "subterms"
(TermNet.pp
- (ppMap
+ (Print.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;
+ (Print.ppPair Print.ppInt Term.ppPath)));
+
+ val ppWaiting =
+ ppField "waiting"
+ (Print.ppMap (IntSet.toList) (Print.ppList Print.ppInt));
+in
+ fun pp (Rewrite {known,redexes,subterms,waiting,...}) =
+ Print.blockProgram Print.Inconsistent 2
+ [Print.addString "Rewrite",
+ Print.addBreak 1,
+ Print.blockProgram Print.Inconsistent 1
+ [Print.addString "{",
+ ppKnown known,
+(*MetisTrace5
+ Print.addString ",",
+ Print.addBreak 1,
+ ppRedexes redexes,
+ Print.addString ",",
+ Print.addBreak 1,
+ ppSubterms subterms,
+ Print.addString ",",
+ Print.addBreak 1,
+ ppWaiting waiting,
+*)
+ Print.skip],
+ Print.addString "}"]
+end;
+*)
+
+val toString = Print.toString pp;
(* ------------------------------------------------------------------------- *)
(* Debug functions. *)
@@ -14028,7 +18900,7 @@
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
@@ -14082,8 +18954,8 @@
Rewrite
{order = order, known = known, redexes = redexes,
subterms = subterms, waiting = waiting}
-(*TRACE5
- val () = Parser.ppTrace pp "Rewrite.add: result" rw
+(*MetisTrace5
+ val () = Print.trace pp "Rewrite.add: result" rw
*)
in
rw
@@ -14147,17 +19019,18 @@
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"
+ val th = Rule.symmetryRule l r
+ in
+ fn tm =>
+ if Term.equal 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"
+ fn tm =>
+ if Term.equal tm l then (r,th) else raise Error "mkNeqConv: LR"
end
end;
@@ -14212,14 +19085,14 @@
| SOME lit => (false,lit)
val (lit',litTh) = literule lit
in
- if lit = lit' then eqn
+ if Literal.equal 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
+(*MetisDebug
handle Error err => raise Error ("Rewrite.rewriteIdEqn':\n" ^ err);
*)
@@ -14232,7 +19105,7 @@
val neq = neqConvsDelete neq lit
val (lit',litTh) = mk_literule neq lit
in
- if lit = lit' then acc
+ if Literal.equal lit lit' then acc
else
let
val th = Thm.resolve lit th litTh
@@ -14268,15 +19141,15 @@
fun rewriteIdRule' order known redexes id th =
rewriteIdLiteralsRule' order known redexes id (Thm.clause th) th;
-(*DEBUG
+(*MetisDebug
val rewriteIdRule' = fn order => fn known => fn redexes => fn id => fn th =>
let
-(*TRACE6
- val () = Parser.ppTrace Thm.pp "Rewrite.rewriteIdRule': th" th
+(*MetisTrace6
+ val () = Print.trace Thm.pp "Rewrite.rewriteIdRule': th" th
*)
val result = rewriteIdRule' order known redexes id th
-(*TRACE6
- val () = Parser.ppTrace Thm.pp "Rewrite.rewriteIdRule': result" result
+(*MetisTrace6
+ val () = Print.trace Thm.pp "Rewrite.rewriteIdRule': result" result
*)
val _ = not (thmReducible order known id result) orelse
raise Bug "rewriteIdRule: should be normalized"
@@ -14322,8 +19195,8 @@
end;
fun sameRedexes NONE _ _ = false
- | sameRedexes (SOME LeftToRight) (l0,_) (l,_) = l0 = l
- | sameRedexes (SOME RightToLeft) (_,r0) (_,r) = r0 = r;
+ | sameRedexes (SOME LeftToRight) (l0,_) (l,_) = Term.equal l0 l
+ | sameRedexes (SOME RightToLeft) (_,r0) (_,r) = Term.equal r0 r;
fun redexResidues NONE (l,r) = [(l,r,false),(r,l,false)]
| redexResidues (SOME LeftToRight) (l,r) = [(l,r,true)]
@@ -14346,13 +19219,13 @@
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
@@ -14364,7 +19237,13 @@
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 identical =
+ let
+ val (l0,r0) = eq0
+ and (l,r) = eq
+ in
+ Term.equal l l0 andalso Term.equal r r0
+ end
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
@@ -14434,7 +19313,7 @@
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
@@ -14451,7 +19330,7 @@
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
@@ -14460,18 +19339,21 @@
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
+(*MetisTrace5
+ val ppPl = Print.ppMap IntSet.toList (Print.ppList Print.ppInt)
+ val () = Print.trace ppPl "Rewrite.rebuild: rpl" rpl
+ val () = Print.trace 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}
+ {order = order,
+ known = known,
+ redexes = redexes,
+ subterms = subterms,
+ waiting = waiting}
end;
end;
@@ -14499,17 +19381,17 @@
if isReduced rw then (rw,[])
else reduceAcc (IntSet.empty,IntSet.empty,IntSet.empty,rw,IntSet.empty);
-(*DEBUG
+(*MetisDebug
val reduce' = fn rw =>
let
-(*TRACE4
- val () = Parser.ppTrace pp "Rewrite.reduce': rw" rw
+(*MetisTrace4
+ val () = Print.trace 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
+(*MetisTrace4
+ val ppResult = Print.ppPair pp (Print.ppList Print.ppInt)
+ val () = Print.trace ppResult "Rewrite.reduce': result" result
*)
val ths = map (fn (id,((_,th),_)) => (id,th)) (IntMap.toList known')
val _ =
@@ -14547,7 +19429,7 @@
(* ========================================================================= *)
(* A STORE FOR UNIT THEOREMS *)
-(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Units =
@@ -14571,7 +19453,7 @@
val toString : units -> string
-val pp : units Metis.Parser.pp
+val pp : units Metis.Print.pp
(* ------------------------------------------------------------------------- *)
(* Add units into the store. *)
@@ -14599,7 +19481,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -14608,7 +19490,7 @@
(* ========================================================================= *)
(* A STORE FOR UNIT THEOREMS *)
-(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Units :> Units =
@@ -14634,7 +19516,7 @@
fun toString units = "U{" ^ Int.toString (size units) ^ "}";
-val pp = Parser.ppMap toString Parser.ppString;
+val pp = Print.ppMap toString Print.ppString;
(* ------------------------------------------------------------------------- *)
(* Add units into the store. *)
@@ -14718,7 +19600,7 @@
(* ========================================================================= *)
(* CLAUSE = ID + THEOREM *)
-(* Copyright (c) 2002-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2002-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Clause =
@@ -14818,7 +19700,9 @@
val showId : bool Unsynchronized.ref
-val pp : clause Metis.Parser.pp
+val pp : clause Metis.Print.pp
+
+val toString : clause -> string
end
@@ -14826,7 +19710,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -14835,7 +19719,7 @@
(* ========================================================================= *)
(* CLAUSE = ID + THEOREM *)
-(* Copyright (c) 2002-2004 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2002-2004 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Clause :> Clause =
@@ -14851,8 +19735,7 @@
let
val r = Unsynchronized.ref 0
in
- fn () => CRITICAL (fn () =>
- case r of Unsynchronized.ref n => let val () = r := n + 1 in n end)
+ fn () => case r of Unsynchronized.ref n => let val () = r := n + 1 in n end
end;
(* ------------------------------------------------------------------------- *)
@@ -14882,19 +19765,21 @@
val showId = Unsynchronized.ref false;
local
- val ppIdThm = Parser.ppPair Parser.ppInt Thm.pp;
-in
- fun pp p (Clause {id,thm,...}) =
- if !showId then ppIdThm p (id,thm) else Thm.pp p thm;
-end;
+ val ppIdThm = Print.ppPair Print.ppInt Thm.pp;
+in
+ fun pp (Clause {id,thm,...}) =
+ if !showId then ppIdThm (id,thm) else Thm.pp thm;
+end;
+
+fun toString cl = Print.toString pp cl;
(* ------------------------------------------------------------------------- *)
(* Basic operations. *)
(* ------------------------------------------------------------------------- *)
-val default : parameters =
+val default : parameters =
{ordering = KnuthBendixOrder.default,
- orderLiterals = UnsignedLiteralOrder, (*LCP: changed from PositiveLiteralOrder*)
+ orderLiterals = UnsignedLiteralOrder (* PositiveLiteralOrder *) (* MODIFIED by Jasmin Blanchette *),
orderTerms = true};
fun mk info = Clause info
@@ -14977,13 +19862,13 @@
LiteralSet.foldr addLit LiteralSet.empty litSet
end;
-(*TRACE6
+(*MetisTrace6
val largestLiterals = fn cl =>
let
val ppResult = LiteralSet.pp
- val () = Parser.ppTrace pp "Clause.largestLiterals: cl" cl
+ val () = Print.trace pp "Clause.largestLiterals: cl" cl
val result = largestLiterals cl
- val () = Parser.ppTrace ppResult "Clause.largestLiterals: result" result
+ val () = Print.trace ppResult "Clause.largestLiterals: result" result
in
result
end;
@@ -15053,10 +19938,10 @@
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
+(*MetisTrace4
+ val () = Print.trace Rewrite.pp "Clause.rewrite: rewr" rewr
+ val () = Print.trace Print.ppInt "Clause.rewrite: id" id
+ val () = Print.trace pp "Clause.rewrite: cl" cl
*)
val thm =
@@ -15066,13 +19951,13 @@
val result = Clause {parameters = parameters, id = id, thm = thm}
-(*TRACE4
- val () = Parser.ppTrace pp "Clause.rewrite: result" result
+(*MetisTrace4
+ val () = Print.trace pp "Clause.rewrite: result" result
*)
in
result
end
-(*DEBUG
+(*MetisDebug
handle Error err => raise Error ("Clause.rewrite:\n" ^ err);
*)
@@ -15089,12 +19974,12 @@
map apply (Rule.factor' lits)
end;
-(*TRACE5
+(*MetisTrace5
val factor = fn cl =>
let
- val () = Parser.ppTrace pp "Clause.factor: cl" cl
+ val () = Print.trace pp "Clause.factor: cl" cl
val result = factor cl
- val () = Parser.ppTrace (Parser.ppList pp) "Clause.factor: result" result
+ val () = Print.trace (Print.ppList pp) "Clause.factor: result" result
in
result
end;
@@ -15102,51 +19987,55 @@
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
+(*MetisTrace5
+ val () = Print.trace pp "Clause.resolve: cl1" cl1
+ val () = Print.trace Literal.pp "Clause.resolve: lit1" lit1
+ val () = Print.trace pp "Clause.resolve: cl2" cl2
+ val () = Print.trace 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
+(*MetisTrace5
+ val () = Print.trace 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
+(*MetisTrace5
(trace "Clause.resolve: th1 violates ordering\n"; false) orelse
*)
raise Error "resolve: clause1: ordering constraints"
val _ = isLargerLiteral parameters (Thm.clause th2) lit2 orelse
-(*TRACE5
+(*MetisTrace5
(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
+(*MetisTrace5
+ val () = Print.trace Thm.pp "Clause.resolve: th" th
*)
val cl = Clause {parameters = parameters, id = newId (), thm = th}
-(*TRACE5
- val () = Parser.ppTrace pp "Clause.resolve: cl" cl
+(*MetisTrace5
+ val () = Print.trace 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
+fun paramodulate (cl1,lit1,ort1,tm1) (cl2,lit2,path2,tm2) =
+ let
+(*MetisTrace5
+ val () = Print.trace pp "Clause.paramodulate: cl1" cl1
+ val () = Print.trace Literal.pp "Clause.paramodulate: lit1" lit1
+ val () = Print.trace Rewrite.ppOrient "Clause.paramodulate: ort1" ort1
+ val () = Print.trace Term.pp "Clause.paramodulate: tm1" tm1
+ val () = Print.trace pp "Clause.paramodulate: cl2" cl2
+ val () = Print.trace Literal.pp "Clause.paramodulate: lit2" lit2
+ val () = Print.trace Term.ppPath "Clause.paramodulate: path2" path2
+ val () = Print.trace Term.pp "Clause.paramodulate: tm2" tm2
*)
val Clause {parameters, thm = th1, ...} = cl1
and Clause {thm = th2, ...} = cl2
@@ -15155,33 +20044,37 @@
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"
+ raise Error "Clause.paramodulate: with clause: ordering"
val _ = isLargerLiteral parameters (Thm.clause th2) lit2 orelse
-(*TRACE5
- (trace "Clause.paramodulate: cl2 ordering\n"; false) orelse
-*)
- raise Error "paramodulate: into clause: ordering constraints"
+ raise Error "Clause.paramodulate: into clause: ordering"
+
val eqn = (Literal.destEq lit1, th1)
val eqn as (l_r,_) =
- case ort of
+ case ort1 of
Rewrite.LeftToRight => eqn
| Rewrite.RightToLeft => Rule.symEqn eqn
+(*MetisTrace6
+ val () = Print.trace Rule.ppEquation "Clause.paramodulate: eqn" 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
+ raise Error "Clause.paramodulate: equation: ordering constraints"
+ val th = Rule.rewrRule eqn lit2 path2 th2
+(*MetisTrace5
+ val () = Print.trace Thm.pp "Clause.paramodulate: th" th
*)
in
Clause {parameters = parameters, id = newId (), thm = th}
- end;
+ end
+(*MetisTrace5
+ handle Error err =>
+ let
+ val () = trace ("Clause.paramodulate: failed: " ^ err ^ "\n")
+ in
+ raise Error err
+ end;
+*)
end
end;
@@ -15190,7 +20083,7 @@
(* ========================================================================= *)
(* THE ACTIVE SET OF CLAUSES *)
-(* Copyright (c) 2002-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2002-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Active =
@@ -15200,7 +20093,10 @@
(* A type of active clause sets. *)
(* ------------------------------------------------------------------------- *)
-type simplify = {subsume : bool, reduce : bool, rewrite : bool}
+type simplify =
+ {subsume : bool,
+ reduce : bool,
+ rewrite : bool}
type parameters =
{clause : Metis.Clause.parameters,
@@ -15217,13 +20113,15 @@
val size : active -> int
-val saturated : active -> Metis.Clause.clause list
+val saturation : 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
+val new :
+ parameters -> {axioms : Metis.Thm.thm list, conjecture : Metis.Thm.thm list} ->
+ active * {axioms : Metis.Clause.clause list, conjecture : Metis.Clause.clause list}
(* ------------------------------------------------------------------------- *)
(* Add a clause into the active set and deduce all consequences. *)
@@ -15235,7 +20133,7 @@
(* Pretty printing. *)
(* ------------------------------------------------------------------------- *)
-val pp : active Metis.Parser.pp
+val pp : active Metis.Print.pp
end
@@ -15243,7 +20141,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -15252,7 +20150,7 @@
(* ========================================================================= *)
(* THE ACTIVE SET OF CLAUSES *)
-(* Copyright (c) 2002-2006 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2002-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Active :> Active =
@@ -15264,10 +20162,32 @@
(* Helper functions. *)
(* ------------------------------------------------------------------------- *)
-local
+(*MetisDebug
+local
+ fun mkRewrite ordering =
+ let
+ fun add (cl,rw) =
+ let
+ val {id, thm = th, ...} = Clause.dest cl
+ in
+ case total Thm.destUnitEq th of
+ SOME l_r => Rewrite.add rw (id,(l_r,th))
+ | NONE => rw
+ end
+ in
+ foldl add (Rewrite.new (KnuthBendixOrder.compare ordering))
+ end;
+
fun allFactors red =
let
- fun allClause cl = List.all red (cl :: Clause.factor cl)
+ fun allClause cl =
+ List.all red (cl :: Clause.factor cl) orelse
+ let
+ val () = Print.trace Clause.pp
+ "Active.isSaturated.allFactors: cl" cl
+ in
+ false
+ end
in
List.all allClause
end;
@@ -15282,6 +20202,12 @@
| SOME cl => allFactors red [cl]
in
LiteralSet.all allLiteral2 (Clause.literals cl)
+ end orelse
+ let
+ val () = Print.trace Clause.pp
+ "Active.isSaturated.allResolutions: cl2" cl
+ in
+ false
end
fun allClause1 allCls cl =
@@ -15291,7 +20217,14 @@
fun allLiteral1 lit = List.all (allClause2 (cl,lit)) allCls
in
LiteralSet.all allLiteral1 (Clause.literals cl)
- end
+ end orelse
+ let
+ val () = Print.trace Clause.pp
+ "Active.isSaturated.allResolutions: cl1" cl
+ in
+ false
+ end
+
in
fn [] => true
| allCls as cl :: cls =>
@@ -15312,9 +20245,24 @@
| SOME cl => allFactors red [cl]
in
List.all allSubterms (Literal.nonVarTypedSubterms lit)
+ end orelse
+ let
+ val () = Print.trace Literal.pp
+ "Active.isSaturated.allParamodulations: lit2" lit
+ in
+ false
end
in
LiteralSet.all allLiteral2 (Clause.literals cl)
+ end orelse
+ let
+ val () = Print.trace Clause.pp
+ "Active.isSaturated.allParamodulations: cl2" cl
+ val (_,_,ort,_) = cl_lit_ort_tm
+ val () = Print.trace Rewrite.ppOrient
+ "Active.isSaturated.allParamodulations: ort1" ort
+ in
+ false
end
fun allClause1 cl =
@@ -15330,9 +20278,21 @@
| SOME (l,r) =>
allCl2 (cl,lit,Rewrite.LeftToRight,l) andalso
allCl2 (cl,lit,Rewrite.RightToLeft,r)
+ end orelse
+ let
+ val () = Print.trace Literal.pp
+ "Active.isSaturated.allParamodulations: lit1" lit
+ in
+ false
end
in
LiteralSet.all allLiteral1 (Clause.literals cl)
+ end orelse
+ let
+ val () = Print.trace Clause.pp
+ "Active.isSaturated.allParamodulations: cl1" cl
+ in
+ false
end
in
List.all allClause1 cls
@@ -15350,30 +20310,49 @@
val cl' = Clause.reduce reduce cl'
val cl' = Clause.rewrite rewrite cl'
in
- not (Clause.equalThms cl cl') andalso simp cl'
+ not (Clause.equalThms cl cl') andalso
+ (simp cl' orelse
+ let
+ val () = Print.trace Clause.pp
+ "Active.isSaturated.redundant: cl'" cl'
+ in
+ false
+ end)
end
in
- simp
+ fn cl =>
+ simp cl orelse
+ let
+ val () = Print.trace Clause.pp
+ "Active.isSaturated.redundant: cl" cl
+ in
+ false
+ end
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;
+ val rd = Units.empty
+ val rw = mkRewrite ordering cls
+ val red = redundant {subsume = subs, reduce = rd, rewrite = rw}
+ in
+ (allFactors red cls andalso
+ allResolutions red cls andalso
+ allParamodulations red cls) orelse
+ let
+ val () = Print.trace Rewrite.pp "Active.isSaturated: rw" rw
+ val () = Print.trace (Print.ppList Clause.pp)
+ "Active.isSaturated: clauses" cls
+ in
+ false
+ end
+ end;
+end;
+
+fun checkSaturated ordering subs cls =
+ if isSaturated ordering subs cls then ()
+ else raise Bug "Active.checkSaturated";
+*)
(* ------------------------------------------------------------------------- *)
(* A type of active clause sets. *)
@@ -15453,7 +20432,7 @@
IntMap.foldr add [] cls
end;
-fun saturated active =
+fun saturation active =
let
fun remove (cl,(cls,subs)) =
let
@@ -15467,7 +20446,7 @@
val (cls,_) = foldl remove ([], Subsume.new ()) cls
val (cls,subs) = foldl remove ([], Subsume.new ()) cls
-(*DEBUG
+(*MetisDebug
val Active {parameters,...} = active
val {clause,...} = parameters
val {ordering,...} = clause
@@ -15485,57 +20464,53 @@
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);
+ Print.ppMap toStr Print.ppString
+ end;
+
+(*MetisDebug
+local
+ fun ppField f ppA a =
+ Print.blockProgram Print.Inconsistent 2
+ [Print.addString (f ^ " ="),
+ Print.addBreak 1,
+ ppA a];
val ppClauses =
ppField "clauses"
- (Parser.ppMap IntMap.toList
- (Parser.ppList (Parser.ppPair Parser.ppInt Clause.pp)));
+ (Print.ppMap IntMap.toList
+ (Print.ppList (Print.ppPair Print.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)
+ (Print.ppMap (fn (c,l,p,t) => ((Clause.id c, l, p), t))
+ (Print.ppPair
+ (Print.ppTriple Print.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;
+ fun pp (Active {clauses,rewrite,subterms,...}) =
+ Print.blockProgram Print.Inconsistent 2
+ [Print.addString "Active",
+ Print.addBreak 1,
+ Print.blockProgram Print.Inconsistent 1
+ [Print.addString "{",
+ ppClauses clauses,
+ Print.addString ",",
+ Print.addBreak 1,
+ ppRewrite rewrite,
+(*MetisTrace5
+ Print.addString ",",
+ Print.addBreak 1,
+ ppSubterms subterms,
+*)
+ Print.skip],
+ Print.addString "}"];
+end;
+*)
+
+val toString = Print.toString pp;
(* ------------------------------------------------------------------------- *)
(* Simplify clauses. *)
@@ -15566,17 +20541,17 @@
end
end;
-(*DEBUG
+(*MetisDebug
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
+ fun traceCl s = Print.trace Clause.pp ("Active.simplify: " ^ s)
+(*MetisTrace4
+ val ppClOpt = Print.ppOption Clause.pp
val () = traceCl "cl" cl
*)
val cl' = simplify simp units rewr subs cl
-(*TRACE4
- val () = Parser.ppTrace ppClOpt "Active.simplify: cl'" cl'
+(*MetisTrace4
+ val () = Print.trace ppClOpt "Active.simplify: cl'" cl'
*)
val () =
case cl' of
@@ -15711,8 +20686,8 @@
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
+(*MetisTrace4
+ val () = Print.trace Literal.pp "Active.deduceResolution: lit" lit
*)
in
if Atom.isEq atm then acc
@@ -15747,13 +20722,30 @@
val eqns = Clause.largestEquations cl
val subtms =
if TermNet.null equations then [] else Clause.largestSubterms cl
+(*MetisTrace5
+ val () = Print.trace LiteralSet.pp "Active.deduce: lits" lits
+ val () = Print.trace
+ (Print.ppList
+ (Print.ppMap (fn (lit,ort,_) => (lit,ort))
+ (Print.ppPair Literal.pp Rewrite.ppOrient)))
+ "Active.deduce: eqns" eqns
+ val () = Print.trace
+ (Print.ppList
+ (Print.ppTriple Literal.pp Term.ppPath Term.pp))
+ "Active.deduce: subtms" subtms
+*)
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
+ val acc = rev acc
+
+(*MetisTrace5
+ val () = Print.trace (Print.ppList Clause.pp) "Active.deduce: acc" acc
+*)
+ in
+ acc
end;
(* ------------------------------------------------------------------------- *)
@@ -15807,12 +20799,12 @@
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
+(*MetisTrace5
+ val () = Print.trace Clause.pp "Active.addRed: cl" cl
+ val () = Print.trace Term.pp "Active.addRed: tm" tm
*)
val id = Clause.id cl
in
@@ -15821,15 +20813,15 @@
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
+(*MetisTrace5
+ val () = Print.trace Term.pp "Active.addReduce: l" l
+ val () = Print.trace Term.pp "Active.addReduce: r" r
+ val () = Print.trace Print.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
@@ -15853,7 +20845,7 @@
if choose_clause_rewritables active ids then clause_rewritables active
else rewrite_rewritables active ids;
-(*DEBUG
+(*MetisDebug
val rewritables = fn active => fn ids =>
let
val clause_ids = clause_rewritables active
@@ -15863,13 +20855,13 @@
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
+ val ppIdl = Print.ppList Print.ppInt
+ val ppIds = Print.ppMap IntSet.toList ppIdl
+ val () = Print.trace pp "Active.rewritables: active" active
+ val () = Print.trace ppIdl "Active.rewritables: ids" ids
+ val () = Print.trace ppIds
"Active.rewritables: clause_ids" clause_ids
- val () = Parser.ppTrace ppIds
+ val () = Print.trace ppIds
"Active.rewritables: rewrite_ids" rewrite_ids
in
raise Bug "Active.rewritables: ~(rewrite_ids SUBSET clause_ids)"
@@ -15884,12 +20876,19 @@
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
+ {parameters,
+ clauses,
+ units,
+ rewrite,
+ subsume,
+ literals,
+ equations,
+ subterms,
+ allSubterms} = active
val clauses = IntMap.filter (idPred o fst) clauses
and subsume = Subsume.filter clausePred subsume
@@ -15899,9 +20898,14 @@
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,
+ {parameters = parameters,
+ clauses = clauses,
+ units = units,
+ rewrite = rewrite,
+ subsume = subsume,
+ literals = literals,
+ equations = equations,
+ subterms = subterms,
allSubterms = allSubterms}
end;
in
@@ -15909,21 +20913,21 @@
if Rewrite.isReduced rewrite then (active,[])
else
let
-(*TRACE3
+(*MetisTrace3
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
+(*MetisTrace3
+ val ppCls = Print.ppList Clause.pp
+ val () = Print.trace ppCls "Active.extract_rewritables: cls" cls
*)
in
(delete active ids, cls)
end
-(*DEBUG
+(*MetisDebug
handle Error err =>
raise Bug ("Active.extract_rewritables: shouldn't fail\n" ^ err);
*)
@@ -15997,13 +21001,13 @@
fun factor active cls = factor' active [] cls;
end;
-(*TRACE4
+(*MetisTrace4
val factor = fn active => fn cls =>
let
- val ppCls = Parser.ppList Clause.pp
- val () = Parser.ppTrace ppCls "Active.factor: cls" cls
+ val ppCls = Print.ppList Clause.pp
+ val () = Print.trace ppCls "Active.factor: cls" cls
val (active,cls') = factor active cls
- val () = Parser.ppTrace ppCls "Active.factor: cls'" cls'
+ val () = Print.trace ppCls "Active.factor: cls'" cls'
in
(active,cls')
end;
@@ -16013,16 +21017,18 @@
(* Create a new active clause set and initialize clauses. *)
(* ------------------------------------------------------------------------- *)
-fun new parameters ths =
+fun new parameters {axioms,conjecture} =
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
+ val active = empty parameters
+ val (active,axioms) = factor active (map mk_clause axioms)
+ val (active,conjecture) = factor active (map mk_clause conjecture)
+ in
+ (active, {axioms = axioms, conjecture = conjecture})
end;
(* ------------------------------------------------------------------------- *)
@@ -16037,16 +21043,16 @@
else if not (Clause.equalThms cl cl') then factor active [cl']
else
let
-(*TRACE3
- val () = Parser.ppTrace Clause.pp "Active.add: cl" cl
+(*MetisTrace2
+ val () = Print.trace 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
+(*MetisTrace2
+ val ppCls = Print.ppList Clause.pp
+ val () = Print.trace ppCls "Active.add: cls" cls
*)
in
(active,cls)
@@ -16059,22 +21065,48 @@
(* ========================================================================= *)
(* THE WAITING SET OF CLAUSES *)
-(* Copyright (c) 2002-2007 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2002-2007 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Waiting =
sig
(* ------------------------------------------------------------------------- *)
-(* A type of waiting sets of clauses. *)
-(* ------------------------------------------------------------------------- *)
+(* The parameters control the order that clauses are removed from the *)
+(* waiting set: clauses are assigned a weight and removed in strict weight *)
+(* order, with smaller weights being removed before larger weights. *)
+(* *)
+(* The weight of a clause is defined to be *)
+(* *)
+(* d * s^symbolsWeight * v^variablesWeight * l^literalsWeight * m *)
+(* *)
+(* where *)
+(* *)
+(* d = the derivation distance of the clause from the axioms *)
+(* s = the number of symbols in the clause *)
+(* v = the number of distinct variables in the clause *)
+(* l = the number of literals in the clause *)
+(* m = the truth of the clause wrt the models *)
+(* ------------------------------------------------------------------------- *)
+
+type weight = real
+
+type modelParameters =
+ {model : Metis.Model.parameters,
+ initialPerturbations : int,
+ maxChecks : int option,
+ perturbations : int,
+ weight : weight}
type parameters =
- {symbolsWeight : real,
- literalsWeight : real,
- modelsWeight : real,
- modelChecks : int,
- models : Metis.Model.parameters list}
+ {symbolsWeight : weight,
+ variablesWeight : weight,
+ literalsWeight : weight,
+ models : modelParameters list}
+
+(* ------------------------------------------------------------------------- *)
+(* A type of waiting sets of clauses. *)
+(* ------------------------------------------------------------------------- *)
type waiting
@@ -16086,11 +21118,14 @@
val default : parameters
-val new : parameters -> Metis.Clause.clause list -> waiting
+val new :
+ parameters ->
+ {axioms : Metis.Clause.clause list,
+ conjecture : Metis.Clause.clause list} -> waiting
val size : waiting -> int
-val pp : waiting Metis.Parser.pp
+val pp : waiting Metis.Print.pp
(* ------------------------------------------------------------------------- *)
(* Adding new clauses. *)
@@ -16110,7 +21145,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -16119,7 +21154,7 @@
(* ========================================================================= *)
(* THE WAITING SET OF CLAUSES *)
-(* Copyright (c) 2002-2007 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2002-2007 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Waiting :> Waiting =
@@ -16131,35 +21166,23 @@
(* 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 weight = real;
+
+type modelParameters =
+ {model : Model.parameters,
+ initialPerturbations : int,
+ maxChecks : int option,
+ perturbations : int,
+ weight : weight}
type parameters =
- {symbolsWeight : real,
- literalsWeight : real,
- modelsWeight : real,
- modelChecks : int,
- models : Model.parameters list};
+ {symbolsWeight : weight,
+ variablesWeight : weight,
+ literalsWeight : weight,
+ models : modelParameters list};
type distance = real;
-type weight = real;
-
datatype waiting =
Waiting of
{parameters : parameters,
@@ -16170,27 +21193,105 @@
(* Basic operations. *)
(* ------------------------------------------------------------------------- *)
+val defaultModels : modelParameters list =
+ [(* MODIFIED by Jasmin Blanchette
+ {model = Model.default,
+ initialPerturbations = 100,
+ maxChecks = SOME 20,
+ perturbations = 0,
+ weight = 1.0} *)];
+
val default : parameters =
{symbolsWeight = 1.0,
- literalsWeight = 0.0,
- modelsWeight = 0.0,
- modelChecks = 20,
- models = []};
+ literalsWeight = (* 1.0 *) 0.0, (* MODIFIED by Jasmin Blanchette *)
+ variablesWeight = (* 1.0 *) 0.0, (* MODIFIED by Jasmin Blanchette *)
+ models = defaultModels};
fun size (Waiting {clauses,...}) = Heap.size clauses;
val pp =
- Parser.ppMap
+ Print.ppMap
(fn w => "Waiting{" ^ Int.toString (size w) ^ "}")
- Parser.ppString;
-
-(*DEBUG
+ Print.ppString;
+
+(*MetisDebug
val pp =
- Parser.ppMap
+ Print.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));
-*)
+ (Print.ppList (Print.ppTriple Print.ppReal Print.ppInt Clause.pp));
+*)
+
+(* ------------------------------------------------------------------------- *)
+(* Perturbing the models. *)
+(* ------------------------------------------------------------------------- *)
+
+type modelClause = NameSet.set * Thm.clause;
+
+fun mkModelClause cl =
+ let
+ val lits = Clause.literals cl
+ val fvs = LiteralSet.freeVars lits
+ in
+ (fvs,lits)
+ end;
+
+val mkModelClauses = map mkModelClause;
+
+fun perturbModel M cls =
+ if null cls then K ()
+ else
+ let
+ val N = {size = Model.size M}
+
+ fun perturbClause (fv,cl) =
+ let
+ val V = Model.randomValuation N fv
+ in
+ if Model.interpretClause M V cl then ()
+ else Model.perturbClause M V cl
+ end
+
+ fun perturbClauses () = app perturbClause cls
+ in
+ fn n => funpow n perturbClauses ()
+ end;
+
+fun initialModel axioms conjecture parm =
+ let
+ val {model,initialPerturbations,...} : modelParameters = parm
+ val m = Model.new model
+ val () = perturbModel m conjecture initialPerturbations
+ val () = perturbModel m axioms initialPerturbations
+ in
+ m
+ end;
+
+fun checkModels parms models (fv,cl) =
+ let
+ fun check ((parm,model),z) =
+ let
+ val {maxChecks,weight,...} : modelParameters = parm
+ val n = {maxChecks = maxChecks}
+ val {T,F} = Model.check Model.interpretClause n model fv cl
+ in
+ Math.pow (1.0 + Real.fromInt T / Real.fromInt (T + F), weight) * z
+ end
+ in
+ List.foldl check 1.0 (zip parms models)
+ end;
+
+fun perturbModels parms models cls =
+ let
+ fun perturb (parm,model) =
+ let
+ val {perturbations,...} : modelParameters = parm
+ in
+ perturbModel model cls perturbations
+ end
+ in
+ app perturb (zip parms models)
+ end;
(* ------------------------------------------------------------------------- *)
(* Clause weights. *)
@@ -16199,40 +21300,39 @@
local
fun clauseSymbols cl = Real.fromInt (LiteralSet.typedSymbols cl);
+ fun clauseVariables cl =
+ Real.fromInt (NameSet.size (LiteralSet.freeVars cl) + 1);
+
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
+ fun clausePriority cl = 1e~12 * Real.fromInt (Clause.id cl);
+in
+ fun clauseWeight (parm : parameters) mods dist mcl cl =
+ let
+(*MetisTrace3
+ val () = Print.trace Clause.pp "Waiting.clauseWeight: cl" cl
+*)
+ val {symbolsWeight,variablesWeight,literalsWeight,models,...} = parm
val lits = Clause.literals cl
val symbolsW = Math.pow (clauseSymbols lits, symbolsWeight)
+ val variablesW = Math.pow (clauseVariables lits, variablesWeight)
val literalsW = Math.pow (clauseLiterals lits, literalsWeight)
- val modelsW = Math.pow (clauseSat modelChecks models lits, modelsWeight)
-(*TRACE4
+ val modelsW = (* checkModels models mods mcl *) 1.0 (* MODIFIED by Jasmin Blanchette *)
+(*MetisTrace4
val () = trace ("Waiting.clauseWeight: dist = " ^
Real.toString dist ^ "\n")
val () = trace ("Waiting.clauseWeight: symbolsW = " ^
Real.toString symbolsW ^ "\n")
+ val () = trace ("Waiting.clauseWeight: variablesW = " ^
+ Real.toString variablesW ^ "\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 weight = dist * symbolsW * variablesW * literalsW * modelsW
+ val weight = weight + clausePriority cl
+(*MetisTrace3
val () = trace ("Waiting.clauseWeight: weight = " ^
Real.toString weight ^ "\n")
*)
@@ -16245,29 +21345,39 @@
(* 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
-*)
-
+fun add' waiting dist mcls cls =
+ let
val Waiting {parameters,clauses,models} = waiting
+ val {models = modelParameters, ...} = parameters
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
+ fun addCl ((mcl,cl),acc) =
+ let
+ val weight = clauseWeight parameters models dist mcl cl
+ in
+ Heap.add acc (weight,(dist,cl))
+ end
+
+ val clauses = List.foldl addCl clauses (zip mcls cls)
+
+ val () = perturbModels modelParameters models mcls
+ in
+ Waiting {parameters = parameters, clauses = clauses, models = models}
+ end;
+
+fun add waiting (_,[]) = waiting
+ | add waiting (dist,cls) =
+ let
+(*MetisTrace3
+ val () = Print.trace pp "Waiting.add: waiting" waiting
+ val () = Print.trace (Print.ppList Clause.pp) "Waiting.add: cls" cls
+*)
+
+ val waiting = add' waiting dist (mkModelClauses cls) cls
+
+(*MetisTrace3
+ val () = Print.trace pp "Waiting.add: waiting" waiting
*)
in
waiting
@@ -16276,15 +21386,24 @@
local
fun cmp ((w1,_),(w2,_)) = Real.compare (w1,w2);
- fun empty parameters =
- let
+ fun empty parameters axioms conjecture =
+ let
+ val {models = modelParameters, ...} = parameters
val clauses = Heap.new cmp
- and models = map Model.new (#models parameters)
+ and models = map (initialModel axioms conjecture) modelParameters
in
Waiting {parameters = parameters, clauses = clauses, models = models}
end;
in
- fun new parameters cls = add (empty parameters) (0.0,cls);
+ fun new parameters {axioms,conjecture} =
+ let
+ val mAxioms = mkModelClauses axioms
+ and mConjecture = mkModelClauses conjecture
+
+ val waiting = empty parameters mAxioms mConjecture
+ in
+ add' waiting 0.0 (mAxioms @ mConjecture) (axioms @ conjecture)
+ end;
end;
(* ------------------------------------------------------------------------- *)
@@ -16310,7 +21429,7 @@
(* ========================================================================= *)
(* THE RESOLUTION PROOF PROCEDURE *)
-(* Copyright (c) 2001-2007 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001-2007 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Resolution =
@@ -16332,13 +21451,15 @@
val default : parameters
-val new : parameters -> Metis.Thm.thm list -> resolution
+val new :
+ parameters -> {axioms : Metis.Thm.thm list, conjecture : Metis.Thm.thm list} ->
+ resolution
val active : resolution -> Metis.Active.active
val waiting : resolution -> Metis.Waiting.waiting
-val pp : resolution Metis.Parser.pp
+val pp : resolution Metis.Print.pp
(* ------------------------------------------------------------------------- *)
(* The main proof loop. *)
@@ -16362,7 +21483,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -16371,7 +21492,7 @@
(* ========================================================================= *)
(* THE RESOLUTION PROOF PROCEDURE *)
-(* Copyright (c) 2001-2007 Joe Hurd, distributed under the BSD License *)
+(* Copyright (c) 2001-2007 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Resolution :> Resolution =
@@ -16380,7 +21501,7 @@
open Useful;
(* ------------------------------------------------------------------------- *)
-(* Parameters. *)
+(* A type of resolution proof procedures. *)
(* ------------------------------------------------------------------------- *)
type parameters =
@@ -16415,11 +21536,11 @@
fun waiting (Resolution {waiting = w, ...}) = w;
val pp =
- Parser.ppMap
+ Print.ppMap
(fn Resolution {active,waiting,...} =>
"Resolution(" ^ Int.toString (Active.size active) ^
"<-" ^ Int.toString (Waiting.size waiting) ^ ")")
- Parser.ppString;
+ Print.ppString;
(* ------------------------------------------------------------------------- *)
(* The main proof loop. *)
@@ -16436,21 +21557,21 @@
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
+(*MetisTrace2
+ val () = Print.trace Active.pp "Resolution.iterate: active" active
+ val () = Print.trace Waiting.pp "Resolution.iterate: waiting" waiting
*)
in
case Waiting.remove waiting of
NONE =>
- Decided (Satisfiable (map Clause.thm (Active.saturated active)))
+ Decided (Satisfiable (map Clause.thm (Active.saturation 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
+(*MetisTrace1
+ val () = Print.trace Clause.pp "Resolution.iterate: cl" cl
*)
val (active,cls) = Active.add active cl
val waiting = Waiting.add waiting (d,cls)
@@ -16472,20 +21593,75 @@
(**** Original file: Tptp.sig ****)
(* ========================================================================= *)
-(* THE TPTP PROBLEM FILE FORMAT (TPTP v2) *)
-(* Copyright (c) 2001-2007 Joe Hurd, distributed under the BSD License *)
+(* THE TPTP PROBLEM FILE FORMAT *)
+(* Copyright (c) 2001 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
signature Tptp =
sig
(* ------------------------------------------------------------------------- *)
-(* Mapping TPTP functions and relations to different names. *)
-(* ------------------------------------------------------------------------- *)
-
-val functionMapping : {name : string, arity : int, tptp : string} list Unsynchronized.ref
-
-val relationMapping : {name : string, arity : int, tptp : string} list Unsynchronized.ref
+(* Mapping to and from TPTP variable, function and relation names. *)
+(* ------------------------------------------------------------------------- *)
+
+type mapping
+
+val defaultMapping : mapping
+
+val mkMapping :
+ {functionMapping : {name : Metis.Name.name, arity : int, tptp : string} list,
+ relationMapping : {name : Metis.Name.name, arity : int, tptp : string} list} ->
+ mapping
+
+val addVarSetMapping : mapping -> Metis.NameSet.set -> mapping
+
+(* ------------------------------------------------------------------------- *)
+(* Interpreting TPTP functions and relations in a finite model. *)
+(* ------------------------------------------------------------------------- *)
+
+val defaultFixedMap : Metis.Model.fixedMap
+
+val defaultModel : Metis.Model.parameters
+
+val ppFixedMap : mapping -> Metis.Model.fixedMap Metis.Print.pp
+
+(* ------------------------------------------------------------------------- *)
+(* TPTP roles. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype role =
+ AxiomRole
+ | ConjectureRole
+ | DefinitionRole
+ | NegatedConjectureRole
+ | PlainRole
+ | TheoremRole
+ | OtherRole of string;
+
+val isCnfConjectureRole : role -> bool
+
+val isFofConjectureRole : role -> bool
+
+val toStringRole : role -> string
+
+val fromStringRole : string -> role
+
+val ppRole : role Metis.Print.pp
+
+(* ------------------------------------------------------------------------- *)
+(* SZS statuses. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype status =
+ CounterSatisfiableStatus
+ | TheoremStatus
+ | SatisfiableStatus
+ | UnknownStatus
+ | UnsatisfiableStatus
+
+val toStringStatus : status -> string
+
+val ppStatus : status Metis.Print.pp
(* ------------------------------------------------------------------------- *)
(* TPTP literals. *)
@@ -16495,67 +21671,153 @@
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
+val negateLiteral : literal -> literal
+
+val functionsLiteral : literal -> Metis.NameAritySet.set
+
+val relationLiteral : literal -> Metis.Atom.relation option
+
+val freeVarsLiteral : literal -> Metis.NameSet.set
+
+(* ------------------------------------------------------------------------- *)
+(* TPTP formula names. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype formulaName =
+ FormulaName of string
+
+val ppFormulaName : formulaName Metis.Print.pp
+
+(* ------------------------------------------------------------------------- *)
+(* TPTP formula bodies. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype formulaBody =
+ CnfFormulaBody of literal list
+ | FofFormulaBody of Metis.Formula.formula
+
+(* ------------------------------------------------------------------------- *)
+(* TPTP formula sources. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype formulaSource =
+ NoFormulaSource
+ | StripFormulaSource of
+ {inference : string,
+ parents : formulaName list}
+ | NormalizeFormulaSource of
+ {inference : Metis.Normalize.inference,
+ parents : formulaName list}
+ | ProofFormulaSource of
+ {inference : Metis.Proof.inference,
+ parents : formulaName list}
(* ------------------------------------------------------------------------- *)
(* 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
+ Formula of
+ {name : formulaName,
+ role : role,
+ body : formulaBody,
+ source : formulaSource}
+
+val nameFormula : formula -> formulaName
+
+val roleFormula : formula -> role
+
+val bodyFormula : formula -> formulaBody
+
+val sourceFormula : formula -> formulaSource
+
+val functionsFormula : formula -> Metis.NameAritySet.set
+
+val relationsFormula : formula -> Metis.NameAritySet.set
+
+val freeVarsFormula : formula -> Metis.NameSet.set
+
+val freeVarsListFormula : formula list -> Metis.NameSet.set
+
+val isCnfConjectureFormula : formula -> bool
+val isFofConjectureFormula : formula -> bool
+val isConjectureFormula : formula -> bool
+
+(* ------------------------------------------------------------------------- *)
+(* Clause information. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype clauseSource =
+ CnfClauseSource of formulaName * literal list
+ | FofClauseSource of Metis.Normalize.thm
+
+type 'a clauseInfo = 'a Metis.LiteralSetMap.map
+
+type clauseNames = formulaName clauseInfo
+
+type clauseRoles = role clauseInfo
+
+type clauseSources = clauseSource clauseInfo
+
+val noClauseNames : clauseNames
+
+val noClauseRoles : clauseRoles
+
+val noClauseSources : clauseSources
(* ------------------------------------------------------------------------- *)
(* 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
-
+type comments = string list
+
+type includes = string list
+
+datatype problem =
+ Problem of
+ {comments : comments,
+ includes : includes,
+ formulas : formula list}
+
+val hasCnfConjecture : problem -> bool
+val hasFofConjecture : problem -> bool
val hasConjecture : problem -> bool
-val toGoal : problem -> goal
-
-val fromProblem : Metis.Problem.problem -> problem
-
-val prove : {filename : string} -> bool
+val freeVars : problem -> Metis.NameSet.set
+
+val mkProblem :
+ {comments : comments,
+ includes : includes,
+ names : clauseNames,
+ roles : clauseRoles,
+ problem : Metis.Problem.problem} -> problem
+
+val normalize :
+ problem ->
+ {subgoal : Metis.Formula.formula * formulaName list,
+ problem : Metis.Problem.problem,
+ sources : clauseSources} list
+
+val goal : problem -> Metis.Formula.formula
+
+val read : {mapping : mapping, filename : string} -> problem
+
+val write :
+ {problem : problem,
+ mapping : mapping,
+ filename : string} -> unit
+
+val prove : {filename : string, mapping : mapping} -> bool
(* ------------------------------------------------------------------------- *)
(* TSTP proofs. *)
(* ------------------------------------------------------------------------- *)
-val ppProof : Metis.Proof.proof Metis.Parser.pp
-
-val proofToString : Metis.Proof.proof -> string
+val fromProof :
+ {problem : problem,
+ proofs : {subgoal : Metis.Formula.formula * formulaName list,
+ sources : clauseSources,
+ refutation : Metis.Thm.thm} list} -> formula list
end
@@ -16563,7 +21825,7 @@
structure Metis = struct open Metis
(* Metis-specific ML environment *)
-nonfix ++ -- RL mem;
+nonfix ++ -- RL;
val explode = String.explode;
val implode = String.implode;
val print = TextIO.print;
@@ -16571,8 +21833,8 @@
val foldr = List.foldr;
(* ========================================================================= *)
-(* THE TPTP PROBLEM FILE FORMAT (TPTP v2) *)
-(* Copyright (c) 2001-2007 Joe Hurd, distributed under the BSD License *)
+(* THE TPTP PROBLEM FILE FORMAT *)
+(* Copyright (c) 2001 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)
structure Tptp :> Tptp =
@@ -16581,11 +21843,95 @@
open Useful;
(* ------------------------------------------------------------------------- *)
-(* Constants. *)
-(* ------------------------------------------------------------------------- *)
-
-val ROLE_NEGATED_CONJECTURE = "negated_conjecture"
-and ROLE_CONJECTURE = "conjecture";
+(* Default TPTP function and relation name mapping. *)
+(* ------------------------------------------------------------------------- *)
+
+val defaultFunctionMapping =
+ [(* Mapping TPTP functions to infix symbols *)
+ {name = "~", arity = 1, tptp = "negate"},
+ {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 = "append"},
+ {name = ",", arity = 2, tptp = "pair"},
+ (* Expanding HOL symbols to TPTP alphanumerics *)
+ {name = ":", arity = 2, tptp = "has_type"},
+ {name = ".", arity = 2, tptp = "apply"}];
+
+val defaultRelationMapping =
+ [(* Mapping TPTP relations to infix symbols *)
+ {name = "=", arity = 2, tptp = "="}, (* this preserves the = symbol *)
+ {name = "==", arity = 2, tptp = "equalish"},
+ {name = "<=", arity = 2, tptp = "less_equal"},
+ {name = "<", arity = 2, tptp = "less_than"},
+ {name = ">=", arity = 2, tptp = "greater_equal"},
+ {name = ">", arity = 2, tptp = "greater_than"},
+ (* Expanding HOL symbols to TPTP alphanumerics *)
+ {name = "{}", arity = 1, tptp = "bool"}];
+
+(* ------------------------------------------------------------------------- *)
+(* Interpreting TPTP functions and relations in a finite model. *)
+(* ------------------------------------------------------------------------- *)
+
+val defaultFunctionModel =
+ [{name = "~", arity = 1, model = Model.negName},
+ {name = "*", arity = 2, model = Model.multName},
+ {name = "/", arity = 2, model = Model.divName},
+ {name = "+", arity = 2, model = Model.addName},
+ {name = "-", arity = 2, model = Model.subName},
+ {name = "::", arity = 2, model = Model.consName},
+ {name = "@", arity = 2, model = Model.appendName},
+ {name = ":", arity = 2, model = Term.hasTypeFunctionName},
+ {name = "additive_identity", arity = 0, model = Model.numeralName 0},
+ {name = "app", arity = 2, model = Model.appendName},
+ {name = "complement", arity = 1, model = Model.complementName},
+ {name = "difference", arity = 2, model = Model.differenceName},
+ {name = "divide", arity = 2, model = Model.divName},
+ {name = "empty_set", arity = 0, model = Model.emptyName},
+ {name = "identity", arity = 0, model = Model.numeralName 1},
+ {name = "identity_map", arity = 1, model = Model.projectionName 1},
+ {name = "intersection", arity = 2, model = Model.intersectName},
+ {name = "minus", arity = 1, model = Model.negName},
+ {name = "multiplicative_identity", arity = 0, model = Model.numeralName 1},
+ {name = "n0", arity = 0, model = Model.numeralName 0},
+ {name = "n1", arity = 0, model = Model.numeralName 1},
+ {name = "n2", arity = 0, model = Model.numeralName 2},
+ {name = "n3", arity = 0, model = Model.numeralName 3},
+ {name = "n4", arity = 0, model = Model.numeralName 4},
+ {name = "n5", arity = 0, model = Model.numeralName 5},
+ {name = "n6", arity = 0, model = Model.numeralName 6},
+ {name = "n7", arity = 0, model = Model.numeralName 7},
+ {name = "n8", arity = 0, model = Model.numeralName 8},
+ {name = "n9", arity = 0, model = Model.numeralName 9},
+ {name = "nil", arity = 0, model = Model.nilName},
+ {name = "null_class", arity = 0, model = Model.emptyName},
+ {name = "singleton", arity = 1, model = Model.singletonName},
+ {name = "successor", arity = 1, model = Model.sucName},
+ {name = "symmetric_difference", arity = 2,
+ model = Model.symmetricDifferenceName},
+ {name = "union", arity = 2, model = Model.unionName},
+ {name = "universal_class", arity = 0, model = Model.universeName}];
+
+val defaultRelationModel =
+ [{name = "=", arity = 2, model = Atom.eqRelationName},
+ {name = "==", arity = 2, model = Atom.eqRelationName},
+ {name = "<=", arity = 2, model = Model.leName},
+ {name = "<", arity = 2, model = Model.ltName},
+ {name = ">=", arity = 2, model = Model.geName},
+ {name = ">", arity = 2, model = Model.gtName},
+ {name = "divides", arity = 2, model = Model.dividesName},
+ {name = "element_of_set", arity = 2, model = Model.memberName},
+ {name = "equal", arity = 2, model = Atom.eqRelationName},
+ {name = "equal_elements", arity = 2, model = Atom.eqRelationName},
+ {name = "equal_sets", arity = 2, model = Atom.eqRelationName},
+ {name = "equivalent", arity = 2, model = Atom.eqRelationName},
+ {name = "less", arity = 2, model = Model.ltName},
+ {name = "less_or_equal", arity = 2, model = Model.leName},
+ {name = "member", arity = 2, model = Model.memberName},
+ {name = "subclass", arity = 2, model = Model.subsetName},
+ {name = "subset", arity = 2, model = Model.subsetName}];
(* ------------------------------------------------------------------------- *)
(* Helper functions. *)
@@ -16601,97 +21947,451 @@
n > 0 andalso hp (String.sub (s,0)) andalso ct (n - 1)
end;
-(* ------------------------------------------------------------------------- *)
-(* Mapping TPTP functions and relations to different names. *)
-(* ------------------------------------------------------------------------- *)
-
-val functionMapping = Unsynchronized.ref
- [(* Mapping TPTP functions to infix symbols *)
- {name = "*", arity = 2, tptp = "multiply"},
- {name = "/", arity = 2, tptp = "divide"},
- {name = "+", arity = 2, tptp = "add"},
- {name = "-", arity = 2, tptp = "subtract"},
- {name = "::", arity = 2, tptp = "cons"},
- {name = ",", arity = 2, tptp = "pair"},
- (* Expanding HOL symbols to TPTP alphanumerics *)
- {name = ":", arity = 2, tptp = "has_type"},
- {name = ".", arity = 2, tptp = "apply"},
- {name = "<=", arity = 0, tptp = "less_equal"}];
-
-val relationMapping = Unsynchronized.ref
- [(* Mapping TPTP relations to infix symbols *)
- {name = "=", arity = 2, tptp = "="},
- {name = "==", arity = 2, tptp = "equalish"},
- {name = "<=", arity = 2, tptp = "less_equal"},
- {name = "<", arity = 2, tptp = "less_than"},
- (* Expanding HOL symbols to TPTP alphanumerics *)
- {name = "{}", arity = 1, tptp = "bool"}];
-
-fun mappingToTptp x =
- let
- fun mk ({name,arity,tptp},m) = NameArityMap.insert m ((name,arity),tptp)
- in
- foldl mk (NameArityMap.new ()) x
- end;
-
-fun mappingFromTptp x =
- let
- fun mk ({name,arity,tptp},m) = NameArityMap.insert m ((tptp,arity),name)
- in
- foldl mk (NameArityMap.new ()) x
- end;
-
-fun findMapping mapping (name_arity as (n,_)) =
- Option.getOpt (NameArityMap.peek mapping name_arity, n);
-
-fun mapTerm functionMap =
- let
- val mapName = findMapping functionMap
-
- fun mapTm (tm as Term.Var _) = tm
- | mapTm (Term.Fn (f,a)) = Term.Fn (mapName (f, length a), map mapTm a)
- in
- mapTm
- end;
-
-fun mapAtom {functionMap,relationMap} (p,a) =
- (findMapping relationMap (p, length a), map (mapTerm functionMap) a);
-
-fun mapFof maps =
- let
- open Formula
-
- fun form True = True
- | form False = False
- | form (Atom a) = Atom (mapAtom maps a)
- | form (Not p) = Not (form p)
- | form (And (p,q)) = And (form p, form q)
- | form (Or (p,q)) = Or (form p, form q)
- | form (Imp (p,q)) = Imp (form p, form q)
- | form (Iff (p,q)) = Iff (form p, form q)
- | form (Forall (v,p)) = Forall (v, form p)
- | form (Exists (v,p)) = Exists (v, form p)
- in
- form
- end;
-
-(* ------------------------------------------------------------------------- *)
-(* Comments. *)
-(* ------------------------------------------------------------------------- *)
-
-fun mkComment "" = "%"
- | mkComment line = "% " ^ line;
-
-fun destComment "" = ""
- | destComment l =
- let
- val _ = String.sub (l,0) = #"%" orelse raise Error "destComment"
- val n = if size l >= 2 andalso String.sub (l,1) = #" " then 2 else 1
- in
- String.extract (l,n,NONE)
- end;
-
-val isComment = can destComment;
+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;
+
+fun variant avoid s =
+ if not (StringSet.member s avoid) then s
+ else
+ let
+ val s = stripSuffix Char.isDigit s
+
+ fun var i =
+ let
+ val s_i = s ^ Int.toString i
+ in
+ if not (StringSet.member s_i avoid) then s_i else var (i + 1)
+ end
+ in
+ var 0
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Mapping to legal TPTP names. *)
+(* ------------------------------------------------------------------------- *)
+
+local
+ fun nonEmptyPred p l =
+ case l of
+ [] => false
+ | c :: cs => p (c,cs);
+
+ fun existsPred l x = List.exists (fn p => p x) l;
+
+ fun isTptpChar #"_" = true
+ | isTptpChar c = Char.isAlphaNum c;
+
+ fun isTptpName l s = nonEmptyPred (existsPred l) (explode s);
+
+ fun isRegular (c,cs) =
+ Char.isLower c andalso List.all isTptpChar cs;
+
+ fun isNumber (c,cs) =
+ Char.isDigit c andalso List.all Char.isDigit cs;
+
+ fun isDefined (c,cs) =
+ c = #"$" andalso nonEmptyPred isRegular cs;
+
+ fun isSystem (c,cs) =
+ c = #"$" andalso nonEmptyPred isDefined cs;
+in
+ fun mkTptpVarName s =
+ let
+ val s =
+ case List.filter isTptpChar (explode s) of
+ [] => [#"X"]
+ | l as c :: cs =>
+ if Char.isUpper c then l
+ else if Char.isLower c then Char.toUpper c :: cs
+ else #"X" :: l
+ in
+ implode s
+ end;
+
+ val isTptpConstName = isTptpName [isRegular,isNumber,isDefined,isSystem]
+ and isTptpFnName = isTptpName [isRegular,isDefined,isSystem]
+ and isTptpPropName = isTptpName [isRegular,isDefined,isSystem]
+ and isTptpRelName = isTptpName [isRegular,isDefined,isSystem];
+
+ val isTptpFormulaName = isTptpName [isRegular,isNumber];
+end;
+
+(* ------------------------------------------------------------------------- *)
+(* Mapping to legal TPTP variable names. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype varToTptp = VarToTptp of StringSet.set * string NameMap.map;
+
+val emptyVarToTptp = VarToTptp (StringSet.empty, NameMap.new ());
+
+fun addVarToTptp vm v =
+ let
+ val VarToTptp (avoid,mapping) = vm
+ in
+ if NameMap.inDomain v mapping then vm
+ else
+ let
+ val s = variant avoid (mkTptpVarName (Name.toString v))
+
+ val avoid = StringSet.add avoid s
+ and mapping = NameMap.insert mapping (v,s)
+ in
+ VarToTptp (avoid,mapping)
+ end
+ end;
+
+local
+ fun add (v,vm) = addVarToTptp vm v;
+in
+ val addListVarToTptp = List.foldl add;
+
+ val addSetVarToTptp = NameSet.foldl add;
+end;
+
+val fromListVarToTptp = addListVarToTptp emptyVarToTptp;
+
+val fromSetVarToTptp = addSetVarToTptp emptyVarToTptp;
+
+fun getVarToTptp vm v =
+ let
+ val VarToTptp (_,mapping) = vm
+ in
+ case NameMap.peek mapping v of
+ SOME s => s
+ | NONE => raise Bug "Tptp.getVarToTptp: unknown var"
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Mapping from TPTP variable names. *)
+(* ------------------------------------------------------------------------- *)
+
+fun getVarFromTptp s = Name.fromString s;
+
+(* ------------------------------------------------------------------------- *)
+(* Mapping to TPTP function and relation names. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype nameToTptp = NameToTptp of string NameArityMap.map;
+
+local
+ val emptyNames : string NameArityMap.map = NameArityMap.new ();
+
+ fun addNames ({name,arity,tptp},mapping) =
+ NameArityMap.insert mapping ((name,arity),tptp);
+
+ val fromListNames = List.foldl addNames emptyNames;
+in
+ fun mkNameToTptp mapping = NameToTptp (fromListNames mapping);
+end;
+
+local
+ fun escapeChar c =
+ case c of
+ #"\\" => "\\\\"
+ | #"'" => "\\'"
+ | #"\n" => "\\n"
+ | #"\t" => "\\t"
+ | _ => str c;
+
+ val escapeString = String.translate escapeChar;
+in
+ fun singleQuote s = "'" ^ escapeString s ^ "'";
+end;
+
+fun getNameToTptp isTptp s = if isTptp s then s else singleQuote s;
+
+fun getNameArityToTptp isZeroTptp isPlusTptp (NameToTptp mapping) na =
+ case NameArityMap.peek mapping na of
+ SOME s => s
+ | NONE =>
+ let
+ val (n,a) = na
+ val isTptp = if a = 0 then isZeroTptp else isPlusTptp
+ val s = Name.toString n
+ in
+ getNameToTptp isTptp s
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Mapping from TPTP function and relation names. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype nameFromTptp = NameFromTptp of (string * int, Name.name) Map.map;
+
+local
+ val stringArityCompare = prodCompare String.compare Int.compare;
+
+ val emptyStringArityMap = Map.new stringArityCompare;
+
+ fun addStringArityMap ({name,arity,tptp},mapping) =
+ Map.insert mapping ((tptp,arity),name);
+
+ val fromListStringArityMap =
+ List.foldl addStringArityMap emptyStringArityMap;
+in
+ fun mkNameFromTptp mapping = NameFromTptp (fromListStringArityMap mapping);
+end;
+
+fun getNameFromTptp (NameFromTptp mapping) sa =
+ case Map.peek mapping sa of
+ SOME n => n
+ | NONE =>
+ let
+ val (s,_) = sa
+ in
+ Name.fromString s
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Mapping to and from TPTP variable, function and relation names. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype mapping =
+ Mapping of
+ {varTo : varToTptp,
+ fnTo : nameToTptp,
+ relTo : nameToTptp,
+ fnFrom : nameFromTptp,
+ relFrom : nameFromTptp};
+
+fun mkMapping mapping =
+ let
+ val {functionMapping,relationMapping} = mapping
+
+ val varTo = emptyVarToTptp
+ val fnTo = mkNameToTptp functionMapping
+ val relTo = mkNameToTptp relationMapping
+
+ val fnFrom = mkNameFromTptp functionMapping
+ val relFrom = mkNameFromTptp relationMapping
+ in
+ Mapping
+ {varTo = varTo,
+ fnTo = fnTo,
+ relTo = relTo,
+ fnFrom = fnFrom,
+ relFrom = relFrom}
+ end;
+
+fun addVarListMapping mapping vs =
+ let
+ val Mapping
+ {varTo,
+ fnTo,
+ relTo,
+ fnFrom,
+ relFrom} = mapping
+
+ val varTo = addListVarToTptp varTo vs
+ in
+ Mapping
+ {varTo = varTo,
+ fnTo = fnTo,
+ relTo = relTo,
+ fnFrom = fnFrom,
+ relFrom = relFrom}
+ end;
+
+fun addVarSetMapping mapping vs =
+ let
+ val Mapping
+ {varTo,
+ fnTo,
+ relTo,
+ fnFrom,
+ relFrom} = mapping
+
+ val varTo = addSetVarToTptp varTo vs
+ in
+ Mapping
+ {varTo = varTo,
+ fnTo = fnTo,
+ relTo = relTo,
+ fnFrom = fnFrom,
+ relFrom = relFrom}
+ end;
+
+fun varToTptp mapping v =
+ let
+ val Mapping {varTo,...} = mapping
+ in
+ getVarToTptp varTo v
+ end;
+
+fun fnToTptp mapping fa =
+ let
+ val Mapping {fnTo,...} = mapping
+ in
+ getNameArityToTptp isTptpConstName isTptpFnName fnTo fa
+ end;
+
+fun relToTptp mapping ra =
+ let
+ val Mapping {relTo,...} = mapping
+ in
+ getNameArityToTptp isTptpPropName isTptpRelName relTo ra
+ end;
+
+fun varFromTptp (_ : mapping) v = getVarFromTptp v;
+
+fun fnFromTptp mapping fa =
+ let
+ val Mapping {fnFrom,...} = mapping
+ in
+ getNameFromTptp fnFrom fa
+ end;
+
+fun relFromTptp mapping ra =
+ let
+ val Mapping {relFrom,...} = mapping
+ in
+ getNameFromTptp relFrom ra
+ end;
+
+val defaultMapping =
+ let
+ fun lift {name,arity,tptp} =
+ {name = Name.fromString name, arity = arity, tptp = tptp}
+
+ val functionMapping = map lift defaultFunctionMapping
+ and relationMapping = map lift defaultRelationMapping
+
+ val mapping =
+ {functionMapping = functionMapping,
+ relationMapping = relationMapping}
+ in
+ mkMapping mapping
+ end;
+
+(* ------------------------------------------------------------------------- *)
+(* Interpreting TPTP functions and relations in a finite model. *)
+(* ------------------------------------------------------------------------- *)
+
+fun mkFixedMap funcModel relModel =
+ let
+ fun mkEntry {name,arity,model} = ((Name.fromString name, arity), model)
+
+ fun mkMap l = NameArityMap.fromList (map mkEntry l)
+ in
+ {functionMap = mkMap funcModel,
+ relationMap = mkMap relModel}
+ end;
+
+val defaultFixedMap = mkFixedMap defaultFunctionModel defaultRelationModel;
+
+val defaultModel =
+ let
+ val {size = N, fixed = fix} = Model.default
+
+ val fix = Model.mapFixed defaultFixedMap fix
+ in
+ {size = N, fixed = fix}
+ end;
+
+local
+ fun toTptpMap toTptp =
+ let
+ fun add ((src,arity),dest,m) =
+ let
+ val src = Name.fromString (toTptp (src,arity))
+ in
+ NameArityMap.insert m ((src,arity),dest)
+ end
+ in
+ fn m => NameArityMap.foldl add (NameArityMap.new ()) m
+ end;
+
+ fun toTptpFixedMap mapping fixMap =
+ let
+ val {functionMap = fnMap, relationMap = relMap} = fixMap
+
+ val fnMap = toTptpMap (fnToTptp mapping) fnMap
+ and relMap = toTptpMap (relToTptp mapping) relMap
+ in
+ {functionMap = fnMap,
+ relationMap = relMap}
+ end;
+in
+ fun ppFixedMap mapping fixMap =
+ Model.ppFixedMap (toTptpFixedMap mapping fixMap);
+end;
+
+(* ------------------------------------------------------------------------- *)
+(* TPTP roles. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype role =
+ AxiomRole
+ | ConjectureRole
+ | DefinitionRole
+ | NegatedConjectureRole
+ | PlainRole
+ | TheoremRole
+ | OtherRole of string;
+
+fun isCnfConjectureRole role =
+ case role of
+ NegatedConjectureRole => true
+ | _ => false;
+
+fun isFofConjectureRole role =
+ case role of
+ ConjectureRole => true
+ | _ => false;
+
+fun toStringRole role =
+ case role of
+ AxiomRole => "axiom"
+ | ConjectureRole => "conjecture"
+ | DefinitionRole => "definition"
+ | NegatedConjectureRole => "negated_conjecture"
+ | PlainRole => "plain"
+ | TheoremRole => "theorem"
+ | OtherRole s => s;
+
+fun fromStringRole s =
+ case s of
+ "axiom" => AxiomRole
+ | "conjecture" => ConjectureRole
+ | "definition" => DefinitionRole
+ | "negated_conjecture" => NegatedConjectureRole
+ | "plain" => PlainRole
+ | "theorem" => TheoremRole
+ | _ => OtherRole s;
+
+val ppRole = Print.ppMap toStringRole Print.ppString;
+
+(* ------------------------------------------------------------------------- *)
+(* SZS statuses. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype status =
+ CounterSatisfiableStatus
+ | TheoremStatus
+ | SatisfiableStatus
+ | UnknownStatus
+ | UnsatisfiableStatus;
+
+fun toStringStatus status =
+ case status of
+ CounterSatisfiableStatus => "CounterSatisfiable"
+ | TheoremStatus => "Theorem"
+ | SatisfiableStatus => "Satisfiable"
+ | UnknownStatus => "Unknown"
+ | UnsatisfiableStatus => "Unsatisfiable";
+
+val ppStatus = Print.ppMap toStringStatus Print.ppString;
(* ------------------------------------------------------------------------- *)
(* TPTP literals. *)
@@ -16701,14 +22401,29 @@
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 destLiteral lit =
+ case lit of
+ Literal l => l
+ | _ => raise Error "Tptp.destLiteral";
+
+fun isBooleanLiteral lit =
+ case lit of
+ Boolean _ => true
+ | _ => false;
+
+fun equalBooleanLiteral b lit =
+ case lit of
+ Boolean b' => b = b'
+ | _ => false;
+
+fun negateLiteral (Boolean b) = (Boolean (not b))
+ | negateLiteral (Literal l) = (Literal (Literal.negate l));
+
+fun functionsLiteral (Boolean _) = NameAritySet.empty
+ | functionsLiteral (Literal lit) = Literal.functions lit;
+
+fun relationLiteral (Boolean _) = NONE
+ | relationLiteral (Literal lit) = SOME (Literal.relation lit);
fun literalToFormula (Boolean true) = Formula.True
| literalToFormula (Boolean false) = Formula.False
@@ -16718,107 +22433,174 @@
| literalFromFormula Formula.False = Boolean false
| literalFromFormula fm = Literal (Literal.fromFormula fm);
-fun literalFreeVars (Boolean _) = NameSet.empty
- | literalFreeVars (Literal lit) = Literal.freeVars lit;
+fun freeVarsLiteral (Boolean _) = NameSet.empty
+ | freeVarsLiteral (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);
+fun ppVar mapping v =
+ let
+ val s = varToTptp mapping v
+ in
+ Print.addString s
+ end;
+
+fun ppFnName mapping fa = Print.addString (fnToTptp mapping fa);
+
+fun ppConst mapping c = ppFnName mapping (c,0);
+
+fun ppTerm mapping =
+ let
+ fun term tm =
+ case tm of
+ Term.Var v => ppVar mapping v
+ | Term.Fn (f,tms) =>
+ case length tms of
+ 0 => ppConst mapping f
+ | a =>
+ Print.blockProgram Print.Inconsistent 2
+ [ppFnName mapping (f,a),
+ Print.addString "(",
+ Print.ppOpList "," term tms,
+ Print.addString ")"]
+ in
+ Print.block Print.Inconsistent 0 o term
+ end;
+
+fun ppRelName mapping ra = Print.addString (relToTptp mapping ra);
+
+fun ppProp mapping p = ppRelName mapping (p,0);
+
+fun ppAtom mapping (r,tms) =
+ case length tms of
+ 0 => ppProp mapping r
+ | a =>
+ Print.blockProgram Print.Inconsistent 2
+ [ppRelName mapping (r,a),
+ Print.addString "(",
+ Print.ppOpList "," (ppTerm mapping) tms,
+ Print.addString ")"];
+
+local
+ val neg = Print.sequence (Print.addString "~") (Print.addBreak 1);
+
+ fun fof mapping fm =
+ case fm of
+ Formula.And _ => assoc_binary mapping ("&", Formula.stripConj fm)
+ | Formula.Or _ => assoc_binary mapping ("|", Formula.stripDisj fm)
+ | Formula.Imp a_b => nonassoc_binary mapping ("=>",a_b)
+ | Formula.Iff a_b => nonassoc_binary mapping ("<=>",a_b)
+ | _ => unitary mapping fm
+
+ and nonassoc_binary mapping (s,a_b) =
+ Print.ppOp2 (" " ^ s) (unitary mapping) (unitary mapping) a_b
+
+ and assoc_binary mapping (s,l) = Print.ppOpList (" " ^ s) (unitary mapping) l
+
+ and unitary mapping fm =
+ case fm of
+ Formula.True => Print.addString "$true"
+ | Formula.False => Print.addString "$false"
+ | Formula.Forall _ => quantified mapping ("!", Formula.stripForall fm)
+ | Formula.Exists _ => quantified mapping ("?", Formula.stripExists fm)
+ | Formula.Not _ =>
+ (case total Formula.destNeq fm of
+ SOME a_b => Print.ppOp2 " !=" (ppTerm mapping) (ppTerm mapping) a_b
+ | NONE =>
+ let
+ val (n,fm) = Formula.stripNeg fm
+ in
+ Print.blockProgram Print.Inconsistent 2
+ [Print.duplicate n neg,
+ unitary mapping fm]
+ end)
+ | Formula.Atom atm =>
+ (case total Formula.destEq fm of
+ SOME a_b => Print.ppOp2 " =" (ppTerm mapping) (ppTerm mapping) a_b
+ | NONE => ppAtom mapping atm)
+ | _ =>
+ Print.blockProgram Print.Inconsistent 1
+ [Print.addString "(",
+ fof mapping fm,
+ Print.addString ")"]
+
+ and quantified mapping (q,(vs,fm)) =
+ let
+ val mapping = addVarListMapping mapping vs
+ in
+ Print.blockProgram Print.Inconsistent 2
+ [Print.addString q,
+ Print.addString " ",
+ Print.blockProgram Print.Inconsistent (String.size q)
+ [Print.addString "[",
+ Print.ppOpList "," (ppVar mapping) vs,
+ Print.addString "] :"],
+ Print.addBreak 1,
+ unitary mapping fm]
+ end;
+in
+ fun ppFof mapping fm = Print.block Print.Inconsistent 0 (fof mapping fm);
+end;
+
+(* ------------------------------------------------------------------------- *)
+(* Lexing TPTP files. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype token =
+ AlphaNum of string
+ | Punct of char
+ | Quote of string;
+
+fun isAlphaNum #"_" = true
+ | isAlphaNum c = Char.isAlphaNum c;
+
+local
+ open Parse;
+
+ infixr 9 >>++
+ infixr 8 ++
+ infixr 7 >>
+ infixr 6 ||
+
+ 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 =
+ some (equal #"'") >> singleton ||
+ some (equal #"\\") >> singleton
+
+ fun stopOn #"'" = true
+ | stopOn #"\n" = true
+ | stopOn _ = false
+
+ val quotedParser =
+ some (equal #"\\") ++ escapeParser >> op:: ||
+ some (not o stopOn) >> singleton
+ in
+ exactChar #"'" ++ many quotedParser ++ exactChar #"'" >>
+ (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;
(* ------------------------------------------------------------------------- *)
@@ -16829,7 +22611,7 @@
val clauseFunctions =
let
- fun funcs (lit,acc) = NameAritySet.union (literalFunctions lit) acc
+ fun funcs (lit,acc) = NameAritySet.union (functionsLiteral lit) acc
in
foldl funcs NameAritySet.empty
end;
@@ -16837,7 +22619,7 @@
val clauseRelations =
let
fun rels (lit,acc) =
- case literalRelation lit of
+ case relationLiteral lit of
NONE => acc
| SOME r => NameAritySet.add acc r
in
@@ -16846,15 +22628,13 @@
val clauseFreeVars =
let
- fun fvs (lit,acc) = NameSet.union (literalFreeVars lit) acc
+ fun fvs (lit,acc) = NameSet.union (freeVarsLiteral 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);
@@ -16865,115 +22645,475 @@
fun clauseFromThm th = clauseFromLiteralSet (Thm.clause th);
-val ppClause = Parser.ppMap clauseToFormula ppFof;
+fun ppClause mapping = Print.ppMap clauseToFormula (ppFof mapping);
+
+(* ------------------------------------------------------------------------- *)
+(* TPTP formula names. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype formulaName = FormulaName of string;
+
+datatype formulaNameSet = FormulaNameSet of formulaName Set.set;
+
+fun compareFormulaName (FormulaName s1, FormulaName s2) =
+ String.compare (s1,s2);
+
+fun toTptpFormulaName (FormulaName s) =
+ getNameToTptp isTptpFormulaName s;
+
+val ppFormulaName = Print.ppMap toTptpFormulaName Print.ppString;
+
+val emptyFormulaNameSet = FormulaNameSet (Set.empty compareFormulaName);
+
+fun memberFormulaNameSet n (FormulaNameSet s) = Set.member n s;
+
+fun addFormulaNameSet (FormulaNameSet s) n = FormulaNameSet (Set.add s n);
+
+fun addListFormulaNameSet (FormulaNameSet s) l =
+ FormulaNameSet (Set.addList s l);
+
+(* ------------------------------------------------------------------------- *)
+(* TPTP formula bodies. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype formulaBody =
+ CnfFormulaBody of literal list
+ | FofFormulaBody of Formula.formula;
+
+fun destCnfFormulaBody body =
+ case body of
+ CnfFormulaBody x => x
+ | _ => raise Error "destCnfFormulaBody";
+
+val isCnfFormulaBody = can destCnfFormulaBody;
+
+fun destFofFormulaBody body =
+ case body of
+ FofFormulaBody x => x
+ | _ => raise Error "destFofFormulaBody";
+
+val isFofFormulaBody = can destFofFormulaBody;
+
+fun formulaBodyFunctions body =
+ case body of
+ CnfFormulaBody cl => clauseFunctions cl
+ | FofFormulaBody fm => Formula.functions fm;
+
+fun formulaBodyRelations body =
+ case body of
+ CnfFormulaBody cl => clauseRelations cl
+ | FofFormulaBody fm => Formula.relations fm;
+
+fun formulaBodyFreeVars body =
+ case body of
+ CnfFormulaBody cl => clauseFreeVars cl
+ | FofFormulaBody fm => Formula.freeVars fm;
+
+fun ppFormulaBody mapping body =
+ case body of
+ CnfFormulaBody cl => ppClause mapping cl
+ | FofFormulaBody fm => ppFof mapping (Formula.generalize fm);
+
+(* ------------------------------------------------------------------------- *)
+(* TPTP formula sources. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype formulaSource =
+ NoFormulaSource
+ | StripFormulaSource of
+ {inference : string,
+ parents : formulaName list}
+ | NormalizeFormulaSource of
+ {inference : Normalize.inference,
+ parents : formulaName list}
+ | ProofFormulaSource of
+ {inference : Proof.inference,
+ parents : formulaName list};
+
+fun isNoFormulaSource source =
+ case source of
+ NoFormulaSource => true
+ | _ => false;
+
+fun functionsFormulaSource source =
+ case source of
+ NoFormulaSource => NameAritySet.empty
+ | StripFormulaSource _ => NameAritySet.empty
+ | NormalizeFormulaSource data =>
+ let
+ val {inference = inf, parents = _} = data
+ in
+ case inf of
+ Normalize.Axiom fm => Formula.functions fm
+ | Normalize.Definition (_,fm) => Formula.functions fm
+ | _ => NameAritySet.empty
+ end
+ | ProofFormulaSource data =>
+ let
+ val {inference = inf, parents = _} = data
+ in
+ case inf of
+ Proof.Axiom cl => LiteralSet.functions cl
+ | Proof.Assume atm => Atom.functions atm
+ | Proof.Subst (sub,_) => Subst.functions sub
+ | Proof.Resolve (atm,_,_) => Atom.functions atm
+ | Proof.Refl tm => Term.functions tm
+ | Proof.Equality (lit,_,tm) =>
+ NameAritySet.union (Literal.functions lit) (Term.functions tm)
+ end;
+
+fun relationsFormulaSource source =
+ case source of
+ NoFormulaSource => NameAritySet.empty
+ | StripFormulaSource _ => NameAritySet.empty
+ | NormalizeFormulaSource data =>
+ let
+ val {inference = inf, parents = _} = data
+ in
+ case inf of
+ Normalize.Axiom fm => Formula.relations fm
+ | Normalize.Definition (_,fm) => Formula.relations fm
+ | _ => NameAritySet.empty
+ end
+ | ProofFormulaSource data =>
+ let
+ val {inference = inf, parents = _} = data
+ in
+ case inf of
+ Proof.Axiom cl => LiteralSet.relations cl
+ | Proof.Assume atm => NameAritySet.singleton (Atom.relation atm)
+ | Proof.Subst _ => NameAritySet.empty
+ | Proof.Resolve (atm,_,_) => NameAritySet.singleton (Atom.relation atm)
+ | Proof.Refl tm => NameAritySet.empty
+ | Proof.Equality (lit,_,_) =>
+ NameAritySet.singleton (Literal.relation lit)
+ end;
+
+fun freeVarsFormulaSource source =
+ case source of
+ NoFormulaSource => NameSet.empty
+ | StripFormulaSource _ => NameSet.empty
+ | NormalizeFormulaSource data => NameSet.empty
+ | ProofFormulaSource data =>
+ let
+ val {inference = inf, parents = _} = data
+ in
+ case inf of
+ Proof.Axiom cl => LiteralSet.freeVars cl
+ | Proof.Assume atm => Atom.freeVars atm
+ | Proof.Subst (sub,_) => Subst.freeVars sub
+ | Proof.Resolve (atm,_,_) => Atom.freeVars atm
+ | Proof.Refl tm => Term.freeVars tm
+ | Proof.Equality (lit,_,tm) =>
+ NameSet.union (Literal.freeVars lit) (Term.freeVars tm)
+ end;
+
+local
+ val GEN_INFERENCE = "inference"
+ and GEN_INTRODUCED = "introduced";
+
+ fun nameStrip inf = inf;
+
+ fun ppStrip mapping inf = Print.skip;
+
+ fun nameNormalize inf =
+ case inf of
+ Normalize.Axiom _ => "canonicalize"
+ | Normalize.Definition _ => "canonicalize"
+ | Normalize.Simplify _ => "simplify"
+ | Normalize.Conjunct _ => "conjunct"
+ | Normalize.Specialize _ => "specialize"
+ | Normalize.Skolemize _ => "skolemize"
+ | Normalize.Clausify _ => "clausify";
+
+ fun ppNormalize mapping inf = Print.skip;
+
+ fun nameProof inf =
+ case inf of
+ Proof.Axiom _ => "canonicalize"
+ | Proof.Assume _ => "assume"
+ | Proof.Subst _ => "subst"
+ | Proof.Resolve _ => "resolve"
+ | Proof.Refl _ => "refl"
+ | Proof.Equality _ => "equality";
+
+ local
+ fun ppTermInf mapping = ppTerm mapping;
+
+ fun ppAtomInf mapping atm =
+ case total Atom.destEq atm of
+ SOME (a,b) => ppAtom mapping (Name.fromString "$equal", [a,b])
+ | NONE => ppAtom mapping atm;
+
+ fun ppLiteralInf mapping (pol,atm) =
+ Print.sequence
+ (if pol then Print.skip else Print.addString "~ ")
+ (ppAtomInf mapping atm);
+ in
+ fun ppProofTerm mapping =
+ Print.ppBracket "$fot(" ")" (ppTermInf mapping);
+
+ fun ppProofAtom mapping =
+ Print.ppBracket "$cnf(" ")" (ppAtomInf mapping);
+
+ fun ppProofLiteral mapping =
+ Print.ppBracket "$cnf(" ")" (ppLiteralInf mapping);
+ end;
+
+ val ppProofVar = ppVar;
+
+ val ppProofPath = Term.ppPath;
+
+ fun ppProof mapping inf =
+ Print.blockProgram Print.Inconsistent 1
+ [Print.addString "[",
+ (case inf of
+ Proof.Axiom _ => Print.skip
+ | Proof.Assume atm => ppProofAtom mapping atm
+ | Proof.Subst _ => Print.skip
+ | Proof.Resolve (atm,_,_) => ppProofAtom mapping atm
+ | Proof.Refl tm => ppProofTerm mapping tm
+ | Proof.Equality (lit,path,tm) =>
+ Print.program
+ [ppProofLiteral mapping lit,
+ Print.addString ",",
+ Print.addBreak 1,
+ ppProofPath path,
+ Print.addString ",",
+ Print.addBreak 1,
+ ppProofTerm mapping tm]),
+ Print.addString "]"];
+
+ val ppParent = ppFormulaName;
+
+ fun ppProofSubst mapping =
+ Print.ppMap Subst.toList
+ (Print.ppList
+ (Print.ppBracket "bind(" ")"
+ (Print.ppOp2 "," (ppProofVar mapping)
+ (ppProofTerm mapping))));
+
+ fun ppProofParent mapping (p,s) =
+ if Subst.null s then ppParent p
+ else Print.ppOp2 " :" ppParent (ppProofSubst mapping) (p,s);
+in
+ fun ppFormulaSource mapping source =
+ case source of
+ NoFormulaSource => Print.skip
+ | StripFormulaSource {inference,parents} =>
+ let
+ val gen = GEN_INFERENCE
+
+ val name = nameStrip inference
+ in
+ Print.blockProgram Print.Inconsistent (size gen + 1)
+ [Print.addString gen,
+ Print.addString "(",
+ Print.addString name,
+ Print.addString ",",
+ Print.addBreak 1,
+ Print.ppBracket "[" "]" (ppStrip mapping) inference,
+ Print.addString ",",
+ Print.addBreak 1,
+ Print.ppList ppParent parents,
+ Print.addString ")"]
+ end
+ | NormalizeFormulaSource {inference,parents} =>
+ let
+ val gen = GEN_INFERENCE
+
+ val name = nameNormalize inference
+ in
+ Print.blockProgram Print.Inconsistent (size gen + 1)
+ [Print.addString gen,
+ Print.addString "(",
+ Print.addString name,
+ Print.addString ",",
+ Print.addBreak 1,
+ Print.ppBracket "[" "]" (ppNormalize mapping) inference,
+ Print.addString ",",
+ Print.addBreak 1,
+ Print.ppList ppParent parents,
+ Print.addString ")"]
+ end
+ | ProofFormulaSource {inference,parents} =>
+ let
+ val isTaut = null parents
+
+ val gen = if isTaut then GEN_INTRODUCED else GEN_INFERENCE
+
+ val name = nameProof inference
+
+ val parents =
+ let
+ val sub =
+ case inference of
+ Proof.Subst (s,_) => s
+ | _ => Subst.empty
+ in
+ map (fn parent => (parent,sub)) parents
+ end
+ in
+ Print.blockProgram Print.Inconsistent (size gen + 1)
+ ([Print.addString gen,
+ Print.addString "("] @
+ (if isTaut then
+ [Print.addString "tautology",
+ Print.addString ",",
+ Print.addBreak 1,
+ Print.blockProgram Print.Inconsistent 1
+ [Print.addString "[",
+ Print.addString name,
+ Print.addString ",",
+ Print.addBreak 1,
+ ppProof mapping inference,
+ Print.addString "]"]]
+ else
+ [Print.addString name,
+ Print.addString ",",
+ Print.addBreak 1,
+ ppProof mapping inference,
+ Print.addString ",",
+ Print.addBreak 1,
+ Print.ppList (ppProofParent mapping) parents]) @
+ [Print.addString ")"])
+ end
+end;
(* ------------------------------------------------------------------------- *)
(* 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";
+ Formula of
+ {name : formulaName,
+ role : role,
+ body : formulaBody,
+ source : formulaSource};
+
+fun nameFormula (Formula {name,...}) = name;
+
+fun roleFormula (Formula {role,...}) = role;
+
+fun bodyFormula (Formula {body,...}) = body;
+
+fun sourceFormula (Formula {source,...}) = source;
+
+fun destCnfFormula fm = destCnfFormulaBody (bodyFormula fm);
val isCnfFormula = can destCnfFormula;
-fun destFofFormula (FofFormula x) = x
- | destFofFormula _ = raise Error "destFofFormula";
+fun destFofFormula fm = destFofFormulaBody (bodyFormula fm);
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};
+fun functionsFormula fm =
+ let
+ val bodyFns = formulaBodyFunctions (bodyFormula fm)
+ and sourceFns = functionsFormulaSource (sourceFormula fm)
+ in
+ NameAritySet.union bodyFns sourceFns
+ end;
+
+fun relationsFormula fm =
+ let
+ val bodyRels = formulaBodyRelations (bodyFormula fm)
+ and sourceRels = relationsFormulaSource (sourceFormula fm)
+ in
+ NameAritySet.union bodyRels sourceRels
+ end;
+
+fun freeVarsFormula fm =
+ let
+ val bodyFvs = formulaBodyFreeVars (bodyFormula fm)
+ and sourceFvs = freeVarsFormulaSource (sourceFormula fm)
+ in
+ NameSet.union bodyFvs sourceFvs
+ end;
+
+val freeVarsListFormula =
+ let
+ fun add (fm,vs) = NameSet.union vs (freeVarsFormula fm)
+ in
+ List.foldl add NameSet.empty
+ end;
val formulasFunctions =
let
- fun funcs (fm,acc) = NameAritySet.union (formulaFunctions fm) acc
+ fun funcs (fm,acc) = NameAritySet.union (functionsFormula fm) acc
in
foldl funcs NameAritySet.empty
end;
val formulasRelations =
let
- fun rels (fm,acc) = NameAritySet.union (formulaRelations fm) acc
+ fun rels (fm,acc) = NameAritySet.union (relationsFormula 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;
-
+fun isCnfConjectureFormula fm =
+ case fm of
+ Formula {role, body = CnfFormulaBody _, ...} => isCnfConjectureRole role
+ | _ => false;
+
+fun isFofConjectureFormula fm =
+ case fm of
+ Formula {role, body = FofFormulaBody _, ...} => isFofConjectureRole role
+ | _ => false;
+
+fun isConjectureFormula fm =
+ isCnfConjectureFormula fm orelse
+ isFofConjectureFormula fm;
+
+(* Parsing and pretty-printing *)
+
+fun ppFormula mapping fm =
+ let
+ val Formula {name,role,body,source} = fm
+
+ val gen =
+ case body of
+ CnfFormulaBody _ => "cnf"
+ | FofFormulaBody _ => "fof"
+ in
+ Print.blockProgram Print.Inconsistent (size gen + 1)
+ ([Print.addString gen,
+ Print.addString "(",
+ ppFormulaName name,
+ Print.addString ",",
+ Print.addBreak 1,
+ ppRole role,
+ Print.addString ",",
+ Print.addBreak 1,
+ Print.blockProgram Print.Consistent 1
+ [Print.addString "(",
+ ppFormulaBody mapping body,
+ Print.addString ")"]] @
+ (if isNoFormulaSource source then []
+ else
+ [Print.addString ",",
+ Print.addBreak 1,
+ ppFormulaSource mapping source]) @
+ [Print.addString ")."])
+ end;
+
+fun formulaToString mapping = Print.toString (ppFormula mapping);
+
+local
+ open Parse;
+
+ infixr 9 >>++
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 lowerParser = someAlphaNum (fn s => Char.isLower (String.sub (s,0)));
val upperParser = someAlphaNum (fn s => Char.isUpper (String.sub (s,0)));
@@ -16986,12 +23126,7 @@
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;
+ val quoteParser = maybe (fn Quote s => SOME s | _ => NONE);
local
fun f [] = raise Bug "symbolParser"
@@ -17008,16 +23143,19 @@
punctParser #"$" ++ punctParser #"$" ++ someAlphaNum (K true) >>
(fn ((),((),s)) => "$$" ^ s);
- val nameParser = stringParser || numberParser || quoteParser (K false);
-
- val roleParser = lowerParser;
+ val nameParser =
+ (stringParser || numberParser || quoteParser) >> FormulaName;
+
+ val roleParser = lowerParser >> fromStringRole;
local
fun isProposition s = isHdTlString Char.isLower isAlphaNum s;
in
val propositionParser =
someAlphaNum isProposition ||
- definedParser || systemParser || quoteParser isProposition;
+ definedParser ||
+ systemParser ||
+ quoteParser;
end;
local
@@ -17025,17 +23163,20 @@
in
val functionParser =
someAlphaNum isFunction ||
- definedParser || systemParser || quoteParser isFunction;
+ definedParser ||
+ systemParser ||
+ quoteParser;
end;
local
- fun isConstant s =
- isHdTlString Char.isLower isAlphaNum s orelse
- isHdTlString Char.isDigit Char.isDigit s;
+ fun isConstant s = isHdTlString Char.isLower isAlphaNum s;
in
val constantParser =
someAlphaNum isConstant ||
- definedParser || systemParser || quoteParser isConstant;
+ definedParser ||
+ numberParser ||
+ systemParser ||
+ quoteParser;
end;
val varParser = upperParser;
@@ -17046,536 +23187,819 @@
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
+ fun mkVarName mapping v = varFromTptp mapping v;
+
+ fun mkVar mapping v =
+ let
+ val v = mkVarName mapping v
+ in
+ Term.Var v
+ end
+
+ fun mkFn mapping (f,tms) =
+ let
+ val f = fnFromTptp mapping (f, length tms)
+ in
+ Term.Fn (f,tms)
+ end;
+
+ fun mkConst mapping c = mkFn mapping (c,[]);
+
+ fun mkAtom mapping (r,tms) =
+ let
+ val r = relFromTptp mapping (r, length tms)
+ in
+ (r,tms)
+ end;
+
+ fun termParser mapping input =
+ let
+ val fnP = functionArgumentsParser mapping >> mkFn mapping
+ val nonFnP = nonFunctionArgumentsTermParser mapping
+ in
+ fnP || nonFnP
+ end input
+
+ and functionArgumentsParser mapping input =
+ let
+ val commaTmP = (punctParser #"," ++ termParser mapping) >> snd
+ in
+ (functionParser ++ punctParser #"(" ++ termParser mapping ++
+ many commaTmP ++ punctParser #")") >>
+ (fn (f,((),(t,(ts,())))) => (f, t :: ts))
+ end input
+
+ and nonFunctionArgumentsTermParser mapping input =
+ let
+ val varP = varParser >> mkVar mapping
+ val constP = constantParser >> mkConst mapping
+ in
+ varP || constP
+ end input;
+
+ fun binaryAtomParser mapping tm input =
+ let
+ val eqP =
+ (punctParser #"=" ++ termParser mapping) >>
+ (fn ((),r) => (true,("$equal",[tm,r])))
+
+ val neqP =
+ (symbolParser "!=" ++ termParser mapping) >>
+ (fn ((),r) => (false,("$equal",[tm,r])))
+ in
+ eqP || neqP
+ end input;
+
+ fun maybeBinaryAtomParser mapping (s,tms) input =
+ let
+ val tm = mkFn mapping (s,tms)
+ in
+ optional (binaryAtomParser mapping tm) >>
+ (fn SOME lit => lit
+ | NONE => (true,(s,tms)))
+ end input;
+
+ fun literalAtomParser mapping input =
+ let
+ val fnP =
+ functionArgumentsParser mapping >>++
+ maybeBinaryAtomParser mapping
+
+ val nonFnP =
+ nonFunctionArgumentsTermParser mapping >>++
+ binaryAtomParser mapping
+
+ val propP = propositionParser >> (fn s => (true,(s,[])))
+ in
+ fnP || nonFnP || propP
+ end input;
+
+ fun atomParser mapping input =
+ let
+ fun mk (pol,rel) =
+ case rel of
+ ("$true",[]) => Boolean pol
+ | ("$false",[]) => Boolean (not pol)
+ | ("$equal",[l,r]) => Literal (pol, Atom.mkEq (l,r))
+ | (r,tms) => Literal (pol, mkAtom mapping (r,tms))
+ in
+ literalAtomParser mapping >> mk
+ end input;
+
+ fun literalParser mapping input =
+ let
+ val negP =
+ (punctParser #"~" ++ atomParser mapping) >>
+ (negateLiteral o snd)
+
+ val posP = atomParser mapping
+ in
+ negP || posP
+ end input;
+
+ fun disjunctionParser mapping input =
+ let
+ val orLitP = (punctParser #"|" ++ literalParser mapping) >> snd
+ in
+ (literalParser mapping ++ many orLitP) >> (fn (h,t) => h :: t)
+ end input;
+
+ fun clauseParser mapping input =
+ let
+ val disjP = disjunctionParser mapping
+
+ val bracketDisjP =
+ (punctParser #"(" ++ disjP ++ punctParser #")") >>
+ (fn ((),(c,())) => c)
+ in
+ bracketDisjP || disjP
+ end input;
+
+ val binaryConnectiveParser =
+ (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));
+
+ val quantifierParser =
+ (punctParser #"!" >> K Formula.listMkForall) ||
+ (punctParser #"?" >> K Formula.listMkExists);
+
+ fun fofFormulaParser mapping input =
+ let
+ fun mk (f,NONE) = f
+ | mk (f, SOME t) = t f
+ in
+ (unitaryFormulaParser mapping ++
+ optional (binaryFormulaParser mapping)) >> mk
+ end input
+
+ and binaryFormulaParser mapping input =
+ let
+ val nonAssocP = nonAssocBinaryFormulaParser mapping
+
+ val assocP = assocBinaryFormulaParser mapping
+ in
+ nonAssocP || assocP
+ end input
+
+ and nonAssocBinaryFormulaParser mapping input =
+ let
+ fun mk (c,g) f = c (f,g)
+ in
+ (binaryConnectiveParser ++ unitaryFormulaParser mapping) >> mk
+ end input
+
+ and assocBinaryFormulaParser mapping input =
+ let
+ val orP = orFormulaParser mapping
+
+ val andP = andFormulaParser mapping
+ in
+ orP || andP
+ end input
+
+ and orFormulaParser mapping input =
+ let
+ val orFmP = (punctParser #"|" ++ unitaryFormulaParser mapping) >> snd
+ in
+ atLeastOne orFmP >>
+ (fn fs => fn f => Formula.listMkDisj (f :: fs))
+ end input
+
+ and andFormulaParser mapping input =
+ let
+ val andFmP = (punctParser #"&" ++ unitaryFormulaParser mapping) >> snd
+ in
+ atLeastOne andFmP >>
+ (fn fs => fn f => Formula.listMkConj (f :: fs))
+ end input
+
+ and unitaryFormulaParser mapping input =
+ let
+ val quantP = quantifiedFormulaParser mapping
+
+ val unaryP = unaryFormulaParser mapping
+
+ val brackP =
+ (punctParser #"(" ++ fofFormulaParser mapping ++
+ punctParser #")") >>
+ (fn ((),(f,())) => f)
+
+ val atomP =
+ atomParser mapping >>
+ (fn Boolean b => Formula.mkBoolean b
+ | Literal l => Literal.toFormula l)
+ in
+ quantP ||
+ unaryP ||
+ brackP ||
+ atomP
+ end input
+
+ and quantifiedFormulaParser mapping input =
+ let
+ fun mk (q,(vs,((),f))) = q (map (mkVarName mapping) vs, f)
+ in
+ (quantifierParser ++ varListParser ++ punctParser #":" ++
+ unitaryFormulaParser mapping) >> mk
+ end input
+
+ and unaryFormulaParser mapping input =
+ let
+ fun mk (c,f) = c f
+ in
+ (unaryConnectiveParser ++ unitaryFormulaParser mapping) >> mk
+ end 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 cnfParser mapping input =
+ let
+ fun mk ((),((),(name,((),(role,((),(cl,((),())))))))) =
+ let
+ val body = CnfFormulaBody cl
+ val source = NoFormulaSource
+ in
+ Formula
+ {name = name,
+ role = role,
+ body = body,
+ source = source}
+ end
+ in
+ (alphaNumParser "cnf" ++ punctParser #"(" ++
+ nameParser ++ punctParser #"," ++
+ roleParser ++ punctParser #"," ++
+ clauseParser mapping ++ punctParser #")" ++
+ punctParser #".") >> mk
+ end input;
+
+ fun fofParser mapping input =
+ let
+ fun mk ((),((),(name,((),(role,((),(fm,((),())))))))) =
+ let
+ val body = FofFormulaBody fm
+ val source = NoFormulaSource
+ in
+ Formula
+ {name = name,
+ role = role,
+ body = body,
+ source = source}
+ end
+ in
+ (alphaNumParser "fof" ++ punctParser #"(" ++
+ nameParser ++ punctParser #"," ++
+ roleParser ++ punctParser #"," ++
+ fofFormulaParser mapping ++ punctParser #")" ++
+ punctParser #".") >> mk
+ end input;
+in
+ fun formulaParser mapping input =
+ let
+ val cnfP = cnfParser mapping
+
+ val fofP = fofParser mapping
+ in
+ cnfP || fofP
+ end input;
+end;
+
+(* ------------------------------------------------------------------------- *)
+(* Include declarations. *)
+(* ------------------------------------------------------------------------- *)
+
+fun ppInclude i =
+ Print.blockProgram Print.Inconsistent 2
+ [Print.addString "include('",
+ Print.addString i,
+ Print.addString "')."];
+
+val includeToString = Print.toString ppInclude;
+
+local
+ open Parse;
+
+ infixr 9 >>++
+ infixr 8 ++
+ infixr 7 >>
+ infixr 6 ||
+
+ val filenameParser = maybe (fn Quote s => SOME s | _ => NONE);
+in
+ val includeParser =
+ (some (equal (AlphaNum "include")) ++
+ some (equal (Punct #"(")) ++
+ filenameParser ++
+ some (equal (Punct #")")) ++
+ some (equal (Punct #"."))) >>
+ (fn (_,(_,(f,(_,_)))) => f);
+end;
+
+(* ------------------------------------------------------------------------- *)
+(* Parsing TPTP files. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype declaration =
+ IncludeDeclaration of string
+ | FormulaDeclaration of formula;
+
+val partitionDeclarations =
+ let
+ fun part (d,(il,fl)) =
+ case d of
+ IncludeDeclaration i => (i :: il, fl)
+ | FormulaDeclaration f => (il, f :: fl)
+ in
+ fn l => List.foldl part ([],[]) (rev l)
+ end;
+
+local
+ open Parse;
+
+ infixr 9 >>++
+ infixr 8 ++
+ infixr 7 >>
+ infixr 6 ||
+
+ fun declarationParser mapping =
+ (includeParser >> IncludeDeclaration) ||
+ (formulaParser mapping >> FormulaDeclaration);
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;
+ val tokens = Parse.everything (lexer >> singleton) chars
+ in
+ Parse.everything (parser >> singleton) tokens
+ end;
+in
+ fun parseDeclaration mapping = parseChars (declarationParser mapping);
+end;
+
+(* ------------------------------------------------------------------------- *)
+(* Clause information. *)
+(* ------------------------------------------------------------------------- *)
+
+datatype clauseSource =
+ CnfClauseSource of formulaName * literal list
+ | FofClauseSource of Normalize.thm;
+
+type 'a clauseInfo = 'a LiteralSetMap.map;
+
+type clauseNames = formulaName clauseInfo;
+
+type clauseRoles = role clauseInfo;
+
+type clauseSources = clauseSource clauseInfo;
+
+val noClauseNames : clauseNames = LiteralSetMap.new ();
+
+val allClauseNames : clauseNames -> formulaNameSet =
+ let
+ fun add (_,n,s) = addFormulaNameSet s n
+ in
+ LiteralSetMap.foldl add emptyFormulaNameSet
+ end;
+
+val noClauseRoles : clauseRoles = LiteralSetMap.new ();
+
+val noClauseSources : clauseSources = LiteralSetMap.new ();
+
+(* ------------------------------------------------------------------------- *)
+(* Comments. *)
+(* ------------------------------------------------------------------------- *)
+
+fun mkLineComment "" = "%"
+ | mkLineComment line = "% " ^ line;
+
+fun destLineComment cs =
+ case cs of
+ [] => ""
+ | #"%" :: #" " :: rest => implode rest
+ | #"%" :: rest => implode rest
+ | _ => raise Error "Tptp.destLineComment";
+
+val isLineComment = can destLineComment;
(* ------------------------------------------------------------------------- *)
(* 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 =
+type comments = string list;
+
+type includes = string list;
+
+datatype problem =
+ Problem of
+ {comments : comments,
+ includes : includes,
+ formulas : formula list};
+
+fun hasCnfConjecture (Problem {formulas,...}) =
+ List.exists isCnfConjectureFormula formulas;
+
+fun hasFofConjecture (Problem {formulas,...}) =
+ List.exists isFofConjectureFormula formulas;
+
+fun hasConjecture (Problem {formulas,...}) =
+ List.exists isConjectureFormula formulas;
+
+fun freeVars (Problem {formulas,...}) = freeVarsListFormula formulas;
+
+local
+ fun bump n avoid =
+ let
+ val s = FormulaName (Int.toString n)
+ in
+ if memberFormulaNameSet s avoid then bump (n + 1) avoid
+ else (s, n, addFormulaNameSet avoid s)
+ end;
+
+ fun fromClause defaultRole names roles cl (n,avoid) =
+ let
+ val (name,n,avoid) =
+ case LiteralSetMap.peek names cl of
+ SOME name => (name,n,avoid)
+ | NONE => bump n avoid
+
+ val role = Option.getOpt (LiteralSetMap.peek roles cl, defaultRole)
+
+ val body = CnfFormulaBody (clauseFromLiteralSet cl)
+
+ val source = NoFormulaSource
+
+ val formula =
+ Formula
+ {name = name,
+ role = role,
+ body = body,
+ source = source}
+ in
+ (formula,(n,avoid))
+ end;
+in
+ fun mkProblem {comments,includes,names,roles,problem} =
+ let
+ fun fromCl defaultRole = fromClause defaultRole names roles
+
+ val {axioms,conjecture} = problem
+
+ val n_avoid = (0, allClauseNames names)
+
+ val (axiomFormulas,n_avoid) = maps (fromCl AxiomRole) axioms n_avoid
+
+ val (conjectureFormulas,_) =
+ maps (fromCl NegatedConjectureRole) conjecture n_avoid
+
+ val formulas = axiomFormulas @ conjectureFormulas
+ in
+ Problem
+ {comments = comments,
+ includes = includes,
+ formulas = formulas}
+ end;
+end;
+
+type normalization =
+ {problem : Problem.problem,
+ sources : clauseSources};
+
+val initialNormalization : normalization =
+ {problem = {axioms = [], conjecture = []},
+ sources = noClauseSources};
+
+datatype problemGoal =
+ NoGoal
+ | CnfGoal of (formulaName * clause) list
+ | FofGoal of (formulaName * Formula.formula) list;
+
+local
+ fun partitionFormula (formula,(cnfAxioms,fofAxioms,cnfGoals,fofGoals)) =
+ let
+ val Formula {name,role,body,...} = formula
+ in
+ case body of
+ CnfFormulaBody cl =>
+ if isCnfConjectureRole role then
+ let
+ val cnfGoals = (name,cl) :: cnfGoals
+ in
+ (cnfAxioms,fofAxioms,cnfGoals,fofGoals)
+ end
+ else
+ let
+ val cnfAxioms = (name,cl) :: cnfAxioms
+ in
+ (cnfAxioms,fofAxioms,cnfGoals,fofGoals)
+ end
+ | FofFormulaBody fm =>
+ if isFofConjectureRole role then
+ let
+ val fofGoals = (name,fm) :: fofGoals
+ in
+ (cnfAxioms,fofAxioms,cnfGoals,fofGoals)
+ end
+ else
+ let
+ val fofAxioms = (name,fm) :: fofAxioms
+ in
+ (cnfAxioms,fofAxioms,cnfGoals,fofGoals)
+ end
+ end;
+
+ fun partitionFormulas fms =
+ let
+ val (cnfAxioms,fofAxioms,cnfGoals,fofGoals) =
+ List.foldl partitionFormula ([],[],[],[]) fms
+
+ val goal =
+ case (rev cnfGoals, rev fofGoals) of
+ ([],[]) => NoGoal
+ | (cnfGoals,[]) => CnfGoal cnfGoals
+ | ([],fofGoals) => FofGoal fofGoals
+ | (_ :: _, _ :: _) =>
+ raise Error "TPTP problem has both cnf and fof conjecture formulas"
+ in
+ {cnfAxioms = rev cnfAxioms,
+ fofAxioms = rev fofAxioms,
+ goal = goal}
+ end;
+
+ fun addClauses role clauses acc : normalization =
+ let
+ fun addClause (cl_src,sources) =
+ LiteralSetMap.insert sources cl_src
+
+ val {problem,sources} : normalization = acc
+ val {axioms,conjecture} = problem
+
+ val cls = map fst clauses
+ val (axioms,conjecture) =
+ if isCnfConjectureRole role then (axioms, cls @ conjecture)
+ else (cls @ axioms, conjecture)
+
+ val problem = {axioms = axioms, conjecture = conjecture}
+ and sources = List.foldl addClause sources clauses
+ in
+ {problem = problem,
+ sources = sources}
+ end;
+
+ fun addCnf role ((name,clause),(norm,cnf)) =
+ if List.exists (equalBooleanLiteral true) clause then (norm,cnf)
+ else
+ let
+ val cl = List.mapPartial (total destLiteral) clause
+ val cl = LiteralSet.fromList cl
+
+ val src = CnfClauseSource (name,clause)
+
+ val norm = addClauses role [(cl,src)] norm
+ in
+ (norm,cnf)
+ end;
+
+ val addCnfAxiom = addCnf AxiomRole;
+
+ val addCnfGoal = addCnf NegatedConjectureRole;
+
+ fun addFof role (th,(norm,cnf)) =
+ let
+ fun sourcify (cl,inf) = (cl, FofClauseSource inf)
+
+ val (clauses,cnf) = Normalize.addCnf th cnf
+ val clauses = map sourcify clauses
+ val norm = addClauses role clauses norm
+ in
+ (norm,cnf)
+ end;
+
+ fun addFofAxiom ((_,fm),acc) =
+ addFof AxiomRole (Normalize.mkAxiom fm, acc);
+
+ fun normProblem subgoal (norm,_) =
+ let
+ val {problem,sources} = norm
+ val {axioms,conjecture} = problem
+ val problem = {axioms = rev axioms, conjecture = rev conjecture}
+ in
+ {subgoal = subgoal,
+ problem = problem,
+ sources = sources}
+ end;
+
+ val normProblemFalse = normProblem (Formula.False,[]);
+
+ fun splitProblem acc =
+ let
+ fun mk parents subgoal =
+ let
+ val subgoal = Formula.generalize subgoal
+
+ val th = Normalize.mkAxiom (Formula.Not subgoal)
+
+ val acc = addFof NegatedConjectureRole (th,acc)
+ in
+ normProblem (subgoal,parents) acc
+ end
+
+ fun split (name,goal) =
+ let
+ val subgoals = Formula.splitGoal goal
+ val subgoals =
+ if null subgoals then [Formula.True] else subgoals
+
+ val parents = [name]
+ in
+ map (mk parents) subgoals
+ end
+ in
+ fn goals => List.concat (map split goals)
+ end;
+
+ fun clausesToGoal cls =
+ let
+ val cls = map (Formula.generalize o clauseToFormula o snd) cls
+ in
+ Formula.listMkConj cls
+ end;
+
+ fun formulasToGoal fms =
+ let
+ val fms = map (Formula.generalize o snd) fms
+ in
+ Formula.listMkConj fms
+ end;
+in
+ fun goal (Problem {formulas,...}) =
+ let
+ val {cnfAxioms,fofAxioms,goal} = partitionFormulas formulas
+
+ val fm =
+ case goal of
+ NoGoal => Formula.False
+ | CnfGoal cls => Formula.Imp (clausesToGoal cls, Formula.False)
+ | FofGoal goals => formulasToGoal goals
+
+ val fm =
+ if null fofAxioms then fm
+ else Formula.Imp (formulasToGoal fofAxioms, fm)
+
+ val fm =
+ if null cnfAxioms then fm
+ else Formula.Imp (clausesToGoal cnfAxioms, fm)
+ in
+ fm
+ end;
+
+ fun normalize (Problem {formulas,...}) =
+ let
+ val {cnfAxioms,fofAxioms,goal} = partitionFormulas formulas
+
+ val acc = (initialNormalization, Normalize.initialCnf)
+ val acc = List.foldl addCnfAxiom acc cnfAxioms
+ val acc = List.foldl addFofAxiom acc fofAxioms
+ in
+ case goal of
+ NoGoal => [normProblemFalse acc]
+ | CnfGoal cls => [normProblemFalse (List.foldl addCnfGoal acc cls)]
+ | FofGoal goals => splitProblem acc goals
+ end;
+end;
+
+local
+ datatype blockComment =
+ OutsideBlockComment
+ | EnteringBlockComment
+ | InsideBlockComment
+ | LeavingBlockComment;
+
+ fun stripLineComments 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
+ Stream.Nil => (rev acc, Stream.Nil)
+ | Stream.Cons (line,rest) =>
+ case total destLineComment line of
+ SOME s => stripLineComments (s :: acc) (rest ())
+ | NONE => (rev acc, Stream.filter (not o isLineComment) strm);
+
+ fun advanceBlockComment c state =
+ case state of
+ OutsideBlockComment =>
+ if c = #"/" then (Stream.Nil, EnteringBlockComment)
+ else (Stream.singleton c, OutsideBlockComment)
+ | EnteringBlockComment =>
+ if c = #"*" then (Stream.Nil, InsideBlockComment)
+ else if c = #"/" then (Stream.singleton #"/", EnteringBlockComment)
+ else (Stream.fromList [#"/",c], OutsideBlockComment)
+ | InsideBlockComment =>
+ if c = #"*" then (Stream.Nil, LeavingBlockComment)
+ else (Stream.Nil, InsideBlockComment)
+ | LeavingBlockComment =>
+ if c = #"/" then (Stream.Nil, OutsideBlockComment)
+ else if c = #"*" then (Stream.Nil, LeavingBlockComment)
+ else (Stream.Nil, InsideBlockComment);
+
+ fun eofBlockComment state =
+ case state of
+ OutsideBlockComment => Stream.Nil
+ | EnteringBlockComment => Stream.singleton #"/"
+ | _ => raise Error "EOF inside a block comment";
+
+ val stripBlockComments =
+ Stream.mapsConcat advanceBlockComment eofBlockComment
+ OutsideBlockComment;
+in
+ fun read {mapping,filename} =
+ let
+ (* Estimating parse error line numbers *)
+
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
+ val {chars,parseErrorLocation} = Parse.initialize {lines = lines}
+ in
+ (let
+ (* The character stream *)
+
+ val (comments,chars) = stripLineComments [] chars
+
+ val chars = Parse.everything Parse.any chars
+
+ val chars = stripBlockComments chars
+
+ (* The declaration stream *)
+
+ val declarations = Stream.toList (parseDeclaration mapping chars)
+
+ val (includes,formulas) = partitionDeclarations declarations
+ in
+ Problem
+ {comments = comments,
+ includes = includes,
+ formulas = formulas}
+ end
+ handle Parse.NoParse => raise Error "parse error")
+ handle Error err =>
+ raise Error ("error in TPTP file \"" ^ filename ^ "\" " ^
+ parseErrorLocation () ^ "\n" ^ err)
+ end;
+end;
+
+local
+ val newline = Stream.singleton "\n";
+
+ fun spacer top = if top then Stream.Nil else newline;
+
+ fun mkComment comment = mkLineComment comment ^ "\n";
+
+ fun mkInclude inc = includeToString inc ^ "\n";
+
+ fun formulaStream _ _ [] = Stream.Nil
+ | formulaStream mapping top (h :: t) =
+ Stream.append
+ (Stream.concatList
+ [spacer top,
+ Stream.singleton (formulaToString mapping h),
+ newline])
+ (fn () => formulaStream mapping false t);
+in
+ fun write {problem,mapping,filename} =
+ let
+ val Problem {comments,includes,formulas} = problem
+
+ val includesTop = null comments
+ val formulasTop = includesTop andalso null includes
+ in
+ Stream.toTextFile
+ {filename = filename}
+ (Stream.concatList
+ [Stream.map mkComment (Stream.fromList comments),
+ spacer includesTop,
+ Stream.map mkInclude (Stream.fromList includes),
+ formulaStream mapping formulasTop formulas])
+ end;
+end;
+
+local
+ fun refute {axioms,conjecture} =
+ let
+ val axioms = map Thm.axiom axioms
+ and conjecture = map Thm.axiom conjecture
+ val problem = {axioms = axioms, conjecture = conjecture}
+ val resolution = Resolution.new Resolution.default problem
+ in
+ case Resolution.loop resolution 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
+ val problem = read filename
+ val problems = map #problem (normalize problem)
in
List.all refute problems
end;
@@ -17586,133 +24010,385 @@
(* ------------------------------------------------------------------------- *)
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 =
+ fun newName avoid prefix =
+ let
+ fun bump i =
+ let
+ val name = FormulaName (prefix ^ Int.toString i)
+ val i = i + 1
+ in
+ if memberFormulaNameSet name avoid then bump i else (name,i)
+ end
+ in
+ bump
+ end;
+
+ fun lookupClauseSource sources cl =
+ case LiteralSetMap.peek sources cl of
+ SOME src => src
+ | NONE => raise Bug "Tptp.lookupClauseSource";
+
+ fun lookupFormulaName fmNames fm =
+ case FormulaMap.peek fmNames fm of
+ SOME name => name
+ | NONE => raise Bug "Tptp.lookupFormulaName";
+
+ fun lookupClauseName clNames cl =
+ case LiteralSetMap.peek clNames cl of
+ SOME name => name
+ | NONE => raise Bug "Tptp.lookupClauseName";
+
+ fun lookupClauseSourceName sources fmNames cl =
+ case lookupClauseSource sources cl of
+ CnfClauseSource (name,_) => name
+ | FofClauseSource th =>
+ let
+ val (fm,_) = Normalize.destThm th
+ in
+ lookupFormulaName fmNames fm
+ end;
+
+ fun collectProofDeps sources ((_,inf),names_ths) =
+ case inf of
+ Proof.Axiom cl =>
+ let
+ val (names,ths) = names_ths
+ in
+ case lookupClauseSource sources cl of
+ CnfClauseSource (name,_) =>
+ let
+ val names = addFormulaNameSet names name
+ in
+ (names,ths)
+ end
+ | FofClauseSource th =>
+ let
+ val ths = th :: ths
+ in
+ (names,ths)
+ end
+ end
+ | _ => names_ths;
+
+ fun collectNormalizeDeps ((_,inf,_),fofs_defs) =
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;
+ Normalize.Axiom fm =>
+ let
+ val (fofs,defs) = fofs_defs
+ val fofs = FormulaSet.add fofs fm
+ in
+ (fofs,defs)
+ end
+ | Normalize.Definition n_d =>
+ let
+ val (fofs,defs) = fofs_defs
+ val defs = StringMap.insert defs n_d
+ in
+ (fofs,defs)
+ end
+ | _ => fofs_defs;
+
+ fun collectSubgoalProofDeps subgoalProof (names,fofs,defs) =
+ let
+ val {subgoal,sources,refutation} = subgoalProof
+
+ val names = addListFormulaNameSet names (snd subgoal)
+
+ val proof = Proof.proof refutation
+
+ val (names,ths) =
+ List.foldl (collectProofDeps sources) (names,[]) proof
+
+ val normalization = Normalize.proveThms (rev ths)
+
+ val (fofs,defs) =
+ List.foldl collectNormalizeDeps (fofs,defs) normalization
+
+ val subgoalProof =
+ {subgoal = subgoal,
+ normalization = normalization,
+ sources = sources,
+ proof = proof}
+ in
+ (subgoalProof,(names,fofs,defs))
+ end;
+
+ fun addProblemFormula names fofs (formula,(avoid,formulas,fmNames)) =
+ let
+ val name = nameFormula formula
+
+ val avoid = addFormulaNameSet avoid name
+
+ val (formulas,fmNames) =
+ if memberFormulaNameSet name names then
+ (formula :: formulas, fmNames)
+ else
+ case bodyFormula formula of
+ CnfFormulaBody _ => (formulas,fmNames)
+ | FofFormulaBody fm =>
+ if not (FormulaSet.member fm fofs) then (formulas,fmNames)
+ else (formula :: formulas, FormulaMap.insert fmNames (fm,name))
+ in
+ (avoid,formulas,fmNames)
+ end;
+
+ fun addDefinitionFormula avoid (_,def,(formulas,i,fmNames)) =
+ let
+ val (name,i) = newName avoid "definition_" i
+
+ val role = DefinitionRole
+
+ val body = FofFormulaBody def
+
+ val source = NoFormulaSource
+
+ val formula =
+ Formula
+ {name = name,
+ role = role,
+ body = body,
+ source = source}
+
+ val formulas = formula :: formulas
+
+ val fmNames = FormulaMap.insert fmNames (def,name)
+ in
+ (formulas,i,fmNames)
+ end;
+
+ fun addSubgoalFormula avoid subgoalProof (formulas,i) =
+ let
+ val {subgoal,normalization,sources,proof} = subgoalProof
+
+ val (fm,pars) = subgoal
+
+ val (name,i) = newName avoid "subgoal_" i
+
+ val number = i - 1
+
+ val (subgoal,formulas) =
+ if null pars then (NONE,formulas)
+ else
+ let
+ val role = PlainRole
+
+ val body = FofFormulaBody fm
+
+ val source =
+ StripFormulaSource
+ {inference = "strip",
+ parents = pars}
+
+ val formula =
+ Formula
+ {name = name,
+ role = role,
+ body = body,
+ source = source}
+ in
+ (SOME (name,fm), formula :: formulas)
+ end
+
+ val subgoalProof =
+ {number = number,
+ subgoal = subgoal,
+ normalization = normalization,
+ sources = sources,
+ proof = proof}
+ in
+ (subgoalProof,(formulas,i))
+ end;
+
+ fun mkNormalizeFormulaSource fmNames inference fms =
+ let
+ val fms =
+ case inference of
+ Normalize.Axiom fm => fm :: fms
+ | Normalize.Definition (_,fm) => fm :: fms
+ | _ => fms
+
+ val parents = map (lookupFormulaName fmNames) fms
+ in
+ NormalizeFormulaSource
+ {inference = inference,
+ parents = parents}
+ end;
+
+ fun mkProofFormulaSource sources fmNames clNames inference =
+ let
+ val parents =
+ case inference of
+ Proof.Axiom cl => [lookupClauseSourceName sources fmNames cl]
+ | _ =>
+ let
+ val cls = map Thm.clause (Proof.parents inference)
+ in
+ map (lookupClauseName clNames) cls
+ end
+ in
+ ProofFormulaSource
+ {inference = inference,
+ parents = parents}
+ end;
+
+ fun addNormalizeFormula avoid prefix ((fm,inf,fms),acc) =
+ let
+ val (formulas,i,fmNames) = acc
+
+ val (name,i) = newName avoid prefix i
+
+ val role = PlainRole
+
+ val body = FofFormulaBody fm
+
+ val source = mkNormalizeFormulaSource fmNames inf fms
+
+ val formula =
+ Formula
+ {name = name,
+ role = role,
+ body = body,
+ source = source}
+
+ val formulas = formula :: formulas
+
+ val fmNames = FormulaMap.insert fmNames (fm,name)
+ in
+ (formulas,i,fmNames)
+ end;
+
+ fun isSameClause sources formulas inf =
+ case inf of
+ Proof.Axiom cl =>
+ (case lookupClauseSource sources cl of
+ CnfClauseSource (name,lits) =>
+ if List.exists isBooleanLiteral lits then NONE
+ else SOME name
+ | _ => NONE)
+ | _ => NONE;
+
+ fun addProofFormula avoid sources fmNames prefix ((th,inf),acc) =
+ let
+ val (formulas,i,clNames) = acc
+
+ val cl = Thm.clause th
+ in
+ case isSameClause sources formulas inf of
+ SOME name =>
+ let
+ val clNames = LiteralSetMap.insert clNames (cl,name)
+ in
+ (formulas,i,clNames)
+ end
+ | NONE =>
+ let
+ val (name,i) = newName avoid prefix i
+
+ val role = PlainRole
+
+ val body = CnfFormulaBody (clauseFromLiteralSet cl)
+
+ val source = mkProofFormulaSource sources fmNames clNames inf
+
+ val formula =
+ Formula
+ {name = name,
+ role = role,
+ body = body,
+ source = source}
+
+ val formulas = formula :: formulas
+
+ val clNames = LiteralSetMap.insert clNames (cl,name)
+ in
+ (formulas,i,clNames)
+ end
+ end;
+
+ fun addSubgoalProofFormulas avoid fmNames (subgoalProof,formulas) =
+ let
+ val {number,subgoal,normalization,sources,proof} = subgoalProof
+
+ val (formulas,fmNames) =
+ case subgoal of
+ NONE => (formulas,fmNames)
+ | SOME (name,fm) =>
+ let
+ val source =
+ StripFormulaSource
+ {inference = "negate",
+ parents = [name]}
+
+ val prefix = "negate_" ^ Int.toString number ^ "_"
+
+ val (name,_) = newName avoid prefix 0
+
+ val role = PlainRole
+
+ val fm = Formula.Not fm
+
+ val body = FofFormulaBody fm
+
+ val formula =
+ Formula
+ {name = name,
+ role = role,
+ body = body,
+ source = source}
+
+ val formulas = formula :: formulas
+
+ val fmNames = FormulaMap.insert fmNames (fm,name)
+ in
+ (formulas,fmNames)
+ end
+
+ val prefix = "normalize_" ^ Int.toString number ^ "_"
+ val (formulas,_,fmNames) =
+ List.foldl (addNormalizeFormula avoid prefix)
+ (formulas,0,fmNames) normalization
+
+ val prefix = "refute_" ^ Int.toString number ^ "_"
+ val clNames : formulaName LiteralSetMap.map = LiteralSetMap.new ()
+ val (formulas,_,_) =
+ List.foldl (addProofFormula avoid sources fmNames prefix)
+ (formulas,0,clNames) proof
+ in
+ formulas
+ end;
+in
+ fun fromProof {problem,proofs} =
+ let
+ val names = emptyFormulaNameSet
+ and fofs = FormulaSet.empty
+ and defs : Formula.formula StringMap.map = StringMap.new ()
+
+ val (proofs,(names,fofs,defs)) =
+ maps collectSubgoalProofDeps proofs (names,fofs,defs)
+
+ val Problem {formulas,...} = problem
+
+ val fmNames : formulaName FormulaMap.map = FormulaMap.new ()
+ val (avoid,formulas,fmNames) =
+ List.foldl (addProblemFormula names fofs)
+ (emptyFormulaNameSet,[],fmNames) formulas
+
+ val (formulas,_,fmNames) =
+ StringMap.foldl (addDefinitionFormula avoid)
+ (formulas,0,fmNames) defs
+
+ val (proofs,(formulas,_)) =
+ maps (addSubgoalFormula avoid) proofs (formulas,0)
+
+ val formulas =
+ List.foldl (addSubgoalProofFormulas avoid fmNames) formulas proofs
+ in
+ rev formulas
+ end
+(*MetisDebug
+ handle Error err => raise Bug ("Tptp.fromProof: shouldn't fail:\n" ^ err);
+*)
+end;
end
end;