fset-cvs

Download

fset-cvs@common-lisp.net

July 2007

1 participants
2 discussions

[fset-cvs] r17 - tags/fset_1.1
by sburson＠common-lisp.net 15 Jul '07

15 Jul '07

Author: sburson Date: Sun Jul 15 19:28:42 2007 New Revision: 17 Added: tags/fset_1.1/ - copied from r16, trunk/ Log: Tagging 1.1.

1 0

[fset-cvs] r16 - trunk/Code
by sburson＠common-lisp.net 15 Jul '07

15 Jul '07

Author: sburson Date: Sun Jul 15 19:27:07 2007 New Revision: 16 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 Log: Many changes for 1.1. () Added stateful iterators. These aren't really any faster than converting to a list, but they do cons less on large collections. GMap arg types now use the stateful iterators. Added GMap arg- and result-types `:map' and `:bag-pairs', using the multiple-value features in GMap 3.3 (Misc-Extensions 1.1). Added GMap arg-type `:sequence' for completely generic iteration. () Incompatible change: the macro `do-bag', which does map-style iteration, has been renamed to `do-bag-pairs'; the new `do-bag' does set-style iteration. () Incompatible change: `map-merge' has been renamed to `map-union'. () Implemented `some' and friends; added `nonempty' and `map-intersection'. () Added historically-related-trees optimization for some set, bag, and map operations. Now, if you take one of these collections, perform a small number of point changes on it (adding or removing a single element or pair), and apply an operation that supports this optimization to the original collection and the result, the operation will run in log time rather than linear time. Currently, the supported operations are: `subset?', `union', `intersection', `set-difference', `map-union', and `map-intersection'; and `compare' on sets, bags, maps, and seqs. Fixed bugs: () The print methods didn't support `*print-level*' portably. () The `compare' methods for lists and vectors were wrong in the presence of equivalent-but-unequal elements. Also, for lists, we no longer compare lengths first, because `length' on a list takes linear time, and because we now support dotted lists. () `pop-first' and `pop-last' were very wrong (they did not return the value popped). () `insert' wasn't sufficiently validating its arguments; also, the implementation had a bug. () There was a bug in `compare' on seqs. Modified: trunk/Code/defs.lisp ============================================================================== --- trunk/Code/defs.lisp (original) +++ trunk/Code/defs.lisp Sun Jul 15 19:27:07 2007 @@ -30,10 +30,13 @@ #:some #:every #:notany #:notevery ;; This one is internal. #+(or cmu scl sbcl) #:length) - (:export #:set #:bag #:map #:seq #:tuple + (:export #:collection #:set #:bag #:map #:seq #:tuple + #:wb-set #:wb-bag #:wb-map #:wb-seq #:dyn-tuple #:compare - #:empty? #:size #:arb #:member? #:multiplicity + #:empty? nonempty? #:size #:arb #:member? #: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. @@ -53,8 +56,8 @@ #:position #:position-if #:position-if-not #:remove #:remove-if #:remove-if-not #:substitute #:substitute-if #:substitute-if-not - #:convert - #:do-set #:do-bag #:do-map #:do-seq #:do-tuple + #:convert #:iterator + #:do-set #:do-bag #:do-bag-pairs #:do-map #:do-seq #:do-tuple #:adjoinf #:removef #:unionf #:def-tuple-key #:get-tuple-key #:tuple-merge #:fset-setup-readtable #:*fset-readtable* @@ -90,7 +93,8 @@ ;;; The seq implementation tries to use strings for leaf vectors when possible. ;;; In some Lisp implementations, there are two kinds of strings; but in some -;;; of these, the larger form takes as much space as a general vector. +;;; of these, the larger form takes as much space as a general vector, so nothing +;;; is to be saved by using it. (when (and (not (typep (make-string 1 :element-type 'extended-char) 'base-string)) (not (and (> (integer-length (1- char-code-limit)) 16) (< (integer-length most-positive-fixnum) 32)))) Modified: trunk/Code/fset.lisp ============================================================================== --- trunk/Code/fset.lisp (original) +++ trunk/Code/fset.lisp Sun Jul 15 19:27:07 2007 @@ -20,6 +20,13 @@ (defgeneric empty? (collection) (:documentation "Returns true iff the collection is empty.")) +;;; Wish I could think of a shorter name that would still be easy to remember. +(defun nonempty? (collection) + "Returns true iff the collection is not empty." + (not (empty? collection))) + +(declaim (inline nonempty?)) + (defgeneric size (collection) (:documentation "Returns the number of members in a set, seq, or bag, or the number of @@ -220,7 +227,7 @@ "Returns the range of the map, that is, the set of all values to which keys are mapped by the map.")) -(defgeneric map-merge (map1 map2 &optional val-fn) +(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 @@ -232,6 +239,16 @@ default for the new map is computed by calling `val-fn' on the symbol `fset:map-default' and the defaults for the two maps.")) +(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.")) + (defgeneric restrict (map set) (:documentation "Returns a map containing only those pairs of `map' whose keys are @@ -303,6 +320,119 @@ (:documentation "Returns the concatenation of `seq1' and `seq2'.")) + +;;; This is the opposite order from `cl:coerce', but I like it better, because I +;;; think the calls are easier to read with the type first. It's also consistent +;;; with `cl:concatenate' -- the inconsistency between `coerce' and `concatenate' +;;; has long bugged me. +(defgeneric convert (to-type collection &key) + (:documentation "Converts the collection to the specified type. Some methods may +take additional keyword arguments to further specify the kind of conversion.")) + +;;; 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)) + +;;; ================================================================================ +;;; Iterators + +;;; Rationale: +;;; () The use of a closure allows implementation genericity without requiring +;;; a CLOS dispatch on each iteration. +;;; () There are several ways to use this iterator. You can explicitly call +;;; either sense of the termination predicate -- both senses are provided as +;;; a stylistic convenience -- and then use the `:get' method separately. Or, +;;; if you are going for maximum speed, you can just use `:get'; if you know +;;; your collection doesn't contain `nil', you can just look at the first value +;;; to check termination; if it might contain `nil', you can use the extra value. +(defgeneric iterator (collection &key) + (:documentation + "Returns an iterator for the collection. (These are stateful iterators and +are not thread-safe; if you want a pure iterator, your best bet is to `convert' +the collection to a list.) The iterator is a closure of one argument; given +`:done?', it returns true iff the iterator is exhausted; given `:more?', it +returns true iff the iterator is _not_ exhausted. Given `:get', if the iterator +is not exhausted, it returns the next element (or pair, for a map, as two values), +with the second value (third, for a map) being true, and advances one element; if +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'. +(declaim (ftype (function (t &key &allow-other-keys) function) iterator)) + +;;; Iterators for the Lisp sequence types are useful for some generic operations +;;; (e.g. `some' and friends). +(defmethod iterator ((ls list) &key) + (lambda (op) + (ecase op + (:get (if ls (values (pop ls) t) + (values nil nil))) + (:done? (null ls)) + (:more? ls)))) + +(defmethod iterator ((vec vector) &key) + (let ((idx 0) + (len (length vec))) + ;; You might think this could be more elegantly done by defining a method on + ;; `simple-vector', but the CL standard does not require `simple-vector' to + ;; be a class (and it isn't in Allegro). + (if (simple-vector-p vec) + (lambda (op) + (ecase op + (:get (if (< idx len) (values (prog1 (svref vec idx) (incf idx)) t) + (values nil nil))) + (:done? (>= idx len)) + (:more? (< idx len)))) + (lambda (op) + (ecase op + (:get (if (< idx len) (values (prog1 (aref vec idx) (incf idx)) t) + (values nil nil))) + (:done? (>= idx len)) + (:more? (< idx len))))))) + +(defmethod iterator ((str string) &key) + (let ((idx 0) + (len (length str))) + ;; You might think this could be more elegantly done by defining a method on + ;; `simple-string', but the CL standard does not require `simple-string' to + ;; be a class (and it isn't in Allegro). + (if (simple-string-p str) + (lambda (op) + (ecase op + (:get (if (< idx len) (values (prog1 (schar str idx) (incf idx)) t) + (values nil nil))) + (:done? (>= idx len)) + (:more? (< idx len)))) + (lambda (op) + (ecase op + (:get (if (< idx len) (values (prog1 (char str idx) (incf idx)) t) + (values nil nil))) + (:done? (>= idx len)) + (:more? (< idx len))))))) + +;;; If an implementation has any more concrete subtypes of `sequence' besides +;;; those above, this method will cover them. Note, this is `cl:sequence' we're +;;; talking about here. +(defmethod iterator ((seq sequence) &key) + (let ((idx 0) + (len (length seq))) + (lambda (op) + (ecase op + (:get (if (< idx len) (values (prog1 (elt seq idx) (incf idx)) t) + (values nil nil))) + (:done? (>= idx len)) + (:more? (< idx len)))))) + +(def-gmap-arg-type :sequence (seq) + "Yields the elements of `seq', which can be of any CL sequence type as well +as an FSet seq, or a set or bag as well." + `((iterator ,seq) + #'(lambda (it) (declare (type function it)) (funcall it ':done?)) + #'(lambda (it) (declare (type function it)) (funcall it ':get)))) + +;;; ================================================================================ +;;; Generic versions of Common Lisp sequence functions + (defgeneric subseq (seq start &optional end) (:documentation "Returns the subsequence of `seq' from `start' (inclusive) to `end' (exclusive), @@ -337,17 +467,6 @@ (defmethod stable-sort ((s sequence) pred &key key) (cl:stable-sort s pred :key key)) - -;;; This is the opposite order from `cl:coerce', but I like it better, because I -;;; think the calls are easier to read with the type first. It's also consistent -;;; with `cl:concatenate' -- the inconsistency between `coerce' and `concatenate' -;;; has long bugged me. -(defgeneric convert (to-type collection &key) - (:documentation "Converts the collection to the specified type. Some methods may -take additional keyword arguments to further specify the kind of conversion.")) - -;;; Generic versions of `find' etc. - (defgeneric find (item collection &key key test) (:documentation "If `collection' is a Lisp sequence, this simply calls `cl:find'. On an FSet @@ -454,7 +573,7 @@ (defgeneric remove-if (pred collection &key key start end from-end count) (:documentation "If `collection' is a Lisp sequence, this simply calls `cl:remove-if'. -Also works on an FSet seq.")) +Also works on an FSet seq; but see `filter'.")) (defmethod remove-if (pred (s sequence) &rest keyword-args) (declare (dynamic-extent keyword-args)) @@ -463,7 +582,7 @@ (defgeneric remove-if-not (pred collection &key key) (:documentation "If `collection' is a Lisp sequence, this simply calls `cl:remove-if-not'. -Also works on an FSet seq.")) +Also works on an FSet seq; but see `filter'.")) (defmethod remove-if-not (pred (s sequence) &rest keyword-args) (declare (dynamic-extent keyword-args)) @@ -497,19 +616,62 @@ (declare (dynamic-extent keyword-args)) (apply #'cl:substitute-if-not newitem pred s keyword-args)) +;;; `(gmap :or ...)' is a bit faster. +(defun some (pred sequence0 &rest more-sequences) + "FSet generic version of `cl:some'." + (let ((it0 (iterator sequence0)) + (more-its (mapcar #'iterator more-sequences)) + (pred (coerce pred 'function))) + (do () + ((or (funcall it0 ':done?) + (gmap :or (lambda (it) (funcall it ':done?)) + (:list more-its))) + nil) + (let ((val (apply pred (funcall it0 ':get) (mapcar (lambda (it) (funcall it ':get)) + more-its)))) + (when val + (return val)))))) + +;;; `(gmap :and ...)' is a bit faster. +(defun every (pred sequence0 &rest more-sequences) + "FSet generic version of `cl:every'." + (let ((it0 (iterator sequence0)) + (more-its (mapcar #'iterator more-sequences)) + (pred (coerce pred 'function))) + (do () + ((or (funcall it0 ':done?) + (gmap :or (lambda (it) (funcall it ':done?)) + (:list more-its))) + t) + (let ((val (apply pred (funcall it0 ':get) (mapcar (lambda (it) (funcall it ':get)) + more-its)))) + (when (not val) + (return nil)))))) + +(defun notany (pred sequence0 &rest more-sequences) + "FSet generic version of `cl:notany'." + (not (apply #'some pred sequence0 more-sequences))) + +(defun notevery (pred sequence0 &rest more-sequences) + "FSet generic version of `cl:notevery'." + (not (apply #'every pred sequence0 more-sequences))) + ;;; ================================================================================ ;;; New names for a few existing CL functions ;;; The CL function is poorly (albeit traditionally) named, and we shadow the name. -(defun lastcons (x) - (cl:last x)) - -(defun head (x) - (car x)) - -(defun tail (x) - (cdr x)) +(defun lastcons (list) + "Returns the last cons of `list'. This is a renaming of the CL function `last'." + (cl:last list)) + +(defun head (list) + "Another name for the `car' operation on lists." + (car list)) + +(defun tail (list) + "Another name for the `cdr' operation on lists." + (cdr list)) (declaim (inline lastcons head tail)) @@ -581,86 +743,124 @@ with-last "(push-last seq val) --> (setf seq (with-last seq val))") -(define-modify-macro pop-first () - less-first - "(pop-first seq) --> (setf seq (less-first seq))") - -(define-modify-macro pop-last () - less-last - "(pop-last seq) --> (setf seq (less-last seq))") - +(defmacro pop-first (seq &environment env) + "Removes the first element from `seq' and returns it." + (let ((vars vals new setter getter (get-setf-expansion seq env))) + (unless (= 1 (length new)) + (error "Nonsensical `pop-first' form: ~S." `(pop-first ,seq))) + `(let* (,@(mapcar #'list vars vals) + (,(car new) ,getter)) + (prog1 + (first ,(car new)) + (setq ,(car new) (less-first ,(car new))) + ,setter)))) + +(defmacro pop-last (seq &environment env) + "Removes the last element from `seq' and returns it." + (let ((vars vals new setter getter (get-setf-expansion seq env))) + (unless (= 1 (length new)) + (error "Nonsensical `pop-last' form: ~S." `(pop-last ,seq))) + `(let* (,@(mapcar #'list vars vals) + (,(car new) ,getter)) + (prog1 + (last ,(car new)) + (setq ,(car new) (less-last ,(car new))) + ,setter)))) + ;;; ================================================================================ ;;; Sets -(defparameter *empty-set* (make-set nil)) +;;; Note that while many of these methods are defined on `wb-set', some of them are +;;; written generically; I have left these defined on `set'. Also, the assumption +;;; that `wb-set' is the default implementation is hard-coded at the moment. + + +(defstruct (wb-set + (:include set) + (:constructor make-wb-set (contents)) + (:predicate wb-set?) + (:print-function print-wb-set) + (:copier nil)) + "A class of functional sets represented as weight-balanced binary trees. This is +the default implementation of sets in FSet." + contents) + + +(defparameter *empty-wb-set* (make-wb-set nil)) (defun empty-set () - "Returns an empty set." - *empty-set*) + "Returns an empty set of the default implementation." + *empty-wb-set*) (declaim (inline empty-set)) -(defmethod empty? ((s set)) - (null (set-contents s))) +(defun empty-wb-set () + "Returns an empty wb-set." + *empty-wb-set*) +(declaim (inline empty-wb-set)) + +(defmethod empty? ((s wb-set)) + (null (wb-set-contents s))) -(defmethod size ((s set)) - (WB-Set-Tree-Size (set-contents s))) +(defmethod size ((s wb-set)) + (WB-Set-Tree-Size (wb-set-contents s))) -(defmethod set-size ((s set)) - (WB-Set-Tree-Size (set-contents s))) +(defmethod set-size ((s wb-set)) + (WB-Set-Tree-Size (wb-set-contents s))) -(defmethod arb ((s set)) - (let ((tree (set-contents s))) +(defmethod arb ((s wb-set)) + (let ((tree (wb-set-contents s))) (if tree (values (WB-Set-Tree-Arb tree) t) (values nil nil)))) -(defmethod member? (x (s set)) - (WB-Set-Tree-Member? (set-contents s) x)) +(defmethod member? (x (s wb-set)) + (WB-Set-Tree-Member? (wb-set-contents s) x)) -(defmethod lookup ((s set) key) - (WB-Set-Tree-Find-Equal (set-contents s) key)) +;;; Note, first value is `t' or `nil'. +(defmethod lookup ((s wb-set) key) + (WB-Set-Tree-Find-Equal (wb-set-contents s) key)) -(defmethod least ((s set)) - (let ((tree (set-contents s))) +(defmethod least ((s wb-set)) + (let ((tree (wb-set-contents s))) (if tree (values (WB-Set-Tree-Least tree) t) (values nil nil)))) -(defmethod greatest ((s set)) - (let ((tree (set-contents s))) +(defmethod greatest ((s wb-set)) + (let ((tree (wb-set-contents s))) (and tree (values (WB-Set-Tree-Greatest tree) t)))) -(defmethod with1 ((s set) value) - (let ((contents (set-contents s)) +(defmethod with1 ((s wb-set) value) + (let ((contents (wb-set-contents s)) ((new-contents (WB-Set-Tree-With contents value)))) (if (eq new-contents contents) s - (make-set new-contents)))) + (make-wb-set new-contents)))) -(defmethod less1 ((s set) value) - (let ((contents (set-contents s)) +(defmethod less1 ((s wb-set) value) + (let ((contents (wb-set-contents s)) ((new-contents (WB-Set-Tree-Less contents value)))) (if (eq new-contents contents) s - (make-set new-contents)))) + (make-wb-set new-contents)))) -(defmethod union ((s1 set) (s2 set)) - (make-set (WB-Set-Tree-Union (set-contents s1) (set-contents s2)))) +(defmethod union ((s1 wb-set) (s2 wb-set)) + (make-wb-set (WB-Set-Tree-Union (wb-set-contents s1) (wb-set-contents s2)))) -(defmethod intersection ((s1 set) (s2 set)) - (make-set (WB-Set-Tree-Intersect (set-contents s1) (set-contents s2)))) +(defmethod intersection ((s1 wb-set) (s2 wb-set)) + (make-wb-set (WB-Set-Tree-Intersect (wb-set-contents s1) (wb-set-contents s2)))) -(defmethod set-difference ((s1 set) (s2 set)) - (make-set (WB-Set-Tree-Diff (set-contents s1) (set-contents s2)))) +(defmethod set-difference ((s1 wb-set) (s2 wb-set)) + (make-wb-set (WB-Set-Tree-Diff (wb-set-contents s1) (wb-set-contents s2)))) -(defmethod set-difference-2 ((s1 set) (s2 set)) - (let ((newc1 newc2 (WB-Set-Tree-Diff-2 (set-contents s1) (set-contents s2)))) - (values (make-set newc1) (make-set newc2)))) +(defmethod set-difference-2 ((s1 wb-set) (s2 wb-set)) + (let ((newc1 newc2 (WB-Set-Tree-Diff-2 (wb-set-contents s1) (wb-set-contents s2)))) + (values (make-wb-set newc1) (make-wb-set newc2)))) -(defmethod subset? ((s1 set) (s2 set)) - (WB-Set-Tree-Subset? (set-contents s1) (set-contents s2))) +(defmethod subset? ((s1 wb-set) (s2 wb-set)) + (WB-Set-Tree-Subset? (wb-set-contents s1) (wb-set-contents s2))) -(defmethod compare ((s1 set) (s2 set)) - (WB-Set-Tree-Compare (set-contents s1) (set-contents s2))) +(defmethod compare ((s1 wb-set) (s2 wb-set)) + (WB-Set-Tree-Compare (wb-set-contents s1) (wb-set-contents s2))) (defgeneric internal-do-set (set elt-fn value-fn) (:documentation @@ -676,13 +876,16 @@ (internal-do-set ,set #'(lambda (,var) . ,body) #'(lambda () ,value)))) -(defmethod internal-do-set ((s set) elt-fn value-fn) +(defmethod internal-do-set ((s wb-set) elt-fn value-fn) (declare (optimize (speed 3) (safety 0)) (type function elt-fn value-fn)) ;; Expect Python note about "can't use known return convention" - (Do-WB-Set-Tree-Members (x (set-contents s) (funcall value-fn)) + (Do-WB-Set-Tree-Members (x (wb-set-contents s) (funcall value-fn)) (funcall elt-fn x))) +(defmethod iterator ((s wb-set) &key) + (Make-WB-Set-Tree-Iterator (wb-set-contents s))) + (defmethod filter ((pred function) (s set)) (set-filter pred s)) @@ -692,18 +895,20 @@ (defmethod filter ((pred map) (s set)) (set-filter pred s)) -(defmethod filter ((pred set) (s set)) - (intersection pred s)) - -(defmethod filter ((pred bag) (s set)) - (intersection pred s)) - (defun set-filter (pred s) (let ((result nil)) (do-set (x s) (when (@ pred x) (setq result (WB-Set-Tree-With result x)))) - (make-set result))) + (make-wb-set result))) + +;;; A set is another kind of boolean-valued map. +(defmethod filter ((pred set) (s set)) + (intersection pred s)) + +;;; A bag is yet another kind of boolean-valued map. +(defmethod filter ((pred bag) (s set)) + (intersection pred s)) (defmethod image ((fn function) (s set)) (set-image fn s)) @@ -724,7 +929,7 @@ (let ((result nil)) (do-set (x s) (setq result (WB-Set-Tree-With result (@ fn x)))) - (make-set result))) + (make-wb-set result))) (defmethod fold ((fn function) (s set) &optional (initial-value nil init?)) (set-fold fn s initial-value init?)) @@ -753,8 +958,14 @@ (defmethod convert ((to-type (eql 'set)) (s set) &key) s) -(defmethod convert ((to-type (eql 'bag)) (s set) &key) - (make-bag (WB-Set-Tree-To-Bag-Tree (set-contents s)))) +(defmethod convert ((to-type (eql 'wb-set)) (s wb-set) &key) + s) + +(defmethod convert ((to-type (eql 'bag)) (s wb-set) &key) + (make-wb-bag (WB-Set-Tree-To-Bag-Tree (wb-set-contents s)))) + +(defmethod convert ((to-type (eql 'wb-bag)) (s wb-set) &key) + (make-wb-bag (WB-Set-Tree-To-Bag-Tree (wb-set-contents s)))) (defmethod convert ((to-type (eql 'list)) (s set) &key) (declare (optimize (speed 3))) @@ -768,10 +979,10 @@ (convert 'seq (convert 'list s))) (defmethod convert ((to-type (eql 'set)) (l list) &key) - (make-set (WB-Set-Tree-From-List l))) + (make-wb-set (WB-Set-Tree-From-List l))) -(defmethod convert ((to-type (eql 'set)) (s seq) &key) - (make-set (WB-Seq-Tree-To-Set-Tree (seq-contents s)))) +(defmethod convert ((to-type (eql 'wb-set)) (l list) &key) + (make-wb-set (WB-Set-Tree-From-List l))) (defmethod find (item (s set) &key key test) (declare (optimize (speed 3) (safety 0))) @@ -855,167 +1066,203 @@ (let ((pred (coerce pred 'function))) (count-if #'(lambda (x) (not (funcall pred x))) s :key key))) -(defun print-set (set stream level) - (format stream "#{ ") - (let ((i 0)) - (do-set (x set) - (when (> i 0) - (format stream " ")) - (when (and *print-length* (>= i *print-length*)) - (format stream "...") - (return)) - (incf i) - (write x :stream stream :level (and *print-level* (- *print-level* level)))) - (when (> i 0) - (format stream " "))) - (format stream "}")) - -(gmap::def-gmap-arg-type :set (set) - `((convert 'list ,set) - #'null - #'car - #'cdr)) - -(gmap::def-gmap-res-type :set (&optional filterp) - `(nil #'WB-Set-Tree-With #'make-set ,filterp)) +(defun print-wb-set (set stream level) + (if (and *print-level* (>= level *print-level*)) + (format stream "#") + (progn + (format stream "#{ ") + (let ((i 0)) + (do-set (x set) + (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 x :stream stream))) + (when (> i 0) + (format stream " "))) + (format stream "}")))) + +(def-gmap-arg-type :set (set) + "Yields the elements of `set'." + `((iterator ,set) + #'(lambda (it) (declare (type function it)) (funcall it ':done?)) + #'(lambda (it) (declare (type function it)) (funcall it ':get)))) + +(def-gmap-res-type :set (&key filterp) + "Returns a set of the values, optionally filtered by `filterp'." + `(nil #'WB-Set-Tree-With #'make-wb-set ,filterp)) + + +;;; A bit faster than `:set', if you know it's a `wb-set'. +(def-gmap-arg-type :wb-set (set) + "Yields the elements of `set'." + `((Make-WB-Set-Tree-Iterator-Internal (wb-set-contents ,set)) + #'WB-Set-Tree-Iterator-Done? + #'WB-Set-Tree-Iterator-Get)) + +(def-gmap-res-type :wb-set (&key filterp) + "Returns a set of the values, optionally filtered by `filterp'." + `(nil #'WB-Set-Tree-With #'make-wb-set ,filterp)) ;;; ================================================================================ ;;; Bags -(defparameter *empty-bag* (make-bag nil)) +(defstruct (wb-bag + (:include bag) + (:constructor make-wb-bag (contents)) + (:predicate wb-bag?) + (:print-function print-wb-bag) + (:copier nil)) + "A class of functional bags (multisets) represented as weight-balanced binary +trees. This is the default implementation of bags in FSet." + contents) + + +(defparameter *empty-wb-bag* (make-wb-bag nil)) + +(defun empty-bag () + "Returns an empty bag of the default implementation." + *empty-wb-bag*) +(declaim (inline empty-bag)) + +(defun empty-wb-bag () + "Returns an empty wb-bag." + *empty-wb-bag*) +(declaim (inline empty-wb-bag)) -(defun empty-bag () *empty-bag*) +(defmethod empty? ((b wb-bag)) + (null (wb-bag-contents b))) -(defmethod empty? ((b bag)) - (null (bag-contents b))) - -(defmethod arb ((m bag)) - (let ((tree (bag-contents m))) +(defmethod arb ((m wb-bag)) + (let ((tree (wb-bag-contents m))) (if tree (let ((val mult (WB-Bag-Tree-Arb-Pair tree))) (values val mult t)) (values nil nil nil)))) -(defmethod member? (x (b bag)) - (plusp (WB-Bag-Tree-Multiplicity (bag-contents b) x))) +(defmethod member? (x (b wb-bag)) + (plusp (WB-Bag-Tree-Multiplicity (wb-bag-contents b) x))) -(defmethod lookup ((b bag) x) - (let ((mult value-found (WB-Bag-Tree-Multiplicity (bag-contents b) x))) +(defmethod lookup ((b wb-bag) x) + (let ((mult value-found (WB-Bag-Tree-Multiplicity (wb-bag-contents b) x))) (if (plusp mult) (values t value-found) (values nil nil)))) -(defmethod least ((b bag)) - (let ((tree (bag-contents b))) +(defmethod least ((b wb-bag)) + (let ((tree (wb-bag-contents b))) (if tree (let ((val mult (WB-Bag-Tree-Least-Pair tree))) (values val mult t)) (values nil nil nil)))) -(defmethod greatest ((m bag)) - (let ((tree (bag-contents m))) +(defmethod greatest ((m wb-bag)) + (let ((tree (wb-bag-contents m))) (if tree (let ((val mult (WB-Bag-Tree-Greatest-Pair tree))) (values val mult t)) (values nil nil nil)))) -(defmethod size ((b bag)) - (WB-Bag-Tree-Total-Count (bag-contents b))) +(defmethod size ((b wb-bag)) + (WB-Bag-Tree-Total-Count (wb-bag-contents b))) -(defmethod set-size ((b bag)) - (WB-Bag-Tree-Size (bag-contents b))) +(defmethod set-size ((b wb-bag)) + (WB-Bag-Tree-Size (wb-bag-contents b))) -(defmethod multiplicity (x (b bag)) - (WB-Bag-Tree-Multiplicity (bag-contents b) x)) +(defmethod multiplicity (x (b wb-bag)) + (WB-Bag-Tree-Multiplicity (wb-bag-contents b) x)) (defmethod multiplicity (x (s set)) (if (member? x s) 1 0)) -(defmethod with1 ((b bag) value) - (make-bag (WB-Bag-Tree-With (bag-contents b) value))) +(defmethod with1 ((b wb-bag) value) + (make-wb-bag (WB-Bag-Tree-With (wb-bag-contents b) value))) -(defmethod with2 ((b bag) value multiplicity) +(defmethod with2 ((b wb-bag) value multiplicity) (assert (and (integerp multiplicity) (not (minusp multiplicity)))) (if (zerop multiplicity) b - (make-bag (WB-Bag-Tree-With (bag-contents b) value multiplicity)))) + (make-wb-bag (WB-Bag-Tree-With (wb-bag-contents b) value multiplicity)))) -(defmethod less1 ((b bag) value) - (make-bag (WB-Bag-Tree-Less (bag-contents b) value))) +(defmethod less1 ((b wb-bag) value) + (make-wb-bag (WB-Bag-Tree-Less (wb-bag-contents b) value))) -(defmethod less2 ((b bag) value multiplicity) +(defmethod less2 ((b wb-bag) value multiplicity) (assert (and (integerp multiplicity) (not (minusp multiplicity)))) (if (zerop multiplicity) b - (make-bag (WB-Bag-Tree-Less (bag-contents b) value multiplicity)))) + (make-wb-bag (WB-Bag-Tree-Less (wb-bag-contents b) value multiplicity)))) -(defmethod union ((b1 bag) (b2 bag)) - (make-bag (WB-Bag-Tree-Union (bag-contents b1) (bag-contents b2)))) +(defmethod union ((b1 wb-bag) (b2 wb-bag)) + (make-wb-bag (WB-Bag-Tree-Union (wb-bag-contents b1) (wb-bag-contents b2)))) -(defmethod union ((s set) (b bag)) - (make-bag (WB-Bag-Tree-Union (WB-Set-Tree-To-Bag-Tree (set-contents s)) - (bag-contents b)))) +(defmethod union ((s wb-set) (b wb-bag)) + (make-wb-bag (WB-Bag-Tree-Union (WB-Set-Tree-To-Bag-Tree (wb-set-contents s)) + (wb-bag-contents b)))) -(defmethod union ((b bag) (s set)) - (make-bag (WB-Bag-Tree-Union (bag-contents b) - (WB-Set-Tree-To-Bag-Tree (set-contents s))))) +(defmethod union ((b wb-bag) (s wb-set)) + (make-wb-bag (WB-Bag-Tree-Union (wb-bag-contents b) + (WB-Set-Tree-To-Bag-Tree (wb-set-contents s))))) -(defmethod bag-sum ((b1 bag) (b2 bag)) - (make-bag (WB-Bag-Tree-Sum (bag-contents b1) (bag-contents b2)))) +(defmethod bag-sum ((b1 wb-bag) (b2 wb-bag)) + (make-wb-bag (WB-Bag-Tree-Sum (wb-bag-contents b1) (wb-bag-contents b2)))) -(defmethod bag-sum ((s set) (b bag)) - (make-bag (WB-Bag-Tree-Sum (WB-Set-Tree-To-Bag-Tree (set-contents s)) - (bag-contents b)))) +(defmethod bag-sum ((s wb-set) (b wb-bag)) + (make-wb-bag (WB-Bag-Tree-Sum (WB-Set-Tree-To-Bag-Tree (wb-set-contents s)) + (wb-bag-contents b)))) -(defmethod bag-sum ((b bag) (s set)) - (make-bag (WB-Bag-Tree-Sum (bag-contents b) - (WB-Set-Tree-To-Bag-Tree (set-contents s))))) +(defmethod bag-sum ((b wb-bag) (s wb-set)) + (make-wb-bag (WB-Bag-Tree-Sum (wb-bag-contents b) + (WB-Set-Tree-To-Bag-Tree (wb-set-contents s))))) -(defmethod intersection ((s1 bag) (s2 bag)) - (make-bag (WB-Bag-Tree-Intersect (bag-contents s1) (bag-contents s2)))) +(defmethod intersection ((s1 wb-bag) (s2 wb-bag)) + (make-wb-bag (WB-Bag-Tree-Intersect (wb-bag-contents s1) (wb-bag-contents s2)))) -(defmethod intersection ((s set) (b bag)) - (make-bag (WB-Set-Tree-Intersect (set-contents s) - (WB-Bag-Tree-To-Set-Tree (bag-contents b))))) +(defmethod intersection ((s wb-set) (b wb-bag)) + (make-wb-bag (WB-Set-Tree-Intersect (wb-set-contents s) + (WB-Bag-Tree-To-Set-Tree (wb-bag-contents b))))) -(defmethod intersection ((b bag) (s set)) - (make-bag (WB-Set-Tree-Intersect (WB-Bag-Tree-To-Set-Tree (bag-contents b)) - (set-contents s)))) +(defmethod intersection ((b wb-bag) (s wb-set)) + (make-wb-bag (WB-Set-Tree-Intersect (WB-Bag-Tree-To-Set-Tree (wb-bag-contents b)) + (wb-set-contents s)))) -(defmethod bag-product ((b1 bag) (b2 bag)) - (make-bag (WB-Bag-Tree-Product (bag-contents b1) (bag-contents b2)))) +(defmethod bag-product ((b1 wb-bag) (b2 wb-bag)) + (make-wb-bag (WB-Bag-Tree-Product (wb-bag-contents b1) (wb-bag-contents b2)))) -(defmethod bag-product ((s set) (b bag)) - (make-bag (WB-Bag-Tree-Product (WB-Set-Tree-To-Bag-Tree (set-contents s)) - (bag-contents b)))) +(defmethod bag-product ((s wb-set) (b wb-bag)) + (make-wb-bag (WB-Bag-Tree-Product (WB-Set-Tree-To-Bag-Tree (wb-set-contents s)) + (wb-bag-contents b)))) -(defmethod bag-product ((b bag) (s set)) - (make-bag (WB-Bag-Tree-Product (bag-contents b) - (WB-Set-Tree-To-Bag-Tree (set-contents s))))) +(defmethod bag-product ((b wb-bag) (s wb-set)) + (make-wb-bag (WB-Bag-Tree-Product (wb-bag-contents b) + (WB-Set-Tree-To-Bag-Tree (wb-set-contents s))))) -(defmethod bag-difference ((b1 bag) (b2 bag)) - (make-bag (WB-Bag-Tree-Diff (bag-contents b1) (bag-contents b2)))) +(defmethod bag-difference ((b1 wb-bag) (b2 wb-bag)) + (make-wb-bag (WB-Bag-Tree-Diff (wb-bag-contents b1) (wb-bag-contents b2)))) -(defmethod bag-difference ((s set) (b bag)) - (make-bag (WB-Bag-Tree-Diff (WB-Set-Tree-To-Bag-Tree (set-contents s)) - (bag-contents b)))) +(defmethod bag-difference ((s wb-set) (b wb-bag)) + (make-wb-bag (WB-Bag-Tree-Diff (WB-Set-Tree-To-Bag-Tree (wb-set-contents s)) + (wb-bag-contents b)))) -(defmethod bag-difference ((b bag) (s set)) - (make-bag (WB-Bag-Tree-Diff (bag-contents b) - (WB-Set-Tree-To-Bag-Tree (set-contents s))))) +(defmethod bag-difference ((b wb-bag) (s wb-set)) + (make-wb-bag (WB-Bag-Tree-Diff (wb-bag-contents b) + (WB-Set-Tree-To-Bag-Tree (wb-set-contents s))))) -(defmethod subbag? ((b1 bag) (b2 bag)) - (WB-Bag-Tree-Subbag? (bag-contents b1) (bag-contents b2))) +(defmethod subbag? ((b1 wb-bag) (b2 wb-bag)) + (WB-Bag-Tree-Subbag? (wb-bag-contents b1) (wb-bag-contents b2))) -(defmethod subbag? ((s set) (b bag)) - (WB-Bag-Tree-Subbag? (WB-Set-Tree-To-Bag-Tree (set-contents s)) (bag-contents b))) +(defmethod subbag? ((s wb-set) (b wb-bag)) + (WB-Bag-Tree-Subbag? (WB-Set-Tree-To-Bag-Tree (wb-set-contents s)) (wb-bag-contents b))) -(defmethod subbag? ((b bag) (s set)) - (WB-Bag-Tree-Subbag? (bag-contents b) (WB-Set-Tree-To-Bag-Tree (set-contents s)))) +(defmethod subbag? ((b wb-bag) (s wb-set)) + (WB-Bag-Tree-Subbag? (wb-bag-contents b) (WB-Set-Tree-To-Bag-Tree (wb-set-contents s)))) -(defmethod compare ((b1 bag) (b2 bag)) - (WB-Bag-Tree-Compare (bag-contents b1) (bag-contents b2))) +(defmethod compare ((b1 wb-bag) (b2 wb-bag)) + (WB-Bag-Tree-Compare (wb-bag-contents b1) (wb-bag-contents b2))) -(defgeneric internal-do-bag (bag elt-fn value-fn) +(defgeneric internal-do-bag-pairs (bag elt-fn value-fn) (:documentation "Calls `elt-fn' on successive pairs of the bag (the second argument is the multiplicity); when done, calls `value-fn' on no arguments and returns the @@ -1023,21 +1270,37 @@ different bag implementations; it is not for public use. `elt-fn' and `value-fn' must be function objects, not symbols.")) -(defmacro do-bag ((value-var mult-var bag &optional value) - &body body) +(defmacro do-bag-pairs ((value-var mult-var bag &optional value) + &body body) "For each member of `bag', binds `value-var' and `mult-var' to the member and its multiplicity respectively, and executes `body'. When done, returns `value'." `(block nil - (internal-do-bag ,bag #'(lambda (,value-var ,mult-var) . ,body) - #'(lambda () ,value)))) + (internal-do-bag-pairs ,bag #'(lambda (,value-var ,mult-var) . ,body) + #'(lambda () ,value)))) + +(defmacro do-bag ((value-var bag &optional value) + &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-"))) + `(block nil + (internal-do-bag-pairs ,bag #'(lambda (,value-var ,mult-var) + (dotimes (i ,mult-var) + . ,body)) + #'(lambda () ,value))))) -(defmethod internal-do-bag ((b bag) elt-fn value-fn) +(defmethod internal-do-bag-pairs ((b wb-bag) elt-fn value-fn) (declare (optimize (speed 3) (safety 0)) (type function elt-fn value-fn)) ;; Expect Python note about "can't use known return convention" - (Do-WB-Bag-Tree-Pairs (x n (bag-contents b) (funcall value-fn)) + (Do-WB-Bag-Tree-Pairs (x n (wb-bag-contents b) (funcall value-fn)) (funcall elt-fn x n))) +(defmethod iterator ((b wb-bag) &key pairs?) + (if pairs? + (Make-WB-Bag-Tree-Pair-Iterator (wb-bag-contents b)) + (Make-WB-Bag-Tree-Iterator (wb-bag-contents b)))) + (defmethod filter ((pred function) (b bag)) (bag-filter pred b)) @@ -1047,19 +1310,19 @@ (defmethod filter ((pred map) (b bag)) (bag-filter pred b)) +(defun bag-filter (pred b) + (let ((result nil)) + (do-bag-pairs (x n b) + (when (@ pred x) + (setq result (WB-Bag-Tree-With result x n)))) + (make-wb-bag result))) + (defmethod filter ((pred set) (b bag)) (bag-product (convert pred 'bag) b)) (defmethod filter ((pred bag) (b bag)) (bag-filter pred b)) -(defun bag-filter (pred b) - (let ((result nil)) - (do-bag (x n b) - (when (@ pred x) - (setq result (WB-Bag-Tree-With result x n)))) - (make-bag result))) - (defmethod image ((fn function) (b bag)) (bag-image fn b)) @@ -1077,9 +1340,9 @@ (defun bag-image (fn b) (let ((result nil)) - (do-bag (x n b) + (do-bag-pairs (x n b) (setq result (WB-Bag-Tree-With result (@ fn x) n))) - (make-bag result))) + (make-wb-bag result))) (defmethod fold ((fn function) (s bag) &optional (initial-value nil init?)) (bag-fold fn s initial-value init?)) @@ -1093,15 +1356,14 @@ (type function fn)) (if init? (let ((result initial-value)) - (do-bag (x n s) - (dotimes (i n) - (setq result (funcall fn result x)))) + (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 (x n s) + (do-bag-pairs (x n s) (if first? (setq result x first? nil) (setq result (funcall fn result x))) @@ -1112,19 +1374,30 @@ (defmethod convert ((to-type (eql 'bag)) (b bag) &key) b) +(defmethod convert ((to-type (eql 'wb-bag)) (b wb-bag) &key) + b) + +(defmethod convert ((to-type (eql 'set)) (b wb-bag) &key) + (make-wb-set (WB-Bag-Tree-To-Set-Tree (wb-bag-contents b)))) + +(defmethod convert ((to-type (eql 'wb-set)) (b wb-bag) &key) + (make-wb-set (WB-Bag-Tree-To-Set-Tree (wb-bag-contents b)))) + (defmethod convert ((to-type (eql 'list)) (b bag) &key) (declare (optimize (speed 3) (safety 0))) (let ((result nil)) - (do-bag (value count b) + (do-bag (value b) ;; Expect 2 Python notes about generic arithmetic. - (dotimes (i count) - (push value result))) + (push value result)) (nreverse result))) +(defmethod convert ((to-type (eql 'seq)) (b bag) &key) + (convert 'seq (convert 'list b))) + (defmethod convert ((to-type (eql 'alist)) (b bag) &key) (declare (optimize (speed 3) (safety 0))) (let ((result nil)) - (do-bag (value count b) + (do-bag-pairs (value count b) (push (cons value count) result)) (nreverse result))) @@ -1140,12 +1413,12 @@ (error "Cdr of pair is not a positive integer: ~S" pr)) (setq contents (WB-Bag-Tree-With contents (car pr) (cdr pr)))) - (make-bag contents)) + (make-wb-bag contents)) ;; &&& Improve me someday (let ((contents nil)) (dolist (x l) (setq contents (WB-Bag-Tree-With contents x))) - (make-bag contents)))) + (make-wb-bag contents)))) (defmethod find (item (b bag) &key key test) (declare (optimize (speed 3) (safety 0))) @@ -1153,17 +1426,17 @@ (let ((key (coerce key 'function))) (if test (let ((test (coerce test 'function))) - (do-bag (x n b nil) + (do-bag-pairs (x n b nil) (declare (ignore n)) (when (funcall test item (funcall key x)) (return x)))) - (do-bag (x n b nil) - (declare (ignore n)) + (do-bag-pairs (x n b nil) + (declare (ignore n)) (when (equal? item (funcall key x)) (return x))))) (if (and test (not (or (eq test 'equal?) (eq test #'equal?)))) (let ((test (coerce test 'function))) - (do-bag (x n b nil) + (do-bag-pairs (x n b nil) (declare (ignore n)) (when (funcall test item x) (return x)))) @@ -1176,11 +1449,11 @@ (let ((pred (coerce pred 'function))) (if key (let ((key (coerce key 'function))) - (do-bag (x n b nil) + (do-bag-pairs (x n b nil) (declare (ignore n)) (when (funcall pred (funcall key x)) (return x)))) - (do-bag (x n b nil) + (do-bag-pairs (x n b nil) (declare (ignore n)) (when (funcall pred x) (return x)))))) @@ -1197,15 +1470,15 @@ (let ((key (coerce key 'function))) (if test (let ((test (coerce test 'function))) - (do-bag (x n b total) + (do-bag-pairs (x n b total) (when (funcall test item (funcall key x)) (incf total n)))) - (do-bag (x n b total) + (do-bag-pairs (x n b total) (when (equal? item (funcall key x)) (incf total n))))) (if (and test (not (or (eq test 'equal?) (eq test #'equal?)))) (let ((test (coerce test 'function))) - (do-bag (x n b total) + (do-bag-pairs (x n b total) (when (funcall test item x) (incf total n)))) (multiplicity item b))))) @@ -1216,11 +1489,11 @@ (total 0)) (if key (let ((key (coerce key 'function))) - (do-bag (x n b nil) + (do-bag-pairs (x n b nil) (when (funcall pred (funcall key x)) (incf total n)) total)) - (do-bag (x n b nil) + (do-bag-pairs (x n b nil) (when (funcall pred x) (incf total n)) total)))) @@ -1230,95 +1503,151 @@ (let ((pred (coerce pred 'function))) (count-if #'(lambda (x) (not (funcall pred x))) s :key key))) -(defun print-bag (bag stream level) - (format stream "#{% ") - (let ((i 0)) - (do-bag (x n bag) - (when (> i 0) - (format stream " ")) - (when (and *print-length* (>= i *print-length*)) - (format stream "...") - (return)) - (incf i) - (if (> n 1) - (progn - (format stream "#%") - (write `(,x ,n) :stream stream - :level (and *print-level* (- *print-level* level)))) - (write x :stream stream :level (and *print-level* (- *print-level* level))))) - (when (> i 0) - (format stream " "))) - (format stream "%}")) - - -;;; Note that this yields each element potentially multiple times. (GMap needs -;;; a way for an arg type to return pairs, other than as conses or lists.) -(gmap::def-gmap-arg-type :bag (bag) - `((convert 'list ,bag) - #'null - #'car - #'cdr)) - -(gmap::def-gmap-res-type :bag (&optional filterp) - `(nil #'WB-Bag-Tree-With #'make-bag ,filterp)) +(defun print-wb-bag (bag stream level) + (if (and *print-level* (>= level *print-level*)) + (format stream "#") + (progn + (format stream "#{% ") + (let ((i 0)) + (do-bag-pairs (x n bag) + (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*)))) + (if (> n 1) + (progn + (format stream "#%") + (write `(,x ,n) :stream stream)) + (write x :stream stream)))) + (when (> i 0) + (format stream " "))) + (format stream "%}")))) + + +(def-gmap-arg-type :bag (bag) + "Yields each element of `bag', as many times as its multiplicity." + `((iterator ,bag) + #'(lambda (it) (declare (type function it)) (funcall it ':done?)) + #'(lambda (it) (declare (type function it)) (funcall it ':get)))) + +(def-gmap-arg-type :bag-pairs (bag) + "Yields each element of `bag' and its multiplicity as two values." + `((iterator ,bag :pairs? t) + #'(lambda (it) (declare (type function it)) (funcall it ':done?)) + (:values 2 #'(lambda (it) (declare (type function it)) (funcall it ':get))))) + +(def-gmap-arg-type :wb-bag (bag) + "Yields each element of `bag', as many times as its multiplicity." + `((Make-WB-Bag-Tree-Iterator-Internal (wb-bag-contents ,bag)) + #'WB-Bag-Tree-Iterator-Done? + #'WB-Bag-Tree-Iterator-Get)) + +(def-gmap-arg-type :wb-bag-pairs (bag) + "Yields each element of `bag' and its multiplicity as two values." + `((Make-WB-Bag-Tree-Pair-Iterator-Internal (wb-bag-contents ,bag)) + #'WB-Bag-Tree-Pair-Iterator-Done? + (:values 2 #'WB-Bag-Tree-Pair-Iterator-Get))) + +(def-gmap-res-type :bag (&key filterp) + "Returns a bag of the values, optionally filtered by `filterp'." + `(nil #'WB-Bag-Tree-With #'make-wb-bag ,filterp)) + +(def-gmap-res-type :bag-pairs (&key filterp) + "Consumes two values from the mapped function; returns a bag of the pairs. +Note that `filterp', if supplied, must take two arguments." + `(nil (:consume 2 #'WB-Bag-Tree-With) #'make-wb-bag ,filterp)) + +(def-gmap-res-type :wb-bag (&key filterp) + "Returns a wb-bag of the values, optionally filtered by `filterp'." + `(nil #'WB-Bag-Tree-With #'make-wb-bag ,filterp)) + +(def-gmap-res-type :wb-bag-pairs (&key filterp) + "Consumes two values from the mapped function; returns a wb-bag of the pairs. +Note that `filterp', if supplied, must take two arguments." + `(nil (:consume 2 #'WB-Bag-Tree-With) #'make-wb-bag ,filterp)) ;;; ================================================================================ ;;; Maps -(defparameter *empty-map* (make-map nil)) +(defstruct (wb-map + (:include map) + (:constructor make-wb-map (contents &optional default)) + (:predicate wb-map?) + (:print-function print-wb-map) + (:copier nil)) + "A class of functional maps represented as weight-balanced binary trees. This is +the default implementation of maps in FSet." + contents) + + +(defparameter *empty-wb-map* (make-wb-map nil)) (defun empty-map (&optional default) - (if default (make-map nil default) - *empty-map*)) + "Returns an empty map of the default implementation." + (if default (make-wb-map nil default) + *empty-wb-map*)) (declaim (inline empty-map)) -(defmethod empty? ((m map)) - (null (map-contents m))) +(defun empty-wb-map (&optional default) + "Returns an empty wb-map." + (if default (make-wb-map nil default) + *empty-wb-map*)) +(declaim (inline empty-wb-map)) -(defmethod arb ((m map)) - (let ((tree (map-contents m))) +(defmethod empty? ((m wb-map)) + (null (wb-map-contents m))) + +(defmethod arb ((m wb-map)) + (let ((tree (wb-map-contents m))) (if tree (let ((key val (WB-Map-Tree-Arb-Pair tree))) (values key val t)) (values nil nil nil)))) -(defmethod least ((m map)) - (let ((tree (map-contents m))) +(defmethod least ((m wb-map)) + (let ((tree (wb-map-contents m))) (if tree (let ((key val (WB-Map-Tree-Least-Pair tree))) (values key val t)) (values nil nil nil)))) -(defmethod greatest ((m map)) - (let ((tree (map-contents m))) +(defmethod greatest ((m wb-map)) + (let ((tree (wb-map-contents m))) (if tree (let ((key val (WB-Map-Tree-Greatest-Pair tree))) (values key val t)) (values nil nil nil)))) -(defmethod size ((m map)) - (WB-Map-Tree-Size (map-contents m))) +(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 map) key) - (let ((val? val (WB-Map-Tree-Lookup (map-contents m) key))) +(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 map) key value) - (make-map (WB-Map-Tree-With (map-contents m) key value) +(defmethod with2 ((m wb-map) key value) + (make-wb-map (WB-Map-Tree-With (wb-map-contents m) key value) (map-default m))) -(defmethod less1 ((m map) key) - (make-map (WB-Map-Tree-Less (map-contents m) key) +(defmethod less1 ((m wb-map) key) + (make-wb-map (WB-Map-Tree-Less (wb-map-contents m) key) (map-default m))) -(defmethod domain ((m map)) +(defmethod domain ((m wb-map)) ;; &&& Cache this? It's pretty fast anyway. - (make-set (WB-Map-Tree-Domain (map-contents m)))) + (make-wb-set (WB-Map-Tree-Domain (wb-map-contents m)))) -(defmethod compare ((map1 map) (map2 map)) - (WB-Map-Tree-Compare (map-contents map1) (map-contents map2))) +(defmethod compare ((map1 wb-map) (map2 wb-map)) + (WB-Map-Tree-Compare (wb-map-contents map1) (wb-map-contents map2))) (defgeneric internal-do-map (map elt-fn value-fn) (:documentation @@ -1336,13 +1665,16 @@ #'(lambda (,key-var ,value-var) . ,body) #'(lambda () ,value)))) -(defmethod internal-do-map ((m map) elt-fn value-fn) +(defmethod internal-do-map ((m wb-map) elt-fn value-fn) (declare (optimize (speed 3) (safety 0)) (type function elt-fn value-fn)) ;; Expect Python note about "can't use known return convention" - (Do-WB-Map-Tree-Pairs (x y (map-contents m) (funcall value-fn)) + (Do-WB-Map-Tree-Pairs (x y (wb-map-contents m) (funcall value-fn)) (funcall elt-fn x y))) +(defmethod iterator ((m wb-map) &key) + (Make-WB-Map-Tree-Iterator (wb-map-contents m))) + (defmethod filter ((pred function) (m map)) (map-filter pred m)) @@ -1363,7 +1695,7 @@ (do-map (x y m) (when (@ pred x y) (setq result (WB-Map-Tree-With result x y)))) - (make-map result (map-default m)))) + (make-wb-map result (map-default m)))) (defmethod image ((fn function) (m map)) (map-image fn m)) @@ -1376,7 +1708,7 @@ (do-map (x y m) (let ((new-x new-y (funcall fn x y))) (setq result (WB-Map-Tree-With result new-x new-y)))) - (make-map result (map-default m)))) + (make-wb-map result (map-default m)))) (defmethod range ((m map)) ;;; &&& Also a candidate for caching -- but the operation isn't terribly common. @@ -1384,33 +1716,41 @@ (do-map (key val m) (declare (ignore key)) (setq s (WB-Set-Tree-With s val))) - (make-set s))) + (make-wb-set s))) -(defmethod map-merge ((map1 map) (map2 map) +(defmethod map-union ((map1 wb-map) (map2 wb-map) &optional (val-fn #'(lambda (k v1 v2) (declare (ignore k v1)) v2))) - (make-map (WB-Map-Tree-Merge (map-contents map1) (map-contents map2) - (coerce val-fn 'function)) - (funcall val-fn nil (map-default map1) (map-default map2)))) + (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)))) + +(defmethod map-intersection ((map1 wb-map) (map2 wb-map) + &optional (val-fn #'(lambda (k v1 v2) + (declare (ignore k v1)) + (values v2 t)))) + (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)))) -(defmethod restrict ((m map) (s set)) - (make-map (WB-Map-Tree-Restrict (map-contents m) (set-contents s)) +(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))) -(defmethod restrict-not ((m map) (s set)) - (make-map (WB-Map-Tree-Restrict-Not (map-contents m) (set-contents s)) +(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))) -(defmethod compose ((map1 map) (map2 map)) - (let ((tree2 (map-contents map2)) +(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-map result (if new-default? new-default (map-default map2)))))) + (make-wb-map result (if new-default? new-default (map-default map2)))))) (defmethod compose ((m map) (fn function)) (map-fn-compose m fn)) @@ -1424,33 +1764,39 @@ (let ((result nil)) (do-map (key val m) (setq result (WB-Map-Tree-With result key (funcall fn val)))) - (make-map result (funcall fn (map-default m))))) + (make-wb-map result (funcall fn (map-default m))))) (defmethod convert ((to-type (eql 'map)) (m map) &key) m) -(defmethod convert ((to-type (eql 'list)) (m map) &key) - (let ((result nil)) +(defmethod convert ((to-type (eql 'wb-map)) (m wb-map) &key) + m) + +(defmethod convert ((to-type (eql 'list)) (m map) &key (pair-fn #'cons)) + (let ((result nil) + (pair-fn (coerce pair-fn 'function))) (do-map (key val m) - (push (cons key val) result)) + (push (funcall pair-fn key val) result)) (nreverse result))) -(defmethod convert ((to-type (eql 'seq)) (m map) &key) - (convert 'seq (convert 'list m))) +(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 'set)) (m map) &key pair-fn) - (let ((result nil)) +(defmethod convert ((to-type (eql 'set)) (m map) &key (pair-fn #'cons)) + (let ((result nil) + (pair-fn (coerce pair-fn 'function))) (do-map (key val m) - (setq result (WB-Set-Tree-With result (if pair-fn - (funcall pair-fn key val) - (list key val))))) - (make-set result))) + (setq result (WB-Set-Tree-With result (funcall pair-fn key val)))) + (make-wb-set result))) -(defmethod convert ((to-type (eql 'map)) (alist list) &key) - (let ((m nil)) +(defmethod convert ((to-type (eql 'map)) (alist list) + &key (key-fn #'car) (value-fn #'cdr)) + (let ((m nil) + (key-fn (coerce key-fn 'function)) + (value-fn (coerce value-fn 'function))) (dolist (pr alist) - (setq m (WB-Map-Tree-With m (car pr) (cdr pr)))) - (make-map m))) + (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))) @@ -1469,7 +1815,7 @@ (do-map (x y m nil) (when (funcall test item x) (return (values x y))))) - (let ((val? val (WB-Map-Tree-Lookup (map-contents m) item))) + (let ((val? val (lookup m item))) (if val? (values item val) (values nil nil)))))) @@ -1513,7 +1859,7 @@ (declare (ignore y)) (when (funcall test item x) (incf total)))) - (let ((val? val (WB-Map-Tree-Lookup (map-contents m) item))) + (let ((val? val (lookup m item))) (declare (ignore val)) (if val? 1 0)))))) @@ -1540,104 +1886,149 @@ (let ((pred (coerce pred 'function))) (count-if #'(lambda (x) (not (funcall pred x))) m :key key))) -(defun print-map (map stream level) - (format stream "#{| ") - (let ((i 0)) - (do-map (x y map) - (when (> i 0) - (format stream " ")) - (when (and *print-length* (>= i *print-length*)) - (format stream "...") - (return)) - (incf i) - (format stream "(") - (write x :stream stream :level (and *print-level* (- *print-level* level))) - (format stream " ") - (write y :stream stream :level (and *print-level* (- *print-level* level))) - (format stream ")")) - (when (> i 0) - (format stream " "))) - (format stream "|}") - (let ((default (map-default map))) - (when default - (format stream "/~A" default)))) +(defun print-wb-map (map stream level) + (if (and *print-level* (>= level *print-level*)) + (format stream "#") + (progn + (format stream "#{| ") + (let ((i 0)) + (do-map (x y map) + (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 "|}") + (let ((default (map-default map))) + (when default + (format stream "/~A" default)))))) + + +(def-gmap-arg-type :map (map) + "Yields each pair of `map', as two values." + `((iterator ,map) + #'(lambda (it) (declare (type function it)) (funcall it ':done?)) + (:values 2 #'(lambda (it) (declare (type function it)) (funcall it ':get))))) + +(def-gmap-arg-type :wb-map (map) + "Yields each pair of `map', as two values." + `((Make-WB-Map-Tree-Iterator-Internal (wb-map-contents ,map)) + #'WB-Map-Tree-Iterator-Done? + (:values 2 #'WB-Map-Tree-Iterator-Get))) + +(def-gmap-res-type :map (&key filterp) + "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)) + +(def-gmap-res-type :wb-map (&key filterp) + "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)) ;;; ================================================================================ ;;; Seqs -(defparameter *empty-seq* (make-seq nil)) - -(defun empty-seq () *empty-seq*) +(defstruct (wb-seq + (:include seq) + (:constructor make-wb-seq (contents)) + (:predicate wb-seq?) + (:print-function print-wb-seq) + (:copier nil)) + "A class of functional seqs (sequences, but we use the short name to avoid +confusion with `cl:sequence') represented as weight-balanced binary trees. +This is the default implementation of seqs in FSet." + contents) + + +(defparameter *empty-wb-seq* (make-wb-seq nil)) + +(defun empty-seq () + "Returns an empty seq of the default implementation." + *empty-wb-seq*) (declaim (inline empty-seq)) -(defmethod empty? ((s seq)) - (null (seq-contents s))) +(defun empty-wb-seq () + "Returns an empty wb-seq." + *empty-wb-seq*) +(declaim (inline empty-wb-seq)) + +(defmethod empty? ((s wb-seq)) + (null (wb-seq-contents s))) -(defmethod size ((s seq)) - (WB-Seq-Tree-Size (seq-contents s))) +(defmethod size ((s wb-seq)) + (WB-Seq-Tree-Size (wb-seq-contents s))) -(defmethod lookup ((s seq) key) - (let ((val? val (WB-Seq-Tree-Subscript (seq-contents s) key))) +(defmethod lookup ((s wb-seq) key) + (let ((val? val (WB-Seq-Tree-Subscript (wb-seq-contents s) key))) (values val val?))) -(defmethod first ((s seq)) - (let ((val? val (WB-Seq-Tree-Subscript (seq-contents s) 0))) +(defmethod first ((s wb-seq)) + (let ((val? val (WB-Seq-Tree-Subscript (wb-seq-contents s) 0))) (values val val?))) -(defmethod last ((s seq)) - (let ((tree (seq-contents s)) +(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?))) -(defmethod with-first ((s seq) val) - (make-seq (WB-Seq-Tree-Insert (seq-contents s) 0 val))) +(defmethod with-first ((s wb-seq) val) + (make-wb-seq (WB-Seq-Tree-Insert (wb-seq-contents s) 0 val))) -(defmethod with-last ((s seq) val) - (let ((tree (seq-contents s))) - (make-seq (WB-Seq-Tree-Insert tree (WB-Seq-Tree-Size tree) val)))) - -(defmethod less-first ((s seq)) - (let ((tree (seq-contents s))) - (make-seq (WB-Seq-Tree-Subseq tree 1 (WB-Seq-Tree-Size tree))))) - -(defmethod less-last ((s seq)) - (let ((tree (seq-contents s))) - (make-seq (WB-Seq-Tree-Subseq tree 0 (1- (WB-Seq-Tree-Size tree)))))) +(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)))) + +(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))))) + +(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)))))) -(defmethod with2 ((s seq) index val) - (let ((tree (seq-contents s)) +(defmethod with2 ((s wb-seq) index val) + (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-seq (if (= index size) + (make-wb-seq (if (= index size) (WB-Seq-Tree-Insert tree index val) (WB-Seq-Tree-With tree index val))))) -(defmethod insert ((s seq) idx val) - (let ((tree (seq-contents 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-seq (WB-Seq-Tree-Insert tree idx val)))) + (make-wb-seq (WB-Seq-Tree-Insert tree idx val)))) -(defmethod less1 ((s seq) idx) - (let ((tree (seq-contents s))) +(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-seq (WB-Seq-Tree-Remove tree idx)))) + (make-wb-seq (WB-Seq-Tree-Remove tree idx)))) -(defmethod concat ((s1 seq) (s2 seq)) - (make-seq (WB-Seq-Tree-Concat (seq-contents s1) (seq-contents s2)))) +(defmethod concat ((s1 wb-seq) (s2 wb-seq)) + (make-wb-seq (WB-Seq-Tree-Concat (wb-seq-contents s1) (wb-seq-contents s2)))) -(defmethod subseq ((s seq) start &optional end) - (let ((tree (seq-contents s))) - (make-seq (WB-Seq-Tree-Subseq tree start (or end (WB-Seq-Tree-Size tree)))))) +(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)))) -(defmethod reverse ((s seq)) - (make-seq (WB-Seq-Tree-Reverse (seq-contents s)))) +(defmethod reverse ((s wb-seq)) + (make-wb-seq (WB-Seq-Tree-Reverse (wb-seq-contents s)))) (defmethod sort ((s seq) pred &key key) (convert 'seq (cl:sort (convert 'vector s) pred :key key))) @@ -1648,20 +2039,45 @@ (defmethod convert ((to-type (eql 'seq)) (s seq) &key) s) +(defmethod convert ((to-type (eql 'wb-seq)) (s wb-seq) &key) + s) + (defmethod convert ((to-type (eql 'seq)) (vec vector) &key) - (make-seq (WB-Seq-Tree-From-Vector vec))) + (make-wb-seq (WB-Seq-Tree-From-Vector vec))) + +(defmethod convert ((to-type (eql 'wb-seq)) (vec vector) &key) + (make-wb-seq (WB-Seq-Tree-From-Vector vec))) -(defmethod convert ((to-type (eql 'vector)) (s seq) &key) - (WB-Seq-Tree-To-Vector (seq-contents s))) +(defmethod convert ((to-type (eql 'vector)) (s wb-seq) &key) + (WB-Seq-Tree-To-Vector (wb-seq-contents s))) (defmethod convert ((to-type (eql 'seq)) (l list) &key) - (make-seq (WB-Seq-Tree-From-List l))) + (make-wb-seq (WB-Seq-Tree-From-List l))) + +(defmethod convert ((to-type (eql 'wb-seq)) (l list) &key) + (make-wb-seq (WB-Seq-Tree-From-List l))) + +(defmethod convert ((to-type (eql 'list)) (s wb-seq) &key) + (WB-Seq-Tree-To-List (wb-seq-contents 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)) (s wb-seq) &key) + (make-wb-set (WB-Seq-Tree-To-Set-Tree (wb-seq-contents s)))) + +(defmethod convert ((to-type (eql 'wb-set)) (s wb-seq) &key) + (make-wb-set (WB-Seq-Tree-To-Set-Tree (wb-seq-contents s)))) -(defmethod convert ((to-type (eql 'list)) (s seq) &key) - (WB-Seq-Tree-To-List (seq-contents s))) +(defmethod convert ((to-type (eql 'wb-seq)) (b bag) &key) + (convert 'wb-seq (convert 'list b))) -(defmethod compare ((s1 seq) (s2 seq)) - (WB-Seq-Tree-Compare (seq-contents s1) (seq-contents s2))) +(defmethod convert ((to-type (eql 'wb-seq)) (m map) &key (pair-fn #'cons)) + (convert 'wb-seq (convert 'list m :pair-fn pair-fn))) + +(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 &key start end from-end?) @@ -1688,17 +2104,20 @@ ,@(and end? `(:end ,end)) ,@(and from-end?? `(:from-end? ,from-end?))))) -(defmethod internal-do-seq ((s seq) elt-fn value-fn +(defmethod internal-do-seq ((s wb-seq) elt-fn value-fn &key (start 0) - (end (WB-Seq-Tree-Size (seq-contents s))) + (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 (seq-contents s) start end from-end? + (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)) (declare (optimize (speed 3) (safety 0))) (do-seq (y s) @@ -1729,7 +2148,7 @@ ;; insist `fn' be a function instead of using `@'. (when (funcall fn x) (push x result))) - (make-seq (WB-Seq-Tree-From-List (nreverse result))))) + (make-wb-seq (WB-Seq-Tree-From-List (nreverse result))))) (defmethod image ((fn function) (s seq)) (seq-image fn s)) @@ -1756,7 +2175,7 @@ ;; 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-seq (WB-Seq-Tree-From-List (nreverse 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?)) @@ -2007,27 +2426,47 @@ (substitute-if newitem #'(lambda (x) (not (funcall pred x))) s :key key :start start :end end :from-end from-end :count count))) -(defun print-seq (seq stream level) - (format stream "#[ ") - (let ((i 0)) - (do-seq (x seq) - (when (> i 0) - (format stream " ")) - (when (and *print-length* (>= i *print-length*)) - (format stream "...") - (return)) - (incf i) - (write x :stream stream :level (and *print-level* (- *print-level* level)))) - (when (> i 0) - (format stream " "))) - (format stream "]")) - -(gmap::def-gmap-arg-type :seq (seq) - `((convert 'list ,seq) - #'null - #'car - #'cdr)) +(defun print-wb-seq (seq stream level) + (if (and *print-level* (>= level *print-level*)) + (format stream "#") + (progn + (format stream "#[ ") + (let ((i 0)) + (do-seq (x seq) + (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 x :stream stream))) + (when (> i 0) + (format stream " "))) + (format stream "]")))) + +(def-gmap-arg-type :seq (seq) + "Yields the elements of `seq'." + `((iterator ,seq) + #'(lambda (it) (declare (type function it)) (funcall it ':done?)) + #'(lambda (it) (declare (type function it)) (funcall it ':get)))) + +(def-gmap-arg-type :wb-seq (seq) + "Yields the elements of `seq'." + `((Make-WB-Seq-Tree-Iterator-Internal (wb-seq-contents ,seq)) + #'WB-Seq-Tree-Iterator-Done? + #'WB-Seq-Tree-Iterator-Get)) + +(def-gmap-res-type :seq (&key filterp) + "Returns a seq of the values, optionally filtered by `filterp'." + `(nil + #'(lambda (a b) (cons b a)) + #'(lambda (s) (convert 'seq (nreverse s))) + ,filterp)) -(gmap::def-gmap-res-type :seq (&optional filterp) - `(nil #'(lambda (a b) (cons b a)) #'(lambda (s) (convert 'seq (nreverse s))) +(def-gmap-res-type :wb-seq (&key filterp) + "Returns a seq of the values, optionally filtered by `filterp'." + `(nil + #'(lambda (a b) (cons b a)) + #'(lambda (s) (convert 'seq (nreverse s))) ,filterp)) Modified: trunk/Code/order.lisp ============================================================================== --- trunk/Code/order.lisp (original) +++ trunk/Code/order.lisp Sun Jul 15 19:27:07 2007 @@ -11,10 +11,10 @@ ;;; This license provides NO WARRANTY. -(defgeneric compare (a b) +(defgeneric compare (x y) (:documentation - "Returns one of `:less', `:greater', `:equal', or `:unequal' according as `a' -is less than, greater than, or equal to `b', or none of these. While the + "Returns one of `:less', `:greater', `:equal', or `:unequal' according as `x' +is less than, greater than, or equal to `y', or none of these. While the ordering does not have to be total, it must be consistent: for two values A and B that compare `:unequal' to each other, for any third value C, if A compares `:less' or `:greater' to C, then B must compare to C the same way; @@ -31,50 +31,52 @@ (eq (compare a b) ':equal))) -;;; Need these here to get the types declared. +;;; Abstract classes + +(defstruct (collection + (:constructor nil) + (:predicate collection?) + (:copier nil)) + "The root class of the FSet functional collections hierarchy. It is a +structure class.") (defstruct (set - (:constructor make-set (contents)) + (:constructor nil) + (:include collection) (:predicate set?) - (:print-function print-set) (:copier nil)) - contents) - + "The abstract class for FSet functional sets. It is a structure class.") (defstruct (bag - (:constructor make-bag (contents)) + (:constructor nil) + (:include collection) (:predicate bag?) - (:print-function print-bag) (:copier nil)) - contents) - + "The abstract class for FSet functional bags (multisets). It is a structure +class.") (defstruct (map - (:constructor make-map (contents &optional default)) + (:constructor nil) + (:include collection) (:predicate map?) - (:print-function print-map) (:copier nil)) - contents + "The abstract class for FSet functional maps. It is a structure class." (default nil)) - (defstruct (seq - (:constructor make-seq (contents)) + (:constructor nil) + (:include collection) (:predicate seq?) - (:print-function print-seq) (:copier nil)) - contents) - + "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.") (defstruct (tuple - (:constructor Make-Tuple-Internal (descriptor contents)) - (:predicate tuple?) - (:print-function print-tuple) - (:copier nil)) - ;; A `Tuple-Desc'. - descriptor - ;; A vector of value chunks (vectors) (all these vectors being simple). - contents) + (:constructor nil) + (:include collection) + (:predicate tuple?) + (:copier nil)) + "The abstract class for FSet functional tuples. It is a structure class.") ;;; ================================================================================ @@ -266,19 +268,24 @@ (defmethod compare ((a vector) (b vector)) (let ((len-a (length a)) - (len-b (length b))) + (len-b (length b)) + (default ':equal)) (cond ((< len-a len-b) ':less) ((> len-a len-b) ':greater) ((and (simple-vector-p a) (simple-vector-p b)) - (dotimes (i len-a ':equal) + (dotimes (i len-a default) (let ((res (compare (svref a i) (svref b i)))) - (unless (eq res ':equal) - (return res))))) + (when (or (eq res ':less) (eq res ':greater)) + (return res)) + (when (eq res ':unequal) + (setq default ':unequal))))) (t - (dotimes (i len-a ':equal) + (dotimes (i len-a default) (let ((res (compare (aref a i) (aref b i)))) - (unless (eq res ':equal) - (return res)))))))) + (when (or (eq res ':less) (eq res ':greater)) + (return res)) + (when (eq res ':unequal) + (setq default ':unequal)))))))) ;;; Lists @@ -320,17 +327,19 @@ ':greater) (defmethod compare ((a list) (b list)) - (let ((len-a (length a)) - (len-b (length b))) - (cond ((< len-a len-b) ':less) - ((> len-a len-b) ':greater) - (t - (do ((a a (cdr a)) - (b b (cdr b))) - ((null a) ':equal) - (let ((comp (compare (car a) (car b)))) - (unless (eq comp ':equal) - (return comp)))))))) + ;; 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. + (do ((a a (cdr a)) + (b b (cdr b)) + (default ':equal)) + ((or (atom a) (atom b)) + (compare a b)) + (let ((comp (compare (car a) (car b)))) + (when (or (eq comp ':less) (eq comp ':greater)) + (return comp)) + (when (eq comp ':unequal) + (setq default ':unequal))))) ;;; Sets Modified: trunk/Code/port.lisp ============================================================================== --- trunk/Code/port.lisp (original) +++ trunk/Code/port.lisp Sun Jul 15 19:27:07 2007 @@ -188,7 +188,10 @@ #+lispworks (defun make-char (code bits) - (code-char code bits)) + ;; Unfortunately, an attempt to use `bits' runs into LispWorks bugs; e.g., + ;; `(concatenate 'string ...)' tries to make a `base-string', and fails. + (declare (ignore bits)) + (code-char code)) ;;; This little oddity exists because of a limitation in Python (that's the Modified: trunk/Code/reader.lisp ============================================================================== --- trunk/Code/reader.lisp (original) +++ trunk/Code/reader.lisp Sun Jul 15 19:27:07 2007 @@ -86,27 +86,95 @@ ;;; ;;; Tuple syntax: ;;; -;;; #< <subexpression>* > +;;; #~< <subexpression>* > ;;; ;;; where each subexpression is either a pair is written as a list of two forms, ;;; or a use of the `#$' notation. Again, the forms are all evaluated; the keys ;;; must all be instances of `tuple-key'. Examples: ;;; -;;; #< (k1 2) (k3 'x) > ; maps k1 to 2, and k3 to the value of X -;;; #{| #$x (k1 2) |} ; equivalent to `(tuple-merge x #< (1 2) >)' +;;; #~< (k1 2) (k3 'x) > ; maps k1 to 2, and k3 to the value of X +;;; #{| #$x (k1 2) |} ; equivalent to `(tuple-merge x #< (1 2) >)' ;;; -;;; In any case where multiple values are provided for the same key, the rightmost +;;; In any case where more than one value is provided for a given key, the rightmost ;;; subexpression takes precedence. ;;; +;;; Discussion: having the reader macros return constructor macro invocations, so +;;; that the operands of the reader macro will be evaluated, is not the traditional +;;; Lisp way of doing things. Consider the #(...) reader macro for vectors: the +;;; reader macro constructs and returns the vector itself, necessarily treating the +;;; operands (the s-expressions within the parentheses) as constants. To write an +;;; expression that constructs a vector but evaluates some of its operands, you must +;;; either just call `vector', or use backquote: `#(1 2 ,x) +;;; +;;; I didn't want these reader macros to work that way, partly because I've never +;;; been very fond of backquote, and partly because FSet was inspired by Refine, and +;;; in Refine syntax, collection expressions evaluate their operands. Also, in +;;; Refine, these expressions are used for pattern matching: +;;; +;;; ( s = [ $x, 'foo, $y ] --> ...) +;;; +;;; which searches sequence `s' for an occurrence of symbol `foo', and if it finds +;;; one, binds `x' and `y' to the left and right subsequences of `s' defined by that +;;; occurrence of `foo', and evaluates the expression to the right of the arrow. I +;;; eventually want to add this kind of pattern matching to FSet, and I think the +;;; reader macros will be handy for that purpose (though not required; one can use +;;; the constructor macros instead). If the reader macros worked the same as #(...), +;;; though, the only way to make them work for this would be to extend backquote to +;;; support the FSet types; and CL defines no portable interface for extending +;;; backquote. +;;; +;;; The downside, though, of having the FSet reader macros work the way they do, is +;;; the loss of readable printing: even though the reader macros accept the same +;;; delimiter syntax as the print functions for `wb-set' etc. produce, it is not +;;; possible to write out an FSet structure (to a file, say) and then read it back +;;; in using these reader macros, unless it contains only objects that are self- +;;; evaluating in CL like numbers, strings, and keyword symbols. If it contains +;;; lists or non-keyword symbols, the form returned by the reader macro will attempt +;;; to evaluate these (and presumably fail). +;;; +;;; To me, the ideal solution would be to modify the Lisp printer so that when +;;; printing a non-self-evaluating object -- a non-keyword symbol or list -- it would +;;; quote it, thus: +;;; +;;; * 'a +;;; 'A +;;; * (list 'a 'b) +;;; '(A B) +;;; +;;; This is, or is similar to, an approach of Brian C. Smith in his semantically +;;; normalized "2-Lisp". Given this change, one could arrange for readable printing +;;; of the FSet types: +;;; +;;; * #{ 1 'x } +;;; #{ 1 'X } +;;; +;;; I think this would be a better way to do things, but there's no question it +;;; would confuse current users of CL (and also, of course, it can't be implemented +;;; portably). +;;; +;;; So, what to do? All I can come up with at the moment is to provide two sets of +;;; reader macros: one that functions as described above (evaluating operands), and +;;; a second "rereading" set that is non-evaluating, like #(...), and so can be used +;;; to reread printed FSet values. +;;; +;;; It remains to be seen whether anyone uses the reader macros, anyway. + (defmacro set (&rest args) - "As a type: the FSet set type. + "Constructs a set of the default implementation according to the supplied +argument subforms. Each argument subform can be an expression, whose value +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)) -As a macro: constructs a set according to the supplied argument subforms. Each +(defmacro wb-set (&rest args) + "Constructs a wb-set according to the supplied argument subforms. Each argument subform can be an expression, whose value 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." +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." (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) '$))) @@ -119,15 +187,26 @@ (recur splice-args start)))) (defmacro bag (&rest args) - "As a type: the FSet bag type. + "Constructs a bag of the default implementation according to the supplied +argument subforms. Each argument subform can be an expression, whose value +will be added to the bag with multiplicity 1; or a list of the form +\($ `expression'), in which case the expression must evaluate to a bag (or a +set), which is bag-summed into the result; or a list of the form +\(% `expression1' `expression2') (called a \"multi-arg\"), which indicates that +the value of `expression1' is bag-summed 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." + `(wb-bag . ,args)) -As a macro: constructs a bag according to the supplied argument subforms. Each +(defmacro wb-bag (&rest args) + "Constructs a wb-bag according to the supplied argument subforms. Each argument subform can be an expression, whose value will be added to the bag -with multiplicity 1; or a list of the form ($ <expression>), in which case the +with multiplicity 1; or a list of the form ($ `expression'), in which case the expression must evaluate to a bag (or a set), which is bag-summed into the -result; or a list of the form (% <expression1> <expression2>) (called a -\"multi-arg\"), which indicates that the value of <expression1> is bag-summed -into the result with multiplicity given by the value of <expression2>. That +result; or a list of the form (% `expression1' `expression2') (called a +\"multi-arg\"), which indicates that the value of `expression1' is bag-summed +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." (let ((normal-args (remove-if #'(lambda (arg) (and (listp arg) @@ -156,12 +235,21 @@ (add-splice-args splice-args start))))) (defmacro map (&rest args) - "As a type: the FSet map type. - -As a macro: constructs a map according to the supplied argument subforms. Each -argument subform can be a list of the form (<key-expr> <value-expr>), denoting -a mapping from the value of <key-expr> to the value of <value-expr>; or a list -of the form ($ <expression>), in which case the expression must evaluate to a + "Constructs a map of the default implementation according to the supplied +argument subforms. Each argument subform can be a list of the form (`key-expr' +`value-expr'), denoting a mapping from the value of `key-expr' to the value of +`value-expr'; or a list of the form ($ `expression'), in which case the +expression must evaluate to a map, denoting all its mappings. The result is +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)) + +(defmacro wb-map (&rest args) + "Constructs a wb-map according to the supplied argument subforms. Each +argument subform can be a list of the form (`key-expr' `value-expr'), denoting +a mapping from the value of `key-expr' to the value of `value-expr'; or a list +of the form ($ `expression'), in which case the expression must evaluate to a map, denoting all its mappings. The result is 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 @@ -182,13 +270,20 @@ (recur args `(empty-map)))) (defmacro seq (&rest args) - "As a type: the FSet sequence type. - -As a macro: constructs a sequence according to the supplied argument subforms. -Each argument subform can be an expression whose value is to appear in the -sequence; 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." + "Constructs a seq of the default implementation according to the supplied +argument subforms. Each argument subform can be an expression whose value is +to appear in the sequence; 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." + `(wb-seq . ,args)) + +(defmacro wb-seq (&rest args) + "Constructs a wb-seq according to the supplied argument subforms. Each +argument subform can be an expression whose value is to appear in the sequence; +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." (labels ((recur (args nonsplice-args) (cond ((null args) (if nonsplice-args @@ -209,17 +304,25 @@ (recur args nil))) (defmacro tuple (&rest args) - "As a type: the FSet tuple type. - - -As a macro: constructs a tuple according to the supplied argument subforms. -Each argument subform can be a list of the form (<key-expr> <value-expr>), -denoting a mapping from the value of <key-expr> to the value of <value-expr>; or -a list of the form ($ <expression>), in which case the expression must evaluate -to a tuple, denoting all its mappings. The result is 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." + "Constructs a tuple of the default implementation according to the supplied +argument subforms. Each argument subform can be a list of the form (`key-expr' +`value-expr'), denoting a mapping from the value of `key-expr' to the value of +`value-expr'; or a list of the form ($ `expression'), in which case the +expression must evaluate to a tuple, denoting all its mappings. The result is +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)) + +(defmacro dyn-tuple (&rest args) + "Constructs a dyn-tuple according to the supplied argument subforms. Each +argument subform can be a list of the form (`key-expr' `value-expr'), denoting +a mapping from the value of `key-expr' to the value of `value-expr'; or a list +of the form ($ `expression'), in which case the expression must evaluate to a +tuple, denoting all its mappings. The result is 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." (labels ((recur (args result) (cond ((null args) result) ((not (and (listp (car args)) @@ -258,13 +361,22 @@ (declare (ignore subchar arg)) `(seq . ,(read-delimited-list #\] stream t))) +(defun |#~-reader| (stream subchar arg) + (declare (ignore subchar arg)) + (unless (eql (read-char stream) #\<) + (error "\"#~\" must be followed by \"<\"")) + `(tuple . ,(read-delimited-list #\> stream t))) + (defun |#$-reader| (stream subchar arg) (declare (ignore subchar arg)) `($ ,(read stream t nil t))) (defun |#%-reader| (stream subchar arg) (declare (ignore subchar arg)) - `(% . ,(read stream t nil t))) + (let ((subform (read stream t nil t))) + (unless (and (consp subform) (consp (cdr subform)) (null (cddr subform))) + (error "\"#%\" must be followed by a 2-element list.")) + `(% . ,subform))) (defun fset-setup-readtable (readtable) @@ -273,6 +385,7 @@ (set-macro-character #\} (get-macro-character #\)) nil readtable) (set-dispatch-macro-character #\# #\[ #'|#[-reader| readtable) (set-macro-character #\] (get-macro-character #\)) nil readtable) + (set-dispatch-macro-character #\# #\~ #'|#~-reader| readtable) (set-dispatch-macro-character #\# #\$ #'|#$-reader| readtable) (set-dispatch-macro-character #\# #\% #'|#%-reader| readtable) readtable) @@ -280,3 +393,63 @@ (defvar *fset-readtable* (fset-setup-readtable (copy-readtable nil)) "A copy of the standard readtable with FSet reader macros installed.") + +;;; These function in the traditional Lisp manner, constructing the structures +;;; at read time. They can therefore be used to read back previously printed +;;; structure containing FSet collections. +(defun |rereading-#{-reader| (stream subchar arg) + (declare (ignore subchar arg)) + (case (peek-char nil stream t nil t) + (#\| + (read-char stream t nil t) + (convert 'map (prog1 + (read-delimited-list #\| stream t) + (unless (eql (read-char stream) #\}) + (error "Incorrect #{| ... |} syntax"))) + :value-fn #'cadr)) + (#\% + (read-char stream t nil t) + (let ((stuff (read-delimited-list #\% stream t)) + (result (bag))) + (unless (eql (read-char stream) #\}) + (error "Incorrect #{% ... %} syntax")) + (dolist (x stuff) + (if (and (consp x) (eq (car x) '%)) + (adjoinf result (cadr x) (caddr x)) + (adjoinf result x))) + result)) + (otherwise + (convert 'set (read-delimited-list #\} stream t))))) + +(defun |rereading-#[-reader| (stream subchar arg) + (declare (ignore subchar arg)) + (convert 'seq (read-delimited-list #\] stream t))) + +(defun |rereading-#~-reader| (stream subchar arg) + (declare (ignore subchar arg)) + (unless (eql (read-char stream) #\<) + (error "\"#~\" must be followed by \"<\"")) + (let ((stuff (read-delimited-list #\> stream t)) + (result (tuple))) + (dolist (pr stuff) + (unless (and (consp pr) (consp (cdr pr)) (null (cddr pr))) + (error "~S is not a 2-element list." pr)) + (setf result (with result (get-tuple-key (car pr)) (cadr pr)))) + result)) + +(defun fset-setup-rereading-readtable (readtable) + "Adds the FSet rereading reader macros to `readtable'. These reader macros +will correctly read structure printed by the FSet print functions. Returns +`readtable'." + (set-dispatch-macro-character #\# #\{ #'|rereading-#{-reader| readtable) + (set-macro-character #\} (get-macro-character #\)) nil readtable) + (set-dispatch-macro-character #\# #\[ #'|rereading-#[-reader| readtable) + (set-macro-character #\] (get-macro-character #\)) nil readtable) + (set-dispatch-macro-character #\# #\~ #'|rereading-#~-reader| readtable) + (set-dispatch-macro-character #\# #\% #'|#%-reader| readtable) + readtable) + +(defvar *fset-rereading-readtable* (fset-setup-rereading-readtable (copy-readtable nil)) + "A copy of the standard readtable with the rereading FSet reader macros +installed. This readtable can be used to read structure printed by the FSet +print functions.") Modified: trunk/Code/testing.lisp ============================================================================== --- trunk/Code/testing.lisp (original) +++ trunk/Code/testing.lisp Sun Jul 15 19:27:07 2007 @@ -86,10 +86,32 @@ (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 (member (compare (least fs0) + (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)) + '(:equal :unequal)) + (error "Set greatest failed on iteration ~D" i)) (unless (equal? fs0 (convert 'set s0)) (error "Set equal? failed (fs0) on iteration ~D" i)) (unless (equal? fs1 (convert 'set s1)) (error "Set equal? failed (fs1) on iteration ~D" i)) + (unless (equal? (convert 'list fs0) (gmap :list nil (:set fs0))) + (error "Set iterator failed (fs0) on iteration ~D" i)) + (unless (equal? fs1 (gmap :set nil (:list (convert 'list fs1)))) + (error "Set iterator or accumulator failed (fs1) on iteration ~D" i)) (let ((fsu (union fs0 fs1)) (su (cl:union s0 s1 :test #'equal?))) (unless (and (verify fsu) (equal? fsu (convert 'set su))) @@ -179,6 +201,11 @@ (error "Map equal? failed (fm0) on iteration ~D" i)) (unless (equal? fm1 (convert 'map m1)) (error "Map equal? failed (fm1) on iteration ~D" i)) + (unless (eq (Map-Compare (convert 'list fm0) (gmap :list #'cons (:map fm0))) + ':equal) + (error "Map iterator failed (fm0) on iteration ~D" i)) + (unless (equal? fm1 (gmap :map nil (:alist (convert 'list fm1)))) + (error "Map iterator/accumulator failed (fm1) on iteration ~D" i)) (unless (eq (Map-Compare (convert 'list fm0) m0) ':equal) (error "Map equal? failed (fm1) on iteration ~D" i)) (unless (eq (Map-Compare (convert 'list fm1) m1) ':equal) @@ -195,13 +222,22 @@ (unless (eq (compare fm1a fm1b) (Map-Compare (convert 'list fm1a) (convert 'list fm1b))) (error "Map compare failed (fm1) on iteration ~D" i)))) - (let ((fmm (map-merge fm0 fm1)) - (mm m0)) + (let ((fmu (map-union fm0 fm1)) + (mu m0)) (dolist (pr m1) - (setq mm (Alist-Assign mm (car pr) (cdr pr)))) - (unless (and (verify fmm) - (equal? fmm (convert 'map mm))) - (error "Map merge failed on iteration ~D: ~A, ~A, ~A, ~A" i mm fmm fm0 fm1))) + (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))) + (let ((fmi (map-intersection fm0 fm1)) + (mi nil)) + (dolist (pr m1) + (when (assoc (car pr) m0 :test #'equal?) + (setq mi (Alist-Assign mi (car pr) (cdr pr))))) + (unless (and (verify fmi) + (equal? fmi (convert 'map mi))) + (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))) (unless (and (verify fmr) @@ -277,6 +313,15 @@ (error "Bag equal? failed (fb0) on iteration ~D" i)) (unless (equal? fb1 (convert 'bag b1 :from-type 'alist)) (error "Bag equal? failed (fb1) on iteration ~D" i)) + (unless (equal? (convert 'list fb0) (gmap :list nil (:bag fb0))) + (error "Bag iterator failed (fb0) on iteration ~D" i)) + (unless (equal? fb1 (gmap :bag nil (:list (convert 'list fb1)))) + (error "Bag iterator/accumulator failed (fb1) on iteration ~D" i)) + (unless (eq (Map-Compare (convert 'alist fb0) (gmap :list #'cons (:bag-pairs fb0))) + ':equal) + (error "Bag pair iterator failed (fb0) on iteration ~D" i)) + (unless (equal? fb1 (gmap :bag-pairs nil (:alist (convert 'alist fb1)))) + (error "Bag pair iterator/accumulator failed (fb1) on iteration ~D" i)) (let ((fbu (union fb0 fb1)) (bu (Alist-Bag-Union b0 b1))) (unless (and (verify fbu) (equal? fbu (convert 'bag bu :from-type 'alist))) @@ -311,6 +356,7 @@ (defun Test-Seq-Operations (i) + (declare (optimize (debug 3))) (let ((fs0 (empty-seq)) (s0 nil) (fs1 (empty-seq)) @@ -321,10 +367,9 @@ ;; all. (dotimes (j 100) (let ((rand (random 100)) - ((r (cond ((< rand 8) (Make-My-Integer rand)) - ((< rand 16) - #+FSet-Ext-Strings (make-char (+ rand 16) (random 3)) - #-FSet-Ext-Strings (code-char rand))))) + ((r (if (< rand 8) (Make-My-Integer rand) + #+FSet-Ext-Strings (make-char (+ rand 16) (random 3)) + #-FSet-Ext-Strings (code-char rand)))) (pos (if (null s0) 0 (random (length s0)))) (which (random 6)) (tmp nil)) @@ -378,10 +423,20 @@ (error "Seq equality failed (fs0, A), on iteration ~D" i)) (unless (equal? fs0 (convert 'seq s0)) (error "Seq equality failed (fs0, B), on iteration ~D" i)) + (unless (gmap :and #'equal? (:seq fs0) (:list s0)) + (error "Seq iterator failed on iteration ~D" i)) + (unless (gmap :and #'equal? (:seq fs0) (:sequence s0)) + (error "Seq or list iterator failed on iteration ~D" i)) + (unless (gmap :and #'equal? (:seq fs0) (:sequence (coerce s0 'simple-vector))) + (error "Seq or simple-vector iterator failed on iteration ~D" i)) (unless (equal? (convert 'vector fs1) (coerce s1 'vector)) (error "Seq equality failed (fs1, A), on iteration ~D" i)) (unless (equal? fs1 (convert 'seq (coerce s1 'vector))) (error "Seq equality failed (fs1, B), on iteration ~D" i)) + (unless (equal? (convert 'list fs0) (gmap :list nil (:seq fs0))) + (error "Seq iterator failed (fs0) on iteration ~D" i)) + (unless (equal? fs1 (gmap :seq nil (:list (convert 'list fs1)))) + (error "Seq iterator/accumulator failed (fs1) on iteration ~D" i)) (let ((fsc (concat fs0 fs1)) (sc (cl:append s0 s1))) (unless (equal? (convert 'list fsc) sc) @@ -457,6 +512,8 @@ ((> e12 e22) (return ':greater))))))))) (defun Map-Compare (m1 m2) + ;; Rather too hairy to be a good reference implementation. Seems to be + ;; correct, though. (let ((len1 (length m1)) (len2 (length m2)) (result ':equal)) @@ -491,10 +548,10 @@ (let ((pr2 (assoc (car pr1) g2))) (and pr2 (= (cdr pr1) (cdr pr2))))) g1) - (let ((vals1 (cl:reduce #'with1 (mapcar #'cdr g1) - :initial-value (empty-set))) - (vals2 (cl:reduce #'with1 (mapcar #'cdr g2) - :initial-value (empty-set))) + (let ((vals1 (reduce #'with1 (mapcar #'cdr g1) + :initial-value (empty-set))) + (vals2 (reduce #'with1 (mapcar #'cdr g2) + :initial-value (empty-set))) ((comp (compare vals1 vals2)))) (if (eq comp ':equal) (setq result ':unequal) @@ -656,17 +713,17 @@ (set-difference s0 s1)))) -(defmethod verify ((s set)) - (WB-Set-Tree-Verify (set-contents s))) +(defmethod verify ((s wb-set)) + (WB-Set-Tree-Verify (wb-set-contents s))) -(defmethod verify ((b bag)) - (WB-Bag-Tree-Verify (bag-contents b))) +(defmethod verify ((b wb-bag)) + (WB-Bag-Tree-Verify (wb-bag-contents b))) -(defmethod verify ((m map)) - (WB-Map-Tree-Verify (map-contents m))) +(defmethod verify ((m wb-map)) + (WB-Map-Tree-Verify (wb-map-contents m))) -(defmethod verify ((s seq)) - (WB-Seq-Tree-Verify (seq-contents s))) +(defmethod verify ((s wb-seq)) + (WB-Seq-Tree-Verify (wb-seq-contents s))) (defun eqv (a b) (or (eq a b) (and a b))) @@ -679,5 +736,5 @@ (defun Time-Index (seq n) (time (dotimes (i n) (dotimes (j (size seq)) - (WB-Seq-Tree-Subscript (seq-contents seq) i))))) + (WB-Seq-Tree-Subscript (wb-seq-contents seq) i))))) Modified: trunk/Code/tuples.lisp ============================================================================== --- trunk/Code/tuples.lisp (original) +++ trunk/Code/tuples.lisp Sun Jul 15 19:27:07 2007 @@ -101,6 +101,20 @@ ;;; but it's something to keep in mind. +(defstruct (dyn-tuple + (:include tuple) + (:constructor make-dyn-tuple (descriptor contents)) + (:predicate dyn-tuple?) + (:print-function print-dyn-tuple) + (:copier nil)) + "A class of functional tuples represented as vectors with dynamically- +reordered key vectors. This is the default implementation of tuples in FSet." + ;; A `Tuple-Desc'. + descriptor + ;; A vector of value chunks (vectors) (all these vectors being simple). + contents) + + (defstruct (tuple-key (:constructor make-tuple-key (name default-fn number)) (:predicate tuple-key?) @@ -214,11 +228,16 @@ (defun empty-tuple () + "Returns an empty tuple of the default implementation." + (empty-dyn-tuple)) + +(defun empty-dyn-tuple () + "Returns an empty dyn-tuple." (let ((desc (lookup *Tuple-Descriptor-Map* (empty-map)))) (unless desc (setq desc (Make-Tuple-Desc (empty-set) (vector))) (setf (lookup *Tuple-Descriptor-Map* (empty-map)) desc)) - (Make-Tuple-Internal desc (vector)))) + (make-dyn-tuple desc (vector)))) (defvar *Tuple-Random-Value* 0 "State for an extremely fast, low-quality generator of small numbers of @@ -238,7 +257,7 @@ (defun Tuple-Lookup (tuple key &optional no-reorder?) ;(declare (optimize (speed 3) (safety 0))) - (let ((desc (tuple-descriptor tuple)) + (let ((desc (dyn-tuple-descriptor tuple)) ((pairs (Tuple-Desc-Pairs desc)) ((nkeys*2 (length pairs)))) (key-num (if (typep key 'fixnum) key ; for internal use only @@ -254,7 +273,7 @@ (declare (fixnum pr)) (when (= (logand pr Tuple-Key-Number-Mask) key-num) - (let ((chunks (tuple-contents tuple)) + (let ((chunks (dyn-tuple-contents tuple)) (val-idx (the fixnum (ash pr (- Tuple-Key-Number-Size))))) (let ((val (svref (svref chunks (ash val-idx (- Tuple-Value-Chunk-Bits))) (logand val-idx (1- Tuple-Value-Chunk-Size))))) @@ -270,7 +289,7 @@ (defun Tuple-Reorder-Keys (tuple idx) ;(declare (optimize (speed 3) (safety 0))) (declare (fixnum idx)) - (let ((desc (tuple-descriptor tuple)) + (let ((desc (dyn-tuple-descriptor tuple)) ((pairs (Tuple-Desc-Pairs desc)))) (with-lock ((Tuple-Desc-Lock desc) :wait? nil) (let ((nkeys*2 (length pairs)) @@ -296,8 +315,8 @@ ;; Present in tuple already -- key set doesn't change. ;; The lookup may have reordered the tuple. (let ((key-num (tuple-key-number key)) - (contents (tuple-contents tuple)) - ((desc (tuple-descriptor tuple)) + (contents (dyn-tuple-contents tuple)) + ((desc (dyn-tuple-descriptor tuple)) ((pairs (Tuple-Desc-Pairs desc)) ((nkeys*2 (length pairs)) ((pr (dotimes (i nkeys*2 (assert nil)) @@ -316,8 +335,8 @@ (dotimes (i (length contents)) (setf (svref new-contents i) (svref contents i))) (setf (svref new-contents ichunk) new-chunk) - (Make-Tuple-Internal desc new-contents))) - (let ((old-desc (tuple-descriptor tuple))) + (make-dyn-tuple desc new-contents))) + (let ((old-desc (dyn-tuple-descriptor tuple))) (unless (< (size (Tuple-Desc-Key-Set old-desc)) (1- (ash 1 Tuple-Value-Index-Size))) (error "Tuple too long (limit ~D pairs in this implementation)." @@ -360,13 +379,13 @@ (setf (lookup *Tuple-Descriptor-Map* new-key-set) new-desc) (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 (tuple-contents tuple)) + (old-chunks (dyn-tuple-contents tuple)) (new-chunks (make-array (ceiling nkeys Tuple-Value-Chunk-Size)))) (do ((i 0 (1+ i)) (n nkeys (- n Tuple-Value-Chunk-Size)) (reorder-map reorder-map (cdr reorder-map))) ((= i (length new-chunks)) - (Make-Tuple-Internal new-desc new-chunks)) + (make-dyn-tuple new-desc new-chunks)) (if (null (car reorder-map)) (setf (svref new-chunks i) (svref old-chunks i)) (let ((chunk-len (min n Tuple-Value-Chunk-Size)) @@ -440,8 +459,8 @@ (pr-var (gensym "PR-")) (val-idx-var (gensym "VAL-IDX-"))) `(let ((,tuple-var ,tuple-form)) - (let ((,contents-var (tuple-contents ,tuple-var)) - (,desc-var (tuple-descriptor ,tuple-var)) + (let ((,contents-var (dyn-tuple-contents ,tuple-var)) + (,desc-var (dyn-tuple-descriptor ,tuple-var)) ((,pairs-var (Tuple-Desc-Pairs ,desc-var)))) (dotimes (,idx-var (the fixnum (size (Tuple-Desc-Key-Set ,desc-var)))) (declare (fixnum ,idx-var)) @@ -463,23 +482,23 @@ (Do-Tuple-Internal (x y tup (funcall value-fn)) (funcall elt-fn x y))) -(defun print-tuple (tuple stream level) - (format stream "#<") +(defun print-dyn-tuple (tuple stream level) + (format stream "#~~<") (let ((i 0)) (do-tuple (key val tuple) (unless (= i 0) - (format stream ", ")) + (format stream " ")) (when (and *print-length* (>= i *print-length*)) (format stream "...") (return)) (incf i) - (format stream "~A: " (tuple-key-name key)) - (write val :stream stream :level (and *print-level* (- *print-level* level))))) + (write (list (tuple-key-name key) val) + :stream stream :level (and *print-level* (- *print-level* level))))) (format stream ">")) (defmethod compare ((tup1 tuple) (tup2 tuple)) - (let ((key-vec-1 (svref (tuple-contents tup1) 0)) - (key-vec-2 (svref (tuple-contents tup2) 0)) + (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))))) (if (not (eq res ':equal)) res Modified: trunk/Code/wb-trees.lisp ============================================================================== --- trunk/Code/wb-trees.lisp (original) +++ trunk/Code/wb-trees.lisp Sun Jul 15 19:27:07 2007 @@ -35,9 +35,8 @@ This means, for instance, that a viable way to implement the ordering relation for some class is to compute hash codes for the instances and -compare the hash codes (this is probably how we'll have to do it in Java). -If the hashing is done well, collisions will be rare -- rare enough that the -performance consequences will be negligible. +compare the hash codes. If the hashing is done well, collisions will be +rare -- rare enough that the performance consequences will be negligible. Also, we go to considerable effort to minimize the number of calls to the ordering function `compare'. In fact, this is why we have a 4-valued @@ -270,8 +269,8 @@ (ecase comp ((:equal :unequal) (if (Equivalent-Set? node-val) - (let ((v (find value (Equivalent-Set-Members node-val) - :test #'equal?))) + (let ((v (cl:find value (Equivalent-Set-Members node-val) + :test #'equal?))) (and v (values t v))) (values t node-val))) ((:less) @@ -690,8 +689,8 @@ (setq unequal? t)) (and (or (eq comp ':less) (eq comp ':greater)) comp))) - (:simple-vector tree1 (- lo base1) (- hi base1)) - (:simple-vector tree2 (- lo base2) (- hi base2))) + (:simple-vector tree1 :start (- lo base1) :stop (- hi base1)) + (:simple-vector tree2 :start (- lo base2) :stop (- hi base2))) (if unequal? ':unequal ':equal)))) ((simple-vector-p tree1) (let ((rev-comp (WB-Set-Tree-Compare-Rng tree2 base2 tree1 base1 lo hi))) @@ -1335,29 +1334,156 @@ ;; You may ask, why do we do this with a macro rather than a mapper when ;; we're going to have a function call for every invocation of the body anyway? ;; First, this local call is faster, or should be, than a general funcall; and - ;; second, some compilers may decide to inline `do-it' if the body is small. - ;; (Alas, Allegro seems to lose on both counts, even at speed 3.) - (let ((do-it-fn (gensym "DO-IT-")) + ;; second, some compilers may decide to inline `body-fn' if the body is small. + (let ((body-fn (gensym "BODY-")) (recur-fn (gensym "RECUR-"))) `(block nil - (labels ((,do-it-fn (,var) . ,body) + (labels ((,body-fn (,var) . ,body) (,recur-fn (tree) (when tree (cond ((simple-vector-p tree) (dotimes (i (length tree)) - (,do-it-fn (svref tree i)))) + (,body-fn (svref tree i)))) (t (,recur-fn (WB-Set-Tree-Node-Left tree)) (let ((val (WB-Set-Tree-Node-Value tree))) (if (Equivalent-Set? val) (dolist (val (Equivalent-Set-Members val)) - (,do-it-fn val)) - (,do-it-fn val))) + (,body-fn val)) + (,body-fn val))) (,recur-fn (WB-Set-Tree-Node-Right tree))))))) (,recur-fn ,tree-form)) ,value-form))) +;;; ---------------- +;;; Stateful iterator + +(defun Make-WB-Set-Tree-Iterator (tree) + (let ((iter (Make-WB-Set-Tree-Iterator-Internal tree))) + (lambda (op) + (ecase op + (:get (WB-Set-Tree-Iterator-Get iter)) + (:done? (WB-Set-Tree-Iterator-Done? iter)) + (:more? (not (WB-Set-Tree-Iterator-Done? iter))))))) + +(defun Make-WB-Set-Tree-Iterator-Internal (tree) + (WB-Set-Tree-Iterator-Canonicalize + (Make-WB-Tree-Iterator tree (WB-Set-Tree-Size tree) 2 t))) + +(defun WB-Set-Tree-Iterator-Canonicalize (iter) + (declare (optimize (speed 3) (safety 0))) + (loop + (let ((sp (svref iter 0)) + ((node (svref iter sp)) + (idx (svref iter (1+ sp))))) + (declare (fixnum sp idx)) + (cond ((null node) + (if (= sp 1) + (return) + (progn + (decf sp 2) + (setf (svref iter 0) sp) + (incf (the fixnum (svref iter (1+ sp))))))) + ((simple-vector-p node) + (cond ((< idx (length node)) + (return)) + ((= sp 1) + (setf (svref iter 1) nil) + (return)) + (t + (decf sp 2) + (setf (svref iter 0) sp) + (incf (the fixnum (svref iter (1+ sp))))))) + ((= idx 0) + (unless (< (+ sp 3) (length iter)) + (error "Internal FSet error: iterator stack overflow. Please report this bug.")) + (incf sp 2) + (setf (svref iter 0) sp) + (setf (svref iter sp) (WB-Set-Tree-Node-Left node)) + (setf (svref iter (1+ sp)) 0)) + ((= idx (1+ (Set-Value-Size (WB-Set-Tree-Node-Value node)))) + ;; Tail recursion + (setf (svref iter sp) (WB-Set-Tree-Node-Right node)) + (setf (svref iter (1+ sp)) 0)) + (t (return))))) + iter) + +(defun WB-Set-Tree-Iterator-Done? (iter) + (declare (optimize (speed 3) (safety 0))) + (null (svref iter (svref iter 0)))) + +(defun WB-Set-Tree-Iterator-Get (iter) + (declare (optimize (speed 3) (safety 0))) + (let ((sp (svref iter 0)) + ((node (svref iter sp)) + (idx (svref iter (1+ sp))))) + (declare (fixnum idx)) + (if (null node) + (values nil nil) + (progn + (incf (the fixnum (svref iter (1+ sp)))) + (WB-Set-Tree-Iterator-Canonicalize iter) + (values (if (simple-vector-p node) (svref node idx) + (let ((val (WB-Set-Tree-Node-Value node))) + (if (Equivalent-Set? val) + (nth (1- idx) (Equivalent-Set-Members val)) + val))) + t))))) + + +;;; ---------------- +;;; Utilities used by all tree types in this file + +(defun Make-WB-Tree-Iterator (tree size frame-size nodes-have-values?) + (declare (type fixnum frame-size)) + (let ((depth (the fixnum (WB-Tree-Max-Depth size nodes-have-values?))) + ((stack (make-array (the fixnum (1+ (the fixnum (* frame-size depth)))))))) + (setf (svref stack 0) 1) + (setf (svref stack 1) tree) + (dotimes (i (1- frame-size)) + (setf (svref stack (+ i 2)) 0)) + stack)) + +(defun WB-Tree-True-Max-Depth (size nodes-have-values?) + (cond ((= size 0) 1) ; not really, but this is convenient + ((= size 1) 1) + ((= size 2) 1) + (t + (let ((size (if nodes-have-values? (1- size) size)) + ((subtree-max (min (1- size) + (floor (* size (/ WB-Tree-Balance-Factor + (1+ WB-Tree-Balance-Factor)))))))) + (1+ (WB-Tree-True-Max-Depth subtree-max nodes-have-values?)))))) + +(defconstant WB-Tree-Precomputed-Max-Depths 1000) + +(defvar *WB-Tree-Max-Depths-Without-Values* + (gmap :vector (lambda (i) (WB-Tree-True-Max-Depth i nil)) + (:index 0 WB-Tree-Precomputed-Max-Depths))) + +(defvar *WB-Tree-Max-Depths-With-Values* + (gmap :vector (lambda (i) (WB-Tree-True-Max-Depth i t)) + (:index 0 WB-Tree-Precomputed-Max-Depths))) + +(defun WB-Tree-Max-Depth (size nodes-have-values?) + ;; For purposes of this worst-case analysis I ignore the leaf vectors, though I + ;; think it would be possible to prove that they are always at least half full. + ;; There's almost no cost to overestimating this by a few, so this tries to be + ;; very fast and conservative. + (declare (optimize (speed 3) (safety 0)) + (type fixnum size)) + (if (< size WB-Tree-Precomputed-Max-Depths) + (svref (if nodes-have-values? + *WB-Tree-Max-Depths-With-Values* + *WB-Tree-Max-Depths-Without-Values*) + size) + (values (ceiling (* (1- (integer-length size)) + ;; constant: + (/ (log 2) (log (/ (+ 1 WB-Tree-Balance-Factor) + WB-Tree-Balance-Factor)))))))) + + ;;; ================================================================================ ;;; Equivalent-Set routines @@ -2075,10 +2201,10 @@ val-comp) ((< count1 count2) ':less) ((> count1 count2) ':greater)))) - (:simple-vector (car tree1) (- lo base1) (- hi base1)) - (:simple-vector (cdr tree1) (- lo base1) (- hi base1)) - (:simple-vector (car tree2) (- lo base2) (- hi base2)) - (:simple-vector (cdr tree2) (- lo base2) (- hi base2))) + (:simple-vector (car tree1) :start (- lo base1) :stop (- hi base1)) + (:simple-vector (cdr tree1) :start (- lo base1) :stop (- hi base1)) + (:simple-vector (car tree2) :start (- lo base2) :stop (- hi base2)) + (:simple-vector (cdr tree2) :start (- lo base2) :stop (- hi base2))) (if unequal? ':unequal ':equal)))) ((consp tree1) (let ((rev-comp (WB-Bag-Tree-Compare-Rng tree2 base2 tree1 base1 lo hi))) @@ -2858,29 +2984,212 @@ &body body) "Iterates over the pairs of the bag, for each one binding `val-var' to the value and `count-var' to its member count." - (let ((do-it-fn (gensym "DO-IT-")) + (let ((body-fn (gensym "BODY-")) (recur-fn (gensym "RECUR-"))) `(block nil - (labels ((,do-it-fn (,val-var ,count-var) + (labels ((,body-fn (,val-var ,count-var) (declare (type integer ,count-var)) . ,body) (,recur-fn (tree) (when tree (if (consp tree) (dotimes (i (length (the simple-vector (car tree)))) - (,do-it-fn (svref (car tree) i) (svref (cdr tree) i))) + (,body-fn (svref (car tree) i) (svref (cdr tree) i))) (progn (,recur-fn (WB-Bag-Tree-Node-Left tree)) (let ((value (WB-Bag-Tree-Node-Value tree))) (if (Equivalent-Bag? value) (dolist (pr (Equivalent-Bag-Alist value)) - (,do-it-fn (car pr) (cdr pr))) - (,do-it-fn value (WB-Bag-Tree-Node-Count tree)))) + (,body-fn (car pr) (cdr pr))) + (,body-fn value (WB-Bag-Tree-Node-Count tree)))) (,recur-fn (WB-Bag-Tree-Node-Right tree))))))) (,recur-fn ,tree-form)) ,value-form))) +;;; ---------------- +;;; Stateful iterator + +(defun Make-WB-Bag-Tree-Iterator (tree) + (let ((iter (Make-WB-Bag-Tree-Iterator-Internal tree))) + (lambda (op) + (ecase op + (:get (WB-Bag-Tree-Iterator-Get iter)) + (:done? (WB-Bag-Tree-Iterator-Done? iter)) + (:more? (not (WB-Bag-Tree-Iterator-Done? iter))))))) + +(defun Make-WB-Bag-Tree-Iterator-Internal (tree) + (WB-Bag-Tree-Iterator-Canonicalize + (Make-WB-Tree-Iterator tree (WB-Bag-Tree-Size tree) 3 t))) + +(defun WB-Bag-Tree-Iterator-Canonicalize (iter) + (declare (optimize (speed 3) (safety 0))) + (loop + (let ((sp (svref iter 0)) + ((node (svref iter sp)) + (idx1 (svref iter (+ sp 1))) + (idx2 (svref iter (+ sp 2))))) + (declare (fixnum sp idx1 idx2)) + (cond ((null node) + (if (= sp 1) + (return) + (progn + (decf sp 3) + (setf (svref iter 0) sp) + (incf (the fixnum (svref iter (+ sp 1))))))) + ((consp node) + (cond ((< idx1 (length (the simple-vector (cdr node)))) + (if (< idx2 (the fixnum (svref (cdr node) idx1))) + (return) + (progn + (incf (the fixnum (svref iter (+ sp 1)))) + (setf (svref iter (+ sp 2)) 0)))) + ((= sp 1) + (setf (svref iter 1) nil) + (return)) + (t + (decf sp 3) + (setf (svref iter 0) sp) + (incf (the fixnum (svref iter (+ sp 1))))))) + ((= idx1 0) + (unless (< (+ sp 5) (length iter)) + (error "Internal FSet error: iterator stack overflow. Please report this bug.")) + (incf sp 3) + (setf (svref iter 0) sp) + (setf (svref iter sp) (WB-Bag-Tree-Node-Left node)) + (setf (svref iter (+ sp 1)) 0) + (setf (svref iter (+ sp 2)) 0)) + (t + (let ((val (WB-Bag-Tree-Node-Value node))) + (if (Equivalent-Bag? val) + (let ((alist (Equivalent-Bag-Alist val))) + (if (< (1- idx1) (length alist)) + (if (< idx2 (the fixnum (cdr (nth (1- idx1) alist)))) + (return) + (progn + (incf (the fixnum (svref iter (+ sp 1)))) + (setf (svref iter (+ sp 2)) 0))) + (progn + ;; Tail recursion + (setf (svref iter sp) (WB-Bag-Tree-Node-Right node)) + (setf (svref iter (+ sp 1)) 0) + (setf (svref iter (+ sp 2)) 0)))) + (if (= idx1 1) + (if (< idx2 (the fixnum (WB-Bag-Tree-Node-Count node))) + (return) + (incf (the fixnum (svref iter (+ sp 1))))) + (progn + ;; Tail recursion + (setf (svref iter sp) (WB-Bag-Tree-Node-Right node)) + (setf (svref iter (+ sp 1)) 0) + (setf (svref iter (+ sp 2)) 0))))))))) + iter) + +(defun WB-Bag-Tree-Iterator-Done? (iter) + (declare (optimize (speed 3) (safety 0))) + (null (svref iter (svref iter 0)))) + +(defun WB-Bag-Tree-Iterator-Get (iter) + (declare (optimize (speed 3) (safety 0))) + (let ((sp (svref iter 0)) + ((node (svref iter sp)) + (idx1 (svref iter (+ sp 1))))) + (declare (fixnum sp idx1)) + (cond ((null node) + (values nil nil)) + ((consp node) + (progn + (incf (the fixnum (svref iter (+ sp 2)))) + (WB-Bag-Tree-Iterator-Canonicalize iter) + (values (svref (car node) idx1) t))) + (t + (let ((val (WB-Bag-Tree-Node-Value node))) + (if (Equivalent-Bag? val) + (let ((alist (Equivalent-Bag-Alist val))) + (incf (the fixnum (svref iter (+ sp 2)))) + (WB-Bag-Tree-Iterator-Canonicalize iter) + (values (car (nth (1- idx1) alist)) t)) + (progn + (incf (the fixnum (svref iter (+ sp 2)))) + (WB-Bag-Tree-Iterator-Canonicalize iter) + (values val t)))))))) + + +;;; Map-style bag iterator + +(defun Make-WB-Bag-Tree-Pair-Iterator (tree) + (let ((iter (Make-WB-Bag-Tree-Pair-Iterator-Internal tree))) + (lambda (op) + (ecase op + (:get (WB-Bag-Tree-Pair-Iterator-Get iter)) + (:done? (WB-Bag-Tree-Pair-Iterator-Done? iter)) + (:more? (not (WB-Bag-Tree-Pair-Iterator-Done? iter))))))) + +(defun Make-WB-Bag-Tree-Pair-Iterator-Internal (tree) + (WB-Bag-Tree-Pair-Iterator-Canonicalize + (Make-WB-Tree-Iterator tree (WB-Bag-Tree-Size tree) 2 t))) + +(defun WB-Bag-Tree-Pair-Iterator-Canonicalize (iter) + (declare (optimize (speed 3) (safety 0))) + (loop + (let ((sp (svref iter 0)) + ((node (svref iter sp)) + (idx (svref iter (1+ sp))))) + (declare (fixnum sp idx)) + (cond ((null node) + (if (= sp 1) + (return) + (progn + (decf sp 2) + (setf (svref iter 0) sp) + (incf (the fixnum (svref iter (1+ sp))))))) + ((consp node) + (cond ((< idx (length (the simple-array (car node)))) + (return)) + ((= sp 1) + (setf (svref iter 1) nil) + (return)) + (t + (decf sp 2) + (setf (svref iter 0) sp) + (incf (the fixnum (svref iter (1+ sp))))))) + ((= idx 0) + (unless (< (+ sp 3) (length iter)) + (error "Internal FSet error: iterator stack overflow. Please report this bug.")) + (incf sp 2) + (setf (svref iter 0) sp) + (setf (svref iter sp) (WB-Bag-Tree-Node-Left node)) + (setf (svref iter (1+ sp)) 0)) + ((= idx (1+ (Bag-Value-Size (WB-Bag-Tree-Node-Value node)))) + ;; Tail recursion + (setf (svref iter sp) (WB-Bag-Tree-Node-Right node)) + (setf (svref iter (1+ sp)) 0)) + (t (return))))) + iter) + +(defun WB-Bag-Tree-Pair-Iterator-Done? (iter) + (declare (optimize (speed 3) (safety 0))) + (null (svref iter (svref iter 0)))) + +(defun WB-Bag-Tree-Pair-Iterator-Get (iter) + (declare (optimize (speed 3) (safety 0))) + (let ((sp (svref iter 0)) + ((node (svref iter sp)) + (idx (svref iter (1+ sp))))) + (declare (fixnum idx)) + (if (null node) + (values nil nil nil) + (progn + (incf (the fixnum (svref iter (1+ sp)))) + (WB-Bag-Tree-Pair-Iterator-Canonicalize iter) + (if (consp node) + (values (svref (car node) idx) (svref (cdr node) idx) t) + (let ((val (WB-Bag-Tree-Node-Value node))) + (if (Equivalent-Bag? val) + (let ((pr (nth (1- idx) (Equivalent-Bag-Alist val)))) + (values (car pr) (cdr pr) t)) + (values val (WB-Bag-Tree-Node-Count node) t)))))))) + ;;; ================================================================================ ;;; Equivalent-Bag routines @@ -2908,7 +3217,7 @@ ;; Next form must do generic + (ignore Python notes). (Make-Equivalent-Bag (cons (cons val2 (+ (the integer (cdr pr1)) count2)) - (remove pr1 alist1))) + (cl:remove pr1 alist1))) (Make-Equivalent-Bag (cons (cons val2 count2) alist1)))))) (if (Equivalent-Bag? val2) (Equivalent-Bag-Sum val2 count2 val1 count1) @@ -2939,7 +3248,7 @@ (if pr1 ;; Next form must do generic arithmetic (ignore Python notes). (Make-Equivalent-Bag (cons (cons val2 (max (the integer (cdr pr1)) count2)) - (remove pr1 alist1))) + (cl:remove pr1 alist1))) (Make-Equivalent-Bag (cons (cons val2 count2) alist1)))))) (if (Equivalent-Bag? val2) (Equivalent-Bag-Union val2 count2 val1 count1) @@ -3336,7 +3645,7 @@ (cons (Vector-Insert (car tree) idx key) (Vector-Insert (cdr tree) idx value)) (Make-WB-Map-Tree-Node (if found? - (Equivalent-Map-Merge (svref (car tree) idx) + (Equivalent-Map-Union (svref (car tree) idx) (svref (cdr tree) idx) key value) key) @@ -3356,7 +3665,7 @@ ((:equal :unequal) ;; Since we're probably updating the value anyway, we don't bother trying ;; to figure out whether we can reuse the node. - (Make-WB-Map-Tree-Node (Equivalent-Map-Merge node-key + (Make-WB-Map-Tree-Node (Equivalent-Map-Union node-key (WB-Map-Tree-Node-Value tree) key value) value @@ -3488,13 +3797,13 @@ ;;; ================================================================================ -;;; Merge +;;; Union and intersection -(defun WB-Map-Tree-Merge (tree1 tree2 val-fn) - (WB-Map-Tree-Merge-Rng tree1 tree2 val-fn +(defun WB-Map-Tree-Union (tree1 tree2 val-fn) + (WB-Map-Tree-Union-Rng tree1 tree2 val-fn Hedge-Negative-Infinity Hedge-Positive-Infinity)) -(defun WB-Map-Tree-Merge-Rng (tree1 tree2 val-fn lo hi) +(defun WB-Map-Tree-Union-Rng (tree1 tree2 val-fn lo hi) (declare (optimize (speed 3) (safety 0)) (type function val-fn) (type WB-Map-Tree tree1 tree2)) @@ -3505,21 +3814,21 @@ ((null tree1) (WB-Map-Tree-Split tree2 lo hi)) ((and (consp tree1) (consp tree2)) - (WB-Map-Tree-Vector-Pair-Merge tree1 tree2 val-fn lo hi)) + (WB-Map-Tree-Vector-Pair-Union tree1 tree2 val-fn lo hi)) ((consp tree1) ;; Can't use the swap-trees trick here, as the operation is noncommutative. (let ((key2 (WB-Map-Tree-Node-Key tree2)) (val2 (WB-Map-Tree-Node-Value tree2)) ((eqvk1? eqvk1 eqvv1 (WB-Map-Tree-Find-Equivalent tree1 key2)) - ((key val (if eqvk1? (Equivalent-Map-Merge eqvk1 eqvv1 key2 val2 val-fn) + ((key val (if eqvk1? (Equivalent-Map-Union eqvk1 eqvv1 key2 val2 val-fn) (values key2 val2)))))) (WB-Map-Tree-Concat key val - (WB-Map-Tree-Merge-Rng (WB-Map-Tree-Trim tree1 lo key2) + (WB-Map-Tree-Union-Rng (WB-Map-Tree-Trim tree1 lo key2) (WB-Map-Tree-Trim (WB-Map-Tree-Node-Left tree2) lo key2) val-fn lo key2) - (WB-Map-Tree-Merge-Rng (WB-Map-Tree-Trim tree1 key2 hi) + (WB-Map-Tree-Union-Rng (WB-Map-Tree-Trim tree1 key2 hi) (WB-Map-Tree-Trim (WB-Map-Tree-Node-Right tree2) key2 hi) val-fn key2 hi)))) @@ -3527,17 +3836,63 @@ (let ((key1 (WB-Map-Tree-Node-Key tree1)) (val1 (WB-Map-Tree-Node-Value tree1)) ((eqvk2? eqvk2 eqvv2 (WB-Map-Tree-Find-Equivalent tree2 key1)) - ((key val (if eqvk2? (Equivalent-Map-Merge key1 val1 eqvk2 eqvv2 val-fn) + ((key val (if eqvk2? (Equivalent-Map-Union key1 val1 eqvk2 eqvv2 val-fn) (values key1 val1)))))) (WB-Map-Tree-Concat key val - (WB-Map-Tree-Merge-Rng (WB-Map-Tree-Node-Left tree1) + (WB-Map-Tree-Union-Rng (WB-Map-Tree-Node-Left tree1) (WB-Map-Tree-Trim tree2 lo key1) val-fn lo key1) - (WB-Map-Tree-Merge-Rng (WB-Map-Tree-Node-Right tree1) + (WB-Map-Tree-Union-Rng (WB-Map-Tree-Node-Right tree1) (WB-Map-Tree-Trim tree2 key1 hi) val-fn key1 hi)))))) +(defun WB-Map-Tree-Intersect (tree1 tree2 val-fn) + (WB-Map-Tree-Intersect-Rng tree1 tree2 val-fn + Hedge-Negative-Infinity Hedge-Positive-Infinity)) + +(defun WB-Map-Tree-Intersect-Rng (tree1 tree2 val-fn lo hi) + (declare (optimize (speed 3) (safety 0)) + (type function val-fn) + (type WB-Map-Tree tree1 tree2)) + (cond ((eq tree1 tree2) ; historically-related-map optimization + (WB-Map-Tree-Split tree1 lo hi)) + ((or (null tree1) (null tree2)) + nil) + ((and (consp tree1) (consp tree2)) + (Vector-Pair-Intersect tree1 tree2 val-fn lo hi)) + ((consp tree1) + ;; Can't use the swap-trees trick here, as the operation is noncommutative. + (let ((key2 (WB-Map-Tree-Node-Key tree2)) + (val2 (WB-Map-Tree-Node-Value tree2)) + ((eqvk1? eqvk1 eqvv1 (WB-Map-Tree-Find-Equivalent tree1 key2)) + ((nonnull? key val + (and eqvk1? (Equivalent-Map-Intersect eqvk1 eqvv1 key2 val2 val-fn)))))) + (WB-Map-Tree-Concat-Maybe + nonnull? key val + (WB-Map-Tree-Intersect-Rng (WB-Map-Tree-Trim tree1 lo key2) + (WB-Map-Tree-Trim (WB-Map-Tree-Node-Left tree2) + lo key2) + val-fn lo key2) + (WB-Map-Tree-Intersect-Rng (WB-Map-Tree-Trim tree1 key2 hi) + (WB-Map-Tree-Trim (WB-Map-Tree-Node-Right tree2) + key2 hi) + val-fn key2 hi)))) + (t + (let ((key1 (WB-Map-Tree-Node-Key tree1)) + (val1 (WB-Map-Tree-Node-Value tree1)) + ((eqvk2? eqvk2 eqvv2 (WB-Map-Tree-Find-Equivalent tree2 key1)) + ((nonnull? key val + (and eqvk2? (Equivalent-Map-Intersect key1 val1 eqvk2 eqvv2 val-fn)))))) + (WB-Map-Tree-Concat-Maybe + nonnull? key val + (WB-Map-Tree-Intersect-Rng (WB-Map-Tree-Node-Left tree1) + (WB-Map-Tree-Trim tree2 lo key1) + val-fn lo key1) + (WB-Map-Tree-Intersect-Rng (WB-Map-Tree-Node-Right tree1) + (WB-Map-Tree-Trim tree2 key1 hi) + val-fn key1 hi)))))) + ;;; ================================================================================ ;;; Restrict and restrict-not @@ -3656,21 +4011,19 @@ ;;; ================================================================================ ;;; Compare -(defun WB-Map-Tree-Compare (tree1 tree2) +(defun WB-Map-Tree-Compare (tree1 tree2 &optional (val-fn #'compare)) (let ((size1 (WB-Map-Tree-Size tree1)) (size2 (WB-Map-Tree-Size tree2))) (cond ((< size1 size2) ':less) ((> size1 size2) ':greater) - (t (WB-Map-Tree-Compare-Rng tree1 0 tree2 0 0 size1))))) + (t (WB-Map-Tree-Compare-Rng tree1 0 tree2 0 0 size1 val-fn))))) -(defun WB-Map-Tree-Compare-Rng (tree1 base1 tree2 base2 lo hi) - (WB-Map-Tree-Compare-Rng-1 tree1 base1 tree2 base2 lo hi)) - -(defun WB-Map-Tree-Compare-Rng-1 (tree1 base1 tree2 base2 lo hi) +(defun WB-Map-Tree-Compare-Rng (tree1 base1 tree2 base2 lo hi val-fn) ;; See notes at `WB-Set-Tree-Compare-Rng'. (declare (optimize (speed 3) (safety 0)) (type WB-Map-Tree tree1 tree2) - (type fixnum base1 base2 lo hi)) + (type fixnum base1 base2 lo hi) + (type function val-fn)) (cond ((and (eq tree1 tree2) (= base1 base2)) ; historically-related-map optimization ':equal) ((= lo hi) ':equal) @@ -3682,18 +4035,18 @@ (setq unequal? t)) (if (or (eq key-comp ':less) (eq key-comp ':greater)) key-comp - (let ((val-comp (compare val1 val2))) + (let ((val-comp (funcall val-fn val1 val2))) (when (eq val-comp ':unequal) (setq unequal? t)) (and (or (eq val-comp ':less) (eq val-comp ':greater)) val-comp))))) - (:simple-vector (car tree1) (- lo base1) (- hi base1)) - (:simple-vector (cdr tree1) (- lo base1) (- hi base1)) - (:simple-vector (car tree2) (- lo base2) (- hi base2)) - (:simple-vector (cdr tree2) (- lo base2) (- hi base2))) + (:simple-vector (car tree1) :start (- lo base1) :stop (- hi base1)) + (:simple-vector (cdr tree1) :start (- lo base1) :stop (- hi base1)) + (:simple-vector (car tree2) :start (- lo base2) :stop (- hi base2)) + (:simple-vector (cdr tree2) :start (- lo base2) :stop (- hi base2))) (if unequal? ':unequal ':equal)))) ((consp tree1) - (let ((rev-comp (WB-Map-Tree-Compare-Rng tree2 base2 tree1 base1 lo hi))) + (let ((rev-comp (WB-Map-Tree-Compare-Rng tree2 base2 tree1 base1 lo hi val-fn))) (ecase rev-comp (:less ':greater) (:greater ':less) @@ -3705,14 +4058,14 @@ ((left1a base1a (WB-Map-Tree-Rank-Trim left1 base1 lo new-hi)) (tree2a base2a (WB-Map-Tree-Rank-Trim tree2 base2 lo new-hi)) ((left-comp (WB-Map-Tree-Compare-Rng left1a base1a tree2a base2a - lo new-hi))))))) + lo new-hi val-fn))))))) (if (or (eq left-comp ':less) (eq left-comp ':greater)) left-comp (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)))) - ((comp (Equivalent-Map-Compare key1 val1 key2 val2)))) + ((comp (Equivalent-Map-Compare key1 val1 key2 val2 val-fn)))) (if (or (eq comp ':less) (eq comp ':greater)) comp (let ((key1-size (Map-Key-Size key1)) @@ -3723,8 +4076,9 @@ (+ base1 left1-size key1-size)) new-lo hi)) (tree2a base2a (WB-Map-Tree-Rank-Trim tree2 base2 new-lo hi)) - ((right-comp (WB-Map-Tree-Compare-Rng right1a base1a tree2a - base2a new-lo hi)))))) + ((right-comp + (WB-Map-Tree-Compare-Rng right1a base1a tree2a base2a + new-lo hi val-fn)))))) (if (not (eq right-comp ':equal)) right-comp (if (eq left-comp ':unequal) ':unequal comp)))))))))) @@ -3828,6 +4182,11 @@ (WB-Map-Tree-Trim (WB-Map-Tree-Node-Left tree) lo hi)) (WB-Map-Tree-Trim (WB-Map-Tree-Node-Right tree) lo hi)))))) +(defun WB-Map-Tree-Concat-Maybe (pair? key value left right) + (declare (optimize (speed 3) (safety 0))) + (if pair? (WB-Map-Tree-Concat key value left right) + (WB-Map-Tree-Join left right))) + (defun WB-Map-Tree-Concat (key value left right) (declare (optimize (speed 3) (safety 0)) (type WB-Map-Tree left right)) @@ -3955,8 +4314,8 @@ (WB-Map-Tree-Verify-Rng (WB-Map-Tree-Node-Right tree) key hi)))))) -(defun WB-Map-Tree-Vector-Pair-Merge (pr1 pr2 val-fn lo hi) - (let ((new-pr any-equivalent? (Vector-Pair-Merge pr1 pr2 val-fn lo hi))) +(defun WB-Map-Tree-Vector-Pair-Union (pr1 pr2 val-fn lo hi) + (let ((new-pr any-equivalent? (Vector-Pair-Union pr1 pr2 val-fn lo hi))) (if any-equivalent? (let ((tree nil)) ;; Let's just do it the stupid way -- it's not supposed to happen often. @@ -3974,7 +4333,7 @@ (Vector-Subseq (cdr new-pr) (1+ split-point))))) new-pr)))) -(defun Vector-Pair-Merge (pr1 pr2 val-fn lo hi) +(defun Vector-Pair-Union (pr1 pr2 val-fn lo hi) (declare (optimize (speed 3) (safety 0)) (type cons pr1 pr2) (type function val-fn)) @@ -4034,7 +4393,7 @@ (push (svref vals2 i2) vals) (incf i2)) ((:unequal) - (push (Equivalent-Map-Merge key1 (svref vals1 i1) + (push (Equivalent-Map-Union key1 (svref vals1 i1) key2 (svref vals2 i2) val-fn) keys) (push nil vals) @@ -4042,6 +4401,49 @@ (incf i2) (setq any-equivalent? t))))))))) +(defun Vector-Pair-Intersect (pr1 pr2 val-fn lo hi) + (declare (optimize (speed 3) (safety 0)) + (type cons pr1 pr2) + (type function val-fn)) + (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)))) + (declare (type fixnum i1 i2 len1 len2)) + (unless (eq lo Hedge-Negative-Infinity) + (do () ((or (= i1 len1) (less-than? lo (svref keys1 i1)))) + (incf i1))) + (unless (eq hi Hedge-Positive-Infinity) + (do () ((or (= i1 len1) (less-than? (svref keys1 (1- len1)) hi))) + (decf len1))) + (do ((keys nil) + (vals nil)) + ((or (= i1 len1) (= i2 len2)) + (and keys (cons (coerce (nreverse keys) 'simple-vector) + (coerce (nreverse vals) 'simple-vector)))) + (let ((key1 (svref keys1 i1)) + (key2 (svref keys2 i2)) + ((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))) + (incf i1) + (incf i2)) + ((:less) + (incf i1)) + ((:greater) + (incf i2)) + ((:unequal) + (incf i1) + (incf i2))))))) + (defun Vector-Pair-Restrict (map-pr set-vec lo hi) (declare (optimize (speed 3) (safety 0)) (type cons map-pr) @@ -4141,10 +4543,10 @@ (defmacro Do-WB-Map-Tree-Pairs ((key-var value-var tree-form &optional value-form) &body body) ;; See comment at `Do-WB-Set-Tree-Members'. - (let ((do-it-fn (gensym "DO-IT-")) + (let ((body-fn (gensym "BODY-")) (recur-fn (gensym "RECUR-"))) `(block nil - (labels ((,do-it-fn (,key-var ,value-var) + (labels ((,body-fn (,key-var ,value-var) . ,body) (,recur-fn (tree) (when tree @@ -4152,23 +4554,100 @@ (let ((keys (car tree)) (vals (cdr tree))) (dotimes (i (length (the simple-vector (car tree)))) - (,do-it-fn (svref keys i) (svref vals i)))) + (,body-fn (svref keys i) (svref vals i)))) (progn (,recur-fn (WB-Map-Tree-Node-Left tree)) (let ((key (WB-Map-Tree-Node-Key tree))) (if (Equivalent-Map? key) (dolist (pr (Equivalent-Map-Alist key)) - (,do-it-fn (car pr) (cdr pr))) - (,do-it-fn key (WB-Map-Tree-Node-Value tree)))) + (,body-fn (car pr) (cdr pr))) + (,body-fn key (WB-Map-Tree-Node-Value tree)))) (,recur-fn (WB-Map-Tree-Node-Right tree))))))) (,recur-fn ,tree-form)) ,value-form))) +;;; ---------------- +;;; Stateful iterator + +(defun Make-WB-Map-Tree-Iterator (tree) + (let ((iter (Make-WB-Map-Tree-Iterator-Internal tree))) + (lambda (op) + (ecase op + (:get (WB-Map-Tree-Iterator-Get iter)) + (:done? (WB-Map-Tree-Iterator-Done? iter)) + (:more? (not (WB-Map-Tree-Iterator-Done? iter))))))) + +(defun Make-WB-Map-Tree-Iterator-Internal (tree) + (WB-Map-Tree-Iterator-Canonicalize + (Make-WB-Tree-Iterator tree (WB-Map-Tree-Size tree) 2 t))) + +(defun WB-Map-Tree-Iterator-Canonicalize (iter) + (declare (optimize (speed 3) (safety 0))) + (loop + (let ((sp (svref iter 0)) + ((node (svref iter sp)) + (idx (svref iter (1+ sp))))) + (declare (fixnum sp idx)) + (cond ((null node) + (if (= sp 1) + (return) + (progn + (decf sp 2) + (setf (svref iter 0) sp) + (incf (the fixnum (svref iter (1+ sp))))))) + ((consp node) + (cond ((< idx (length (the simple-array (car node)))) + (return)) + ((= sp 1) + (setf (svref iter 1) nil) + (return)) + (t + (decf sp 2) + (setf (svref iter 0) sp) + (incf (the fixnum (svref iter (1+ sp))))))) + ((= idx 0) + (unless (< (+ sp 3) (length iter)) + (error "Internal FSet error: iterator stack overflow. Please report this bug.")) + (incf sp 2) + (setf (svref iter 0) sp) + (setf (svref iter sp) (WB-Map-Tree-Node-Left node)) + (setf (svref iter (1+ sp)) 0)) + ((= idx (1+ (Map-Key-Size (WB-Map-Tree-Node-Key node)))) + ;; Tail recursion + (setf (svref iter sp) (WB-Map-Tree-Node-Right node)) + (setf (svref iter (1+ sp)) 0)) + (t (return))))) + iter) + +(defun WB-Map-Tree-Iterator-Done? (iter) + (declare (optimize (speed 3) (safety 0))) + (null (svref iter (svref iter 0)))) + +(defun WB-Map-Tree-Iterator-Get (iter) + (declare (optimize (speed 3) (safety 0))) + (let ((sp (svref iter 0)) + ((node (svref iter sp)) + (idx (svref iter (1+ sp))))) + (declare (fixnum idx)) + (if (null node) + (values nil nil nil) + (progn + (incf (the fixnum (svref iter (1+ sp)))) + (WB-Map-Tree-Iterator-Canonicalize iter) + (if (consp node) + (values (svref (car node) idx) (svref (cdr node) idx) t) + (let ((key (WB-Map-Tree-Node-Key node))) + (if (Equivalent-Map? key) + (let ((pr (nth (1- idx) (Equivalent-Map-Alist key)))) + (values (car pr) (cdr pr) t)) + (values key (WB-Map-Tree-Node-Value node) t)))))))) + + ;;; ================================================================================ ;;; Equivalent-Map routines -(defun Equivalent-Map-Merge (key1 val1 key2 val2 +(defun Equivalent-Map-Union (key1 val1 key2 val2 &optional (val-fn #'(lambda (k v1 v2) (declare (ignore k v1)) v2))) @@ -4216,6 +4695,49 @@ (values key1 (funcall val-fn key1 val1 val2)) (Make-Equivalent-Map (list (cons key1 val1) (cons key2 val2))))))) +(defun Equivalent-Map-Intersect (key1 val1 key2 val2 val-fn) + "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 intersection 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 intersection +is null, returns false." + (declare (optimize (speed 3) (safety 0)) + (type function val-fn)) + (if (Equivalent-Map? key1) + (if (Equivalent-Map? key2) + (let ((alist1 (Equivalent-Map-Alist key1)) + (alist2 (Equivalent-Map-Alist key2)) + ((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)))))) + (and result + (if (cdr result) + (values t (Make-Equivalent-Map result)) + (values t (caar result) (cdar result))))) + (let ((alist1 (Equivalent-Map-Alist key1)) + ((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)))))) + (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))))) + (and (equal? key1 key2) + (let ((val val? (funcall val-fn key1 val1 val2))) + (and val? (values t key1 val))))))) + (defun Equivalent-Map-Less (eqvm key) "Removes the pair associated with `key' from `eqvm', an `Equivalent-Map'. If the result is a single pair, it's returned as two values; otherwise one value @@ -4224,7 +4746,7 @@ (let ((alist (Equivalent-Map-Alist eqvm)) ((pr (assoc key alist :test #'equal?)))) (if pr - (let ((result (remove pr alist))) + (let ((result (cl:remove pr alist))) (declare (type list result)) (if (= (length result) 1) (values (caar result) (cdar result)) @@ -4237,9 +4759,9 @@ (let ((alist1 (Equivalent-Map-Alist key)) (mems2 (if (Equivalent-Set? set-elt) (Equivalent-Set-Members set-elt) (list set-elt)))) - (let ((result (remove-if-not #'(lambda (pr) - (member (car pr) mems2 :test #'equal?)) - alist1))) + (let ((result (cl:remove-if-not #'(lambda (pr) + (member (car pr) mems2 :test #'equal?)) + alist1))) (cond ((null result) nil) ((null (cdr result)) (values t (caar result) (cdar result))) @@ -4257,9 +4779,9 @@ (let ((alist1 (Equivalent-Map-Alist key)) (mems2 (if (Equivalent-Set? set-elt) (Equivalent-Set-Members set-elt) (list set-elt)))) - (let ((result (remove-if #'(lambda (pr) - (member (car pr) mems2 :test #'equal?)) - alist1))) + (let ((result (cl:remove-if #'(lambda (pr) + (member (car pr) mems2 :test #'equal?)) + alist1))) (cond ((null result) nil) ((null (cdr result)) (values t (caar result) (cdar result))) @@ -4271,7 +4793,7 @@ (and (not (equal? key set-elt)) (values t key val))))) -(defun Equivalent-Map-Compare (key1 val1 key2 val2) +(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))) (let ((comp (compare key1 key2))) @@ -4300,7 +4822,7 @@ ':less) (if (Equivalent-Map? key2) ':greater - (let ((val-comp (compare val1 val2))) + (let ((val-comp (funcall val-fn val1 val2))) (if (not (eq val-comp ':equal)) val-comp comp))))))) (defmethod compare (key (eqvm Equivalent-Map)) @@ -4630,7 +5152,7 @@ (declare (optimize (speed 3) (safety 0)) (type WB-Seq-Tree tree) (type fixnum start end)) - (cond ((null tree) nil) + (cond ((or (null tree) (>= start end)) nil) ((simple-vector-p tree) (Vector-Subseq tree start end)) ((stringp tree) @@ -4646,7 +5168,8 @@ (new-right (if (and (<= start left-size) (= (+ left-size right-size) end)) right - (WB-Seq-Tree-Subseq right (max 0 (- start left-size)) + (WB-Seq-Tree-Subseq right + (max 0 (the fixnum (- start left-size))) (- end left-size))))))) (if (and (eq new-left left) (eq new-right right)) tree @@ -4691,7 +5214,7 @@ ((piece (cond ;; Ignore Python notes -- we don't know exactly what ;; `vec' is. ((gmap :and #'base-char-p - (:vector vec base (+ base piece-len))) + (:vector vec :start base :stop (+ base piece-len))) (let ((str (make-string piece-len :element-type 'base-char))) (dotimes (i piece-len) @@ -4699,7 +5222,7 @@ str)) #+FSet-Ext-Strings ((gmap :and #'(lambda (x) (typep x 'character)) - (:vector vec base (+ base piece-len))) + (:vector vec :start base :stop (+ base piece-len))) (let ((str (make-string piece-len :element-type 'character))) (dotimes (i piece-len) @@ -4861,15 +5384,17 @@ (declare (optimize (speed 3) (safety 0)) (type WB-Seq-Tree tree1 tree2) (type fixnum base1 base2 lo hi)) - (cond ((= lo hi) ':equal) + (cond ((and (eq tree1 tree2) (= base1 base2)) ; historically-related seq optimization + ':equal) + ((= lo hi) ':equal) ((and (stringp tree1) (stringp tree2)) (or (gmap :or #'(lambda (ch1 ch2) (cond ((char< ch1 ch2) ':less) - ((char> ch2 ch1) ':greater))) - (:simple-string tree1 (- lo base1) (- hi base1)) - (:simple-string tree2 (- lo base2) (- hi base2))) + ((char> ch1 ch2) ':greater))) + (:simple-string tree1 :start (- lo base1) :stop (- hi base1)) + (:simple-string tree2 :start (- lo base2) :stop (- hi base2))) ':equal)) - ((and (simple-vector-p tree1) (simple-vector-p tree2)) + ((and (vectorp tree1) (vectorp tree2)) (let ((unequal? nil)) (or (gmap :or #'(lambda (val1 val2) (let ((comp (compare val1 val2))) @@ -4879,8 +5404,8 @@ comp))) ;; We're doing a CLOS dispatch on each pair anyway, so I don't ;; think the `aref's matter much. - (:vector tree1 (- lo base1) (- hi base1)) - (:vector tree2 (- lo base2) (- hi base2))) + (:vector tree1 :start (- lo base1) :stop (- hi base1)) + (:vector tree2 :start (- lo base2) :stop (- hi base2))) (if unequal? ':unequal ':equal)))) ((or (stringp tree1) (simple-vector-p tree1)) (let ((rev-comp (WB-Seq-Tree-Compare-Rng tree2 base2 tree1 base1 lo hi))) @@ -4981,7 +5506,7 @@ (> sizl (* sizr WB-Tree-Balance-Factor))) (let ((ll (WB-Seq-Tree-Node-Left left)) (rl (WB-Seq-Tree-Node-Right left))) - (if (or (null rl) (simple-vector-p rl) + (if (or (null rl) (simple-string-p rl) (simple-vector-p rl) (<= (WB-Seq-Tree-Size rl) (WB-Seq-Tree-Size ll))) (Make-WB-Seq-Tree-Node ll (WB-Seq-Tree-Build-Node rl right)) (Make-WB-Seq-Tree-Node (WB-Seq-Tree-Build-Node @@ -4992,7 +5517,7 @@ (> sizr (* sizl WB-Tree-Balance-Factor))) (let ((lr (WB-Seq-Tree-Node-Left right)) (rr (WB-Seq-Tree-Node-Right right))) - (if (or (null lr) (simple-vector-p lr) + (if (or (null lr) (simple-string-p lr) (simple-vector-p lr) (<= (WB-Seq-Tree-Size lr) (WB-Seq-Tree-Size rr))) (Make-WB-Seq-Tree-Node (WB-Seq-Tree-Build-Node left lr) rr) @@ -5025,20 +5550,19 @@ ;; You may ask, why do we do this with a macro rather than a mapper when ;; we're going to have a function call for every invocation of the body anyway? ;; First, this local call is faster, or should be, than a general funcall; and - ;; second, some compilers may decide to inline `do-it' if the body is small. - ;; (Alas, Allegro seems to lose on both counts, even at speed 3.) - (let ((do-it-fn (gensym "DO-IT-")) + ;; second, some compilers may decide to inline `body-fn' if the body is small. + (let ((body-fn (gensym "BODY-")) (recur-fn (gensym "RECUR-"))) `(block nil - (labels ((,do-it-fn (,var) . ,body) + (labels ((,body-fn (,var) . ,body) (,recur-fn (tree) (when tree (cond ((stringp tree) (dotimes (i (length (the simple-string tree))) - (,do-it-fn (schar tree i)))) + (,body-fn (schar tree i)))) ((simple-vector-p tree) (dotimes (i (length tree)) - (,do-it-fn (svref tree i)))) + (,body-fn (svref tree i)))) (t (,recur-fn (WB-Seq-Tree-Node-Left tree)) (,recur-fn (WB-Seq-Tree-Node-Right tree))))))) @@ -5048,7 +5572,7 @@ (defmacro Do-WB-Seq-Tree-Members-Gen ((var tree-form start-form end-form from-end-form &optional value-form) &body body) - (let ((do-it-fn (gensym "DO-IT-")) + (let ((body-fn (gensym "BODY-")) (recur-fn (gensym "RECUR-")) (start-var (gensym "START-")) (end-var (gensym "END-")) @@ -5058,7 +5582,7 @@ (,end-var ,end-form) (,from-end-var ,from-end-form)) (declare (type fixnum ,start-var ,end-var)) - (labels ((,do-it-fn (,var) . ,body) + (labels ((,body-fn (,var) . ,body) (,recur-fn (tree start end) (declare (type fixnum start end)) (when tree @@ -5066,18 +5590,18 @@ (if (not ,from-end-var) (do ((i start (1+ i))) ((>= i end)) - (,do-it-fn (schar tree i))) + (,body-fn (schar tree i))) (do ((i (1- end) (1- i))) ((< i start)) - (,do-it-fn (schar tree i))))) + (,body-fn (schar tree i))))) ((simple-vector-p tree) (if (not ,from-end-var) (do ((i start (1+ i))) ((>= i end)) - (,do-it-fn (svref tree i))) + (,body-fn (svref tree i))) (do ((i (1- end) (1- i))) ((< i start)) - (,do-it-fn (svref tree i))))) + (,body-fn (svref tree i))))) (t (let ((left (WB-Seq-Tree-Node-Left tree)) ((left-size (WB-Seq-Tree-Size left))) @@ -5101,6 +5625,86 @@ ,value-form))) +;;; ---------------- +;;; Stateful iterator + +(defun Make-WB-Seq-Tree-Iterator (tree) + (let ((iter (Make-WB-Seq-Tree-Iterator-Internal tree))) + (lambda (op) + (ecase op + (:get (WB-Seq-Tree-Iterator-Get iter)) + (:done? (WB-Seq-Tree-Iterator-Done? iter)) + (:more? (not (WB-Seq-Tree-Iterator-Done? iter))))))) + +(defun Make-WB-Seq-Tree-Iterator-Internal (tree) + (WB-Seq-Tree-Iterator-Canonicalize + (Make-WB-Tree-Iterator tree (WB-Seq-Tree-Size tree) 2 nil))) + +(defun WB-Seq-Tree-Iterator-Canonicalize (iter) + (declare (optimize (speed 3) (safety 0))) + (loop + (let ((sp (svref iter 0)) + ((node (svref iter sp)) + (idx (svref iter (1+ sp))))) + (declare (fixnum sp idx)) + (cond ((null node) + (if (= sp 1) + (return) + (progn + (decf sp 2) + (setf (svref iter 0) sp) + (incf (the fixnum (svref iter (1+ sp))))))) + ((simple-string-p node) + (cond ((< idx (length node)) + (return)) + ((= sp 1) + (setf (svref iter 1) nil) + (return)) + (t + (decf sp 2) + (setf (svref iter 0) sp) + (incf (the fixnum (svref iter (1+ sp))))))) + ((simple-vector-p node) + (cond ((< idx (length node)) + (return)) + ((= sp 1) + (setf (svref iter 1) nil) + (return)) + (t + (decf sp 2) + (setf (svref iter 0) sp) + (incf (the fixnum (svref iter (1+ sp))))))) + ((= idx 0) + (unless (< (+ sp 3) (length iter)) + (error "Internal FSet error: iterator stack overflow. Please report this bug.")) + (incf sp 2) + (setf (svref iter 0) sp) + (setf (svref iter sp) (WB-Seq-Tree-Node-Left node)) + (setf (svref iter (1+ sp)) 0)) + (t + ;; Tail recursion + (setf (svref iter sp) (WB-Seq-Tree-Node-Right node)) + (setf (svref iter (1+ sp)) 0))))) + iter) + +(defun WB-Seq-Tree-Iterator-Done? (iter) + (declare (optimize (speed 3) (safety 0))) + (null (svref iter (svref iter 0)))) + +(defun WB-Seq-Tree-Iterator-Get (iter) + (declare (optimize (speed 3) (safety 0))) + (let ((sp (svref iter 0)) + ((node (svref iter sp)) + (idx (svref iter (1+ sp))))) + (declare (fixnum idx)) + (if (null node) + (values nil nil) + (progn + (incf (the fixnum (svref iter (1+ sp)))) + (WB-Seq-Tree-Iterator-Canonicalize iter) + (values (if (simple-string-p node) (schar node idx) (svref node idx)) t))))) + + ;;; ================================================================================ ;;; Verifier @@ -5112,9 +5716,12 @@ (let ((sizl (WB-Seq-Tree-Size (WB-Seq-Tree-Node-Left tree))) (sizr (WB-Seq-Tree-Size (WB-Seq-Tree-Node-Right tree)))) (and (= (WB-Seq-Tree-Node-Size tree) (+ sizl sizr)) - (or (<= sizr 4) + ;; We suppress the balance test if one side is smaller than 8 + ;; here, instead of 4, because of `*WB-Tree-Max-String-Length*', + ;; which makes the trees appear less balanced. + (or (<= sizr 8) (<= sizl (* sizr WB-Tree-Balance-Factor))) - (or (<= sizl 4) + (or (<= sizl 8) (<= sizr (* sizl WB-Tree-Balance-Factor))) (WB-Seq-Tree-Verify (WB-Seq-Tree-Node-Left tree)) (WB-Seq-Tree-Verify (WB-Seq-Tree-Node-Right tree)))))))

1 0