[fset-cvs] r18 - trunk/Code

26 Oct 2008

Author: sburson
Date: Sun Oct 26 05:34:03 2008
New Revision: 18
Log:
Lots and lots of changes for 1.2.
Added:
   trunk/Code/bounded-sets.lisp
   trunk/Code/complement-sets.lisp
   trunk/Code/interval.lisp
   trunk/Code/relations.lisp
Modified:
   trunk/Code/defs.lisp
   trunk/Code/fset.lisp
   trunk/Code/order.lisp
   trunk/Code/port.lisp
   trunk/Code/reader.lisp
   trunk/Code/testing.lisp
   trunk/Code/tuples.lisp
   trunk/Code/wb-trees.lisp
Added: trunk/Code/bounded-sets.lisp
==============================================================================

--- (empty file)
+++ trunk/Code/bounded-sets.lisp	Sun Oct 26 05:34:03 2008
@@ -0,0 +1,209 @@
+;;; -*- Mode: Lisp; Package: FSet; Syntax: ANSI-Common-Lisp -*-
+
+(in-package :fset)
+
+
+;;; "Bounded" is certainly not an ideal term, but I couldn't find anything better
+;;; in Wikipedia's pages on topology.  "Set-in-discrete-topology" is just too long.
+(defstruct (bounded-set
+	     (:include set)
+	     (:constructor make-bounded-set-internal (universe set complement?))
+	     (:predicate bounded-set?)
+	     (:print-function print-bounded-set)
+	     (:copier nil))
+  "A "bounded set" is a subset (not necessarily proper) of a specified set,
+called the "universe".  (Topologically, it is a set in the discrete topology
+on the universe.)"
+  universe
+  set
+  ;; We go to some trouble to make sure that the `set' never contains more than
+  ;; half the `universe'.  This doesn't help asymptotic complexity, but does help
+  ;; with the constant factor.
+  complement?)
+
+(defun make-bounded-set (universe set &optional complement?)
+  (unless (subset? set universe)
+    (error "Attempt to create a bounded-set whose set is not a subset of its universe"))
+  ;; Ensure that if the set is exactly half the size of the universe, we use the
+  ;; positive representation.
+  (if complement?
+      (if (<= (size universe) (* 2 (size set)))
+	  (make-bounded-set-internal universe (set-difference universe set) nil)
+	(make-bounded-set-internal universe set t))
+    (if (< (size universe) (* 2 (size set)))
+	(make-bounded-set-internal universe (set-difference universe set) t)
+      (make-bounded-set-internal universe set nil))))
+
+(defun bounded-set-contents (bs)
+  (if (bounded-set-complement? bs)
+      (set-difference (bounded-set-universe bs) (bounded-set-set bs))
+    (bounded-set-set bs)))
+
+(defmethod complement ((bs bounded-set))
+  (make-bounded-set-internal (bounded-set-universe bs) (bounded-set-set bs)
+			     (not (bounded-set-complement? bs))))
+
+(defmethod empty? ((bs bounded-set))
+  (and (not (bounded-set-complement? bs))
+       (empty? (bounded-set-set bs))))
+
+(defmethod contains? ((bs bounded-set) x)
+  (if (bounded-set-complement? bs)
+      (not (contains? (bounded-set-set bs) x))
+    (contains? (bounded-set-set bs) x)))
+
+(defmethod arb ((bs bounded-set))
+  (if (bounded-set-complement? bs)
+      ;; Ugh
+      (do-set (x (bounded-set-universe bs))
+	(unless (contains? (bounded-set-set bs) x)
+	  (return x)))
+    (arb (bounded-set-set bs))))
+
+(defmethod size ((bs bounded-set))
+  (if (bounded-set-complement? bs)
+      (- (size (bounded-set-universe bs))
+	 (size (bounded-set-set bs)))
+    (size (bounded-set-set bs))))
+
+(defmethod with ((bs1 bounded-set) x &optional (arg2 nil arg2?))
+  (declare (ignore arg2))
+  (check-two-arguments arg2? 'with 'bounded-set)
+  (unless (contains? (bounded-set-universe bs1) x)
+    (error "NIU: You have addressed a planet not ...~@
+	    er, I mean, you have tried to add an element to a bounded-set~@
+	    that is not in its universe"))
+  (if (bounded-set-complement? bs1)
+      (make-bounded-set-internal (bounded-set-universe bs1)
+				 (less (bounded-set-set bs1) x)
+				 t)
+    (make-bounded-set (bounded-set-universe bs1) (with (bounded-set-set bs1) x))))
+
+(defmethod less ((bs1 bounded-set) x &optional (arg2 nil arg2?))
+  (declare (ignore arg2))
+  (check-two-arguments arg2? 'less 'bounded-set)
+  (unless (contains? (bounded-set-universe bs1) x)
+    (error "NIU: You have addressed a planet not ...~@
+	    er, I mean, you have tried to remove an element from a bounded-set~@
+	    that is not in its universe"))
+  (if (bounded-set-complement? bs1)
+      (make-bounded-set (bounded-set-universe bs1) (with (bounded-set-set bs1) x) t)
+    (make-bounded-set-internal (bounded-set-universe bs1)
+			       (less (bounded-set-set bs1) x)
+			       nil)))
+
+(defmethod union ((bs1 bounded-set) (bs2 bounded-set) &key)
+  (unless (equal? (bounded-set-universe bs1) (bounded-set-universe bs2))
+    (error "Can't take the union of two bounded-sets with different universes"))
+  (let ((u (bounded-set-universe bs1))
+	(s1 (bounded-set-set bs1))
+	(s2 (bounded-set-set bs2)))
+    (if (bounded-set-complement? bs1)
+	(if (bounded-set-complement? bs2)
+	    (make-bounded-set-internal u (intersection s1 s2) t)
+	  (make-bounded-set-internal u (set-difference s1 s2) t))
+      (if (bounded-set-complement? bs2)
+	  (make-bounded-set-internal u (set-difference s2 s1) t)
+	(make-bounded-set u (union s1 s2))))))
+
+(defmethod intersection ((bs1 bounded-set) (bs2 bounded-set) &key)
+  (unless (equal? (bounded-set-universe bs1) (bounded-set-universe bs2))
+    (error "Can't take the intersection of two bounded-sets with different universes"))
+  (let ((u (bounded-set-universe bs1))
+	(s1 (bounded-set-set bs1))
+	(s2 (bounded-set-set bs2)))
+    (if (bounded-set-complement? bs1)
+	(if (bounded-set-complement? bs2)
+	    (make-bounded-set u (union s1 s2) t)
+	  (make-bounded-set-internal u (set-difference s2 s1) nil))
+      (if (bounded-set-complement? bs2)
+	  (make-bounded-set-internal u (set-difference s1 s2) nil)
+	(make-bounded-set-internal u (intersection s1 s2) nil)))))
+
+(defmethod set-difference ((bs1 bounded-set) (bs2 bounded-set) &key)
+  (unless (equal? (bounded-set-universe bs1) (bounded-set-universe bs2))
+    (error "Can't take the set-difference of two bounded-sets with different universes"))
+  (let ((u (bounded-set-universe bs1))
+	(s1 (bounded-set-set bs1))
+	(s2 (bounded-set-set bs2)))
+    (if (bounded-set-complement? bs1)
+	(if (bounded-set-complement? bs2)
+	    (make-bounded-set-internal u (set-difference s2 s1) nil)
+	  (make-bounded-set u (union s1 s2) t))
+      (if (bounded-set-complement? bs2)
+	  (make-bounded-set-internal u (intersection s1 s2) nil)
+	(make-bounded-set-internal u (set-difference s1 s2) nil)))))
+
+(defmethod subset? ((bs1 bounded-set) (bs2 bounded-set))
+  (unless (equal? (bounded-set-universe bs1) (bounded-set-universe bs2))
+    (error "Can't do `subset?' on two bounded-sets with different universes"))
+  (let ((s1 (bounded-set-set bs1))
+	(s2 (bounded-set-set bs2)))
+    (if (bounded-set-complement? bs1)
+	(and (bounded-set-complement? bs2)
+	     (subset? s2 s1))
+      (if (bounded-set-complement? bs2)
+	  (disjoint? s1 s2)
+	(subset? s1 s2)))))
+
+(defmethod disjoint? ((bs1 bounded-set) (bs2 bounded-set))
+  (unless (equal? (bounded-set-universe bs1) (bounded-set-universe bs2))
+    (error "Can't do `disjoint?' on two bounded-sets with different universes"))
+  (let ((s1 (bounded-set-set bs1))
+	(s2 (bounded-set-set bs2)))
+    (if (bounded-set-complement? bs1)
+	;; Note, we've ruled out the case where the two sets are mutual complements,
+	;; both in complement form.
+	(and (not (bounded-set-complement? bs2))
+	     (subset? s2 s1))
+      (if (bounded-set-complement? bs2)
+	  (subset? s1 s2)
+	(disjoint? s1 s2)))))
+
+(defmethod internal-do-set ((bs bounded-set) elt-fn value-fn)
+  (declare (optimize (speed 3) (safety 0))
+	   (type function elt-fn value-fn))
+  (if (bounded-set-complement? bs)
+      ;; Should we form the complement?  That would cons -- but this is O(n log n).
+      (internal-do-set (bounded-set-universe bs)
+		       (lambda (x)
+			 (unless (contains? (bounded-set-set bs) x)
+			   (funcall elt-fn x)))
+		       value-fn)
+    (internal-do-set (bounded-set-set bs) elt-fn value-fn)))
+
+(defun print-bounded-set (bs stream level)
+  (declare (ignore level))
+  (format stream "~:[+~;-~]" (bounded-set-complement? bs))
+  (write (bounded-set-set bs) :stream stream))
+
+(defmethod compare ((bs1 bounded-set) (bs2 bounded-set))
+  ;; We don't constrain the bounded-sets to have the same universes, since the
+  ;; FSet way is to let you mix absolutely any objects in sets.  (We feel no
+  ;; obligation to make the different-universe case be fast, though.)
+  (if (equal? (bounded-set-universe bs1) (bounded-set-universe bs2))
+      (let ((s1 (bounded-set-set bs1))
+	    (s2 (bounded-set-set bs2)))
+	(if (bounded-set-complement? bs1)
+	    (if (bounded-set-complement? bs2)
+		(compare s2 s1)
+	      ':greater)
+	  (if (bounded-set-complement? bs2)
+	      ':less
+	    (compare s1 s2))))
+    (compare (bounded-set-contents bs1) (bounded-set-contents bs2))))
+
+(defmethod compare ((bs bounded-set) (s set))
+  ;; Potentially slow, but unlikely to be used.
+  (compare (bounded-set-contents bs) s))
+
+(defmethod compare ((s set) (bs bounded-set))
+  ;; Potentially slow, but unlikely to be used.
+  (compare s (bounded-set-contents bs)))
+
+;;; Hmm... we have no way to say "a normal set" except to specify the
+;;; implementation.  Seems like we have a missing abstract class,
+;;; `enumerated-set' or some such.
+(defmethod convert ((to-type (eql 'wb-set)) (bs bounded-set) &key)
+  (bounded-set-contents bs))
+
Added: trunk/Code/complement-sets.lisp
==============================================================================
--- (empty file)
+++ trunk/Code/complement-sets.lisp	Sun Oct 26 05:34:03 2008
@@ -0,0 +1,125 @@
+;;; -*- Mode: Lisp; Package: FSet; Syntax: ANSI-Common-Lisp -*-
+
+(in-package :fset)
+
+
+(defstruct (complement-set
+	     (:include set)
+	     (:constructor make-complement-set (complement))
+	     (:predicate complement-set?)
+	     (:print-function print-complement-set)
+	     (:copier nil))
+  "A "complement set" is the complement of an ordinary set.  It's infinite, so
+it can't be enumerated as is.  But its complement is ordinary, of course, as is
+its intersection with an ordinary set, and the difference of it and another
+complement set."
+  complement)
+
+(defgeneric complement (set)
+  (:documentation
+    "Returns the complement of the set."))
+
+;;; Compatibility method.
+(defmethod complement ((x function))
+  (cl:complement x))
+
+(defmethod complement ((s set))
+  (make-complement-set s))
+
+(defmethod complement ((cs complement-set))
+  (complement-set-complement cs))
+
+(defmethod contains? ((cs complement-set) x)
+  (not (contains? (complement-set-complement cs) x)))
+
+(defmethod arb ((cs complement-set))
+  ;; Well... I _could_ return some newly consed object... but I think this
+  ;; makes more sense :-)
+  (error "Can't take `arb' of a complement-set"))
+
+(defmethod size ((cs complement-set))
+  ;; Not sure this really makes sense... but what the hell...
+  (- (size (complement-set-complement cs))))
+
+(defmethod with ((cs complement-set) x &optional (arg2 nil arg2?))
+  (declare (ignore arg2))
+  (check-two-arguments arg2? 'with 'complement-set)
+  (let ((comp (complement-set-complement cs))
+	((new (less comp x))))
+    (if (eq new comp) cs
+      (make-complement-set new))))
+
+(defmethod less ((cs complement-set) x &optional (arg2 nil arg2?))
+  (declare (ignore arg2))
+  (check-two-arguments arg2? 'less 'complement-set)
+  (let ((comp (complement-set-complement cs))
+	((new (with comp x))))
+    (if (eq new comp) cs
+      (make-complement-set new))))
+
+(defmethod union ((cs1 complement-set) (cs2 complement-set) &key)
+  (make-complement-set (intersection (complement-set-complement cs1)
+				     (complement-set-complement cs2))))
+
+(defmethod union ((cs complement-set) (s set) &key)
+  (make-complement-set (set-difference (complement-set-complement cs) s)))
+
+(defmethod union ((s set) (cs complement-set) &key)
+  (make-complement-set (set-difference (complement-set-complement cs) s)))
+
+(defmethod intersection ((cs1 complement-set) (cs2 complement-set) &key)
+  (make-complement-set (union (complement-set-complement cs1)
+			      (complement-set-complement cs2))))
+
+(defmethod intersection ((cs complement-set) (s set) &key)
+  (set-difference s (complement-set-complement cs)))
+
+(defmethod intersection ((s set) (cs complement-set) &key)
+  (set-difference s (complement-set-complement cs)))
+
+(defmethod set-difference ((cs1 complement-set) (cs2 complement-set) &key)
+  ;; The Venn diagram is very helpful for understanding this.
+  (set-difference (complement-set-complement cs2) (complement-set-complement cs1)))
+
+(defmethod set-difference ((cs complement-set) (s set) &key)
+  (make-complement-set (union (complement-set-complement cs) s)))
+
+(defmethod set-difference ((s set) (cs complement-set) &key)
+  (intersection s (complement-set-complement cs)))
+
+(defmethod subset? ((cs1 complement-set) (cs2 complement-set))
+  (subset? (complement-set-complement cs2) (complement-set-complement cs1)))
+
+(defmethod subset? ((cs complement-set) (s set))
+  nil)
+
+(defmethod subset? ((s set) (cs complement-set))
+  (disjoint? s (complement-set-complement cs)))
+
+(defmethod disjoint? ((cs1 complement-set) (cs2 complement-set))
+  nil)
+
+(defmethod disjoint? ((cs complement-set) (s set))
+  (subset? s (complement-set-complement cs)))
+
+(defmethod disjoint? ((s set) (cs complement-set))
+  (subset? s (complement-set-complement cs)))
+
+(defmethod internal-do-set ((cs complement-set) elt-fn value-fn)
+  (declare (ignore elt-fn value-fn))
+  (error "Can't enumerate a complement-set"))
+
+(defun print-complement-set (cs stream level)
+  (declare (ignore level))
+  (format stream "~~")			; to distinguish from bounded-sets
+  (write (complement-set-complement cs) :stream stream))
+
+(defmethod compare ((cs1 complement-set) (cs2 complement-set))
+  (compare (complement-set-complement cs2) (complement-set-complement cs1)))
+
+(defmethod compare ((cs complement-set) (s set))
+  ':greater)
+
+(defmethod compare ((s set) (cs complement-set))
+  ':less)
+
Modified: trunk/Code/defs.lisp
==============================================================================
--- trunk/Code/defs.lisp	(original)
+++ trunk/Code/defs.lisp	Sun Oct 26 05:34:03 2008
@@ -12,40 +12,43 @@
(defpackage :fset
-  (:use :cl :gmap :new-let)
+  (:use :cl :gmap :new-let :lexical-contexts)
   (:shadowing-import-from :new-let #:let #:cond)
   ;; For each of these shadowed symbols, using packages must either shadowing-
   ;; import it or shadowing-import the original Lisp symbol.
   (:shadow ;; Shadowed type/constructor names
       #:set #:map
       ;; Shadowed set operations
-	   #:union #:intersection #:set-difference
+	   #:union #:intersection #:set-difference #:complement
       ;; Shadowed sequence operations
-	   #:first #:last #:subseq #:reverse #:sort #:stable-sort
+	   #:first #:last #:subseq #:reverse #:sort #:stable-sort #:reduce
       #:find #:find-if #:find-if-not
       #:count #:count-if #:count-if-not
       #:position #:position-if #:position-if-not
       #:remove #:remove-if #:remove-if-not
       #:substitute #:substitute-if #:substitute-if-not
-	   #:some #:every #:notany #:notevery
-	   ;; This one is internal.
-	   #+(or cmu scl sbcl) #:length)
+	   #:some #:every #:notany #:notevery)
   (:export #:collection #:set #:bag #:map #:seq #:tuple
+	   #:collection? #:set? #:bag? #:map? #:seq? #:tuple?
       #:wb-set #:wb-bag #:wb-map #:wb-seq #:dyn-tuple
-	   #:compare
-	   #:empty? nonempty? #:size #:arb #:member? #:multiplicity
+	   ;; `Equal?' is exported because users may want to call it; `Compare'
+	   ;; because they may want to extend it; and `Compare-Slots' because it's
+	   ;; useful in extending `Compare'.  But `Less-Than?' and `Greater-Than?'
+	   ;; are unlikely to be useful in user code.
+	   #:equal? #:compare #:compare-slots #:identity-ordering-mixin
+	   #:define-cross-type-compare-methods
+	   #:empty? nonempty? #:size #:arb #:contains? #:multiplicity
       #:empty-set #:empty-bag #:empty-map #:empty-seq #:empty-tuple
       #:empty-wb-set #:empty-wb-bag #:empty-wb-map #:empty-wb-seq
       #:empty-dyn-tuple
       #:least #:greatest #:lookup #:@
-	   ;; `with1' etc. have to be exposed in case someone wants to do
-	   ;; `(function ...)' on them.
-	   #:with #:with1 #:with2 #:less #:less1 #:less2
-	   #:union #:bag-sum #:intersection #:bag-product
+	   #:with #:less
+	   #:union #:bag-sum #:intersection #:bag-product #:complement
       #:set-difference #:set-difference-2 #:bag-difference
-	   #:subset? #:subbag?
-	   #:filter #:image #:fold #:domain #:range
-	   #:map-merge #:restrict #:restrict-not #:compose #:map-default
+	   #:subset? #:disjoint? #:subbag?
+	   #:filter #:image #:reduce #:domain #:range #:with-default
+	   #:map-union #:map-intersection #:map-difference-2
+	   #:restrict #:restrict-not #:compose #:map-default
       #:first #:last
       #:lastcons #:head #:tail
       #:with-first #:less-first #:push-first #:pop-first
@@ -63,7 +66,12 @@
       #:fset-setup-readtable #:*fset-readtable*
       #:$
       ;; Used by the bag methods that convert to and from lists.
-	   #:alist))
+	   #:alist
+	   ;; Bounded sets
+	   #:bounded-set #:make-bounded-set #:bounded-set-contents
+	   ;; Relations
+	   #:relation #:bin-rel #:wb-bin-rel #:empty-bin-rel #:empty-wb-bin-rel
+	   #:lookup-inv #:inverse #:join #:conflicts))
;;; A convenient package for experimenting with FSet.  Also serves as an example
@@ -74,15 +82,16 @@
 ;;; You may also wish to do:
 ;;;   (setq *readtable* *fset-readtable*)
 (defpackage :fset-user
-  (:use :cl :fset :gmap :new-let)
+  (:use :cl :fset :gmap :new-let :lexical-contexts)
   (:shadowing-import-from :new-let #:let #:cond)
   (:shadowing-import-from :fset
    		  ;; Shadowed type/constructor names
    		  #:set #:map
    		  ;; Shadowed set operations
-			  #:union #:intersection #:set-difference
+			  #:union #:intersection #:set-difference #:complement
    		  ;; Shadowed sequence operations
    		  #:first #:last #:subseq #:reverse #:sort #:stable-sort
+			  #:reduce
    		  #:find #:find-if #:find-if-not
    		  #:count #:count-if #:count-if-not
    		  #:position #:position-if #:position-if-not
Modified: trunk/Code/fset.lisp
==============================================================================
--- trunk/Code/fset.lisp	(original)
+++ trunk/Code/fset.lisp	Sun Oct 26 05:34:03 2008
@@ -47,13 +47,37 @@
 it simply means that the sole postcondition is that the returned value or pair
 is a member of the collection."))
-(defgeneric member? (x collection)
+;;; I've decided I prefer `contains?' because its argument order is more
+;;; consistent -- I think all the other operations that take a collection and
+;;; a value which might be a member of the collection or its domain, take the
+;;; collection as the first argument.  (Well, except for those we inherit from
+;;; CL, like `find'.)
+(defun member? (x collection)
+  "Returns true iff `x' is a member of the set or bag.  Stylistically, `contains?'
+is preferred over `member?'."
+  (contains? collection x))
+
+(defgeneric contains? (collection x)
+  (:documentation
+    "Returns true iff the set or bag contains `x'."))
+
+(defgeneric domain-contains? (collection x)
+  (:documentation
+    "Returns true iff the domain of the map or seq contains `x'.  (The domain
+of a seq is the set of valid indices.)"))
+
+;;; This is a common operation on seqs, making me wonder if the name should
+;;; be shorter, but I like the clarity of this name.  Simply defining `contains?'
+;;; on maps and seqs to do this is not entirely out of the question, but (a) I
+;;; previously had `contains?' on a map meaning `domain-contains?', and (b) I
+;;; prefer a single generic function to have a single time complexity.
+(defgeneric range-contains? (collection x)
   (:documentation
-    "Returns true iff `x' is a member of a set, bag, or seq, or (for convenience)
-a member of the domain of a map.  Note that for a seq, a linear search is
-required."))
+    "Returns true iff the range of the map or seq contains `x'.  (The range
+of a seq is the set of members.)  Note that this requires a linear search."))
-(defgeneric multiplicity (x bag)
+;;; This used to take its arguments in the other order.
+(defgeneric multiplicity (bag x)
   (:documentation "Returns the multiplicity of `x' in the bag."))
(defgeneric least (collection)
@@ -79,9 +103,32 @@
     "If `collection' is a map, returns the value to which `key' is mapped.
 If `collection' is a seq, takes `key' as an index and returns the
 corresponding member (0-origin, of course).  If `collection' is a set or
-bag that contains a member `equal?' to `key', returns true and the member
+bag that contains a member equal to `key', returns true and the member
 as two values, else false and `nil'; this is useful for canonicalization."))
+(defgeneric rank (collection value)
+  (:documentation
+    "If `collection' is a set or bag that contains `value', returns the rank of
+`value' in the ordering defined by `compare', and a true second value.  If
+`collection' is a map whose domain contains `value', returns the rank of
+`value' in the domain of the map, and a true second value.  If `value' is not
+in the collection, the second value is false, and the first value is the rank
+of the least member of the collection greater than `value' (if any; otherwise
+the size (for a bag, the set-size) of the collection).  Note that if there are
+values/keys that are unequal but equivalent to `value', an arbitrary order
+will be imposed on them for this purpose; but another collection that is
+`equal?' but not `eq' to this one will in general order them differently.
+Also, on a bag, multiplicities are ignored for this purpose."))
+
+(defgeneric at-rank (collection rank)
+  (:documentation
+    "On a set, returns the element with rank `rank'; on a bag, returns
+that element with its multiplicity as a second value; on a map, returns
+the pair with that rank as two values.  Note that if there are values/keys
+that are unequal but equivalent in the collection, an arbitrary order will be
+imposed on them for this purpose; but another collection that is `equal?'
+but not `eq' to this one will in general order them differently."))
+
 (defmacro @ (fn-or-collection &rest args)
   "A little hack with two purposes: (1) to make it easy to make FSet maps
 behave like Lisp functions in certain contexts; and (2) to somewhat lessen the
@@ -89,7 +136,7 @@
 The idea is that you can write `(@ fn arg)', and if `fn' is a Lisp function,
 it will be funcalled on the argument; otherwise `lookup' (q.v.) will be called
 on `fn' and `arg'.  To allow for `@' to be used in more contexts, it actually
-can take any number of `args', though `lookup' always takes exactly one.  Thus
+can take any number of `args', though `lookup' always takes exactly two.  Thus
 you can write `(@ fn arg1 arg2 ...)' when you just want a shorter name for
 `funcall'.  As a matter of style, it is suggested that `@' be used only for
 side-effect-free functions.  Also, though this doc string has spoken only of
@@ -108,41 +155,25 @@
       ;; length and issue the error ourselves (if that helps).
       (lookup ,fn-var . ,args))))))
-(defmacro with (collection val1 &optional (val2 nil val2?))
-  "A syntactic convenience.  Expands to a call to `with1' if called with two
-arguments, or to `with2' if called with three."
-  (if val2? `(with2 ,collection ,val1 ,val2)
-    `(with1 ,collection ,val1)))
-
-(defgeneric with1 (collection value)
-  (:documentation
-    "Adds `value' to a set or bag, returning the updated collection."))
-
-(defgeneric with2 (collection key value)
-  (:documentation
-    "Adds a mapping from `key' to `value' to a map or seq, returning the
-updated collection.  In the seq case, `key' must be in the interval
-[0, size(collection)]."))
-
-(defmacro less (collection val1 &optional (val2 nil val2?))
-  "A syntactic convenience.  Expands to a call to `less1' if called with two
-arguments, or to `less2' if called with three."
-  (if val2? `(less2 ,collection ,val1 ,val2)
-    `(less1 ,collection ,val1)))
-
-(defgeneric less1 (collection value)
-  (:documentation
-    "Removes `value' from a set, or the pair whose key is `value' from a
-map, or one occurrence of `value' from a bag, or the element whose index
-is `value' from a seq (shifting subsequent elements down); returns the
-updated collection."))
-
-(defgeneric less2 (collection value count)
+(defgeneric with (collection value1 &optional value2)
   (:documentation
-    "Removes `count' occurrences of `value' from a bag, returning the updated
-collection."))
+    "On a set, adds `value1' to it, returning the updated set.  On a bag, adds
+`value2' occurrences of `value1', returning the updated bag; `value2' defaults
+to 1.  On a map, adds a mapping from `value1' (the key) to `value2', returning
+the updated map.  On a seq, replaces the element at index `value1' with
+`value2', returning the updated seq (the seq is extended in either direction
+if needed; previously uninitialized indices are filled with the seq's default)."))
+
+(defgeneric less (collection value1 &optional value2)
+  (:documentation
+    "On a set, removes `value1' from it if present, returning the updated set.
+On a bag, removes `value2' occurrences of `value1' if present, returning the
+updated bag; `value2' defaults to 1.  On a map, removes the pair whose key is
+`value1', if present, returning the updated map.  On a seq, removes the element
+at index `value1', if that index is in bounds, and shifts subsequent elements
+down, returning the updated seq."))
-(defgeneric union (set-or-bag1 set-or-bag2)
+(defgeneric union (set-or-bag1 set-or-bag2 &key)
   (:documentation
     "Returns the union of the two sets/bags.  The result is a set if both
 arguments are sets; otherwise a bag.  The union of two bags is a bag whose
@@ -154,7 +185,7 @@
     "Returns a bag whose multiplicity, for any value, is the sum of its
 multiplicities in the two argument bags."))
-(defgeneric intersection (set-or-bag1 set-or-bag2)
+(defgeneric intersection (set-or-bag1 set-or-bag2 &key)
   (:documentation
     "Returns the intersection of the two sets/bags.  The result is a bag
 if both arguments are bags; otherwise a set.  The intersection of two bags
@@ -166,7 +197,7 @@
     "Returns a bag whose multiplicity, for any value, is the product of
 its multiplicities in the two argument bags."))
-(defgeneric set-difference (set1 set2)
+(defgeneric set-difference (set1 set2 &key)
   (:documentation
     "Returns the set difference of set1 and set2, i.e., the set containing
 every member of `set1' that is not in `set2'."))
@@ -180,13 +211,18 @@
     "Returns a bag whose multiplicity, for any value, is its multiplicity
 in `bag1' less that in `bag2', but of course not less than zero."))
-(defgeneric subset? (set1 set2)
-  (:documentation "Returns true iff `set1' is a subset of `set2'."))
+(defgeneric subset? (sub super)
+  (:documentation "Returns true iff `sub' is a subset of `super'."))
-(defgeneric subbag? (bag1 bag2)
+(defgeneric disjoint? (set1 set2)
   (:documentation
-    "Returns true iff `bag1' is a subbag of `bag2', that is, for every
-member of `bag1', `bag2' contains the same value with at least the same
+    "Returns true iff `set1' and `set2' have a null intersection (without
+actually constructing said intersection)."))
+
+(defgeneric subbag? (sub super)
+  (:documentation
+    "Returns true iff `sub' is a subbag of `super', that is, for every
+member of `sub', `super' contains the same value with at least the same
 multiplicity."))
(defgeneric filter (fn collection)
@@ -209,14 +245,17 @@
 Lisp function of two arguments that returns two values (the map-default of the
 result is that of `collection')."))
-(defgeneric fold (fn collection &optional initial-value)
+(defgeneric reduce (fn collection &key key initial-value)
   (:documentation
-    "Iterates over `collection', maintaining a state S; on each iteration, `fn'
-is called on S and the next member of `collection', and the result is used as
-the new value of S; finally, returns S.  The first iteration is special: if
-`initial-value' is supplied, it is used as the initial S; otherwise, the first
-member of `collection' is used as the initial S, and `fn' is not called on this
-iteration."))
+    "If `collection' is a Lisp sequence, this simply calls `cl:reduce' (q.v.).
+On an FSet collection, the `:start', `:end', and `:from-end' keywords are
+accepted only if `collection' is a seq."))
+
+(defmethod reduce (fn (s sequence) &rest keyword-args
+		   &key key initial-value start end from-end)
+  (declare (dynamic-extent keyword-args)
+	   (ignore key initial-value start end from-end))
+  (apply #'cl:reduce fn s keyword-args))
(defgeneric domain (map)
   (:documentation
@@ -227,27 +266,42 @@
     "Returns the range of the map, that is, the set of all values to which keys
 are mapped by the map."))
+(defgeneric default (collection)
+  (:documentation
+    "Returns the default for the map or seq, i.e., the value returned by `lookup'
+when the supplied key or index is not in the domain."))
+
+(defgeneric with-default (collection new-default)
+  (:documentation
+    "Returns a new map or seq with the same contents as `collection' but whose
+default is now `new-default'."))
+
 (defgeneric map-union (map1 map2 &optional val-fn)
   (:documentation
     "Returns a map containing all the keys of `map1' and `map2', where the
 value for each key contained in only one map is the value from that map, and
-the value for each key contained in both maps is the result of calling `val-fn'
-on the key, the value from `map1', and the value from `map2'.  `val-fn'
-defaults to simply returning its third argument, so the entries in `map2'
-simply shadow those in `map1'.  Also, `val-fn' must have the property that if
-its second and third arguments are equal, its result is equal to them.  The
-default for the new map is computed by calling `val-fn' on the symbol
-`fset:map-default' and the defaults for the two maps."))
+the value for each key contained in both maps is the result of calling
+`val-fn' on the value from `map1' and the value from `map2'.  `val-fn'
+defaults to simply returning its second argument, so the entries in `map2'
+simply shadow those in `map1'.  The default for the new map is the result of
+calling `val-fn' on the defaults for the two maps (so be sure it can take
+these values)."))
(defgeneric map-intersection (map1 map2 &optional val-fn)
   (:documentation
     "Returns a map containing all the keys that are in the domains of both
 `map1' and `map2', where the value for each key is the result of calling
-`val-fn' on the key, the value from `map1', and the value from `map2'.
-`val-fn' defaults to simply returning its third argument, so the entries in
-`map2' simply shadow those in `map1'.  The default for the new map is
-computed by calling `val-fn' on the symbol `fset:map-default' and the
-defaults for the two maps."))
+`val-fn' on the value from `map1' and the value from `map2'.  `val-fn'
+defaults to simply returning its second argument, so the entries in `map2'
+simply shadow those in `map1'.  The default for the new map is the result
+of calling `val-fn' on the defaults for the two maps (so be sure it can
+take these values)."))
+
+(defgeneric map-difference-2 (map1 map2)
+  (:documentation
+    "Returns, as two values: a map containing all the pairs that are in `map1'
+but not `map2', with the same default as `map1'; and one containing all the
+pairs that are in `map2' but not `map1', with the same default as `map2'."))
(defgeneric restrict (map set)
   (:documentation
@@ -311,8 +365,9 @@
(defgeneric insert (seq idx val)
   (:documentation
-    "Returns a new sequence like `seq' but with `val' inserted at `idx', which
-must be in [0, n] where `n' is `(size seq)'."))
+    "Returns a new sequence like `seq' but with `val' inserted at `idx' (the seq
+is extended in either direction if needed prior to the insertion; previously
+uninitialized indices are filled with the seq's default)."))
;;; &&& Maybe we should shadow `concatenate' instead, so you can specify a
 ;;; result type.
@@ -331,7 +386,7 @@
;;; The `&allow-other-keys' is to persuade SBCL not to issue warnings about keywords
 ;;; that are accepted by some methods of `convert'.
-(declaim (ftype (function (t t &key &allow-other-keys) function) convert))
+(declaim (ftype (function (t t &key &allow-other-keys) t) convert))
;;; ================================================================================
 ;;; Iterators
@@ -357,7 +412,7 @@
 it is exhausted, it returns two `nil' values (three, for a map)."))
;;; The `&allow-other-keys' is to persuade SBCL not to issue warnings about keywords
-;;; that are acccpted by some methods of `convert'.
+;;; that are accepted by some methods of `iterator'.
 (declaim (ftype (function (t &key &allow-other-keys) function) iterator))
;;; Iterators for the Lisp sequence types are useful for some generic operations
@@ -475,8 +530,10 @@
 if `collection' is a seq.  Also, on a map, this scans the domain; on success,
 it returns the corresponding range element as the second value."))
-(defmethod find (item (s sequence) &rest keyword-args)
-  (declare (dynamic-extent keyword-args))
+(defmethod find (item (s sequence) &rest keyword-args
+		      &key key test test-not start end from-end)
+  (declare (dynamic-extent keyword-args)
+	   (ignore key test test-not start end from-end))
   (apply #'cl:find item s keyword-args))
(defgeneric find-if (pred collection &key key)
@@ -486,8 +543,9 @@
 only if `collection' is a seq.  Also, on a map, this scans the domain; on
 success, it returns the corresponding range element as the second value."))
-(defmethod find-if (pred (s sequence) &rest keyword-args)
-  (declare (dynamic-extent keyword-args))
+(defmethod find-if (pred (s sequence) &rest keyword-args &key key start end from-end)
+  (declare (dynamic-extent keyword-args)
+	   (ignore key start end from-end))
   (apply #'cl:find-if pred s keyword-args))
(defgeneric find-if-not (pred collection &key key)
@@ -497,8 +555,9 @@
 accepted only if `collection' is a seq.  Also, on a map, this scans the domain;
 on success, it returns the corresponding range element as the second value."))
-(defmethod find-if-not (pred (s sequence) &rest keyword-args)
-  (declare (dynamic-extent keyword-args))
+(defmethod find-if-not (pred (s sequence) &rest keyword-args &key key start end from-end)
+  (declare (dynamic-extent keyword-args)
+	   (ignore key start end from-end))
   (apply #'cl:find-if-not pred s keyword-args))
(defgeneric count (item collection &key key test)
@@ -508,8 +567,10 @@
 accepted; and the `:start', `:end', and `:from-end' keywords are accepted only
 if `collection' is a seq.  Also, on a map, this scans the domain."))
-(defmethod count (item (s sequence) &rest keyword-args)
-  (declare (dynamic-extent keyword-args))
+(defmethod count (item (s sequence) &rest keyword-args
+		       &key key test test-not start end from-end)
+  (declare (dynamic-extent keyword-args)
+	   (ignore key test test-not start end from-end))
   (apply #'cl:count item s keyword-args))
(defgeneric count-if (pred collection &key key)
@@ -518,8 +579,9 @@
 FSet collection, the `:start', `:end', and `:from-end' keywords are accepted
 only if `collection' is a seq.  Also, on a map, this scans the domain."))
-(defmethod count-if (pred (s sequence) &rest keyword-args)
-  (declare (dynamic-extent keyword-args))
+(defmethod count-if (pred (s sequence) &rest keyword-args &key key start end from-end)
+  (declare (dynamic-extent keyword-args)
+	   (ignore key start end from-end))
   (apply #'cl:count-if pred s keyword-args))
(defgeneric count-if-not (pred collection &key key)
@@ -528,8 +590,9 @@
 On an FSet collection, the `:start', `:end', and `:from-end' keywords are
 accepted only if `collection' is a seq.  Also, on a map, this scans the domain."))
-(defmethod count-if-not (pred (s sequence) &rest keyword-args)
-  (declare (dynamic-extent keyword-args))
+(defmethod count-if-not (pred (s sequence) &rest keyword-args &key key start end from-end)
+  (declare (dynamic-extent keyword-args)
+	   (ignore key start end from-end))
   (apply #'cl:count-if-not pred s keyword-args))
(defgeneric position (item collection &key key test start end from-end)
@@ -538,8 +601,10 @@
 FSet seq, the default for `test' is `equal?', and the `:test-not' keyword is
 not accepted."))
-(defmethod position (item (s sequence) &rest keyword-args)
-  (declare (dynamic-extent keyword-args))
+(defmethod position (item (s sequence) &rest keyword-args
+			  &key key test test-not start end from-end)
+  (declare (dynamic-extent keyword-args)
+	   (ignore key test test-not start end from-end))
   (apply #'cl:position item s keyword-args))
(defgeneric position-if (pred collection &key key start end from-end)
@@ -547,36 +612,43 @@
     "If `collection' is a Lisp sequence, this simply calls `cl:position-if'.
 Also works on an FSet seq."))
-(defmethod position-if (pred (s sequence) &rest keyword-args)
-  (declare (dynamic-extent keyword-args))
+(defmethod position-if (pred (s sequence) &rest keyword-args &key key start end from-end)
+  (declare (dynamic-extent keyword-args)
+	   (ignore key start end from-end))
   (apply #'cl:position-if pred s keyword-args))
-(defgeneric position-if-not (pred collection &key key)
+(defgeneric position-if-not (pred collection &key key start end from-end)
   (:documentation
     "If `collection' is a Lisp sequence, this simply calls `cl:position-if-not'.
 Also works on an FSet seq."))
-(defmethod position-if-not (pred (s sequence) &rest keyword-args)
-  (declare (dynamic-extent keyword-args))
+(defmethod position-if-not (pred (s sequence) &rest keyword-args
+				 &key key start end from-end)
+  (declare (dynamic-extent keyword-args)
+	   (ignore key start end from-end))
   (apply #'cl:position-if-not pred s keyword-args))
-(defgeneric remove (item collection &key key test start end from-end count)
+(defgeneric remove (item collection &key key test)
   (:documentation
     "If `collection' is a Lisp sequence, this simply calls `cl:remove'.  On an
 FSet seq, the default for `test' is `equal?', and the `:test-not' keyword is
 not accepted."))
-(defmethod remove (item (s sequence) &rest keyword-args)
-  (declare (dynamic-extent keyword-args))
+(defmethod remove (item (s sequence) &rest keyword-args
+			&key key test start end from-end count)
+  (declare (dynamic-extent keyword-args)
+	   (ignore key test start end from-end count))
   (apply #'cl:remove item s keyword-args))
-(defgeneric remove-if (pred collection &key key start end from-end count)
+(defgeneric remove-if (pred collection &key key)
   (:documentation
     "If `collection' is a Lisp sequence, this simply calls `cl:remove-if'.
 Also works on an FSet seq; but see `filter'."))
-(defmethod remove-if (pred (s sequence) &rest keyword-args)
-  (declare (dynamic-extent keyword-args))
+(defmethod remove-if (pred (s sequence) &rest keyword-args
+			   &key key start end from-end count)
+  (declare (dynamic-extent keyword-args)
+	   (ignore key start end from-end count))
   (apply #'cl:remove-if pred s keyword-args))
(defgeneric remove-if-not (pred collection &key key)
@@ -584,36 +656,44 @@
     "If `collection' is a Lisp sequence, this simply calls `cl:remove-if-not'.
 Also works on an FSet seq; but see `filter'."))
-(defmethod remove-if-not (pred (s sequence) &rest keyword-args)
-  (declare (dynamic-extent keyword-args))
+(defmethod remove-if-not (pred (s sequence) &rest keyword-args
+			       &key key start end from-end count)
+  (declare (dynamic-extent keyword-args)
+	   (ignore key start end from-end count))
   (apply #'cl:remove-if-not pred s keyword-args))
-(defgeneric substitute (newitem olditem collection &key key test start end from-end count)
+(defgeneric substitute (newitem olditem collection &key key)
   (:documentation
     "If `collection' is a Lisp sequence, this simply calls `cl:substitute'.  On
 an FSet seq, the default for `test' is `equal?', and the `:test-not' keyword
 is not accepted."))
-(defmethod substitute (newitem olditem (s sequence) &rest keyword-args)
-  (declare (dynamic-extent keyword-args))
+(defmethod substitute (newitem olditem (s sequence) &rest keyword-args
+			       &key key test start end from-end count)
+  (declare (dynamic-extent keyword-args)
+	   (ignore key test start end from-end count))
   (apply #'cl:substitute newitem olditem s keyword-args))
-(defgeneric substitute-if (newitem pred collection &key key start end from-end count)
+(defgeneric substitute-if (newitem pred collection &key key)
   (:documentation
     "If `collection' is a Lisp sequence, this simply calls `cl:substitute-if'.
 Also works on an FSet seq."))
-(defmethod substitute-if (newitem pred (s sequence) &rest keyword-args)
-  (declare (dynamic-extent keyword-args))
+(defmethod substitute-if (newitem pred (s sequence) &rest keyword-args
+				  &key key start end from-end count)
+  (declare (dynamic-extent keyword-args)
+	   (ignore key start end from-end count))
   (apply #'cl:substitute-if newitem pred s keyword-args))
-(defgeneric substitute-if-not (newitem pred collection &key key start end from-end count)
+(defgeneric substitute-if-not (newitem pred collection &key key)
   (:documentation
     "If `collection' is a Lisp sequence, this simply calls `cl:substitute-if-not'.
 Also works on an FSet seq."))
-(defmethod substitute-if-not (newitem pred (s sequence) &rest keyword-args)
-  (declare (dynamic-extent keyword-args))
+(defmethod substitute-if-not (newitem pred (s sequence) &rest keyword-args
+				      &key key start end from-end count)
+  (declare (dynamic-extent keyword-args)
+	   (ignore key start end from-end count))
   (apply #'cl:substitute-if-not newitem pred s keyword-args))
;;; `(gmap :or ...)' is a bit faster.
@@ -657,6 +737,22 @@
   (not (apply #'every pred sequence0 more-sequences)))
+(defmethod union ((ls1 list) (ls2 list) &rest keyword-args &key test test-not)
+  (declare (dynamic-extent keyword-args)
+	   (ignore test test-not))
+  (apply #'cl:union ls1 ls2 keyword-args))
+
+(defmethod intersection ((ls1 list) (ls2 list) &rest keyword-args &key test test-not)
+  (declare (dynamic-extent keyword-args)
+	   (ignore test test-not))
+  (apply #'cl:intersection ls1 ls2 keyword-args))
+
+(defmethod set-difference ((ls1 list) (ls2 list) &rest keyword-args &key test test-not)
+  (declare (dynamic-extent keyword-args)
+	   (ignore test test-not))
+  (apply #'cl:set-difference ls1 ls2 keyword-args))
+
+
 ;;; ================================================================================
 ;;; New names for a few existing CL functions
@@ -767,7 +863,7 @@
     (setq ,(car new) (less-last ,(car new)))
     ,setter))))
-				      
+
 ;;; ================================================================================
 ;;; Sets
@@ -813,13 +909,26 @@
     (if tree (values (WB-Set-Tree-Arb tree) t)
       (values nil nil))))
-(defmethod member? (x (s wb-set))
+(defmethod contains? ((s wb-set) x)
   (WB-Set-Tree-Member? (wb-set-contents s) x))
;;; Note, first value is `t' or `nil'.
 (defmethod lookup ((s wb-set) key)
   (WB-Set-Tree-Find-Equal (wb-set-contents s) key))
+(defmethod rank ((s wb-set) x)
+  (let ((found? rank (WB-Set-Tree-Rank (wb-set-contents s) x)))
+    (values rank found?)))
+
+(defmethod at-rank ((s wb-set) rank)
+  (let ((contents (wb-set-contents s))
+	((size (WB-Set-Tree-Size contents))))
+    (unless (and (>= rank 0) (< rank size))
+      (error 'simple-type-error :datum rank :expected-type `(integer 0 (,size))
+	     :format-control "Rank ~D out of bounds on ~A"
+	     :format-arguments (list rank s)))
+    (WB-Set-Tree-Rank-Element contents rank)))
+
 (defmethod least ((s wb-set))
   (let ((tree (wb-set-contents s)))
     (if tree (values (WB-Set-Tree-Least tree) t)
@@ -829,27 +938,43 @@
   (let ((tree (wb-set-contents s)))
     (and tree (values (WB-Set-Tree-Greatest tree) t))))
-(defmethod with1 ((s wb-set) value)
+(defmacro check-two-arguments (arg2? op type)
+  `(when ,arg2?
+     (error 'simple-program-error
+	    :format-control "~A on a ~A takes only two arguments"
+	    :format-arguments (list ,op ,type))))
+
+(defmacro check-three-arguments (arg2? op type)
+  `(unless ,arg2?
+     (error 'simple-program-error
+	    :format-control "~A on a ~A takes three arguments"
+	    :format-arguments (list ,op ,type))))
+
+(defmethod with ((s wb-set) value &optional (arg2 nil arg2?))
+  (declare (ignore arg2))
+  (check-two-arguments arg2? 'with 'wb-set)
   (let ((contents (wb-set-contents s))
    ((new-contents (WB-Set-Tree-With contents value))))
     (if (eq new-contents contents)
    s
       (make-wb-set new-contents))))
-(defmethod less1 ((s wb-set) value)
+(defmethod less ((s wb-set) value &optional (arg2 nil arg2?))
+  (declare (ignore arg2))
+  (check-two-arguments arg2? 'less 'wb-set)
   (let ((contents (wb-set-contents s))
    ((new-contents (WB-Set-Tree-Less contents value))))
     (if (eq new-contents contents)
    s
       (make-wb-set new-contents))))
-(defmethod union ((s1 wb-set) (s2 wb-set))
+(defmethod union ((s1 wb-set) (s2 wb-set) &key)
   (make-wb-set (WB-Set-Tree-Union (wb-set-contents s1) (wb-set-contents s2))))
-(defmethod intersection ((s1 wb-set) (s2 wb-set))
+(defmethod intersection ((s1 wb-set) (s2 wb-set) &key)
   (make-wb-set (WB-Set-Tree-Intersect (wb-set-contents s1) (wb-set-contents s2))))
-(defmethod set-difference ((s1 wb-set) (s2 wb-set))
+(defmethod set-difference ((s1 wb-set) (s2 wb-set) &key)
   (make-wb-set (WB-Set-Tree-Diff (wb-set-contents s1) (wb-set-contents s2))))
(defmethod set-difference-2 ((s1 wb-set) (s2 wb-set))
@@ -859,6 +984,9 @@
 (defmethod subset? ((s1 wb-set) (s2 wb-set))
   (WB-Set-Tree-Subset? (wb-set-contents s1) (wb-set-contents s2)))
+(defmethod disjoint? ((s1 wb-set) (s2 wb-set))
+  (WB-Set-Tree-Disjoint? (wb-set-contents s1) (wb-set-contents s2)))
+
 (defmethod compare ((s1 wb-set) (s2 wb-set))
   (WB-Set-Tree-Compare (wb-set-contents s1) (wb-set-contents s2)))
@@ -873,6 +1001,8 @@
   "For each member of `set', binds `var' to it and executes `body'.  When done,
 returns `value'."
   `(block nil		; in case `body' contains `(return ...)'
+     ;; &&& Here and in similar cases below, `dynamic-extent' declarations could
+     ;; be helpful.  (The closures will have to be bound to variables.)
      (internal-do-set ,set #'(lambda (,var) . ,body)
    		   #'(lambda () ,value))))
@@ -931,29 +1061,35 @@
       (setq result (WB-Set-Tree-With result (@ fn x))))
     (make-wb-set result)))
-(defmethod fold ((fn function) (s set) &optional (initial-value nil init?))
-  (set-fold fn s initial-value init?))
+(defmethod reduce ((fn function) (s set) &key key (initial-value nil init?))
+  (set-reduce fn s initial-value (and key (coerce key 'function)) init?))
-(defmethod fold ((fn symbol) (s set) &optional (initial-value nil init?))
-  (set-fold (coerce fn 'function) s initial-value init?))
+(defmethod reduce ((fn symbol) (s set) &key key (initial-value nil init?))
+  (set-reduce (coerce fn 'function) s initial-value (and key (coerce key 'function))
+	      init?))
-(defun set-fold (fn s initial-value init?)
+(defun set-reduce (fn s initial-value key init?)
   (declare (optimize (speed 3) (safety 0))
-	   (type function fn))
-  (if init?
-      (let ((result initial-value))
-	(do-set (x s)
-	  (setq result (funcall fn result x)))
-	result)
-    (if (empty? s)
-	(error "Attempt to fold an empty set with no initial value")
-      (let ((result nil)
-	    (first? t))
-	(do-set (x s)
-	  (if first? (setq result x
-			   first? nil)
-	    (setq result (funcall fn result x))))
-	result))))
+	   (type function fn)
+	   (type (or function null) key))
+  (let ((result initial-value)
+	(call-fn? init?))
+    (if (and (not init?) (empty? s))
+	(setq result (funcall fn))
+      (do-set (x s)
+	(if call-fn?
+	    (setq result (funcall fn result (if key (funcall key x) x)))
+	  (setq result (if key (funcall key x) x)
+		call-fn? t))))
+    result))
+
+;;; For convenience.  Note that it always returns a seq.
+(defmethod sort ((s set) pred &key key)
+  (convert 'seq (cl:sort (convert 'vector s) pred :key key)))
+
+;;; For convenience.  Note that it always returns a seq.
+(defmethod stable-sort ((s set) pred &key key)
+  (convert 'seq (cl:stable-sort (convert 'vector s) pred :key key)))
(defmethod convert ((to-type (eql 'set)) (s set) &key)
   s)
@@ -974,16 +1110,36 @@
       (push x result))
     (nreverse result)))
+(defmethod convert ((to-type (eql 'vector)) (s set) &key)
+  (declare (optimize (speed 3) (safety 0)))
+  (let ((result (make-array (the fixnum (size s))))
+	(i 0))
+    (declare (type fixnum i))
+    (do-set (x s)
+      (setf (svref result i) x)
+      (incf i))
+    result))
+
 (defmethod convert ((to-type (eql 'seq)) (s set) &key)
   ;; Not sure we can improve on this much.
   (convert 'seq (convert 'list s)))
+(defmethod convert ((to-type (eql 'wb-seq)) (s set) &key)
+  ;; Not sure we can improve on this much.
+  (convert 'wb-seq (convert 'list s)))
+
 (defmethod convert ((to-type (eql 'set)) (l list) &key)
   (make-wb-set (WB-Set-Tree-From-List l)))
(defmethod convert ((to-type (eql 'wb-set)) (l list) &key)
   (make-wb-set (WB-Set-Tree-From-List l)))
+(defmethod convert ((to-type (eql 'set)) (s sequence) &key)
+  (make-wb-set (WB-Set-Tree-From-CL-Sequence s)))
+
+(defmethod convert ((to-type (eql 'wb-set)) (s sequence) &key)
+  (make-wb-set (WB-Set-Tree-From-CL-Sequence s)))
+
 (defmethod find (item (s set) &key key test)
   (declare (optimize (speed 3) (safety 0)))
   (if key
@@ -1070,20 +1226,17 @@
   (if (and *print-level* (>= level *print-level*))
       (format stream "#")
     (progn
-      (format stream "#{ ")
+      (format stream "#{")
       (let ((i 0))
    (do-set (x set)
-	  (when (> i 0)
-	    (format stream " "))
+	  (format stream " ")
      (when (and *print-length* (>= i *print-length*))
        (format stream "...")
        (return))
      (incf i)
      (let ((*print-level* (and *print-level* (1- *print-level*))))
-	    (write x :stream stream)))
-	(when (> i 0)
-	  (format stream " ")))
-      (format stream "}"))))
+	    (write x :stream stream))))
+      (format stream " }"))))
(def-gmap-arg-type :set (set)
   "Yields the elements of `set'."
@@ -1144,7 +1297,7 @@
      (values val mult t))
       (values nil nil nil))))
-(defmethod member? (x (b wb-bag))
+(defmethod contains? ((b wb-bag) x)
   (plusp (WB-Bag-Tree-Multiplicity (wb-bag-contents b) x)))
(defmethod lookup ((b wb-bag) x)
@@ -1153,6 +1306,19 @@
    (values t value-found)
       (values nil nil))))
+(defmethod rank ((s wb-bag) x)
+  (let ((found? rank (WB-Bag-Tree-Rank (wb-bag-contents s) x)))
+    (values rank found?)))
+
+(defmethod at-rank ((s wb-bag) rank)
+  (let ((contents (wb-bag-contents s))
+	((size (WB-Bag-Tree-Size contents))))
+    (unless (and (>= rank 0) (< rank size))
+      (error 'simple-type-error :datum rank :expected-type `(integer 0 (,size))
+	     :format-control "Rank ~D out of bounds on ~A"
+	     :format-arguments (list rank s)))
+    (WB-Bag-Tree-Rank-Pair contents rank)))
+
 (defmethod least ((b wb-bag))
   (let ((tree (wb-bag-contents b)))
     (if tree
@@ -1173,36 +1339,30 @@
 (defmethod set-size ((b wb-bag))
   (WB-Bag-Tree-Size (wb-bag-contents b)))
-(defmethod multiplicity (x (b wb-bag))
+(defmethod multiplicity ((b wb-bag) x)
   (WB-Bag-Tree-Multiplicity (wb-bag-contents b) x))
-(defmethod multiplicity (x (s set))
-  (if (member? x s) 1 0))
+(defmethod multiplicity ((s set) x)
+  (if (contains? s x) 1 0))
-(defmethod with1 ((b wb-bag) value)
-  (make-wb-bag (WB-Bag-Tree-With (wb-bag-contents b) value)))
-
-(defmethod with2 ((b wb-bag) value multiplicity)
+(defmethod with ((b wb-bag) value &optional (multiplicity 1))
   (assert (and (integerp multiplicity) (not (minusp multiplicity))))
   (if (zerop multiplicity) b
     (make-wb-bag (WB-Bag-Tree-With (wb-bag-contents b) value multiplicity))))
-(defmethod less1 ((b wb-bag) value)
-  (make-wb-bag (WB-Bag-Tree-Less (wb-bag-contents b) value)))
-
-(defmethod less2 ((b wb-bag) value multiplicity)
+(defmethod less ((b wb-bag) value &optional (multiplicity 1))
   (assert (and (integerp multiplicity) (not (minusp multiplicity))))
   (if (zerop multiplicity) b
     (make-wb-bag (WB-Bag-Tree-Less (wb-bag-contents b) value multiplicity))))
-(defmethod union ((b1 wb-bag) (b2 wb-bag))
+(defmethod union ((b1 wb-bag) (b2 wb-bag) &key)
   (make-wb-bag (WB-Bag-Tree-Union (wb-bag-contents b1) (wb-bag-contents b2))))
-(defmethod union ((s wb-set) (b wb-bag))
+(defmethod union ((s wb-set) (b wb-bag) &key)
   (make-wb-bag (WB-Bag-Tree-Union (WB-Set-Tree-To-Bag-Tree (wb-set-contents s))
    			  (wb-bag-contents b))))
-(defmethod union ((b wb-bag) (s wb-set))
+(defmethod union ((b wb-bag) (s wb-set) &key)
   (make-wb-bag (WB-Bag-Tree-Union (wb-bag-contents b)
    			  (WB-Set-Tree-To-Bag-Tree (wb-set-contents s)))))
@@ -1217,14 +1377,14 @@
   (make-wb-bag (WB-Bag-Tree-Sum (wb-bag-contents b)
    			(WB-Set-Tree-To-Bag-Tree (wb-set-contents s)))))
-(defmethod intersection ((s1 wb-bag) (s2 wb-bag))
+(defmethod intersection ((s1 wb-bag) (s2 wb-bag) &key)
   (make-wb-bag (WB-Bag-Tree-Intersect (wb-bag-contents s1) (wb-bag-contents s2))))
-(defmethod intersection ((s wb-set) (b wb-bag))
+(defmethod intersection ((s wb-set) (b wb-bag) &key)
   (make-wb-bag (WB-Set-Tree-Intersect (wb-set-contents s)
    			      (WB-Bag-Tree-To-Set-Tree (wb-bag-contents b)))))
-(defmethod intersection ((b wb-bag) (s wb-set))
+(defmethod intersection ((b wb-bag) (s wb-set) &key)
   (make-wb-bag (WB-Set-Tree-Intersect (WB-Bag-Tree-To-Set-Tree (wb-bag-contents b))
    			      (wb-set-contents s))))
@@ -1282,10 +1442,14 @@
    	  &body body)
   "For each member of `bag', binds `value-var' to it and and executes `body' a
 number of times equal to the member's multiplicity.  When done, returns `value'."
-  (let ((mult-var (gensym "MULT-")))
+  (let ((mult-var (gensym "MULT-"))
+	(idx-var (gensym "IDX-")))
     `(block nil
        (internal-do-bag-pairs ,bag #'(lambda (,value-var ,mult-var)
-				       (dotimes (i ,mult-var)
+				       ;; Seems safe to assume it's a fixnum here.
+				       (declare (type fixnum ,mult-var))
+				       (dotimes (,idx-var ,mult-var)
+					 (declare (type fixnum ,idx-var))
    				 . ,body))
    		      #'(lambda () ,value)))))
@@ -1344,32 +1508,27 @@
       (setq result (WB-Bag-Tree-With result (@ fn x) n)))
     (make-wb-bag result)))
-(defmethod fold ((fn function) (s bag) &optional (initial-value nil init?))
-  (bag-fold fn s initial-value init?))
+(defmethod reduce ((fn function) (b bag) &key key (initial-value nil init?))
+  (bag-reduce fn b initial-value (and key (coerce key 'function)) init?))
-(defmethod fold ((fn symbol) (s bag) &optional (initial-value nil init?))
-  (bag-fold (coerce fn 'function) s initial-value init?))
+(defmethod reduce ((fn symbol) (b bag) &key key (initial-value nil init?))
+  (bag-reduce (coerce fn 'function) b initial-value (and key (coerce key 'function))
+	      init?))
-(defun bag-fold (fn s initial-value init?)
-  ;; Expect 5 Python notes about generic arithmetic.
+(defun bag-reduce (fn b initial-value key init?)
   (declare (optimize (speed 3) (safety 0))
-	   (type function fn))
-  (if init?
-      (let ((result initial-value))
-	(do-bag (x s)
-	  (setq result (funcall fn result x)))
-	result)
-    (if (empty? s)
-	(error "Attempt to fold an empty bag with no initial value")
-      (let ((result nil)
-	    (first? t))
-	(do-bag-pairs (x n s)
-	  (if first? (setq result x
-			   first? nil)
-	    (setq result (funcall fn result x)))
-	  (dotimes (i (1- n))
-	    (setq result (funcall fn result x))))
-	result))))
+	   (type function fn)
+	   (type (or function null) key))
+  (let ((result initial-value)
+	(call-fn? init?))
+    (if (and (not init?) (empty? b))
+	(setq result (funcall fn))
+      (do-bag (x b)
+	(if call-fn?
+	    (setq result (funcall fn result (if key (funcall key x) x)))
+	  (setq result (if key (funcall key x) x)
+		call-fn? t))))
+    result))
(defmethod convert ((to-type (eql 'bag)) (b bag) &key)
   b)
@@ -1387,13 +1546,15 @@
   (declare (optimize (speed 3) (safety 0)))
   (let ((result nil))
     (do-bag (value b)
-      ;; Expect 2 Python notes about generic arithmetic.
       (push value result))
     (nreverse result)))
(defmethod convert ((to-type (eql 'seq)) (b bag) &key)
   (convert 'seq (convert 'list b)))
+(defmethod convert ((to-type (eql 'vector)) (b bag) &key)
+  (coerce (convert 'list b) 'vector))
+
 (defmethod convert ((to-type (eql 'alist)) (b bag) &key)
   (declare (optimize (speed 3) (safety 0)))
   (let ((result nil))
@@ -1406,12 +1567,23 @@
 cdr of each pair (which must be a positive integer) is the member count for
 the car.  Otherwise the operand is treated as a simple list of members, some
 of which may be repeated."
+  (bag-from-list l from-type))
+
+(defmethod convert ((to-type (eql 'wb-bag)) (l list) &key from-type)
+  "If `from-type' is the symbol `alist', treats the operand as an alist where the
+cdr of each pair (which must be a positive integer) is the member count for
+the car.  Otherwise the operand is treated as a simple list of members, some
+of which may be repeated."
+  (bag-from-list l from-type))
+
+(defun bag-from-list (l from-type)
   (if (eq from-type 'alist)
       (let ((contents nil))
    (dolist (pr l)
      (unless (and (integerp (cdr pr)) (< 0 (cdr pr)))
-	    (error "Cdr of pair is not a positive integer: ~S"
-		   pr))
+	    (error 'simple-type-error :datum (cdr pr) :expected-type '(integer 0 *)
+		   :format-control "Cdr of pair is not a positive integer: ~S"
+		   :format-arguments (list (cdr pr))))
      (setq contents (WB-Bag-Tree-With contents (car pr) (cdr pr))))
    (make-wb-bag contents))
     ;; &&& Improve me someday
@@ -1420,6 +1592,20 @@
    (setq contents (WB-Bag-Tree-With contents x)))
       (make-wb-bag contents))))
+(defmethod convert ((to-type (eql 'bag)) (s sequence) &key)
+  ;; &&& Improve me someday
+  (let ((contents nil))
+    (dotimes (i (length s))
+      (setq contents (WB-Bag-Tree-With contents (elt s i))))
+    (make-wb-bag contents)))
+
+(defmethod convert ((to-type (eql 'wb-bag)) (s sequence) &key)
+  ;; &&& Improve me someday
+  (let ((contents nil))
+    (dotimes (i (length s))
+      (setq contents (WB-Bag-Tree-With contents (elt s i))))
+    (make-wb-bag contents)))
+
 (defmethod find (item (b bag) &key key test)
   (declare (optimize (speed 3) (safety 0)))
   (if key
@@ -1472,15 +1658,15 @@
          (let ((test (coerce test 'function)))
    	(do-bag-pairs (x n b total)
    	  (when (funcall test item (funcall key x))
-		    (incf total n))))
+		    (setq total (gen + total n)))))
        (do-bag-pairs (x n b total)
          (when (equal? item (funcall key x))
-		(incf total n)))))
+		(setq total (gen + total n))))))
       (if (and test (not (or (eq test 'equal?) (eq test #'equal?))))
      (let ((test (coerce test 'function)))
        (do-bag-pairs (x n b total)
          (when (funcall test item x)
-		(incf total n))))
+		(setq total (gen + total n)))))
    (multiplicity item b)))))
(defmethod count-if (pred (b bag) &key key)
@@ -1491,11 +1677,11 @@
    (let ((key (coerce key 'function)))
      (do-bag-pairs (x n b nil)
        (when (funcall pred (funcall key x))
-	      (incf total n))
+	      (setq total (gen + total n)))
        total))
       (do-bag-pairs (x n b nil)
    (when (funcall pred x)
-	  (incf total n))
+	  (setq total (gen + total n)))
    total))))
(defmethod count-if-not (pred (s bag) &key key)
@@ -1598,6 +1784,12 @@
     *empty-wb-map*))
 (declaim (inline empty-wb-map))
+(defmethod default ((m map))
+  (map-default m))
+
+(defmethod with-default ((m wb-map) new-default)
+  (make-wb-map (wb-map-contents m) new-default))
+
 (defmethod empty? ((m wb-map))
   (null (wb-map-contents m)))
@@ -1625,22 +1817,34 @@
 (defmethod size ((m wb-map))
   (WB-Map-Tree-Size (wb-map-contents m)))
-;;; I.e., is it a member of the domain?
-(defmethod member? (x (m wb-map))
-  (WB-Map-Tree-Lookup (wb-map-contents m) x))
-
 (defmethod lookup ((m wb-map) key)
   (let ((val? val (WB-Map-Tree-Lookup (wb-map-contents m) key)))
     ;; Our internal convention is the reverse of the external one.
     (values (if val? val (map-default m)) val?)))
-(defmethod with2 ((m wb-map) key value)
+(defmethod rank ((s wb-map) x)
+  (let ((found? rank (WB-Map-Tree-Rank (wb-map-contents s) x)))
+    (values rank found?)))
+
+(defmethod at-rank ((s wb-map) rank)
+  (let ((contents (wb-map-contents s))
+	((size (WB-Map-Tree-Size contents))))
+    (unless (and (>= rank 0) (< rank size))
+      (error 'simple-type-error :datum rank :expected-type `(integer 0 (,size))
+	     :format-control "Rank ~D out of bounds on ~A"
+	     :format-arguments (list rank s)))
+    (WB-Map-Tree-Rank-Pair contents rank)))
+
+(defmethod with ((m wb-map) key &optional (value nil value?))
+  (check-three-arguments value? 'with 'wb-map)
   (make-wb-map (WB-Map-Tree-With (wb-map-contents m) key value)
-	    (map-default m)))
+	       (map-default m)))
-(defmethod less1 ((m wb-map) key)
+(defmethod less ((m wb-map) key &optional (arg2 nil arg2?))
+  (declare (ignore arg2))
+  (check-two-arguments arg2? 'less 'wb-map)
   (make-wb-map (WB-Map-Tree-Less (wb-map-contents m) key)
-	    (map-default m)))
+	       (map-default m)))
(defmethod domain ((m wb-map))
   ;; &&& Cache this?  It's pretty fast anyway.
@@ -1681,19 +1885,10 @@
 (defmethod filter ((pred symbol) (m map))
   (map-filter (coerce pred 'function) m))
-(defmethod filter ((pred map) (m map))
-  (map-filter pred m))
-
-(defmethod filter ((pred set) (m map))
-  (map-filter pred m))
-
-(defmethod filter ((pred bag) (m map))
-  (map-filter pred m))
-
 (defun map-filter (pred m)
   (let ((result nil))
     (do-map (x y m)
-      (when (@ pred x y)
+      (when (funcall pred x y)
    (setq result (WB-Map-Tree-With result x y))))
     (make-wb-map result (map-default m))))
@@ -1711,60 +1906,70 @@
     (make-wb-map result (map-default m))))
(defmethod range ((m map))
-  ;;; &&& Also a candidate for caching -- but the operation isn't terribly common.
   (let ((s nil))
     (do-map (key val m)
       (declare (ignore key))
       (setq s (WB-Set-Tree-With s val)))
     (make-wb-set s)))
+(defmethod domain-contains? ((m wb-map) x)
+  (WB-Map-Tree-Lookup (wb-map-contents m) x))
+
+(defmethod range-contains? ((m wb-map) x)
+  (do-map (k v m)
+    (declare (ignore k))
+    (when (equal? v x)
+      (return t))))
+
 (defmethod map-union ((map1 wb-map) (map2 wb-map)
-		      &optional (val-fn #'(lambda (k v1 v2)
-					    (declare (ignore k v1))
+		      &optional (val-fn #'(lambda (v1 v2)
+					    (declare (ignore v1))
    				    v2)))
   (make-wb-map (WB-Map-Tree-Union (wb-map-contents map1) (wb-map-contents map2)
    			  (coerce val-fn 'function))
-	       (funcall val-fn 'map-default (map-default map1) (map-default map2))))
+	       (funcall val-fn (map-default map1) (map-default map2))))
(defmethod map-intersection ((map1 wb-map) (map2 wb-map)
-			     &optional (val-fn #'(lambda (k v1 v2)
-						   (declare (ignore k v1))
-						   (values v2 t))))
+			     &optional (val-fn #'(lambda (v1 v2)
+						   (declare (ignore v1))
+						   v2)))
   (make-wb-map (WB-Map-Tree-Intersect (wb-map-contents map1) (wb-map-contents map2)
    			      (coerce val-fn 'function))
-	       (funcall val-fn 'map-default (map-default map1) (map-default map2))))
+	       (funcall val-fn (map-default map1) (map-default map2))))
+
+(defmethod map-difference-2 ((map1 wb-map) (map2 wb-map))
+  (let ((newc1 newc2 (WB-Map-Tree-Diff-2 (wb-map-contents map1) (wb-map-contents map2))))
+    (values (make-wb-map newc1 (map-default map1))
+	    (make-wb-map newc2 (map-default map2)))))
(defmethod restrict ((m wb-map) (s wb-set))
   (make-wb-map (WB-Map-Tree-Restrict (wb-map-contents m) (wb-set-contents s))
-	    (map-default m)))
+	       (map-default m)))
(defmethod restrict-not ((m wb-map) (s wb-set))
   (make-wb-map (WB-Map-Tree-Restrict-Not (wb-map-contents m) (wb-set-contents s))
-	    (map-default m)))
+	       (map-default m)))
(defmethod compose ((map1 map) (map2 wb-map))
-  (let ((tree2 (wb-map-contents map2))
-	(result nil))
-    (do-map (key val1 map1)
-      (let ((val2? val2 (WB-Map-Tree-Lookup tree2 val1)))
-	(setq result (WB-Map-Tree-With result key (if val2? val2
-						    (map-default map2))))))
-    (let ((new-default new-default? (WB-Map-Tree-Lookup tree2 (map-default map1))))
-      (make-wb-map result (if new-default? new-default (map-default map2))))))
+  (let ((tree2 (wb-map-contents map2)))
+    (make-wb-map (WB-Map-Tree-Compose (wb-map-contents map1)
+				      #'(lambda (x)
+					  (let ((val2? val2
+						  (WB-Map-Tree-Lookup tree2 x)))
+					    (if val2? val2 (map-default map2)))))
+		 (let ((new-default new-default?
+			 (WB-Map-Tree-Lookup tree2 (map-default map1))))
+		   (if new-default? new-default (map-default map2))))))
-(defmethod compose ((m map) (fn function))
+(defmethod compose ((m wb-map) (fn function))
   (map-fn-compose m fn))
-(defmethod compose ((m map) (fn symbol))
+(defmethod compose ((m wb-map) (fn symbol))
   (map-fn-compose m (coerce fn 'function)))
(defun map-fn-compose (m fn)
-  (declare (optimize (speed 3) (safety 0))
-	   (type function fn))
-  (let ((result nil))
-    (do-map (key val m)
-      (setq result (WB-Map-Tree-With result key (funcall fn val))))
-    (make-wb-map result (funcall fn (map-default m)))))
+  (make-wb-map (WB-Map-Tree-Compose (wb-map-contents m) fn)
+	       (funcall fn (map-default m))))
(defmethod convert ((to-type (eql 'map)) (m map) &key)
   m)
@@ -1782,6 +1987,9 @@
 (defmethod convert ((to-type (eql 'seq)) (m map) &key (pair-fn #'cons))
   (convert 'seq (convert 'list m :pair-fn pair-fn)))
+(defmethod convert ((to-type (eql 'vector)) (m map) &key (pair-fn #'cons))
+  (coerce (convert 'list m :pair-fn pair-fn) 'vector))
+
 (defmethod convert ((to-type (eql 'set)) (m map) &key (pair-fn #'cons))
   (let ((result nil)
    (pair-fn (coerce pair-fn 'function)))
@@ -1789,15 +1997,37 @@
       (setq result (WB-Set-Tree-With result (funcall pair-fn key val))))
     (make-wb-set result)))
-(defmethod convert ((to-type (eql 'map)) (alist list)
+(defmethod convert ((to-type (eql 'map)) (list list)
    	    &key (key-fn #'car) (value-fn #'cdr))
+  (wb-map-from-list list key-fn value-fn))
+
+(defmethod convert ((to-type (eql 'wb-map)) (list list)
+		    &key (key-fn #'car) (value-fn #'cdr))
+  (wb-map-from-list list key-fn value-fn))
+
+(defun wb-map-from-list (list key-fn value-fn)
   (let ((m nil)
    (key-fn (coerce key-fn 'function))
    (value-fn (coerce value-fn 'function)))
-    (dolist (pr alist)
+    (dolist (pr list)
       (setq m (WB-Map-Tree-With m (funcall key-fn pr) (funcall value-fn pr))))
     (make-wb-map m)))
+(defmethod convert ((to-type (eql 'map)) (s sequence)
+		    &key (key-fn #'car) (value-fn #'cdr))
+  (wb-map-from-cl-sequence s key-fn value-fn))
+
+(defmethod convert ((to-type (eql 'wb-map)) (s sequence)
+		    &key (key-fn #'car) (value-fn #'cdr))
+  (wb-map-from-cl-sequence s key-fn value-fn))
+
+(defun wb-map-from-cl-sequence (s key-fn value-fn)
+  (let ((m nil))
+    (dotimes (i (length s))
+      (let ((pr (elt s i)))
+	(setq m (WB-Map-Tree-With m (funcall key-fn pr) (funcall value-fn pr)))))
+    (make-wb-map m)))
+
 (defmethod find (item (m map) &key key test)
   (declare (optimize (speed 3) (safety 0)))
   (if key
@@ -1900,7 +2130,7 @@
        (return))
      (incf i)
      (let ((*print-level* (and *print-level* (1- *print-level*))))
-	    (write (list x y) :stream stream)))
+	    (write (list x y) :stream stream :pretty nil)))
    (when (> i 0)
      (format stream " ")))
       (format stream "|}")
@@ -1921,15 +2151,17 @@
     #'WB-Map-Tree-Iterator-Done?
     (:values 2 #'WB-Map-Tree-Iterator-Get)))
-(def-gmap-res-type :map (&key filterp)
+(def-gmap-res-type :map (&key filterp default)
   "Consumes two values from the mapped function; returns a map of the pairs.
 Note that `filterp', if supplied, must take two arguments."
-  `(nil (:consume 2 #'WB-Map-Tree-With) #'make-wb-map ,filterp))
+  `(nil (:consume 2 #'WB-Map-Tree-With) #'(lambda (tree) (make-wb-map tree ,default))
+    ,filterp))
-(def-gmap-res-type :wb-map (&key filterp)
+(def-gmap-res-type :wb-map (&key filterp default)
   "Consumes two values from the mapped function; returns a wb-map of the pairs.
 Note that `filterp', if supplied, must take two arguments."
-  `(nil (:consume 2 #'WB-Map-Tree-With) #'make-wb-map ,filterp))
+  `(nil (:consume 2 #'WB-Map-Tree-With) #'(lambda (tree) (make-wb-map tree ,default))
+    ,filterp))
;;; ================================================================================
@@ -1937,7 +2169,7 @@
(defstruct (wb-seq
        (:include seq)
-	    (:constructor make-wb-seq (contents))
+	    (:constructor make-wb-seq (contents &optional default))
        (:predicate wb-seq?)
        (:print-function print-wb-seq)
        (:copier nil))
@@ -1949,9 +2181,10 @@
(defparameter *empty-wb-seq* (make-wb-seq nil))
-(defun empty-seq ()
+(defun empty-seq (&optional default)
   "Returns an empty seq of the default implementation."
-  *empty-wb-seq*)
+  (if default (make-wb-seq nil default)
+    *empty-wb-seq*))
 (declaim (inline empty-seq))
(defun empty-wb-seq ()
@@ -1962,79 +2195,128 @@
 (defmethod empty? ((s wb-seq))
   (null (wb-seq-contents s)))
+(defmethod default ((s seq))
+  (seq-default s))
+
+(defmethod with-default ((s wb-seq) new-default)
+  (make-wb-seq (wb-seq-contents s) new-default))
+
 (defmethod size ((s wb-seq))
   (WB-Seq-Tree-Size (wb-seq-contents s)))
(defmethod lookup ((s wb-seq) key)
   (let ((val? val (WB-Seq-Tree-Subscript (wb-seq-contents s) key)))
-    (values val val?)))
+    (values (if val? val (seq-default s)) val?)))
(defmethod first ((s wb-seq))
   (let ((val? val (WB-Seq-Tree-Subscript (wb-seq-contents s) 0)))
-    (values val val?)))
+    (values (if val? val (seq-default s)) val?)))
(defmethod last ((s wb-seq))
   (let ((tree (wb-seq-contents s))
    ((val? val (WB-Seq-Tree-Subscript tree (1- (WB-Seq-Tree-Size tree))))))
-    (values val val?)))
+    (values (if val? val (seq-default s)) val?)))
(defmethod with-first ((s wb-seq) val)
-  (make-wb-seq (WB-Seq-Tree-Insert (wb-seq-contents s) 0 val)))
+  (make-wb-seq (WB-Seq-Tree-Insert (wb-seq-contents s) 0 val)
+	       (seq-default s)))
(defmethod with-last ((s wb-seq) val)
   (let ((tree (wb-seq-contents s)))
-    (make-wb-seq (WB-Seq-Tree-Insert tree (WB-Seq-Tree-Size tree) val))))
+    (make-wb-seq (WB-Seq-Tree-Insert tree (WB-Seq-Tree-Size tree) val)
+		 (seq-default s))))
(defmethod less-first ((s wb-seq))
   (let ((tree (wb-seq-contents s)))
-    (make-wb-seq (WB-Seq-Tree-Subseq tree 1 (WB-Seq-Tree-Size tree)))))
+    (make-wb-seq (WB-Seq-Tree-Subseq tree 1 (WB-Seq-Tree-Size tree))
+		 (seq-default s))))
(defmethod less-last ((s wb-seq))
   (let ((tree (wb-seq-contents s)))
-    (make-wb-seq (WB-Seq-Tree-Subseq tree 0 (1- (WB-Seq-Tree-Size tree))))))
+    (make-wb-seq (WB-Seq-Tree-Subseq tree 0 (1- (WB-Seq-Tree-Size tree)))
+		 (seq-default s))))
-(defmethod with2 ((s wb-seq) index val)
+(defmethod with ((s wb-seq) idx &optional (val nil val?))
+  (check-three-arguments val? 'with 'wb-seq)
   (let ((tree (wb-seq-contents s))
    ((size (WB-Seq-Tree-Size tree))))
-    (unless (and (>= index 0) (<= index size))
-      ;;; &&& Signal a condition?
-      (error "Index ~D out of bounds on ~A" index s))
-    (make-wb-seq (if (= index size)
-		  (WB-Seq-Tree-Insert tree index val)
-		(WB-Seq-Tree-With tree index val)))))
+    (when (< idx -1)
+      (setq tree (WB-Seq-Tree-Concat
+		   (WB-Seq-Tree-From-Vector
+		     (make-array (- -1 idx) :initial-element (seq-default s)))
+		   tree))
+      (setq idx -1))
+    (when (> idx size)
+      (setq tree (WB-Seq-Tree-Concat
+		   tree (WB-Seq-Tree-From-Vector
+			  (make-array (- idx size) :initial-element (seq-default s)))))
+      (setq size idx))
+    (make-wb-seq (if (= idx -1)
+		     (WB-Seq-Tree-Insert tree 0 val)
+		   (if (= idx size)
+		       (WB-Seq-Tree-Insert tree idx val)
+		     (WB-Seq-Tree-With tree idx val)))
+		 (seq-default s))))
(defmethod insert ((s wb-seq) idx val)
-  (let ((tree (wb-seq-contents s)))
-    (unless (and (>= idx 0) (<= idx (WB-Seq-Tree-Size tree)))
-      ;;; &&& Signal a condition?
-      (error "Index ~D out of bounds on ~A" idx s))
-    (make-wb-seq (WB-Seq-Tree-Insert tree idx val))))
-
-(defmethod less1 ((s wb-seq) idx)
-  (let ((tree (wb-seq-contents s)))
-    (unless (and (>= idx 0) (< idx (WB-Seq-Tree-Size tree)))
-      ;;; &&& Signal a condition?
-      (error "Index ~D out of bounds on ~A" idx s))
-    (make-wb-seq (WB-Seq-Tree-Remove tree idx))))
+  (let ((tree (wb-seq-contents s))
+	((size (WB-Seq-Tree-Size tree))))
+    (when (< idx 0)
+      (setq tree (WB-Seq-Tree-Concat
+		   (WB-Seq-Tree-From-Vector
+		     (make-array (- idx) :initial-element (seq-default s)))
+		   tree))
+      (setq idx 0))
+    (when (> idx size)
+      (setq tree (WB-Seq-Tree-Concat
+		   tree (WB-Seq-Tree-From-Vector
+			  (make-array (- idx size) :initial-element (seq-default s)))))
+      (setq size idx))
+    (make-wb-seq (WB-Seq-Tree-Insert tree idx val)
+		 (seq-default s))))
+
+(defmethod less ((s wb-seq) idx &optional (arg2 nil arg2?))
+  (declare (ignore arg2))
+  (check-two-arguments arg2? 'less 'wb-seq)
+  (let ((tree (wb-seq-contents s))
+	((size (WB-Seq-Tree-Size tree))))
+    (if (and (>= idx 0) (< idx size))
+	(make-wb-seq (WB-Seq-Tree-Remove tree idx) (seq-default s))
+      s)))
(defmethod concat ((s1 wb-seq) (s2 wb-seq))
-  (make-wb-seq (WB-Seq-Tree-Concat (wb-seq-contents s1) (wb-seq-contents s2))))
+  (make-wb-seq (WB-Seq-Tree-Concat (wb-seq-contents s1) (wb-seq-contents s2))
+	       ;; Don't see what to do but pick one arbitrarily.
+	       (seq-default s1)))
(defmethod subseq ((s wb-seq) start &optional end)
   (let ((tree (wb-seq-contents s))
    ((size (WB-Seq-Tree-Size tree))
     ((start (max 0 start))
      (end (if end (min end size) size)))))
-    (make-wb-seq (WB-Seq-Tree-Subseq tree start end))))
+    (make-wb-seq (WB-Seq-Tree-Subseq tree start end)
+		 (seq-default s))))
(defmethod reverse ((s wb-seq))
-  (make-wb-seq (WB-Seq-Tree-Reverse (wb-seq-contents s))))
+  (make-wb-seq (WB-Seq-Tree-Reverse (wb-seq-contents s))
+	       (seq-default s)))
-(defmethod sort ((s seq) pred &key key)
-  (convert 'seq (cl:sort (convert 'vector s) pred :key key)))
+(defmethod sort ((s wb-seq) pred &key key)
+  (with-default (convert 'seq (cl:sort (convert 'vector s) pred :key key))
+		(seq-default s)))
+
+(defmethod stable-sort ((s wb-seq) pred &key key)
+  (with-default (convert 'seq (cl:stable-sort (convert 'vector s) pred :key key))
+		(seq-default s)))
-(defmethod stable-sort ((s seq) pred &key key)
-  (convert 'seq (cl:stable-sort (convert 'vector s) pred :key key)))
+(defmethod domain ((s wb-seq))
+  (let ((result nil))
+    (dotimes (i (size s))
+      (setq result (WB-Set-Tree-With result i)))
+    (make-wb-set result)))
+
+(defmethod range ((s wb-seq))
+  (convert 'set s))
(defmethod convert ((to-type (eql 'seq)) (s seq) &key)
   s)
@@ -2079,7 +2361,10 @@
 (defmethod compare ((s1 wb-seq) (s2 wb-seq))
   (WB-Seq-Tree-Compare (wb-seq-contents s1) (wb-seq-contents s2)))
-(defgeneric internal-do-seq (seq elt-fn value-fn
+(defmethod compare-lexicographically ((s1 wb-seq) (s2 wb-seq))
+  (WB-Seq-Tree-Compare-Lexicographically (wb-seq-contents s1) (wb-seq-contents s2)))
+
+(defgeneric internal-do-seq (seq elt-fn value-fn index?
    			 &key start end from-end?)
   (:documentation
     "Calls `elt-fn' on successive elements of `seq', possibly restricted by
@@ -2091,34 +2376,49 @@
(defmacro do-seq ((var seq
    	   &key (start nil start?) (end nil end?) (from-end? nil from-end??)
-		   (value nil))
+		   (index nil index?) (value nil))
    	  &body body)
   "For each element of `seq', possibly restricted by `start' and `end', and in
 reverse order if `from-end?' is true, binds `var' to it and executes `body'.
-When done, returns `value'."
+If `index' is supplied, it names a variable that will be bound at each
+iteration to the index of the current element of `seq'.  When done, returns
+`value'."
   `(block nil
      (internal-do-seq ,seq
-		      #'(lambda (,var) . ,body)
+		      #'(lambda (,var . ,(and index? `(,index))) . ,body)
    	      #'(lambda () ,value)
+		      ,index?
    	      ,@(and start? `(:start ,start))
    	      ,@(and end? `(:end ,end))
    	      ,@(and from-end?? `(:from-end? ,from-end?)))))
-(defmethod internal-do-seq ((s wb-seq) elt-fn value-fn
+(defmethod internal-do-seq ((s wb-seq) elt-fn value-fn index?
    		    &key (start 0)
    		         (end (WB-Seq-Tree-Size (wb-seq-contents s)))
    		         from-end?)
   (declare (optimize (speed 3) (safety 0))
       (type function elt-fn value-fn))
-  ;; Expect Python note about "can't use known return convention"
-  (Do-WB-Seq-Tree-Members-Gen (x (wb-seq-contents s) start end from-end?
-				 (funcall value-fn))
-    (funcall elt-fn x)))
+  (check-type start fixnum)
+  (check-type end fixnum)
+  ;; Expect Python notes about "can't use known return convention"
+  (if index?
+      (let ((i start))
+	(declare (type fixnum i))
+	(Do-WB-Seq-Tree-Members-Gen (x (wb-seq-contents s) start end from-end?
+				       (funcall value-fn))
+	  (funcall elt-fn x i)
+	  (incf i)))
+    (Do-WB-Seq-Tree-Members-Gen (x (wb-seq-contents s) start end from-end?
+				     (funcall value-fn))
+	(funcall elt-fn x))))
(defmethod iterator ((s wb-seq) &key)
   (Make-WB-Seq-Tree-Iterator (wb-seq-contents s)))
-(defmethod member? (x (s seq))
+(defmethod domain-contains? ((s seq) x)
+  (and (integerp x) (>= x 0) (< x (size s))))
+
+(defmethod range-contains? ((s seq) x)
   (declare (optimize (speed 3) (safety 0)))
   (do-seq (y s)
     (when (equal? y x)
@@ -2144,11 +2444,10 @@
       (type function fn))
   (let ((result nil))
     (do-seq (x s)
-      ;; Since constructing seqs is much faster than for the other types, we
-      ;; insist `fn' be a function instead of using `@'.
       (when (funcall fn x)
    (push x result)))
-    (make-wb-seq (WB-Seq-Tree-From-List (nreverse result)))))
+    (make-wb-seq (WB-Seq-Tree-From-List (nreverse result))
+		 (seq-default s))))
(defmethod image ((fn function) (s seq))
   (seq-image fn s))
@@ -2172,59 +2471,76 @@
   ;; the result in the same shape.
   (let ((result nil))
     (do-seq (x s)
-      ;; Since constructing seqs is much faster than for the other types, we
-      ;; insist `fn' be a function instead of using `@'.
       (push (funcall fn x) result))
-    (make-wb-seq (WB-Seq-Tree-From-List (nreverse result)))))
-
-(defmethod fold ((fn function) (s seq) &optional (initial-value nil init?))
-  (seq-fold fn s initial-value init?))
+    (make-wb-seq (WB-Seq-Tree-From-List (nreverse result))
+		 (seq-default s))))
-(defmethod fold ((fn symbol) (s seq) &optional (initial-value nil init?))
-  (seq-fold (coerce fn 'function) s initial-value init?))
+(defmethod reduce ((fn function) (s seq)
+		   &key key (initial-value nil init?)
+		   (start 0) (end (size s)) (from-end nil))
+  (seq-reduce fn s initial-value (and key (coerce key 'function)) init?
+	      start end from-end))
+
+(defmethod reduce ((fn symbol) (s seq)
+		   &key key (initial-value nil init?)
+		   (start 0) (end (size s)) (from-end nil))
+  (seq-reduce (coerce fn 'function) s initial-value (and key (coerce key 'function))
+	      init? start end from-end))
-(defun seq-fold (fn s initial-value init?)
+(defun seq-reduce (fn s initial-value key init? start end from-end?)
   (declare (optimize (speed 3) (safety 0))
-	   (type function fn))
-  (if init?
-      (let ((result initial-value))
-	(do-seq (x s)
-	  (setq result (funcall fn result x)))
-	result)
-    (if (empty? s)
-	(error "Attempt to fold an empty sequence with no initial value")
-      (let ((result nil)
-	    (first? t))
-	(do-seq (x s)
-	  (if first? (setq result x
-			   first? nil)
-	    (setq result (funcall fn result x))))
-	result))))
+	   (type function fn)
+	   (type (or function null) key)
+	   (type fixnum start end))
+  (let ((result initial-value)
+	(call-fn? init?))
+    (if (and (not init?) (empty? s))
+	(setq result (funcall fn))
+      (if (and (= start 0) (= end (the fixnum (size s))) (not from-end?))
+	  (do-seq (x s)
+	    (if call-fn?
+		(setq result (funcall fn result (if key (funcall key x) x)))
+	      (setq result (if key (funcall key x) x)
+		    call-fn? t)))
+	;; &&& Would be nice if our iterators were up to this.
+	(dotimes (i (- end start))
+	  (declare (type fixnum i))
+	  (let ((x (lookup s (if from-end? (the fixnum (- end i 1))
+			       (the fixnum (+ i start))))))
+	    (if call-fn?
+		(setq result (funcall fn result (if key (funcall key x) x)))
+	      (setq result (if key (funcall key x) x)
+		    call-fn? t))))))
+    result))
(defmethod find (item (s seq) &key key test start end from-end)
   (declare (optimize (speed 3) (safety 0)))
-  (if key
-      (let ((key (coerce key 'function)))
-	(if test
-	    (let ((test (coerce test 'function)))
-	      (do-seq (x s :start start :end end :from-end? from-end :value nil)
-		(when (funcall test item (funcall key x))
-		  (return x))))
-	  (do-seq (x s :start start :end end :from-end? from-end :value nil)
-	    (when (equal? item (funcall key x))
-	      (return x)))))
-    (if test
-	(let ((test (coerce test 'function)))
-	  (do-seq (x s :start start :end end :from-end? from-end :value nil)
-	    (when (funcall test item x)
-		  (return x))))
-      (do-seq (x s :start start :end end :from-end? from-end :value nil)
-	(when (equal? item x)
-	  (return x))))))
+  (let ((start (or start 0))
+	(end (or end (size s))))
+    (if key
+	(let ((key (coerce key 'function)))
+	  (if test
+	      (let ((test (coerce test 'function)))
+		(do-seq (x s :start start :end end :from-end? from-end :value nil)
+		  (when (funcall test item (funcall key x))
+		    (return x))))
+	    (do-seq (x s :start start :end end :from-end? from-end :value nil)
+	      (when (equal? item (funcall key x))
+		(return x)))))
+      (if test
+	  (let ((test (coerce test 'function)))
+	    (do-seq (x s :start start :end end :from-end? from-end :value nil)
+	      (when (funcall test item x)
+		    (return x))))
+	(do-seq (x s :start start :end end :from-end? from-end :value nil)
+	  (when (equal? item x)
+	    (return x)))))))
(defmethod find-if (pred (s seq) &key key start end from-end)
   (declare (optimize (speed 3) (safety 0)))
-  (let ((pred (coerce pred 'function)))
+  (let ((pred (coerce pred 'function))
+	(start (or start 0))
+	(end (or end (size s))))
     (if key
    (let ((key (coerce key 'function)))
      (do-seq (x s :start start :end end :from-end? from-end :value nil)
@@ -2242,7 +2558,9 @@
(defmethod count (item (s seq) &key key test start end from-end)
   (declare (optimize (speed 3) (safety 0)))
-  (let ((total 0))
+  (let ((total 0)
+	(start (or start 0))
+	(end (or end (size s))))
     (declare (fixnum total))
     (if key
    (let ((key (coerce key 'function)))
@@ -2270,7 +2588,9 @@
 (defmethod count-if (pred (s seq) &key key start end from-end)
   (declare (optimize (speed 3) (safety 0)))
   (let ((pred (coerce pred 'function))
-	(n 0))
+	(n 0)
+	(start (or start 0))
+	(end (or end (size s))))
     (declare (fixnum n))
     (if key
    (let ((key (coerce key 'function)))
@@ -2291,7 +2611,9 @@
(defmethod position (item (s seq) &key key test start end from-end)
   (declare (optimize (speed 3) (safety 0)))
-  (let ((pos 0))
+  (let ((pos 0)
+	(start (or start 0))
+	(end (or end (size s))))
     (declare (fixnum pos))
     (if key
    (let ((key (coerce key 'function)))
@@ -2319,7 +2641,9 @@
 (defmethod position-if (pred (s seq) &key key start end from-end)
   (declare (optimize (speed 3) (safety 0)))
   (let ((pred (coerce pred 'function))
-	(pos 0))
+	(pos 0)
+	(start (or start 0))
+	(end (or end (size s))))
     (declare (fixnum pos))
     (if key
    (let ((key (coerce key 'function)))
@@ -2443,7 +2767,10 @@
        (write x :stream stream)))
    (when (> i 0)
      (format stream " ")))
-      (format stream "]"))))
+      (format stream "]")
+      (let ((default (seq-default seq)))
+	(when default
+	  (format stream "/~A" default))))))
(def-gmap-arg-type :seq (seq)
   "Yields the elements of `seq'."
@@ -2470,3 +2797,22 @@
     #'(lambda (a b) (cons b a))
     #'(lambda (s) (convert 'seq (nreverse s)))
     ,filterp))
+
+
+;;; ================================================================================
+;;; CL Sequences
+
+;;; Convenience methods for some of the FSet generic functions.
+
+(defmethod empty? ((l list))
+  (null l))
+
+(defmethod empty? ((s sequence))
+  (zerop (length s)))
+
+(defmethod size ((s sequence))
+  (length s))
+
+(defmethod lookup ((s sequence) idx)
+  (elt s idx))
+
Added: trunk/Code/interval.lisp
==============================================================================
--- (empty file)
+++ trunk/Code/interval.lisp	Sun Oct 26 05:34:03 2008
@@ -0,0 +1,400 @@
+;;; -*- Mode: Lisp; Package: FSet; Syntax: ANSI-Common-Lisp -*-
+
+(in-package :fset)
+
+;;; File: interval.lisp
+;;; Contents: interval sets
+;;;
+;;; This file is part of FSet.  Copyright (c) 2007 Sympoiesis, Inc.
+;;; FSet is licensed under the Lisp Lesser GNU Public License, or LLGPL.
+;;; See: http://opensource.franz.com/preamble.html
+;;; This license provides NO WARRANTY.
+
+;;; Assumption: the items are totally ordered (no unequal-but-equivalent pairs).
+
+(defstruct (interval-set
+	    (:include set)
+	    (:constructor make-interval-set (contents))
+	    (:predicate interval-set?)
+	    (:print-function print-interval-set)
+	    (:copier nil))
+  contents)
+
+(defun print-interval-set (set stream level)
+  (if (and *print-level* (>= level *print-level*))
+      (format stream "#")
+    (progn
+      (format stream "#I{")
+      (let ((i 0))
+	(Do-WB-Set-Tree-Members (iv (interval-set-contents set))
+	  (format stream " ")
+	  (when (and *print-length* (>= i *print-length*))
+	    (format stream "...")
+	    (return))
+	  (incf i)
+	  (let ((*print-level* (and *print-level* (1- *print-level*))))
+	    (write iv :stream stream))))
+      (format stream " }"))))
+
+(defstruct (interval
+	    (:constructor make-raw-interval (lower upper kind))
+	    (:predicate interval?)
+	    (:print-function print-interval)
+	    (:copier nil))
+  lower
+  upper
+  kind)		; closed at: one of ':both, ':lower, ':upper, ':neither
+
+(defun print-interval (iv stream level)
+  (if (and *print-level* (>= level *print-level*))
+      (format stream "#")
+    (progn
+      (format stream (if (interval-lower-closed? iv) "[" "("))
+      (let ((*print-level* (and *print-level* (1- *print-level*))))
+	(write (interval-lower iv) :stream stream)
+	(format stream " ")
+	(write (interval-upper iv) :stream stream))
+      (format stream (if (interval-upper-closed? iv) "]" ")")))))
+
+(defun interval-kind-symbol (lower-closed? upper-closed?)
+  (if lower-closed?
+      (if upper-closed? ':both ':lower)
+    (if upper-closed? ':upper ':neither)))
+
+(defun make-interval (lower upper lower-closed? upper-closed?)
+  (let ((comp (compare lower upper)))
+    (unless (and (not (eq comp ':greater))
+		 (or (eq comp ':less)
+		     ;; If the interval is null, it had better be closed.
+		     (and lower-closed? upper-closed?)))
+      (error "Attempt to create inconsistent interval")))
+  (make-raw-interval lower upper (interval-kind-symbol lower-closed? upper-closed?)))
+
+(defun interval-lower-closed? (iv)
+  (let ((kind (interval-kind iv)))
+    (or (eq kind ':lower) (eq kind ':both))))
+
+(defun interval-upper-closed? (iv)
+  (let ((kind (interval-kind iv)))
+    (or (eq kind ':upper) (eq kind ':both))))
+
+;;; Says `:equal' if `x' is in `iv'.
+(defmethod compare ((x t) (iv interval))
+  (cond ((let ((comp (compare x (interval-lower iv))))
+	   (or (eq comp ':less)
+	       (and (eq comp ':equal) (not (interval-lower-closed? iv)))))
+	 ':less)
+	((let ((comp (compare x (interval-upper iv))))
+	   (or (eq comp ':greater)
+	       (and (eq comp ':equal) (not (interval-upper-closed? iv)))))
+	 ':greater)
+	(t ':equal)))
+
+;;; Says `:equal' if `x' is in `iv'.
+(defmethod compare ((iv interval) (x t))
+  (cond ((let ((comp (compare (interval-upper iv) x)))
+	   (or (eq comp ':less)
+	       (and (eq comp ':equal) (not (interval-upper-closed? iv)))))
+	 ':less)
+	((let ((comp (compare (interval-lower iv) x)))
+	   (or (eq comp ':greater)
+	       (and (eq comp ':equal) (not (interval-lower-closed? iv)))))
+	 ':greater)
+	(t ':equal)))
+
+;;; Says `:equal' if the intervals overlap.
+(defmethod compare ((iv0 interval) (iv1 interval))
+  (values (compare-intervals iv0 iv1)))
+
+(defun compare-intervals (iv0 iv1)
+  "Second value is true if the two abut.  `:equal' means they overlap."
+  (let ((comp-ul (compare (interval-upper iv0) (interval-lower iv1))))
+    (cond ((or (eq comp-ul ':less)
+	       (and (eq comp-ul ':equal)
+		    (not (interval-upper-closed? iv0))
+		    (not (interval-lower-closed? iv1))))
+	   (values ':less nil))
+	  ((and (eq comp-ul ':equal)
+		(not (and (interval-upper-closed? iv0) (interval-lower-closed? iv1))))
+	   (values ':less t))
+	  (t
+	   (let ((comp-lu (compare (interval-lower iv0) (interval-upper iv1))))
+	     (cond ((or (eq comp-lu ':greater)
+			(and (eq comp-lu ':equal)
+			     (not (interval-lower-closed? iv0))
+			     (not (interval-upper-closed? iv1))))
+		    (values ':greater nil))
+		   ((and (eq comp-lu ':equal)
+			 (not (and (interval-lower-closed? iv0)
+				   (interval-upper-closed? iv1))))
+		    (values ':greater t))
+		   (t ':equal)))))))
+
+(defun empty-interval-set ()
+  (make-interval-set nil))
+
+(defmethod empty? ((s interval-set))
+  (null (interval-set-contents s)))
+
+(defmethod size ((s interval-set))
+  "The number of intervals in the set."
+  (WB-Set-Tree-Size (interval-set-contents s)))
+
+;;; Internal.
+(defgeneric with-interval (interval-set lower upper lower-closed? upper-closed?))
+
+(defmethod with-interval ((s interval-set) lower upper lower-closed? upper-closed?)
+  (let ((contents (interval-set-contents s)))
+    (let ((size (WB-Set-Tree-Size contents))
+	  ((raw-lower-rank lower-found? (WB-Set-Tree-Find-Rank contents lower))
+	   (raw-upper-rank upper-found? (WB-Set-Tree-Find-Rank contents upper))
+	   ((lower-rank (if lower-found? (1+ raw-lower-rank) raw-lower-rank))
+	    (upper-rank (if upper-found? (1- raw-upper-rank) raw-upper-rank))
+	    ((removed (gmap :set (lambda (i) (WB-Set-Tree-Rank-Element contents i))
+			    (:index lower-rank upper-rank))))))
+	  (new-lower lower)
+	  (new-lower-closed? lower-closed?)
+	  (new-upper upper)
+	  (new-upper-closed? upper-closed?))
+      (declare (fixnum size raw-lower-rank raw-upper-rank lower-rank upper-rank))
+      (when (or lower-found? (> lower-rank 0))
+	(let ((prev-iv (WB-Set-Tree-Rank-Element contents (1- lower-rank))))
+	  (when (or lower-found?
+		    (and (equal? (interval-upper prev-iv) lower)
+			 (or (interval-upper-closed? prev-iv)
+			     lower-closed?)))
+	    (adjoinf removed prev-iv)
+	    (ecase (compare (interval-lower prev-iv) lower)
+	      ((:less)
+	       (setq new-lower (interval-lower prev-iv))
+	       (setq new-lower-closed? (interval-lower-closed? prev-iv)))
+	      ((:equal)
+	       (when (interval-lower-closed? prev-iv)
+		 (setq new-lower-closed? t)))))))
+      (when (or upper-found? (< upper-rank size))
+	(let ((next-iv (WB-Set-Tree-Rank-Element contents upper-rank)))
+	  (when (or upper-found?
+		    (and (equal? (interval-lower next-iv) upper)
+			 (or (interval-lower-closed? next-iv)
+			     upper-closed?)))
+	    (adjoinf removed next-iv)
+	    (ecase (compare (interval-upper next-iv) upper)
+	      ((:greater)
+	       (setq new-upper (interval-upper next-iv))
+	       (setq new-upper-closed? (interval-upper-closed? next-iv)))
+	      ((:equal)
+	       (when (interval-upper-closed? next-iv)
+		 (setq new-upper-closed? t)))))))
+      (make-interval-set
+	(WB-Set-Tree-With (WB-Set-Tree-Diff contents (wb-set-contents removed))
+			  (make-interval new-lower new-upper
+					 new-lower-closed? new-upper-closed?))))))
+
+(defmethod with ((s interval-set) (iv interval) &optional (arg2 nil arg2?))
+  (declare (ignore arg2))
+  (check-two-arguments arg2? 'with 'interval-set)
+  (with-interval s (interval-lower iv) (interval-upper iv)
+		 (interval-lower-closed? iv) (interval-upper-closed? iv)))
+
+
+;;; Internal.
+(defgeneric less-interval (interval-set lower upper lower-closed? upper-closed?))
+
+(defmethod less-interval ((s interval-set) lower upper lower-closed? upper-closed?)
+  (let ((contents (interval-set-contents s)))
+    (let ((lower-rank lower-found? (WB-Set-Tree-Find-Rank contents lower))
+	  (upper-rank upper-found? (WB-Set-Tree-Find-Rank contents upper))
+	  ((removed (gmap :set (lambda (i) (WB-Set-Tree-Rank-Element contents i))
+			  (:index lower-rank upper-rank))))
+	  (new (set)))
+      (declare (fixnum lower-rank upper-rank))
+      (when lower-found?
+	(let ((lower-iv (WB-Set-Tree-Rank-Element contents lower-rank)))
+	  (unless (and (equal? (interval-upper lower-iv) lower)
+		       (not (interval-upper-closed? lower-iv))
+		       (not lower-closed?))
+	    (adjoinf removed lower-iv)
+	    (let ((comp (compare (interval-lower lower-iv) lower)))
+	      (when (or (eq comp ':less)
+			(and (eq comp ':equal)
+			     (interval-lower-closed? lower-iv)
+			     (not lower-closed?)))
+		(adjoinf new (make-interval (interval-lower lower-iv) lower
+					    (interval-lower-closed? lower-iv)
+					    (not lower-closed?))))))))
+      (when upper-found?
+	(let ((upper-iv (WB-Set-Tree-Rank-Element contents upper-rank)))
+	  (unless (and (equal? (interval-lower upper-iv) upper)
+		       (not (interval-lower-closed? upper-iv))
+		       (not upper-closed?))
+	    (adjoinf removed upper-iv)
+	    (let ((comp (compare (interval-upper upper-iv) upper)))
+	      (when (or (eq comp ':greater)
+			(and (eq comp ':equal)
+			     (interval-upper-closed? upper-iv)
+			     (not upper-closed?)))
+		(adjoinf new (make-interval upper (interval-upper upper-iv)
+					    (not upper-closed?)
+					    (interval-upper-closed? upper-iv))))))))
+      (make-interval-set
+	(WB-Set-Tree-Union (WB-Set-Tree-Diff contents (wb-set-contents removed))
+			   (wb-set-contents new))))))
+
+(defmethod less ((s interval-set) (iv interval) &optional (arg2 nil arg2?))
+  (declare (ignore arg2))
+  (check-two-arguments arg2? 'less 'interval-set)
+  (less-interval s (interval-lower iv) (interval-upper iv)
+		 (interval-lower-closed? iv) (interval-upper-closed? iv)))
+
+(defmethod union ((s0 interval-set) (s1 interval-set) &key)
+  ;; Works, but needs to be rewritten to run in linear time and cons less.
+  (let ((contents0 (interval-set-contents s0))
+	(contents1 (interval-set-contents s1)))
+    (let ((iter0 (Make-WB-Set-Tree-Iterator-Internal contents0))
+	  (iter1 (Make-WB-Set-Tree-Iterator-Internal contents1))
+	  ((cur0 (WB-Set-Tree-Iterator-Get iter0))
+	   (cur1 (WB-Set-Tree-Iterator-Get iter1)))
+	  (result nil))
+      (while (and cur0 cur1)
+	(let ((comp abut? (compare-intervals cur0 cur1))
+	      ((comp (if abut? ':equal comp))))
+	  (ecase comp
+	    ((:less)
+	     (setq result (WB-Set-Tree-With result cur0))
+	     (setq cur0 (WB-Set-Tree-Iterator-Get iter0)))
+	    ((:greater)
+	     (setq result (WB-Set-Tree-With result cur1))
+	     (setq cur1 (WB-Set-Tree-Iterator-Get iter1)))
+	    ((:equal)		; they overlap or abut
+	     (let ((lcomp (compare (interval-lower cur0) (interval-lower cur1)))
+		   (ucomp (compare (interval-upper cur0) (interval-upper cur1))))
+	       (if (or (eq lcomp ':less)
+		       (and (eq lcomp ':equal) (interval-lower-closed? cur0)))
+		   (progn
+		     (when (or (eq ucomp ':less)
+			       (and (eq ucomp ':equal)
+				    (not (interval-upper-closed? cur0))
+				    (interval-upper-closed? cur1)))
+		       (setq cur0 (make-interval
+				    (interval-lower cur0) (interval-upper cur1)
+				    (interval-lower-closed? cur0)
+				    (interval-upper-closed? cur1))))
+		     (setq cur1 (WB-Set-Tree-Iterator-Get iter1)))
+		 (progn
+		   (when (or (eq ucomp ':greater)
+			     (and (eq ucomp ':equal)
+				  (not (interval-upper-closed? cur1))
+				  (interval-upper-closed? cur0)))
+		     (setq cur1 (make-interval
+				  (interval-lower cur1) (interval-upper cur0)
+				  (interval-lower-closed? cur1)
+				  (interval-upper-closed? cur0))))
+		   (setq cur0 (WB-Set-Tree-Iterator-Get iter0)))))))))
+      (while cur0
+	(setq result (WB-Set-Tree-With result cur0))
+	(setq cur0 (WB-Set-Tree-Iterator-Get iter0)))
+      (while cur1
+	(setq result (WB-Set-Tree-With result cur1))
+	(setq cur1 (WB-Set-Tree-Iterator-Get iter1)))
+      (make-interval-set result))))
+
+(defmethod intersection ((s0 interval-set) (s1 interval-set) &key)
+  ;; Works, but needs to be rewritten to run in linear time and cons less.
+  (let ((contents0 (interval-set-contents s0))
+	(contents1 (interval-set-contents s1)))
+    (let ((iter0 (Make-WB-Set-Tree-Iterator-Internal contents0))
+	  (iter1 (Make-WB-Set-Tree-Iterator-Internal contents1))
+	  ((cur0 (WB-Set-Tree-Iterator-Get iter0))
+	   (cur1 (WB-Set-Tree-Iterator-Get iter1)))
+	  (result nil))
+      (while (and cur0 cur1)
+	(let ((comp (compare-intervals cur0 cur1)))
+	  (ecase comp
+	    ((:less)
+	     (setq cur0 (WB-Set-Tree-Iterator-Get iter0)))
+	    ((:greater)
+	     (setq cur1 (WB-Set-Tree-Iterator-Get iter1)))
+	    ((:equal)		; they overlap
+	     (let ((lcomp (compare (interval-lower cur0) (interval-lower cur1)))
+		   (ucomp (compare (interval-upper cur0) (interval-upper cur1))))
+	       (if (or (eq ucomp ':less)
+		       (and (eq ucomp ':equal) (interval-upper-closed? cur1)))
+		   (progn
+		     (when (or (eq lcomp ':less)
+			       (and (eq lcomp ':equal)
+				    (interval-lower-closed? cur0)
+				    (not (interval-lower-closed? cur1))))
+		       (setq cur0 (make-interval
+				    (interval-lower cur1) (interval-upper cur0)
+				    (interval-lower-closed? cur1)
+				    (interval-upper-closed? cur0))))
+		     (setq result (WB-Set-Tree-With result cur0))
+		     (setq cur0 (WB-Set-Tree-Iterator-Get iter0)))
+		 (progn
+		   (when (or (eq lcomp ':greater)
+			     (and (eq lcomp ':equal)
+				  (interval-lower-closed? cur1)
+				  (not (interval-lower-closed? cur0))))
+		     (setq cur1 (make-interval
+				  (interval-lower cur0) (interval-upper cur1)
+				  (interval-lower-closed? cur0)
+				  (interval-upper-closed? cur1))))
+		   (setq result (WB-Set-Tree-With result cur1))
+		   (setq cur1 (WB-Set-Tree-Iterator-Get iter1)))))))))
+      (make-interval-set result))))
+
+(defmethod set-difference ((s0 interval-set) (s1 interval-set) &key)
+  ;; Works, but needs to be rewritten to run in linear time and cons less.
+  (let ((contents0 (interval-set-contents s0))
+	(contents1 (interval-set-contents s1)))
+    (let ((iter0 (Make-WB-Set-Tree-Iterator-Internal contents0))
+	  (iter1 (Make-WB-Set-Tree-Iterator-Internal contents1))
+	  ((cur0 (WB-Set-Tree-Iterator-Get iter0))
+	   (cur1 (WB-Set-Tree-Iterator-Get iter1)))
+	  (result nil))
+      (while (and cur0 cur1)
+	(let ((comp (compare-intervals cur0 cur1)))
+	  (ecase comp
+	    ((:less)
+	     (setq result (WB-Set-Tree-With result cur0))
+	     (setq cur0 (WB-Set-Tree-Iterator-Get iter0)))
+	    ((:greater)
+	     (setq cur1 (WB-Set-Tree-Iterator-Get iter1)))
+	    ((:equal)		; they overlap
+	     (let ((lcomp (compare (interval-lower cur0) (interval-lower cur1)))
+		   (ucomp (compare (interval-upper cur0) (interval-upper cur1))))
+	       (when (or (eq lcomp ':less)
+			 (and (eq lcomp ':equal)
+			      (interval-lower-closed? cur0)
+			      (not (interval-lower-closed? cur1))))
+		 (let ((iv (make-interval (interval-lower cur0) (interval-lower cur1)
+					  (interval-lower-closed? cur0)
+					  (not (interval-lower-closed? cur1)))))
+		   (setq result (WB-Set-Tree-With result iv))))
+	       (if (eq ucomp ':greater)
+		   (setq cur0 (make-interval (interval-upper cur1) (interval-upper cur0)
+					     (not (interval-upper-closed? cur1))
+					     (interval-upper-closed? cur0)))
+		 (setq cur0 (WB-Set-Tree-Iterator-Get iter0))))))))
+      (while cur0
+	(setq result (WB-Set-Tree-With result cur0))
+	(setq cur0 (WB-Set-Tree-Iterator-Get iter0)))
+      (make-interval-set result))))
+
+
+;;; ================================================================================
+;;; Interval set relations
+
+;;; An "interval set relation" is a binary relation whose left domain is encoded as
+;;; an interval set.  It does not cache its inverse (it could, but I have no need
+;;; for this).  Adam Megacz calls it a "topological bag", but that doesn't seem
+;;; right to me (it's certainly not a bag in the sense in which I use the word).
+
+(defstruct (interval-set-relation
+	    (:constructor make-interval-set-relation (contents))
+	    (:predicate interval-set-relation?)
+	    (:print-function print-interval-set-relation)
+	    (:copier nil))
+  contents)
+
+
Modified: trunk/Code/order.lisp
==============================================================================
--- trunk/Code/order.lisp	(original)
+++ trunk/Code/order.lisp	Sun Oct 26 05:34:03 2008
@@ -30,6 +30,52 @@
   (or (eql a b)
       (eq (compare a b) ':equal)))
+;;; Makes it easy to define `compare' methods on new classes.  Just say:
+;;;
+;;; (defmethod compare ((f1 frob) (f2 frob))
+;;;   (compare-slots f1 f2 #'frob-foo #'frob-bar))
+;;;
+(defmacro compare-slots (obj1 obj2 &rest accessors)
+  "A handy macro for writing the bodies of `compare' methods for user classes.
+Returns the result of comparing the two objects by comparing the results of
+calling each of `accessors', in order, on the objects.  Despite the name, an
+accessor can actually be any function on the class in question; it can also
+be a symbol, which will be used to access the slot via `slot-value'.  For
+example, if class `frob' has accessor `frob-foo' and slot `bar':
+
+  (defmethod compare ((f1 frob) (f2 frob))
+    (compare-slots f1 f2 #'frob-foo 'bar))"
+  (let ((default-var (gensym "DEFAULT-"))
+	(comp-var (gensym "COMP-"))
+	(obj1-var (gensym "OBJ1-"))
+	(obj2-var (gensym "OBJ2-")))
+    (labels ((rec (accs)
+	       (if (null accs) default-var
+		 `(let ((,comp-var (compare ,(call (car accs) obj1-var)
+					    ,(call (car accs) obj2-var))))
+		    (if (or (eq ,comp-var ':less) (eq ,comp-var ':greater))
+			,comp-var
+		      (let ((,default-var (if (eq ,comp-var ':unequal)
+					      ':unequal ,default-var)))
+			,(rec (cdr accs)))))))
+	     (call (fn arg)
+	       ;; Makes the expansion more readable, if nothing else
+	       (cond ((and (listp fn)
+			   (eq (car fn) 'function))
+		      `(,(cadr fn) ,arg))
+		     ((and (listp fn)
+			   (eq (car fn) 'lambda))
+		      `(,fn ,arg))
+		     ((and (listp fn)
+			   (eq (car fn) 'quote)
+			   (symbolp (cadr fn)))
+		      `(slot-value ,arg ,fn))
+		     (t `(funcall ,fn ,arg)))))
+      `(let ((,obj1-var ,obj1)
+	     (,obj2-var ,obj2)
+	     (,default-var ':equal))
+	,(rec accessors)))))
+
;;; Abstract classes
@@ -69,7 +115,8 @@
        (:predicate seq?)
        (:copier nil))
   "The abstract class for FSet functional seqs (sequences, but we use the short
-name to avoid confusion with `cl:sequence').  It is a structure class.")
+name to avoid confusion with `cl:sequence').  It is a structure class."
+  (default nil))
(defstruct (tuple
        (:constructor nil)
@@ -80,6 +127,26 @@
;;; ================================================================================
+;;; Identity ordering
+
+(defclass identity-ordering-mixin ()
+    ((serial-number :accessor serial-number)
+     (next-serial-number :initform '0 :allocation :class))
+  (:documentation
+    "A mixin class for classes whose instances will be used in FSet collections,
+and for which the appropriate equivalence relation is identity (`eq').
+This is the right choice for the vast majority of mutable classes."))
+
+(defmethod initialize-instance :before ((obj identity-ordering-mixin)
+					&key &allow-other-keys)
+  (setf (serial-number obj) (slot-value obj 'next-serial-number))
+  (incf (slot-value obj 'next-serial-number)))
+
+(defmethod compare ((obj1 identity-ordering-mixin) (obj2 identity-ordering-mixin))
+  (compare-slots obj1 obj2 #'serial-number))
+
+
+;;; ================================================================================
 ;;; Compare methods
;;; Default
@@ -88,10 +155,10 @@
 ;;; declared, as they are below, than to use this for all cross-type comparisons.
 ;;; But this is fast enough that I think it will suffice for user-defined types.
 ;;; Of course the user is free to define all the cross-type methods themselves
-;;; if they want, but there are quadratically many of them.
+;;; if they want; a macro to assist with this is below.
 (defmethod compare ((a t) (b t))
   (let ((a-type (cond ((realp a) 'real)
-		      ((stringp a) 'string)	; We have to check for these ourselves
+		      ((stringp a) 'string)	; We check for these ourselves
    	      ((vectorp a) 'vector)	; because `type-of' may cons a list.
    	      (t (type-of a))))
    (b-type (cond ((realp b) 'real)
@@ -101,15 +168,87 @@
     (if (eq a-type b-type)
    ;; If we get here, they haven't defined a compare method for their type.
    ;; This is the best we can do.
-	(if (eq a b) ':equal ':unequal)
+	(if (eql a b) ':equal ':unequal)
       (if (and (symbolp a-type) (symbolp b-type))
-	  (compare a-type b-type)		;; Just compare the type symbols.
+	  ;; Just compare the type symbols.  But note, under rare circumstances
+	  ;; involving `rename-package', this can return `:unequal'.
+	  (compare a-type b-type)
    ;; If we get here, one or both of them are probably instances of anonymous
    ;; CLOS classes.  Again, this is the best we can do (or would an error
    ;; be better??).
    ':unequal))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (deflex +Master-Type-Ordering+ nil
+    "Keeps track of the types for which explicit cross-comparison methods have
+been generated, and against which subsequent such methods will be generated.
+This is a list in reverse order."))
+
+;;; Handy macro to generate the cross-comparison methods.
+(defmacro define-cross-type-compare-methods (type)
+  "Generates cross-type comparison methods for `type' against the types on
+which the macro has previously been invoked.  This macro is intended to be
+invoked at the top level of a source file.  You should make sure that calls
+to this macro are always compiled in the same order; if you don't, you could
+possibly get a "master type ordering out of sync" error, at which point you
+should delete all your fasls, restart your Lisp session, and recompile.
+However, the implementation tries very hard to prevent this."
+  (unless (symbolp type)
+    (error "Type name required, not ~S" type))
+  ;; Have to add it to the list, if it's not there, at both expansion time and
+  ;; load time.
+  (pushnew type +Master-Type-Ordering+)
+  (let ((types (member type +Master-Type-Ordering+))
+	((prev-types (cdr types))))
+    `(progn
+       (let ((mto-len (length +Master-Type-Ordering+)))
+	 (unless (if (< mto-len ,(length types))
+		     (equal +Master-Type-Ordering+
+			    (cl:subseq ',prev-types (- ,(length prev-types) mto-len)))
+		   (equal (cl:subseq +Master-Type-Ordering+
+				     (- mto-len ,(length types)))
+			  ',types))
+	   ;; This can happen if calls to this macro are compiled in a different
+	   ;; order on different occasions, but only if neither call has been loaded.
+	   (error "FSet master type ordering out of sync.~@
+		   See fset::define-cross-type-compare-methods.")))
+       (unless (member ',type +Master-Type-Ordering+)
+	 ;; You might think we would set it to the full expansion-time value,
+	 ;; but that would cause problems if FSet is recompiled in a session
+	 ;; in which this macro has been invoked on other types -- it would cause
+	 ;; this fasl to contain symbols from those packages.
+	 (setq +Master-Type-Ordering+ ',types))
+       . ,(cl:reduce #'append
+		     (mapcar (lambda (type2)
+			       `((defmethod compare ((a ,type2) (b ,type))
+				   ':less)
+				 (defmethod compare ((a ,type) (b ,type2))
+				   ':greater)))
+			     prev-types)))))
+
+;;; CL types
+(define-cross-type-compare-methods null)
+(define-cross-type-compare-methods real)
+(define-cross-type-compare-methods character)
+(define-cross-type-compare-methods symbol)
+(define-cross-type-compare-methods string)
+(define-cross-type-compare-methods vector)
+(define-cross-type-compare-methods list)
+(define-cross-type-compare-methods package)
+(define-cross-type-compare-methods pathname)
+
+;;; FSet types
+(define-cross-type-compare-methods set)
+(define-cross-type-compare-methods bag)
+(define-cross-type-compare-methods map)
+(define-cross-type-compare-methods seq)
+(define-cross-type-compare-methods tuple)
+
+;;; For users
+(define-cross-type-compare-methods identity-ordering-mixin)
+
+
 ;;; Nil
(defmethod compare ((a null) (b null))
@@ -118,12 +257,6 @@
;;; Reals
-(defmethod compare ((a null) (b real))
-  ':less)
-
-(defmethod compare ((b real) (a null))
-  ':greater)
-
 (defmethod compare ((a real) (b real))
   (cond ((< a b) ':less)
    ((> a b) ':greater)
@@ -136,18 +269,6 @@
;;; Characters
-(defmethod compare ((a null) (b character))
-  ':less)
-
-(defmethod compare ((b character) (a null))
-  ':greater)
-
-(defmethod compare ((a real) (b character))
-  ':less)
-
-(defmethod compare ((b character) (a real))
-  ':greater)
-
 ;;; `char<' is called directly in many places in the code where we know two
 ;;; characters are being compared. 
 (defmethod compare ((a character) (b character))
@@ -158,63 +279,26 @@
;;; Symbols
-(defmethod compare ((a null) (b symbol))
-  ':less)
-
-(defmethod compare ((b symbol) (a null))
-  ':greater)
-
-(defmethod compare ((a real) (b symbol))
-  ':less)
-
-(defmethod compare ((b symbol) (a real))
-  ':greater)
-
-(defmethod compare ((a character) (b symbol))
-  ':less)
-
-(defmethod compare ((b symbol) (a character))
-  ':greater)
-
 (defmethod compare ((a symbol) (b symbol))
   (if (eq a b) ':equal
-    (let ((pa (symbol-package a))
-	  (pb (symbol-package b)))
-      (if (not (eq pa pb))
-	  (Compare-Strings (package-name pa) (package-name pb))
-	(Compare-Strings (symbol-name a) (symbol-name b))))))
+    (let ((pkg-comp (compare (symbol-package a) (symbol-package b))))
+      (if (or (eq pkg-comp ':equal) (eq pkg-comp ':unequal))
+	  ;; We've already checked for `eq', so they can't be equal, but they can
+	  ;; be "unequal" in two cases: uninterned symbols of the same name;
+	  ;; symbols of the same name in packages one of which has the name that
+	  ;; the other had before `rename-package' was done on it.
+	  (let ((comp (Compare-Strings (symbol-name a) (symbol-name b))))
+	    (if (eq comp ':equal) ':unequal
+	      comp))
+	pkg-comp))))
;;; Strings
-(defmethod compare ((a null) (b string))
-  ':less)
-
-(defmethod compare ((b string) (a null))
-  ':greater)
-
-(defmethod compare ((a real) (b string))
-  ':less)
-
-(defmethod compare ((b string) (a real))
-  ':greater)
-
-(defmethod compare ((a character) (b string))
-  ':less)
-
-(defmethod compare ((b string) (a character))
-  ':greater)
-
-(defmethod compare ((a symbol) (b string))
-  ':less)
-
-(defmethod compare ((b string) (a symbol))
-  ':greater)
-
 (defmethod compare ((a string) (b string))
   (Compare-Strings a b))
-;;; Abstracted out for use by `(Compare symbol symbol)'.  Do not use otherwise.
+;;; Abstracted out for use by `(compare symbol symbol)'.  Do not use otherwise.
 (defun Compare-Strings (a b)
   (let ((len-a (length a))
    (len-b (length b)))
@@ -228,44 +312,14 @@
    	   (cond ((char< ca cb) (return ':less))
    		 ((char> ca cb) (return ':greater)))))
         (dotimes (i len-a ':equal)
-	       (let ((ca (schar a i))
-		     (cb (schar b i)))
+	       (let ((ca (char a i))
+		     (cb (char b i)))
    	 (cond ((char< ca cb) (return ':less))
    	       ((char> ca cb) (return ':greater))))))))))
;;; Vectors
-(defmethod compare ((a null) (b vector))
-  ':less)
-
-(defmethod compare ((b vector) (a null))
-  ':greater)
-
-(defmethod compare ((a real) (b vector))
-  ':less)
-
-(defmethod compare ((b vector) (a real))
-  ':greater)
-
-(defmethod compare ((a character) (b vector))
-  ':less)
-
-(defmethod compare ((b vector) (a character))
-  ':greater)
-
-(defmethod compare ((a symbol) (b vector))
-  ':less)
-
-(defmethod compare ((b vector) (a symbol))
-  ':greater)
-
-(defmethod compare ((a string) (b vector))
-  ':less)
-
-(defmethod compare ((b vector) (a string))
-  ':greater)
-
 (defmethod compare ((a vector) (b vector))
   (let ((len-a (length a))
    (len-b (length b))
@@ -290,51 +344,21 @@
;;; Lists
-(defmethod compare ((a null) (b list))
-  ':less)
-
-(defmethod compare ((b list) (a null))
-  ':greater)
-
-(defmethod compare ((a real) (b list))
-  ':less)
-
-(defmethod compare ((b list) (a real))
-  ':greater)
-
-(defmethod compare ((a character) (b list))
-  ':less)
-
-(defmethod compare ((b list) (a character))
-  ':greater)
-
-(defmethod compare ((a symbol) (b list))
-  ':less)
-
-(defmethod compare ((b list) (a symbol))
-  ':greater)
-
-(defmethod compare ((a string) (b list))
-  ':less)
-
-(defmethod compare ((b list) (a string))
-  ':greater)
-
-(defmethod compare ((a vector) (b list))
-  ':less)
-
-(defmethod compare ((b list) (a vector))
-  ':greater)
-
 (defmethod compare ((a list) (b list))
   ;; We don't compare lengths first, as we did for vectors, because `length'
   ;; on a list takes linear time, not constant time.
   ;; Also, we want to handle dotted lists.
+  (compare-lists-lexicographically a b))
+
+(defun compare-lists-lexicographically (a b)
   (do ((a a (cdr a))
        (b b (cdr b))
        (default ':equal))
       ((or (atom a) (atom b))
-       (compare a b))
+       (let ((comp (compare a b)))
+	 (if (or (eq comp ':less) (eq comp ':greater))
+	     comp
+	   default)))
     (let ((comp (compare (car a) (car b))))
       (when (or (eq comp ':less) (eq comp ':greater))
    (return comp))
@@ -342,295 +366,95 @@
    (setq default ':unequal)))))
-;;; Sets
-
-(defmethod compare ((a null) (b set))
-  ':less)
-
-(defmethod compare ((b set) (a null))
-  ':greater)
-
-(defmethod compare ((a real) (b set))
-  ':less)
-
-(defmethod compare ((b set) (a real))
-  ':greater)
-
-(defmethod compare ((a character) (b set))
-  ':less)
-
-(defmethod compare ((b set) (a character))
-  ':greater)
-
-(defmethod compare ((a symbol) (b set))
-  ':less)
-
-(defmethod compare ((b set) (a symbol))
-  ':greater)
-
-(defmethod compare ((a string) (b set))
-  ':less)
-
-(defmethod compare ((b set) (a string))
-  ':greater)
-
-(defmethod compare ((a vector) (b set))
-  ':less)
-
-(defmethod compare ((b set) (a vector))
-  ':greater)
-
-(defmethod compare ((a list) (b set))
-  ':less)
-
-(defmethod compare ((b set) (a list))
-  ':greater)
-
-;;; ((set set) method is elsewhere)
-
-
-;;; Bags
-
-(defmethod compare ((a null) (b bag))
-  ':less)
-
-(defmethod compare ((b bag) (a null))
-  ':greater)
-
-(defmethod compare ((a real) (b bag))
-  ':less)
-
-(defmethod compare ((b bag) (a real))
-  ':greater)
-
-(defmethod compare ((a character) (b bag))
-  ':less)
-
-(defmethod compare ((b bag) (a character))
-  ':greater)
-
-(defmethod compare ((a symbol) (b bag))
-  ':less)
+;;; Packages (needed for symbols)
-(defmethod compare ((b bag) (a symbol))
-  ':greater)
+(deflex +Package-Original-Name+ (make-hash-table)
+  "FSet uses this to protect itself from the effects of `rename-package',
+which could otherwise change the ordering of packages, and thus of symbols,
+and thus of types named by those symbols.")
+
+(defmethod compare ((a package) (b package))
+  ;; This is a bit subtle.  In order to keep things fast in the most common
+  ;; case -- comparing symbols in the same package -- we do the `eq' test first,
+  ;; and if it succeeds, we don't squirrel away the current package name.  This
+  ;; is okay, because if a package has never been involved in an interpackage
+  ;; comparison, then FSet can't be counting on the results of that comparison
+  ;; to remain consistent.
+  (if (eq a b)
+      ':equal
+    (flet ((pkg-name (pkg)
+	     (or (gethash pkg +Package-Original-Name+)
+		 (setf (gethash pkg +Package-Original-Name+)
+		       (package-name pkg)))))
+      (let ((a-name (pkg-name a))
+	    (b-name (pkg-name b))
+	    ((comp (compare a-name b-name))))
+	(if (eq comp ':equal)
+	    ':unequal			; we already checked for the `eq' case
+	  comp)))))
+
+
+;;; Pathnames
+
+(defmethod compare ((a pathname) (b pathname))
+  (compare-slots a b #'pathname-host #'pathname-device #'pathname-directory
+		 #'pathname-name #'pathname-type #'pathname-version))
-(defmethod compare ((a string) (b bag))
-  ':less)
-(defmethod compare ((b bag) (a string))
-  ':greater)
-
-(defmethod compare ((a vector) (b bag))
-  ':less)
-
-(defmethod compare ((b bag) (a vector))
-  ':greater)
-
-(defmethod compare ((a list) (b bag))
-  ':less)
-
-(defmethod compare ((b bag) (a list))
-  ':greater)
-
-(defmethod compare ((a set) (b bag))
-  ':less)
-
-(defmethod compare ((b bag) (a set))
-  ':greater)
-
-;;; ((bag bag) method is elsewhere)
-
-
-;;; Maps
-
-(defmethod compare ((a null) (b map))
-  ':less)
-
-(defmethod compare ((b map) (a null))
-  ':greater)
-
-(defmethod compare ((a real) (b map))
-  ':less)
-
-(defmethod compare ((b map) (a real))
-  ':greater)
-
-(defmethod compare ((a character) (b map))
-  ':less)
-
-(defmethod compare ((b map) (a character))
-  ':greater)
-
-(defmethod compare ((a symbol) (b map))
-  ':less)
-
-(defmethod compare ((b map) (a symbol))
-  ':greater)
-
-(defmethod compare ((a string) (b map))
-  ':less)
-
-(defmethod compare ((b map) (a string))
-  ':greater)
-
-(defmethod compare ((a vector) (b map))
-  ':less)
-
-(defmethod compare ((b map) (a vector))
-  ':greater)
-
-(defmethod compare ((a list) (b map))
-  ':less)
-
-(defmethod compare ((b map) (a list))
-  ':greater)
-
-(defmethod compare ((a set) (b map))
-  ':less)
-
-(defmethod compare ((b map) (a set))
-  ':greater)
-
-(defmethod compare ((a bag) (b map))
-  ':less)
-
-(defmethod compare ((b map) (a bag))
-  ':greater)
-
-;;; ((map map) method is elsewhere)
-
-;;; Sequences
-
-(defmethod compare ((a null) (b seq))
-  ':less)
-
-(defmethod compare ((b seq) (a null))
-  ':greater)
-
-(defmethod compare ((a real) (b seq))
-  ':less)
-
-(defmethod compare ((b seq) (a real))
-  ':greater)
-
-(defmethod compare ((a character) (b seq))
-  ':less)
-
-(defmethod compare ((b seq) (a character))
-  ':greater)
-
-(defmethod compare ((a symbol) (b seq))
-  ':less)
-
-(defmethod compare ((b seq) (a symbol))
-  ':greater)
-
-(defmethod compare ((a string) (b seq))
-  ':less)
-
-(defmethod compare ((b seq) (a string))
-  ':greater)
-
-(defmethod compare ((a vector) (b seq))
-  ':less)
-
-(defmethod compare ((b seq) (a vector))
-  ':greater)
-
-(defmethod compare ((a list) (b seq))
-  ':less)
-
-(defmethod compare ((b seq) (a list))
-  ':greater)
-
-(defmethod compare ((a set) (b seq))
-  ':less)
-
-(defmethod compare ((b seq) (a set))
-  ':greater)
-
-(defmethod compare ((a bag) (b seq))
-  ':less)
-
-(defmethod compare ((b seq) (a bag))
-  ':greater)
-
-(defmethod compare ((a map) (b seq))
-  ':less)
-
-(defmethod compare ((b seq) (a map))
-  ':greater)
-
-;;; ((seq seq) method is elsewhere)
-
-;;; Tuples
-
-(defmethod compare ((a null) (b tuple))
-  ':less)
-
-(defmethod compare ((b tuple) (a null))
-  ':greater)
-
-(defmethod compare ((a real) (b tuple))
-  ':less)
-
-(defmethod compare ((b tuple) (a real))
-  ':greater)
-
-(defmethod compare ((a character) (b tuple))
-  ':less)
-
-(defmethod compare ((b tuple) (a character))
-  ':greater)
-
-(defmethod compare ((a symbol) (b tuple))
-  ':less)
-
-(defmethod compare ((b tuple) (a symbol))
-  ':greater)
-
-(defmethod compare ((a string) (b tuple))
-  ':less)
-
-(defmethod compare ((b tuple) (a string))
-  ':greater)
-
-(defmethod compare ((a vector) (b tuple))
-  ':less)
-
-(defmethod compare ((b tuple) (a vector))
-  ':greater)
-
-(defmethod compare ((a list) (b tuple))
-  ':less)
-
-(defmethod compare ((b tuple) (a list))
-  ':greater)
-
-(defmethod compare ((a set) (b tuple))
-  ':less)
-
-(defmethod compare ((b tuple) (a set))
-  ':greater)
-
-(defmethod compare ((a bag) (b tuple))
-  ':less)
-
-(defmethod compare ((b tuple) (a bag))
-  ':greater)
-
-(defmethod compare ((a map) (b tuple))
-  ':less)
-
-(defmethod compare ((b tuple) (a map))
-  ':greater)
+;;; ================================================================================
+;;; Lexicographic comparison of sequences
-(defmethod compare ((a seq) (b tuple))
-  ':less)
+;;; User code that specifically wants lexicographic comparison can call this
+;;; in the `compare' method for the user type in question.
+(defgeneric compare-lexicographically (a b)
+  (:documentation
+    "Returns the result of a lexicographic comparison of `a' and `b', which
+can be strings, vectors, lists, or seqs."))
-(defmethod compare ((b tuple) (a seq))
-  ':greater)
+(defmethod compare-lexicographically ((a string) (b string))
+  (let ((len-a (length a))
+	(len-b (length b)))
+    (if (and (simple-string-p a) (simple-string-p b))
+	(dotimes (i (min len-a len-b)
+		  (cond ((< len-a len-b) ':less)
+			((> len-a len-b) ':greater)
+			(t ':equal)))
+	  (let ((ca (schar a i))
+		(cb (schar b i)))
+	    (cond ((char< ca cb) (return ':less))
+		  ((char> ca cb) (return ':greater)))))
+      (dotimes (i (min len-a len-b)
+		(cond ((< len-a len-b) ':less)
+		      ((> len-a len-b) ':greater)
+		      (t ':equal)))
+	(let ((ca (char a i))
+	      (cb (char b i)))
+	  (cond ((char< ca cb) (return ':less))
+		((char> ca cb) (return ':greater))))))))
-;;; ((tuple tuple) method is elsewhere)
+(defmethod compare-lexicographically ((a list) (b list))
+  (compare-lists-lexicographically a b))
+(defmethod compare-lexicographically ((a vector) (b vector))
+  (let ((len-a (length a))
+	(len-b (length b))
+	(default ':equal))
+    (if (and (simple-vector-p a) (simple-vector-p b))
+	(dotimes (i (min len-a len-b)
+		  (cond ((< len-a len-b) ':less)
+			((> len-a len-b) ':greater)
+			(t default)))
+	  (let ((res (compare (svref a i) (svref b i))))
+	    (when (or (eq res ':less) (eq res ':greater))
+	      (return res))
+	    (when (eq res ':unequal)
+	      (setq default ':unequal))))
+      (dotimes (i (min len-a len-b)
+		(cond ((< len-a len-b) ':less)
+		      ((> len-a len-b) ':greater)
+		      (t default)))
+	(let ((res (compare (aref a i) (aref b i))))
+	  (when (or (eq res ':less) (eq res ':greater))
+	    (return res))
+	  (when (eq res ':unequal)
+	    (setq default ':unequal)))))))
Modified: trunk/Code/port.lisp
==============================================================================
--- trunk/Code/port.lisp	(original)
+++ trunk/Code/port.lisp	Sun Oct 26 05:34:03 2008
@@ -16,99 +16,168 @@
 ;;; real locking.
#+(and allegro (not os-threads))
-(defun make-lock (&optional name)
-  (declare (ignore name))
-  nil)
-#+(and allegro (not os-threads))
-(defmacro with-lock ((lock &key (wait? t)) &body body)
-  (declare (ignore lock wait?))
-  `(excl:without-interrupts . ,body))
+(progn
+  (defun make-lock (&optional name)
+    (declare (ignore name))
+    nil)
+  (defmacro with-lock ((lock &key (wait? t)) &body body)
+    (declare (ignore lock wait?))
+    `(excl:without-interrupts . ,body))
+  (defmacro read-memory-barrier ()
+    'nil)
+  (defmacro write-memory-barrier ()
+    'nil))
#+(and allegro os-threads)
-(defun make-lock (&optional name)
-  (error "&&& Write me"))
-#+(and allegro os-threads)
-(defmacro with-lock ((lock &key (wait? t)) &body body)
-  (error "&&& Write me"))
+(progn
+  (defun make-lock (&optional (name "A lock"))
+    (mp:make-process-lock :name name))
+  (defmacro with-lock ((lock &key (wait? t)) &body body)
+    ;; See the OpenMCL code below for a suggestion of how to implement non-waiting
+    ;; mode (Allegro doesn't have it built in).
+    (error "&&& Write me"))
+  (defvar *Allegro-Read-Memory-Barrier-Lock*
+    (mp:make-process-lock :name "Read Memory Barrier Lock"))
+  (defmacro read-memory-barrier ()
+    ;; Allegro doesn't seem to have any better way to do this.
+    (mp:with-process-lock (*Allegro-Read-Memory-Barrier-Lock*)
+      nil))
+  (defvar *Allegro-Write-Memory-Barrier-Lock*
+    (mp:make-process-lock :name "Write Memory Barrier Lock"))
+  (defmacro write-memory-barrier ()
+    ;; Allegro doesn't seem to have any better way to do this.
+    (mp:with-process-lock (*Allegro-Write-Memory-Barrier-Lock*)
+      nil)))
#+lispworks
-(defun make-lock (&optional name)
-  (declare (ignore name))
-  nil)
-#+lispworks
-(defmacro with-lock ((lock &key (wait? t)) &body body)
-  (declare (ignore lock wait?))
-  `(mp:without-interrupts . ,body))
+(progn
+  (defun make-lock (&optional name)
+    (declare (ignore name))
+    nil)
+  (defmacro with-lock ((lock &key (wait? t)) &body body)
+    (declare (ignore lock wait?))
+    `(mp:without-interrupts . ,body))
+  (defmacro read-memory-barrier ()
+    'nil)
+  (defmacro write-memory-barrier ()
+    'nil))
+
#+cmu
-(defun make-lock (&optional name)
-  (declare (ignore name))
-  nil)
-#+cmu
-(defmacro with-lock ((lock &key (wait? t)) &body body)
-  (declare (ignore lock wait?))
-  `(sys:without-interrupts . ,body))
+(progn
+  (defun make-lock (&optional name)
+    (declare (ignore name))
+    nil)
+  (defmacro with-lock ((lock &key (wait? t)) &body body)
+    (declare (ignore lock wait?))
+    `(sys:without-interrupts . ,body))
+  (defmacro read-memory-barrier ()
+    'nil)
+  (defmacro write-memory-barrier ()
+    'nil))
#+sbcl
-(defun make-lock (&optional name)
-  (sb-thread:make-mutex :name name))
+(progn
+  (defun make-lock (&optional name)
+    (sb-thread:make-mutex :name name))
+  (defmacro with-lock ((lock &key (wait? t)) &body body)
+    `(sb-thread:with-mutex (,lock :wait-p ,wait?)
+       . ,body))
+  #-sb-thread
+  (progn
+    (defmacro read-memory-barrier ()
+      nil)
+    (defmacro write-memory-barrier ()
+      nil))
+  #+sb-thread
+  (progn
+    (defvar *SBCL-Read-Memory-Barrier-Lock*
+      (sb-thread:make-mutex :name "Read Memory Barrier Lock"))
+    (defmacro read-memory-barrier ()
+      ;; SBCL doesn't seem to have any better way to do this (yet).
+      (mp:with-process-lock (*SBCL-Read-Memory-Barrier-Lock*)
+	nil))
+    (defvar *SBCL-Write-Memory-Barrier-Lock*
+      (sb-thread:make-mutex :name "Write Memory Barrier Lock"))
+    (defmacro write-memory-barrier ()
+      ;; SBCL doesn't seem to have any better way to do this (yet).
+      (mp:with-process-lock (*SBCL-Write-Memory-Barrier-Lock*)
+	nil))))
-#+sbcl
-(defmacro with-lock ((lock &key (wait? t)) &body body)
-  `(sb-thread:with-mutex (,lock :wait-p ,wait?)
-     . ,body))
#+scl
-(defun make-lock (&optional name)
-  (thread:make-lock name :type ':recursive :auto-free t))
-#+scl
-(defmacro with-lock ((lock &key (wait? t)) &body body)
-  `(thread:with-lock-held (,lock "Lock Wait" :wait ,wait?)
-			  . ,body))
+(progn
+  (defun make-lock (&optional name)
+    (thread:make-lock name :type ':recursive :auto-free t))
+  (defmacro with-lock ((lock &key (wait? t)) &body body)
+    `(thread:with-lock-held (,lock "Lock Wait" :wait ,wait?)
+			    . ,body))
+  (defmacro read-memory-barrier ()
+    '(kernel:read-memory-barrier))
+  (defmacro write-memory-barrier ()
+    '(kernel:write-memory-barrier)))
#+openmcl
-(defun make-lock (&optional name)
-  (ccl:make-lock name))
-#+openmcl
-(defmacro with-lock ((lock &key (wait? t)) &body body)
-  (let ((lock-var (gensym "LOCK-"))
-	(wait?-var (gensym "WAIT?-"))
-	(try-succeeded?-var (gensym "TRY-SUCCEEDED?-")))
-    `(let ((,lock-var ,lock)
-	   . ,(and (not (eq wait? 't))
-		   `((,wait?-var ,wait?)
-		     (,try-succeeded?-var nil))))
-       ,(if (eq wait? 't)
-	    `(ccl:with-lock-grabbed (,lock-var)
-	      . ,body)
-	  `(unwind-protect
-	       (and (or ,wait?-var (and (ccl:try-lock ,lock-var)
-				   (setq ,try-succeeded?-var t)))
-		    (ccl:with-lock-grabbed (,lock-var)
-		      . ,body))
-	     (when ,try-succeeded?-var
-	       (ccl:release-lock ,lock-var)))))))
-
-#+(and genera new-scheduler)
-(defun make-lock (&optional name)
-  (process:make-lock name))
+(progn
+  (defun make-lock (&optional name)
+    (ccl:make-lock name))
+  (defmacro with-lock ((lock &key (wait? t)) &body body)
+    (let ((lock-var (gensym "LOCK-"))
+	  (wait?-var (gensym "WAIT?-"))
+	  (try-succeeded?-var (gensym "TRY-SUCCEEDED?-")))
+      `(let ((,lock-var ,lock)
+	     . ,(and (not (eq wait? 't))
+		     `((,wait?-var ,wait?)
+		       (,try-succeeded?-var nil))))
+	 ,(if (eq wait? 't)
+	      `(ccl:with-lock-grabbed (,lock-var)
+		. ,body)
+	    `(unwind-protect
+		 (and (or ,wait?-var (and (ccl:try-lock ,lock-var)
+					  (setq ,try-succeeded?-var t)))
+		      (ccl:with-lock-grabbed (,lock-var)
+			. ,body))
+	       (when ,try-succeeded?-var
+		 (ccl:release-lock ,lock-var)))))))
+  (defvar *OpenMCL-Read-Memory-Barrier-Lock*
+    (ccl:make-lock "Read Memory Barrier Lock"))
+  (defmacro read-memory-barrier ()
+    ;; OpenMCL doesn't seem to have any better way to do this.
+    (ccl:with-lock-grabbed (*OpenMCL-Read-Memory-Barrier-Lock*)
+      nil))
+  (defvar *OpenMCL-Write-Memory-Barrier-Lock*
+    (ccl:make-lock "Write Memory Barrier Lock"))
+  (defmacro write-memory-barrier ()
+    ;; OpenMCL doesn't seem to have any better way to do this.
+    (ccl:with-lock-grabbed (*OpenMCL-Write-Memory-Barrier-Lock*)
+      nil)))
#+(and genera new-scheduler)
-(defmacro with-lock ((lock &key (wait? t)) &body body)
-  (declare (ignore wait?))
-  `(process:with-lock (,lock)
-     . ,body))
+(progn
+  (defun make-lock (&optional name)
+    (process:make-lock name))
+  (defmacro with-lock ((lock &key (wait? t)) &body body)
+    (declare (ignore wait?))
+    `(process:with-lock (,lock)
+       . ,body))
+  (defmacro read-memory-barrier ()
+    'nil)
+  (defmacro read-memory-barrier ()
+    'nil))
;;; Some implementations have no threading at all (yet).
 #+clisp
-(defun make-lock (&optional name)
-  (declare (ignore name))
-  nil)
-
-#+clisp
-(defmacro with-lock ((lock &key (wait? t)) &body body)
-  (declare (ignore lock wait?))
-  `(progn . ,body))
+(progn
+  (defun make-lock (&optional name)
+    (declare (ignore name))
+    nil)
+  (defmacro with-lock ((lock &key (wait? t)) &body body)
+    (declare (ignore lock wait?))
+    `(progn . ,body))
+  (defmacro read-memory-barrier ()
+    'nil)
+  (defmacro write-memory-barrier ()
+    'nil))
;;; ----------------
@@ -118,7 +187,7 @@
(defconstant Tuple-Key-Number-Size
   (ecase (integer-length most-positive-fixnum)
-    (60 40)	; SBCL, OpenMCL, 64-bit
+    (60 40)	; SBCL, OpenMCL, Scieneer CL, 64-bit
     (31 18)	; Symbolics L-machine, I-machine
     (29 17)	; Allegro, CMUCL, SBCL, LispWorks (most), 32-bit
     (24 15)	; CLISP, 32-bit
@@ -194,16 +263,41 @@
   (code-char code))
+;;; I'm one of these weird people who detests `loop' (except in its CLtL1 form).
+(defmacro while (pred &body body)
+  `(do () ((not ,pred))
+     . ,body))
+
+
+;;; ----------------
+
+;;; A macro used mostly by the bag code to get generic arithmetic in speed-3
+;;; routines without all those compiler notes from CMUCL, SBCL, or Scieneer
+;;; CL.
+(defmacro gen (op &rest args)
+  (let ((vars (mapcar (lambda (x) (and (not (or (symbolp x) (numberp x)))
+				       (gensym "VAR-")))
+		      args)))
+    `(let ,(cl:remove nil (mapcar (lambda (var arg)
+				    (and var `(,var ,arg)))
+				  vars args))
+       (locally (declare (optimize (speed 1) (safety 1)))
+	 (,op . ,(mapcar (lambda (var arg) (or var arg))
+			 vars args))))))
+
+
 ;;; This little oddity exists because of a limitation in Python (that's the
 ;;; CMUCL compiler).  Given a call to `length' on type `(or null simple-vector)',
 ;;; Python isn't quite smart enough to optimize the call unless we do the case
 ;;; breakdown for it like this.
 #+(or cmu scl)
-(defmacro length (x)
+(defmacro length-nv (x)
   (ext:once-only ((x x))
     `(if (null ,x) 0 (cl:length ,x))))
 #+sbcl
-(defmacro length (x)
+(defmacro length-nv (x)
   (sb-ext::once-only ((x x))
     `(if (null ,x) 0 (cl:length ,x))))
-
+#-(or cmu scl sbcl)
+(defmacro length-nv (x)
+  `(length ,x))
Modified: trunk/Code/reader.lisp
==============================================================================
--- trunk/Code/reader.lisp	(original)
+++ trunk/Code/reader.lisp	Sun Oct 26 05:34:03 2008
@@ -12,7 +12,9 @@
;;; This file defines two different kinds of convenience syntax for constructing
 ;;; the FSet datatypes: constructor macros, and reader macros that expand to
-;;; invocations of the constructor macros.
+;;; invocations of the constructor macros.  (Note 2008-10-25: the reader macros
+;;; haven't been used much; the constructor macros seem to be as much syntax as
+;;; is desirable in Lisp.  But, they're here if you want them.)
 ;;;
 ;;; Each constructor macro has the same name as the type it constructs (making
 ;;; them somewhat like `cl:list', but with some additional features).  Some
@@ -64,7 +66,7 @@
 ;;; use of the `#$' notation.  Again, the forms are all evaluated.  Examples:
 ;;;
 ;;;   #{| (1 2) (3 'x) |}   ; maps 1 to 2, and 3 to the value of X
-;;;   #{| #$x (1 2) |}      ; equivalent to `(map-merge x #{| (1 2) |})'
+;;;   #{| #$x (1 2) |}      ; equivalent to `(map-union x #{| (1 2) |})'
 ;;;
 ;;; In any case where multiple values are provided for the same key, the rightmost
 ;;; subexpression takes precedence.
@@ -167,7 +169,7 @@
 will be a member of the result set; or a list of the form ($ `expression'), in
 which case the expression must evaluate to a set, all of whose members become
 members of the result set."
-  `(wb-set . ,args))
+  (expand-set-constructor-form 'set args))
(defmacro wb-set (&rest args)
   "Constructs a wb-set according to the supplied argument subforms.  Each
@@ -175,16 +177,24 @@
 result set; or a list of the form ($ `expression'), in which case the
 expression must evaluate to a set, all of whose members become members of the
 result set."
+  (expand-set-constructor-form 'wb-set args))
+
+(defun expand-set-constructor-form (type-name args)
   (let ((normal-args (remove-if #'(lambda (arg) (and (listp arg) (eq (car arg) '$)))
    			args))
    (splice-args (remove-if-not #'(lambda (arg) (and (listp arg) (eq (car arg) '$)))
    			    args))
-	((start (if normal-args `(convert 'set (list . ,normal-args))
-		  `(empty-set)))))
+	((start (if normal-args `(convert ',type-name (list . ,normal-args))
+		  (ecase type-name
+		    (set `(empty-set))
+		    (wb-set `(empty-wb-set)))))))
     (labels ((recur (splice-args result)
           (if (null splice-args) result
-		 `(union ,(cadar splice-args) ,result))))
-      (recur splice-args  start))))
+		 (if (= (length (car splice-args)) 2)
+		     (recur (cdr splice-args) `(union ,(cadar splice-args) ,result))
+		   (error "A splice-arg to the `~S' macro must be of the form ~@
+			   ($ <sub-set>) -- not ~S" type-name (car splice-args))))))
+      (recur splice-args start))))
(defmacro bag (&rest args)
   "Constructs a bag of the default implementation according to the supplied
@@ -197,7 +207,7 @@
 given by the value of `expression2'.  That is, the multiplicity of each member
 of the result bag is the sum of its multiplicities as supplied by each of the
 argument subforms."
-  `(wb-bag . ,args))
+  (expand-bag-constructor-form 'bag args))
(defmacro wb-bag (&rest args)
   "Constructs a wb-bag according to the supplied argument subforms.  Each
@@ -209,6 +219,9 @@
 into the result with multiplicity given by the value of `expression2'.  That
 is, the multiplicity of each member of the result bag is the sum of its
 multiplicities as supplied by each of the argument subforms."
+  (expand-bag-constructor-form 'wb-bag args))
+
+(defun expand-bag-constructor-form (type-name args)
   (let ((normal-args (remove-if #'(lambda (arg) (and (listp arg)
    					     (member (car arg) '($ %))))
    			args))
@@ -216,19 +229,25 @@
    			    args))
    (multi-args (remove-if-not #'(lambda (arg) (and (listp arg) (eq (car arg) '%)))
    			   args))
-	((start (if normal-args `(convert 'bag (list . ,normal-args))
-		  `(empty-bag)))))
+	((start (if normal-args `(convert ',type-name (list . ,normal-args))
+		  (ecase type-name
+		    (bag `(empty-bag))
+		    (wb-bag `(empty-wb-bag)))))))
     (labels ((add-splice-args (splice-args result)
           (if (null splice-args) result
-		 `(bag-sum ,(cadar splice-args)
-			   ,(add-splice-args (cdr splice-args) result))))
+		 (if (= (length (car splice-args)) 2)
+		     `(bag-sum ,(cadar splice-args)
+			       ,(add-splice-args (cdr splice-args) result))
+		   (error "A splice-arg to the `~S' macro must be of the form~@
+			   ($ <sub-bag>) -- not ~S"
+			  type-name (car splice-args)))))
         (add-multi-args (multi-args result)
           (if (null multi-args) result
    	 (let ((m-arg (car multi-args)))
    	   (unless (and (listp m-arg) (= (length m-arg) 3))
-		     (error "A multi-arg to the `~S' macro must be of the form ~
-			     (% <element> <count>) -- not ~S."
-			    'bag m-arg))
+		     (error "A multi-arg to the `~S' macro must be of the form~@
+			     (% <element> <count>) -- not ~S"
+			    type-name m-arg))
    	 `(with ,(add-multi-args (cdr multi-args) result)
    		,(second m-arg) ,(third m-arg))))))
       (add-multi-args multi-args
@@ -243,7 +262,7 @@
 constructed from the denoted mappings in left-to-right order; so if a given key
 is supplied by more than one argument subform, its associated value will be
 given by the rightmost such subform."
-  `(wb-map . ,args))
+  (expand-map-constructor-form 'map args))
(defmacro wb-map (&rest args)
   "Constructs a wb-map according to the supplied argument subforms.  Each
@@ -254,20 +273,26 @@
 mappings in left-to-right order; so if a given key is supplied by more than
 one argument subform, its associated value will be given by the rightmost such
 subform."
-  (labels ((recur (args result)
-	     (cond ((null args) result)
-		   ((not (and (listp (car args))
-			      (= (length (car args)) 2)))
-		    (error "Arguments to ~S must all be pairs expressed as 2-element ~@
-			    lists, or ($ x) subforms -- not ~S."
-			   'map (car args)))
-		   ((eq (caar args) '$)
-		    (if (equal result `(empty-map))
-			(recur (cdr args) (cadar args))
-		      (recur (cdr args) `(map-merge ,result ,(cadar args)))))
-		   (t
-		    (recur (cdr args) `(with ,result ,(caar args) ,(cadar args)))))))
-    (recur args `(empty-map))))
+  (expand-map-constructor-form 'wb-map args))
+
+(defun expand-map-constructor-form (type-name args)
+  (let ((empty-form (ecase type-name
+		      (map `(empty-map))
+		      (wb-map `(empty-wb-map)))))
+    (labels ((recur (args result)
+	       (cond ((null args) result)
+		     ((not (and (listp (car args))
+				(= (length (car args)) 2)))
+		      (error "Arguments to ~S must all be pairs expressed as 2-element~@
+			      lists, or ($ x) subforms -- not ~S"
+			     type-name (car args)))
+		     ((eq (caar args) '$)
+		      (if (eq result empty-form)
+			  (recur (cdr args) (cadar args))
+			(recur (cdr args) `(map-union ,result ,(cadar args)))))
+		     (t
+		      (recur (cdr args) `(with ,result ,(caar args) ,(cadar args)))))))
+      (recur args empty-form))))
(defmacro seq (&rest args)
   "Constructs a seq of the default implementation according to the supplied
@@ -276,7 +301,7 @@
 case the expression must evaluate to a sequence, all of whose values appear in
 the result sequence.  The order of the result sequence reflects the order of
 the argument subforms."
-  `(wb-seq . ,args))
+  (expand-seq-constructor-form 'seq args))
(defmacro wb-seq (&rest args)
   "Constructs a wb-seq according to the supplied argument subforms.  Each
@@ -284,19 +309,29 @@
 or a list of the form ($ `expression'), in which case the expression must
 evaluate to a sequence, all of whose values appear in the result sequence.  The
 order of the result sequence reflects the order of the argument subforms."
+  (expand-seq-constructor-form 'wb-seq args))
+
+(defun expand-seq-constructor-form (type-name args)
   (labels ((recur (args nonsplice-args)
         (cond ((null args)
    	    (if nonsplice-args
-			`(convert 'seq (list . ,(cl:reverse nonsplice-args)))
-		      `(empty-seq)))
+			`(convert ',type-name (list . ,(cl:reverse nonsplice-args)))
+		      (ecase type-name
+			(seq `(empty-seq))
+			(wb-seq `(empty-wb-seq)))))
    	   ((and (listp (car args))
    		 (eq (caar args) '$))
+		    (unless (= (length (car args)) 2)
+		      (error "A splice-arg to the `~S' macro must be of the form~@
+			      ($ <sub-seq>) -- not ~S"
+			     type-name (car args)))
    	    (let ((rest (if (cdr args)
    			    `(concat ,(cadar args)
    				     ,(recur (cdr args) nil))
    			  (cadar args))))
    	      (if nonsplice-args
-			  `(concat (convert 'seq (list . ,(cl:reverse nonsplice-args)))
+			  `(concat (convert ',type-name
+					    (list . ,(cl:reverse nonsplice-args)))
    			   ,rest)
    		rest)))
    	   (t
@@ -312,7 +347,7 @@
 constructed from the denoted mappings in left-to-right order; so if a given key
 is supplied by more than one argument subform, its associated value will be
 given by the rightmost such subform."
-  `(dyn-tuple . ,args))
+  (expand-tuple-constructor-form 'tuple args))
(defmacro dyn-tuple (&rest args)
   "Constructs a dyn-tuple according to the supplied argument subforms.  Each
@@ -323,15 +358,20 @@
 mappings in left-to-right order; so if a given key is supplied by more than one
 argument subform, its associated value will be given by the rightmost such
 subform."
+  (expand-tuple-constructor-form 'dyn-tuple args))
+
+(defun expand-tuple-constructor-form (type-name args)
   (labels ((recur (args result)
         (cond ((null args) result)
    	   ((not (and (listp (car args))
    		      (= (length (car args)) 2)))
-		    (error "Arguments to ~S must all be pairs expressed as 2-element ~@
-			    lists, or ($ x) subforms -- not ~S."
-			   'tuple (car args)))
+		    (error "Arguments to ~S must all be pairs expressed as 2-element~@
+			    lists, or ($ x) subforms -- not ~S"
+			   type-name (car args)))
    	   ((eq (caar args) '$)
-		    (if (equal result `(empty-tuple))
+		    (if (equal result (ecase type-name
+					(tuple `(empty-tuple))
+					(dyn-tuple `(empty-dyn-tuple))))
    		(recur (cdr args) (cadar args))
    	      (recur (cdr args) `(tuple-merge ,result ,(cadar args)))))
    	   (t
@@ -364,7 +404,7 @@
 (defun |#~-reader| (stream subchar arg)
   (declare (ignore subchar arg))
   (unless (eql (read-char stream) #<)
-    (error ""#~" must be followed by "<""))
+    (error ""#~~" must be followed by "<""))
   `(tuple . ,(read-delimited-list #> stream t)))
(defun |#$-reader| (stream subchar arg)
@@ -410,7 +450,7 @@
     (#%
      (read-char stream t nil t)
      (let ((stuff (read-delimited-list #% stream t))
-	   (result (bag)))
+	   (result (empty-bag)))
        (unless (eql (read-char stream) #})
     (error "Incorrect #{% ... %} syntax"))
        (dolist (x stuff)
@@ -428,9 +468,9 @@
 (defun |rereading-#~-reader| (stream subchar arg)
   (declare (ignore subchar arg))
   (unless (eql (read-char stream) #<)
-    (error ""#~" must be followed by "<""))
+    (error ""#~~" must be followed by "<""))
   (let ((stuff (read-delimited-list #> stream t))
-	(result (tuple)))
+	(result (empty-tuple)))
     (dolist (pr stuff)
       (unless (and (consp pr) (consp (cdr pr)) (null (cddr pr)))
    (error "~S is not a 2-element list." pr))
Added: trunk/Code/relations.lisp
==============================================================================
--- (empty file)
+++ trunk/Code/relations.lisp	Sun Oct 26 05:34:03 2008
@@ -0,0 +1,473 @@
+;;; -*- Mode: Lisp; Package: FSet; Syntax: ANSI-Common-Lisp -*-
+
+(in-package :fset)
+
+;;; File: relations.lisp
+;;; Contents: Relations (binary and general).
+;;;
+;;; This file is part of FSet.  Copyright (c) 2007 Sympoiesis, Inc.
+;;; FSet is licensed under the Lisp Lesser GNU Public License, or LLGPL.
+;;; See: http://opensource.franz.com/preamble.html
+;;; This license provides NO WARRANTY.
+
+
+(defstruct (relation
+	    (:include collection)
+	    (:constructor nil)
+	    (:predicate relation?)
+	    (:copier nil))
+  "The abstract class for FSet relations.  It is a structure class.")
+
+(defgeneric arity (rel)
+  (:documentation "Returns the arity of the relation `rel'."))
+
+(defstruct (2-relation
+	    (:include relation)
+	    (:constructor nil)
+	    (:predicate 2-relation?)
+	    (:copier nil))
+  "The abstract class for FSet binary relations.  It is a structure class.")
+
+(defmethod arity ((br 2-relation))
+  2)
+
+(defstruct (wb-2-relation
+	    (:include 2-relation)
+	    (:constructor make-wb-2-relation (size map0 map1))
+	    (:predicate wb-2-relation?)
+	    (:print-function print-wb-2-relation)
+	    (:copier nil))
+  "A class of functional binary relations represented as pairs of weight-
+balanced binary trees.  This is the default implementation of binary relations
+in FSet.  The inverse is constructed lazily, and maintained thereafter."
+  size
+  map0
+  map1)
+
+(defparameter *empty-wb-2-relation* (make-wb-2-relation 0 nil nil))
+
+(defun empty-2-relation ()
+  *empty-wb-2-relation*)
+(declaim (inline empty-2-relation))
+
+(defun empty-wb-2-relation ()
+  *empty-wb-2-relation*)
+(declaim (inline empty-wb-2-relation))
+
+(defmethod empty? ((br wb-2-relation))
+  (zerop (wb-2-relation-size br)))
+
+(defmethod size ((br wb-2-relation))
+  (wb-2-relation-size br))
+
+(defmethod arb ((br wb-2-relation))
+  (let ((tree (wb-2-relation-map0 br)))
+    (if tree
+	(let ((key val (WB-Map-Tree-Arb-Pair tree)))
+	  (values key (WB-Set-Tree-Arb val)) t)
+      (values nil nil nil))))
+
+;;; Must pass the pair as a cons -- the generic function doesn't allow us to
+;;; add a parameter.  (&&& Actually we should do the same thing we're doing
+;;; with `with' and `less'.)
+(defmethod contains? ((br wb-2-relation) pr)
+  (let ((found? set-tree (WB-Map-Tree-Lookup (wb-2-relation-map0 br) (car pr))))
+    (and found? (WB-Set-Tree-Member? set-tree (cdr pr)))))
+
+;;; Returns the range set.
+(defmethod lookup ((br wb-2-relation) x)
+  (let ((found? set-tree (WB-Map-Tree-Lookup (wb-2-relation-map0 br) x)))
+    (if found? (make-wb-set set-tree)
+      *empty-wb-set*)))
+
+(defgeneric lookup-inv (2-relation y)
+  (:documentation "Does an inverse lookup on a binary relation."))
+
+(defmethod lookup-inv ((br wb-2-relation) y)
+  (get-inverse br)
+  (let ((found? set-tree (WB-Map-Tree-Lookup (wb-2-relation-map1 br) y)))
+    (if found? (make-wb-set set-tree)
+      *empty-wb-set*)))
+
+(defmethod domain ((br wb-2-relation))
+  (make-wb-set (WB-Map-Tree-Domain (wb-2-relation-map0 br))))
+
+(defmethod range ((br wb-2-relation))
+  (get-inverse br)
+  (make-wb-set (WB-Map-Tree-Domain (wb-2-relation-map1 br))))
+
+(defun get-inverse (br)
+  (let ((m0 (wb-2-relation-map0 br))
+	(m1 (wb-2-relation-map1 br)))
+    (when (and m0 (null m1))
+      (Do-WB-Map-Tree-Pairs (x s m0)
+	(Do-WB-Set-Tree-Members (y s)
+	  (let ((ignore prev (WB-Map-Tree-Lookup m1 y)))
+	    (declare (ignore ignore))
+	    (setq m1 (WB-Map-Tree-With m1 y (WB-Set-Tree-With prev x))))))
+      ;;; Look Ma, no locking!  Assuming the write is atomic.
+      (setf (wb-2-relation-map1 br) m1))
+    m1))
+
+(defgeneric inverse (2-relation)
+  (:documentation "The inverse of a binary relation."))
+
+;;; This is so fast (once the inverse is constructed) we almost don't need
+;;; `lookup-inv'.  Maybe we should just put a compiler optimizer on
+;;; `(lookup (inverse ...) ...)'?
+(defmethod inverse ((br wb-2-relation))
+  (get-inverse br)
+  (make-wb-2-relation (wb-2-relation-size br) (wb-2-relation-map1 br)
+		      (wb-2-relation-map0 br)))
+
+(defmethod least ((br wb-2-relation))
+  (let ((tree (wb-2-relation-map0 br)))
+    (if tree
+	(let ((key val (WB-Map-Tree-Least-Pair tree)))
+	  (values key val t))
+      (values nil nil nil))))
+
+(defmethod greatest ((br wb-2-relation))
+  (let ((tree (wb-2-relation-map0 br)))
+    (if tree
+	(let ((key val (WB-Map-Tree-Greatest-Pair tree)))
+	  (values key val t))
+      (values nil nil nil))))
+
+(defmethod with ((br wb-2-relation) x &optional (y nil y?))
+  ;; Try to provide a little support for the cons representation of pairs.
+  (unless y?
+    (setq y (cdr x) x (car x)))
+  (let ((found? set-tree (WB-Map-Tree-Lookup (wb-2-relation-map0 br) x))
+	(map1 (wb-2-relation-map1 br)))
+    (if found?
+	(let ((new-set-tree (WB-Set-Tree-With set-tree y)))
+	  (if (eq new-set-tree set-tree)
+	      br			; `y' was already there
+	    (make-wb-2-relation (1+ (wb-2-relation-size br))
+			     (WB-Map-Tree-With (wb-2-relation-map0 br) x new-set-tree)
+			     (and map1
+				  (let ((ignore set-tree-1
+					  (WB-Map-Tree-Lookup map1 y)))
+				    (declare (ignore ignore))
+				    (WB-Map-Tree-With
+				      map1 y (WB-Set-Tree-With set-tree-1 x)))))))
+      (make-wb-2-relation (1+ (wb-2-relation-size br))
+		       (WB-Map-Tree-With (wb-2-relation-map0 br) x
+					 (WB-Set-Tree-With nil y))
+		       (and map1
+			    (let ((ignore set-tree-1
+				    (WB-Map-Tree-Lookup map1 y)))
+			      (declare (ignore ignore))
+			      (WB-Map-Tree-With
+				map1 y (WB-Set-Tree-With set-tree-1 x))))))))
+
+(defmethod less ((br wb-2-relation) x &optional (y nil y?))
+  ;; Try to provide a little support for the cons representation of pairs.
+  (unless y?
+    (setq y (cdr x) x (car x)))
+  (let ((found? set-tree (WB-Map-Tree-Lookup (wb-2-relation-map0 br) x))
+	(map1 (wb-2-relation-map1 br)))
+    (if (not found?)
+	br
+      (let ((new-set-tree (WB-Set-Tree-Less set-tree y)))
+	(if (eq new-set-tree set-tree)
+	    br
+	  (make-wb-2-relation (1- (wb-2-relation-size br))
+			   (if new-set-tree
+			       (WB-Map-Tree-With (wb-2-relation-map0 br) x new-set-tree)
+			     (WB-Map-Tree-Less (wb-2-relation-map0 br) x))
+			   (and map1
+				(let ((ignore set-tree
+					(WB-Map-Tree-Lookup map1 y))
+				      ((new-set-tree (WB-Set-Tree-Less set-tree x))))
+				  (declare (ignore ignore))
+				  (if new-set-tree
+				      (WB-Map-Tree-With map1 y new-set-tree)
+				    (WB-Map-Tree-Less map1 y))))))))))
+
+(defmethod union ((br1 wb-2-relation) (br2 wb-2-relation) &key)
+  (let ((new-size 0)
+	((new-map0 (WB-Map-Tree-Union (wb-2-relation-map0 br1) (wb-2-relation-map0 br2)
+				      (lambda (ignore s1 s2)
+					(declare (ignore ignore))
+					(let ((s (WB-Set-Tree-Union s1 s2)))
+					  (incf new-size (WB-Set-Tree-Size s))
+					  s))))
+	 (new-map1 (and (or (wb-2-relation-map1 br1) (wb-2-relation-map1 br2))
+			(WB-Map-Tree-Union (wb-2-relation-map1 br1)
+					   (wb-2-relation-map1 br2)
+					   (lambda (ignore s1 s2)
+					     (declare (ignore ignore))
+					     (WB-Set-Tree-Union s1 s2)))))))
+    (make-wb-2-relation new-size new-map0 new-map1)))
+
+(defmethod intersection ((br1 wb-2-relation) (br2 wb-2-relation) &key)
+  (let ((new-size 0)
+	((new-map0 (WB-Map-Tree-Intersect (wb-2-relation-map0 br1)
+					  (wb-2-relation-map0 br2)
+					  (lambda (ignore s1 s2)
+					    (declare (ignore ignore))
+					    (let ((s (WB-Set-Tree-Intersect s1 s2)))
+					      (incf new-size (WB-Set-Tree-Size s))
+					      (values s s)))))
+	 (new-map1 (and (or (wb-2-relation-map1 br1) (wb-2-relation-map1 br2))
+			(WB-Map-Tree-Intersect (wb-2-relation-map1 br1)
+					       (wb-2-relation-map1 br2)
+					       (lambda (ignore s1 s2)
+						 (declare (ignore ignore))
+						 (let ((s (WB-Set-Tree-Intersect s1 s2)))
+						   (values s s))))))))
+    (make-wb-2-relation new-size new-map0 new-map1)))
+
+(defgeneric join (relation-a column-a relation-b column-b)
+  (:documentation
+    "A relational equijoin, matching up `column-a' of `relation-a' with `column-b' of
+`relation-b'.  For a binary relation, the columns are named 0 (domain) and 1 (range)."))
+
+(defmethod join ((bra wb-2-relation) cola (brb wb-2-relation) colb)
+  (let ((map0a map1a (ecase cola
+		       (1 (values (wb-2-relation-map0 bra) (wb-2-relation-map1 bra)))
+		       (0 (progn
+			    (get-inverse bra)
+			    (values (wb-2-relation-map1 bra)
+				    (wb-2-relation-map0 bra))))))
+	(map0b map1b (ecase colb
+		       (0 (values (wb-2-relation-map0 brb) (wb-2-relation-map1 brb)))
+		       (1 (progn
+			    (get-inverse brb)
+			    (values (wb-2-relation-map1 brb)
+				    (wb-2-relation-map0 brb))))))
+	(new-map0 nil)
+	(new-map1 nil)
+	(new-size 0))
+    (Do-WB-Map-Tree-Pairs (x ys map0a)
+      (Do-WB-Set-Tree-Members (y ys)
+	(let ((ignore s (WB-Map-Tree-Lookup map0b y)))
+	  (declare (ignore ignore))
+	  (when s
+	    (let ((ignore prev (WB-Map-Tree-Lookup new-map0 x))
+		  ((new (WB-Set-Tree-Union prev s))))
+	      (declare (ignore ignore))
+	      (incf new-size (- (WB-Set-Tree-Size new) (WB-Set-Tree-Size prev)))
+	      (setq new-map0 (WB-Map-Tree-With new-map0 x new)))))))
+    (when (or map1a map1b)
+      (when (null map1b)
+	(setq map1b (get-inverse brb)))
+      (when (null map1a)
+	(setq map1a (get-inverse bra)))
+      (Do-WB-Map-Tree-Pairs (x ys map1b)
+	(Do-WB-Set-Tree-Members (y ys)
+	  (let ((ignore s (WB-Map-Tree-Lookup map1a y)))
+	    (declare (ignore ignore))
+	    (when s
+	      (let ((ignore prev (WB-Map-Tree-Lookup new-map1 x)))
+		(declare (ignore ignore))
+		(setq new-map1
+		      (WB-Map-Tree-With new-map1 x (WB-Set-Tree-Union prev s)))))))))
+    (make-wb-2-relation new-size new-map0 new-map1)))
+
+
+(defgeneric internal-do-2-relation (br elt-fn value-fn))
+
+(defmacro do-2-relation ((key val br &optional value) &body body)
+  `(block nil
+     (internal-do-2-relation ,br (lambda (,key ,val) . ,body)
+			      (lambda () ,value))))
+
+(defmethod internal-do-2-relation ((br wb-2-relation) elt-fn value-fn)
+  (Do-WB-Map-Tree-Pairs (x y-set (wb-2-relation-map0 br) (funcall value-fn))
+    (Do-WB-Set-Tree-Members (y y-set)
+      (funcall elt-fn x y))))
+
+(defmethod convert ((to-type (eql '2-relation)) (br 2-relation) &key)
+  br)
+
+(defmethod convert ((to-type (eql 'wb-2-relation)) (br wb-2-relation) &key)
+  br)
+
+(defmethod convert ((to-type (eql 'set)) (br 2-relation) &key (pair-fn #'cons))
+  (let ((result nil)
+	(pair-fn (coerce pair-fn 'function)))
+    (do-2-relation (x y br)
+      (setq result (WB-Set-Tree-With result (funcall pair-fn x y))))
+    (make-wb-set result)))
+
+(defmethod convert ((to-type (eql '2-relation)) (m map) &key from-type)
+  "If `from-type' is the symbol `map-to-sets', the range elements must all be
+sets, and the result pairs each domain element with each member of the
+corresponding range set.  Otherwise, the result pairs each domain element
+with the corresponding range element directly."
+  (if (eq from-type 'map-to-sets)
+      (map-to-sets-to-wb-2-relation m)
+    (map-to-wb-2-relation m)))
+
+(defmethod convert ((to-type (eql 'wb-2-relation)) (m map) &key from-type)
+  "If `from-type' is the symbol `map-to-sets', the range elements must all be
+sets, and the result pairs each domain element with each member of the
+corresponding range set.  Otherwise, the result pairs each domain element
+with the corresponding range element directly."
+  (if (eq from-type 'map-to-sets)
+      (map-to-sets-to-wb-2-relation m)
+    (map-to-wb-2-relation m)))
+
+(defun map-to-sets-to-wb-2-relation (m)
+  (let ((size 0)
+	((new-tree (WB-Map-Tree-Compose
+		     (wb-map-contents m)
+		     #'(lambda (s)
+			 (let ((s (wb-set-contents (convert 'wb-set s))))
+			   (incf size (WB-Set-Tree-Size s))
+			   s))))))
+    (make-wb-2-relation size new-tree nil)))
+
+(defun map-to-wb-2-relation (m)
+  (let ((new-tree (WB-Map-Tree-Compose (wb-map-contents m)
+				       #'(lambda (x) (WB-Set-Tree-With nil x)))))
+    (make-wb-2-relation (size m) new-tree nil)))
+
+(defmethod convert ((to-type (eql '2-relation)) (alist list)
+		    &key (key-fn #'car) (value-fn #'cdr))
+  (list-to-wb-2-relation alist key-fn value-fn))
+
+(defmethod convert ((to-type (eql 'wb-2-relation)) (alist list)
+		    &key (key-fn #'car) (value-fn #'cdr))
+  (list-to-wb-2-relation alist key-fn value-fn))
+
+(defun list-to-wb-2-relation (alist key-fn value-fn)
+  (let ((m0 nil)
+	(size 0)
+	(key-fn (coerce key-fn 'function))
+	(value-fn (coerce value-fn 'function)))
+    (dolist (pr alist)
+      (let ((k (funcall key-fn pr))
+	    (v (funcall value-fn pr))
+	    ((found? prev (WB-Map-Tree-Lookup m0 k))
+	     ((new (WB-Set-Tree-With prev v)))))
+	(declare (ignore found?))
+	(when (> (WB-Set-Tree-Size new) (WB-Set-Tree-Size prev))
+	  (incf size)
+	  (setq m0 (WB-Map-Tree-With m0 k new)))))
+    (make-wb-2-relation size m0 nil)))
+
+(defmethod convert ((to-type (eql 'map)) (br wb-2-relation) &key)
+  (2-relation-to-wb-map br))
+
+(defmethod convert ((to-type (eql 'wb-map)) (br wb-2-relation) &key)
+  (2-relation-to-wb-map br))
+
+(defun 2-relation-to-wb-map (br)
+  (let ((m nil))
+    (Do-WB-Map-Tree-Pairs (x s (wb-2-relation-map0 br))
+      (let ((sz (WB-Set-Tree-Size s)))
+	(unless (= 1 sz)
+	  (error "2-relation maps ~A to ~D values" x sz))
+	(setq m (WB-Map-Tree-With m x (WB-Set-Tree-Arb s)))))
+    (make-wb-map m)))
+
+(defgeneric conflicts (2-relation)
+  (:documentation
+    "Returns a 2-relation containing only those pairs of `2-relation' whose domain value
+is mapped to multiple range values."))
+
+(defmethod conflicts ((br wb-2-relation))
+  (let ((m0 nil)
+	(size 0))
+    (Do-WB-Map-Tree-Pairs (x s (wb-2-relation-map0 br))
+      (when (> (WB-Set-Tree-Size s) 1)
+	(setq m0 (WB-Map-Tree-With m0 x s))
+	(incf size (WB-Set-Tree-Size s))))
+    (make-wb-2-relation size m0 nil)))
+
+(defun print-wb-2-relation (br stream level)
+  (if (and *print-level* (>= level *print-level*))
+      (format stream "#")
+    (progn
+      (format stream "#{+ ")
+      (let ((i 0))
+	(do-2-relation (x y br)
+	  (when (> i 0)
+	    (format stream " "))
+	  (when (and *print-length* (>= i *print-length*))
+	    (format stream "...")
+	    (return))
+	  (incf i)
+	  (let ((*print-level* (and *print-level* (1- *print-level*))))
+	    (write (list x y) :stream stream)))
+	(when (> i 0)
+	  (format stream " ")))
+      (format stream "+}"))))
+
+(def-gmap-res-type :2-relation (&key filterp)
+  "Consumes two values from the mapped function; returns a 2-relation of the pairs.
+Note that `filterp', if supplied, must take two arguments."
+  `(nil (:consume 2 #'(lambda (alist x y) (cons (cons x y) alist)))
+	#'(lambda (alist) (list-to-wb-2-relation alist #'car #'cdr))
+	,filterp))
+
+(def-gmap-res-type :wb-2-relation (&key filterp)
+  "Consumes two values from the mapped function; returns a 2-relation of the pairs.
+Note that `filterp', if supplied, must take two arguments."
+  `(nil (:consume 2 #'(lambda (alist x y) (cons (cons x y) alist)))
+	#'(lambda (alist) (list-to-wb-2-relation alist #'car #'cdr))
+	,filterp))
+
+
+(define-cross-type-compare-methods relation)
+
+(defmethod compare ((a wb-2-relation) (b wb-2-relation))
+  (WB-Map-Tree-Compare (wb-2-relation-map0 a) (wb-2-relation-map0 b)
+		       #'WB-Set-Tree-Compare))
+
+(defmethod verify ((br wb-2-relation))
+  ;; Slow, but thorough.
+  (and (WB-Map-Tree-Verify (wb-2-relation-map0 br))
+       (WB-Map-Tree-Verify (wb-2-relation-map1 br))
+       (let ((size 0))
+	 (and (Do-WB-Map-Tree-Pairs (x s (wb-2-relation-map0 br) t)
+		(WB-Set-Tree-Verify s)
+		(incf size (WB-Set-Tree-Size s))
+		(or (null (wb-2-relation-map1 br))
+		    (Do-WB-Set-Tree-Members (y s)
+		      (let ((ignore s1 (WB-Map-Tree-Lookup (wb-2-relation-map1 br) y)))
+			(declare (ignore ignore))
+			(unless (WB-Set-Tree-Member? s1 x)
+			  (format *debug-io* "Map discrepancy in wb-2-relation")
+			  (return nil))))))
+	      (or (= size (wb-2-relation-size br))
+		  (progn (format *debug-io* "Size discrepancy in wb-2-relation")
+			 nil))))
+       (or (null (wb-2-relation-map1 br))
+	   (let ((size 0))
+	     (Do-WB-Map-Tree-Pairs (x s (wb-2-relation-map1 br))
+	       (declare (ignore x))
+	       (WB-Set-Tree-Verify s)
+	       (incf size (WB-Set-Tree-Size s)))
+	     (or (= size (wb-2-relation-size br))
+		 (progn (format *debug-io*  "Size discrepancy in wb-2-relation")
+			nil))))))
+
+
+(defgeneric closure (2-relation set)
+  (:documentation
+    "The transitive closure of the set over the relation.  The relation may
+also be supplied as a function returning a set."))
+
+(defmethod closure ((fn function) (s set))
+  (set-closure fn s))
+
+(defmethod closure ((r 2-relation) (s set))
+  (set-closure r s))
+
+(defun set-closure (r s)
+  ;; This could probably use a little moer work.
+  (let ((workset (set-difference
+		   (reduce #'union (image r (convert 'seq s)) :initial-value (set))
+		   s))
+	(result s))
+    (while (nonempty? workset)
+      (let ((x (arb workset)))
+	(removef workset x)
+	(adjoinf result x)
+	(unionf workset (set-difference (@ r x) result))))
+    result))
Modified: trunk/Code/testing.lisp
==============================================================================
--- trunk/Code/testing.lisp	(original)
+++ trunk/Code/testing.lisp	Sun Oct 26 05:34:03 2008
@@ -15,8 +15,20 @@
        (:constructor Make-My-Integer (Value)))
   Value)
+(def-tuple-key K0)
+(def-tuple-key K1)
+(def-tuple-key K2)
+(def-tuple-key K3)
+(def-tuple-key K4)
+(def-tuple-key K5)
+(def-tuple-key K6)
+(def-tuple-key K7)
+(def-tuple-key K8)
+(def-tuple-key K9)
+
(defun run-test-suite (n-iterations &optional random-seed)
+  (Test-Misc)
   (let ((*random-state* (make-seeded-random-state random-seed))) ; for repeatability.
     (dotimes (i n-iterations)
       (Test-Map-Operations i (Test-Set-Operations i))
@@ -25,6 +37,197 @@
       (Test-Tuple-Operations i))))
+(defun Test-Misc ()
+  "Tests some things that don't need extensive random test cases generated."
+  (macrolet ((test (form)
+	       `(unless ,form
+		  (error "Test failed: ~S" ',form))))
+    (flet ((equal? (a b)
+	     (and (equal? a b)
+		  (equal? b a)))
+	   (less-than? (a b)
+	     (and (less-than? a b)
+		  (greater-than? b a)))
+	   (unequal? (a b)
+	     (and (eq (compare a b) ':unequal)
+		  (eq (compare b a) ':unequal))))
+      (test (less-than? nil 1))
+      (test (less-than? 1 2))
+      (test (equal? 11/31 11/31))
+      (test (unequal? 3 3.0))
+      (test (less-than? 1 #\x))
+      (test (less-than? #\x #\y))
+      (test (less-than? #\z 'a))
+      (test (less-than? 'a 'b))
+      (test (less-than? 'x 'ab))
+      (test (equal? 'a 'a))
+      (test (less-than? 'reduce 'cl:find))
+      (test (less-than? '#:a '#:b))
+      (test (unequal? '#:foo '#:foo))
+      (test (less-than? 'a "A"))
+      (test (less-than? "A" "B"))
+      (test (less-than? "x" "12"))
+      (test (equal? "This is a text." "This is a text."))
+      (test (less-than? "x" #(#\x)))
+      (test (less-than? #(1) #(#\y)))
+      (test (equal? #(1 2) #(1 2)))
+      ;; Anyone hacking the guts of FSet should be sure they understand the next
+      ;; two examples.
+      (test (unequal? #(1 2) #(1.0 2)))
+      (test (less-than? #(1 2) #(1.0 3)))
+      (test (less-than? #(1) '(0)))
+      (test (less-than? '(0) '(a)))
+      (test (less-than? '(0 1) '(a)))
+      (test (unequal? '(1 2) '(1.0 2)))
+      (test (less-than? '(1 2) '(1.0 3)))
+      (test (less-than? '(x) (find-package :fset)))
+      (test (less-than? (find-package :fset) #p"/"))
+      (test (equal? #p"/foo/bar" #p"/foo/bar"))
+      (test (less-than? #p"/foo/bar" #p"/foo/baz"))
+      (test (less-than? #p"/bar" #p"/foo/bar"))
+      (test (less-than? #p"/" (set)))
+      ;; We use `eval' to force the macro to be expanded during the test.
+      (test (equal (convert 'list
+			    (eval '(set 1 ($ (set 1 2)) ($ (set 3 4)))))
+		   '(1 2 3 4)))
+      (test (equalp (convert 'list
+			     (set "foo" (find-package :fset) '(a b) 17 #p"/"
+				  nil #\x 'car #p"/foo" "bar" 'bike #(1 2) 3
+				  #(2 1) '(a . b) #\y))
+		    `(nil 3 17 #\x #\y bike car "bar" "foo" #(1 2) #(2 1)
+		      (a . b) (a b) ,(find-package :fset) #p"/" #p"/foo")))
+      (test (less-than? (set 1 2) (set 1 2 0)))
+      (test (unequal? (set 'a 3 'c) (set 'a 3.0 'c)))
+      (test (less-than? (set 'a 3 'c) (set 'a 3.0 'd)))
+      (test (less-than? (set 1) (bag 1)))
+      (test (equal (convert 'list
+			    (eval '(bag 1 ($ (bag 3 3)) (% "x" 3) 4
+				        ($ (bag (% 7 2) 8 1)))))
+		   '(1 1 3 3 4 7 7 8 "x" "x" "x")))
+      (test (equal (convert 'list (bag 1 2 1)) '(1 1 2)))
+      (test (less-than? (bag 1) (map ('x 1))))
+      (test (equal (convert 'list
+			    (eval '(map ($ (map ('x 0) ('y 3) ('z 4))) ('x 1)
+				        ($ (map ('z 7) ('w 9))))))
+		   '((w . 9) (x . 1) (y . 3) (z . 7))))
+      (test (equal (convert 'list (map ('x 1) ('y 2))) '((x . 1) (y . 2))))
+      (test (less-than? (map ('x 1)) (map ('y 1))))
+      (test (less-than? (map ('x 1)) (map ('x 2))))
+      (test (unequal? (map ('x 1) ('y 2)) (map ('x 1.0) ('y 2))))
+      (test (less-than? (map ('x 1)) (seq "x")))
+      (test (equal (convert 'list (eval '(seq 1 ($ (seq 8 'x 7)) 2 4 ($ (seq 'z 3)))))
+		   '(1 8 x 7 2 4 z 3)))
+      (test (equal (convert 'list (seq 1 'x "u")) '(1 x "u")))
+      (test (less-than? (seq "x") (seq "y")))
+      (test (unequal? (seq 'a 3 'c) (seq 'a 3.0 'c)))
+      (test (less-than? (seq 'a 3 'c) (seq 'a 3.0 'd)))
+      (test (less-than? (seq) (tuple)))
+      (test (equal (convert 'list (eval '(tuple (k0 1) ($ (tuple (k1 2) (k2 3)))
+					        (k0 2) ($ (tuple (k4 7) (k2 8))))))
+		   `((,k0 . 2) (,k1 . 2) (,k2 . 8) (,k4 . 7))))
+      (test (less-than? (tuple (k0 1)) (tuple (k0 2))))
+      (test (unequal? (tuple (k0 1.0) (k1 'c)) (tuple (k0 1) (k1 'c))))
+      (test (less-than? (tuple (k0 1.0) (k1 'c)) (tuple (k0 1) (k1 'd))))
+      (test (empty? (set)))
+      (test (empty? (map)))
+      (test (empty? (bag)))
+      (test (empty? (seq)))
+      (test (nonempty? (set 1)))
+      (test (= (size (set 1 2 1 3)) 3))
+      (test (= (size (map ('x 1) ('y 2) ('x 3))) 2))
+      (test (= (size (bag 1 2 1 3)) 4))
+      (test (= (size (seq 1 2 3)) 3))
+      (test (= (set-size (set 1 2 1 3)) 3))
+      (test (= (set-size (bag 1 2 1 3)) 3))
+      (test (let ((val val? (arb (set))))
+	      (and (null val) (not val?))))
+      (test (let ((s (set 1 4 8))
+		  ((val val? (arb s))))
+	      (and val? (contains? s val))))
+      (test (let ((val mult val? (arb (bag))))
+	      (and (null val) (null mult) (not val?))))
+      (test (let ((b (bag 1 4 8))
+		  ((val mult val? (arb b))))
+	      (and val? (contains? b val) (= mult 1))))
+      (test (let ((key val pr? (arb (map))))
+	      (and (null key) (null val) (not pr?))))
+      (test (let ((m (map ('x 0) ('y 1) ('z 3)))
+		  ((key val pr? (arb m))))
+	      (and pr? (equal? val (lookup m key)))))
+      (test (contains? (set 1 2 1) 1))
+      (test (contains? (bag 1 2 1) 2))
+      (test (domain-contains? (map ('x 0) ('y 1)) 'y))
+      (test (domain-contains? (seq 'a 'e 'g 'x) 3))
+      (test (= (multiplicity (bag 1 2 1) 1) 2))
+      (test (= (multiplicity (bag 1 2 1) 2) 1))
+      (test (let ((val val? (least (set 13 7 42))))
+	      (and (= val 7) val?)))
+      (test (let ((val val? (least (set))))
+	      (and (null val) (not val?))))
+      (test (let ((val mult val? (least (bag 4 9 13 4 7))))
+	      (and (= val 4) (= mult 2) val?)))
+      (test (let ((val mult val? (least (bag))))
+	      (and (null val) (null mult) (not val?))))
+      (test (let ((key val pr? (least (map ('x 4) ('y 7)))))
+	      (and (eq key 'x) (= val 4) pr?)))
+      (test (let ((key val pr? (least (map))))
+	      (and (null key) (null val) (not pr?))))
+      (test (let ((val val? (greatest (set 13 7 42))))
+	      (and (= val 42) val?)))
+      (test (let ((val val? (greatest (set))))
+	      (and (null val) (not val?))))
+      (test (let ((val mult val? (greatest (bag 4 9 13 4 7))))
+	      (and (= val 13) (= mult 1) val?)))
+      (test (let ((val mult val? (greatest (bag))))
+	      (and (null val) (null mult) (not val?))))
+      (test (let ((key val pr? (greatest (map ('x 4) ('y 7)))))
+	      (and (eq key 'y) (= val 7) pr?)))
+      (test (let ((key val pr? (greatest (map))))
+	      (and (null key) (null val) (not pr?))))
+      (test (eq (lookup (map ('x 'a) ('y 'b)) 'x) 'a))
+      (test (eq (lookup (seq 'a 'b 'c) 1) 'b))
+      (test (let ((s0 "x")
+		  (s1 "y")
+		  ((val canon (lookup (set s0 s1) "x"))))
+	      (and val (eq canon s0))))
+      (test (let ((s0 "x")
+		  (s1 "y")
+		  ((val canon (lookup (bag s0 s1) "x"))))
+	      (and val (eq canon s0))))
+      (test (let ((rank val? (rank (set 1 2 3 4) 2)))
+	      (and (= rank 1) val?)))
+      (test (let ((rank val? (rank (set 1 2 3 4) 3.5)))
+	      (and (= rank 3) (not val?))))
+      (test (let ((rank val? (rank (set 1 2 3 4) 5)))
+	      (and (= rank 4) (not val?))))
+      (test (let ((rank val? (rank (set) 5)))
+	      (and (= rank 0) (not val?))))
+      (test (let ((rank val? (rank (bag 1 2 3 4) 2)))
+	      (and (= rank 1) val?)))
+      (test (let ((rank val? (rank (bag 1 2 3 4) 3.5)))
+	      (and (= rank 3) (not val?))))
+      (test (let ((rank val? (rank (bag 1 2 3 4) 5)))
+	      (and (= rank 4) (not val?))))
+      (test (let ((rank val? (rank (bag) 5)))
+	      (and (= rank 0) (not val?))))
+      (test (let ((rank val? (rank (map (1 12) (2 27) (3 39) (4 46)) 2)))
+	      (and (= rank 1) val?)))
+      (test (let ((rank val? (rank (map (1 12) (2 27) (3 39) (4 46)) 3.5)))
+	      (and (= rank 3) (not val?))))
+      (test (let ((rank val? (rank (map (1 12) (2 27) (3 39) (4 46)) 5)))
+	      (and (= rank 4) (not val?))))
+      (test (let ((rank val? (rank (map) 5)))
+	      (and (= rank 0) (not val?))))
+      (test (eql (at-rank (set 4 8 2 3 6) 3) 6))
+      (test (eql (at-rank (bag 4 8 2 4 3 2 6) 3) 6))
+      (test (let ((key val (at-rank (map ('a 3) ('d 7) ('c 3) ('g 1) ('e 6)) 3)))
+	      (and (eq key 'e) (eql val 6))))
+      ;; Good start, but &&& more to do here.
+      (test (equal (reduce (lambda (x y) (cons y x)) (seq 3 7 9 13)
+			   :initial-value nil :from-end t :start 1 :end 3)
+		   '(7 9))))))
+
+
 (defun Test-Set-Operations (i)
   (declare (optimize (speed 0) (safety 3) (debug 3)))
   (let ((fs0 (empty-set))
@@ -41,7 +244,7 @@
      (error "Set size or with failed on iteration ~D, adding ~A: ~D, ~D" i r
    	 (size tmp) (length s0)))
    (unless (and (subset? fs0 tmp)
-		     (or (member? r fs0) (not (subset? tmp fs0))))
+		     (or (contains? fs0 r) (not (subset? tmp fs0))))
      (error "Set subset? failed on iteration ~D" i))
    (setq fs0 tmp)))
     (dotimes (j 100)
@@ -54,13 +257,19 @@
      (error "Set size or with failed on iteration ~D, adding ~A: ~D, ~D" i r
    	 (size tmp) (length s1)))
    (unless (and (subset? fs1 tmp)
-		     (or (member? r fs1) (not (subset? tmp fs1))))
-	  (error "Set Subset? failed on iteration ~D" i))
-	(setq fs1 tmp)))
+		     (or (contains? fs1 r) (not (subset? tmp fs1))))
+	  (error "Set subset? failed on iteration ~D" i))
+	(setq fs1 tmp)
+	(unless (eqv (disjoint? fs0 fs1)
+		     (disjoint? fs1 fs0)
+		     (not (do-set (x fs1 nil)
+			    (when (contains? fs0 x)
+			      (return t)))))
+	  (error "Set disjoint? failed on iteration ~D" i))))
     (dotimes (j 20)
       (let ((r (Make-My-Integer (random 200))))
-	(unless (eqv (member? r fs0) (member r s0 :test #'equal?))
-	  (error "Set member? failed (fs0) on iteration ~D, ~A" i r))
+	(unless (eqv (contains? fs0 r) (member r s0 :test #'equal?))
+	  (error "Set contains? failed (fs0) on iteration ~D, ~A" i r))
    (setq s0 (remove r s0 :test #'equal?))
    (let ((tmp (less fs0 r)))
      (unless (verify tmp)
@@ -70,8 +279,8 @@
      (setq fs0 tmp))))
     (dotimes (j 20)
       (let ((r (Make-My-Integer (random 200))))
-	(unless (eqv (member? r fs1) (member r s1 :test #'equal?))
-	  (error "Set member? failed (fs1) on iteration ~D" i))
+	(unless (eqv (contains? fs1 r) (member r s1 :test #'equal?))
+	  (error "Set contains? failed (fs1) on iteration ~D" i))
    (setq s1 (remove r s1 :test #'equal?))
    (let ((tmp (less fs1 r)))
      (unless (verify tmp)
@@ -86,22 +295,24 @@
    (setq tmp (less tmp nil))
    (unless (verify tmp)
      (error "Set verify failed removing NIL"))))
-    (unless (member? (arb fs0) fs0)
-      (error "Set arb/member? failed (fs0) on iteration ~D" i))
-    (unless (member? (arb fs1) fs1)
-      (error "Set arb/member? failed (fs1) on iteration ~D" i))
+    (unless (contains? fs0 (arb fs0))
+      (error "Set arb/contains? failed (fs0) on iteration ~D" i))
+    (unless (contains? fs1 (arb fs1))
+      (error "Set arb/contains? failed (fs1) on iteration ~D" i))
     (unless (member (compare (least fs0)
-			     (reduce #'(lambda (mi1 mi2)
-					 (if (< (my-integer-value mi1)
-						(my-integer-value mi2))
-					     mi1 mi2)) s0))
+			     (reduce (lambda (mi1 mi2)
+				       (if (< (my-integer-value mi1)
+					      (my-integer-value mi2))
+					   mi1 mi2))
+				     s0))
    	    '(:equal :unequal))
       (error "Set least failed on iteration ~D" i))
     (unless (member (compare (greatest fs0)
-			     (reduce #'(lambda (mi1 mi2)
-					 (if (> (my-integer-value mi1)
-						(my-integer-value mi2))
-					     mi1 mi2)) s0))
+			     (reduce (lambda (mi1 mi2)
+				       (if (> (my-integer-value mi1)
+					      (my-integer-value mi2))
+					   mi1 mi2))
+				     s0))
    	    '(:equal :unequal))
       (error "Set greatest failed on iteration ~D" i))
     (unless (equal? fs0 (convert 'set s0))
@@ -141,6 +352,21 @@
       (unless (eq (compare fs1a fs1b)
    	  (Set-Compare (convert 'list fs1a) (convert 'list fs1b)))
    (error "Set compare failed (fs1) on iteration ~D" i)))
+    (unless (gmap :and (lambda (x i)
+			 (and (eql (rank fs0 x) i)
+			      (equal? x (at-rank fs0 i))))
+		  (:set fs0)
+		  (:index 0 (size fs0)))
+      (error "Set rank, at-rank, or iterator failed"))
+    (let ((r (do ((r (random 200) (random 200)))
+		 ((not (contains? fs0 r)) r))))
+      (unless (= (rank fs0 r)
+		 (if (greater-than? r (greatest fs0))
+		     (size fs0)
+		   (do ((r2 r (1+ r2)))
+		       ((contains? fs0 r2)
+			(rank fs0 r2)))))
+	(error "Set at-rank of non-member failed")))
     fs0))
@@ -197,6 +423,26 @@
      (unless (= (size tmp) (length m1))
        (error "Map size or less failed (fm1) on iteration ~D, removing ~A" i r))
      (setq fm1 tmp))))
+    (unless (domain-contains? fm0 (arb fm0))
+      (error "Map arb/contains? failed (fm0) on iteration ~D" i))
+    (unless (domain-contains? fm1 (arb fm1))
+      (error "Map arb/contains? failed (fm1) on iteration ~D" i))
+    (unless (member (compare (least fm0)
+			     (reduce (lambda (mi1 mi2)
+				       (if (< (my-integer-value mi1)
+					      (my-integer-value mi2))
+					   mi1 mi2))
+				     (mapcar #'car m0)))
+		    '(:equal :unequal))
+      (error "Map least failed on iteration ~D" i))
+    (unless (member (compare (greatest fm0)
+			     (reduce (lambda (mi1 mi2)
+				       (if (> (my-integer-value mi1)
+					      (my-integer-value mi2))
+					   mi1 mi2))
+				     (mapcar #'car m0)))
+		    '(:equal :unequal))
+      (error "Map greatest failed on iteration ~D" i))
     (unless (equal? fm0 (convert 'map m0))
       (error "Map equal? failed (fm0) on iteration ~D" i))
     (unless (equal? fm1 (convert 'map m1))
@@ -228,7 +474,11 @@
    (setq mu (Alist-Assign mu (car pr) (cdr pr))))
       (unless (and (verify fmu)
    	   (equal? fmu (convert 'map mu)))
-	(error "Map union failed on iteration ~D: ~A, ~A, ~A, ~A" i mu fmu fm0 fm1)))
+	(error "Map union failed on iteration ~D: ~A, ~A, ~A, ~A" i mu fmu fm0 fm1))
+      (let ((fmd1 fmd2 (map-difference-2 fmu fm1)))
+	(unless (and (equal? fmu (map-union (restrict fm1 (domain fmu)) fmd1))
+		     (equal? fm1 (map-union (restrict fmu (domain fm1)) fmd2)))
+	  (error "Map difference failed on iteration ~D" i))))
     (let ((fmi (map-intersection fm0 fm1))
      (mi nil))
       (dolist (pr m1)
@@ -239,15 +489,32 @@
    (error "Map intersection failed on iteration ~D: ~A, ~A, ~A, ~A"
           i mi fmi fm0 fm1)))
     (let ((fmr (restrict fm0 a-set))
-	  (mr (remove-if-not #'(lambda (pr) (member? (car pr) a-set)) m0)))
+	  (mr (remove-if-not #'(lambda (pr) (contains? a-set (car pr))) m0)))
       (unless (and (verify fmr)
    	   (equal? fmr (convert 'map mr)))
    (error "Map restrict failed on iteration ~D: ~A, ~A" i fmr mr)))
     (let ((fmr (restrict-not fm0 a-set))
-	  (mr (remove-if #'(lambda (pr) (member? (car pr) a-set)) m0)))
+	  (mr (remove-if #'(lambda (pr) (contains? a-set (car pr))) m0)))
       (unless (and (verify fmr)
    	   (equal? fmr (convert 'map mr)))
-	(error "Map restrict-not failed on iteration ~D: ~A, ~A, ~A" i fmr mr fm0)))))
+	(error "Map restrict-not failed on iteration ~D: ~A, ~A, ~A" i fmr mr fm0)))
+    (unless (gmap :and (lambda (x y i)
+			 (and (eql (rank fm0 x) i)
+			      (let ((rx ry (at-rank fm0 i)))
+				(and (equal? x rx)
+				     (= y ry)))))
+		  (:map fm0)
+		  (:index 0 (size fm0)))
+      (error "Map rank, at-rank, or iterator failed"))
+    (let ((r (do ((r (random 200) (random 200)))
+		 ((not (domain-contains? fm0 r)) r))))
+      (unless (= (rank fm0 r)
+		 (if (greater-than? r (greatest fm0))
+		     (size fm0)
+		   (do ((r2 r (1+ r2)))
+		       ((contains? fm0 r2)
+			(rank fm0 r2)))))
+	(error "Map at-rank of non-member failed")))))
(defun Test-Bag-Operations (i)
@@ -265,6 +532,8 @@
    (unless (= (size tmp) (Alist-Bag-Size b0))
      (error "Bag size or with failed (fb0) on iteration ~D, adding ~A: ~D, ~D" i r
    	 (size tmp) (Alist-Bag-Size b0)))
+	(unless (= (set-size tmp) (length b0))
+	  (error "Bag set-size failed (fb0) on iteration ~D" i))
    (unless (and (subbag? fb0 tmp) (not (subbag? tmp fb0)))
      (error "Bag subbag? failed (fb0) on iteration ~D" i))
    (setq fb0 tmp)))
@@ -277,13 +546,15 @@
    (unless (= (size tmp) (Alist-Bag-Size b1))
      (error "Bag size or with failed (fb1) on iteration ~D, adding ~A: ~D, ~D" i r
    	 (size tmp) (Alist-Bag-Size b1)))
+	(unless (= (set-size tmp) (length b1))
+	  (error "Bag set-size failed (fb1) on iteration ~D" i))
    (unless (and (subbag? fb1 tmp) (not (subbag? tmp fb1)))
      (error "Bag Subbag? failed (fb1) on iteration ~D" i))
    (setq fb1 tmp)))
     (dotimes (j 20)
       (let ((r (Make-My-Integer (random 200))))
-	(unless (eqv (member? r fb0) (assoc r b0 :test #'equal?))
-	  (error "Bag member? failed (fb0) on iteration ~D, ~A" i r))
+	(unless (eqv (contains? fb0 r) (assoc r b0 :test #'equal?))
+	  (error "Bag contains? failed (fb0) on iteration ~D, ~A" i r))
    (setq b0 (Alist-Bag-Remove b0 r))
    (let ((tmp (less fb0 r)))
      (unless (verify tmp)
@@ -293,8 +564,8 @@
      (setq fb0 tmp))))
     (dotimes (j 20)
       (let ((r (Make-My-Integer (random 200))))
-	(unless (eqv (member? r fb1) (assoc r b1 :test #'equal?))
-	  (error "Bag member? failed (fb1) on iteration ~D" i))
+	(unless (eqv (contains? fb1 r) (assoc r b1 :test #'equal?))
+	  (error "Bag contains? failed (fb1) on iteration ~D" i))
    (setq b1 (Alist-Bag-Remove b1 r))
    (let ((tmp (less fb1 r)))
      (unless (verify tmp)
@@ -309,6 +580,26 @@
    (setq tmp (less tmp nil))
    (unless (verify tmp)
      (error "Bag verify failed removing NIL"))))
+    (unless (contains? fb0 (arb fb0))
+      (error "Bag arb/contains? failed (fb0) on iteration ~D" i))
+    (unless (contains? fb1 (arb fb1))
+      (error "Bag arb/contains? failed (fb1) on iteration ~D" i))
+    (unless (member (compare (least fb0)
+			     (reduce (lambda (mi1 mi2)
+				       (if (< (my-integer-value mi1)
+					      (my-integer-value mi2))
+					   mi1 mi2))
+				     (mapcar #'car b0)))
+		    '(:equal :unequal))
+      (error "Bag least failed on iteration ~D" i))
+    (unless (member (compare (greatest fb0)
+			     (reduce (lambda (mi1 mi2)
+				       (if (> (my-integer-value mi1)
+					      (my-integer-value mi2))
+					   mi1 mi2))
+				     (mapcar #'car b0)))
+		    '(:equal :unequal))
+      (error "Bag greatest failed on iteration ~D" i))
     (unless (equal? fb0 (convert 'bag b0 :from-type 'alist))
       (error "Bag equal? failed (fb0) on iteration ~D" i))
     (unless (equal? fb1 (convert 'bag b1 :from-type 'alist))
@@ -352,6 +643,23 @@
       (unless (eq (compare fb1a fb1b)
    	  (Map-Compare (convert 'alist fb1a) (convert 'alist fb1b)))
    (error "Compare failed (fb1) on iteration ~D" i)))
+    (unless (gmap :and (lambda (x n i)
+			 (and (eql (rank fb0 x) i)
+			      (let ((rx rn (at-rank fb0 i)))
+				(and (equal? x rx)
+				     (= n rn)))))
+		  (:bag-pairs fb0)
+		  (:index 0 (size fb0)))
+      (error "Bag rank, at-rank, or iterator failed"))
+    (let ((r (do ((r (random 200) (random 200)))
+		 ((not (contains? fb0 r)) r))))
+      (unless (= (rank fb0 r)
+		 (if (greater-than? r (greatest fb0))
+		     (set-size fb0)
+		   (do ((r2 r (1+ r2)))
+		       ((contains? fb0 r2)
+			(rank fb0 r2)))))
+	(error "Bag at-rank of non-member failed")))
     fb0))
@@ -373,9 +681,6 @@
        (pos (if (null s0) 0 (random (length s0))))
        (which (random 6))
        (tmp nil))
-	(unless (eql (position r s0 :test #'equal?)
-		     (Seq-Position r fs0))
-	  (error "Seq-position failed on iteration ~D" i))
    (cond ((and (= which 0) s0)
           (when (= pos (length s0))
    	 (decf pos))
@@ -419,6 +724,7 @@
      (error "Seq verify (fs1) failed on iteration ~D (~A ~D ~D)"
    	 i (case which (0 "update") (1 "delete") (t "insert")) pos r))
    (setq fs1 tmp)))
+    (Test-CL-Generic-Sequence-Ops i fs0 s0 fs1 s1)
     (unless (equal? (convert 'list fs0) s0)
       (error "Seq equality failed (fs0, A), on iteration ~D" i))
     (unless (equal? fs0 (convert 'seq s0))
@@ -457,19 +763,29 @@
    	    (Seq-Compare (convert 'list fs0a) (convert 'list fs0b)))
      (error "Seq compare failed on iteration ~D" i))))))
+(defun Test-CL-Generic-Sequence-Ops (i fs0 s0 fs1 s1)
+  (declare (ignore fs0 s0))		; for now
+  (dotimes (j 20)
+    (let ((r (Make-My-Integer (random 200)))
+	  (s (random (size fs1)))
+	  ((e (+ s (random (- (size fs1) s))))))
+      ;; The use of `eql' checks that we find the correct instance.
+      (unless (and (eql (find r s1 :start s :end e :test #'equal? :from-end t)
+			(find r fs1 :start s :end e :from-end t))
+		   (eql (find (My-Integer-Value r) s1
+			      :start s :end e :key #'My-Integer-Value)
+			(find (My-Integer-Value r) fs1
+			      :start s :end e :key #'My-Integer-Value))
+		   (eql (find r s1 :start s :end e :test #'less-than?)
+			(find r fs1 :start s :end e :test #'less-than?))
+		   (eql (find (My-Integer-Value r) s1
+			      :start s :end e :key #'My-Integer-Value :test #'>)
+			(find (My-Integer-Value r) fs1
+			      :start s :end e :key #'My-Integer-Value :test #'>)))
+	(error "Find failed on iteration ~D" i)))))
-(def-tuple-key K0)
-(def-tuple-key K1)
-(def-tuple-key K2)
-(def-tuple-key K3)
-(def-tuple-key K4)
-(def-tuple-key K5)
-(def-tuple-key K6)
-(def-tuple-key K7)
-(def-tuple-key K8)
-(def-tuple-key K9)
-(defvar Tuple-Keys (vector K0 K1 K2 K3 K4 K5 K6 K7 K8 K9))
+(deflex Tuple-Keys (vector K0 K1 K2 K3 K4 K5 K6 K7 K8 K9))
(defun Test-Tuple-Operations (i)
   (let ((tup (tuple))
@@ -548,9 +864,9 @@
    			       (let ((pr2 (assoc (car pr1) g2)))
    				 (and pr2 (= (cdr pr1) (cdr pr2)))))
    			   g1)
-		      (let ((vals1 (reduce #'with1 (mapcar #'cdr g1)
+		      (let ((vals1 (reduce #'with (mapcar #'cdr g1)
    				   :initial-value (empty-set)))
-			    (vals2 (reduce #'with1 (mapcar #'cdr g2)
+			    (vals2 (reduce #'with (mapcar #'cdr g2)
    				   :initial-value (empty-set)))
    		    ((comp (compare vals1 vals2))))
    		(if (eq comp ':equal)
@@ -662,7 +978,7 @@
   (if (empty? fs)
       (error "`Pick' on empty set")
     (do ((r (Make-My-Integer (random 200)) (Make-My-Integer (random 200))))
-	((member? r fs)
+	((contains? fs r)
     r))))
@@ -713,6 +1029,9 @@
       (set-difference s0 s1))))
+;;; Internal.
+(defgeneric verify (coll))
+
 (defmethod verify ((s wb-set))
   (WB-Set-Tree-Verify (wb-set-contents s)))
@@ -726,7 +1045,9 @@
   (WB-Seq-Tree-Verify (wb-seq-contents s)))
-(defun eqv (a b) (or (eq a b) (and a b)))
+(defun eqv (a b &rest more)
+  (and (or (eq a b) (and a b))
+       (gmap :and #'eqv (:constant a) (:list more))))
(defun Time-Seq-Iter (seq n)
Modified: trunk/Code/tuples.lisp
==============================================================================
--- trunk/Code/tuples.lisp	(original)
+++ trunk/Code/tuples.lisp	Sun Oct 26 05:34:03 2008
@@ -291,6 +291,8 @@
   (declare (fixnum idx))
   (let ((desc (dyn-tuple-descriptor tuple))
    ((pairs (Tuple-Desc-Pairs desc))))
+    ;; Some implementations can't do `:wait? nil', but that's okay -- we'll just
+    ;; do a little redundant work.
     (with-lock ((Tuple-Desc-Lock desc) :wait? nil)
       (let ((nkeys*2 (length pairs))
        ((window-size (Tuple-Window-Size nkeys*2))))
@@ -345,7 +347,9 @@
    	(let ((nd (lookup (Tuple-Desc-Next-Desc-Map old-desc) key)))
    	  (if nd (values nd (Tuple-Desc-Key-Set nd))
    	    (let ((nks (with (Tuple-Desc-Key-Set old-desc) key))
-			  ((nd (lookup *Tuple-Descriptor-Map* nks))))
+			  ((nd (progn
+				 (read-memory-barrier)
+				 (lookup *Tuple-Descriptor-Map* nks)))))
    	      (when nd
    		(setf (lookup (Tuple-Desc-Next-Desc-Map old-desc) key) nd))
    	      (values nd nks)))))
@@ -376,7 +380,13 @@
    	      (dotimes (i (- nkeys window-size 1))
    		(add-pair (+ i window-size 1)
    			  (svref old-pairs (+ i window-size)))))))))
-	    (setf (lookup *Tuple-Descriptor-Map* new-key-set) new-desc)
+	    ;(setf (lookup *Tuple-Descriptor-Map* new-key-set) new-desc)
+	    ;; Technically, we need a memory barrier to make sure the new map value
+	    ;; is fully constructed before being made available to other threads.
+	    (setq *Tuple-Descriptor-Map*
+		  (prog1
+		      (with *Tuple-Descriptor-Map* new-key-set new-desc)
+		    (write-memory-barrier)))
        (setf (lookup (Tuple-Desc-Next-Desc-Map old-desc) key) new-desc))
      (let ((reorder-map (Tuple-Get-Reorder-Map old-desc new-desc))
    	(old-chunks (dyn-tuple-contents tuple))
@@ -421,10 +431,12 @@
    (dotimes (i (length chunk))
      (let ((new-idx (+ (* ichunk Tuple-Value-Chunk-Size) i))
    	((new-pr (cl:find new-idx new-pairs
-				  :key #'(lambda (pr) (ash pr (- Tuple-Key-Number-Size)))))
+				  :key #'(lambda (pr)
+					   (ash pr (- Tuple-Key-Number-Size)))))
    	 ((old-pr (cl:find (logand new-pr Tuple-Key-Number-Mask)
    			   old-pairs
-				   :key #'(lambda (pr) (logand pr Tuple-Key-Number-Mask))))
+				   :key #'(lambda (pr)
+					    (logand pr Tuple-Key-Number-Mask))))
    	  ((old-idx (and old-pr (ash old-pr (- Tuple-Key-Number-Size))))))))
        (unless (eql old-idx new-idx)
          (setq changed? t))
@@ -497,19 +509,25 @@
   (format stream ">"))
(defmethod compare ((tup1 tuple) (tup2 tuple))
-  (let ((key-vec-1 (svref (dyn-tuple-contents tup1) 0))
-	(key-vec-2 (svref (dyn-tuple-contents tup2) 0))
-	((res (compare (svref key-vec-1 3) (svref key-vec-2 3)))))
+  (let ((key-set-1 (tuple-desc-key-set (dyn-tuple-descriptor tup1)))
+	(key-set-2 (tuple-desc-key-set (dyn-tuple-descriptor tup2)))
+	((res (compare key-set-1 key-set-2)))
+	(default ':equal))
     (if (not (eq res ':equal))
    res
-      (do-set (key (svref key-vec-1 3) ':equal)
-	(let ((res (compare (Tuple-Lookup tup1 key t)
-			    (Tuple-Lookup tup2 key t))))
-	  (unless (eq res ':equal)
-	    (return res)))))))
+      (do-set (key key-set-1 default)
+	(let ((val1? val1 (Tuple-Lookup tup1 key t))
+	      (val2? val2 (Tuple-Lookup tup2 key t))
+	      ((res (compare val1 val2))))
+	  (declare (ignore val1? val2?))
+	  (when (or (eq res ':less) (eq res ':greater))
+	    (return res))
+	  (when (eq res ':unequal)
+	    (setq default ':unequal)))))))
-(defmethod with2 ((tuple tuple) (key tuple-key) value)
+(defmethod with ((tuple tuple) (key tuple-key) &optional (value nil value?))
+  (check-three-arguments value? 'with 'tuple)
   (Tuple-With tuple key value))
(defmethod lookup ((tuple tuple) (key tuple-key))
@@ -522,20 +540,20 @@
   (:documentation "Returns a new tuple containing all the keys of `tuple1' and `tuple2',
 where the value for each key contained in only one tuple is the value from
 that tuple, and the value for each key contained in both tuples is the result
-of calling `val-fn' on the key, the value from `tuple1', and the value from
-`tuple2'.  `val-fn' defaults to simply returning its third argument, so
-the entries in `tuple2' simply shadow those in `tuple1'."))
+of calling `val-fn' on the value from `tuple1' and the value from `tuple2'.
+`val-fn' defaults to simply returning its third argument, so the entries in
+`tuple2' simply shadow those in `tuple1'."))
(defmethod tuple-merge ((tup1 tuple) (tup2 tuple)
-			&optional (val-fn #'(lambda (k v1 v2)
-					      (declare (ignore k v1))
+			&optional (val-fn #'(lambda (v1 v2)
+					      (declare (ignore v1))
    				      v2)))
   ;;; Someday: better implementation.
   (let ((result tup1)
    (val-fn (coerce val-fn 'function)))
     (do-tuple (k v2 tup2)
       (let ((v1? v1 (Tuple-Lookup tup1 k)))
-	(setq result (with result k (if v1? (funcall val-fn k v1 v2) v2)))))
+	(setq result (with result k (if v1? (funcall val-fn v1 v2) v2)))))
     result))
(defmethod convert ((to-type (eql 'map)) (tup tuple) &key)
@@ -544,3 +562,10 @@
       (setq m (with m k v)))
     m))
+(defmethod convert ((to-type (eql 'list)) (tup tuple) &key (pair-fn #'cons))
+  (let ((result nil)
+	(pair-fn (coerce pair-fn 'function)))
+    (do-tuple (k v tup)
+      (push (funcall pair-fn k v) result))
+    (nreverse result)))
+
Modified: trunk/Code/wb-trees.lisp
==============================================================================
--- trunk/Code/wb-trees.lisp	(original)
+++ trunk/Code/wb-trees.lisp	Sun Oct 26 05:34:03 2008
@@ -121,17 +121,12 @@
     1))
-;;; &&& This seems to be the only way to get Python to accept this type.
-;;; `(declare (values fixnum))' didn't do it.
 (declaim (ftype (function (WB-Set-Tree) fixnum) WB-Set-Tree-Size))
(defun WB-Set-Tree-Size (tree)
   "The number of members contained in this tree."
   (declare (optimize (speed 3) (safety 0))
       (type WB-Set-Tree tree))
-  ;; &&& Python bug (in 18d, anyway): Python can't convince itself that the result
-  ;; can't be null.  Seems to be some problem with the conditional, but rewriting with
-  ;; `if' didn't fix it.  (Bug still exists in 19a.)
   (cond ((null tree) 0)
    ((simple-vector-p tree) (length tree))
    (t (WB-Set-Tree-Node-Size tree))))
@@ -229,6 +224,27 @@
         ((:greater)
          (WB-Set-Tree-Member? (WB-Set-Tree-Node-Right tree) value)))))))
+(defun WB-Set-Tree-Member?-Cfn (tree value cfn)
+  "Returns true iff `value' is a member of `tree'."
+  (declare (optimize (speed 3) (safety 0))
+	   (type WB-Set-Tree tree)
+	   (type function cfn))
+  (cond ((null tree) nil)
+	((simple-vector-p tree)
+	 (eq (Vector-Set-Binary-Search-Cfn tree value cfn) ':equal))
+	(t
+	 (let ((node-val (WB-Set-Tree-Node-Value tree))
+	       ((comp (funcall cfn value node-val))))
+	   (ecase comp
+	     (:equal t)
+	     ((:unequal)
+	      (and (Equivalent-Set? node-val)
+		   (member value (Equivalent-Set-Members node-val) :test #'equal?)))
+	     ((:less)
+	      (WB-Set-Tree-Member? (WB-Set-Tree-Node-Left tree) value))
+	     ((:greater)
+	      (WB-Set-Tree-Member? (WB-Set-Tree-Node-Right tree) value)))))))
+
 (defun WB-Set-Tree-Find-Equivalent (tree value)
   "If `tree' contains one or more values equivalent to `value', returns (first
 value) true and (second value) either the one value or an `Equivalent-Set'
@@ -278,6 +294,30 @@
         ((:greater)
          (WB-Set-Tree-Find-Equal (WB-Set-Tree-Node-Right tree) value)))))))
+(defun WB-Set-Tree-Find-Rank (tree value)
+  "Returns the rank at which `value' appears in `tree', if it does, else the rank
+it would occupy if it were present.  The second value is true iff the value was
+found.  Note that if the set contains equivalent-but-unequal elements, they all
+appear at the same rank."
+  (cond ((null tree) 0)
+	((simple-vector-p tree)
+	 (let ((found? idx (Vector-Set-Binary-Search tree value)))
+	   (values idx found?)))
+	(t
+	 (let ((node-val (WB-Set-Tree-Node-Value tree))
+	       ((comp (compare value node-val)))
+	       (left (WB-Set-Tree-Node-Left tree)))
+	   (ecase comp
+	     ((:equal :unequal)
+	      (WB-Set-Tree-Size left))
+	     ((:less)
+	      (WB-Set-Tree-Find-Rank left value))
+	     ((:greater)
+	      (let ((right-rank found?
+		      (WB-Set-Tree-Find-Rank (WB-Set-Tree-Node-Right tree) value)))
+		(values (+ (WB-Set-Tree-Size left) right-rank)
+			found?))))))))
+
;;; ================================================================================
 ;;; With
@@ -496,10 +536,8 @@
 (defun WB-Set-Tree-Intersect (tree1 tree2)
   "Returns the intersection of `tree1' and `tree2'.  Runs in time linear in
 the total sizes of the two trees."
-  (if (eq tree1 tree2)
-      tree1
-    (WB-Set-Tree-Intersect-Rng tree1 tree2
-			       Hedge-Negative-Infinity Hedge-Positive-Infinity)))
+  (WB-Set-Tree-Intersect-Rng tree1 tree2
+			     Hedge-Negative-Infinity Hedge-Positive-Infinity))
(defun WB-Set-Tree-Intersect-Rng (tree1 tree2 lo hi)
   "Returns the intersection of `tree1' with `tree2', considering only those
@@ -536,9 +574,8 @@
 (defun WB-Set-Tree-Diff (tree1 tree2)
   "Returns the set difference of `tree1' less `tree2'.  Runs in time linear in
 the total sizes of the two trees."
-  (and (not (eq tree1 tree2))
-       (WB-Set-Tree-Diff-Rng tree1 tree2
-			     Hedge-Negative-Infinity Hedge-Positive-Infinity)))
+  (WB-Set-Tree-Diff-Rng tree1 tree2
+			Hedge-Negative-Infinity Hedge-Positive-Infinity))
(defun WB-Set-Tree-Diff-Rng (tree1 tree2 lo hi)
   "Returns the set difference of `tree1' less `tree2', considering only those
@@ -590,10 +627,8 @@
 (defun WB-Set-Tree-Diff-2 (tree1 tree2)
   "Returns two values: the set difference of `tree1' less `tree2', and that of
 `tree2' less `tree1'.  Runs in time linear in the total sizes of the two trees."
-  (if (eq tree1 tree2)
-      (values nil nil)
-    (WB-Set-Tree-Diff-2-Rng tree1 tree2
-			    Hedge-Negative-Infinity Hedge-Positive-Infinity)))
+  (WB-Set-Tree-Diff-2-Rng tree1 tree2
+			  Hedge-Negative-Infinity Hedge-Positive-Infinity))
(defun WB-Set-Tree-Diff-2-Rng (tree1 tree2 lo hi)
   "Returns two values: the set difference of `tree1' less `tree2', and that of
@@ -602,7 +637,7 @@
 this range."
   (declare (optimize (speed 3) (safety 0))
       (type WB-Set-Tree tree1 tree2))
-  (cond ((eq tree1 tree2) (values nil nil)) ; historically-related-set optimization
+  (cond ((eq tree1 tree2) (values nil nil)) ; historically-related tree optimization
    ((or (null tree1) (null tree2))
     (values (WB-Set-Tree-Split tree1 lo hi)
    	 (WB-Set-Tree-Split tree2 lo hi)))
@@ -710,7 +745,8 @@
       (if (or (eq left-comp ':less) (eq left-comp ':greater))
           left-comp
         (let ((val1 (WB-Set-Tree-Node-Value tree1))
-		   (val2 (WB-Set-Tree-Rank-Element tree2 (the fixnum (- new-hi base2))))
+		   (val2 (WB-Set-Tree-Rank-Element-Internal
+			   tree2 (the fixnum (- new-hi base2))))
    	   ((val-comp (Equivalent-Set-Compare val1 val2))))
           (if (or (eq val-comp ':less) (eq val-comp ':greater))
    	   val-comp
@@ -745,25 +781,68 @@
    			  (Set-Value-Size (WB-Set-Tree-Node-Value tree)))
    		       lo hi)))))
+(defun WB-Set-Tree-Rank (tree value)
+  "Searches a set tree `tree' for `value'.  Returns two values, a boolean and an
+index.  If `value', or a value equivalent to `value', is in `tree', the boolean
+is true, and the index is the rank of the value; otherwise, the boolean is false
+and the index is the rank `value' would have if it were to be added.  Note that
+if the set contains equivalent-but-unequal elements, the rank of each of several
+such elements is guaranteed consistent only within the same tree (by `eq'), not
+between equal trees."
+  (labels ((rec (tree value base)
+	     (cond ((null tree) (values nil base))
+		   ((simple-vector-p tree)
+		    (let ((found? idx (Vector-Set-Binary-Search tree value)))
+		      (values found? (+ idx base))))
+		   (t
+		    (let ((node-val (WB-Set-Tree-Node-Value tree))
+			  (left (WB-Set-Tree-Node-Left tree))
+			  ((left-size (WB-Set-Tree-Size left))
+			   ((node-base (+ base left-size))))
+			  ((comp (compare value node-val))))
+		      (ecase comp
+			(:equal (values t node-base))
+			((:unequal)
+			 (if (Equivalent-Set? node-val)
+			     (let ((mems (Equivalent-Set-Members node-val))
+				   ((pos (cl:position value mems :test #'equal?))))
+			       (if pos (values t (+ node-base pos))
+				 (values nil node-base)))
+			   (values nil node-base)))
+			((:less)
+			 (rec left value base))
+			((:greater)
+			 (rec (WB-Set-Tree-Node-Right tree) value
+			      (+ node-base (Set-Value-Size node-val))))))))))
+    (rec tree value 0)))
+
 (defun WB-Set-Tree-Rank-Element (tree rank)
+  (let ((elt rem (WB-Set-Tree-Rank-Element-Internal tree rank)))
+    (if (Equivalent-Set? elt)
+	(nth rem (Equivalent-Set-Members elt))
+      elt)))
+
+(defun WB-Set-Tree-Rank-Element-Internal (tree rank)
   (declare (optimize (speed 3) (safety 0))
       (type WB-Set-Tree tree)
       (type fixnum rank))
   (cond ((null tree)
     (error "Bug in set comparator"))
    ((simple-vector-p tree)
-	 (aref tree rank))
+	 (values (svref tree rank) 0))
    (t
     (let ((left (WB-Set-Tree-Node-Left tree))
           ((left-size (WB-Set-Tree-Size left))))
       (if (< rank left-size)
-	       (WB-Set-Tree-Rank-Element left rank)
+	       (WB-Set-Tree-Rank-Element-Internal left rank)
         (let ((val (WB-Set-Tree-Node-Value tree))
-		   ((val-size (Set-Value-Size val))))
-	       (if (= rank left-size)
-		   val
-		 (WB-Set-Tree-Rank-Element (WB-Set-Tree-Node-Right tree)
-					   (- rank left-size val-size)))))))))
+		   ((val-size (Set-Value-Size val))
+		    (rank (- rank left-size))))
+	       (declare (type fixnum rank))
+	       (if (< rank val-size)
+		   (values val rank)
+		 (WB-Set-Tree-Rank-Element-Internal (WB-Set-Tree-Node-Right tree)
+						    (- rank val-size)))))))))
;;; ================================================================================
@@ -809,6 +888,34 @@
;;; ================================================================================
+;;; Disjointness testing
+
+(defun WB-Set-Tree-Disjoint? (tree1 tree2)
+  (WB-Set-Tree-Disjoint?-Rng tree1 tree2
+			     Hedge-Negative-Infinity Hedge-Positive-Infinity))
+
+(defun WB-Set-Tree-Disjoint?-Rng (tree1 tree2 lo hi)
+  (cond ((or (null tree1) (null tree2))
+	 t)
+	((eq tree1 tree2)
+	 nil)
+	((and (simple-vector-p tree1) (simple-vector-p tree2))
+	 (Vector-Set-Disjoint? tree1 tree2 lo hi))
+	((simple-vector-p tree1)
+	 (WB-Set-Tree-Disjoint?-Rng (WB-Set-Tree-Trim tree2 lo hi)
+				    tree1 lo hi))
+	(t
+	 (let ((val1 (WB-Set-Tree-Node-Value tree1))
+	       ((eqvv2? eqvv2 (WB-Set-Tree-Find-Equivalent tree2 val1))))
+	   (and (or (null eqvv2?) (Equivalent-Set-Disjoint? val1 eqvv2))
+		(WB-Set-Tree-Disjoint?-Rng (WB-Set-Tree-Node-Left tree1)
+					   (WB-Set-Tree-Trim tree2 lo val1)
+					   lo val1)
+		(WB-Set-Tree-Disjoint?-Rng (WB-Set-Tree-Node-Right tree1)
+					   (WB-Set-Tree-Trim tree2 val1 hi)
+					   val1 hi))))))
+
+;;; ================================================================================
 ;;; Miscellany
(defun WB-Set-Tree-From-List (lst)
@@ -822,6 +929,15 @@
    					(- n n2))))))))
     (recur lst (length lst))))
+(defun WB-Set-Tree-From-CL-Sequence (seq)
+  (labels ((recur (n m)
+	     (cond ((= n m) nil)
+		   ((= n (1- m)) (vector (elt seq n)))
+		   (t
+		    (let ((n2 (floor (+ n m) 2)))
+		      (WB-Set-Tree-Union (recur n n2) (recur n2 m)))))))
+    (recur 0 (length seq))))
+
;;; ================================================================================
 ;;; Support routines for the above (sets)
@@ -849,6 +965,30 @@
    (:less             (setq hi (1- mid)))
    (:greater          (setq lo (1+ mid)))))))
+(defun Vector-Set-Binary-Search-Cfn (vec value cfn)
+  "Searches a vector set `vec' for `value'.  Returns two values, a symbol and an
+index.  If `value', or a value equivalent to `value', is in `vec', the symbol
+is `:equal' resp. `:unequal', and the index is the position of the value;
+otherwise, the symbol is `nil' and the index is where `value' would go if it
+were to be inserted."
+  (declare (optimize (speed 3) (safety 0))
+	   (type simple-vector vec)
+	   #+(or cmu scl)
+	   (values t fixnum)
+	   (type function cfn))
+  (do ((lo 0)
+       (hi (1- (length vec))))
+      ((> lo hi)
+       (values nil lo))
+    (declare (type fixnum lo hi))
+    (let ((mid (ash (the fixnum (+ lo hi)) -1))
+	  ((vec-val (svref vec mid))
+	   ((comp (funcall cfn value vec-val)))))
+      (ecase comp
+	((:equal :unequal) (return (values comp mid)))
+	(:less             (setq hi (1- mid)))
+	(:greater          (setq lo (1+ mid)))))))
+
 (defun Vector-Set-Binary-Search-Lo (vec lo)
   "Returns the index of the left edge of the first member of `vec' that is
 above `lo'."
@@ -977,7 +1117,7 @@
   (declare (optimize (speed 3) (safety 0))
       (type WB-Set-Tree tree))
   (if (simple-vector-p tree)
-      (aref tree 0)
+      (svref tree 0)
     (let ((left (WB-Set-Tree-Node-Left tree)))
       (if left
      (WB-Set-Tree-Minimum-Value left)
@@ -1005,7 +1145,8 @@
   (cond ((and (or (null left) (simple-vector-p left))
          (or (null right) (simple-vector-p right)))
     (if (and (not (Equivalent-Set? value))
-		  (< (+ (length left) (length right)) *WB-Tree-Max-Vector-Length*))
+		  (< (+ (length-nv left) (length-nv right))
+		     *WB-Tree-Max-Vector-Length*))
         (concatenate 'simple-vector left (vector value) right)
       (Make-WB-Set-Tree-Node value left right)))
    (t
@@ -1301,8 +1442,8 @@
       (type (or null simple-vector) vec1 vec2))
   (let ((i1 0)
    (i2 0)
-	(len1 (length vec1))
-	(len2 (length vec2)))
+	(len1 (length-nv vec1))
+	(len2 (length-nv vec2)))
     (declare (type fixnum len1 len2))
     (unless (eq lo Hedge-Negative-Infinity)
       (do () ((or (= i1 len1) (less-than? lo (svref vec1 i1))))
@@ -1327,6 +1468,39 @@
      ((:unequal)
       (return nil)))))))
+(defun Vector-Set-Disjoint? (vec1 vec2 lo hi)
+  "Returns true iff `vec1' does not contain any member of `vec2', restricted
+to those members above `lo' and below `hi'."
+  (declare (optimize (speed 3) (safety 0))
+	   (type simple-vector vec1 vec2))
+  (let ((i1 0)
+	(i2 0)
+	(len1 (length vec1))
+	(len2 (length vec2)))
+    (declare (type fixnum i1 i2 len1 len2))
+    (unless (eq lo Hedge-Negative-Infinity)
+      (do () ((or (= i1 len1) (less-than? lo (svref vec1 i1))))
+	(incf i1)))
+    (unless (eq hi Hedge-Positive-Infinity)
+      (do () ((or (= i1 len1) (less-than? (svref vec1 (1- len1)) hi)))
+	(decf len1)))
+    (do ()
+	((or (= i1 len1) (= i2 len2))
+	 t)
+      (let ((v1 (svref vec1 i1))
+	    (v2 (svref vec2 i2))
+	    ((comp (compare v1 v2))))
+	(ecase comp
+	  ((:equal)
+	   (return nil))
+	  ((:less)
+	   (incf i1))
+	  ((:greater)
+	   (incf i2))
+	  ((:unequal)
+	   (incf i1)
+	   (incf i2)))))))
+
 ;;; ================================================================================
 ;;; Iteration primitives
@@ -1573,6 +1747,21 @@
    (member val1 (Equivalent-Set-Members val2) :test #'equal?)
       (equal? val1 val2))))
+(defun Equivalent-Set-Disjoint? (val1 val2)
+  "Both `val1' and `val2' may be single values (representing singleton sets)
+or `Equivalent-Set's of values.  If their intersection is null, returns
+true, else false."
+  (declare (optimize (speed 3) (safety 0)))
+  (if (Equivalent-Set? val1)
+      (if (Equivalent-Set? val2)
+	  (dolist (m1 (Equivalent-Set-Members val1) nil)
+	    (when (member m1 (Equivalent-Set-Members val2) :test #'equal?)
+	      (return nil)))
+	(not (member val2 (Equivalent-Set-Members val1) :test #'equal?)))
+    (if (Equivalent-Set? val2)
+	(not (member val1 (Equivalent-Set-Members val2) :test #'equal?))
+      (not (equal? val1 val2)))))
+
 (defun Equivalent-Set-Compare (val1 val2)
   (declare (optimize (speed 3) (safety 0)))
   (let ((comp (compare val1 val2)))
@@ -1692,6 +1881,8 @@
    ((consp tree) (length (the simple-vector (car tree))))
    (t (WB-Bag-Tree-Node-Size tree))))
+(declaim (ftype (function (WB-Bag-Tree) fixnum) WB-Bag-Tree-Size))
+
 (defun WB-Bag-Tree-Total-Count (tree)
   (declare (optimize (speed 3) (safety 0))
       (type WB-Bag-Tree tree))
@@ -1702,19 +1893,25 @@
 (declaim (ftype (function (WB-Bag-Tree) integer) WB-Bag-Tree-Total-Count))
+;;; This is just to get rid of compiler optimization notes.
+(def-gmap-res-type :gen-sum (&key filterp)
+  "Returns the sum of the values, optionally filtered by `filterp', using
+generic arithmetic."
+  `(0 #'(lambda (x y) (gen + x y)) nil ,filterp))
+
 (defun Make-WB-Bag-Tree-Node (value count left right)
   "The low-level constructor for a bag tree node.  `count' is ignored and can be
 `nil' if value is an `Equivalent-Bag'."
   (declare (optimize (speed 3) (safety 0))
       (type WB-Bag-Tree left right))
-  (Make-Raw-WB-Bag-Tree-Node (+ (WB-Bag-Tree-Size left) (WB-Bag-Tree-Size right)
-				(Bag-Value-Size value))
-			     ;; Next form must do generic + (ignore Python notes).
-			     (+ (WB-Bag-Tree-Total-Count left)
-				(WB-Bag-Tree-Total-Count right)
-				(if (Equivalent-Bag? value)
-				    (gmap :sum #'cdr (:list (Equivalent-Bag-Alist value)))
-				  (or count 0)))
+  (Make-Raw-WB-Bag-Tree-Node (gen + (WB-Bag-Tree-Size left) (WB-Bag-Tree-Size right)
+				  (Bag-Value-Size value))
+			     (gen + (WB-Bag-Tree-Total-Count left)
+				  (WB-Bag-Tree-Total-Count right)
+				  (if (Equivalent-Bag? value)
+				      (gmap :gen-sum #'cdr
+					    (:list (Equivalent-Bag-Alist value)))
+				    (or count 0)))
    		     value (or count 0) left right))
@@ -1739,13 +1936,12 @@
       (type WB-Bag-Tree tree))
   (let ((val count (WB-Bag-Tree-Minimum-Pair tree)))
     (if (Equivalent-Bag? val)
-	(values (caar (Equivalent-Bag-Alist val))
-		(cdar (Equivalent-Bag-Alist val)))
+	(let ((pr (car (Equivalent-Bag-Alist val))))
+	  (values (car pr) (cdr pr)))
       (values val count))))
#|| Don't think I'm going to use this.
 (defun WB-Bag-Tree-Less-Least (tree all?)
-  ;; Should generate 3 Python warnings on `generic--'.
   (declare (optimize (speed 3) (safety 0))
       (type WB-Bag-Tree tree))
   (cond ((null tree) nil)
@@ -1800,7 +1996,7 @@
      (WB-Bag-Tree-Greatest-Pair right)
    (let ((val (WB-Bag-Tree-Node-Value tree)))
      (if (Equivalent-Bag? val)
-	      (let ((pr (lastcons (Equivalent-Bag-Alist val))))
+	      (let ((pr (car (lastcons (Equivalent-Bag-Alist val)))))
    	(values (car pr) (cdr pr)))
        (values val (WB-Bag-Tree-Node-Count tree))))))))
@@ -1876,9 +2072,8 @@
       ;; this routine is called by `WB-Bag-Tree-Concat'.
       (if (and (eq found? ':equal) (not (Equivalent-Bag? value)))
           (cons (car tree)
-		     ;; Next form must do generic + (ignore Python warning).
-		     (Vector-Update (cdr tree) idx (+ (the integer (svref (cdr tree) idx))
-						      count)))
+		     (Vector-Update (cdr tree) idx (gen + (svref (cdr tree) idx)
+							count)))
         (if (and (not found?)
    	      (< (length (the simple-vector (car tree)))
    		 *WB-Tree-Max-Vector-Length*)
@@ -1936,10 +2131,9 @@
     (let ((found? idx (Vector-Set-Binary-Search (car tree) value)))
       (if (eq found? ':equal)
           (let ((prev-count (the integer (svref (cdr tree) idx))))
-		 ;; Next form must do generic > and - (ignore Python notes).
-		 (if (> prev-count count)
+		 (if (gen > prev-count count)
    	     (cons (car tree) (Vector-Update (cdr tree) idx
-						     (the integer (- prev-count count))))
+						     (gen - prev-count count)))
    	   (and (> (length (the simple-vector (car tree))) 1)
    		(cons (Vector-Remove-At (car tree) idx)
    		      (Vector-Remove-At (cdr tree) idx)))))
@@ -2225,7 +2419,8 @@
         (let ((val1 (WB-Bag-Tree-Node-Value tree1))
    	   (count1 (WB-Bag-Tree-Node-Count tree1))
    	   (val2 count2
-		      (WB-Bag-Tree-Rank-Pair tree2 (the fixnum (- new-hi base2))))
+		      (WB-Bag-Tree-Rank-Pair-Internal
+			tree2 (the fixnum (- new-hi base2))))
    	   ((val-comp (Equivalent-Bag-Compare val1 count1 val2 count2))))
           (if (or (eq val-comp ':less) (eq val-comp ':greater))
    	   val-comp
@@ -2256,27 +2451,74 @@
          (values tree base)
        (WB-Bag-Tree-Rank-Trim (WB-Bag-Tree-Node-Left tree) base lo hi))
    (WB-Bag-Tree-Rank-Trim (WB-Bag-Tree-Node-Right tree)
-			       (+ node-rank (Bag-Value-Size (WB-Bag-Tree-Node-Value tree)))
+			       (+ node-rank
+				  (Bag-Value-Size (WB-Bag-Tree-Node-Value tree)))
    		       lo hi)))))
+(defun WB-Bag-Tree-Rank (tree value)
+  "Searches a bag tree `tree' for `value'.  Returns two values, a boolean and an
+index.  If `value', or a value equivalent to `value', is in `tree', the symbol
+is true, and the index is the rank of the value; otherwise, the boolean is false
+and the index is the rank `value' would have if it were to be added.  Note that
+if the bag contains equivalent-but-unequal elements, the rank of each of several
+such elements is guaranteed consistent only within the same tree (by `eq'), not
+between equal trees."
+  (labels ((rec (tree value base)
+	     (cond ((null tree) (values nil base))
+		   ((consp tree)
+		    (let ((found? idx (Vector-Set-Binary-Search (car tree) value)))
+		      (values found? (+ idx base))))
+		   (t
+		    (let ((node-val (WB-Bag-Tree-Node-Value tree))
+			  (left (WB-Bag-Tree-Node-Left tree))
+			  ((left-size (WB-Bag-Tree-Size left))
+			   ((node-base (+ base left-size))))
+			  ((comp (compare value node-val))))
+		      (ecase comp
+			(:equal (values t node-base))
+			((:unequal)
+			 (if (Equivalent-Bag? node-val)
+			     (let ((mems (Equivalent-Bag-Alist node-val))
+				   ((pos (cl:position value mems :test #'equal?
+						      :key #'car))))
+			       (if pos (values t (+ node-base pos))
+				 (values nil node-base)))
+			   (values nil node-base)))
+			((:less)
+			 (rec left value base))
+			((:greater)
+			 (rec (WB-Bag-Tree-Node-Right tree) value
+			      (+ node-base (Bag-Value-Size node-val))))))))))
+    (rec tree value 0)))
+
 (defun WB-Bag-Tree-Rank-Pair (tree rank)
+  (let ((elt count rem (WB-Bag-Tree-Rank-Pair-Internal tree rank)))
+    (if (Equivalent-Bag? elt)
+	(let ((pr (nth rem (Equivalent-Bag-Alist elt))))
+	  (values (car pr) (cdr pr)))
+      (values elt count))))
+
+(defun WB-Bag-Tree-Rank-Pair-Internal (tree rank)
   (declare (optimize (speed 3) (safety 0))
       (type WB-Bag-Tree tree)
       (type fixnum rank))
   (cond ((null tree)
     (error "Bug in bag comparator"))
    ((consp tree)
-	 (values (svref (car tree) rank) (svref (cdr tree) rank)))
+	 (values (svref (car tree) rank) (svref (cdr tree) rank) 0))
    (t
     (let ((left (WB-Bag-Tree-Node-Left tree))
           ((left-size (WB-Bag-Tree-Size left))))
       (if (< rank left-size)
-	       (WB-Bag-Tree-Rank-Pair left rank)
-	     (let ((val (WB-Bag-Tree-Node-Value tree)))
-	       (if (= rank left-size)
-		   (values val (WB-Bag-Tree-Node-Count tree))
-		 (WB-Bag-Tree-Rank-Pair (WB-Bag-Tree-Node-Right tree)
-					(- rank left-size (Bag-Value-Size val))))))))))
+	       (WB-Bag-Tree-Rank-Pair-Internal left rank)
+	     (let ((val (WB-Bag-Tree-Node-Value tree))
+		   ((val-size (Bag-Value-Size val))
+		    (rank (- rank left-size))))
+	       (declare (type fixnum rank))
+	       (if (< rank val-size)
+		   (values val (WB-Bag-Tree-Node-Count tree) rank)
+		 (WB-Bag-Tree-Rank-Pair-Internal (WB-Bag-Tree-Node-Right tree)
+						 (the fixnum (- rank val-size))))))))))
;;; ================================================================================
@@ -2294,6 +2536,7 @@
   (declare (optimize (speed 3) (safety 0))
       (type WB-Bag-Tree tree1 tree2))
   (cond ((null tree1) t)
+	((eq tree1 tree2) t)		; historically-related-tree optimization
    ((and (consp tree1) (or (null tree2) (consp tree2)))
     (Vector-Pair-Bag-Subbag? tree1 tree2 lo hi))
    ((consp tree1)
@@ -2512,8 +2755,8 @@
   (if (and (or (null left) (consp left))
       (or (null right) (consp right)))
       (if (and (not (Equivalent-Bag? value))
-	       (< (+ (length (the (or null simple-vector) (car left)))
-		     (length (the (or null simple-vector) (car right))))
+	       (< (+ (length-nv (the (or null simple-vector) (car left)))
+		     (length-nv (the (or null simple-vector) (car right))))
    	  *WB-Tree-Max-Vector-Length*))
      (cons (concatenate 'simple-vector (car left) (vector value) (car right))
    	(concatenate 'simple-vector (cdr left) (vector count) (cdr right)))
@@ -2676,9 +2919,7 @@
           (ecase comp
    	 (:equal
    	  (push val1 vals)
-		  ;; Next form must do generic arithmetic (ignore Python notes).
-		  (push (max (the integer (svref counts1 i1))
-			     (the integer (svref counts2 i2)))
+		  (push (gen max (svref counts1 i1) (svref counts2 i2))
    		counts)
    	  (incf i1)
    	  (incf i2))
@@ -2768,9 +3009,7 @@
           (ecase comp
    	 (:equal
    	  (push val1 vals)
-		  ;; Next form must do generic + (ignore Python notes).
-		  (push (+ (the integer (svref counts1 i1))
-			   (the integer (svref counts2 i2)))
+		  (push (gen + (svref counts1 i1) (svref counts2 i2))
    		counts)
    	  (incf i1)
    	  (incf i2))
@@ -2824,9 +3063,7 @@
    (ecase comp
      (:equal
       (push val1 vals)
-	   ;; Next form must do generic arithmetic (ignore Python notes).
-	   (push (min (the integer (svref counts1 i1))
-		      (the integer (svref counts2 i2)))
+	   (push (gen min (svref counts1 i1) (svref counts2 i2))
    	 counts)
       (incf i1)
       (incf i2))
@@ -2871,9 +3108,7 @@
    (ecase comp
      (:equal
       (push val1 vals)
-	   ;; Next form must do generic * (ignore Python notes).
-	   (push (* (the integer (svref counts1 i1))
-		    (the integer (svref counts2 i2)))
+	   (push (gen * (svref counts1 i1) (svref counts2 i2))
    	 counts)
       (incf i1)
       (incf i2))
@@ -2918,9 +3153,8 @@
    (ecase comp
      ((:equal)
       (let ((c1 (the integer (svref counts1 i1)))
-		 ;; Next form must do generic - (ignore Python notes).
-		 ((c (- c1 (the integer (svref counts2 i2))))))
-	     (when (> c 0)
+		 ((c (gen - c1 (svref counts2 i2)))))
+	     (when (gen > c 0)
           (push v1 vals)
           (push c counts)))
       (incf i1)
@@ -2963,9 +3197,7 @@
        ((comp (compare v1 v2))))
    (ecase comp
      ((:equal)
-	   ;; Next form must do generic > (ignore Python notes).
-	   (when (> (the integer (svref counts1 i1))
-		    (the integer (svref counts2 i2)))
+	   (when (gen > (svref counts1 i1) (svref counts2 i2))
         (return nil))
       (incf i1)
       (incf i2))
@@ -3204,9 +3436,7 @@
          (dolist (pr1 alist1)
    	(let ((pr2 (assoc (car pr1) alist2 :test #'equal?)))
    	  (if pr2
-		      ;; Next form must do generic + (ignore Python notes).
-		      (progn (push (cons (car pr1) (+ (the integer (cdr pr1))
-						      (the integer (cdr pr2))))
+		      (progn (push (cons (car pr1) (gen + (cdr pr1) (cdr pr2)))
    			   result)
    		     (setq alist2 (delete pr2 alist2)))
    	    (push pr1 result))))
@@ -3214,15 +3444,13 @@
          (Make-Equivalent-Bag result))
      (let ((pr1 (assoc val2 alist1 :test #'equal?)))
        (if pr1
-		;; Next form must do generic + (ignore Python notes).
-		(Make-Equivalent-Bag (cons (cons val2 (+ (the integer (cdr pr1))
-							 count2))
+		(Make-Equivalent-Bag (cons (cons val2 (gen + (cdr pr1) count2))
    				   (cl:remove pr1 alist1)))
          (Make-Equivalent-Bag (cons (cons val2 count2) alist1))))))
     (if (Equivalent-Bag? val2)
    (Equivalent-Bag-Sum val2 count2 val1 count1)
       (if (equal? val1 val2)
-	  (values val1 (+ count1 count2))
+	  (values val1 (gen + count1 count2))
    (Make-Equivalent-Bag (list (cons val1 count1) (cons val2 count2)))))))
(defun Equivalent-Bag-Union (val1 count1 val2 count2)
@@ -3236,9 +3464,7 @@
          (dolist (pr1 alist1)
    	(let ((pr2 (assoc (car pr1) alist2 :test #'equal?)))
    	  (if pr2
-		      ;; Next form must do generic arithmetic (ignore Python notes).
-		      (progn (push (cons (car pr1) (max (the integer (cdr pr1))
-							(the integer (cdr pr2))))
+		      (progn (push (cons (car pr1) (gen max (cdr pr1) (cdr pr2)))
    			   result)
    		     (setq alist2 (delete pr2 alist2)))
    	    (push pr1 result))))
@@ -3246,14 +3472,13 @@
          (Make-Equivalent-Bag result))
      (let ((pr1 (assoc val2 alist1 :test #'equal?)))
        (if pr1
-		;; Next form must do generic arithmetic (ignore Python notes).
-		(Make-Equivalent-Bag (cons (cons val2 (max (the integer (cdr pr1)) count2))
+		(Make-Equivalent-Bag (cons (cons val2 (gen max (cdr pr1) count2))
    				   (cl:remove pr1 alist1)))
          (Make-Equivalent-Bag (cons (cons val2 count2) alist1))))))
     (if (Equivalent-Bag? val2)
    (Equivalent-Bag-Union val2 count2 val1 count1)
       (if (equal? val1 val2)
-	  (values val1 (max count1 count2))
+	  (values val1 (gen max count1 count2))
    (Make-Equivalent-Bag (list (cons val1 count1) (cons val2 count2)))))))
(defun Equivalent-Bag-Intersect (val1 count1 val2 count2)
@@ -3267,23 +3492,19 @@
          (dolist (pr1 alist1)
    	(let ((pr2 (assoc (car pr1) alist2 :test #'equal?)))
    	  (when pr2
-		    ;; Next form must do generic arithmetic (ignore Python notes).
-		    (push (cons (car pr1) (min (the integer (cdr pr1))
-					       (the integer (cdr pr2))))
+		    (push (cons (car pr1) (gen min (cdr pr1) (cdr pr2)))
    		  result))))
          (cond ((null result) nil)
    	    ((null (cdr result)) (values t (caar result) (cdar result)))
    	    (t (values t (Make-Equivalent-Bag result)))))
      (let ((pr1 (assoc val2 alist1 :test #'equal?)))
        (and pr1
-		 ;; Next form must do generic arithmetic (ignore Python notes).
-		 (values t val2 (min (the integer (cdr pr1)) count2))))))
+		 (values t val2 (gen min (cdr pr1) count2))))))
     (if (Equivalent-Bag? val2)
    (let ((pr2 (assoc val1 (Equivalent-Bag-Alist val2) :test #'equal?)))
-	  ;; Next form must do generic arithmetic (ignore Python notes).
-	  (and pr2 (values t val1 (min count1 (the integer (cdr pr2))))))
+	  (and pr2 (values t val1 (gen min count1 (cdr pr2)))))
       (and (equal? val1 val2)
-	   (values t val1 (min count1 count2))))))
+	   (values t val1 (gen min count1 count2))))))
(defun Equivalent-Bag-Product (val1 count1 val2 count2)
   (declare (optimize (speed 3) (safety 0))
@@ -3296,24 +3517,19 @@
          (dolist (pr1 alist1)
    	(let ((pr2 (assoc (car pr1) alist2 :test #'equal?)))
    	  (when pr2
-		    ;; Next form must do generic arithmetic (ignore Python notes).
-		    (push (cons (car pr1) (* (the integer (cdr pr1))
-					     (the integer (cdr pr2))))
+		    (push (cons (car pr1) (gen * (cdr pr1) (cdr pr2)))
    		  result))))
          (cond ((null result) nil)
    	    ((null (cdr result)) (values t (caar result) (cdar result)))
    	    (t (values t (Make-Equivalent-Bag result)))))
      (let ((pr1 (assoc val2 alist1 :test #'equal?)))
        (and pr1
-		 ;; Next form must do generic arithmetic (ignore Python notes).
-		 (values t val2 (* (the integer (cdr pr1)) count2))))))
+		 (values t val2 (gen * (cdr pr1) count2))))))
     (if (Equivalent-Bag? val2)
    (let ((pr2 (assoc val1 (Equivalent-Bag-Alist val2) :test #'equal?)))
-	  ;; Next form must do generic arithmetic (ignore Python notes).
-	  (and pr2 (values t val1 (* count1 (the integer (cdr pr2))))))
+	  (and pr2 (values t val1 (gen * count1 (cdr pr2)))))
       (and (equal? val1 val2)
-	   ;; Next form must do generic arithmetic (ignore Python notes).
-	   (values t val1 (* count1 count2))))))
+	   (values t val1 (gen * count1 count2))))))
(defun Equivalent-Bag-Difference (val1 count1 val2 count2)
   (declare (optimize (speed 3) (safety 0))
@@ -3325,26 +3541,23 @@
        (result nil))
    (dolist (pr1 alist1)
      (let ((pr2 (assoc (car pr1) alist2 :test #'equal?)))
-	    ;; Next form must do generic arithmetic (ignore Python notes).
        (cond ((null pr2)
    	   (push pr1 result))
-		  ((> (the integer (cdr pr1)) (the integer (cdr pr2)))
+		  ((gen > (cdr pr1) (cdr pr2))
    	   (push (cons (car pr1)
-			       (- (the integer (cdr pr1)) (the integer (cdr pr2))))
+			       (gen - (cdr pr1) (cdr pr2)))
    		 result)))))
    (cond ((null result) nil)
          ((null (cdr result)) (values t (caar result) (cdar result)))
          (t (values t (Make-Equivalent-Bag result)))))
     (if (Equivalent-Bag? val2)
    (let ((pr2 (assoc val1 (Equivalent-Bag-Alist val2) :test #'equal?)))
-	  ;; Next form must do generic arithmetic (ignore Python notes).
      (cond ((null pr2)
    	 (values t val1 count1))
-		((> count1 (the integer (cdr pr2)))
-		 (values t val1 (- count1 (the integer (cdr pr2)))))))
+		((gen > count1 (cdr pr2))
+		 (values t val1 (gen - count1 (cdr pr2))))))
       (if (equal? val1 val2)
-	  ;; Next form must do generic arithmetic (ignore Python notes).
-	  (and (> count1 count2) (values t val1 (- count1 count2)))
+	  (and (gen > count1 count2) (values t val1 (gen - count1 count2)))
    (values t val1 count1)))))
(defun Equivalent-Bag-Subbag? (val1 count1 val2 count2)
@@ -3355,16 +3568,13 @@
       (let ((alist2 (Equivalent-Bag-Alist val2)))
         (dolist (pr1 (Equivalent-Bag-Alist val1) t)
           (let ((pr2 (assoc (car pr1) alist2 :test #'equal?)))
-		 ;; Next form must do generic arithmetic (ignore Python notes).
-		 (unless (and pr2 (<= (the integer (cdr pr1)) (the integer (cdr pr2))))
+		 (unless (and pr2 (gen <= (cdr pr1) (cdr pr2)))
    	   (return nil))))))
     (if (Equivalent-Bag? val2)
    (let ((pr2 (assoc val1 (Equivalent-Bag-Alist val2) :test #'equal?)))
-	  ;; Next form must do generic arithmetic (ignore Python notes).
-	  (and pr2 (<= count1 (the integer (cdr pr2)))))
+	  (and pr2 (gen <= count1 (cdr pr2))))
       (and (equal? val1 val2)
-	   ;; Next form must do generic arithmetic (ignore Python notes).
-	   (<= count1 count2)))))
+	   (gen <= count1 count2)))))
(defun Equivalent-Bag-Compare (val1 count1 val2 count2)
   "Compares two pairs where the key of either or both may be an `Equivalent-Bag'."
@@ -3396,8 +3606,8 @@
        ':less)
    (cond ((Equivalent-Bag? val2)
           ':greater)
-	      ((< count1 count2) ':less)
-	      ((> count1 count2) ':greater)
+	      ((gen < count1 count2) ':less)
+	      ((gen > count1 count2) ':greater)
          (t comp))))))
(defmethod compare (x (eqvs Equivalent-Bag))
@@ -3555,7 +3765,7 @@
   (declare (optimize (speed 3) (safety 0))
       (type WB-Map-Tree tree))
   (if (consp tree)
-      (let ((idx  (1- (length (the simple-vector (car tree))))))
+      (let ((idx (1- (length (the simple-vector (car tree))))))
    (values (svref (car tree) idx)
    	(svref (cdr tree) idx)))
     (let ((right (WB-Map-Tree-Node-Right tree)))
@@ -3563,7 +3773,7 @@
      (WB-Map-Tree-Greatest-Pair right)
    (let ((key (WB-Map-Tree-Node-Key tree)))
      (if (Equivalent-Map? key)
-	      (let ((pr (car (Equivalent-Map-Alist key))))
+	      (let ((pr (car (lastcons (Equivalent-Map-Alist key)))))
    	(values (car pr) (cdr pr)))
        (values key (WB-Map-Tree-Node-Value tree))))))))
@@ -3797,7 +4007,7 @@
;;; ================================================================================
-;;; Union and intersection
+;;; Union, intersection, and map difference
(defun WB-Map-Tree-Union (tree1 tree2 val-fn)
   (WB-Map-Tree-Union-Rng tree1 tree2 val-fn
@@ -3894,6 +4104,69 @@
    				val-fn key1 hi))))))
+(defun WB-Map-Tree-Diff-2 (tree1 tree2)
+  "Returns two values: one containing the pairs that are in `tree1' but not
+`tree2', and the other containing the pairs that are in `tree2' but not
+`tree1'."
+  (WB-Map-Tree-Diff-2-Rng tree1 tree2
+			  Hedge-Negative-Infinity Hedge-Positive-Infinity))
+
+(defun WB-Map-Tree-Diff-2-Rng (tree1 tree2 lo hi)
+  (cond ((eq tree1 tree2)		; historically-related tree optimization
+	 (values nil nil))
+	((or (null tree1) (null tree2))
+	 (values (WB-Map-Tree-Split tree1 lo hi)
+		 (WB-Map-Tree-Split tree2 lo hi)))
+	((and (consp tree1) (consp tree2))
+	 (Vector-Pair-Diff-2 tree1 tree2 lo hi))
+	((consp tree1)
+	 (let ((key2 (WB-Map-Tree-Node-Key tree2))
+	       (val2 (WB-Map-Tree-Node-Value tree2))
+	       ((new-left-1 new-left-2
+		  (WB-Map-Tree-Diff-2-Rng (WB-Map-Tree-Trim tree1 lo key2)
+					  (WB-Map-Tree-Trim (WB-Map-Tree-Node-Left tree2)
+							    lo key2)
+					  lo key2))
+		(new-right-1 new-right-2
+		  (WB-Map-Tree-Diff-2-Rng (WB-Map-Tree-Trim tree1 key2 hi)
+					  (WB-Map-Tree-Trim (WB-Map-Tree-Node-Right tree2)
+							    key2 hi)
+					  key2 hi)))
+	       ((eqvk1? eqvk1 eqvv1 (WB-Map-Tree-Find-Equivalent tree1 key2))
+		((nonnull1? diffk1 diffv1
+		   (and eqvk1? (Equivalent-Map-Difference eqvk1 eqvv1 key2 val2)))
+		 (nonnull2? diffk2 diffv2
+		   (if eqvk1? (Equivalent-Map-Difference key2 val2 eqvk1 eqvv1)
+		     (values t key2 val2))))))
+	   (values (if nonnull1? (WB-Map-Tree-Concat diffk1 diffv1 new-left-1 new-right-1)
+		     (WB-Map-Tree-Join new-left-1 new-right-1))
+		   (if nonnull2? (WB-Map-Tree-Concat diffk2 diffv2 new-left-2 new-right-2)
+		     (WB-Map-Tree-Join new-left-2 new-right-2)))))
+	(t
+	 (let ((key1 (WB-Map-Tree-Node-Key tree1))
+	       (val1 (WB-Map-Tree-Node-Value tree1))
+	       ((new-left-1 new-left-2
+		  (WB-Map-Tree-Diff-2-Rng (WB-Map-Tree-Trim (WB-Map-Tree-Node-Left tree1)
+							    lo key1)
+					  (WB-Map-Tree-Trim tree2 lo key1)
+					  lo key1))
+		(new-right-1 new-right-2
+		  (WB-Map-Tree-Diff-2-Rng (WB-Map-Tree-Trim (WB-Map-Tree-Node-Right tree1)
+							    key1 hi)
+					  (WB-Map-Tree-Trim tree2 key1 hi)
+					  key1 hi)))
+	       ((eqvk2? eqvk2 eqvv2 (WB-Map-Tree-Find-Equivalent tree2 key1))
+		((nonnull1? diffk1 diffv1
+		   (if eqvk2? (Equivalent-Map-Difference key1 val1 eqvk2 eqvv2)
+		     (values t key1 val1)))
+		 (nonnull2? diffk2 diffv2
+		   (and eqvk2? (Equivalent-Map-Difference eqvk2 eqvv2 key1 val1))))))
+	   (values (if nonnull1? (WB-Map-Tree-Concat diffk1 diffv1 new-left-1 new-right-1)
+		     (WB-Map-Tree-Join new-left-1 new-right-1))
+		   (if nonnull2? (WB-Map-Tree-Concat diffk2 diffv2 new-left-2 new-right-2)
+		     (WB-Map-Tree-Join new-left-2 new-right-2)))))))
+
+
 ;;; ================================================================================
 ;;; Restrict and restrict-not
@@ -4064,7 +4337,8 @@
         (let ((key1 (WB-Map-Tree-Node-Key tree1))
    	   (val1 (WB-Map-Tree-Node-Value tree1))
    	   (key2 val2
-		      (WB-Map-Tree-Rank-Pair tree2 (the fixnum (- new-hi base2))))
+		      (WB-Map-Tree-Rank-Pair-Internal
+			tree2 (the fixnum (- new-hi base2))))
    	   ((comp (Equivalent-Map-Compare key1 val1 key2 val2 val-fn))))
           (if (or (eq comp ':less) (eq comp ':greater))
    	   comp
@@ -4099,24 +4373,70 @@
    		       (+ node-rank (Map-Key-Size (WB-Map-Tree-Node-Key tree)))
    		       lo hi)))))
+(defun WB-Map-Tree-Rank (tree key)
+  "Searches a map tree `tree' for `key'.  Returns two values, a boolean and an
+index.  If `key', or a value equivalent to `key', is in `tree', the boolean
+is true, and the index is the rank of the value; otherwise, the boolean is false
+and the index is the rank `key' would have if it were to be added.  Note that
+if the map contains equivalent-but-unequal keys, the rank of each of several
+such keys is guaranteed consistent only within the same tree (by `eq'), not
+between equal trees."
+  (labels ((rec (tree key base)
+	     (cond ((null tree) (values nil base))
+		   ((consp tree)
+		    (let ((found? idx (Vector-Set-Binary-Search (car tree) key)))
+		      (values found? (+ idx base))))
+		   (t
+		    (let ((node-val (WB-Map-Tree-Node-Key tree))
+			  (left (WB-Map-Tree-Node-Left tree))
+			  ((left-size (WB-Map-Tree-Size left))
+			   ((node-base (+ base left-size))))
+			  ((comp (compare key node-val))))
+		      (ecase comp
+			(:equal (values t node-base))
+			((:unequal)
+			 (if (Equivalent-Map? node-val)
+			     (let ((prs (Equivalent-Map-Alist node-val))
+				   ((pos (cl:position key prs :test #'equal?
+						      :key #'car))))
+			       (if pos (values t (+ node-base pos))
+				 (values nil node-base)))
+			   (values nil node-base)))
+			((:less)
+			 (rec left key base))
+			((:greater)
+			 (rec (WB-Map-Tree-Node-Right tree) key
+			      (+ node-base (Map-Key-Size node-val))))))))))
+    (rec tree key 0)))
+
 (defun WB-Map-Tree-Rank-Pair (tree rank)
+  (let ((key value rem (WB-Map-Tree-Rank-Pair-Internal tree rank)))
+    (if (Equivalent-Map? key)
+	(let ((pr (nth rem (Equivalent-Map-Alist key))))
+	  (values (car pr) (cdr pr)))
+      (values key value))))
+
+(defun WB-Map-Tree-Rank-Pair-Internal (tree rank)
   (declare (optimize (speed 3) (safety 0))
       (type WB-Map-Tree tree)
       (type fixnum rank))
   (cond ((null tree)
     (error "Bug in map comparator"))
    ((consp tree)
-	 (values (svref (car tree) rank) (svref (cdr tree) rank)))
+	 (values (svref (car tree) rank) (svref (cdr tree) rank) 0))
    (t
     (let ((left (WB-Map-Tree-Node-Left tree))
           ((left-size (WB-Map-Tree-Size left))))
       (if (< rank left-size)
-	       (WB-Map-Tree-Rank-Pair left rank)
-	     (let ((key (WB-Map-Tree-Node-Key tree)))
-	       (if (= rank left-size)
-		   (values key (WB-Map-Tree-Node-Value tree))
-		 (WB-Map-Tree-Rank-Pair (WB-Map-Tree-Node-Right tree)
-					(- rank left-size (Map-Key-Size key))))))))))
+	       (WB-Map-Tree-Rank-Pair-Internal left rank)
+	     (let ((key (WB-Map-Tree-Node-Key tree))
+		   ((key-size (Map-Key-Size key)))
+		   (rank (- rank left-size)))
+	       (declare (type fixnum rank key-size))
+	       (if (< rank key-size)
+		   (values key (WB-Map-Tree-Node-Value tree) rank)
+		 (WB-Map-Tree-Rank-Pair-Internal (WB-Map-Tree-Node-Right tree)
+						 (the fixnum (- rank key-size))))))))))
;;; ================================================================================
 ;;; Support routines for the above (maps)
@@ -4229,8 +4549,8 @@
   (if (and (or (null left) (consp left))
       (or (null right) (consp right)))
       (if (and (not (Equivalent-Map? key))
-	       (< (+ (length (the (or null simple-vector) (car left)))
-		     (length (the (or null simple-vector) (car right))))
+	       (< (+ (length-nv (the (or null simple-vector) (car left)))
+		     (length-nv (the (or null simple-vector) (car right))))
    	  *WB-Tree-Max-Vector-Length*))
      (cons (concatenate 'simple-vector (car left) (vector key) (car right))
    	(concatenate 'simple-vector (cdr left) (vector value) (cdr right)))
@@ -4380,7 +4700,7 @@
           (ecase comp
    	 ((:equal)
    	  (push key1 keys)
-		  (push (funcall val-fn key1 (svref vals1 i1) (svref vals2 i2))
+		  (push (funcall val-fn (svref vals1 i1) (svref vals2 i2))
    		vals)
    	  (incf i1)
    	  (incf i2))
@@ -4430,17 +4750,81 @@
        ((comp (compare key1 key2))))
    (ecase comp
      ((:equal)
-	   (let ((val val? (funcall val-fn key1 (svref vals1 i1) (svref vals2 i2))))
-	     (when val?
-	       (push key1 keys)
-	       (push val vals)))
+	   (push key1 keys)
+	   (push (funcall val-fn (svref vals1 i1) (svref vals2 i2)) vals)
+	   (incf i1)
+	   (incf i2))
+	  ((:less)
+	   (incf i1))
+	  ((:greater)
+	   (incf i2))
+	  ((:unequal)
+	   (incf i1)
+	   (incf i2)))))))
+
+(defun Vector-Pair-Diff-2 (pr1 pr2 lo hi)
+  (let ((keys1 (the simple-vector (car pr1)))
+	(vals1 (the simple-vector (cdr pr1)))
+	(keys2 (the simple-vector (car pr2)))
+	(vals2 (the simple-vector (cdr pr2)))
+	(i1 0)
+	(i2 0)
+	((len1 (length keys1))
+	 (len2 (length keys2))))
+    (unless (eq lo Hedge-Negative-Infinity)
+      (do () ((or (= i1 len1) (less-than? lo (svref keys1 i1))))
+	(incf i1))
+      (do () ((or (= i2 len2) (less-than? lo (svref keys2 i2))))
+	(incf i2)))
+    (unless (eq hi Hedge-Positive-Infinity)
+      (do () ((or (= i1 len1) (less-than? (svref keys1 (1- len1)) hi)))
+	(decf len1))
+      (do () ((or (= i2 len2) (less-than? (svref keys2 (1- len2)) hi)))
+	(decf len2)))
+    (do ((diff-1-keys nil)
+	 (diff-1-vals nil)
+	 (diff-2-keys nil)
+	 (diff-2-vals nil))
+	((or (= i1 len1) (= i2 len2))
+	 (do () ((= i1 len1))
+	   (push (svref keys1 i1) diff-1-keys)
+	   (push (svref vals1 i1) diff-1-vals)
+	   (incf i1))
+	 (do () ((= i2 len2))
+	   (push (svref keys2 i2) diff-2-keys)
+	   (push (svref vals2 i2) diff-2-vals)
+	   (incf i2))
+	 (values (and diff-1-keys (cons (coerce (nreverse diff-1-keys) 'simple-vector)
+					(coerce (nreverse diff-1-vals) 'simple-vector)))
+		 (and diff-2-keys (cons (coerce (nreverse diff-2-keys) 'simple-vector)
+					(coerce (nreverse diff-2-vals) 'simple-vector)))))
+      (let ((key1 (svref keys1 i1))
+	    (key2 (svref keys2 i2))
+	    (val1 (svref vals1 i1))
+	    (val2 (svref vals2 i2))
+	    ((comp (compare key1 key2))))
+	(ecase comp
+	  ((:equal)
+	   (unless (equal? val1 val2)
+	     (push key1 diff-1-keys)
+	     (push val1 diff-1-vals)
+	     (push key2 diff-2-keys)
+	     (push val2 diff-2-vals))
       (incf i1)
       (incf i2))
      ((:less)
+	   (push key1 diff-1-keys)
+	   (push val1 diff-1-vals)
       (incf i1))
      ((:greater)
+	   (push key2 diff-2-keys)
+	   (push val2 diff-2-vals)
       (incf i2))
      ((:unequal)
+	   (push key1 diff-1-keys)
+	   (push val1 diff-1-vals)
+	   (push key2 diff-2-keys)
+	   (push val2 diff-2-vals)
       (incf i1)
       (incf i2)))))))
@@ -4567,6 +4951,24 @@
        ,value-form)))
+(defun WB-Map-Tree-Compose (tree fn)
+  (if (consp tree)
+      (cons (car tree)
+	    (gmap (:vector :length (length (cdr tree)))
+		  fn (:simple-vector (cdr tree))))
+    (let ((key (WB-Map-Tree-Node-Key tree))
+	  (val (WB-Map-Tree-Node-Value tree))
+	  (new-left (WB-Map-Tree-Compose (WB-Map-Tree-Node-Left tree) fn))
+	  (new-right (WB-Map-Tree-Compose (WB-Map-Tree-Node-Right tree) fn)))
+      (if (Equivalent-Map? key)
+	  (Make-WB-Map-Tree-Node
+	    (Make-Equivalent-Map (mapcar (lambda (pr)
+					   (cons (car pr) (funcall fn (cdr pr))))
+					 (Equivalent-Map-Alist key)))
+	    val new-left new-right)
+	(Make-WB-Map-Tree-Node key (funcall fn val) new-left new-right)))))
+
+
 ;;; ----------------
 ;;; Stateful iterator
@@ -4648,8 +5050,8 @@
 ;;; Equivalent-Map routines
(defun Equivalent-Map-Union (key1 val1 key2 val2
-			     &optional (val-fn #'(lambda (k v1 v2)
-						   (declare (ignore k v1))
+			     &optional (val-fn #'(lambda (v1 v2)
+						   (declare (ignore v1))
    					   v2)))
   "Both `key1' and `key2' may be single values (representing a single key/value
 pair) or `Equivalent-Map's of key/value pairs.  That is, if `key1' is a
@@ -4668,7 +5070,7 @@
        (dolist (pr1 alist1)
          (let ((pr2 (find (car pr1) alist2 :test #'equal? :key #'car)))
    	(if pr2
-		    (push (cons (car pr1) (funcall val-fn (car pr1) (cdr pr1) (cdr pr2)))
+		    (push (cons (car pr1) (funcall val-fn (cdr pr1) (cdr pr2)))
    		  result)
    	  (push pr1 result))))
        (dolist (pr2 alist2)
@@ -4681,7 +5083,7 @@
      (declare (type list alist1))
      (when pr1
        (setq alist1 (remove pr1 alist1))
-	    (setq val2 (funcall val-fn key2 (cdr pr1) val2)))
+	    (setq val2 (funcall val-fn (cdr pr1) val2)))
      (Make-Equivalent-Map (cons (cons key2 val2) alist1))))
     (if (Equivalent-Map? key2)
    (let ((alist2 (Equivalent-Map-Alist key2))
@@ -4689,10 +5091,10 @@
      (declare (type list alist2))
      (when pr2
        (setq alist2 (remove pr2 alist2))
-	    (setq val1 (funcall val-fn key1 val1 (cdr pr2))))
+	    (setq val1 (funcall val-fn val1 (cdr pr2))))
      (Make-Equivalent-Map (cons (cons key1 val1) alist2)))
       (if (equal? key1 key2)
-	  (values key1 (funcall val-fn key1 val1 val2))
+	  (values key1 (funcall val-fn val1 val2))
    (Make-Equivalent-Map (list (cons key1 val1) (cons key2 val2)))))))
(defun Equivalent-Map-Intersect (key1 val1 key2 val2 val-fn)
@@ -4709,14 +5111,12 @@
       (if (Equivalent-Map? key2)
      (let ((alist1 (Equivalent-Map-Alist key1))
    	(alist2 (Equivalent-Map-Alist key2))
-		((result nil)))
+		(result nil))
        (declare (type list alist1 alist2))
        (dolist (pr1 alist1)
          (let ((pr2 (cl:find (car pr1) alist2 :test #'equal? :key #'car)))
    	(when pr2
-		  (let ((val val? (funcall val-fn (car pr1) (cdr pr1) (cdr pr2))))
-		    (when val?
-		      (push (cons (car pr1) val) result))))))
+		  (push (cons (car pr1) (funcall val-fn (cdr pr1) (cdr pr2))) result))))
        (and result
    	 (if (cdr result)
    	     (values t (Make-Equivalent-Map result))
@@ -4725,18 +5125,47 @@
          ((pr1 (cl:find key2 alist1 :test #'equal? :key #'car))))
      (declare (type list alist1))
      (and pr1
-	       (let ((val val? (funcall val-fn key2 (cdr pr1) val2)))
-		 (and val? (values t key2 val))))))
+	       (values t key2 (funcall val-fn (cdr pr1) val2)))))
     (if (Equivalent-Map? key2)
    (let ((alist2 (Equivalent-Map-Alist key2))
          ((pr2 (cl:find key1 alist2 :test #'equal? :key #'car))))
      (declare (type list alist2))
      (and pr2
-	       (let ((val val? (funcall val-fn key1 val1 (cdr pr2))))
-		 (and val? (values t key1 val)))))
+	       (values t key1 (funcall val-fn val1 (cdr pr2)))))
       (and (equal? key1 key2)
-	   (let ((val val? (funcall val-fn key1 val1 val2)))
-	     (and val? (values t key1 val)))))))
+	   (values t key1 (funcall val-fn val1 val2))))))
+
+(defun Equivalent-Map-Difference (key1 val1 key2 val2)
+  "Both `key1' and `key2' may be single values (representing a single key/value
+pair) or `Equivalent-Map's of key/value pairs.  That is, if `key1' is a
+`Equivalent-Map', `val1' is ignored, and similarly for `key2' and `val2'.
+If the difference is nonnull, returns two or three values: if it is a single
+pair, returns true, the key, and the value; if it is more than one pair,
+returns true and an `Equivalent-Map' of the pairs.  If the difference is
+empty, returns false."
+  (if (Equivalent-Map? key1)
+      (let ((alist1 (Equivalent-Map-Alist key1)))
+	(declare (type list alist1))
+	(let ((alist2 (if (Equivalent-Map? key2) (Equivalent-Map-Alist key2)
+			(list (cons key2 val2))))
+	      (result nil))
+	  (declare (type list alist2))
+	  (dolist (pr1 alist1)
+	    (let ((pr2 (cl:find (car pr1) alist2 :test #'equal? :key #'car)))
+	      (when (or (null pr2) (not (equal? (cdr pr1) (cdr pr2))))
+		(push pr1 result))))
+	  (and result
+	       (if (cdr result)
+		   (values t (Make-Equivalent-Map result))
+		 (values t (caar result) (cdar result))))))
+    (if (Equivalent-Map? key2)
+	(let ((alist2 (Equivalent-Map-Alist key2))
+	      ((pr2 (cl:find key1 alist2 :test #'equal? :key #'car))))
+	  (declare (type list alist2))
+	  (and (or (null pr2) (not (equal? val1 (cdr pr2))))
+	       (values t key1 val1)))
+      (and (or (not (equal? key1 key2)) (not (equal? val1 val2)))
+	   (values t key1 val1)))))
(defun Equivalent-Map-Less (eqvm key)
   "Removes the pair associated with `key' from `eqvm', an `Equivalent-Map'.  If
@@ -4795,7 +5224,8 @@
(defun Equivalent-Map-Compare (key1 val1 key2 val2 val-fn)
   "Compares two pairs where the key of either or both may be an `Equivalent-Map'."
-  (declare (optimize (speed 3) (safety 0)))
+  (declare (optimize (speed 3) (safety 0))
+	   (type function val-fn))
   (let ((comp (compare key1 key2)))
     (if (or (eq comp ':less) (eq comp ':greater))
    comp
@@ -4941,7 +5371,7 @@
         (let ((left (and (> idx 0) (String-Subseq tree 0 idx)))
    	   (right (and (< idx (length tree)) (String-Subseq tree idx))))
           (declare (type (or simple-string null) left right))
-	       (if (< (length left) (length right))
+	       (if (< (length-nv left) (length-nv right))
    	   (Make-WB-Seq-Tree-Node (Vector-Insert (coerce left 'simple-vector)
    						 idx value)
    				  right)
@@ -5154,9 +5584,13 @@
       (type fixnum start end))
   (cond ((or (null tree) (>= start end)) nil)
    ((simple-vector-p tree)
-	 (Vector-Subseq tree start end))
+	 (if (and (= start 0) (= end (length tree)))
+	     tree
+	   (Vector-Subseq tree start end)))
    ((stringp tree)
-	 (String-Subseq tree start end))
+	 (if (and (= start 0) (= end (length tree)))
+	     tree
+	   (String-Subseq tree start end)))
    (t
     (let ((left (WB-Seq-Tree-Node-Left tree))
           ((left-size (WB-Seq-Tree-Size left)))
@@ -5189,7 +5623,7 @@
 ;;; Conversion to/from vectors
(defun WB-Seq-Tree-From-Vector (vec)
-  (declare (optimize (speed 3) (safety 0))
+  (declare (optimize (speed 1) (safety 1))
       (type vector vec))
   (and (> (length vec) 0)
        ;; We walk the vector left-to-right, breaking it up into nearly-equal-sized
@@ -5211,9 +5645,7 @@
          (car stack))
       (declare (type fixnum ipiece base))
       (let ((piece-len (if (< ipiece remainder) (1+ piece-len) piece-len))
-		 ((piece (cond ;; Ignore Python notes -- we don't know exactly what
-			       ;; `vec' is.
-			       ((gmap :and #'base-char-p
+		 ((piece (cond ((gmap :and #'base-char-p
    			      (:vector vec :start base :stop (+ base piece-len)))
    			(let ((str (make-string piece-len
    						:element-type 'base-char)))
@@ -5379,6 +5811,16 @@
      ((> size1 size2) ':greater)
      (t (WB-Seq-Tree-Compare-Rng tree1 0 tree2 0 0 size1)))))
+(defun WB-Seq-Tree-Compare-Lexicographically (tree1 tree2)
+  (let ((size1 (WB-Seq-Tree-Size tree1))
+	(size2 (WB-Seq-Tree-Size tree2)))
+    (let ((comp (WB-Seq-Tree-Compare-Rng tree1 0 tree2 0 0 (min size1 size2))))
+      (cond ((or (eq comp ':less) (eq comp ':greater))
+	     comp)
+	    ((< size1 size2) ':less)
+	    ((> size1 size2) ':greater)
+	    (t comp)))))
+
 (defun WB-Seq-Tree-Compare-Rng (tree1 base1 tree2 base2 lo hi)
   ;; See notes at `WB-Set-Tree-Compare-Rng'.
   (declare (optimize (speed 3) (safety 0))
@@ -5441,6 +5883,8 @@
   (cond ((null tree) nil)
    ((simple-vector-p tree)
     (Vector-Seq-To-Set tree 0 (length tree)))
+	((stringp tree)
+	 (String-Seq-To-Set tree 0 (length tree)))
    (t (WB-Set-Tree-Union (WB-Seq-Tree-To-Set-Tree (WB-Seq-Tree-Node-Left tree))
    		      (WB-Seq-Tree-To-Set-Tree (WB-Seq-Tree-Node-Right tree))))))
@@ -5456,6 +5900,18 @@
       (WB-Set-Tree-Union (Vector-Seq-To-Set vec lo mid)
    		      (Vector-Seq-To-Set vec mid hi))))))
+(defun String-Seq-To-Set (vec lo hi)
+  (declare (optimize (speed 3) (safety 0))
+	   (type simple-string vec)
+	   (type fixnum lo hi))
+  (cond ((= lo hi) nil)			; (shouldn't happen)
+	((= hi (1+ lo))
+	 (vector (schar vec lo)))
+	(t
+	 (let ((mid (ash (+ lo hi) -1)))
+	   (WB-Set-Tree-Union (String-Seq-To-Set vec lo mid)
+			      (String-Seq-To-Set vec mid hi))))))
+
;;; ================================================================================
 ;;; Support routines for the above (sequences)
@@ -5485,7 +5941,7 @@
       (type WB-Seq-Tree left right))
   (cond ((and (or (null left) (stringp left))
          (or (null right) (stringp right))
-	      (< (+ (length left) (length right)) *WB-Tree-Max-String-Length*))
+	      (< (+ (length-nv left) (length-nv right)) *WB-Tree-Max-String-Length*))
     (if (and left right)
         (concatenate #-FSet-Ext-Strings 'base-string
    		  #+FSet-Ext-Strings (if (and (typep left 'base-string)
@@ -5496,7 +5952,7 @@
       (or left right)))
    ((and (or (null left) (simple-vector-p left))
          (or (null right) (simple-vector-p right)))
-	 (if (< (+ (length left) (length right)) *WB-Tree-Max-Vector-Length*)
+	 (if (< (+ (length-nv left) (length-nv right)) *WB-Tree-Max-Vector-Length*)
         (concatenate 'simple-vector left right)
       (Make-WB-Seq-Tree-Node left right)))
    (t
@@ -5625,6 +6081,36 @@
        ,value-form)))
+#|| L8R...
+(defun WB-Seq-Tree-Image (tree fn)
+  (cond ((stringp tree)
+	 (let ((len (length (the simple-string tree)))
+	       (first-val (funcall fn (schar tree 0)))
+	       ;; Heuristic: if the image of elt 0 is a character, figure they're
+	       ;; all likely to be characters.  If not, we'll switch.
+	       ((result char-type
+		  (cond ((typep first-val 'base-char)
+			 (values (make-string len :element-type 'base-char)
+				 'base-char))
+			#+FSet-Ext-Strings
+			((typep first-val 'character)
+			 (values (make-string len :element-type 'character)
+				 'character))
+			(t (values (make-array len) nil))))))
+	   (dotimes (i len)
+	     (let ((val (if (= i 0) first-val (funcall fn (schar tree i)))))
+	       (when (and char-type (> i 0)
+			  ;; I suspect this will optimize much better than
+			  ;; (typep val char-type).
+			  (not (if (eq char-type 'base-char) (typep val 'base-char)
+				 (typep val 'character))))
+		 (let (())))
+	       (if char-type
+		   (setf (schar result i) val)
+		 (setf (svref result i) val))))))))
+||#
+
+
 ;;; ----------------
 ;;; Stateful iterator

    

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

[fset-cvs] r18 - trunk/Code