- fset-cvs@common-lisp.net - mailman3.common-lisp.net

[fset-cvs] r23 - trunk/Code
by Scott L. Burson 04 Nov '08

04 Nov '08

Author: sburson Date: Tue Nov 4 05:36:20 2008 New Revision: 23 Log: Oops -- error in port interface for threaded SBCL. Modified: trunk/Code/port.lisp Modified: trunk/Code/port.lisp ============================================================================== --- trunk/Code/port.lisp (original) +++ trunk/Code/port.lisp Tue Nov 4 05:36:20 2008 @@ -83,6 +83,7 @@ #+(and sbcl (not sb-thread)) (progn (defun make-lock (&optional name) + (declare (ignore name)) nil) (defmacro with-lock ((lock &key (wait? t)) &body body) (declare (ignore lock wait?)) @@ -106,10 +107,10 @@ (deflex *Memory-Barrier-Lock* (sb-thread:make-mutex :name "Memory Barrier Lock")) (defmacro read-memory-barrier () - '(mp:with-process-lock (*Memory-Barrier-Lock*) + '(sb-thread:with-mutex (*Memory-Barrier-Lock*) nil)) (defmacro write-memory-barrier () - '(mp:with-process-lock (*Memory-Barrier-Lock*) + '(sb-thread:with-mutex (*Memory-Barrier-Lock*) nil)))

1 0

[fset-cvs] r22 - tags/fset_1.2.0
by Scott L. Burson 03 Nov '08

03 Nov '08

Author: sburson Date: Mon Nov 3 05:11:51 2008 New Revision: 22 Log: Tagging 1.2.0. Added: tags/fset_1.2.0/ - copied from r21, /trunk/

1 0

[fset-cvs] r21 - trunk
by Scott L. Burson 03 Nov '08

03 Nov '08

Author: sburson Date: Mon Nov 3 05:10:55 2008 New Revision: 21 Log: Update `fset.asd' for new files. Modified: trunk/fset.asd Modified: trunk/fset.asd ============================================================================== --- trunk/fset.asd (original) +++ trunk/fset.asd Mon Nov 3 05:10:55 2008 @@ -24,4 +24,8 @@ (:file "fset") (:file "tuples") (:file "reader") - (:file "testing"))))) + (:file "testing") + (:file "interval") + (:file "relations") + (:file "complement-sets") + (:file "bounded-sets")))))

1 0

[fset-cvs] r20 - trunk/Code
by Scott L. Burson 03 Nov '08

03 Nov '08

Author: sburson Date: Mon Nov 3 05:08:58 2008 New Revision: 20 Log: Some final tweaks for the 1.2 release. Modified: trunk/Code/fset.lisp trunk/Code/interval.lisp trunk/Code/port.lisp trunk/Code/relations.lisp trunk/Code/tuples.lisp trunk/Code/wb-trees.lisp Modified: trunk/Code/fset.lisp ============================================================================== --- trunk/Code/fset.lisp (original) +++ trunk/Code/fset.lisp Mon Nov 3 05:08:58 2008 @@ -1847,7 +1847,6 @@ (map-default m))) (defmethod domain ((m wb-map)) - ;; &&& Cache this? It's pretty fast anyway. (make-wb-set (WB-Map-Tree-Domain (wb-map-contents m)))) (defmethod compare ((map1 wb-map) (map2 wb-map)) Modified: trunk/Code/interval.lisp ============================================================================== --- trunk/Code/interval.lisp (original) +++ trunk/Code/interval.lisp Mon Nov 3 05:08:58 2008 @@ -390,11 +390,12 @@ ;;; for this). Adam Megacz calls it a "topological bag", but that doesn't seem ;;; right to me (it's certainly not a bag in the sense in which I use the word). +#|| Someday (defstruct (interval-set-relation (:constructor make-interval-set-relation (contents)) (:predicate interval-set-relation?) (:print-function print-interval-set-relation) (:copier nil)) contents) - +||# Modified: trunk/Code/port.lisp ============================================================================== --- trunk/Code/port.lisp (original) +++ trunk/Code/port.lisp Mon Nov 3 05:08:58 2008 @@ -28,39 +28,42 @@ (defmacro write-memory-barrier () 'nil)) -#+(and allegro os-threads) +#+(and allegro os-threads) ; &&& untested (progn - (defun make-lock (&optional (name "A lock")) - (mp:make-process-lock :name name)) + (defun make-lock (&optional name) + (apply #'mp:make-process-lock (and name `(:name ,name)))) (defmacro with-lock ((lock &key (wait? t)) &body body) - ;; See the OpenMCL code below for a suggestion of how to implement non-waiting - ;; mode (Allegro doesn't have it built in). - (error "&&& Write me")) - (defvar *Allegro-Read-Memory-Barrier-Lock* - (mp:make-process-lock :name "Read Memory Barrier Lock")) - (defmacro read-memory-barrier () - ;; Allegro doesn't seem to have any better way to do this. - (mp:with-process-lock (*Allegro-Read-Memory-Barrier-Lock*) - nil)) - (defvar *Allegro-Write-Memory-Barrier-Lock* - (mp:make-process-lock :name "Write Memory Barrier Lock")) + `(mp:with-process-lock (,lock :timeout (if ,wait? nil 0)) + . ,body)) + ;; For those implementations that support SMP but don't give us direct ways + ;; to generate memory barriers, we assume that grabbing a lock suffices. + (deflex *Memory-Barrier-Lock* + (mp:make-process-lock :name "Memory Barrier Lock")) + (defmacro read-memory-barrier () + '(mp:with-process-lock (*Memory-Barrier-Lock*) + nil)) (defmacro write-memory-barrier () - ;; Allegro doesn't seem to have any better way to do this. - (mp:with-process-lock (*Allegro-Write-Memory-Barrier-Lock*) - nil))) + '(mp:with-process-lock (*Memory-Barrier-Lock*) + nil))) + #+lispworks (progn (defun make-lock (&optional name) - (declare (ignore name)) - nil) + (apply #'mp:make-lock (and name `(:name ,name)))) (defmacro with-lock ((lock &key (wait? t)) &body body) - (declare (ignore lock wait?)) - `(mp:without-interrupts . ,body)) + `(mp:with-lock (,lock :timeout (if ,wait? nil 0)) + . ,body)) + ;; For those implementations that support SMP but don't give us direct ways + ;; to generate memory barriers, we assume that grabbing a lock suffices. + (deflex *Memory-Barrier-Lock* + (mp:make-lock :name "Memory Barrier Lock")) (defmacro read-memory-barrier () - 'nil) + '(mp:with-lock (*Memory-Barrier-Lock*) + nil)) (defmacro write-memory-barrier () - 'nil)) + '(mp:with-lock (*Memory-Barrier-Lock*) + nil))) #+cmu @@ -76,33 +79,38 @@ (defmacro write-memory-barrier () 'nil)) -#+sbcl + +#+(and sbcl (not sb-thread)) (progn (defun make-lock (&optional name) - (sb-thread:make-mutex :name name)) + nil) (defmacro with-lock ((lock &key (wait? t)) &body body) - `(sb-thread:with-mutex (,lock :wait-p ,wait?) + (declare (ignore lock wait?)) + `(progn . ,body)) - #-sb-thread (progn (defmacro read-memory-barrier () - nil) + 'nil) (defmacro write-memory-barrier () - nil)) - #+sb-thread - (progn - (defvar *SBCL-Read-Memory-Barrier-Lock* - (sb-thread:make-mutex :name "Read Memory Barrier Lock")) - (defmacro read-memory-barrier () - ;; SBCL doesn't seem to have any better way to do this (yet). - (mp:with-process-lock (*SBCL-Read-Memory-Barrier-Lock*) - nil)) - (defvar *SBCL-Write-Memory-Barrier-Lock* - (sb-thread:make-mutex :name "Write Memory Barrier Lock")) - (defmacro write-memory-barrier () - ;; SBCL doesn't seem to have any better way to do this (yet). - (mp:with-process-lock (*SBCL-Write-Memory-Barrier-Lock*) - nil)))) + 'nil))) + +#+(and sbcl sb-thread) +(progn + (defun make-lock (&optional name) + (apply #'sb-thread:make-mutex (and name `(:name ,name)))) + (defmacro with-lock ((lock &key (wait? t)) &body body) + `(sb-thread:with-mutex (,lock :wait-p ,wait?) + . ,body)) + ;; For those implementations that support SMP but don't give us direct ways + ;; to generate memory barriers, we assume that grabbing a lock suffices. + (deflex *Memory-Barrier-Lock* + (sb-thread:make-mutex :name "Memory Barrier Lock")) + (defmacro read-memory-barrier () + '(mp:with-process-lock (*Memory-Barrier-Lock*) + nil)) + (defmacro write-memory-barrier () + '(mp:with-process-lock (*Memory-Barrier-Lock*) + nil))) #+scl @@ -111,12 +119,13 @@ (thread:make-lock name :type ':recursive :auto-free t)) (defmacro with-lock ((lock &key (wait? t)) &body body) `(thread:with-lock-held (,lock "Lock Wait" :wait ,wait?) - . ,body)) + . ,body)) (defmacro read-memory-barrier () '(kernel:read-memory-barrier)) (defmacro write-memory-barrier () '(kernel:write-memory-barrier))) + #+openmcl (progn (defun make-lock (&optional name) @@ -139,18 +148,17 @@ . ,body)) (when ,try-succeeded?-var (ccl:release-lock ,lock-var))))))) - (defvar *OpenMCL-Read-Memory-Barrier-Lock* - (ccl:make-lock "Read Memory Barrier Lock")) + ;; For those implementations that support SMP but don't give us direct ways + ;; to generate memory barriers, we assume that grabbing a lock suffices. + (deflex *Memory-Barrier-Lock* + (ccl:make-lock "Memory Barrier Lock")) (defmacro read-memory-barrier () - ;; OpenMCL doesn't seem to have any better way to do this. - (ccl:with-lock-grabbed (*OpenMCL-Read-Memory-Barrier-Lock*) - nil)) - (defvar *OpenMCL-Write-Memory-Barrier-Lock* - (ccl:make-lock "Write Memory Barrier Lock")) + `(ccl:with-lock-grabbed (*Memory-Barrier-Lock*) + nil)) (defmacro write-memory-barrier () - ;; OpenMCL doesn't seem to have any better way to do this. - (ccl:with-lock-grabbed (*OpenMCL-Write-Memory-Barrier-Lock*) - nil))) + `(ccl:with-lock-grabbed (*Memory-Barrier-Lock*) + nil))) + #+(and genera new-scheduler) (progn @@ -165,7 +173,7 @@ (defmacro read-memory-barrier () 'nil)) -;;; Some implementations have no threading at all (yet). + #+clisp (progn (defun make-lock (&optional name) @@ -180,6 +188,54 @@ 'nil)) +#+(and ecl (not threads)) +(progn + (defun make-lock (&optional name) + (declare (ignore name)) + nil) + (defmacro with-lock ((lock &key (wait? t)) &body body) + (declare (ignore lock wait?)) + `(progn . ,body)) + (defmacro read-memory-barrier () + 'nil) + (defmacro write-memory-barrier () + 'nil)) + +#+(and ecl threads) +(progn + (defun make-lock (&optional name) + (apply #'mp:make-lock (and name `(:name ,name)))) + (defmacro with-lock ((lock &key (wait? t)) &body body) + (let ((lock-var (gensym "LOCK-")) + (wait?-var (gensym "WAIT?-")) + (try-succeeded?-var (gensym "TRY-SUCCEEDED?-"))) + `(let ((,lock-var ,lock) + . ,(and (not (eq wait? 't)) + `((,wait?-var ,wait?) + (,try-succeeded?-var nil)))) + ,(if (eq wait? 't) + `(mp:with-lock (,lock-var) + . ,body) + `(unwind-protect + (and (or ,wait?-var (and (mp:get-lock ,lock-var nil) + (setq ,try-succeeded?-var t))) + (mp:with-lock (,lock-var) + . ,body)) + (when ,try-succeeded?-var + (mp:giveup-lock ,lock-var))))))) + (deflex *ECL-Read-Memory-Barrier-Lock* + (mp:make-lock :name "Read Memory Barrier Lock")) + (defmacro read-memory-barrier () + '(mp:with-lock (*ECL-Read-Memory-Barrier-Lock*) + nil)) + (deflex *ECL-Write-Memory-Barrier-Lock* + (mp:make-lock :name "Write Memory Barrier Lock")) + (defmacro write-memory-barrier () + '(mp:with-lock (*ECL-Write-Memory-Barrier-Lock*) + nil))) + + + ;;; ---------------- ;;; Constants used by the tuple implementation. We choose the widths of @@ -187,9 +243,11 @@ (defconstant Tuple-Key-Number-Size (ecase (integer-length most-positive-fixnum) + (61 40) ; ECL, 64-bit (60 40) ; SBCL, OpenMCL, Scieneer CL, 64-bit + (48 32) ; CLISP, 64-bit (31 18) ; Symbolics L-machine, I-machine - (29 17) ; Allegro, CMUCL, SBCL, LispWorks (most), 32-bit + (29 17) ; Allegro, CMUCL, SBCL, LispWorks (most), ECL, 32-bit (24 15) ; CLISP, 32-bit (23 14)) ; LispWorks 4 on Linux "This limits the number of tuple-keys that can exist in a session.") @@ -199,7 +257,9 @@ (defconstant Tuple-Value-Index-Size (ecase (integer-length most-positive-fixnum) + (61 21) (60 20) + (48 16) (31 13) (29 12) (24 9) Modified: trunk/Code/relations.lisp ============================================================================== --- trunk/Code/relations.lisp (original) +++ trunk/Code/relations.lisp Mon Nov 3 05:08:58 2008 @@ -448,18 +448,18 @@ nil)))))) -(defgeneric closure (2-relation set) +(defgeneric transitive-closure (2-relation set) (:documentation "The transitive closure of the set over the relation. The relation may also be supplied as a function returning a set.")) -(defmethod closure ((fn function) (s set)) - (set-closure fn s)) +(defmethod transitive-closure ((fn function) (s set)) + (set-transitive-closure fn s)) -(defmethod closure ((r 2-relation) (s set)) - (set-closure r s)) +(defmethod transitive-closure ((r 2-relation) (s set)) + (set-transitive-closure r s)) -(defun set-closure (r s) +(defun set-transitive-closure (r s) ;; This could probably use a little moer work. (let ((workset (set-difference (reduce #'union (image r (convert 'seq s)) :initial-value (set)) Modified: trunk/Code/tuples.lisp ============================================================================== --- trunk/Code/tuples.lisp (original) +++ trunk/Code/tuples.lisp Mon Nov 3 05:08:58 2008 @@ -124,11 +124,11 @@ ; (called with one argument, the tuple), or nil number) ; used for lookup and sorting -(defvar *Tuple-Key-Name-Map* (empty-map)) +(deflex +Tuple-Key-Name-Map+ (empty-map)) -(defvar *Tuple-Key-Seq* (empty-seq)) +(deflex +Tuple-Key-Seq+ (empty-seq)) -(defvar *Tuple-Key-Lock* (make-lock "Tuple Key Lock")) +(deflex +Tuple-Key-Lock+ (make-lock "Tuple Key Lock")) (defun get-tuple-key (name &optional default-fn) "Finds or creates a tuple key named `name'. If the key did not already exist, @@ -136,23 +136,24 @@ the tuple has no explicit pair with this key; it is called with one argument, the tuple." (assert (or (null default-fn) (typep default-fn 'function))) - (with-lock (*Tuple-Key-Lock*) - (let ((key (lookup *Tuple-Key-Name-Map* name)) - (key-idx (size *Tuple-Key-Seq*))) + (with-lock (+Tuple-Key-Lock+) + (let ((key (lookup +Tuple-Key-Name-Map+ name)) + (key-idx (size +Tuple-Key-Seq+))) (or key (if (<= key-idx Tuple-Key-Number-Mask) (let ((key (make-tuple-key name default-fn key-idx))) - (setf (lookup *Tuple-Key-Name-Map* name) key) - (push-last *Tuple-Key-Seq* key) + (setf (lookup +Tuple-Key-Name-Map+ name) key) + (push-last +Tuple-Key-Seq+ key) key) (error "Tuple key space exhausted")))))) (defmacro def-tuple-key (name &optional default-fn) - "Defines a tuple key named `name'. If `default-fn' is supplied, it is used -to compute a value for lookups where the tuple has no explicit pair with this -key; it is called with one argument, the tuple." + "Defines a tuple key named `name' as a global lexical variable (see `deflex'). +If `default-fn' is supplied, it is used to compute a value for lookups where +the tuple has no explicit pair with this key; it is called with one argument, +the tuple." (assert (symbolp name)) - `(defvar ,name (get-tuple-key ',name ,default-fn))) + `(deflex ,name (get-tuple-key ',name ,default-fn))) (defun print-tuple-key (key stream level) (declare (ignore level)) @@ -193,17 +194,17 @@ ;; Serial number (used for `Reorder-Map-Map'). Serial-Number) -(defvar Tuple-Desc-Next-Serial-Number 0) +(deflex +Tuple-Desc-Next-Serial-Number+ 0) -(defvar Tuple-Desc-Next-Serial-Number-Lock (make-lock)) +(deflex +Tuple-Desc-Next-Serial-Number-Lock+ (make-lock)) (defun Make-Tuple-Desc (key-set pairs) (Make-Tuple-Desc-Internal key-set pairs (make-lock) - (prog1 Tuple-Desc-Next-Serial-Number - (with-lock (Tuple-Desc-Next-Serial-Number-Lock) - (incf Tuple-Desc-Next-Serial-Number))))) + (prog1 +Tuple-Desc-Next-Serial-Number+ + (with-lock (+Tuple-Desc-Next-Serial-Number-Lock+) + (incf +Tuple-Desc-Next-Serial-Number+))))) -(defvar *Tuple-Descriptor-Map* (empty-map)) +(deflex +Tuple-Descriptor-Map+ (empty-map)) (defmethod compare ((x Tuple-Desc) (y Tuple-Desc)) (let ((xser (Tuple-Desc-Serial-Number x)) @@ -233,13 +234,13 @@ (defun empty-dyn-tuple () "Returns an empty dyn-tuple." - (let ((desc (lookup *Tuple-Descriptor-Map* (empty-map)))) + (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)) + (setf (lookup +Tuple-Descriptor-Map+ (empty-map)) desc)) (make-dyn-tuple desc (vector)))) -(defvar *Tuple-Random-Value* 0 +(deflex +Tuple-Random-Value+ 0 "State for an extremely fast, low-quality generator of small numbers of pseudorandom bits. Yep, this is about as quick-and-dirty as it gets -- we just increment this value by some small prime like 5 each time. We @@ -248,8 +249,8 @@ (declaim (inline Tuple-Random-Value)) (defun Tuple-Random-Value () (the fixnum - (setf *Tuple-Random-Value* - (logand (+ (the fixnum *Tuple-Random-Value*) 5) + (setf +Tuple-Random-Value+ + (logand (+ (the fixnum +Tuple-Random-Value+) 5) most-positive-fixnum)))) (defconstant Tuple-Reorder-Frequency 31 @@ -349,7 +350,7 @@ (let ((nks (with (Tuple-Desc-Key-Set old-desc) key)) ((nd (progn (read-memory-barrier) - (lookup *Tuple-Descriptor-Map* nks))))) + (lookup +Tuple-Descriptor-Map+ nks))))) (when nd (setf (lookup (Tuple-Desc-Next-Desc-Map old-desc) key) nd)) (values nd nks))))) @@ -358,7 +359,7 @@ (old-pairs (Tuple-Desc-Pairs old-desc))) (unless new-desc ;; Lock out reorderings while we do this. One might think we also need a - ;; lock to protect `*Tuple-Descriptor-Map*', but actually it doesn't hurt + ;; lock to protect `+Tuple-Descriptor-Map+', but actually it doesn't hurt ;; anything if we lose an occasional entry -- some tuples will use a ;; descriptor not in the map, but nothing goes wrong as a consequence. (with-lock ((Tuple-Desc-Lock old-desc)) @@ -380,12 +381,12 @@ (dotimes (i (- nkeys window-size 1)) (add-pair (+ i window-size 1) (svref old-pairs (+ i window-size))))))))) - ;(setf (lookup *Tuple-Descriptor-Map* new-key-set) new-desc) + ;(setf (lookup +Tuple-Descriptor-Map+ new-key-set) new-desc) ;; Technically, we need a memory barrier to make sure the new map value ;; is fully constructed before being made available to other threads. - (setq *Tuple-Descriptor-Map* + (setq +Tuple-Descriptor-Map+ (prog1 - (with *Tuple-Descriptor-Map* new-key-set new-desc) + (with +Tuple-Descriptor-Map+ new-key-set new-desc) (write-memory-barrier))) (setf (lookup (Tuple-Desc-Next-Desc-Map old-desc) key) new-desc)) (let ((reorder-map (Tuple-Get-Reorder-Map old-desc new-desc)) @@ -478,7 +479,7 @@ (declare (fixnum ,idx-var)) (let ((,pr-var (the fixnum (svref ,pairs-var ,idx-var))) ((,val-idx-var (ash ,pr-var (- Tuple-Key-Number-Size))))) - (let ((,key-var (lookup *Tuple-Key-Seq* + (let ((,key-var (lookup +Tuple-Key-Seq+ (logand ,pr-var Tuple-Key-Number-Mask))) (,value-var (svref (svref ,contents-var (ash ,val-idx-var Modified: trunk/Code/wb-trees.lisp ============================================================================== --- trunk/Code/wb-trees.lisp (original) +++ trunk/Code/wb-trees.lisp Mon Nov 3 05:08:58 2008 @@ -1610,7 +1610,8 @@ ;;; 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)) + (declare (optimize (speed 3) (safety 0)) + (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) @@ -1632,11 +1633,11 @@ (defconstant WB-Tree-Precomputed-Max-Depths 1000) -(defvar *WB-Tree-Max-Depths-Without-Values* +(deflex +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* +(deflex +WB-Tree-Max-Depths-With-Values+ (gmap :vector (lambda (i) (WB-Tree-True-Max-Depth i t)) (:index 0 WB-Tree-Precomputed-Max-Depths))) @@ -1649,8 +1650,8 @@ (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*) + +WB-Tree-Max-Depths-With-Values+ + +WB-Tree-Max-Depths-Without-Values+) size) (values (ceiling (* (1- (integer-length size)) ;; constant:

1 0

[fset-cvs] r19 - trunk/Code
by Scott L. Burson 27 Oct '08

27 Oct '08

Author: sburson Date: Mon Oct 27 04:44:52 2008 New Revision: 19 Log: Whoops, forgot to export `set-size'. Modified: trunk/Code/defs.lisp Modified: trunk/Code/defs.lisp ============================================================================== --- trunk/Code/defs.lisp (original) +++ trunk/Code/defs.lisp Mon Oct 27 04:44:52 2008 @@ -37,7 +37,7 @@ ;; are unlikely to be useful in user code. #:equal? #:compare #:compare-slots #:identity-ordering-mixin #:define-cross-type-compare-methods - #:empty? nonempty? #:size #:arb #:contains? #:multiplicity + #:empty? nonempty? #:size #:set-size #:arb #:contains? #:multiplicity #:empty-set #:empty-bag #:empty-map #:empty-seq #:empty-tuple #:empty-wb-set #:empty-wb-bag #:empty-wb-map #:empty-wb-seq #:empty-dyn-tuple

1 0

[fset-cvs] r18 - trunk/Code
by Scott L. Burson 26 Oct '08

26 Oct '08

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

1 0

[fset-cvs] RE: Men's Health id 13974300
by Doctor Matt 29 Sep '08

29 Sep '08

1 0

[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

[fset-cvs] r15 - tags/fset_1.0.1
by sburson＠common-lisp.net 11 Jun '07

11 Jun '07

Author: sburson Date: Sun Jun 10 21:37:28 2007 New Revision: 15 Added: tags/fset_1.0.1/ - copied from r14, trunk/ Log: Tagging 1.0.1.

1 0