[fset-cvs] r27 - trunk/Code
sburson at common-lisp.net
sburson at common-lisp.net
Sun Nov 13 05:21:21 UTC 2011
Author: sburson
Date: Sat Nov 12 21:21:18 2011
New Revision: 27
Log:
Merging lots of stuff in from development branch for 1.3.0 release.
Highlights:
* Added `:default' feature to `map' constructor macro.
* Some new modify macros: `includef' (replaces `adjoinf'), `excludef'
(replaces `removef'), `intersectf', `imagef', `composef'. `reduce' now
works on maps.
* Added operations:
() `split' (two-valued `filter')
() `splice' (splice a seq into another seq)
() `appendf' and `prependf' (seq concat-and-assign)
() `tuple-key-name' (new export)
Also, changed `concat' from binary to n-ary.
* Made the methods for `sort' and `stable-sort' on CL sequences copy the
sequence first, so these are now functional operations -- consistent with
FSet semantics, but not with their CL definitions. (In practice the
sequence usually has to be copied anyway; and you can always call `cl:sort'
explicitly if you don't want it to be copied.)
* Made (convert 'vector seq) always return a simple-vector, instead of
figuring out dynamically whether to return a string (which fails on the
empty seq, duh). Added (convert 'string seq) that always returns a string
(errors if it can't).
* New, experimental type `list-relation'. Various other improvements to
relations.
Modified:
trunk/Code/defs.lisp
trunk/Code/fset.lisp
trunk/Code/order.lisp
trunk/Code/reader.lisp
trunk/Code/relations.lisp
trunk/Code/testing.lisp
trunk/Code/tuples.lisp
trunk/Code/wb-trees.lisp
Modified: trunk/Code/defs.lisp
==============================================================================
--- trunk/Code/defs.lisp Sun Nov 9 21:44:59 2008 (r26)
+++ trunk/Code/defs.lisp Sat Nov 12 21:21:18 2011 (r27)
@@ -37,6 +37,7 @@
;; are unlikely to be useful in user code.
#:equal? #:compare #:compare-slots #:identity-ordering-mixin
#:define-cross-type-compare-methods
+ #:compare-lexicographically
#:empty? nonempty? #:size #:set-size #:arb
#:contains? #:domain-contains? #:range-contains? #:member? #:multiplicity
#:empty-set #:empty-bag #:empty-map #:empty-seq #:empty-tuple
@@ -47,14 +48,15 @@
#:union #:bag-sum #:intersection #:bag-product #:complement
#:set-difference #:set-difference-2 #:bag-difference
#:subset? #:disjoint? #:subbag?
- #:filter #:image #:reduce #:domain #:range #:with-default
+ #:filter #:filter-pairs #:split
+ #: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
- #:with-last #:less-last #:push-last #:pop-last
- #:insert #:subseq #:concat #:reverse #:sort #:stable-sort
+ #:with-last #:less-last #:push-last #:pop-last #:appendf #:prependf
+ #:insert #:splice #:subseq #:concat #:reverse #:sort #:stable-sort
#:find #:find-if #:find-if-not
#:count #:count-if #:count-if-not
#:position #:position-if #:position-if-not
@@ -62,8 +64,10 @@
#:substitute #:substitute-if #:substitute-if-not
#: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
+ #:adjoinf #:removef #:includef #:excludef
+ #:unionf #:intersectf #:imagef #:composef
+ #:define-tuple-key #:def-tuple-key #:get-tuple-key #:tuple-key-name
+ #:tuple-merge
#:fset-setup-readtable #:*fset-readtable*
#:$
;; Used by the bag methods that convert to and from lists.
@@ -72,7 +76,12 @@
#: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))
+ #:lookup-inv #:inverse #:join #:conflicts #:map-to-sets
+ #:list-relation #:wb-list-relation #:empty-list-relation
+ #:empty-wb-list-relation #:arity #:query #:query-multi #:do-list-relation
+ #:query-registry #:empty-query-registry #:with-query #:less-query
+ #:all-queries #:lookup-multi #:forward-key #:lookup-restricted
+ #:lookup-multi-restricted))
;;; A convenient package for experimenting with FSet. Also serves as an example
Modified: trunk/Code/fset.lisp
==============================================================================
--- trunk/Code/fset.lisp Sun Nov 9 21:44:59 2008 (r26)
+++ trunk/Code/fset.lisp Sat Nov 12 21:21:18 2011 (r27)
@@ -234,6 +234,20 @@
as a Lisp function, `fn' can be a map, or a set (which is treated as mapping
its members to true and everything else to false)."))
+(defgeneric split (fn collection)
+ (:documentation
+ "Returns two values, (filter fn collection) and
+\(filter (cl:complement fn) collection)."))
+
+(defgeneric filter-pairs (fn collection)
+ (:documentation
+ "Just like `filter' except that if invoked on a bag, `fn' (which must be a
+Lisp function) is called with two arguments for each pair, the member and the
+multiplicity."))
+
+(defmethod filter-pairs (fn (collection t))
+ (filter fn collection))
+
(defgeneric image (fn collection)
(:documentation
"Returns a new collection containing the result of applying `fn' to each
@@ -243,7 +257,20 @@
map, or a set (which is treated as mapping its members to true and everything
else to false). `collection' can also be a map, in which case `fn' must be a
Lisp function of two arguments that returns two values (the map-default of the
-result is that of `collection')."))
+result is that of `collection'); also see `compose'."))
+
+;;; Convenience methods.
+(defmethod image ((fn function) (l list))
+ (mapcar fn l))
+
+(defmethod image ((fn symbol) (l list))
+ (mapcar (coerce fn 'function) l))
+
+(defmethod image ((fn map) (l list))
+ (mapcar (lambda (x) (@ fn x)) l))
+
+(defmethod image ((fn set) (l list))
+ (mapcar (lambda (x) (@ fn x)) l))
(defgeneric reduce (fn collection &key key initial-value)
(:documentation
@@ -261,6 +288,8 @@
(:documentation
"Returns the domain of the map, that is, the set of keys mapped by the map."))
+;;; &&& Actually I think this should return a bag. You can then convert it
+;;; to a set if you want.
(defgeneric range (map)
(:documentation
"Returns the range of the map, that is, the set of all values to which keys
@@ -303,6 +332,23 @@
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'."))
+;;; Possible operation: `map-update' (better name??), which would be like
+;;; `map-union' except the keys would be exactly the keys of `map1'. This
+;;; would be useful for removing items from chained maps:
+;;;
+;;; (map-update chained-map
+;;; (map (key1 (map (key2 (set val)))))
+;;; (fn (x y) (map-update x y #'set-difference)))
+;;;
+;;; If key1->key2->val is not already present, this returns `chained-map'.
+;;;
+;;; But another operation with a legitimate claim on the name would simply
+;;; apply a function to the range value for a specified key:
+;;;
+;;; (map-update chained-map key1
+;;; (fn (m) (map-update m key2
+;;; (fn (s) (less s val)))))
+
(defgeneric restrict (map set)
(:documentation
"Returns a map containing only those pairs of `map' whose keys are
@@ -318,7 +364,8 @@
(:documentation
"Returns a new map with the same domain as `map1', which maps each member
of that domain to the result of applying first `map1' to it, then applying
-`map2-or-fn' to the result."))
+`map2-or-fn' to the result. `map2-or-fn' can also be a sequence, which is
+treated as a map from indices to members."))
(defgeneric first (seq)
(:documentation
@@ -369,11 +416,17 @@
is extended in either direction if needed prior to the insertion; previously
uninitialized indices are filled with the seq's default)."))
+(defgeneric splice (seq idx subseq)
+ (:documentation
+ "Returns a new sequence like `seq' but with the elements of `subseq' 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.
-(defgeneric concat (seq1 seq2)
+(defgeneric concat (seq1 &rest seqs)
(:documentation
- "Returns the concatenation of `seq1' and `seq2'."))
+ "Returns the concatenation of `seq1' with each of `seqs'."))
;;; This is the opposite order from `cl:coerce', but I like it better, because I
@@ -508,19 +561,21 @@
"Returns `seq' sorted by `pred', a function of two arguments; if `key' is
supplied, it is a function of one argument that is applied to the elements of
`seq' before they are passed to `pred'. The sort is not guaranteed to be
-stable."))
+stable. The method for CL sequences copies the sequence first, unlike
+`cl:sort'."))
(defmethod sort ((s sequence) pred &key key)
- (cl:sort s pred :key key))
+ (cl:sort (cl:copy-seq s) pred :key key))
(defgeneric stable-sort (seq pred &key key)
(:documentation
"Returns `seq' sorted by `pred', a function of two arguments; if `key' is
supplied, it is a function of one argument that is applied to the elements of
-`seq' before they are passed to `pred'. The sort is guaranteed to be stable."))
+`seq' before they are passed to `pred'. The sort is guaranteed to be stable.
+The method for CL sequences copies the sequence first, unlike `cl:stable-sort'."))
(defmethod stable-sort ((s sequence) pred &key key)
- (cl:stable-sort s pred :key key))
+ (cl:stable-sort (cl:copy-seq s) pred :key key))
(defgeneric find (item collection &key key test)
(:documentation
@@ -820,6 +875,8 @@
`(lookup ,access-form ,key-temp))))
+;;; `adjoinf' / `removef', which don't form a good pair, are now deprecated
+;;; in favor of `includef' / `excludef'.
(define-modify-macro adjoinf (&rest item-or-tuple)
with
"(adjoinf coll . args) --> (setf coll (with coll . args))")
@@ -828,9 +885,29 @@
less
"(removef coll . args) --> (setf coll (less coll . args))")
+(define-modify-macro includef (&rest item-or-tuple)
+ with
+ "(includef coll . args) --> (setf coll (with coll . args))")
+
+(define-modify-macro excludef (&rest item-or-tuple)
+ less
+ "(excludef coll . args) --> (setf coll (less coll . args))")
+
(define-modify-macro unionf (set)
union)
+(define-modify-macro intersectf (set)
+ intersection)
+
+(define-modify-macro imagef (fn)
+ ximage)
+
+(defun ximage (coll fn)
+ (image fn coll))
+
+(define-modify-macro composef (fn)
+ compose)
+
(define-modify-macro push-first (val)
with-first
"(push-first seq val) --> (setf seq (with-first seq val))")
@@ -863,6 +940,15 @@
(setq ,(car new) (less-last ,(car new)))
,setter))))
+(define-modify-macro appendf (seq)
+ concat)
+
+(define-modify-macro prependf (seq)
+ xconcat)
+
+(defun xconcat (seq1 seq2)
+ (concat seq2 seq1))
+
;;; ================================================================================
;;; Sets
@@ -1120,14 +1206,6 @@
(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)))
@@ -1223,20 +1301,13 @@
(count-if #'(lambda (x) (not (funcall pred x))) s :key key)))
(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)
- (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))))
- (format stream " }"))))
+ (declare (ignore level))
+ (pprint-logical-block (stream nil :prefix "#{" :suffix " }")
+ (do-set (x set)
+ (pprint-pop)
+ (write-char #\Space stream)
+ (pprint-newline :linear stream)
+ (write x :stream stream))))
(def-gmap-arg-type :set (set)
"Yields the elements of `set'."
@@ -1261,6 +1332,15 @@
`(nil #'WB-Set-Tree-With #'make-wb-set ,filterp))
+(def-gmap-res-type :union (&key filterp)
+ "Returns the union of the values, optionally filtered by `filterp'."
+ `((set) #'union nil ,filterp))
+
+(def-gmap-res-type :intersection (&key filterp)
+ "Returns the intersection of the values, optionally filtered by `filterp'."
+ `((complement (set)) #'intersection nil ,filterp))
+
+
;;; ================================================================================
;;; Bags
@@ -1381,11 +1461,11 @@
(make-wb-bag (WB-Bag-Tree-Intersect (wb-bag-contents s1) (wb-bag-contents s2))))
(defmethod intersection ((s wb-set) (b wb-bag) &key)
- (make-wb-bag (WB-Set-Tree-Intersect (wb-set-contents s)
+ (make-wb-set (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) &key)
- (make-wb-bag (WB-Set-Tree-Intersect (WB-Bag-Tree-To-Set-Tree (wb-bag-contents b))
+ (make-wb-set (WB-Set-Tree-Intersect (WB-Bag-Tree-To-Set-Tree (wb-bag-contents b))
(wb-set-contents s))))
(defmethod bag-product ((b1 wb-bag) (b2 wb-bag))
@@ -1487,6 +1567,19 @@
(defmethod filter ((pred bag) (b bag))
(bag-filter pred b))
+(defun bag-filter-pairs (pred b)
+ (let ((result nil))
+ (do-bag-pairs (x n b)
+ (when (funcall pred x n)
+ (setq result (WB-Bag-Tree-With result x n))))
+ (make-wb-bag result)))
+
+(defmethod filter-pairs ((pred function) (b bag))
+ (bag-filter-pairs pred b))
+
+(defmethod filter-pairs ((pred symbol) (b bag))
+ (bag-filter-pairs (coerce pred 'function) b))
+
(defmethod image ((fn function) (b bag))
(bag-image fn b))
@@ -1690,28 +1783,18 @@
(count-if #'(lambda (x) (not (funcall pred x))) s :key key)))
(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 "%}"))))
-
+ (declare (ignore level))
+ (pprint-logical-block (stream nil :prefix "#{%" :suffix " %}")
+ (let ((i 0))
+ (do-bag-pairs (x n bag)
+ (pprint-pop)
+ (write-char #\Space stream)
+ (pprint-newline :linear stream)
+ (incf i)
+ (if (> n 1)
+ (progn
+ (write `(,x ,n) :stream stream))
+ (write x :stream stream))))))
(def-gmap-arg-type :bag (bag)
"Yields each element of `bag', as many times as its multiplicity."
@@ -1904,6 +1987,27 @@
(setq result (WB-Map-Tree-With result new-x new-y))))
(make-wb-map result (map-default m))))
+(defmethod reduce ((fn function) (m map) &key key (initial-value nil init?))
+ (map-reduce fn m initial-value (and key (coerce key 'function)) init?))
+
+(defmethod reduce ((fn symbol) (m map) &key key (initial-value nil init?))
+ (map-reduce (coerce fn 'function) m initial-value (and key (coerce key 'function))
+ init?))
+
+(defun map-reduce (fn m initial-value key init?)
+ (declare (optimize (speed 3) (safety 0))
+ (type function fn)
+ (type (or function null) key))
+ (unless init?
+ (error 'simple-program-error
+ :format-control "~A on a map requires an initial value"
+ :format-arguments '(reduce)))
+ (let ((result initial-value))
+ (do-map (x y m)
+ (let ((x y (if key (funcall key x y) (values x y))))
+ (setq result (funcall fn result x y))))
+ result))
+
(defmethod range ((m map))
(let ((s nil))
(do-map (key val m)
@@ -1966,6 +2070,9 @@
(defmethod compose ((m wb-map) (fn symbol))
(map-fn-compose m (coerce fn 'function)))
+(defmethod compose ((m wb-map) (s seq))
+ (map-fn-compose m (fn (x) (@ s x))))
+
(defun map-fn-compose (m fn)
(make-wb-map (WB-Map-Tree-Compose (wb-map-contents m) fn)
(funcall fn (map-default m))))
@@ -2116,27 +2223,14 @@
(count-if #'(lambda (x) (not (funcall pred x))) m :key key)))
(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 :pretty nil)))
- (when (> i 0)
- (format stream " ")))
- (format stream "|}")
- (let ((default (map-default map)))
- (when default
- (format stream "/~A" default))))))
-
+ (declare (ignore level))
+ (pprint-logical-block (stream nil :prefix "#{|")
+ (do-map (x y map)
+ (pprint-pop)
+ (write-char #\Space stream)
+ (pprint-newline :linear stream)
+ (write (list x y) :stream stream))
+ (format stream " |}~:[~;/~:*~A~]" (map-default map))))
(def-gmap-arg-type :map (map)
"Yields each pair of `map', as two values."
@@ -2274,6 +2368,26 @@
(make-wb-seq (WB-Seq-Tree-Insert tree idx val)
(seq-default s))))
+(defmethod splice ((s wb-seq) idx subseq)
+ (let ((tree (wb-seq-contents s))
+ ((size (WB-Seq-Tree-Size tree)))
+ (subseq-tree (wb-seq-contents (convert 'wb-seq subseq))))
+ (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-Concat (WB-Seq-Tree-Concat (WB-Seq-Tree-Subseq tree 0 idx)
+ subseq-tree)
+ (WB-Seq-Tree-Subseq tree idx (WB-Seq-Tree-Size tree)))
+ (seq-default s))))
+
(defmethod less ((s wb-seq) idx &optional (arg2 nil arg2?))
(declare (ignore arg2))
(check-two-arguments arg2? 'less 'wb-seq)
@@ -2283,10 +2397,11 @@
(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))
- ;; Don't see what to do but pick one arbitrarily.
- (seq-default s1)))
+(defmethod concat ((s1 seq) &rest seqs)
+ (let ((tree (wb-seq-contents s1)))
+ (dolist (seq seqs)
+ (setq tree (WB-Seq-Tree-Concat tree (wb-seq-contents (convert 'seq seq)))))
+ (make-wb-seq tree (seq-default s1))))
(defmethod subseq ((s wb-seq) start &optional end)
(let ((tree (wb-seq-contents s))
@@ -2332,6 +2447,10 @@
(defmethod convert ((to-type (eql 'vector)) (s wb-seq) &key)
(WB-Seq-Tree-To-Vector (wb-seq-contents s)))
+;;; Always returns a string. Signals `type-error' if it encounters a non-character.
+(defmethod convert ((to-type (eql 'string)) (s wb-seq) &key)
+ (WB-Seq-Tree-To-String (wb-seq-contents s)))
+
(defmethod convert ((to-type (eql 'seq)) (l list) &key)
(make-wb-seq (WB-Seq-Tree-From-List l)))
@@ -2341,6 +2460,10 @@
(defmethod convert ((to-type (eql 'list)) (s wb-seq) &key)
(WB-Seq-Tree-To-List (wb-seq-contents s)))
+(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)))
@@ -2448,6 +2571,35 @@
(make-wb-seq (WB-Seq-Tree-From-List (nreverse result))
(seq-default s))))
+(defmethod split ((fn function) (s seq))
+ (seq-split fn s))
+
+(defmethod split ((fn symbol) (s seq))
+ (seq-split (coerce fn 'function) s))
+
+(defmethod split ((fn map) (s seq))
+ (seq-split #'(lambda (x) (lookup fn x)) s))
+
+(defmethod split ((fn set) (s seq))
+ (seq-split #'(lambda (x) (lookup fn x)) s))
+
+(defmethod split ((fn bag) (s seq))
+ (seq-split #'(lambda (x) (lookup fn x)) s))
+
+(defun seq-split (fn s)
+ (declare (optimize (speed 3) (safety 0))
+ (type function fn))
+ (let ((result-1 nil)
+ (result-2 nil))
+ (do-seq (x s)
+ (if (funcall fn x)
+ (push x result-1)
+ (push x result-2)))
+ (values (make-wb-seq (WB-Seq-Tree-From-List (nreverse result-1))
+ (seq-default s))
+ (make-wb-seq (WB-Seq-Tree-From-List (nreverse result-2))
+ (seq-default s)))))
+
(defmethod image ((fn function) (s seq))
(seq-image fn s))
@@ -2750,26 +2902,14 @@
:key key :start start :end end :from-end from-end :count count)))
(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 "]")
- (let ((default (seq-default seq)))
- (when default
- (format stream "/~A" default))))))
+ (declare (ignore level))
+ (pprint-logical-block (stream nil :prefix "#[")
+ (do-seq (x seq)
+ (pprint-pop)
+ (write-char #\Space stream)
+ (pprint-newline :linear stream)
+ (write x :stream stream))
+ (format stream " ]~:[~;/~:*~A~]" (seq-default seq))))
(def-gmap-arg-type :seq (seq)
"Yields the elements of `seq'."
@@ -2797,6 +2937,10 @@
#'(lambda (s) (convert 'seq (nreverse s)))
,filterp))
+(def-gmap-res-type :concat (&key filterp)
+ "Returns the concatenation of the seq values, optionally filtered by `filterp'."
+ `((seq) #'concat nil ,filterp))
+
;;; ================================================================================
;;; CL Sequences
@@ -2812,6 +2956,14 @@
(defmethod size ((s sequence))
(length s))
-(defmethod lookup ((s sequence) idx)
+(defmethod lookup ((s sequence) (idx integer))
(elt s idx))
+
+;;; ================================================================================
+;;; Miscellany
+
+;;; Oooops -- I somehow thought CL already had this.
+(define-condition simple-program-error (simple-condition program-error)
+ ())
+
Modified: trunk/Code/order.lisp
==============================================================================
--- trunk/Code/order.lisp Sun Nov 9 21:44:59 2008 (r26)
+++ trunk/Code/order.lisp Sat Nov 12 21:21:18 2011 (r27)
@@ -33,7 +33,17 @@
;;; 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))
+;;; (compare-slots f1 f2 'foo #'frob-bar))
+;;;
+;;; where `foo' is a slot and `frob-bar' is an accessor (or any other
+;;; function on your class).
+;;;
+;;; If you want distinct instances to never compare `:equal', put `:eql'
+;;; at the end of the accessor list to specify that `eql' is the final
+;;; determiner of equality for your type:
+;;;
+;;; (defmethod compare ((f1 frob) (f2 frob))
+;;; (compare-slots f1 f2 'foo #'frob-bar :eql))
;;;
(defmacro compare-slots (obj1 obj2 &rest accessors)
"A handy macro for writing the bodies of `compare' methods for user classes.
@@ -44,13 +54,23 @@
example, if class `frob' has accessor `frob-foo' and slot `bar':
(defmethod compare ((f1 frob) (f2 frob))
- (compare-slots f1 f2 #'frob-foo 'bar))"
+ (compare-slots f1 f2 #'frob-foo 'bar))
+
+If the symbol `:eql' is supplied as the last accessor, then if the comparisons
+by the other supplied accessors all return `:equal' but `obj1' and `obj2' are
+not eql, this returns `:unequal'."
(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
+ (if (or (null accs)
+ (and (eq (car accs) ':eql)
+ (or (null (cdr accs))
+ (error "If ~S is supplied to ~S, it must be ~
+ the last argument"
+ ':eql 'compare-slots))))
+ 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))
@@ -73,8 +93,9 @@
(t `(funcall ,fn ,arg)))))
`(let ((,obj1-var ,obj1)
(,obj2-var ,obj2)
- (,default-var ':equal))
- ,(rec accessors)))))
+ (,default-var ,(if (member ':eql accessors) '':unequal '':equal)))
+ (if (eql ,obj1-var ,obj2-var) ':equal
+ ,(rec accessors))))))
;;; Abstract classes
@@ -324,7 +345,8 @@
(let ((len-a (length a))
(len-b (length b))
(default ':equal))
- (cond ((< len-a len-b) ':less)
+ (cond ((eq a b) ':equal)
+ ((< len-a len-b) ':less)
((> len-a len-b) ':greater)
((and (simple-vector-p a) (simple-vector-p b))
(dotimes (i len-a default)
@@ -359,6 +381,8 @@
(if (or (eq comp ':less) (eq comp ':greater))
comp
default)))
+ (when (eq a b) ; we could get lucky
+ (return default))
(let ((comp (compare (car a) (car b))))
(when (or (eq comp ':less) (eq comp ':greater))
(return comp))
@@ -412,49 +436,53 @@
can be strings, vectors, lists, or seqs."))
(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))
+ (if (eq a b)
+ ':equal
+ (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 (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)))))
- (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))))))))
+ ((char> ca cb) (return ':greater)))))))))
(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))
+ (if (eq a b)
+ ':equal
+ (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 (svref a i) (svref b i))))
+ (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))))
- (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)))))))
+ (setq default ':unequal))))))))
Modified: trunk/Code/reader.lisp
==============================================================================
--- trunk/Code/reader.lisp Sun Nov 9 21:44:59 2008 (r26)
+++ trunk/Code/reader.lisp Sat Nov 12 21:21:18 2011 (r27)
@@ -258,10 +258,11 @@
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."
+expression must evaluate to a map, denoting all its mappings; or the symbol
+`:default', in which case the next argument subform is a form whose value will
+become the map's default. 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."
(expand-map-constructor-form 'map args))
(defmacro wb-map (&rest args)
@@ -269,18 +270,23 @@
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."
+map, denoting all its mappings; or the symbol `:default', in which case the
+next argument subform is a form whose value will become the map's default. 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."
(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)))))
+ (wb-map `(empty-wb-map))))
+ (default nil))
(labels ((recur (args result)
(cond ((null args) result)
+ ((eq (car args) ':default)
+ (setq default (cadr args))
+ (recur (cddr args) result))
((not (and (listp (car args))
(= (length (car args)) 2)))
(error "Arguments to ~S must all be pairs expressed as 2-element~@
@@ -292,7 +298,7 @@
(recur (cdr args) `(map-union ,result ,(cadar args)))))
(t
(recur (cdr args) `(with ,result ,(caar args) ,(cadar args)))))))
- (recur args empty-form))))
+ `(with-default ,(recur args empty-form) ,default))))
(defmacro seq (&rest args)
"Constructs a seq of the default implementation according to the supplied
Modified: trunk/Code/relations.lisp
==============================================================================
--- trunk/Code/relations.lisp Sun Nov 9 21:44:59 2008 (r26)
+++ trunk/Code/relations.lisp Sat Nov 12 21:21:18 2011 (r27)
@@ -75,6 +75,11 @@
(and found? (WB-Set-Tree-Member? set-tree (cdr pr)))))
;;; Returns the range set.
+;;; &&& Aaagh -- not sure this makes sense -- (setf (lookup rel x) ...) doesn't do
+;;; the right thing at all, relative to this. Maybe the setf expander for `lookup'/`@'
+;;; should call an internal form of `with' that does something different on a
+;;; relation... Yes, I think this operation should be renamed, and `setf-lookup'
+;;; should not exist on a relation, as `lookup' should not.
(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)
@@ -189,17 +194,17 @@
(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))
+ (lambda (s1 s2)
(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)))))))
+ (progn
+ (get-inverse br1)
+ (get-inverse br2)
+ (WB-Map-Tree-Union (wb-2-relation-map1 br1)
+ (wb-2-relation-map1 br2)
+ #'WB-Set-Tree-Union))))))
(make-wb-2-relation new-size new-map0 new-map1)))
(defmethod intersection ((br1 wb-2-relation) (br2 wb-2-relation) &key)
@@ -210,14 +215,14 @@
(declare (ignore ignore))
(let ((s (WB-Set-Tree-Intersect s1 s2)))
(incf new-size (WB-Set-Tree-Size s))
- (values s 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))))))))
+ (progn
+ (get-inverse br1)
+ (get-inverse br2)
+ (WB-Map-Tree-Intersect (wb-2-relation-map1 br1)
+ (wb-2-relation-map1 br2)
+ #'WB-Set-Tree-Intersect))))))
(make-wb-2-relation new-size new-map0 new-map1)))
(defgeneric join (relation-a column-a relation-b column-b)
@@ -268,6 +273,35 @@
(make-wb-2-relation new-size new-map0 new-map1)))
+(defmethod compose ((rel wb-2-relation) (fn function))
+ (2-relation-fn-compose rel fn))
+
+(defmethod compose ((rel wb-2-relation) (fn symbol))
+ (2-relation-fn-compose rel (coerce fn 'function)))
+
+(defmethod compose ((rel wb-2-relation) (fn map))
+ (2-relation-fn-compose rel fn))
+
+(defmethod compose ((rel wb-2-relation) (fn seq))
+ (2-relation-fn-compose rel fn))
+
+(defmethod compose ((rel1 wb-2-relation) (rel2 wb-2-relation))
+ (join rel1 1 rel2 0))
+
+(defun 2-relation-fn-compose (rel fn)
+ (let ((new-size 0)
+ ((new-map0 (gmap :wb-map (lambda (x ys)
+ (let ((result nil))
+ (Do-WB-Set-Tree-Members (y ys)
+ (setq result (WB-Set-Tree-With result (@ fn y))))
+ (incf new-size (WB-Set-Tree-Size result))
+ (values x result)))
+ (:wb-map (make-wb-map (wb-2-relation-map0 rel)))))))
+ (make-wb-2-relation new-size
+ (wb-map-contents new-map0)
+ nil)))
+
+
(defgeneric internal-do-2-relation (br elt-fn value-fn))
(defmacro do-2-relation ((key val br &optional value) &body body)
@@ -293,6 +327,13 @@
(setq result (WB-Set-Tree-With result (funcall pair-fn x y))))
(make-wb-set result)))
+;;; I've made the default conversions between maps and 2-relations use the
+;;; same pairs; that is, the conversion from a map to a 2-relation yields a
+;;; functional relation with the same mappings, and the inverse conversion
+;;; requires a functional relation and yields a map with the same mappings.
+;;; This is mathematically elegant, but I wonder if the other kind of conversion
+;;; -- where the map's range is set-valued -- is not more useful in practice,
+;;; and maybe more deserving of being the default.
(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
@@ -351,9 +392,17 @@
(make-wb-2-relation size m0 nil)))
(defmethod convert ((to-type (eql 'map)) (br wb-2-relation) &key)
+ "This conversion requires the relation to be functional, and returns
+a map representing the function; that is, the relation must map each
+domain value to a single range value, and the returned map maps that
+domain value to that range value."
(2-relation-to-wb-map br))
(defmethod convert ((to-type (eql 'wb-map)) (br wb-2-relation) &key)
+ "This conversion requires the relation to be functional, and returns
+a map representing the function; that is, the relation must map each
+domain value to a single range value, and the returned map maps that
+domain value to that range value."
(2-relation-to-wb-map br))
(defun 2-relation-to-wb-map (br)
@@ -365,6 +414,11 @@
(setq m (WB-Map-Tree-With m x (WB-Set-Tree-Arb s)))))
(make-wb-map m)))
+(defmethod convert ((to-type (eql 'map-to-sets)) (br wb-2-relation) &key)
+ "This conversion returns a map mapping each domain value to the set of
+corresponding range values."
+ (make-wb-map (WB-Map-Tree-Compose (wb-2-relation-map0 br) #'make-wb-set)))
+
(defgeneric conflicts (2-relation)
(:documentation
"Returns a 2-relation containing only those pairs of `2-relation' whose domain value
@@ -398,6 +452,36 @@
(format stream " ")))
(format stream "+}"))))
+(defmethod iterator ((rel wb-2-relation) &key)
+ (let ((outer (Make-WB-Map-Tree-Iterator-Internal (wb-2-relation-map0 rel)))
+ (cur-dom-elt nil)
+ (inner nil))
+ (lambda (op)
+ (ecase op
+ (:get (if (WB-Map-Tree-Iterator-Done? outer)
+ (values nil nil nil)
+ (progn
+ (when (or (null inner) (WB-Set-Tree-Iterator-Done? inner))
+ (let ((dom-elt inner-tree (WB-Map-Tree-Iterator-Get outer)))
+ (setq cur-dom-elt dom-elt)
+ (assert inner-tree) ; must be nonempty
+ (setq inner (Make-WB-Set-Tree-Iterator-Internal inner-tree))))
+ (values cur-dom-elt (WB-Set-Tree-Iterator-Get inner) t))))
+ (:done? (WB-Map-Tree-Iterator-Done? outer))
+ (:more? (not (WB-Map-Tree-Iterator-Done? outer)))))))
+
+(def-gmap-arg-type :2-relation (rel)
+ "Yields each pair of `rel', as two values."
+ `((iterator ,rel)
+ #'(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-2-relation (rel)
+ "Yields each pair of `rel', as two values."
+ `((iterator ,rel)
+ #'(lambda (it) (declare (type function it)) (funcall it ':done?))
+ (:values 2 #'(lambda (it) (declare (type function it)) (funcall it ':get)))))
+
(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."
@@ -460,7 +544,7 @@
(set-transitive-closure r s))
(defun set-transitive-closure (r s)
- ;; This could probably use a little moer work.
+ ;; This could probably use a little more work.
(let ((workset (set-difference
(reduce #'union (image r (convert 'seq s)) :initial-value (set))
s))
@@ -471,3 +555,589 @@
(adjoinf result x)
(unionf workset (set-difference (@ r x) result))))
result))
+
+
+(defmacro 2-relation (&rest args)
+ "Constructs a 2-relation 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 2-relation, all of whose mappings will be
+included in the result."
+ (expand-2-relation-constructor-form '2-relation args))
+
+(defmacro wb-2-relation (&rest args)
+ "Constructs a wb-2-relation 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 2-relation, all of whose mappings will be included in the
+result."
+ (expand-2-relation-constructor-form '2-relation args))
+
+(defun expand-2-relation-constructor-form (type-name args)
+ (let ((empty-form (ecase type-name
+ (2-relation '(empty-2-relation))
+ (wb-2-relation '(empty-wb-2-relation)))))
+ (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) `(union ,result ,(cadar args)))))
+ (t
+ (recur (cdr args) `(with ,result ,(caar args) ,(cadar args)))))))
+ (recur args empty-form))))
+
+
+;;; ================================================================================
+;;; List relations
+
+;;; A list relation is a general relation (i.e. of arbitrary arity >= 2) whose
+;;; tuples are in list form. List relations support a `query' operation that
+;;; takes, along with the relation, two lists, each of length equal to the
+;;; arity, called the "pattern" and "metapattern". For each position, if the
+;;; metapattern contains `nil', the query is not constrained by that position
+;;; (the corresponding position in the pattern is ignored); if the metapattern
+;;; contains `t' or `:single', then the result set contains only those tuples
+;;; with the same value in that position as the pattern has. The difference
+;;; between `t' and `:single' has to do with indexing. For each metapattern
+;;; that is actually used, an index is constructed if not previously present,
+;;; and then is maintained incrementally. If the metapattern has `t' in a
+;;; location, the resulting index will contain all values for that location;
+;;; if it has `:single', the resulting index will contain only those values
+;;; that have actually appeared in a query pattern with this metapattern.
+
+
+
+(defstruct (list-relation
+ (:include relation)
+ (:constructor nil)
+ (:predicate list-relation?)
+ (:copier nil))
+ "The abstract class for FSet list relations. It is a structure class.
+A list relation is a general relation (i.e. of arbitrary arity >= 2) whose
+tuples are in list form.")
+
+(defstruct (wb-list-relation
+ (:include list-relation)
+ (:constructor make-wb-list-relation (arity tuples indices))
+ (:predicate wb-list-relation?)
+ (:print-function print-wb-list-relation)
+ (:copier nil))
+ "A class of functional relations of arbitrary arity >= 2, whose tuples
+are in list form."
+ arity
+ tuples
+ ;; a map from augmented metapattern to map from reduced tuple to set of tuples
+ indices)
+
+
+(defun empty-list-relation (&optional arity)
+ "We allow the arity to be temporarily unspecified; it will be taken from
+the first tuple added, or the first query."
+ (unless (or (null arity) (and (integerp arity) (>= arity 1)))
+ (error "Invalid arity"))
+ (empty-wb-list-relation arity))
+
+(defun empty-wb-list-relation (arity)
+ "We allow the arity to be temporarily unspecified; it will be taken from
+the first tuple added, or the first query."
+ ;; If arity = 1 it's just a set... but what the heck...
+ (unless (or (null arity) (and (integerp arity) (>= arity 1)))
+ (error "Invalid arity"))
+ (make-wb-list-relation arity (set) (map)))
+
+(defmethod arity ((rel wb-list-relation))
+ "Will return `nil' if the arity is not yet specified; see `empty-list-relation'."
+ (wb-list-relation-arity rel))
+
+(defmethod empty? ((rel wb-list-relation))
+ (empty? (wb-list-relation-tuples rel)))
+
+(defmethod size ((rel wb-list-relation))
+ (size (wb-list-relation-tuples rel)))
+
+(defmethod arb ((rel wb-list-relation))
+ (arb (wb-list-relation-tuples rel)))
+
+(defmethod contains? ((rel wb-list-relation) tuple)
+ (contains? (wb-list-relation-tuples rel) tuple))
+
+(defgeneric query (relation pattern metapattern)
+ (:documentation
+ "Along with the relation, takes two lists, each of length equal to the
+arity, called the `pattern' and `metapattern'; returns a set of tuples
+satisfying the query. For each position, if the metapattern contains `nil',
+the query is not constrained by that position (the corresponding position in
+the pattern is ignored); if the metapattern contains `t' or `:single', then
+the result set contains only those tuples with the same value in that
+position as the pattern has. The difference between `t' and `:single' has
+to do with indexing. For each metapattern that is actually used, an index
+is constructed if not previously present, and then is maintained
+incrementally. If the metapattern has `t' in a location, the resulting
+index will contain all values for that location; if it has `:single', the
+resulting index will contain only those values that have actually appeared
+in a query pattern with this metapattern."))
+
+;;; `:single' is implemented, but not necessarily well enough that you'd want to
+;;; use it.
+(defmethod query ((rel wb-list-relation) (pattern list) (metapattern list))
+ (let ((arity (wb-list-relation-arity rel)))
+ (if (null arity)
+ ;; We don't know the arity yet, which means there are no tuples.
+ (set)
+ (progn
+ (unless (and (= (length pattern) arity)
+ (= (length metapattern) arity))
+ (error "Pattern or metapattern is of the wrong length"))
+ (if (every #'identity metapattern)
+ (if (contains? rel pattern) (set pattern) (set))
+ (let ((augmented-mp (augmented-mp pattern metapattern))
+ ((reduced-tuple (reduced-tuple pattern augmented-mp))
+ (index (@ (wb-list-relation-indices rel) augmented-mp))))
+ (if index
+ (@ index reduced-tuple)
+ (progn
+
+ (let ((index-results
+ (remove nil (mapcar (lambda (index mp-elt pat-elt)
+ (and index
+ (@ index (and (eq mp-elt t)
+ (list pat-elt)))))
+ (get-indices rel augmented-mp)
+ augmented-mp pattern))))
+ ;; &&& We also want to build composite indices under some
+ ;; circumstances -- e.g. if the result set is much smaller
+ ;; than the smallest of `index-results'.
+ (if index-results
+ (reduce #'intersection
+ (sort index-results #'> :key #'size))
+ (wb-list-relation-tuples rel)))))))))))
+
+;;; &&& Another nail in the coffin of `:single'... should just rip it out...
+(defgeneric query-multi (rel pattern metapattern)
+ (:documentation
+ "Like `query' (q.v.), except that `pattern' is a list of sets of values
+rather than a list of values. Returns all tuples in the relation for which
+each value is a member of the corresponding set in the pattern. `:single'
+in the metapattern is not accepted."))
+
+(defmethod query-multi ((rel wb-list-relation) (pattern list) (metapattern list))
+ (let ((arity (wb-list-relation-arity rel)))
+ (if (null arity)
+ ;; We don't know the arity yet, which means there are no tuples.
+ (set)
+ (progn
+ (unless (and (= (length pattern) arity)
+ (= (length metapattern) arity))
+ (error "Pattern or metapattern is of the wrong length"))
+ ;; Without :single, the augmented-mp is just the metapattern.
+ (when (member ':single metapattern)
+ (error "~S doesn't take ~S" 'query-multi ':single))
+ (if (every (fn (s) (= (size s) 1)) pattern)
+ (query rel (mapcar #'arb pattern) metapattern)
+ (let ((index-results
+ (remove nil
+ (mapcar (lambda (index pat-elt)
+ (and index
+ (gmap :union
+ (fn (pat-elt-elt)
+ (@ index (list pat-elt-elt)))
+ (:set pat-elt))))
+ (get-indices rel metapattern)
+ pattern))))
+ (if index-results
+ (reduce #'intersection
+ (sort index-results #'> :key #'size))
+ (wb-list-relation-tuples rel))))))))
+
+(defun get-indices (rel augmented-mp)
+ "Returns a list giving the index to use for each element of `augmented-mp'."
+ (flet ((make-mp (i elt)
+ (let ((mp nil)
+ (arity (wb-list-relation-arity rel)))
+ (dotimes (j arity)
+ (push (and (= i (- arity j 1)) elt) mp))
+ mp)))
+ ;; First we see what indices exist on each position.
+ (let ((ex-inds (gmap :list
+ (lambda (mp-elt i)
+ (and mp-elt (or (@ (wb-list-relation-indices rel)
+ (make-mp i mp-elt))
+ (and (not (eq mp-elt t))
+ (@ (wb-list-relation-indices rel)
+ (make-mp i t))))))
+ (:list augmented-mp)
+ (:index 0)))
+ ((unindexed (mapcar (lambda (index mp-elt)
+ (and (null index) mp-elt))
+ ex-inds augmented-mp))))
+ ;; Now, if there were any instantiated positions for which an index did
+ ;; not exist, construct indices for them.
+ (unless (every #'null unindexed)
+ (let ((saved-mps (gmap :list (lambda (unind i)
+ (and unind (make-mp i unind)))
+ (:list unindexed)
+ (:index 0)))
+ (new-indices (make-array (length augmented-mp)
+ :initial-element (empty-map (set)))))
+ (do-set (tuple (wb-list-relation-tuples rel))
+ (gmap nil (lambda (tuple-elt unind saved-mp i)
+ (when (and unind
+ (or (eq unind t)
+ (equal? tuple-elt (cdr unind))))
+ (adjoinf (@ (svref new-indices i)
+ (reduced-tuple tuple saved-mp))
+ tuple)))
+ (:list tuple)
+ (:list unindexed)
+ (:list saved-mps)
+ (:index 0)))
+ (gmap nil (lambda (saved-mp new-index)
+ (when saved-mp
+ (setf (@ (wb-list-relation-indices rel) saved-mp) new-index)))
+ (:list saved-mps)
+ (:vector new-indices))
+ (setq ex-inds (gmap :list (lambda (ex-ind saved-mp new-index)
+ (or ex-ind (and saved-mp new-index)))
+ (:list ex-inds)
+ (:list saved-mps)
+ (:vector new-indices)))))
+ ;; &&& If we just built a complete index that subsumes any single-value indices,
+ ;; need to discard the latter.
+ ;; &&& Also, if the total size of the single-value indices we build for any
+ ;; position gets large enough, we should replace them all with a complete index.
+ ex-inds)))
+
+(defmethod with ((rel wb-list-relation) tuple &optional (arg2 nil arg2?))
+ (declare (ignore arg2))
+ (check-two-arguments arg2? 'with 'wb-list-relation)
+ (let ((arity (or (wb-list-relation-arity rel)
+ (length tuple))))
+ (unless (and (listp tuple) (= (length tuple) arity))
+ (error "Length of tuple, ~D, does not equal arity, ~D"
+ (length tuple) arity))
+ (if (contains? (wb-list-relation-tuples rel) tuple)
+ rel
+ (make-wb-list-relation arity (with (wb-list-relation-tuples rel) tuple)
+ ;; Hmm, methinks we need to index the index map...
+ (image (lambda (aug-mp rt-map)
+ (if (augmented-mp-matches? aug-mp tuple)
+ (let ((rt (reduced-tuple tuple aug-mp)))
+ (values aug-mp
+ (with rt-map rt
+ (with (@ rt-map rt) tuple))))
+ (values aug-mp rt-map)))
+ (wb-list-relation-indices rel))))))
+
+(defmethod less ((rel wb-list-relation) tuple &optional (arg2 nil arg2?))
+ (declare (ignore arg2))
+ (check-two-arguments arg2? 'with 'wb-list-relation)
+ (let ((arity (or (wb-list-relation-arity rel)
+ (length tuple))))
+ (unless (and (listp tuple) (= (length tuple) arity))
+ (error "Length of tuple, ~D, does not equal arity, ~D"
+ (length tuple) arity))
+ (if (not (contains? (wb-list-relation-tuples rel) tuple))
+ rel
+ (make-wb-list-relation arity (less (wb-list-relation-tuples rel) tuple)
+ (image (lambda (aug-mp rt-map)
+ (if (augmented-mp-matches? aug-mp tuple)
+ (let ((rt (reduced-tuple tuple aug-mp)))
+ (values aug-mp
+ (with rt-map rt
+ (less (@ rt-map rt) tuple))))
+ (values aug-mp rt-map)))
+ (wb-list-relation-indices rel))))))
+
+;;; &&& I suppose that instead of consing these things up all the time we could
+;;; have a special pattern object with special compare methods against lists that
+;;; would compare only the desired positions. L8r...
+(defun reduced-tuple (tuple augmented-mp)
+ "Returns a list of those members of `tuple' corresponding to instantiated
+positions in the original pattern."
+ (if (every (lambda (x) (eq x t)) augmented-mp) tuple
+ (gmap (:list :filterp #'identity) ; omits nil
+ (lambda (pat-elt mp-elt)
+ (and (eq mp-elt t) pat-elt))
+ (:list tuple)
+ (:list augmented-mp))))
+
+(defun augmented-mp (pattern metapattern)
+ "Returns a list, of the same length as the pattern, which is like the
+metapattern except that each `:single' has been replaced by a cons of
+`:single' and the corresponding pattern element."
+ (if (not (member ':single metapattern)) metapattern
+ (mapcar (lambda (pat-elt mp-elt)
+ (if (eq mp-elt ':single) (cons ':single pat-elt)
+ mp-elt))
+ pattern metapattern)))
+
+(defun augmented-mp-matches? (augmented-mp tuple)
+ (every (lambda (mp-elt tuple-elt)
+ (or (eq mp-elt nil) (eq mp-elt t)
+ (and (consp mp-elt) (eq (car mp-elt) ':single)
+ (equal? tuple-elt (cdr mp-elt)))))
+ augmented-mp tuple))
+
+
+
+(defgeneric internal-do-list-relation (rel elt-fn value-fn))
+
+(defmacro do-list-relation ((tuple rel &optional value) &body body)
+ `(block nil
+ (internal-do-list-relation ,rel (lambda (,tuple) . ,body)
+ (lambda () ,value))))
+
+(defmethod internal-do-list-relation ((rel wb-list-relation) elt-fn value-fn)
+ (Do-WB-Set-Tree-Members (tuple (wb-set-contents (wb-list-relation-tuples rel))
+ (funcall value-fn))
+ (funcall elt-fn tuple)))
+
+(defun print-wb-list-relation (rel stream level)
+ (if (and *print-level* (>= level *print-level*))
+ (format stream "#")
+ (progn
+ (format stream "#{* ")
+ (let ((i 0))
+ (do-list-relation (tuple rel)
+ (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 tuple :stream stream)))
+ (when (> i 0)
+ (format stream " ")))
+ (format stream "*}~@[^~D~]" (arity rel)))))
+
+#||
+
+Okay, this is a start, but:
+
+() Don't we want to do better meta-indexing, so adding a tuple doesn't require
+iterating through all the indices?
+
+() I'm not creating composite indices yet. The plan is straightforward -- create
+one when the size of the final result set is <= the square root of the size of
+the smallest index set. This is easy, but how do subsequent queries find the
+composite index?
+
+[Later] I think that for now, the single-value index feature is an unnecessary
+complication. Without it, there either exists an index on a column, or not.
+
+As for composite indices, I think the right way to find them will be with a
+discrimination tree (or DAG), but I'm not going to bother with them yet either.
+
+||#
+
+
+;;; A query registry to be used with `list-relation'. Register queries with
+;;; `with-query', supplying a pattern and metapattern. The queries themselves
+;;; are uninterpreted except that they are kept in sets (so CL closures are not
+;;; a good choice). `lookup' returns the set of queries that match the supplied
+;;; tuple.
+(defstruct (query-registry
+ (:constructor make-query-registry (arity indices key-index)))
+ arity
+ ;; A map from augmented metapattern to map from reduced tuple to set of queries.
+ ;; &&& Not worrying for now whether this does anything reasonable with `:single'.
+ indices
+ ;; A map from every "key", i.e., value used in an instantiated position in a
+ ;; pattern, to map from augmented metapattern to set of reduced tuples in which
+ ;; they were used.
+ key-index)
+
+(defun empty-query-registry (&optional arity)
+ (unless (or (null arity) (and (integerp arity) (>= arity 1)))
+ (error "Invalid arity"))
+ (make-query-registry arity (empty-map (empty-map (set)))
+ (empty-map (empty-map (set)))))
+
+(defmethod arity ((reg query-registry))
+ (query-registry-arity reg))
+
+(defmethod with-query ((reg query-registry) (pattern list) (metapattern list) query)
+ (let ((arity (or (query-registry-arity reg)
+ (length pattern))))
+ (unless (and (= (length pattern) arity)
+ (= (length metapattern) arity))
+ (error "Pattern or metapattern is of the wrong length"))
+ (let ((augmented-mp (augmented-mp pattern metapattern))
+ ((reduced-tuple (reduced-tuple pattern augmented-mp))
+ ((prev-1 (@ (query-registry-indices reg) augmented-mp))
+ ((prev-2 (@ prev-1 reduced-tuple)))
+ (aug->red (map (augmented-mp (set reduced-tuple)) :default (set))))))
+ (make-query-registry arity
+ (with (query-registry-indices reg) augmented-mp
+ (with prev-1 reduced-tuple
+ (with prev-2 query)))
+ (map-union (query-registry-key-index reg)
+ (gmap (:map :default (empty-map (set)))
+ (fn (key) (values key aug->red))
+ (:list reduced-tuple))
+ (lambda (x y) (map-union x y #'union)))))))
+
+(defmethod less-query ((reg query-registry) (pattern list) (metapattern list) query)
+ (let ((arity (or (query-registry-arity reg)
+ (length pattern))))
+ (unless (and (= (length pattern) arity)
+ (= (length metapattern) arity))
+ (error "Pattern or metapattern is of the wrong length"))
+ (let ((augmented-mp (augmented-mp pattern metapattern))
+ ((reduced-tuple (reduced-tuple pattern augmented-mp))
+ ((prev-1 (@ (query-registry-indices reg) augmented-mp))
+ ((prev-2 (@ prev-1 reduced-tuple))))))
+ (make-query-registry arity
+ (with (query-registry-indices reg) augmented-mp
+ (with prev-1 reduced-tuple
+ (less prev-2 query)))
+ ;; &&& For now.
+ (query-registry-key-index reg)))))
+
+(defmethod all-queries ((reg query-registry))
+ (gmap :union (fn (_aug-mp submap)
+ (gmap :union (fn (_red-tup queries)
+ queries)
+ (:map submap)))
+ (:map (query-registry-indices reg))))
+
+(defmethod lookup ((reg query-registry) tuple)
+ "Returns all queries in `reg' whose patterns match `tuple'."
+ (let ((arity (or (query-registry-arity reg)
+ (length tuple))))
+ (unless (and (listp tuple) (= (length tuple) arity))
+ (error "Length of tuple, ~D, does not match arity, ~D"
+ (length tuple) arity))
+ (gmap :union (lambda (aug-mp rt-map)
+ (@ rt-map (reduced-tuple tuple aug-mp)))
+ (:map (query-registry-indices reg)))))
+
+(defmethod lookup-multi ((reg query-registry) set-tuple)
+ "Here `set-tuple' contains a set of values in each position. Returns
+all queries in `reg' whose patterns match any member of the cartesian
+product of the sets."
+ (let ((arity (or (query-registry-arity reg)
+ (length set-tuple))))
+ (unless (and (listp set-tuple) (= (length set-tuple) arity))
+ (error "Length of tuple, ~D, does not match arity, ~D"
+ (length set-tuple) arity))
+ ;; Ugh. At least, computing the cartesian product of the reduced set-tuple
+ ;; will frequently be faster than computing that of the original. Still,
+ ;; maybe we &&& need to redesign the indexing scheme here...
+ (gmap :union (lambda (aug-mp rt-map)
+ (gmap :union (fn (tuple)
+ (@ rt-map tuple))
+ (:seq (cartesian-product (reduced-tuple set-tuple aug-mp)))))
+ (:map (query-registry-indices reg)))))
+
+;;; Since all the members are known to be distinct, we return a seq rather
+;;; than pay the setification cost... a little inelegant, though.
+(defmethod cartesian-product ((sets list))
+ (if (null sets)
+ (seq nil)
+ (gmap :concat (fn (tail)
+ (gmap :seq (fn (x) (cons x tail))
+ (:set (car sets))))
+ (:seq (cartesian-product (cdr sets))))))
+
+(defmethod forward-key ((reg query-registry) from-key to-key)
+ "Returns a new query-registry in which all queries whose patterns used
+`from-key' (in an instantiated position) now use `to-key' in that position
+instead."
+ (let ((key-idx-submap (@ (query-registry-key-index reg) from-key))
+ ;; We'll generate garbage maintaining the map, but then the tuple instances
+ ;; will be shared.
+ (subst-cache (map)))
+ (flet ((get-subst (tuple)
+ (or (@ subst-cache tuple)
+ (setf (@ subst-cache tuple)
+ (substitute to-key from-key tuple)))))
+ (make-query-registry
+ (query-registry-arity reg)
+ (image (fn (aug-mp submap)
+ (let ((red-tups (@ key-idx-submap aug-mp)))
+ (values aug-mp
+ (map-union (restrict-not submap red-tups)
+ (gmap (:map :default (set))
+ (fn (tup)
+ (let ((new-tup (get-subst tup)))
+ (values new-tup
+ (union (@ submap tup)
+ (@ submap new-tup)))))
+ (:set red-tups))
+ #'union))))
+ (query-registry-indices reg))
+ ;; Hehe, this is fun :-) We need to update the indices for the other
+ ;; keys that occur along with `from-key' in tuples, and we don't want to
+ ;; walk the whole index to find them; but we already know what tuples are
+ ;; affected (the ones in `key-idx-submap'), so we work off of that. Doing
+ ;; this functionally was interesting.
+ (map-union (reduce (fn (kidx aug-mp tups)
+ (let ((to-update
+ (reduce (fn (x y) (map-union x y #'union))
+ (image (fn (tup)
+ (gmap :map
+ (fn (x) (values x (set tup)))
+ (:set (less (convert 'set tup)
+ from-key))))
+ tups))))
+ (reduce (fn (kidx key tups)
+ (let ((prev-1 (@ kidx key))
+ ((prev-2 (@ prev-1 aug-mp))))
+ (with kidx key
+ (with prev-1 aug-mp
+ (union (set-difference prev-2 tups)
+ (image #'get-subst
+ tups))))))
+ to-update :initial-value kidx)))
+ key-idx-submap
+ :initial-value (less (query-registry-key-index reg) from-key))
+ (map (to-key (compose key-idx-submap
+ (fn (tups)
+ (image #'get-subst tups))))
+ :default (empty-map (set)))
+ (fn (x y) (map-union x y #'union)))))))
+
+(defmethod lookup-restricted ((reg query-registry) tuple key)
+ "Returns all queries in `reg' whose patterns match `tuple' and which use
+`key' (in an instantiated position) in their patterns."
+ (let ((arity (or (query-registry-arity reg)
+ (length tuple))))
+ (unless (and (listp tuple) (= (length tuple) arity))
+ (error "Length of tuple, ~D, does not match arity, ~D"
+ (length tuple) arity))
+ (gmap :union (lambda (aug-mp rt-map)
+ (@ rt-map (reduced-tuple tuple aug-mp)))
+ (:map (let ((key-idx-submap (@ (query-registry-key-index reg) key)))
+ (image (fn (aug-mp rt-map)
+ (values aug-mp (restrict rt-map (@ key-idx-submap aug-mp))))
+ (query-registry-indices reg)))))))
+
+(defmethod lookup-multi-restricted ((reg query-registry) set-tuple keys)
+ "Here `set-tuple' contains a set of values in each position. Returns
+all queries in `reg' whose patterns match any member of the cartesian
+product of the sets and which use a member of `keys' in their patterns."
+ (let ((arity (or (query-registry-arity reg)
+ (length set-tuple))))
+ (unless (and (listp set-tuple) (= (length set-tuple) arity))
+ (error "Length of tuple, ~D, does not match arity, ~D"
+ (length set-tuple) arity))
+ (gmap :union (lambda (aug-mp rt-map)
+ (gmap :union (fn (tuple)
+ (@ rt-map tuple))
+ (:seq (cartesian-product (reduced-tuple set-tuple aug-mp)))))
+ (:map (let ((key-idx-submap
+ (reduce (fn (x y) (map-union x y #'union))
+ (image (query-registry-key-index reg) keys))))
+ (image (fn (aug-mp rt-map)
+ (values aug-mp (restrict rt-map (@ key-idx-submap aug-mp))))
+ (query-registry-indices reg)))))))
Modified: trunk/Code/testing.lisp
==============================================================================
--- trunk/Code/testing.lisp Sun Nov 9 21:44:59 2008 (r26)
+++ trunk/Code/testing.lisp Sat Nov 12 21:21:18 2011 (r27)
@@ -122,8 +122,11 @@
(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))))))
+ (test (equal (sort (convert 'list (eval '(tuple (+K0+ 1)
+ ($ (tuple (+K1+ 2) (+K2+ 3)))
+ (+K0+ 2)
+ ($ (tuple (+K4+ 7) (+K2+ 8))))))
+ #'< :key (fn (x) (tuple-key-number (car x))))
`((,+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))))
Modified: trunk/Code/tuples.lisp
==============================================================================
--- trunk/Code/tuples.lisp Sun Nov 9 21:44:59 2008 (r26)
+++ trunk/Code/tuples.lisp Sat Nov 12 21:21:18 2011 (r27)
@@ -52,7 +52,7 @@
;;; with sparse slots (at which most of the tuples created have no assigned
;;; value), you may find the additional functionality of these tuples useful.
-;;; Keys can be defined with `def-tuple-key', or obtained at runtime with
+;;; Keys can be defined with `define-tuple-key', or obtained at runtime with
;;; `get-tuple-key'.
;;; The implementation gets its speed by arranging for lookup to be done by
@@ -148,6 +148,11 @@
(error "Tuple key space exhausted"))))))
(defmacro def-tuple-key (name &optional default-fn)
+ "Deprecated; use `define-tuple-key'."
+ ;; What this should have been called to begin with.
+ `(define-tuple-key ,name ,default-fn))
+
+(defmacro define-tuple-key (name &optional default-fn)
"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,
Modified: trunk/Code/wb-trees.lisp
==============================================================================
--- trunk/Code/wb-trees.lisp Sun Nov 9 21:44:59 2008 (r26)
+++ trunk/Code/wb-trees.lisp Sat Nov 12 21:21:18 2011 (r27)
@@ -4953,21 +4953,22 @@
(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)))))
+ (and tree
+ (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))))))
;;; ----------------
@@ -5677,61 +5678,59 @@
(push (Make-WB-Seq-Tree-Node left right) stack))))))))
(defun WB-Seq-Tree-To-Vector (tree)
+ (let ((result (make-array (WB-Seq-Tree-Size tree))))
+ (labels ((fillr (tree result idx)
+ (declare (optimize (speed 3) (safety 0))
+ (fixnum idx))
+ (cond ((stringp tree)
+ (dotimes (i (length (the simple-string tree)))
+ (setf (svref result (+ idx i)) (schar tree i))))
+ ((simple-vector-p tree)
+ (dotimes (i (length tree))
+ (setf (svref result (+ idx i)) (svref tree i))))
+ (t
+ (let ((left (WB-Seq-Tree-Node-Left tree)))
+ (fillr left result idx)
+ (fillr (WB-Seq-Tree-Node-Right tree)
+ result (+ idx (WB-Seq-Tree-Size left))))))))
+ (fillr tree result 0)
+ result)))
+
+(defun WB-Seq-Tree-To-String (tree)
(declare (optimize (speed 3) (safety 0)))
- (if (or (null tree) (simple-vector-p tree))
- (coerce tree 'vector)
+ (if (null tree) ""
(labels ((element-type (tree)
(cond ((null tree) 'base-char)
((vectorp tree)
(cond ((typep tree 'base-string) 'base-char)
#+FSet-Ext-Strings
((stringp tree) 'character)
- (t t)))
+ (t
+ (error 'type-error
+ :datum (find-if-not #'characterp tree)
+ :expected-type 'character))))
(t
(let ((left (element-type (WB-Seq-Tree-Node-Left tree)))
(right (element-type (WB-Seq-Tree-Node-Right tree))))
- (cond ((or (eq left t) (eq right t))
- t)
- #+FSet-Ext-Strings
+ (cond #+FSet-Ext-Strings
((or (eq left 'character) (eq right 'character))
'character)
(t 'base-char)))))))
(let ((elt-type (element-type tree)))
- (if (member elt-type '(base-char character))
- (let ((result (make-string (WB-Seq-Tree-Size tree) :element-type elt-type)))
- (labels ((fillr (tree result idx)
- (declare (optimize (speed 3) (safety 0))
- (fixnum idx))
- (cond ((stringp tree)
- (dotimes (i (length (the simple-string tree)))
- ;; All this code duplication is just so we can use
- ;; `(schar result ...)' here and `(svref result ...)'
- ;; below.
- (setf (schar result (+ idx i)) (schar tree i))))
- (t
- (let ((left (WB-Seq-Tree-Node-Left tree)))
- (fillr left result idx)
- (fillr (WB-Seq-Tree-Node-Right tree)
- result (+ idx (WB-Seq-Tree-Size left))))))))
- (fillr tree result 0)
- result))
- (let ((result (make-array (WB-Seq-Tree-Size tree))))
- (labels ((fillr (tree result idx)
- (declare (optimize (speed 3) (safety 0))
- (fixnum idx))
- (cond ((stringp tree)
- (dotimes (i (length (the simple-string tree)))
- (setf (svref result (+ idx i)) (schar tree i))))
- ((simple-vector-p tree)
- (dotimes (i (length tree))
- (setf (svref result (+ idx i)) (svref tree i))))
- (t
- (let ((left (WB-Seq-Tree-Node-Left tree)))
- (fillr left result idx)
- (fillr (WB-Seq-Tree-Node-Right tree)
- result (+ idx (WB-Seq-Tree-Size left))))))))
- (fillr tree result 0)
- result)))))))
+ (let ((result (make-string (WB-Seq-Tree-Size tree) :element-type elt-type)))
+ (labels ((fillr (tree result idx)
+ (declare (optimize (speed 3) (safety 0))
+ (fixnum idx))
+ (cond ((stringp tree)
+ (dotimes (i (length (the simple-string tree)))
+ (setf (schar result (+ idx i)) (schar tree i))))
+ (t
+ (let ((left (WB-Seq-Tree-Node-Left tree)))
+ (fillr left result idx)
+ (fillr (WB-Seq-Tree-Node-Right tree)
+ result (+ idx (WB-Seq-Tree-Size left))))))))
+ (fillr tree result 0)
+ result))))))
;;; ================================================================================
More information about the Fset-cvs
mailing list