[fset-cvs] r18 - trunk/Code
Scott L. Burson
sburson at common-lisp.net
Sun Oct 26 05:34:03 UTC 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
More information about the Fset-cvs
mailing list