diff --git a/.gitignore b/.gitignore index af1167f7858ef79b34b8160696a134ace21b6854..fb3c469cdcc60baf6c820bc71b477f19c69e94d5 100644 --- a/.gitignore +++ b/.gitignore @@ -6,3 +6,4 @@ _darcs Java-Code *.64xfasl .DS_Store +Coverage-Reports diff --git a/Code/champ.lisp b/Code/champ.lisp index d20852458d3626819dab8e492470c206b5339fd2..9049973310ef4e3807d036f1d7e9d2fb2042b16d 100644 --- a/Code/champ.lisp +++ b/Code/champ.lisp @@ -117,30 +117,30 @@ (defstruct (ch-set-node ((consp tree) (the fixnum (car tree))) (t (ch-set-node-hash-value tree)))) -(defun ch-set-tree-with (tree value hash-fn compare-fn &optional (depth 0)) +(defun ch-set-tree-with (tree value hash-fn compare-fn &optional (depth 0) replace?) (declare (optimize (speed 3) (safety 0)) (type function hash-fn compare-fn) (type (integer 0 64) depth)) (let ((value-hash (hash-to-fixnum value hash-fn))) (declare (fixnum value-hash)) (rlabels (rec tree (ash value-hash (- (* champ-hash-bits-per-level depth))) depth) - (rec (node hash-shifted depth &optional node-hash) + (rec (node hash-shifted depth) (declare (fixnum hash-shifted) - (type (integer 0 64) depth) - (type (or null fixnum) node-hash)) + (type (integer 0 64) depth)) (let ((hash-bits (logand hash-shifted champ-hash-level-mask))) (if (null node) (vector (ash 1 hash-bits) 0 1 value-hash value) (if (consp node) ;; We can create collision nodes at any level (see below). -- Well, not at the root. But ;; this is called from elsewhere (e.g. `-union') on subtrees, which might be collision nodes. - (let ((node-hash (or node-hash (hash-to-fixnum (wb-set-tree-arb (cdr node)) hash-fn))) - ((wb-hash-shifted (ash node-hash (- (* champ-hash-bits-per-level depth))))) + (let ((wb-hash-shifted (ash (the fixnum (car node)) (- (* champ-hash-bits-per-level depth)))) (size (1+ (wb-set-tree-size (cdr node))))) - (declare (fixnum wb-hash-shifted hash-shifted size)) + (declare (fixnum wb-hash-shifted size)) (if (= hash-shifted wb-hash-shifted) ;; Update the collision node. - (let ((new-wb-tree (wb-set-tree-with (cdr node) value compare-fn))) + (let ((new-wb-tree (wb-set-tree-with (if replace? (wb-set-tree-less (cdr node) value compare-fn) + (cdr node)) + value compare-fn))) (if (eq new-wb-tree (cdr node)) node ;; New entry in collision node @@ -150,7 +150,7 @@ (defstruct (ch-set-node (content-hash (hash-mix (car node) value-hash))) (if (= hash-bits wb-hash-bits) (vector 0 (ash 1 hash-bits) size content-hash - (rec node (ash hash-shifted (- champ-hash-bits-per-level)) (1+ depth) node-hash)) + (rec node (ash hash-shifted (- champ-hash-bits-per-level)) (1+ depth))) (vector (ash 1 hash-bits) (ash 1 wb-hash-bits) size content-hash value node))))) ;; Normal case @@ -165,7 +165,9 @@ (defstruct (ch-set-node ;; Entry found (let ((ex-value (svref node entry-idx))) (if (equal?-cmp value ex-value compare-fn) - node + (if (and replace? (not (eq value ex-value))) + (vector-update node entry-idx value) + node) ;; Entry with different value found: make a subnode (let ((hash-shifted (ash hash-shifted (- champ-hash-bits-per-level))) (ex-value-hash (hash-to-fixnum ex-value hash-fn)) @@ -186,7 +188,11 @@ (defstruct (ch-set-node (incf (ch-set-node-size n)) (unless (consp n2) (hash-mixf (ch-set-node-hash-value n) value-hash)) - n))) + (if (and (> depth 0) (consp n2) + (zerop (ch-set-node-entry-mask n)) + (= 1 (logcount (ch-set-node-subnode-mask n)))) + n2 + n)))) ;; No entry found: check for subnode (if (logbitp hash-bits subnode-mask) ;; Subnode found @@ -213,7 +219,7 @@ (defstruct (ch-set-node (declare (optimize (speed 3) (safety 0)) (simple-vector vec) (fixnum rem-idx ins-idx)) - (assert (<= rem-idx (the fixnum (1- ins-idx)))) + (assert (< rem-idx ins-idx)) (let ((len (length vec)) ((v (make-array len)))) (declare (fixnum len)) @@ -328,6 +334,7 @@ (defstruct (ch-set-node (svref tree ch-set-node-header-size)))) (defun ch-set-tree-contains? (tree value hash-fn compare-fn &optional (depth 0)) + "On success, returns the set element as the second value." (declare (optimize (speed 3) (safety 0)) (type function hash-fn compare-fn) (type (integer 0 64) depth)) @@ -664,8 +671,8 @@ (defstruct (ch-set-node (type champ-subnode-index isubnode)) (svref n (- (length n) isubnode 1))) -(declaim (inline ch-set-node-add-entry)) -(defun ch-set-node-add-entry (n idx val hash-fn) +(declaim (inline ch-set-node-add-entry!)) +(defun ch-set-node-add-entry! (n idx val hash-fn) (declare (optimize (speed 3) (safety 0)) (type champ-bit-index idx) (type function hash-fn)) @@ -674,8 +681,8 @@ (defstruct (ch-set-node (incf (ch-set-node-size n)) (hash-mixf (ch-set-node-hash-value n) (hash-to-fixnum val hash-fn))) -(declaim (inline ch-set-node-add-subnode)) -(defun ch-set-node-add-subnode (n idx subnode hash-fn) +(declaim (inline ch-set-node-add-subnode!)) +(defun ch-set-node-add-subnode! (n idx subnode hash-fn) (declare (optimize (speed 3) (safety 0)) (type champ-bit-index idx) (type function hash-fn)) @@ -684,7 +691,7 @@ (defstruct (ch-set-node (= 1 (logcount (ch-set-node-entry-mask subnode))) (= 0 (ch-set-node-subnode-mask subnode))) ;; `subnode' contains only an entry -- pull it up. - (ch-set-node-add-entry n idx (svref subnode ch-set-node-header-size) hash-fn) + (ch-set-node-add-entry! n idx (svref subnode ch-set-node-header-size) hash-fn) (progn (when (and (not (consp subnode)) (= 0 (ch-set-node-entry-mask subnode)) @@ -700,7 +707,7 @@ (defstruct (ch-set-node (hash-mixf (ch-set-node-hash-value n) (ch-set-tree-hash-value subnode)))))) (defun ch-set-tree-union (tree1 tree2 hash-fn compare-fn) - (declare (optimize (speed 3) (safety 0)) + (declare (optimize (speed 1) (safety 0)) (type function hash-fn compare-fn)) (rlabels (rec tree1 tree2 0) (rec (tree1 tree2 depth) @@ -723,12 +730,32 @@ (defstruct (ch-set-node (vector 0 (ash 1 bits1) size chash (rec tree1 tree2 (1+ depth))) (let ((subnode0 subnode1 (swap-if (> bits1 bits2) tree1 tree2))) (vector 0 (logior (ash 1 bits1) (ash 1 bits2)) size chash subnode1 subnode0))))))) - ((consp tree1) - (do-wb-set-tree-members (x (cdr tree1)) - (setq tree2 (ch-set-tree-with tree2 x hash-fn compare-fn depth))) - tree2) - ((consp tree2) - (rec tree2 tree1 depth)) + ((or (consp tree1) (consp tree2)) + ;; Left preference: we prefer values from `tree1' when they're equal. + ;; This took even more code, and was even more of a PITA, than I expected. + (let ((tree1-collision? (consp tree1)) + ((norm-node coll-node (swap-if tree1-collision? tree1 tree2)) + ((hash-bits (champ-hash-bits (the fixnum (car coll-node)) depth)) + (entry-mask (ch-set-node-entry-mask norm-node)) + (subnode-mask (ch-set-node-subnode-mask norm-node))))) + (declare (type simple-vector norm-node)) + (cond ((logbitp hash-bits entry-mask) + (let ((ientry (1-bits-below hash-bits entry-mask)) + (isubnode (1-bits-below hash-bits subnode-mask)) + ((value (ch-set-node-entry norm-node ientry)) + ((new-subnode + (ch-set-tree-with coll-node value hash-fn compare-fn (1+ depth) + (not tree1-collision?)))))) + (ch-set-node-change-entry-to-subnode norm-node ientry isubnode hash-bits new-subnode hash-fn))) + ((logbitp hash-bits subnode-mask) + (let ((isubnode (1-bits-below hash-bits subnode-mask)) + ((old-subnode (ch-set-node-subnode norm-node isubnode)))) + (ch-set-node-replace-subnode norm-node isubnode + (if tree1-collision? (rec coll-node old-subnode (1+ depth)) + (rec old-subnode coll-node (1+ depth)))))) + (t + (ch-set-node-insert-subnode norm-node (1-bits-below hash-bits subnode-mask) hash-bits + coll-node))))) (t (let ((entries1 (ch-set-node-entry-mask tree1)) (entries2 (ch-set-node-entry-mask tree2)) @@ -747,11 +774,11 @@ (defstruct (ch-set-node (isubnode2 0)) (declare (fixnum ientry1 isubnode1 ientry2 isubnode2)) (flet ((add-entry (idx val) - (ch-set-node-add-entry res-n idx val hash-fn)) + (ch-set-node-add-entry! res-n idx val hash-fn)) (add-subnode (idx subnode) - (ch-set-node-add-subnode res-n idx subnode hash-fn)) - (subtree-with (tree value) - (ch-set-tree-with tree value hash-fn compare-fn (1+ depth)))) + (ch-set-node-add-subnode! res-n idx subnode hash-fn)) + (subtree-with (tree value &optional replace?) + (ch-set-tree-with tree value hash-fn compare-fn (1+ depth) replace?))) (do-bit-indices (idx (logior all-entries all-subnodes)) (cond ((and (logbitp idx entries1) (logbitp idx entries2)) (let ((val1 (ch-set-node-entry tree1 (postincf ientry1))) @@ -763,7 +790,8 @@ (defstruct (ch-set-node (let ((val (ch-set-node-entry tree1 (postincf ientry1)))) (if (logbitp idx subnodes2) (let ((subnode (ch-set-node-subnode tree2 (postincf isubnode2)))) - (add-subnode idx (subtree-with subnode val))) + ;; Must replace for left preference. + (add-subnode idx (subtree-with subnode val t))) (add-entry idx val)))) ((logbitp idx entries2) (let ((val (ch-set-node-entry tree2 (postincf ientry2)))) @@ -801,7 +829,24 @@ (defstruct (ch-set-node (setq result (ch-set-tree-with result x hash-fn compare-fn depth)))) result))) ((consp tree2) - (rec tree2 tree1 depth)) + (let ((hash-bits (champ-hash-bits (the fixnum (car tree2)) depth)) + (entry-mask (ch-set-node-entry-mask tree1)) + (subnode-mask (ch-set-node-subnode-mask tree1))) + (cond ((logbitp hash-bits entry-mask) + (let ((ientry (1-bits-below hash-bits entry-mask)) + ((value (ch-set-node-entry tree1 ientry)))) + (and (wb-set-tree-contains? (cdr tree2) value compare-fn) + (ch-set-tree-with nil value hash-fn compare-fn depth)))) + ((logbitp hash-bits subnode-mask) + (let ((isubnode (1-bits-below hash-bits subnode-mask)) + ((old-subnode (ch-set-node-subnode tree1 isubnode))) + (result nil)) + (do-wb-set-tree-members (x (cdr tree2)) + (let ((v1? v1 (ch-set-tree-contains? old-subnode x hash-fn compare-fn (1+ depth)))) + (when v1? + (setq result (ch-set-tree-with result v1 hash-fn compare-fn depth))))) + result)) + (t nil)))) (t (let ((entries1 (ch-set-node-entry-mask tree1)) (entries2 (ch-set-node-entry-mask tree2)) @@ -812,9 +857,9 @@ (defstruct (ch-set-node ((res-len (min (length tree1) (length tree2))) ((res-n (make-array res-len :initial-element 0))))) (flet ((add-entry (idx val) - (ch-set-node-add-entry res-n idx val hash-fn)) + (ch-set-node-add-entry! res-n idx val hash-fn)) (add-subnode (idx subnode) - (ch-set-node-add-subnode res-n idx subnode hash-fn)) + (ch-set-node-add-subnode! res-n idx subnode hash-fn)) (subtree-contains? (tree val) (ch-set-tree-contains? tree val hash-fn compare-fn (1+ depth)))) (do-bit-indices (idx (logior (logand entries1 entries2) (logand subnodes1 subnodes2) @@ -827,13 +872,15 @@ (defstruct (ch-set-node (when (equal?-cmp val1 val2 compare-fn) (add-entry idx val1)))) ((and (logbitp idx entries1) (logbitp idx subnodes2)) - (let ((val (ch-set-node-entry tree1 (1-bits-below idx entries1)))) - (when (subtree-contains? (ch-set-node-subnode tree2 (1-bits-below idx subnodes2)) val) - (add-entry idx val)))) + (let ((val1 (ch-set-node-entry tree1 (1-bits-below idx entries1)))) + (when (subtree-contains? (ch-set-node-subnode tree2 (1-bits-below idx subnodes2)) val1) + (add-entry idx val1)))) ((and (logbitp idx subnodes1) (logbitp idx entries2)) - (let ((val (ch-set-node-entry tree2 (1-bits-below idx entries2)))) - (when (subtree-contains? (ch-set-node-subnode tree1 (1-bits-below idx subnodes1)) val) - (add-entry idx val)))) + (let ((val2 (ch-set-node-entry tree2 (1-bits-below idx entries2))) + ((val1? val1 (subtree-contains? (ch-set-node-subnode tree1 (1-bits-below idx subnodes1)) + val2)))) + (when val1? + (add-entry idx val1)))) ((and (logbitp idx subnodes1) (logbitp idx subnodes2)) (add-subnode idx (rec (ch-set-node-subnode tree1 (1-bits-below idx subnodes1)) (ch-set-node-subnode tree2 (1-bits-below idx subnodes2)) @@ -873,9 +920,9 @@ (defstruct (ch-set-node ((res-len (length (the simple-vector tree1))) ; upper bound ((res-n (make-array res-len :initial-element 0))))) (flet ((add-entry (idx val) - (ch-set-node-add-entry res-n idx val hash-fn)) + (ch-set-node-add-entry! res-n idx val hash-fn)) (add-subnode (idx subnode) - (ch-set-node-add-subnode res-n idx subnode hash-fn)) + (ch-set-node-add-subnode! res-n idx subnode hash-fn)) (subtree-less (subtree val) (ch-set-tree-less subtree val hash-fn compare-fn (1+ depth))) (subtree-contains? (subtree val) @@ -944,9 +991,9 @@ (defstruct (ch-set-node (isubnode2 0)) (declare (fixnum ientry1 isubnode1 ientry2 isubnode2)) (flet ((add-entry (n idx val) - (ch-set-node-add-entry n idx val hash-fn)) + (ch-set-node-add-entry! n idx val hash-fn)) (add-subnode (n idx subnode) - (ch-set-node-add-subnode n idx subnode hash-fn)) + (ch-set-node-add-subnode! n idx subnode hash-fn)) (subtree-less (subtree val) (ch-set-tree-less subtree val hash-fn compare-fn (1+ depth))) (subtree-contains? (subtree val) @@ -994,6 +1041,53 @@ (defstruct (ch-set-node (1 (vector (ash 1 (champ-hash-bits hash depth)) 0 1 hash (wb-set-tree-arb wb-set-tree))) (t (cons hash wb-set-tree)))) +(defun ch-set-node-replace-subnode (node isubnode new-subnode) + "Returns a new node with `new-subnode' replacing the subnode at `isubnode'." + (declare (optimize (speed 3) (safety 0)) + (type simple-vector node) + (type champ-subnode-index isubnode)) + (let ((old-subnode (ch-set-node-subnode node isubnode)) + (n (vector-update node (- (length node) isubnode 1) new-subnode))) + (declare (type simple-vector n)) + (setf (svref n (- (length n) isubnode 1)) new-subnode) + (incf (ch-set-node-size n) (- (ch-set-tree-size new-subnode) (ch-set-tree-size old-subnode))) + (hash-mixf (ch-set-node-hash-value n) + (hash-unmix (ch-set-tree-hash-value new-subnode) + (ch-set-tree-hash-value old-subnode))) + n)) + +(defun ch-set-node-insert-subnode (node isubnode hash-bits new-subnode) + "Returns a new node with `new-subnode' inserted just before `isubnode'." + (declare (optimize (speed 3) (safety 0)) + (type simple-vector node) + (type champ-bit-index hash-bits) + (type champ-subnode-index isubnode)) + (let ((n (vector-insert node (- (length node) isubnode) new-subnode))) + (logiorf (ch-set-node-subnode-mask n) (ash 1 hash-bits)) + (incf (ch-set-node-size n) (ch-set-tree-size new-subnode)) + (hash-mixf (ch-set-node-hash-value n) (ch-set-tree-hash-value new-subnode)) + n)) + +(defun ch-set-node-change-entry-to-subnode (node ientry isubnode hash-bits new-subnode hash-fn) + "Returns a new node with entry `ientry' removed, and `new-subnode' inserted just +before `isubnode'." + (declare (optimize (speed 3) (safety 0)) + (type simple-vector node) + (type champ-bit-index hash-bits) + (type champ-entry-index ientry) + (type champ-subnode-index isubnode) + (type function hash-fn)) + (let ((value (ch-set-node-entry node ientry)) + (n (vector-rem-1-ins-1 node (+ ch-set-node-header-size ientry) + (- (length node) isubnode) new-subnode))) + (logandc2f (ch-set-node-entry-mask n) (ash 1 hash-bits)) + (logiorf (ch-set-node-subnode-mask n) (ash 1 hash-bits)) + (incf (ch-set-node-size n) (1- (ch-set-tree-size new-subnode))) + (hash-mixf (ch-set-node-hash-value n) + (hash-unmix (ch-set-tree-hash-value new-subnode) + (hash-to-fixnum value hash-fn))) + n)) + (defun ch-set-compact-node (n) (declare (optimize (speed 3) (safety 0))) (let ((entries (ch-set-node-entry-mask n)) @@ -1102,6 +1196,7 @@ (defstruct (ch-set-node ;;; Verifier (defun ch-set-tree-verify (tree hash-fn) + (declare (optimize (debug 3))) (or (null tree) (rlabels (rec tree 0 0) (rec (node depth partial-hash) @@ -1216,29 +1311,29 @@ (defstruct (ch-map-node (type champ-subnode-index isubnode)) (svref node (- (length node) isubnode 1))) -(defun ch-map-tree-with (tree key value key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn &optional (depth 0)) +(defun ch-map-tree-with (tree key value key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn &optional (depth 0) replace?) (declare (optimize (speed 3) (safety 0)) (type function key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn) (type (integer 0 64) depth)) (let ((key-hash (hash-to-fixnum key key-hash-fn))) (declare (fixnum key-hash)) (rlabels (rec tree (ash key-hash (- (* champ-hash-bits-per-level depth))) depth) - (rec (node hash-shifted depth &optional node-hash) + (rec (node hash-shifted depth) (declare (fixnum hash-shifted) - (type (integer 0 64) depth) - (type (or null fixnum) node-hash)) + (type (integer 0 64) depth)) (let ((hash-bits (logand hash-shifted champ-hash-level-mask))) (if (null node) (vector (ash 1 hash-bits) 0 1 key-hash nil key value) (if (consp node) ;; Collision node. - (let ((node-hash (or node-hash (hash-to-fixnum (wb-map-tree-arb-pair (cdr node)) key-hash-fn))) - ((wb-hash-shifted (ash node-hash (* (- champ-hash-bits-per-level) depth)))) + (let ((wb-hash-shifted (ash (the fixnum (caar node)) (* (- champ-hash-bits-per-level) depth))) (size (1+ (wb-map-tree-size (cdr node))))) - (declare (fixnum wb-hash-shifted hash-shifted size)) + (declare (fixnum wb-hash-shifted size)) (if (= hash-shifted wb-hash-shifted) ;; Update the collision node. - (let ((new-wb-tree (wb-map-tree-with (cdr node) key value key-cmp-fn val-cmp-fn))) + (let ((new-wb-tree (wb-map-tree-with (if replace? (wb-map-tree-less (cdr node) key key-cmp-fn) + (cdr node)) + key value key-cmp-fn val-cmp-fn))) (if (eq new-wb-tree (cdr node)) node (let ((value-hash (and (cdar node) @@ -1259,7 +1354,7 @@ (defstruct (ch-map-node (value-hash (and (cdar node) (hash-mix (cdar node) (hash-to-fixnum value val-hash-fn))))) (if (= hash-bits wb-hash-bits) (vector 0 (ash 1 hash-bits) size key-hash value-hash - (rec node (ash hash-shifted (- champ-hash-bits-per-level)) (1+ depth) node-hash)) + (rec node (ash hash-shifted (- champ-hash-bits-per-level)) (1+ depth))) (vector (ash 1 hash-bits) (ash 1 wb-hash-bits) size key-hash value-hash key value node))))) ;; Normal case. @@ -1273,9 +1368,12 @@ (defstruct (ch-map-node (ex-val (svref node (1+ entry-idx)))) (if (equal?-cmp key ex-key key-cmp-fn) (if (equal?-cmp value ex-val val-cmp-fn) - node ; Key found, value equal: nothing to do + ;; Key found, value equal: nothing to do (unless `replace?' requested) + (if (and replace? (not (and (eq key ex-key) (eq value ex-val)))) + (vector-update-2 node entry-idx key value) + node) ;; Key found, value differs: just update value - (let ((n (vector-update node (+ entry-idx 1) value))) + (let ((n (vector-update-2 node entry-idx key value))) (when (ch-map-node-value-hash n) (hash-mixf (ch-map-node-value-hash n) (hash-unmix (hash-to-fixnum value val-hash-fn) (hash-to-fixnum ex-val val-hash-fn)))) @@ -1319,8 +1417,8 @@ (defstruct (ch-map-node (let ((n (vector-update node subnode-idx new-subnode))) ;; If only a value was updated, the subnode won't have changed size. (setf (ch-map-node-size n) - (the fixnum (+ (ch-map-node-size n) (- (the fixnum (ch-map-tree-size new-subnode)) - (the fixnum (ch-map-tree-size subnode)))))) + (the fixnum (+ (ch-map-node-size n) (- (ch-map-tree-size new-subnode) + (ch-map-tree-size subnode))))) (hash-mixf (ch-map-node-key-hash n) (hash-unmix (ch-map-tree-key-hash new-subnode) (ch-map-tree-key-hash subnode))) (when (ch-map-node-value-hash n) @@ -1371,6 +1469,14 @@ (defstruct (ch-map-node (setf (svref v (+ idx i 2)) (svref vec (+ idx i)))) v)) +(defun vector-update-2 (vec idx val-0 val-1) + (declare (optimize (speed 3) (safety 0)) + (simple-vector vec) + (fixnum idx)) + (let ((v (vector-update vec idx val-0))) + (setf (svref v (1+ idx)) val-1) + v)) + (defun ch-map-tree-hash-value (tree val-hash-fn) (hash-mix (ch-map-tree-key-hash tree) (ch-map-tree-value-hash tree val-hash-fn))) @@ -1458,7 +1564,7 @@ (defstruct (ch-map-node (assert (= depth 0)) (values nil (svref node (1+ entry-idx)))) (t - (let ((n (vector-remove-2-at node entry-idx))) + (let ((n (vector-remove-2 node entry-idx))) (logandc2f (ch-map-node-entry-mask n) (ash 1 hash-bits)) (decf (ch-map-node-size n)) (hash-unmixf (ch-map-node-key-hash n) key-hash) @@ -1470,12 +1576,12 @@ (defstruct (ch-map-node ((subnode-idx (- (the fixnum (length node)) 1 subnode-raw-idx)))) (declare (fixnum subnode-raw-idx subnode-idx)) (if (not (logbitp hash-bits subnode-mask)) - (values node 0) + (values node nil) (let ((subnode (svref node subnode-idx))) (let ((new-subnode lookup-val (rec subnode (ash hash-shifted (- champ-hash-bits-per-level)) (1+ depth)))) (if (eq new-subnode subnode) - (values node 0) + (values node nil) (let ((n (cond ((consp new-subnode) (vector-update node subnode-idx new-subnode)) ((and (= 1 (logcount (ch-map-node-entry-mask new-subnode))) @@ -1484,16 +1590,14 @@ (defstruct (ch-map-node (let ((new-entry-idx (+ ch-map-node-header-size (* 2 (1-bits-below hash-bits entry-mask)))) - ((n (vector-ins-2-rem-1 - node new-entry-idx (svref new-subnode ch-map-node-header-size) - (svref new-subnode (1+ ch-map-node-header-size)) - subnode-idx)))) + (k v (ch-map-node-entry new-subnode 0)) + ((n (vector-ins-2-rem-1 node new-entry-idx k v subnode-idx)))) (logiorf (ch-map-node-entry-mask n) (ash 1 hash-bits)) (logandc2f (ch-map-node-subnode-mask n) (ash 1 hash-bits)) n)) ((and (= 0 (ch-map-node-entry-mask new-subnode)) (= 1 (logcount (ch-map-node-subnode-mask new-subnode))) - (consp (svref new-subnode ch-map-node-header-size))) + (consp (ch-map-node-subnode new-subnode 0))) ;; New subnode contains only a collision node: pull it up into this node (vector-update node subnode-idx (svref new-subnode ch-map-node-header-size))) @@ -1507,7 +1611,7 @@ (defstruct (ch-map-node (ch-map-tree-value-hash subnode val-hash-fn)))) (values n lookup-val))))))))))))))) -(defun vector-remove-2-at (vec idx) +(defun vector-remove-2 (vec idx) (declare (optimize (speed 3) (safety 0)) (simple-vector vec) (fixnum idx)) @@ -1559,7 +1663,7 @@ (defstruct (ch-map-node (* 2 (1-bits-below hash-bits entry-mask)))) ((ex-key (svref node entry-idx)))) (and (equal?-cmp ex-key key key-cmp-fn) - (values t (svref node (1+ entry-idx))))) + (values t (svref node (1+ entry-idx)) (svref node entry-idx)))) (let ((subnode-mask (ch-map-node-subnode-mask node))) (and (logbitp hash-bits subnode-mask) (let ((subnode-idx (- (the fixnum (length node)) @@ -1893,8 +1997,8 @@ (defstruct (ch-map-node ;;; -------------------------------- ;;; Union, intersection, set-difference, subset?, disjoint? -(declaim (inline ch-map-node-add-entry)) -(defun ch-map-node-add-entry (n idx key val key-hash-fn) +(declaim (inline ch-map-node-add-entry!)) +(defun ch-map-node-add-entry! (n idx key val key-hash-fn) (declare (optimize (speed 3) (safety 0)) (type champ-bit-index idx) (type function key-hash-fn)) @@ -1905,8 +2009,8 @@ (defstruct (ch-map-node (incf (ch-map-node-size n)) (hash-mixf (ch-map-node-key-hash n) (hash-to-fixnum key key-hash-fn))) -(declaim (inline ch-map-node-add-subnode)) -(defun ch-map-node-add-subnode (n idx subnode key-hash-fn) +(declaim (inline ch-map-node-add-subnode!)) +(defun ch-map-node-add-subnode! (n idx subnode key-hash-fn) (declare (optimize (speed 3) (safety 0)) (type champ-bit-index idx) (type function key-hash-fn)) @@ -1915,7 +2019,7 @@ (defstruct (ch-map-node (= 1 (logcount (ch-map-node-entry-mask subnode))) (= 0 (ch-map-node-subnode-mask subnode))) ;; `subnode' contains only an entry -- pull it up. - (ch-map-node-add-entry n idx (svref subnode ch-map-node-header-size) + (ch-map-node-add-entry! n idx (svref subnode ch-map-node-header-size) (svref subnode (1+ ch-map-node-header-size)) key-hash-fn) (progn (when (and (not (consp subnode)) @@ -1932,10 +2036,10 @@ (defstruct (ch-map-node (hash-mixf (ch-map-node-key-hash n) (ch-map-tree-key-hash subnode)))))) (defun ch-map-tree-union (tree1 tree2 val-fn key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn) - (declare (optimize (speed 3) (safety 0)) + (declare (optimize (speed 1) (safety 0)) (type function val-fn key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn)) - (rlabels (rec tree1 tree2 val-fn 0) - (rec (tree1 tree2 val-fn depth) + (rlabels (rec tree1 tree2 0) + (rec (tree1 tree2 depth) (declare (type (integer 0 64) depth) (type function val-fn)) (cond ((null tree1) tree2) @@ -1943,7 +2047,7 @@ (defstruct (ch-map-node ((eq tree1 tree2) tree1) ((and (consp tree1) (consp tree2)) (if (= (the fixnum (caar tree1)) (the fixnum (caar tree2))) - (let ((result (wb-map-tree-union (cdr tree1) (cdr tree2) val-fn key-cmp-fn))) + (let ((result (wb-map-tree-union (cdr tree1) (cdr tree2) val-fn key-cmp-fn val-cmp-fn))) (ch-map-node-from-wb result (caar tree1) depth)) (let ((bits1 (champ-hash-bits (the fixnum (caar tree1)) depth)) (bits2 (champ-hash-bits (the fixnum (caar tree2)) depth)) @@ -1951,22 +2055,46 @@ (defstruct (ch-map-node (key-hash (hash-mix (caar tree1) (caar tree2)))) (declare (fixnum size)) (if (= bits1 bits2) - (vector 0 (ash 1 bits1) size key-hash nil (rec tree1 tree2 val-fn (1+ depth))) + (vector 0 (ash 1 bits1) size key-hash nil (rec tree1 tree2 (1+ depth))) (let ((subnode0 subnode1 (swap-if (> bits1 bits2) tree1 tree2))) (vector 0 (logior (ash 1 bits1) (ash 1 bits2)) size key-hash nil subnode1 subnode0)))))) - ((consp tree1) - (do-wb-map-tree-pairs (k1 v1 (cdr tree1)) - (let ((v2? v2 (ch-map-tree-lookup tree2 k1 key-hash-fn key-cmp-fn depth))) - (if v2? - (let ((new-v second-val (funcall val-fn v1 v2))) - (if (eq second-val ':no-value) - (setq tree2 (ch-map-tree-less tree2 k1 key-hash-fn key-cmp-fn val-hash-fn depth)) - (setq tree2 (ch-map-tree-with tree2 k1 new-v key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn - depth)))) - (setq tree2 (ch-map-tree-with tree2 k1 v1 key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth))))) - tree2) - ((consp tree2) - (rec tree2 tree1 (fn (x y) (funcall val-fn y x)) depth)) + ((or (consp tree1) (consp tree2)) + ;; I foolishly undertook to implement left preference and make this case more efficient at + ;; the same time. Turned out to take a crapload of code (and my time), for a not-very-common + ;; case. Sometimes maximum performance is not worth the complication. + (let ((tree1-collision? (consp tree1)) + ((norm-node coll-node (swap-if tree1-collision? tree1 tree2)) + ((hash-bits (champ-hash-bits (the fixnum (caar coll-node)) depth)) + (entry-mask (ch-map-node-entry-mask norm-node)) + (subnode-mask (ch-map-node-subnode-mask norm-node))))) + (declare (type simple-vector norm-node)) + (cond ((logbitp hash-bits entry-mask) + (let ((ientry (1-bits-below hash-bits entry-mask)) + ((norm-key norm-val (ch-map-node-entry norm-node ientry)) + ((coll-val? coll-val coll-key (wb-map-tree-lookup (cdr coll-node) norm-key key-cmp-fn)) + ((new-subnode + (if coll-val? + (let ((new-val second-val + (if tree1-collision? (compute-new-val coll-val norm-val) + (compute-new-val norm-val coll-val)))) + (if (eq second-val ':no-value) + (ch-map-tree-less coll-node norm-key key-hash-fn key-cmp-fn val-hash-fn + (1+ depth)) + (ch-map-tree-with coll-node (if tree1-collision? coll-key norm-key) + new-val key-hash-fn key-cmp-fn val-hash-fn + val-cmp-fn (1+ depth) (not tree1-collision?)))) + (ch-map-tree-with coll-node norm-key norm-val key-hash-fn key-cmp-fn val-hash-fn + val-cmp-fn (1+ depth) (not tree1-collision?)))))))) + (ch-map-node-change-entry-to-subnode norm-node hash-bits new-subnode key-hash-fn val-hash-fn))) + ((logbitp hash-bits subnode-mask) + (let ((isubnode (1-bits-below hash-bits subnode-mask)) + ((old-subnode (ch-map-node-subnode norm-node isubnode)))) + (ch-map-node-replace-subnode norm-node hash-bits + (if tree1-collision? (rec coll-node old-subnode (1+ depth)) + (rec old-subnode coll-node (1+ depth))) + key-hash-fn val-hash-fn))) + (t + (ch-map-node-insert-subnode norm-node hash-bits coll-node val-hash-fn))))) (t (let ((entries1 (ch-map-node-entry-mask tree1)) (entries2 (ch-map-node-entry-mask tree2)) @@ -1986,15 +2114,15 @@ (defstruct (ch-map-node (declare (fixnum ientry1 isubnode1 ientry2 isubnode2)) (setf (ch-map-node-value-hash res-n) nil) (flet ((add-entry (idx key val) - (ch-map-node-add-entry res-n idx key val key-hash-fn)) + (ch-map-node-add-entry! res-n idx key val key-hash-fn)) (add-subnode (idx subnode) - (ch-map-node-add-subnode res-n idx subnode key-hash-fn) + (ch-map-node-add-subnode! res-n idx subnode key-hash-fn) nil) ; hush, SBCL (subtree-lookup (tree key) (ch-map-tree-lookup tree key key-hash-fn key-cmp-fn (1+ depth))) - (subtree-with (subtree key value) + (subtree-with (subtree key value &optional replace?) (ch-map-tree-with subtree key value key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn - (1+ depth))) + (1+ depth) replace?)) (subtree-less (subtree key) (ch-map-tree-less subtree key key-hash-fn key-cmp-fn val-hash-fn (1+ depth)))) (do-bit-indices (idx everything) @@ -2002,7 +2130,7 @@ (defstruct (ch-map-node (let ((key1 val1 (ch-map-node-entry tree1 (postincf ientry1))) (key2 val2 (ch-map-node-entry tree2 (postincf ientry2)))) (if (equal?-cmp key1 key2 key-cmp-fn) - (let ((new-val second-val (funcall val-fn val1 val2))) + (let ((new-val second-val (compute-new-val val1 val2))) (unless (eq second-val ':no-value) (add-entry idx key1 new-val))) (add-subnode idx (subtree-with (subtree-with nil key1 val1) key2 val2))))) @@ -2012,61 +2140,89 @@ (defstruct (ch-map-node (let ((subnode2 (ch-map-node-subnode tree2 (postincf isubnode2))) ((val2? val2 (subtree-lookup subnode2 key1)))) (if val2? - (let ((new-val second-val (funcall val-fn val1 val2))) + (let ((new-val second-val (compute-new-val val1 val2))) (if (eq second-val ':no-value) (add-subnode idx (subtree-less subnode2 key1)) - (add-subnode idx (subtree-with subnode2 key1 new-val)))) - (add-subnode idx (subtree-with subnode2 key1 val1)))) + (add-subnode idx (subtree-with subnode2 key1 new-val t)))) + (add-subnode idx (subtree-with subnode2 key1 val1 t)))) (add-entry idx key1 val1)))) ((logbitp idx entries2) (let ((key2 val2 (ch-map-node-entry tree2 (postincf ientry2)))) (if (logbitp idx subnodes1) (let ((subnode1 (ch-map-node-subnode tree1 (postincf isubnode1))) - ((val1? val1 (subtree-lookup subnode1 key2)))) + ((val1? val1 key1 (subtree-lookup subnode1 key2)))) (if val1? - (let ((new-val second-val (funcall val-fn val1 val2))) + (let ((new-val second-val (compute-new-val val1 val2))) (if (eq second-val ':no-value) (add-subnode idx (subtree-less subnode1 key2)) - (add-subnode idx (subtree-with subnode1 key2 new-val)))) + (add-subnode idx (subtree-with subnode1 key1 new-val t)))) (add-subnode idx (subtree-with subnode1 key2 val2)))) (add-entry idx key2 val2)))) ((and (logbitp idx subnodes1) (logbitp idx subnodes2)) (add-subnode idx (rec (ch-map-node-subnode tree1 (postincf isubnode1)) (ch-map-node-subnode tree2 (postincf isubnode2)) - val-fn (1+ depth)))) + (1+ depth)))) ((logbitp idx subnodes1) (add-subnode idx (ch-map-node-subnode tree1 (postincf isubnode1)))) ((logbitp idx subnodes2) (add-subnode idx (ch-map-node-subnode tree2 (postincf isubnode2)))) (t (error "Bug in 'ch-map-tree-union'"))))) ;; When two entries meet and become a subnode, we no longer need the value slot. - (ch-map-compact-node res-n))))))) + (ch-map-compact-node res-n))))) + (compute-new-val (val1 val2) + (if (equal?-cmp val1 val2 val-cmp-fn) + val1 + (funcall val-fn val1 val2))))) (defun ch-map-tree-intersection (tree1 tree2 val-fn key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn) (declare (optimize (speed 3) (safety 0)) (type function val-fn key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn)) - (rlabels (rec tree1 tree2 val-fn 0) - (rec (tree1 tree2 val-fn depth) + (rlabels (rec tree1 tree2 0) + (rec (tree1 tree2 depth) (declare (type (integer 0 64) depth) (type function val-fn)) (cond ((or (null tree1) (null tree2)) nil) ((eq tree1 tree2) tree1) - ((and (consp tree1) (consp tree2)) - (and (= (the fixnum (caar tree1)) (the fixnum (caar tree2))) - (let ((result (wb-map-tree-intersect (cdr tree1) (cdr tree2) val-fn key-cmp-fn))) - (ch-map-node-from-wb result (caar tree1) depth)))) ((consp tree1) - (let ((result nil)) - (do-wb-map-tree-pairs (k1 v1 (cdr tree1)) - (let ((v2? v2 (ch-map-tree-lookup tree2 k1 key-hash-fn key-cmp-fn depth))) - (when v2? - (let ((new-v second-val (funcall val-fn v1 v2))) - (unless (eq second-val ':no-value) - (setq result (ch-map-tree-with result k1 new-v key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn - depth))))))) - result)) + (if (consp tree2) + (and (= (the fixnum (caar tree1)) (the fixnum (caar tree2))) + (let ((result (wb-map-tree-intersect (cdr tree1) (cdr tree2) val-fn key-cmp-fn val-cmp-fn))) + (ch-map-node-from-wb result (caar tree1) depth))) + (let ((result nil)) + (do-wb-map-tree-pairs (k1 v1 (cdr tree1)) + (let ((v2? v2 (ch-map-tree-lookup tree2 k1 key-hash-fn key-cmp-fn depth))) + (when v2? + (let ((new-v second-val (compute-new-val v1 v2))) + (unless (eq second-val ':no-value) + (setq result (ch-map-tree-with result k1 new-v key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn + depth))))))) + result))) ((consp tree2) - (rec tree2 tree1 (fn (x y) (funcall val-fn y x)) depth)) + (let ((hash-bits (champ-hash-bits (the fixnum (caar tree2)) depth)) + (entry-mask (ch-map-node-entry-mask tree1)) + (subnode-mask (ch-map-node-subnode-mask tree1))) + (cond ((logbitp hash-bits entry-mask) + (let ((ientry (1-bits-below hash-bits entry-mask)) + ((k1 v1 (ch-map-node-entry tree1 ientry)) + ((v2? v2 (wb-map-tree-lookup (cdr tree2) k1 key-cmp-fn))))) + (and v2? + (let ((new-v second-val (compute-new-val v1 v2))) + (and (not (eq second-val ':no-value)) + (ch-map-tree-with nil k1 new-v key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn + depth)))))) + ((logbitp hash-bits subnode-mask) + (let ((isubnode (1-bits-below hash-bits subnode-mask)) + ((old-subnode (ch-map-node-subnode tree1 isubnode))) + (result nil)) + (do-wb-map-tree-pairs (k2 v2 (cdr tree2)) + (let ((v1? v1 k1 (ch-map-tree-lookup old-subnode k2 key-hash-fn key-cmp-fn (1+ depth)))) + (when v1? + (let ((new-v second-val (compute-new-val v1 v2))) + (unless (eq second-val ':no-value) + (setq result (ch-map-tree-with result k1 new-v key-hash-fn key-cmp-fn + val-hash-fn val-cmp-fn depth))))))) + result)) + (t nil)))) (t (let ((entries1 (ch-map-node-entry-mask tree1)) (entries2 (ch-map-node-entry-mask tree2)) @@ -2079,9 +2235,9 @@ (defstruct (ch-map-node ((res-n (make-array res-len :initial-element 0)))))) (setf (ch-map-node-value-hash res-n) nil) (flet ((add-entry (idx key val) - (ch-map-node-add-entry res-n idx key val key-hash-fn)) + (ch-map-node-add-entry! res-n idx key val key-hash-fn)) (add-subnode (idx subnode) - (ch-map-node-add-subnode res-n idx subnode key-hash-fn)) + (ch-map-node-add-subnode! res-n idx subnode key-hash-fn)) (subtree-lookup (tree key) (ch-map-tree-lookup tree key key-hash-fn key-cmp-fn (1+ depth)))) (do-bit-indices (idx combined-mask) @@ -2089,7 +2245,7 @@ (defstruct (ch-map-node (let ((key1 val1 (ch-map-node-entry tree1 (1-bits-below idx entries1))) (key2 val2 (ch-map-node-entry tree2 (1-bits-below idx entries2)))) (when (equal?-cmp key1 key2 key-cmp-fn) - (let ((new-val second-val (funcall val-fn val1 val2))) + (let ((new-val second-val (compute-new-val val1 val2))) (unless (eq second-val ':no-value) (add-entry idx key1 new-val)))))) ((and (logbitp idx entries1) (logbitp idx subnodes2)) @@ -2097,22 +2253,26 @@ (defstruct (ch-map-node (subnode2 (ch-map-node-subnode tree2 (1-bits-below idx subnodes2))) ((val2? val2 (subtree-lookup subnode2 key1)))) (when val2? - (let ((new-val second-val (funcall val-fn val1 val2))) + (let ((new-val second-val (compute-new-val val1 val2))) (unless (eq second-val ':no-value) (add-entry idx key1 new-val)))))) ((and (logbitp idx subnodes1) (logbitp idx entries2)) (let ((key2 val2 (ch-map-node-entry tree2 (1-bits-below idx entries2))) (subnode1 (ch-map-node-subnode tree1 (1-bits-below idx subnodes1))) - ((val1? val1 (subtree-lookup subnode1 key2)))) + ((val1? val1 key1 (subtree-lookup subnode1 key2)))) (when val1? - (let ((new-val second-val (funcall val-fn val1 val2))) + (let ((new-val second-val (compute-new-val val1 val2))) (unless (eq second-val ':no-value) - (add-entry idx key2 new-val)))))) + (add-entry idx key1 new-val)))))) ((and (logbitp idx subnodes1) (logbitp idx subnodes2)) (add-subnode idx (rec (ch-map-node-subnode tree1 (1-bits-below idx subnodes1)) (ch-map-node-subnode tree2 (1-bits-below idx subnodes2)) - val-fn (1+ depth)))))) - (ch-map-compact-node res-n)))))))) + (1+ depth)))))) + (ch-map-compact-node res-n)))))) + (compute-new-val (val1 val2) + (if (equal?-cmp val1 val2 val-cmp-fn) + (values val1 nil) + (n-values 2 (funcall val-fn val1 val2)))))) (defun ch-map-tree-diff-2 (tree1 tree2 key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn) (declare (optimize (speed 3) (safety 0)) @@ -2163,9 +2323,9 @@ (defstruct (ch-map-node (setf (ch-map-node-value-hash res-n1) nil) (setf (ch-map-node-value-hash res-n2) nil) (flet ((add-entry (n idx key val) - (ch-map-node-add-entry n idx key val key-hash-fn)) + (ch-map-node-add-entry! n idx key val key-hash-fn)) (add-subnode (n idx subnode) - (ch-map-node-add-subnode n idx subnode key-hash-fn)) + (ch-map-node-add-subnode! n idx subnode key-hash-fn)) (subtree-less (subtree key) (ch-map-tree-less subtree key key-hash-fn key-cmp-fn val-hash-fn (1+ depth))) (subtree-lookup (subtree key) @@ -2249,9 +2409,9 @@ (defstruct (ch-map-node ((res-n (make-array res-len :initial-element 0)))))) (setf (ch-map-node-value-hash res-n) nil) (flet ((add-entry (idx key val) - (ch-map-node-add-entry res-n idx key val key-hash-fn)) + (ch-map-node-add-entry! res-n idx key val key-hash-fn)) (add-subnode (idx subnode) - (ch-map-node-add-subnode res-n idx subnode key-hash-fn)) + (ch-map-node-add-subnode! res-n idx subnode key-hash-fn)) (map-lookup (map-subtree key) (ch-map-tree-lookup map-subtree key key-hash-fn key-cmp-fn (1+ depth))) (set-contains? (set-subtree key) @@ -2313,9 +2473,9 @@ (defstruct (ch-map-node ((res-n (make-array res-len :initial-element 0))))) (setf (ch-map-node-value-hash res-n) nil) (flet ((add-entry (idx key val) - (ch-map-node-add-entry res-n idx key val key-hash-fn)) + (ch-map-node-add-entry! res-n idx key val key-hash-fn)) (add-subnode (idx subnode) - (ch-map-node-add-subnode res-n idx subnode key-hash-fn)) + (ch-map-node-add-subnode! res-n idx subnode key-hash-fn)) (map-subtree-less (subtree key) (ch-map-tree-less subtree key key-hash-fn key-cmp-fn val-hash-fn (1+ depth))) (set-contains? (set-subtree key) @@ -2352,6 +2512,109 @@ (defstruct (ch-map-node 0 1 key-hash nil k v))) (t (cons (cons key-hash nil) wb-map-tree)))) +(defun ch-map-node-replace-subnode (node hash-bits new-subnode key-hash-fn val-hash-fn) + "Returns a new node with `new-subnode' replacing the subnode at `isubnode'." + (declare (optimize (speed 3) (safety 0)) + (type simple-vector node) + (type champ-bit-index hash-bits) + (type function key-hash-fn val-hash-fn)) + (let ((isubnode (1-bits-below hash-bits (ch-map-node-subnode-mask node))) + ((old-subnode (ch-map-node-subnode node isubnode)))) + ;; Even when unioning, the `:no-value' feature can generate empty subnodes... + (cond ((null new-subnode) + (let ((n (vector-remove-n-at node (- (length node) isubnode 1) 1))) + (logandc2f (ch-map-node-subnode-mask n) (ash 1 hash-bits)) + (decf (ch-map-node-size n) (ch-map-tree-size old-subnode)) + (hash-unmixf (ch-map-node-key-hash n) (ch-map-tree-key-hash old-subnode)) + (when (ch-map-node-value-hash n) + (hash-unmixf (ch-map-node-value-hash n) (ch-map-tree-value-hash old-subnode val-hash-fn))) + n)) + ;; ... or single-entry ones. + ((and (not (consp new-subnode)) + (= 1 (logcount (ch-map-node-entry-mask new-subnode))) + (= 0 (ch-map-node-subnode-mask new-subnode))) + (let ((ientry (1-bits-below hash-bits (ch-map-node-entry-mask node))) + (key val (ch-map-node-entry new-subnode 0)) + ((n (vector-ins-2-rem-1 node (+ ch-map-node-header-size (* 2 ientry)) key val + (- (length node) isubnode 1))))) + (logiorf (ch-map-node-entry-mask n) (ash 1 hash-bits)) + (logandc2f (ch-map-node-subnode-mask n) (ash 1 hash-bits)) + (incf (ch-map-node-size n) (- 1 (ch-map-tree-size old-subnode))) + (hash-mixf (ch-map-node-key-hash n) + (hash-unmix (hash-to-fixnum key key-hash-fn) + (ch-map-tree-key-hash old-subnode))) + (when (ch-map-node-value-hash n) + (hash-mixf (ch-map-node-value-hash n) + (hash-unmix (hash-to-fixnum val val-hash-fn) + (ch-map-tree-value-hash old-subnode val-hash-fn)))) + n)) + (t + (let ((n (vector-update node (- (length node) isubnode 1) new-subnode))) + (declare (type simple-vector n)) + (setf (svref n (- (length n) isubnode 1)) new-subnode) + (incf (ch-map-node-size n) (- (ch-map-tree-size new-subnode) (ch-map-tree-size old-subnode))) + (hash-mixf (ch-map-node-key-hash n) + (hash-unmix (ch-map-tree-key-hash new-subnode) + (ch-map-tree-key-hash old-subnode))) + (when (ch-map-node-value-hash n) + (hash-mixf (ch-map-node-value-hash n) + (hash-unmix (ch-map-tree-value-hash new-subnode val-hash-fn) + (ch-map-tree-value-hash old-subnode val-hash-fn)))) + n))))) + +(defun ch-map-node-insert-subnode (node hash-bits new-subnode val-hash-fn) + "Returns a new node with `new-subnode' inserted just before `isubnode'." + (declare (optimize (speed 3) (safety 0)) + (type simple-vector node) + (type champ-bit-index hash-bits)) + (let ((isubnode (1-bits-below hash-bits (ch-map-node-subnode-mask node))) + ((n (vector-insert node (- (length node) isubnode) new-subnode)))) + (logiorf (ch-map-node-subnode-mask n) (ash 1 hash-bits)) + (incf (ch-map-node-size n) (ch-map-tree-size new-subnode)) + (hash-mixf (ch-map-node-key-hash n) (ch-map-tree-key-hash new-subnode)) + (when (ch-map-node-value-hash n) + (hash-mixf (ch-map-node-value-hash n) + (ch-map-tree-value-hash new-subnode val-hash-fn))) + n)) + +(defun ch-map-node-change-entry-to-subnode (node hash-bits new-subnode key-hash-fn val-hash-fn) + "Returns a new node with entry `ientry' removed, and `new-subnode' inserted just +before `isubnode'." + (declare (optimize (speed 3) (safety 0)) + (type simple-vector node) + (type champ-bit-index hash-bits) + (type function key-hash-fn val-hash-fn)) + (let ((ientry (1-bits-below hash-bits (ch-map-node-entry-mask node))) + (isubnode (1-bits-below hash-bits (ch-map-node-subnode-mask node))) + ((old-key old-val (ch-map-node-entry node ientry)))) + ;; Even when unioning, the `:no-value' feature can generate single-entry subnodes. + (if (and (not (consp new-subnode)) + (= 1 (logcount (ch-map-node-entry-mask new-subnode))) + (= 0 (ch-map-node-subnode-mask new-subnode))) + (let ((key val (ch-map-node-entry new-subnode 0)) + ((n (vector-update-2 node (+ ch-map-node-header-size (* 2 ientry)) key val)))) + (hash-mixf (ch-map-node-key-hash n) + (hash-unmix (hash-to-fixnum key key-hash-fn) + (hash-to-fixnum old-key key-hash-fn))) + (when (ch-map-node-value-hash n) + (hash-mixf (ch-map-node-value-hash n) + (hash-unmix (hash-to-fixnum val val-hash-fn) + (hash-to-fixnum old-val val-hash-fn)))) + n) + (let ((n (vector-rem-2-ins-1 node (+ ch-map-node-header-size (* 2 ientry)) + (- (length node) isubnode) new-subnode))) + (logandc2f (ch-map-node-entry-mask n) (ash 1 hash-bits)) + (logiorf (ch-map-node-subnode-mask n) (ash 1 hash-bits)) + (incf (ch-map-node-size n) (1- (ch-map-tree-size new-subnode))) + (hash-mixf (ch-map-node-key-hash n) + (hash-unmix (ch-map-tree-key-hash new-subnode) + (hash-to-fixnum old-key key-hash-fn))) + (when (ch-map-node-value-hash n) + (hash-mixf (ch-map-node-value-hash n) + (hash-unmix (ch-map-tree-value-hash new-subnode val-hash-fn) + (hash-to-fixnum old-val val-hash-fn)))) + n)))) + (defun ch-map-compact-node (n) (declare (optimize (speed 3) (safety 0))) (let ((entries (ch-map-node-entry-mask n)) @@ -2389,6 +2652,7 @@ (defstruct (ch-map-node n)))) (defun ch-map-tree-verify (tree key-hash-fn val-hash-fn) + (declare (optimize (debug 3))) (or (null tree) (rlabels (rec tree 0 0) (rec (node depth partial-hash) @@ -2397,11 +2661,9 @@ (defstruct (ch-map-node (progn (cerror "Ignore and proceed." "Verification check failed at ~:A: ~S" (path depth partial-hash) ',form) - nil)))) + t)))) (let ((entry-mask (ch-map-node-entry-mask node)) - (subnode-mask (ch-map-node-subnode-mask node)) - ((entry-bits (bit-indices entry-mask)) - (subnode-bits (bit-indices subnode-mask)))) + (subnode-mask (ch-map-node-subnode-mask node))) (and (test (= 0 (logand entry-mask subnode-mask))) (test (= 0 (ash entry-mask (- champ-node-radix)))) (test (= 0 (ash subnode-mask (- champ-node-radix)))) @@ -2428,7 +2690,7 @@ (defstruct (ch-map-node key-hash) (new-partial-hash hash-bits depth partial-hash))))) (:arg index 0) - (:arg list entry-bits)) + (:arg list (bit-indices entry-mask))) ;; Verify subnodes (gmap :and (fn (subnode-idx hash-bits) (let ((subnode (svref node (- (length node) 1 subnode-idx)))) @@ -2457,7 +2719,7 @@ (defstruct (ch-map-node (hash-mixf node-value-hash (ch-map-node-value-hash subnode))) t))))) (:arg index 0) - (:arg list subnode-bits)) + (:arg list (bit-indices subnode-mask))) ;; Finally, check size and hashes (test (= (ch-map-node-size node) size)) (test (= (ch-map-node-key-hash node) node-key-hash)) diff --git a/Code/defs.lisp b/Code/defs.lisp index e3f079623f63be65db80bb9c26811085229aaf50..ec0326a3bf0e59b274a67d6e939ad72ffe206d5c 100644 --- a/Code/defs.lisp +++ b/Code/defs.lisp @@ -16,6 +16,7 @@ (:import-from :gmap #:gmap #:alist #:constant #:index #:index-inc #:sum) (:shadowing-import-from :new-let #:let #:cond) (:shadowing-import-from :mt19937 #:make-random-state #:random #:*random-state*) + #+allegro (:implementation-packages "FSET" "FSET2") ;; 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 @@ -40,20 +41,18 @@ #:wb-custom-set #:wb-custom-bag #:wb-custom-map #:ch-custom-set #:ch-custom-map #:wb-custom-replay-set #:wb-custom-replay-map #:ch-custom-replay-set #:ch-custom-replay-map - ;; `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 #:compare-slots-no-unequal #:eql-compare + #:equal? #:compare #:compare-slots #:compare-slots-no-unequal #:hash-slots #:eql-compare #:define-equality-slots #:define-comparison-slots #:define-hash-function #:unwrap-equivalent-node ; custom comparison functions may have to call this #:hash-value #:hash-value-fixnum #:zero #:hash-mix #:hash-mixf #:hash-multiply #:identity-equality-mixin #:identity-ordering-mixin #:define-cross-type-compare-methods - #:compare-lexicographically + #:compare-lexicographically #:compare-lists-lexicographically #:compare-strings-lexicographically + #:compare-vectors-lexicographically #:compare-seqs-lexicographically #:empty? #:nonempty? #:size #:set-size #:arb #:contains? #:domain-contains? #:range-contains? #:member? #:multiplicity - #:empty-set #:empty-bag #:empty-map #:empty-seq #:empty-tuple + #:empty-set #:empty-set-like #:empty-bag #:empty-bag-like #:empty-map #:empty-map-like + #:empty-seq #:empty-tuple #:empty-wb-set #:empty-wb-bag #:empty-wb-map #:empty-wb-seq #:empty-dyn-tuple #:empty-ch-set #:empty-ch-map #:empty-replay-set #:empty-wb-replay-set #:empty-replay-map #:empty-wb-replay-map @@ -61,16 +60,17 @@ #:least #:greatest #:lookup #:rank #:at-rank #:index #:at-index #:@ #:with #:less #:split-from #:split-above #:split-through #:split-below #:union #:bag-sum #:intersection #:bag-product #:complement - #:set-difference #:set-difference-2 #:bag-difference #:bag-pairs + #:set-difference #:set-difference-2 #:bag-difference #:bag-pairs #:wb-bag-pairs #:subset? #:proper-subset? #:disjoint? #:subbag? #:proper-subbag? #:filter #:filter-pairs #:partition - #:image #:reduce #:domain #:range #:with-default #:update + #:image #:reduce #:domain #:range #:update + #:with-default #:default #:map-union #:map-intersection #:map-difference-2 - #:restrict #:restrict-not #:compose #:map-default + #:restrict #:restrict-not #:compose #:first #:last #:lastcons #:head #:tail #:with-first #:less-first #:push-first #:pop-first - #:with-last #:less-last #:push-last #:pop-last #:appendf #:prependf #:insertf + #:with-last #:less-last #:push-last #:pop-last #:appendf #:prependf #:insertf #:splicef #:insert #:splice #:subseq #:concat #:reverse #:sort #:stable-sort #:sort-and-group #:find #:find-if #:find-if-not #:count #:count-if #:count-if-not @@ -100,6 +100,7 @@ #:full-set ;; Relations #:relation #:relation? #:2-relation #:2-relation? #:wb-2-relation #:wb-2-relation? + #:wb-custom-2-relation #:ch-2-relation #:ch-2-relation? #:ch-custom-2-relation #:empty-2-relation #:empty-wb-2-relation #:empty-ch-2-relation #:do-2-relation #:lookup-inv #:inverse #:join #:conflicts #:map-to-sets #:list-relation #:list-relation? #:wb-list-relation #:wb-list-relation? @@ -116,41 +117,52 @@ ;;; Since we've shadowed `cl:count', we need to do this. (gmap:def-result-type-synonym fset:count cl:count) +;;; We want to import this below, so make sure it exists. +(defvar fset::erapmoc) -;;; The need has arisen to define a second FSet package. There are two motivations: -;;; () the planned introduction of the CHAMP data structure for sets, maps, and bags, -;;; which will become the default, incompatibly altering the behavior of the corresponding -;;; constructor macros, and requiring methods on `hash-value' as well as `compare' for -;;; user types; -;;; () miscellaneous infelicities in the API which cannot be fixed compatibly. -;;; -;;; The plan is for both packages to continue to exist indefinitely. New client code is -;;; encouraged to use package `fset2' instead of `fset'; existing clients may update -;;; their code at their leisure. -;;; NOTE: This package is not ready for use yet. I will announce when it is. + +;;; For a discussion of how the `fset2' package differs from `fset', see: +;;; https://gitlab.common-lisp.net/fset/fset/-/merge_requests/2 (defpackage :fset2 (:nicknames :com.ergy.fset2 :com.sympoiesis.fset2) (:use :cl :fset :new-let :lexical-contexts :rev-fun-bind :misc-extensions.define-class) (:import-from :gmap #:gmap #:alist #:constant #:index #:sum) (:shadowing-import-from :new-let #:let #:cond) (:shadowing-import-from :mt19937 #:make-random-state #:random #:*random-state*) - ;; For each of these shadowed symbols, using packages must either shadowing- + #+allegro (:implementation-packages "FSET" "FSET2") + ;; For each of these shadowed CL 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 #: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 - #:remove #:remove-if #:remove-if-not - #:substitute #:substitute-if #:substitute-if-not - #:some #:every #:notany #:notevery - ;; Additional shadowed names from `fset:' - #:map-intersection) + (:shadowing-import-from :fset + ;; Shadowed set operations + #: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 + #:remove #:remove-if #:remove-if-not + #:substitute #:substitute-if #:substitute-if-not + #:some #:every #:notany #:notevery + ;; Other exported symbols + #:wb-bag-pairs #:$ #:% #:? + ;; Internal, for testing + #:erapmoc) + ;; These are shadowed `fset:' symbols, with different definitions in `fset2:'. + (:shadow ;; Names shadowed from `fset:' to implement FSet2 semantics + #:set #:map #:wb-map #:wb-custom-map #:ch-map #:ch-custom-map #:seq #:wb-seq + #:replay-map #:wb-replay-map #:wb-custom-replay-map #:ch-replay-map #:ch-custom-replay-map + #:empty-set #:empty-map #:empty-wb-map #:empty-ch-map #:empty-seq #:empty-wb-seq + #:rank #:define-tuple-key #:get-tuple-key #:map-to-sets #:concat + ;; These just changed from `&optional' to `&key' + #:empty-wb-set #:empty-ch-set #:empty-wb-bag #:empty-wb-replay-set #:empty-ch-replay-set + #:empty-replay-map #:empty-wb-replay-map #:empty-ch-replay-map + #:empty-wb-2-relation #:empty-ch-2-relation + #:empty-list-relation #:empty-wb-list-relation #:empty-ch-list-relation + ;; Map and seq operations that handle defaults differently + #:lookup #:map-union #:map-intersection #:map-difference-2 #:compose + ;; Functions that call `lookup', transitively + #:internal-lookup #:@ #:image #:filter #:partition) (:export #:collection #:set #:bag #:map #:seq #:tuple #:collection? #:set? #:bag? #:map? #:seq? #:tuple? #:wb-set #:wb-bag #:wb-map #:wb-seq #:dyn-tuple @@ -160,20 +172,18 @@ #:wb-custom-set #:wb-custom-bag #:wb-custom-map #:ch-custom-set #:ch-custom-map #:wb-custom-replay-set #:wb-custom-replay-map #:ch-custom-replay-set #:ch-custom-replay-map - ;; `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 #:compare-slots-no-unequal #:eql-compare + #:equal? #:compare #:compare-slots #:compare-slots-no-unequal #:hash-slots #:eql-compare #:define-equality-slots #:define-comparison-slots #:define-hash-function #:unwrap-equivalent-node ; custom comparison functions may have to call this #:hash-value #:hash-value-fixnum #:zero #:hash-mix #:hash-mixf #:hash-multiply - #:identity-equality-mixin #:identity-ordering-mixin + #:identity-equality-mixin #:define-cross-type-compare-methods - #:compare-lexicographically + #:compare-lexicographically #:compare-lists-lexicographically #:compare-strings-lexicographically + #:compare-vectors-lexicographically #:compare-seqs-lexicographically #:empty? #:nonempty? #:size #:set-size #:arb #:contains? #:domain-contains? #:range-contains? #:member? #:multiplicity - #:empty-set #:empty-bag #:empty-map #:empty-seq #:empty-tuple + #:empty-set #:empty-set-like #:empty-bag #:empty-bag-like #:empty-map #:empty-map-like + #:empty-seq #:empty-tuple #:empty-wb-set #:empty-wb-bag #:empty-wb-map #:empty-wb-seq #:empty-dyn-tuple #:empty-ch-set #:empty-ch-map #:empty-replay-set #:empty-wb-replay-set #:empty-replay-map #:empty-wb-replay-map @@ -181,16 +191,21 @@ #:least #:greatest #:lookup #:rank #:at-rank #:index #:at-index #:@ #:with #:less #:split-from #:split-above #:split-through #:split-below #:union #:bag-sum #:intersection #:bag-product #:complement - #:set-difference #:set-difference-2 #:bag-difference #:bag-pairs + #:set-difference #:set-difference-2 #:bag-difference #:bag-pairs #:wb-bag-pairs #:subset? #:proper-subset #:disjoint? #:subbag? #:proper-subbag? #:filter #:filter-pairs #:partition - #:image #:reduce #:domain #:range #:with-default #:update + #:image #:reduce #:domain #:range #:update + #:with-default #:without-default #:default + #:lookup-error #:map-domain-error #:map-domain-error-map #:map-domain-error-key + #:seq-bounds-error #:seq-bounds-error-seq #:seq-bounds-error-index + #:tuple-key-unbound-error #:tuple-key-unbound-error-tuple #:tuple-key-unbound-error-key + #:empty-seq-error #:empty-seq-error-seq #:map-union #:map-intersection #:map-difference-2 - #:restrict #:restrict-not #:compose #:map-default + #:restrict #:restrict-not #:compose #:first #:last #:lastcons #:head #:tail #:with-first #:less-first #:push-first #:pop-first - #:with-last #:less-last #:push-last #:pop-last #:appendf #:prependf #:insertf + #:with-last #:less-last #:push-last #:pop-last #:appendf #:prependf #:insertf #:splicef #:insert #:splice #:subseq #:concat #:reverse #:sort #:stable-sort #:sort-and-group #:find #:find-if #:find-if-not #:count #:count-if #:count-if-not @@ -202,7 +217,7 @@ #:do-set #:do-bag #:do-bag-pairs #:do-map #:do-map-domain #:do-seq #:do-tuple #:adjoinf #:removef #:includef #:excludef #:unionf #:intersectf #:set-differencef #:map-unionf #:map-intersectf #:imagef #:composef - #:define-tuple-key #:def-tuple-key #:get-tuple-key #:tuple-key-name #:tuple-key? + #:define-tuple-key #:get-tuple-key #:tuple-key-name #:tuple-key? #:tuple-merge #:fset-setup-readtable #:*fset-readtable* #:fset-setup-rereading-readtable #:*fset-rereading-readtable* @@ -220,7 +235,8 @@ #:full-set ;; Relations #:relation #:relation? #:2-relation #:2-relation? #:wb-2-relation #:wb-2-relation? - #:empty-2-relation #:empty-wb-2-relation #:empty-chb-2-relation #:do-2-relation + #:wb-custom-2-relation #:ch-2-relation #:ch-2-relation? #:ch-custom-2-relation + #:empty-2-relation #:empty-wb-2-relation #:empty-ch-2-relation #:do-2-relation #:lookup-inv #:inverse #:join #:conflicts #:map-to-sets #:list-relation #:list-relation? #:wb-list-relation #:wb-list-relation? #:empty-list-relation #:empty-wb-list-relation #:empty-ch-list-relation #:do-list-relation @@ -236,6 +252,11 @@ ;;; Since we've shadowed `cl:count', we need to do this. (gmap:def-result-type-synonym fset2:count cl:count) +#+sbcl +(progn + (sb-ext:add-implementation-package ':fset2 ':fset) + (sb-ext:add-implementation-package ':fset ':fset2)) + ;;; A convenient package for experimenting with FSet. Also serves as an example ;;; of how one might create a package for code to be written using FSet. Note, @@ -262,8 +283,27 @@ #:substitute #:substitute-if #:substitute-if-not #:some #:every #:notany #:notevery)) +(defpackage :fset2-user + (:use :cl :fset2 :gmap :new-let :lexical-contexts) + (:shadowing-import-from :new-let #:let #:cond) + (:shadowing-import-from :fset2 + ;; Shadowed type/constructor names + #:set #:map + ;; Shadowed set operations + #: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 + #:remove #:remove-if #:remove-if-not + #:substitute #:substitute-if #:substitute-if-not + #:some #:every #:notany #:notevery)) + (pushnew ':FSet *features*) +(pushnew ':FSet2 *features*) ;;; 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 diff --git a/Code/fset.lisp b/Code/fset.lisp index bdf8e4ff0a38369e937b746eb39c217cc13e26ad..28433b45dc7c4704af4c8b625301e1beaf3bd836 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -119,11 +119,35 @@ (defgeneric lookup (collection key) (:documentation - "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 -as two values, else false and `nil'; this is useful for canonicalization.")) + "If `collection' is a map, returns three values: if it contains a key equal +to `key', the corresponding value, true, and the key found; otherwise, the map's +default, false, and `nil'. + +If `collection' is a seq, takes `key' as an index and returns two values: if +the index is in bounds, the corresponding element and true; otherwise, the +seq's default and false. + +If `collection' is a set or 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 fset2:lookup (collection key) + (:documentation + "If `collection' is a map, returns three values: if it contains a key equal +to `key', the corresponding value, true, and the key found; otherwise, the map's +default, false, and `nil'. If there's no mapping for `key' and the map has no +default, signals an error of type `map-domain-error'. + +If `collection' is a seq, takes `key' as an index and returns two values: if +the index is in bounds, the corresponding element and true; otherwise, the +seq's default and false. If the index is out of bounds and the seq has no +default, signals an error of type `seq-bounds-error'. + +If `collection' is a set that contains a member equal to `key', returns true +and the member as two values, else false and `nil'; this is useful for +canonicalization. + +If `collection' is a bag that contains a member equal to `key', returns its +multiplicity and the member as two values, else zero and `nil'.")) (defgeneric rank (collection value) (:documentation @@ -140,6 +164,20 @@ 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 fset2:rank (collection value) + (:documentation + "Defined on tree \(WB\) collections only. See `index'. + +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 that `value' would have if it were added. 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 @@ -285,7 +323,7 @@ member of `sub', `super' contains the same value with at least the same multiplicity.")) -(defgeneric filter (fn collection) +(define-generics (filter fset2:filter) (fn collection) (:documentation "Returns a new collection containing those members or pairs of `collection' for which `fn' returns true. If `collection' is a set, bag, or seq, `fn' is @@ -294,7 +332,7 @@ 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).")) -(defmethod filter (fn (s sequence)) +(define-methods (filter fset2:filter) (fn (s sequence)) (cl:remove-if-not fn s)) (defgeneric partition (pred collection) @@ -326,6 +364,24 @@ (defmethod filter-pairs (fn (collection t)) bag methods take keyword argument `:compare-fn-name', and the map method takes `:key-compare-fn-name' and `:val-compare-fn-name'. +If `collection' is a map or seq, the default of the result is the same. + +As well 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 fset2:image (fn collection &key) + (:documentation + "Returns a new collection containing the result of applying `fn' to each +member of `collection', which may be a set, bag, map, or seq. In the bag case, +the multiplicity of each member of the result is the sum of the multiplicities +of the values that `fn' maps to it. In the map case, `fn' is expected to return +two values, which become the new domain and range values. Except in the seq +case, you may wish to specify the organization of the result, so the set and +bag methods take keyword argument `:compare-fn-name', and the map method takes +`:key-compare-fn-name' and `:val-compare-fn-name'. + +If `collection' is a map or seq, the result has a default as specified by +the `:default' or `:no-default?' keyword arguments, if given, or else `nil'. + As well 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).")) @@ -354,14 +410,21 @@ (defmethod reduce (fn (s sequence) &rest keyword-args (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.")) + "Returns two values. If the map or seq has a default \(the value returned +by `lookup' when the supplied key or index is not in the domain\), returns the +default and a true second value; otherwise, the second value is false.")) (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 fset2:without-default (collection) + (:documentation + "Returns a new map, replay map, or seq with the same contents as `collection' +but with no default. Subsequent `lookup' operations on a key not in the map, +or a index outside the seq's bounds, will signal an error.")) + ;;; Prior to 1.4.0, this unconditionally called `val-fn' on the defaults of the ;;; two maps to produce the defaults of the result. This was a PITA in the ;;; common case in which the defaults were null. Now, it calls `val-fn' only @@ -382,6 +445,24 @@ (defmethod reduce (fn (s sequence) &rest keyword-args New feature: if `val-fn' returns `:no-value' as a second value, the result will contain no pair with the corresponding key.")) +(defgeneric fset2: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 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: if both maps +have defaults, the result of calling `val-fn' on those defaults; if only one +map has a default, that default; otherwise none. + +`map-union' assumes that `val-fn' is idempotent, i.e., if the two values +passed to `val-fn' are equal, `val-fn' must return the same value; it may +elide calls to `val-fn' on that basis. + +If `val-fn' returns `:no-value' as a second value, the result will contain +no pair with the corresponding key.")) + ;;; Prior to 1.4.0, this unconditionally called `val-fn' on the defaults of the ;;; two maps to produce the defaults of the result. This was a PITA in the ;;; common case in which the defaults were null. Now, it calls `val-fn' only @@ -401,11 +482,37 @@ (defmethod reduce (fn (s sequence) &rest keyword-args New feature: if `val-fn' returns `:no-value' as a second value, the result will contain no pair with the corresponding key.")) +(defgeneric fset2: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 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, if they both have +defaults; else none. + +`map-intersection' assumes that `val-fn' is idempotent, i.e., if the two +values passed to `val-fn' are equal, `val-fn' must return the same value; +it may elide calls to `val-fn' on that basis. + +If `val-fn' returns `:no-value' as a second value, the result will contain +no pair with the corresponding key.")) + (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 fset2:map-difference-2 (map1 map2) + (:documentation + "Returns, as two values: a map containing all the pairs that are in `map1' +but not `map2', and one containing all the pairs that are in `map2' but not +`map1'. + +The default for each returned map is that of its corresponding argument, if +it has a default, except if the defaults are equal, in which case neither +returned map has a default.")) ;;; Possible operation: `map-update' (better name??), which would be like ;;; `map-union' except the keys would be exactly the keys of `map1'. This @@ -441,6 +548,14 @@ (defmethod reduce (fn (s sequence) &rest keyword-args of that domain to the result of applying first `map1' to it, then applying `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 fset2:compose (map1 map2-or-fn &key) + (: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' can also be a sequence, which is +treated as a map from indices to members. If `map1' has a default, the value +of `map2-or-fn' applied to that default becomes the default of the returned +map.")) (defgeneric first (seq) (:documentation @@ -487,22 +602,24 @@ (defmethod last ((s sequence)) (defgeneric insert (seq idx val) (:documentation - "Returns a new sequence like `seq' but with `val' inserted at `idx' (the 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).")) +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).")) +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 &rest seqs) (:documentation - "Returns the concatenation of `seq1' with each of `seqs'.")) - + "Returns the concatenation of `seq1' with each of `seqs'. The result has the +same default as `seq1'.")) +(defgeneric fset2:concat (seq1 &rest seqs) + (:documentation + "Returns the concatenation of `seq1' with each of `seqs'. The result has the +same default as `seq1'.")) ;;; 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 @@ -513,7 +630,7 @@ (defmethod last ((s sequence)) have additional keyword parameters to further specify the kind of conversion. \(`sequence' here refers to a CL sequence -- either a list or a vector, unless the implementation has more sequence subtypes. FSet's `seq' is not a subtype of -`sequence'.) +`sequence'.\) When `to-type' is one of the abstract types -- `set', `bag', `map' etc. -- the only guarantee is that `convert' will return an instance of the requested type. @@ -615,7 +732,7 @@ (defmethod last ((s sequence)) 2-relation seq 1, 6 wb-2-relation seq 6 map wb-2-relation 1, 11 - wb-map wb-2-relation 1, 11 + wb-map wb-2-relation 11 map-to-sets wb-2-relation 12 tuple tuple 0 @@ -703,16 +820,10 @@ (defmethod last ((s sequence)) functions, respectively, to be used. The returned map will be converted, if necessary, to use the specified functions, or to use `compare' for those not specified. -17. The default of the result is the same as that of the argument. +17. The default of the result is `nil' (in FSet 1) or the same as that of the + argument (in FSet 2). 18. Constructs the ch (CHAMP tree) implementation of its type (`ch-set' etc.).")) -;;; The `&allow-other-keys' is to persuade SBCL not to issue warnings about keywords -;;; that are accepted by some methods of `convert'. This differs from the behavior -;;; we would get by specifying `&allow-other-keys' in the `defgeneric' parameter list; -;;; this way, we still get runtime errors on unexpected keywords (which I guess is an -;;; SBCL extension, since CLHS 7.6.4 says we shouldn't). -(declaim (ftype (function (t t &key &allow-other-keys) t) convert)) - ;;; ================================================================================ ;;; Iterators @@ -1281,25 +1392,25 @@ (defmethod contains? ((ls list) x &optional (y nil y?)) (check-two-arguments y? 'contains 'list) (member x ls :test #'equal?)) -(defmethod concat ((a list) &rest seqs) +(define-methods (concat fset2:concat) ((a list) &rest seqs) (append a (reduce #'append seqs :key (fn (x) (convert 'list x)) :from-end t))) (defmethod convert ((to-type (eql 'list)) (ls list) &key) ls) -(defmethod filter ((pred symbol) (ls list)) +(define-methods (filter fset2:filter) ((pred symbol) (ls list)) (remove-if-not (coerce pred 'function) ls)) -(defmethod filter ((pred function) (ls list)) +(define-methods (filter fset2:filter) ((pred function) (ls list)) (remove-if-not pred ls)) (defmethod convert ((to-type (eql 'vector)) (v vector) &key) v) -(defmethod partition ((pred symbol) (ls list)) +(define-methods (partition fset2:partition) ((pred symbol) (ls list)) (list-partition (coerce-to-function pred) ls)) -(defmethod partition ((pred function) (ls list)) +(define-methods (partition fset2:partition) ((pred function) (ls list)) (list-partition pred ls)) (defun list-partition (pred ls) @@ -1313,29 +1424,37 @@ (defmethod partition ((pred function) (ls list)) (push x res2))) (values (nreverse res1) (nreverse res2)))) -(defmethod image ((fn function) (l list) &key) +(define-methods (image fset2:image) ((fn function) (l list) &key) (mapcar fn l)) -(defmethod image ((fn symbol) (l list) &key) +(define-methods (image fset2:image) ((fn symbol) (l list) &key) (mapcar (coerce fn 'function) l)) (defmethod image ((fn map) (l list) &key) (mapcar (lambda (x) (lookup fn x)) l)) +(defmethod fset2:image ((fn map) (l list) &key) + (mapcar (lambda (x) (fset2:lookup fn x)) l)) (defmethod image ((fn set) (l list) &key) (mapcar (lambda (x) (lookup fn x)) l)) +(defmethod fset2:image ((fn set) (l list) &key) + (mapcar (lambda (x) (fset2:lookup fn x)) l)) -(defmethod image ((fn function) (l vector) &key) +(define-methods (image fset2:image) ((fn function) (l vector) &key) (cl:map 'vector fn l)) -(defmethod image ((fn symbol) (l vector) &key) +(define-methods (image fset2:image) ((fn symbol) (l vector) &key) (cl:map 'vector (coerce fn 'function) l)) (defmethod image ((fn map) (l vector) &key) (cl:map 'vector (lambda (x) (lookup fn x)) l)) +(defmethod fset2:image ((fn map) (l vector) &key) + (cl:map 'vector (lambda (x) (fset2:lookup fn x)) l)) (defmethod image ((fn set) (l vector) &key) (cl:map 'vector (lambda (x) (lookup fn x)) l)) +(defmethod fset2:image ((fn set) (l vector) &key) + (cl:map 'vector (lambda (x) (fset2:lookup fn x)) l)) ;;; ---------------- @@ -1346,9 +1465,9 @@ (defmethod image ((fn set) (l vector) &key) ;;; your list is longer than three or maybe four, you should probably use a dynamic tuple; ;;; see `tuples.lisp'. -(defmethod lookup ((ls list) (key (eql 'first))) +(define-methods (lookup fset2:lookup) ((ls list) (key (eql 'first))) (cl:first ls)) -(defmethod lookup ((ls list) (key (eql 'cl:first))) ; in case they don't shadowing-import `fset:first' +(define-methods (lookup fset2:lookup) ((ls list) (key (eql 'cl:first))) ; in case of no shadowing-import of `fset:first' (cl:first ls)) (defmethod with ((ls list) (key (eql 'first)) &optional (val nil val?)) @@ -1358,56 +1477,56 @@ (defmethod with ((ls list) (key (eql 'cl:first)) &optional (val nil val?)) (check-three-arguments val? 'with 'list) (cons val (cdr ls))) -(defmethod lookup ((ls list) (key (eql 'second))) +(define-methods (lookup fset2:lookup) ((ls list) (key (eql 'second))) (second ls)) (defmethod with ((ls list) (key (eql 'second)) &optional (val nil val?)) (check-three-arguments val? 'with 'list) (list* (cl:first ls) val (cddr ls))) -(defmethod lookup ((ls list) (key (eql 'third))) +(define-methods (lookup fset2:lookup) ((ls list) (key (eql 'third))) (third ls)) (defmethod with ((ls list) (key (eql 'third)) &optional (val nil val?)) (check-three-arguments val? 'with 'list) (list* (cl:first ls) (second ls) val (cdddr ls))) -(defmethod lookup ((ls list) (key (eql 'fourth))) +(define-methods (lookup fset2:lookup) ((ls list) (key (eql 'fourth))) (fourth ls)) (defmethod with ((ls list) (key (eql 'fourth)) &optional (val nil val?)) (check-three-arguments val? 'with 'list) (list* (cl:first ls) (second ls) (third ls) val (cddddr ls))) -(defmethod lookup ((ls list) (key (eql 'fifth))) +(define-methods (lookup fset2:lookup) ((ls list) (key (eql 'fifth))) (fifth ls)) (defmethod with ((ls list) (key (eql 'fifth)) &optional (val nil val?)) (check-three-arguments val? 'with 'list) (list* (cl:first ls) (second ls) (third ls) (fourth ls) val (cdr (cddddr ls)))) -(defmethod lookup ((ls list) (key (eql 'sixth))) +(define-methods (lookup fset2:lookup) ((ls list) (key (eql 'sixth))) (sixth ls)) (defmethod with ((ls list) (key (eql 'sixth)) &optional (val nil val?)) (check-three-arguments val? 'with 'list) (list* (cl:first ls) (second ls) (third ls) (fourth ls) (fifth ls) val (cddr (cddddr ls)))) -(defmethod lookup ((ls list) (key (eql 'seventh))) +(define-methods (lookup fset2:lookup) ((ls list) (key (eql 'seventh))) (seventh ls)) (defmethod with ((ls list) (key (eql 'seventh)) &optional (val nil val?)) (check-three-arguments val? 'with 'list) (list* (cl:first ls) (second ls) (third ls) (fourth ls) (fifth ls) (sixth ls) val (cdddr (cddddr ls)))) -(defmethod lookup ((ls list) (key (eql 'eighth))) +(define-methods (lookup fset2:lookup) ((ls list) (key (eql 'eighth))) (eighth ls)) (defmethod with ((ls list) (key (eql 'eighth)) &optional (val nil val?)) (check-three-arguments val? 'with 'list) (list* (cl:first ls) (second ls) (third ls) (fourth ls) (fifth ls) (sixth ls) (seventh ls) val (cddddr (cddddr ls)))) -(defmethod lookup ((ls list) (key (eql 'ninth))) +(define-methods (lookup fset2:lookup) ((ls list) (key (eql 'ninth))) (ninth ls)) (defmethod with ((ls list) (key (eql 'ninth)) &optional (val nil val?)) @@ -1415,7 +1534,7 @@ (defmethod with ((ls list) (key (eql 'ninth)) &optional (val nil val?)) (list* (cl:first ls) (second ls) (third ls) (fourth ls) (fifth ls) (sixth ls) (seventh ls) (eighth ls) val (cdr (cddddr (cddddr ls))))) -(defmethod lookup ((ls list) (key (eql 'tenth))) +(define-methods (lookup fset2:lookup) ((ls list) (key (eql 'tenth))) (tenth ls)) (defmethod with ((ls list) (key (eql 'tenth)) &optional (val nil val?)) @@ -1428,6 +1547,7 @@ (defmethod with ((ls list) (key (eql 'tenth)) &optional (val nil val?)) ;;; Functional deep update (defun update (fn coll &rest keys) + (declare (dynamic-extent fn)) "Returns a new version of `coll' in which the element reached by doing chained `lookup's on `keys' is updated by `fn'. An example will help a lot here: instead of writing @@ -1441,12 +1561,15 @@ (defmethod with ((ls list) (key (eql 'tenth)) &optional (val nil val?)) This is perhaps most useful in contexts where you don't want to do the `setq' anyway. `fn' can be a function object, an fbound symbol, or a map." (labels ((rec (fn coll keys) - (if (null keys) (@ (if (symbolp fn) (coerce fn 'function) fn) coll) + (if (null keys) (@ fn coll) (with coll (car keys) (rec fn (lookup coll (car keys)) (cdr keys)))))) - (rec fn coll keys))) + (rec (if (symbolp fn) (coerce fn 'function) fn) coll keys))) ;;; If the `fn' is nontrivial, binds a variable to it with a `dynamic-extent' declaration. ;;; (Really, should do this for `image', `filter', etc. etc.) +;;; -- Actually, I'm not sure SBCL needs this. It might be enough to add the declaration to +;;; the `defun' (as I've now done). Also, it makes a bigger difference here than for `image' +;;; etc., because `fn' is called only once. (define-compiler-macro update (&whole form fn coll &rest keys) (if (not (or (symbolp fn) (and (listp fn) @@ -1479,7 +1602,9 @@ (defstruct (tree-set-org (compare-fn-name nil :type symbol :read-only t) (compare-fn nil :type function :read-only t)) -(deflex +fset-default-tree-set-org+ (make-tree-set-org 'compare #'compare)) +;;; I wanted to use `defconstant' for these, but the compiler tries to evaluate them at +;;; compile time, and `make-tree-set-org' doesn't yet exist. +(defparameter +fset-default-tree-set-org+ (make-tree-set-org 'compare #'compare)) (declaim (inline make-wb-set make-wb-custom-set)) @@ -1544,24 +1669,28 @@ (defstruct (wb-custom-set (make-wb-default-set contents) (make-wb-custom-set contents org))) -(defparameter *empty-wb-set* (make-wb-set nil)) +(defparameter +empty-wb-set+ (make-wb-set nil)) (declaim (inline empty-set)) (defun empty-set () "Returns an empty set of the default implementation." - *empty-wb-set*) + +empty-wb-set+) +;;; `fset2:empty-set' is below -;; For the constructor macros. -(defmethod empty-instance-function ((class-name (eql 'set))) - 'empty-set) - -(declaim (inline empty-wb-set)) +(declaim (inline empty-wb-set fset2:empty-wb-set)) (defun empty-wb-set (&optional compare-fn-name) "Returns an empty wb-set. By default, it will be ordered by `fset:compare'; to use a custom ordering, supply the comparison function name (a symbol) as `compare-fn-name'." (if (null compare-fn-name) - *empty-wb-set* + +empty-wb-set+ + (empty-wb-custom-set compare-fn-name))) +(defun fset2:empty-wb-set (&key compare-fn-name) + "Returns an empty wb-set. By default, it will be ordered by `fset:compare'; +to use a custom ordering, supply the comparison function name (a symbol) as +`compare-fn-name'." + (if (null compare-fn-name) + +empty-wb-set+ (empty-wb-custom-set compare-fn-name))) ;;; We cache the last empty `wb-custom-set' instance with a given org, so as to reuse them @@ -1577,7 +1706,7 @@ (defmethod empty-instance-function ((class-name (eql 'set))) (assert (and compare-fn-name (symbolp compare-fn-name) (symbol-package compare-fn-name)) () "compare-fn-name must be a nonnull interned symbol") (if (eq compare-fn-name 'compare) - *empty-wb-set* + +empty-wb-set+ (let ((prev-instance (gethash compare-fn-name +empty-wb-custom-set-cache+)) (compare-fn (symbol-function compare-fn-name))) (if (and prev-instance @@ -1586,13 +1715,10 @@ (defmethod empty-instance-function ((class-name (eql 'set))) (setf (gethash compare-fn-name +empty-wb-custom-set-cache+) (make-wb-custom-set nil (make-tree-set-org compare-fn-name compare-fn))))))) -(defmethod empty-instance-function ((class-name (eql 'wb-set))) - `empty-wb-set) - (defgeneric empty-set-like (s) (:documentation "Returns an empty set of the same implementation, and using the same compare -or hash function, as `s'.")) +or hash function, as `s'. `s' can also be a bag.")) (defmethod empty-set-like ((s wb-default-set)) (empty-set)) @@ -1612,6 +1738,21 @@ (defmethod compare-fn-name ((s wb-default-set)) (defmethod compare-fn-name ((s wb-custom-set)) (tree-set-org-compare-fn-name (wb-custom-set-org s))) +(defgeneric compare-sets (a b elt-compare-fn) + (:documentation + "Compares two sets `a' and `b', using `elt-compare-fn' to compare their +elements. Returns one of the standard FSet comparison result symbols, `:equal', +`:less', `:greater', or `:unequal'.")) + +;;; Help users out since the default default is still `nil'. +(defmethod compare-sets ((a null) (b null) elt-compare-fn) + (declare (ignore elt-compare-fn)) + ':equal) + +(defmethod compare-sets ((a wb-set) (b wb-set) elt-compare-fn) + (declare (type function elt-compare-fn)) + (WB-Set-Tree-Compare (wb-set-contents a) (wb-set-contents b) elt-compare-fn)) + (define-wb-set-method empty? ((s wb-set)) (null (contents s))) @@ -1632,12 +1773,15 @@ (define-wb-set-method contains? ((s wb-set) x &optional (y nil y?)) (WB-Set-Tree-Contains? (contents s) x (compare-fn s))) ;;; Note, first value is `t' or `nil'. -(define-wb-set-method lookup ((s wb-set) key) +(define-wb-set-methods (lookup fset2:lookup) ((s wb-set) key) (WB-Set-Tree-Find-Equal (contents s) key (compare-fn s))) (define-wb-set-method rank ((s wb-set) x) (let ((found? rank (WB-Set-Tree-Rank (contents s) x (compare-fn s)))) (values (if found? rank (1- rank)) found?))) +(define-wb-set-method fset2:rank ((s wb-set) x) + (let ((found? rank (WB-Set-Tree-Rank (contents s) x (compare-fn s)))) + (values rank found?))) (define-wb-set-method at-rank ((s wb-set) rank) (let ((contents (contents s)) @@ -1716,8 +1860,8 @@ (define-wb-set-method union ((s1 wb-set) (s2 wb-set) &key) (defmethod intersection ((s1 set) (s2 set) &key) "Fallback method for mixed implementations." (let ((result (empty-set-like s1))) - (do-set (x s2) - (when (contains? s1 x) + (do-set (x s1) + (when (contains? s2 x) (includef result x))) result)) @@ -1800,23 +1944,26 @@ (define-wb-set-method disjoint? ((s1 wb-set) (s2 wb-set)) (WB-Set-Tree-Disjoint? (contents s1) (contents s2) (compare-fn s1)) (call-next-method))) +(defmethod compare ((s1 wb-set) (s2 wb-set)) + ;; Just as comparing sets of different classes just compares the classes, so comparing WB-sets + ;; with different compare-fns just compares the compare-fns. + (let ((name-comp (compare (wb-set-compare-fn-name s1) (wb-set-compare-fn-name s2)))) + (ecase name-comp + ((:less :greater) + name-comp) + (:equal + ;; Hoo boy. The compare-fn has been redefined since one of the sets was created. + ;; Update them and try again. + (compare (convert 'wb-set s1 :compare-fn-name (wb-set-compare-fn-name s1)) + (convert 'wb-set s2 :compare-fn-name (wb-set-compare-fn-name s1)))) + (:unequal + ;; Shouldn't be possible, since we check the symbol-package in `empty-wb-custom-set'. + (error "Can't compare wb-sets with uninterned compare-fn-names with same symbol-name"))))) + (define-wb-set-method compare ((s1 wb-set) (s2 wb-set)) (if-same-compare-fns (s1 s2) (WB-Set-Tree-Compare (contents s1) (contents s2) (compare-fn s1)) - ;; Just as comparing sets of different classes just compares the classes, so comparing WB-sets - ;; with different compare-fns just compares the compare-fns. - (let ((name-comp (compare (wb-set-compare-fn-name s1) (wb-set-compare-fn-name s2)))) - (ecase name-comp - ((:less :greater) - name-comp) - (:equal - ;; Hoo boy. The compare-fn has been redefined since one of the sets was created. - ;; Update them and try again. - (compare (convert 'wb-set s1 :compare-fn-name (wb-set-compare-fn-name s1)) - (convert 'wb-set s2 :compare-fn-name (wb-set-compare-fn-name s1)))) - (:unequal - ;; Shouldn't be possible, since we check the symbol-package in `empty-wb-custom-set'. - (error "Can't compare wb-sets with uninterned compare-fn-names with same symbol-name")))))) + (call-next-method))) (define-wb-set-method hash-value ((s wb-set)) ;; I expect this to be rarely used, so I don't want to make everybody pay the cost of a @@ -1853,14 +2000,16 @@ (define-wb-set-method fun-iterator ((s wb-set) &key from-end?) (WB-Set-Tree-Rev-Fun-Iter (contents s)) (WB-Set-Tree-Fun-Iter (contents s)))) -(define-wb-set-method filter ((pred function) (s wb-set)) +(define-wb-set-methods (filter fset2:filter) ((pred function) (s wb-set)) (make s (wb-set-filter pred (contents s) (compare-fn s)))) -(define-wb-set-method filter ((pred symbol) (s wb-set)) +(define-wb-set-methods (filter fset2:filter) ((pred symbol) (s wb-set)) (make s (wb-set-filter (coerce-to-function pred) (contents s) (compare-fn s)))) (define-wb-set-method filter ((pred map) (s wb-set)) (make s (wb-set-filter #'(lambda (x) (lookup pred x)) (contents s) (compare-fn s)))) +(define-wb-set-method fset2:filter ((pred map) (s wb-set)) + (make s (wb-set-filter #'(lambda (x) (fset2:lookup pred x)) (contents s) (compare-fn s)))) (defun wb-set-filter (pred contents compare-fn) (declare (optimize (speed 3) (safety 0)) @@ -1872,24 +2021,27 @@ (define-wb-set-method filter ((pred map) (s wb-set)) result)) ;;; A set is another kind of boolean-valued map. -(defmethod filter ((pred set) (s set)) +(define-methods (filter fset2:filter) ((pred set) (s set)) (intersection pred s)) ;;; A bag is yet another kind of boolean-valued map. -(defmethod filter ((pred bag) (s set)) +(define-methods (filter fset2:filter) ((pred bag) (s set)) (intersection pred s)) -(define-wb-set-method partition ((pred function) (s wb-set)) +(define-wb-set-methods (partition fset2:partition) ((pred function) (s wb-set)) (let ((res1 res2 (wb-set-partition pred (contents s) (compare-fn s)))) (values (make s res1) (make s res2)))) -(define-wb-set-method partition ((pred symbol) (s wb-set)) +(define-wb-set-methods (partition fset2:partition) ((pred symbol) (s wb-set)) (let ((res1 res2 (wb-set-partition (coerce-to-function pred) (contents s) (compare-fn s)))) (values (make s res1) (make s res2)))) (define-wb-set-method partition ((pred map) (s wb-set)) (let ((res1 res2 (wb-set-partition #'(lambda (x) (lookup pred x)) (contents s) (compare-fn s)))) (values (make s res1) (make s res2)))) +(define-wb-set-method fset2:partition ((pred map) (s wb-set)) + (let ((res1 res2 (wb-set-partition #'(lambda (x) (fset2:lookup pred x)) (contents s) (compare-fn s)))) + (values (make s res1) (make s res2)))) (defun wb-set-partition (pred contents compare-fn) (declare (optimize (speed 3) (safety 0)) @@ -1902,27 +2054,30 @@ (define-wb-set-method partition ((pred map) (s wb-set)) (setq result-2 (WB-Set-Tree-With result-2 x compare-fn)))) (values result-1 result-2))) -(define-wb-set-method image ((fn function) (s wb-set) &key compare-fn-name) +(define-wb-set-methods (image fset2:image) ((fn function) (s wb-set) &key compare-fn-name) (wb-set-image fn (contents s) (or compare-fn-name (compare-fn-name s)))) -(define-wb-set-method image ((fn symbol) (s wb-set) &key compare-fn-name) +(define-wb-set-methods (image fset2:image) ((fn symbol) (s wb-set) &key compare-fn-name) (wb-set-image (coerce-to-function fn) (contents s) (or compare-fn-name (compare-fn-name s)))) (define-wb-set-method image ((fn map) (s wb-set) &key compare-fn-name) - (wb-set-image fn (contents s) (or compare-fn-name (compare-fn-name s)))) + (wb-set-image (fn (x) (lookup fn x)) (contents s) (or compare-fn-name (compare-fn-name s)))) +(define-wb-set-method fset2:image ((fn map) (s wb-set) &key compare-fn-name) + (wb-set-image (fn (x) (fset2:lookup fn x)) (contents s) (or compare-fn-name (compare-fn-name s)))) -(define-wb-set-method image ((fn set) (s wb-set) &key compare-fn-name) - (wb-set-image fn (contents s) (or compare-fn-name (compare-fn-name s)))) +(define-wb-set-methods (image fset2:image) ((fn set) (s wb-set) &key compare-fn-name) + (wb-set-image (fn (x) (lookup fn x)) (contents s) (or compare-fn-name (compare-fn-name s)))) -(define-wb-set-method image ((fn bag) (s wb-set) &key compare-fn-name) - (wb-set-image fn (contents s) (or compare-fn-name (compare-fn-name s)))) +(define-wb-set-methods (image fset2:image) ((fn bag) (s wb-set) &key compare-fn-name) + (wb-set-image (fn (x) (lookup fn x)) (contents s) (or compare-fn-name (compare-fn-name s)))) (defun wb-set-image (fn contents compare-fn-name) + (declare (type function fn)) (let ((org (wb-set-org (empty-wb-set compare-fn-name))) (result nil)) (do-wb-set-tree-members (x contents) - (setq result (WB-Set-Tree-With result (@ fn x) (tree-set-org-compare-fn org)))) + (setq result (WB-Set-Tree-With result (funcall fn x) (tree-set-org-compare-fn org)))) (make-wb-set result org))) (defmethod reduce ((fn function) (s set) &key key (initial-value nil init?)) @@ -1955,7 +2110,7 @@ (defmethod sort ((s set) pred &key key) (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) +(define-convert-methods (set fset2:set) ((s set) &key) s) (defmethod convert ((to-type (eql 'wb-set)) (s set) &key compare-fn-name) @@ -1989,6 +2144,8 @@ (defmethod convert ((to-type (eql 'vector)) (s set) &key) (defmethod convert ((to-type (eql 'set)) (l list) &key input-sorted?) (make-wb-set (wb-set-from-list l input-sorted? #'compare))) +(defmethod convert ((to-type (eql 'fset2:set)) (l list) &key) + (convert 'ch-set l)) (defmethod convert ((to-type (eql 'wb-set)) (l list) &key input-sorted? compare-fn-name) (convert-to-wb-set s nil @@ -2001,6 +2158,8 @@ (defmethod convert ((to-type (eql 'wb-set)) (l list) &key input-sorted? compare- (defmethod convert ((to-type (eql 'set)) (s seq) &key input-sorted?) (make-wb-set (wb-set-from-sequence s input-sorted? #'compare))) +(defmethod convert ((to-type (eql 'fset2:set)) (s seq) &key) + (convert 'ch-set s)) (defmethod convert ((to-type (eql 'wb-set)) (s seq) &key input-sorted? compare-fn-name) (convert-to-wb-set s nil @@ -2008,6 +2167,8 @@ (defmethod convert ((to-type (eql 'wb-set)) (s seq) &key input-sorted? compare-f (defmethod convert ((to-type (eql 'set)) (s sequence) &key input-sorted?) (make-wb-set (wb-set-from-sequence s input-sorted? #'compare))) +(defmethod convert ((to-type (eql 'fset2:set)) (s sequence) &key) + (convert 'ch-set s)) (defmethod convert ((to-type (eql 'wb-set)) (s sequence) &key input-sorted? compare-fn-name) (convert-to-wb-set s nil @@ -2020,17 +2181,17 @@ (defmethod convert ((to-type (eql 'wb-set)) (s sequence) &key input-sorted? comp (defmethod find (item (s set) &key key test) (declare (optimize (speed 3) (safety 0))) - (let ((test (coerce-to-function-or-equal? test))) + (let ((test default? (coerce-to-function-or-equal? test))) (if key (let ((key (coerce-to-function key))) (do-set (x s) (when (funcall test item (funcall key x)) (return x)))) - (if (not (eq test #'equal?)) - (do-set (x s) - (when (funcall test item x) - (return x))) - (nth-value 1 (lookup s item)))))) + (if (and default? (eq (compare-fn s) #'compare)) + (nth-value 1 (lookup s item)) + (do-set (x s) + (when (funcall test item x) + (return x))))))) (defmethod find-if (pred (s set) &key key) (declare (optimize (speed 3) (safety 0))) @@ -2059,8 +2220,8 @@ (defmethod count (item (s set) &key key test) (do-set (x s total) (when (funcall test item (funcall key x)) (incf total)))) - (if default? - (if (lookup s item) 1 0) + (if (and default? (eq (compare-fn s) #'compare)) + (if (contains? s item) 1 0) (let ((total 0)) (declare (fixnum total)) (do-set (x s total) @@ -2128,6 +2289,8 @@ (defstruct (hash-set-org (compare-fn nil :type function :read-only t) (hash-fn nil :type function :read-only t)) +(defparameter +fset-default-hash-set-org+ (make-hash-set-org 'compare #'compare #'hash-value)) + (declaim (inline make-ch-set)) (defstruct (ch-set @@ -2139,16 +2302,29 @@ (defstruct (ch-set (contents nil :read-only t) (org nil :type hash-set-org :read-only t)) -(defparameter *empty-ch-set* (make-ch-set nil (make-hash-set-org 'compare #'compare #'hash-value))) +(defparameter +empty-ch-set+ (make-ch-set nil +fset-default-hash-set-org+)) + +(declaim (inline fset2:empty-set)) +(defun fset2:empty-set () + "Returns an empty set of the default implementation." + +empty-ch-set+) -(declaim (inline empty-ch-set)) +(declaim (inline empty-ch-set fset2:empty-ch-set)) (defun empty-ch-set (&optional compare-fn-name) "Returns an empty ch-set. By default, it will use `fset:compare' to compare values, and `fset:hash-value' to hash them; to use a custom comparison and hash, use `define-hash-function' to associate them, and then supply the name of the comparison function as `compare-fn-name'." (if (null compare-fn-name) - *empty-ch-set* + +empty-ch-set+ + (empty-ch-custom-set compare-fn-name))) +(defun fset2:empty-ch-set (&key compare-fn-name) + "Returns an empty ch-set. By default, it will use `fset:compare' to compare +values, and `fset:hash-value' to hash them; to use a custom comparison and hash, +use `define-hash-function' to associate them, and then supply the name of the +comparison function as `compare-fn-name'." + (if (null compare-fn-name) + +empty-ch-set+ (empty-ch-custom-set compare-fn-name))) (deflex +empty-ch-custom-set-cache+ (make-hash-table :test 'eq)) @@ -2157,7 +2333,7 @@ (defstruct (ch-set (assert (and compare-fn-name (symbolp compare-fn-name) (symbol-package compare-fn-name)) () "compare-fn-name must be a nonnull interned symbol") (if (eq compare-fn-name 'compare) - *empty-ch-set* + +empty-ch-set+ (let ((prev-instance (gethash compare-fn-name +empty-ch-custom-set-cache+)) (compare-fn (symbol-function compare-fn-name)) (hash-fn-name (or (get compare-fn-name 'hash-function) @@ -2172,9 +2348,6 @@ (defstruct (ch-set (setf (gethash compare-fn-name +empty-ch-custom-set-cache+) (make-ch-set nil (make-hash-set-org compare-fn-name compare-fn hash-fn))))))) -(defmethod empty-instance-function ((class-name (eql 'ch-set))) - 'empty-ch-set) - (defmethod empty-set-like ((s ch-set)) (empty-ch-set (hash-set-org-compare-fn-name (ch-set-org s)))) @@ -2205,7 +2378,7 @@ (defmethod contains? ((s ch-set) x &optional (y nil y?)) (ch-set-tree-contains? (ch-set-contents s) x (hash-set-org-hash-fn hsorg) (hash-set-org-compare-fn hsorg)))) -(defmethod lookup ((s ch-set) key) +(define-methods (lookup fset2:lookup) ((s ch-set) key) (let ((hsorg (ch-set-org s))) (ch-set-tree-contains? (ch-set-contents s) key (hash-set-org-hash-fn hsorg) (hash-set-org-compare-fn hsorg)))) @@ -2271,7 +2444,7 @@ (defmethod set-difference ((s1 ch-set) (s2 ch-set) &key) (defmethod set-difference-rev ((s1 ch-set) (s2 ch-set)) (if-same-ch-set-orgs (s1 s2 hsorg) - (make-ch-set (ch-set-tree-diff (ch-set-contents s1) (ch-set-contents s2) + (make-ch-set (ch-set-tree-diff (ch-set-contents s2) (ch-set-contents s1) (hash-set-org-hash-fn hsorg) (hash-set-org-compare-fn hsorg)) hsorg) @@ -2297,12 +2470,12 @@ (defmethod disjoint? ((s1 ch-set) (s2 ch-set)) (hash-set-org-hash-fn hsorg) (hash-set-org-compare-fn hsorg)) (call-next-method))) -(defmethod partition ((pred function) (s ch-set)) +(define-methods (partition fset2:partition) ((pred function) (s ch-set)) (let ((hsorg (ch-set-org s)) ((res1 res2 (ch-set-partition pred (ch-set-contents s) hsorg)))) (values (make-ch-set res1 hsorg) (make-ch-set res2 hsorg)))) -(defmethod partition ((pred symbol) (s ch-set)) +(define-methods (partition fset2:partition) ((pred symbol) (s ch-set)) (let ((hsorg (ch-set-org s)) ((res1 res2 (ch-set-partition (coerce-to-function pred) (ch-set-contents s) hsorg)))) (values (make-ch-set res1 hsorg) (make-ch-set res2 hsorg)))) @@ -2311,6 +2484,10 @@ (defmethod partition ((pred map) (s ch-set)) (let ((hsorg (ch-set-org s)) ((res1 res2 (ch-set-partition #'(lambda (x) (lookup pred x)) (ch-set-contents s) hsorg)))) (values (make-ch-set res1 hsorg) (make-ch-set res2 hsorg)))) +(defmethod fset2:partition ((pred map) (s ch-set)) + (let ((hsorg (ch-set-org s)) + ((res1 res2 (ch-set-partition #'(lambda (x) (fset2:lookup pred x)) (ch-set-contents s) hsorg)))) + (values (make-ch-set res1 hsorg) (make-ch-set res2 hsorg)))) (defun ch-set-partition (pred contents hsorg) (declare (optimize (speed 3) (safety 0)) @@ -2325,14 +2502,16 @@ (defmethod partition ((pred map) (s ch-set)) (setq result-2 (ch-set-tree-with result-2 x hash-fn compare-fn)))) (values result-1 result-2))) -(defmethod filter ((pred function) (s ch-set)) +(define-methods (filter fset2:filter) ((pred function) (s ch-set)) (ch-set-filter pred s)) -(defmethod filter ((pred symbol) (s ch-set)) +(define-methods (filter fset2:filter) ((pred symbol) (s ch-set)) (ch-set-filter (coerce-to-function pred) s)) (defmethod filter ((pred map) (s ch-set)) (ch-set-filter #'(lambda (x) (lookup pred x)) s)) +(defmethod fset2:filter ((pred map) (s ch-set)) + (ch-set-filter #'(lambda (x) (fset2:lookup pred x)) s)) (defun ch-set-filter (pred s) (declare (optimize (speed 3) (safety 0)) @@ -2345,26 +2524,29 @@ (defmethod filter ((pred map) (s ch-set)) (hash-set-org-compare-fn hsorg))))) (make-ch-set result hsorg))) -(defmethod image ((fn function) (s ch-set) &key compare-fn-name) +(define-methods (image fset2:image) ((fn function) (s ch-set) &key compare-fn-name) (ch-set-image fn s compare-fn-name)) -(defmethod image ((fn symbol) (s ch-set) &key compare-fn-name) +(define-methods (image fset2:image) ((fn symbol) (s ch-set) &key compare-fn-name) (ch-set-image (coerce-to-function fn) s compare-fn-name)) (defmethod image ((fn map) (s ch-set) &key compare-fn-name) - (ch-set-image fn s compare-fn-name)) + (ch-set-image (fn (x) (lookup fn x)) s compare-fn-name)) +(defmethod fset2:image ((fn map) (s ch-set) &key compare-fn-name) + (ch-set-image (fn (x) (fset2:lookup fn x)) s compare-fn-name)) -(defmethod image ((fn set) (s ch-set) &key compare-fn-name) - (ch-set-image fn s compare-fn-name)) +(define-methods (image fset2:image) ((fn set) (s ch-set) &key compare-fn-name) + (ch-set-image (fn (x) (lookup fn x)) s compare-fn-name)) -(defmethod image ((fn bag) (s ch-set) &key compare-fn-name) - (ch-set-image fn s compare-fn-name)) +(define-methods (image fset2:image) ((fn bag) (s ch-set) &key compare-fn-name) + (ch-set-image (fn (x) (lookup fn x)) s compare-fn-name)) (defun ch-set-image (fn s compare-fn-name) + (declare (type function fn)) (let ((result nil) (hsorg (ch-set-org (if compare-fn-name (empty-ch-set compare-fn-name) s)))) (do-ch-set-tree-members (x (ch-set-contents s)) - (setq result (ch-set-tree-with result (@ fn x) (hash-set-org-hash-fn hsorg) + (setq result (ch-set-tree-with result (funcall fn x) (hash-set-org-hash-fn hsorg) (hash-set-org-compare-fn hsorg)))) (make-ch-set result hsorg))) @@ -2472,22 +2654,25 @@ (defstruct (wb-bag (contents nil :read-only t) (org nil :type tree-set-org :read-only t)) -(defparameter *empty-wb-bag* (make-wb-bag nil +fset-default-tree-set-org+)) +(defparameter +empty-wb-bag+ (make-wb-bag nil +fset-default-tree-set-org+)) (declaim (inline empty-bag)) (defun empty-bag () "Returns an empty bag of the default implementation and type." - *empty-wb-bag*) - -(defmethod empty-instance-function ((class-name (eql 'bag))) - 'empty-bag) + +empty-wb-bag+) -(declaim (inline empty-wb-bag)) +(declaim (inline empty-wb-bag fset2:empty-wb-bag)) (defun empty-wb-bag (&optional compare-fn-name) "Returns an empty `wb-bag' ordered according to `compare-fn-name', which must be a symbol." (if (null compare-fn-name) - *empty-wb-bag* + +empty-wb-bag+ + (empty-wb-custom-bag compare-fn-name))) +(defun fset2:empty-wb-bag (&key compare-fn-name) + "Returns an empty `wb-bag' ordered according to `compare-fn-name', which +must be a symbol." + (if (null compare-fn-name) + +empty-wb-bag+ (empty-wb-custom-bag compare-fn-name))) (deflex +empty-wb-custom-bag-cache+ (make-hash-table :test 'eq)) @@ -2496,7 +2681,7 @@ (defmethod empty-instance-function ((class-name (eql 'bag))) (assert (and compare-fn-name (symbolp compare-fn-name) (symbol-package compare-fn-name)) () "compare-fn-name must be a nonnull interned symbol") (if (eq compare-fn-name 'compare) - *empty-wb-bag* + +empty-wb-bag+ (let ((prev-instance (gethash compare-fn-name +empty-wb-custom-bag-cache+)) (compare-fn (symbol-function compare-fn-name))) (if (and prev-instance @@ -2505,13 +2690,15 @@ (defmethod empty-instance-function ((class-name (eql 'bag))) (setf (gethash compare-fn-name +empty-wb-custom-bag-cache+) (make-wb-bag nil (make-tree-set-org compare-fn-name compare-fn))))))) -(defmethod empty-instance-function ((class-name (eql 'wb-bag))) - 'empty-wb-bag) - (defmethod empty-set-like ((b wb-bag)) (let ((tsorg (wb-bag-org b))) (empty-wb-custom-set (tree-set-org-compare-fn-name tsorg)))) +(defgeneric empty-bag-like (b) + (:documentation + "Returns an empty bag of the same implementation, and using the same compare +or hash function, as `b'. `b' can also be a set.")) + (defmethod empty-bag-like ((b wb-bag)) (let ((tsorg (wb-bag-org b))) (empty-wb-custom-bag (tree-set-org-compare-fn-name tsorg)))) @@ -2548,11 +2735,18 @@ (defmethod lookup ((b wb-bag) x) (if (plusp mult) (values t value-found) (values nil nil)))) +(defmethod fset2:lookup ((b wb-bag) x) + (WB-Bag-Tree-Multiplicity (wb-bag-contents b) x + (tree-set-org-compare-fn (wb-bag-org b)))) (defmethod rank ((b wb-bag) x) "Returns the rank in the set ordering, i.e. the upper bound is the `set-size'." (let ((found? rank (WB-Bag-Tree-Rank (wb-bag-contents b) x (tree-set-org-compare-fn (wb-bag-org b))))) (values (if found? rank (1- rank)) found?))) +(defmethod fset2:rank ((b wb-bag) x) + "Returns the rank in the set ordering, i.e. the upper bound is the `set-size'." + (let ((found? rank (WB-Bag-Tree-Rank (wb-bag-contents b) x (tree-set-org-compare-fn (wb-bag-org b))))) + (values rank found?))) (defmethod at-rank ((s wb-bag) rank) "Takes the rank in the set ordering, i.e. the upper bound is the `set-size'." @@ -2614,9 +2808,10 @@ (defmethod less ((b wb-bag) value &optional (multiplicity 1)) (defmethod split-from ((b wb-bag) value) (let ((compare-fn (tree-set-org-compare-fn (wb-bag-org b))) - ((new-contents (WB-Bag-Tree-Split-Above (wb-bag-contents b) value compare-fn)))) - (make-wb-bag (if (< 0 (WB-Bag-Tree-Multiplicity (wb-bag-contents b) value compare-fn)) - (WB-Bag-Tree-With new-contents value compare-fn) + ((new-contents (WB-Bag-Tree-Split-Above (wb-bag-contents b) value compare-fn)) + (count (WB-Bag-Tree-Multiplicity (wb-bag-contents b) value compare-fn)))) + (make-wb-bag (if (plusp count) + (WB-Bag-Tree-With new-contents value compare-fn count) new-contents) (wb-bag-org b)))) @@ -2626,9 +2821,10 @@ (defmethod split-above ((b wb-bag) value) (defmethod split-through ((b wb-bag) value) (let ((compare-fn (tree-set-org-compare-fn (wb-bag-org b))) - ((new-contents (WB-Bag-Tree-Split-Below (wb-bag-contents b) value compare-fn)))) - (make-wb-bag (if (< 0 (WB-Bag-Tree-Multiplicity (wb-bag-contents b) value compare-fn)) - (WB-Bag-Tree-With new-contents value compare-fn) + ((new-contents (WB-Bag-Tree-Split-Below (wb-bag-contents b) value compare-fn)) + (count (WB-Bag-Tree-Multiplicity (wb-bag-contents b) value compare-fn)))) + (make-wb-bag (if (plusp count) + (WB-Bag-Tree-With new-contents value compare-fn count) new-contents) (wb-bag-org b)))) @@ -2639,10 +2835,12 @@ (defmethod split-below ((b wb-bag) value) (defmethod union ((b1 bag) (b2 bag) &key) "Fallback method for mixed implementations." (let ((result b1)) - (do-bag-pairs (x n2 b2) - (let ((n1 (multiplicity result x))) - (when (< n1 n2) - (includef result x (- n2 n1))))) + (do-bag-pairs (x2 n2 b2) + (let ((n1 x1 (multiplicity result x2))) + (cond ((zerop n1) + (includef result x2 n2)) + ((< n1 n2) + (includef result x1 (- n2 n1)))))) result)) (defmethod union ((b1 wb-bag) (b2 wb-bag) &key) @@ -2663,16 +2861,20 @@ (defmethod union ((b wb-bag) (s wb-set) &key) (let ((scmp (wb-set-compare-fn s)) (bcmp (tree-set-org-compare-fn (wb-bag-org b)))) (if (eq scmp bcmp) - (make-wb-bag (WB-Bag-Tree-Union (WB-Set-Tree-To-Bag-Tree (wb-set-contents s)) - (wb-bag-contents b) bcmp) + (make-wb-bag (WB-Bag-Tree-Union (wb-bag-contents b) (WB-Set-Tree-To-Bag-Tree (wb-set-contents s)) + bcmp) (wb-bag-org b)) (call-next-method)))) (defmethod union ((s set) (b bag) &key) "Fallback method for mixed implementations." (let ((result (convert 'bag s))) - (do-bag-pairs (x n b) - (setq result (with result x (- n (if (contains? s x) 1 0))))) + (do-bag-pairs (xb n b) + (let ((xs? xs (lookup s xb))) + (cond ((not xs?) + (includef result xb n)) + ((> n 1) + (includef result xs (1- n)))))) result)) (defmethod union ((s wb-set) (b wb-bag) &key) @@ -2687,8 +2889,11 @@ (defmethod union ((s wb-set) (b wb-bag) &key) (defmethod bag-sum ((b1 bag) (b2 bag)) "Fallback method for mixed implementations." (let ((result b1)) - (do-bag-pairs (x n b2) - (includef result x n)) + (do-bag-pairs (x2 n2 b2) + (let ((n1 x1 (multiplicity b1 x2))) + (if (zerop n1) + (includef result x2 n2) + (includef result x1 n2)))) result)) (defmethod bag-sum ((b1 wb-bag) (b2 wb-bag)) @@ -2701,15 +2906,16 @@ (defmethod bag-sum ((b bag) (s set)) "Fallback method for mixed implementations." (let ((result b)) (do-set (x s) - (setq result (with result x))) + (let ((nb xb (multiplicity b x))) + (includef result (if (zerop nb) x xb)))) result)) (defmethod bag-sum ((b wb-bag) (s wb-set)) (let ((scmp (wb-set-compare-fn s)) (bcmp (tree-set-org-compare-fn (wb-bag-org b)))) (if (eq scmp bcmp) - (make-wb-bag (WB-Bag-Tree-Sum (WB-Set-Tree-To-Bag-Tree (wb-set-contents s)) - (wb-bag-contents b) bcmp) + (make-wb-bag (WB-Bag-Tree-Sum (wb-bag-contents b) + (WB-Set-Tree-To-Bag-Tree (wb-set-contents s)) bcmp) (wb-bag-org b)) (call-next-method)))) @@ -2717,7 +2923,9 @@ (defmethod bag-sum ((s set) (b bag)) "Fallback method for mixed implementations." (let ((result (convert 'bag s))) (do-bag-pairs (x n b) - (setq result (with result x n))) + (let ((xs? xs (lookup s x))) + (if xs? (includef result xs n) + (includef result x n)))) result)) (defmethod bag-sum ((s wb-set) (b wb-bag)) @@ -2732,8 +2940,8 @@ (defmethod bag-sum ((s wb-set) (b wb-bag)) (defmethod intersection ((b1 bag) (b2 bag) &key) "Fallback method for mixed implementations." (let ((result (empty-bag-like b1))) - (do-bag-pairs (x n2 b2) - (includef result x (min (multiplicity b1 x) n2))) + (do-bag-pairs (x1 n1 b1) + (includef result x1 (min (multiplicity b2 x1) n1))) result)) (defmethod intersection ((b1 wb-bag) (b2 wb-bag) &key) @@ -2764,9 +2972,8 @@ (defmethod intersection ((b wb-bag) (s wb-set) &key) (defmethod intersection ((s set) (b bag) &key) "Fallback method for mixed implementations." (let ((result (empty-set-like s))) - (do-bag-pairs (x n b) - (declare (ignore n)) - (when (contains? s x) + (do-set (x s) + (when (contains? b x) (includef result x))) result)) @@ -2774,16 +2981,18 @@ (defmethod intersection ((s wb-set) (b wb-bag) &key) (let ((scmp (wb-set-compare-fn s)) (bcmp (tree-set-org-compare-fn (wb-bag-org b)))) (if (eq scmp bcmp) - (make-wb-set (WB-Set-Tree-Intersect (WB-Bag-Tree-To-Set-Tree (wb-bag-contents b)) - (wb-set-contents s) bcmp) + (make-wb-set (WB-Set-Tree-Intersect (wb-set-contents s) (WB-Bag-Tree-To-Set-Tree (wb-bag-contents b)) + bcmp) (wb-set-org s)) (call-next-method)))) (defmethod bag-product ((b1 bag) (b2 bag)) "Fallback method for mixed implementations." (let ((result (empty-bag-like b1))) - (do-bag-pairs (x n2 b2) - (includef result x (* (multiplicity b1 x) n2))) + (do-bag-pairs (x2 n2 b2) + (let ((n1 x1 (multiplicity b1 x2))) + (unless (zerop n1) + (includef result x1 (* n1 n2))))) result)) (defmethod bag-product ((b1 wb-bag) (b2 wb-bag)) @@ -2805,17 +3014,18 @@ (defmethod bag-product ((b wb-bag) (s wb-set)) (let ((scmp (wb-set-compare-fn s)) (bcmp (tree-set-org-compare-fn (wb-bag-org b)))) (if (eq scmp bcmp) - (make-wb-bag (WB-Bag-Tree-Product (WB-Set-Tree-To-Bag-Tree (wb-set-contents s)) - (wb-bag-contents b) bcmp) + (make-wb-bag (WB-Bag-Tree-Product (wb-bag-contents b) (WB-Set-Tree-To-Bag-Tree (wb-set-contents s)) + bcmp) (wb-bag-org b)) (call-next-method)))) (defmethod bag-product ((s set) (b bag)) "Fallback method for mixed implementations." - (let ((result (empty-bag-like s))) - (do-bag-pairs (x n b) - (when (contains? s x) - (includef result x n))) + (let ((result (convert 'bag (empty-set-like s)))) + (do-bag-pairs (xb n b) + (let ((xs? xs (lookup s xb))) + (when xs? + (includef result xs n)))) result)) (defmethod bag-product ((s wb-set) (b wb-bag)) @@ -2881,7 +3091,7 @@ (defmethod subbag? ((b1 bag) (b2 bag)) (return nil)))) (defmethod subbag? ((b1 wb-bag) (b2 wb-bag)) - (if-same-wb-bag-orgs (b2 b2 tsorg) + (if-same-wb-bag-orgs (b1 b2 tsorg) (WB-Bag-Tree-Subbag? (wb-bag-contents b1) (wb-bag-contents b2) (tree-set-org-compare-fn tsorg)) (call-next-method))) @@ -2924,8 +3134,13 @@ (defmethod disjoint? ((b1 wb-bag) (b2 wb-bag)) (defmethod disjoint? ((b wb-bag) (s wb-set)) (bag-set-disjoint? b s)) +(defmethod disjoint? ((b wb-bag) (s ch-set)) + (bag-set-disjoint? b s)) + (defmethod disjoint? ((s wb-set) (b wb-bag)) (bag-set-disjoint? b s)) +(defmethod disjoint? ((s ch-set) (b wb-bag)) + (bag-set-disjoint? b s)) (defun bag-set-disjoint? (b s) ;; Too lazy to write the WB hedge algorithm. Maybe l8r. @@ -2995,27 +3210,30 @@ (defmethod fun-iterator ((s wb-bag) &key pairs? from-end?) (WB-Bag-Tree-Rev-Fun-Iter (wb-bag-contents s)) (WB-Bag-Tree-Fun-Iter (wb-bag-contents s))))) -(defmethod filter ((pred function) (b bag)) +(define-methods (filter fset2:filter) ((pred function) (b bag)) (bag-filter pred b)) -(defmethod filter ((pred symbol) (b bag)) +(define-methods (filter fset2:filter) ((pred symbol) (b bag)) (bag-filter (coerce-to-function pred) b)) (defmethod filter ((pred map) (b bag)) - (bag-filter pred b)) + (bag-filter (fn (x) (lookup pred x)) b)) +(defmethod fset2:filter ((pred map) (b bag)) + (bag-filter (fn (x) (fset2:lookup pred x)) b)) (defun bag-filter (pred b) (let ((result (empty-bag-like b))) (do-bag-pairs (x n b) - (when (@ pred x) + (when (funcall pred x) (setq result (with result x n)))) result)) -(defmethod filter ((pred set) (b bag)) +(define-methods (filter fset2:filter) ((pred set) (b bag)) (bag-product (convert 'bag pred) b)) -(defmethod filter ((pred bag) (b bag)) - (bag-filter pred b)) +(define-methods (filter fset2:filter) ((pred bag) (b bag)) + ;; Not quite the same as bag intersection. + (bag-filter (fn (x) (contains? pred x)) b)) (defmethod filter-pairs ((pred function) (b bag)) (bag-filter-pairs pred b)) @@ -3030,26 +3248,29 @@ (defmethod filter-pairs ((pred symbol) (b bag)) (setq result (with result x n)))) result)) -(defmethod image ((fn function) (b bag) &key compare-fn-name) +(define-methods (image fset2:image) ((fn function) (b bag) &key compare-fn-name) (bag-image fn b compare-fn-name)) -(defmethod image ((fn symbol) (b bag) &key compare-fn-name) +(define-methods (image fset2:image) ((fn symbol) (b bag) &key compare-fn-name) (bag-image (coerce-to-function fn) b compare-fn-name)) (defmethod image ((fn map) (b bag) &key compare-fn-name) - (bag-image fn b compare-fn-name)) + (bag-image (fn (x) (lookup fn x)) b compare-fn-name)) +(defmethod fset2:image ((fn map) (b bag) &key compare-fn-name) + (bag-image (fn (x) (fset2:lookup fn x)) b compare-fn-name)) -(defmethod image ((fn set) (b bag) &key compare-fn-name) - (bag-image fn b compare-fn-name)) +(define-methods (image fset2:image) ((fn set) (b bag) &key compare-fn-name) + (bag-image (fn (x) (lookup fn x)) b compare-fn-name)) -(defmethod image ((fn bag) (b bag) &key compare-fn-name) - (bag-image fn b compare-fn-name)) +(define-methods (image fset2:image) ((fn bag) (b bag) &key compare-fn-name) + (bag-image (fn (x) (lookup fn x)) b compare-fn-name)) (defun bag-image (fn b compare-fn-name) + (declare (type function fn)) (let ((org (wb-bag-org (if compare-fn-name (empty-wb-bag compare-fn-name) b))) (result nil)) (do-bag-pairs (x n b) - (setq result (WB-Bag-Tree-With result (@ fn x) (tree-set-org-compare-fn org) n))) + (setq result (WB-Bag-Tree-With result (funcall fn x) (tree-set-org-compare-fn org) n))) (make-wb-bag result org))) (defmethod reduce ((fn function) (b bag) &key key (initial-value nil init?)) @@ -3089,7 +3310,7 @@ (defmethod convert ((to-type (eql 'wb-bag)) (b wb-bag) &key compare-fn-name) (do-wb-bag-tree-pairs (x n (wb-bag-contents b) tree) (setq tree (WB-Bag-Tree-With tree x compare-fn n)))))) -(defmethod convert ((to-type (eql 'set)) (b wb-bag) &key) +(define-convert-methods (set fset2:set) ((b wb-bag) &key) (make-wb-set (WB-Bag-Tree-To-Set-Tree (wb-bag-contents b)) (wb-bag-org b))) (defmethod convert ((to-type (eql 'wb-set)) (b wb-bag) &key compare-fn-name) @@ -3175,19 +3396,19 @@ (defmethod convert ((to-type (eql 'wb-bag)) (s sequence) &key input-sorted? pair (defmethod find (item (b bag) &key key test) (declare (optimize (speed 3) (safety 0))) - (let ((test (coerce-to-function-or-equal? test))) + (let ((test default? (coerce-to-function-or-equal? test))) (if key (let ((key (coerce-to-function key))) (do-bag-pairs (x n b nil) (declare (ignore n)) (when (funcall test item (funcall key x)) (return x)))) - (if (not (eq test #'equal?)) - (do-bag-pairs (x n b nil) - (declare (ignore n)) - (when (funcall test item x) - (return x))) - (nth-value 1 (lookup b item)))))) + (if (and default? (eq (compare-fn b) #'compare)) + (nth-value 1 (lookup b item)) + (do-bag-pairs (x n b nil) + (declare (ignore n)) + (when (funcall test item x) + (return x))))))) (defmethod find-if (pred (b bag) &key key) (declare (optimize (speed 3) (safety 0))) @@ -3217,12 +3438,12 @@ (defmethod count (item (b bag) &key key test) (do-bag-pairs (x n b total) (when (funcall test item (funcall key x)) (setq total (gen + total n))))) - (if default? + (if (and default? (eq (compare-fn b) #'compare)) (multiplicity b item) - (let ((total 0)) - (do-bag-pairs (x n b total) - (when (funcall test item x) - (setq total (gen + total n))))))))) + (let ((total 0)) + (do-bag-pairs (x n b total) + (when (funcall test item x) + (setq total (gen + total n))))))))) (defmethod count-if (pred (b bag) &key key) (declare (optimize (speed 3) (safety 0))) @@ -3281,7 +3502,7 @@ (defstruct (tree-map-org (val-compare-fn-name nil :type symbol :read-only t) (val-compare-fn nil :type function :read-only t)) -(deflex +fset-default-tree-map-org+ (make-tree-map-org 'compare #'compare 'compare #'compare)) +(defparameter +fset-default-tree-map-org+ (make-tree-map-org 'compare #'compare 'compare #'compare)) (declaim (inline make-wb-map)) @@ -3296,25 +3517,50 @@ (defstruct (wb-map (contents nil :read-only t) (org nil :type tree-map-org :read-only t)) -(defparameter *empty-wb-map* (make-wb-map nil +fset-default-tree-map-org+ nil)) +(defparameter +empty-wb-map+ (make-wb-map nil +fset-default-tree-map-org+ nil)) + +(defparameter +empty-wb-map/no-default+ (make-wb-map nil +fset-default-tree-map-org+ 'no-default)) + +(declaim (inline fset2-default)) +(defun fset2-default (default? default no-default?) + (if (and default? no-default?) + (error "Both a default and `no-default?' specified") + (cond (default? default) + (no-default? 'no-default) + (t nil)))) (declaim (inline empty-map)) (defun empty-map (&optional default) "Returns an empty map of the default implementation." (if default (make-wb-map nil +fset-default-tree-map-org+ default) - *empty-wb-map*)) + +empty-wb-map+)) +;;; `fset2:empty-map' is below -(defmethod empty-instance-function ((class-name (eql 'map))) - `empty-map) - -(declaim (inline empty-wb-map)) +(declaim (inline empty-wb-map fset2:empty-wb-map)) (defun empty-wb-map (&optional default key-compare-fn-name val-compare-fn-name) - "Returns an empty wb-map." + "Returns an empty wb-map with the specified default and comparison functions." (if (and (null key-compare-fn-name) (null val-compare-fn-name)) (if (null default) - *empty-wb-map* + +empty-wb-map+ (make-wb-map nil +fset-default-tree-map-org+ default)) (empty-wb-custom-map default (or key-compare-fn-name 'compare) (or val-compare-fn-name 'compare)))) +(defun fset2:empty-wb-map (&key (default nil default?) no-default? key-compare-fn-name val-compare-fn-name) + "Returns an empty wb-map with the specified default and comparison functions. +The map's default is `nil' unless a different default is supplied, or +`no-default?' is true." + ;; The idea here is to inline the keyword argument processing and the default selection, hopefully + ;; all of which will constant-fold down to just the default in almost all cases. + (empty-wb-map-internal (fset2-default default? default no-default?) key-compare-fn-name val-compare-fn-name)) + +(defun empty-wb-map-internal (default key-compare-fn-name val-compare-fn-name) + ;; This has gotten too big to inline. + (cond ((or key-compare-fn-name val-compare-fn-name) + (empty-wb-custom-map default (or key-compare-fn-name 'compare) (or val-compare-fn-name 'compare))) + ((null default) + +empty-wb-map+) + ((eq default 'no-default) + +empty-wb-map/no-default+) + (t (make-wb-map nil +fset-default-tree-map-org+ default)))) (deflex +empty-wb-custom-map-cache+ (make-hash-table :test 'equal)) @@ -3326,7 +3572,7 @@ (defmethod empty-instance-function ((class-name (eql 'map))) (symbol-package val-compare-fn-name)) () "val-compare-fn-name must be a nonnull interned symbol") (if (and (eq key-compare-fn-name 'compare) (eq val-compare-fn-name 'compare)) - (if (null default) *empty-wb-map* + (if (null default) +empty-wb-map+ (make-wb-map nil +fset-default-tree-map-org+ default)) ;; &&& This caches one default per type. We could use a two-level map to cache multiple defaults, ;; but the inner maps would have to be custom wb-maps, whose creation couldn't call this function (!). @@ -3338,16 +3584,20 @@ (defmethod empty-instance-function ((class-name (eql 'map))) (if (and prev-instance (let ((prev-org (wb-map-org prev-instance))) (and (eq key-compare-fn (tree-map-org-key-compare-fn prev-org)) - (eq val-compare-fn (tree-map-org-val-compare-fn prev-org)) - (equal?-cmp default (map-default prev-instance) val-compare-fn)))) - prev-instance + (eq val-compare-fn (tree-map-org-val-compare-fn prev-org))))) + (if (equal?-cmp default (map-default prev-instance) val-compare-fn) + prev-instance + (setf (gethash cache-key +empty-wb-custom-map-cache+) + (make-wb-map nil (wb-map-org prev-instance) default))) (setf (gethash cache-key +empty-wb-custom-map-cache+) (make-wb-map nil (make-tree-map-org key-compare-fn-name key-compare-fn val-compare-fn-name val-compare-fn) default)))))) -(defmethod empty-instance-function ((class-name (eql 'wb-map))) - `empty-wb-map) +(defgeneric empty-map-like (m) + (:documentation + "Returns an empty map of the same implementation, and using the same compare +or hash functions, as `m'.")) (defmethod empty-map-like ((m wb-map)) (let ((tmorg (wb-map-org m))) @@ -3367,11 +3617,16 @@ (defmethod val-compare-fn-name ((m wb-map)) (tree-map-org-val-compare-fn-name (wb-map-org m))) (defmethod default ((m map)) - (map-default m)) + (let ((dflt (map-default m))) + (if (eq dflt 'no-default) (values nil nil) + (values dflt t)))) (defmethod with-default ((m wb-map) new-default) (make-wb-map (wb-map-contents m) (wb-map-org m) new-default)) +(defmethod fset2:without-default ((m wb-map)) + (make-wb-map (wb-map-contents m) (wb-map-org m) 'no-default)) + (defmethod empty? ((m wb-map)) (null (wb-map-contents m))) @@ -3405,16 +3660,39 @@ (defmethod contains? ((m wb-map) x &optional (y nil y?)) ((val? val (WB-Map-Tree-Lookup (wb-map-contents m) x (tree-map-org-key-compare-fn comp))))) (and val? (equal?-cmp val y (tree-map-org-val-compare-fn comp))))) -(defmethod lookup ((m wb-map) key) - (let ((val? val (WB-Map-Tree-Lookup (wb-map-contents m) key - (tree-map-org-key-compare-fn (wb-map-org m))))) +(define-condition fset2:lookup-error (error) + ()) + +(define-condition fset2:map-domain-error (fset2:lookup-error) + ((map :initarg :map :reader fset2:map-domain-error-map) + (key :initarg :key :reader fset2:map-domain-error-key)) + (:report (lambda (mde stream) + (let ((*print-length* 8) + (*print-level* 3)) + (format stream "Key ~S not found in map ~A, which has no default" + (fset2:map-domain-error-key mde) (fset2:map-domain-error-map mde)))))) + +;;; Even though FSet 1 code will never generate a map with no default, we could have a mixed +;;; FSet 1/2 codebase, so we should still check for that in `fset:lookup'. +(define-methods (lookup fset2:lookup) ((m wb-map) key) + (let ((val? val mkey (WB-Map-Tree-Lookup (wb-map-contents m) key + (tree-map-org-key-compare-fn (wb-map-org m))))) ;; Our internal convention is the reverse of the external one. - (values (if val? val (map-default m)) val?))) + (values (if val? val + (let ((dflt (map-default m))) + (if (eq dflt 'no-default) + (error 'fset2:map-domain-error :map m :key key) + dflt))) + val? mkey))) (defmethod rank ((m wb-map) x) (let ((found? rank (WB-Map-Tree-Rank (wb-map-contents m) x (tree-map-org-key-compare-fn (wb-map-org m))))) (values (if found? rank (1- rank)) found?))) +(defmethod fset2:rank ((m wb-map) x) + (let ((found? rank (WB-Map-Tree-Rank (wb-map-contents m) x + (tree-map-org-key-compare-fn (wb-map-org m))))) + (values rank found?))) (defmethod at-rank ((m wb-map) rank) (let ((contents (wb-map-contents m)) @@ -3554,29 +3832,35 @@ (defmethod fun-iterator ((s wb-map) &key from-end?) (WB-Map-Tree-Rev-Fun-Iter (wb-map-contents s)) (WB-Map-Tree-Fun-Iter (wb-map-contents s)))) -(defmethod filter ((pred function) (m wb-map)) - (let ((tmorg (wb-map-org m))) - (make-wb-map (wb-map-filter pred m (tree-map-org-key-compare-fn tmorg) (tree-map-org-val-compare-fn tmorg)) - tmorg (map-default m)))) +(define-methods (filter fset2:filter) ((pred function) (m wb-map)) + (wb-map-filter pred m)) -(defmethod filter ((pred symbol) (m wb-map)) - (let ((tmorg (wb-map-org m))) - (make-wb-map (wb-map-filter (coerce-to-function pred) m - (tree-map-org-key-compare-fn tmorg) (tree-map-org-val-compare-fn tmorg)) - tmorg (map-default m)))) +(define-methods (filter fset2:filter) ((pred symbol) (m wb-map)) + (wb-map-filter (coerce-to-function pred) m)) -(defun wb-map-filter (pred m key-compare-fn val-compare-fn) - (let ((result nil)) +(defun wb-map-filter (pred m) + (declare (optimize (speed 3) (safety 0)) (type function pred)) + (let ((tmorg (wb-map-org m)) + ((key-compare-fn (tree-map-org-key-compare-fn tmorg)) + (val-compare-fn (tree-map-org-val-compare-fn tmorg))) + (result nil)) (do-map (x y m) (when (funcall pred x y) (setq result (WB-Map-Tree-With result x y key-compare-fn val-compare-fn)))) - result)) + (make-wb-map result tmorg (map-default m)))) (defmethod image ((fn function) (m wb-map) &key key-compare-fn-name val-compare-fn-name) (wb-map-image fn m key-compare-fn-name val-compare-fn-name (map-default m))) +(defmethod fset2:image ((fn function) (m wb-map) &key key-compare-fn-name val-compare-fn-name) + ;; We can't call `fn' to compute a new default, because we don't have a corresponding + ;; domain value. Copying the default from `m', as FSet1 did, doesn't make sense either; + ;; in general, the range type is different. + (wb-map-image fn m key-compare-fn-name val-compare-fn-name 'no-default)) (defmethod image ((fn symbol) (m wb-map) &key key-compare-fn-name val-compare-fn-name) (wb-map-image (coerce-to-function fn) m key-compare-fn-name val-compare-fn-name (map-default m))) +(defmethod fset2:image ((fn symbol) (m wb-map) &key key-compare-fn-name val-compare-fn-name) + (wb-map-image (coerce-to-function fn) m key-compare-fn-name val-compare-fn-name 'no-default)) (defun wb-map-image (fn m key-compare-fn-name val-compare-fn-name default) (declare (type function fn)) @@ -3633,73 +3917,166 @@ (defmethod range-contains? ((m map) x) (defmethod map-union ((m1 map) (m2 map) &optional (val-fn (fn (_v1 v2) v2))) "Fallback method for mixed implementations." + (generic-map-union m1 m2 val-fn (let ((dflt1 (map-default m1)) + (dflt2 (map-default m2))) + (and (or dflt1 dflt2) (funcall val-fn dflt1 dflt2))))) +(defmethod fset2:map-union ((m1 map) (m2 map) &optional (val-fn (fn (_v1 v2) v2))) + "Fallback method for mixed implementations." + (generic-map-union m1 m2 val-fn (map-union-default m1 m2 val-fn))) + +(defun generic-map-union (m1 m2 val-fn default) (let ((result m1) - (vcf1 (val-compare-fn m1))) - (do-map (k v2 m2) - (let ((v1 v1? (lookup m1 k))) + (vcf1 (val-compare-fn m1)) + (m1d (with-default m1 nil))) ; so `lookup' doesn't error + (do-map (k2 v2 m2) + (let ((v1 v1? k1 (lookup m1d k2))) (if (not v1?) - (setf (lookup result k) v2) + (setf (lookup result k2) v2) (unless (equal?-cmp v1 v2 vcf1) (let ((new-v second-val (funcall val-fn v1 v2))) - (unless (eq second-val ':no-value) - (setf (lookup result k) new-v))))))) - result)) - -(defmethod map-union ((map1 wb-map) (map2 wb-map) + (if (eq second-val ':no-value) + (excludef result k1) + (setf (lookup result k1) new-v))))))) + (with-default result default))) + +(defun map-union-default (m1 m2 val-fn) + (let ((dflt1 (map-default m1)) + (dflt2 (map-default m2))) + (if (eq dflt1 'no-default) dflt2 + (if (eq dflt2 'no-default) dflt1 + (let ((v second-val (funcall val-fn dflt1 dflt2))) + (if (eq second-val ':no-value) 'no-default + v)))))) + +(defmethod map-union ((m1 wb-map) (m2 wb-map) &optional (val-fn (fn (_v1 v2) v2))) - (if-same-wb-map-orgs (map1 map2 tmorg) - (make-wb-map (WB-Map-Tree-Union (wb-map-contents map1) (wb-map-contents map2) - (coerce val-fn 'function) (tree-map-org-key-compare-fn tmorg)) - tmorg (let ((def1 (map-default map1)) - (def2 (map-default map2))) - (and (or def1 def2) (funcall val-fn def1 def2)))) + (if-same-wb-map-orgs (m1 m2 tmorg) + (make-wb-map (WB-Map-Tree-Union (wb-map-contents m1) (wb-map-contents m2) + (coerce val-fn 'function) (tree-map-org-key-compare-fn tmorg) + (tree-map-org-val-compare-fn tmorg)) + tmorg (let ((dflt1 (map-default m1)) + (dflt2 (map-default m2))) + (and (or dflt1 dflt2) (funcall val-fn dflt1 dflt2)))) + (call-next-method))) +(defmethod fset2:map-union ((m1 wb-map) (m2 wb-map) + &optional (val-fn (fn (_v1 v2) v2))) + (if-same-wb-map-orgs (m1 m2 tmorg) + (make-wb-map (WB-Map-Tree-Union (wb-map-contents m1) (wb-map-contents m2) + (coerce val-fn 'function) (tree-map-org-key-compare-fn tmorg) + (tree-map-org-val-compare-fn tmorg)) + tmorg (map-union-default m1 m2 val-fn)) (call-next-method))) (defmethod map-intersection ((m1 map) (m2 map) &optional (val-fn (fn (_v1 v2) v2))) "Fallback method for mixed implementations." + (generic-map-intersection m1 m2 val-fn (let ((dflt1 (map-default m1)) + (dflt2 (map-default m2))) + (and (or dflt1 dflt2) (funcall val-fn dflt1 dflt2))))) +(defmethod fset2:map-intersection ((m1 map) (m2 map) &optional (val-fn (fn (_v1 v2) v2))) + "Fallback method for mixed implementations." + (generic-map-intersection m1 m2 val-fn (map-intersection-default m1 m2 val-fn))) + +(defun generic-map-intersection (m1 m2 val-fn default) (let ((result (empty-map-like m1)) - (vcf1 (val-compare-fn m1))) + (vcf1 (val-compare-fn m1)) + (m2d (with-default m2 nil))) ; prevent `lookup' errors (do-map (k v1 m1) - (let ((v2 v2? (lookup m2 k))) - (when (and v2? (not (equal?-cmp v1 v2 vcf1))) - (let ((new-v second-val (funcall val-fn v1 v2))) - (unless (eq second-val ':no-value) - (setf (lookup result k) new-v)))))) - result)) - -(defmethod map-intersection ((map1 wb-map) (map2 wb-map) + (let ((v2 v2? (lookup m2d k))) + (when v2? + (if (equal?-cmp v1 v2 vcf1) + (setf (lookup result k) v1) + (let ((new-v second-val (funcall val-fn v1 v2))) + (unless (eq second-val ':no-value) + (setf (lookup result k) new-v))))))) + (with-default result default))) + +(defun map-intersection-default (m1 m2 val-fn) + (let ((dflt1 (map-default m1)) + (dflt2 (map-default m2))) + (if (and (not (eq dflt1 'no-default)) (not (eq dflt2 'no-default))) + (let ((v second-val (funcall val-fn dflt1 dflt2))) + (if (eq second-val ':no-value) 'no-default + v)) + 'no-default))) + +(defmethod map-intersection ((m1 wb-map) (m2 wb-map) &optional (val-fn (fn (_v1 v2) v2))) - (if-same-wb-map-orgs (map1 map2 tmorg) - (make-wb-map (WB-Map-Tree-Intersect (wb-map-contents map1) (wb-map-contents map2) - (coerce val-fn 'function) (tree-map-org-key-compare-fn tmorg)) - tmorg (let ((def1 (map-default map1)) - (def2 (map-default map2))) - (and (or def1 def2) (funcall val-fn def1 def2)))) + (if-same-wb-map-orgs (m1 m2 tmorg) + (make-wb-map (WB-Map-Tree-Intersect (wb-map-contents m1) (wb-map-contents m2) + (coerce val-fn 'function) (tree-map-org-key-compare-fn tmorg) + (tree-map-org-val-compare-fn tmorg)) + tmorg (let ((dflt1 (map-default m1)) + (dflt2 (map-default m2))) + (and (or dflt1 dflt2) (funcall val-fn dflt1 dflt2)))) + (call-next-method))) +(defmethod fset2:map-intersection ((m1 wb-map) (m2 wb-map) + &optional (val-fn (fn (_v1 v2) v2))) + (if-same-wb-map-orgs (m1 m2 tmorg) + (make-wb-map (WB-Map-Tree-Intersect (wb-map-contents m1) (wb-map-contents m2) + (coerce val-fn 'function) (tree-map-org-key-compare-fn tmorg) + (tree-map-org-val-compare-fn tmorg)) + tmorg (map-intersection-default m1 m2 val-fn)) (call-next-method))) (defmethod map-difference-2 ((m1 map) (m2 map)) "Fallback method for mixed implementations." + (let ((result1 result2 (generic-map-difference-2 m1 m2))) + (values (with-default result1 (map-default m1)) + (with-default result2 (map-default m2))))) +(defmethod fset2:map-difference-2 ((m1 map) (m2 map)) + "Fallback method for mixed implementations." + (let ((result1 result2 (generic-map-difference-2 m1 m2)) + (dflt1 dflt2 (map-difference-2-defaults m1 m2))) + (values (with-default result1 dflt1) + (with-default result2 dflt2)))) + +(defun generic-map-difference-2 (m1 m2) (let ((result1 (empty-map-like m1)) (result2 (empty-map-like m2)) (vcf1 (val-compare-fn m1)) - (vcf2 (val-compare-fn m2))) + (vcf2 (val-compare-fn m2)) + (m1d (with-default m1 nil)) + (m2d (with-default m2 nil))) (do-map (k v1 m1) - (let ((v2 v2? (lookup m2 k))) + (let ((v2 v2? (lookup m2d k))) (unless (and v2? (equal?-cmp v1 v2 vcf1)) (setf (lookup result1 k) v1)))) (do-map (k v2 m2) - (let ((v1 v1? (lookup m1 k))) + (let ((v1 v1? (lookup m1d k))) (unless (and v1? (equal?-cmp v1 v2 vcf2)) (setf (lookup result2 k) v2)))) (values result1 result2))) -(defmethod map-difference-2 ((map1 wb-map) (map2 wb-map)) - (if-same-wb-map-orgs (map1 map2 tmorg) - (let ((newc1 newc2 (WB-Map-Tree-Diff-2 (wb-map-contents map1) (wb-map-contents map2) +(defun map-difference-2-defaults (m1 m2) + (let ((dflt1 (map-default m1)) + (dflt2 (map-default m2))) + (values (if (eq dflt1 'no-default) 'no-default + (if (eq dflt2 'no-default) dflt1 + (if (equal?-cmp dflt1 dflt2 (val-compare-fn m1)) + 'no-default + dflt1))) + (if (eq dflt2 'no-default) 'no-default + (if (eq dflt1 'no-default) dflt2 + (if (equal?-cmp dflt1 dflt2 (val-compare-fn m2)) + 'no-default + dflt2)))))) + +(defmethod map-difference-2 ((m1 wb-map) (m2 wb-map)) + (if-same-wb-map-orgs (m1 m2 tmorg) + (let ((newc1 newc2 (WB-Map-Tree-Diff-2 (wb-map-contents m1) (wb-map-contents m2) (tree-map-org-key-compare-fn tmorg) (tree-map-org-val-compare-fn tmorg)))) - (values (make-wb-map newc1 tmorg (map-default map1)) - (make-wb-map newc2 tmorg (map-default map2)))) + (values (make-wb-map newc1 tmorg (map-default m1)) + (make-wb-map newc2 tmorg (map-default m2)))) + (call-next-method))) +(defmethod fset2:map-difference-2 ((m1 wb-map) (m2 wb-map)) + (if-same-wb-map-orgs (m1 m2 tmorg) + (let ((newc1 newc2 (WB-Map-Tree-Diff-2 (wb-map-contents m1) (wb-map-contents m2) + (tree-map-org-key-compare-fn tmorg) + (tree-map-org-val-compare-fn tmorg))) + (dflt1 dflt2 (map-difference-2-defaults m1 m2))) + (values (make-wb-map newc1 tmorg dflt1) + (make-wb-map newc2 tmorg dflt2))) (call-next-method))) (defmethod restrict ((m map) (s set)) @@ -3740,16 +4117,16 @@ (defmethod restrict-not ((m wb-map) (s wb-set)) (defun compose-functions (f1 f2) (lambda (&rest args) (multiple-value-call f2 (apply f1 args)))) -(defmethod compose ((f1 function) (f2 function) &key) +(define-methods (compose fset2:compose) ((f1 function) (f2 function) &key) (compose-functions f1 f2)) -(defmethod compose ((f1 symbol) (f2 function) &key) +(define-methods (compose fset2:compose) ((f1 symbol) (f2 function) &key) (compose-functions (symbol-function f1) f2)) -(defmethod compose ((f1 function) (f2 symbol) &key) +(define-methods (compose fset2:compose) ((f1 function) (f2 symbol) &key) (compose-functions f1 (symbol-function f2))) -(defmethod compose ((f1 symbol) (f2 symbol) &key) +(define-methods (compose fset2:compose) ((f1 symbol) (f2 symbol) &key) (compose-functions (symbol-function f1) (symbol-function f2))) ;;; I've removed the fallback method for `compose', as it's not needed -- the maps @@ -3758,30 +4135,44 @@ (defmethod compose ((f1 symbol) (f2 symbol) &key) (defmethod compose ((map1 wb-map) (map2 map) &key val-compare-fn-name) "The returned map's `val-compare-fn-name' can be specified; it defaults to `compare'." - (make-wb-map (WB-Map-Tree-Compose (wb-map-contents map1) - (fn (x) - (let ((val2 val2? (lookup map2 x))) - (if val2? val2 (map-default map2))))) - (wb-map-org (empty-wb-map nil (key-compare-fn-name map1) val-compare-fn-name)) - (let ((new-default new-default? (lookup map2 (map-default map1)))) - (if new-default? new-default (map-default map2))))) - -(defmethod compose ((m wb-map) (fn function) &key val-compare-fn-name) + (if (and (empty? map1) (eq (map-default map1) 'no-default)) + map1 + (make-wb-map (WB-Map-Tree-Compose (wb-map-contents map1) + ;; This can fail if `map2' is an FSet 2 map with no default. + (fn (x) (lookup map2 x))) + (wb-map-org (empty-wb-map nil (key-compare-fn-name map1) val-compare-fn-name)) + (let ((new-default new-default? (lookup map2 (map-default map1)))) + (if new-default? new-default (map-default map2)))))) +(defmethod fset2:compose ((map1 wb-map) (map2 map) &key val-compare-fn-name) + "The returned map's `val-compare-fn-name' can be specified; it defaults +to `compare'." + (if (and (empty? map1) (eq (map-default map1) 'no-default)) + map1 + (make-wb-map (WB-Map-Tree-Compose (wb-map-contents map1) (fn (x) (fset2:lookup map2 x))) + (wb-map-org (empty-wb-map nil (key-compare-fn-name map1) val-compare-fn-name)) + (let ((dflt1 (map-default map1))) + (if (eq dflt1 'no-default) 'no-default + (let ((new-default new-default? (fset2:lookup map2 dflt1))) + (if new-default? new-default (map-default map2)))))))) + +(define-methods (compose fset2:compose) ((m wb-map) (fn function) &key val-compare-fn-name) (wb-map-fn-compose m fn val-compare-fn-name)) -(defmethod compose ((m wb-map) (fn symbol) &key val-compare-fn-name) +(define-methods (compose fset2:compose) ((m wb-map) (fn symbol) &key val-compare-fn-name) (wb-map-fn-compose m (symbol-function fn) val-compare-fn-name)) -(defmethod compose ((m wb-map) (s seq) &key val-compare-fn-name) +(define-methods (compose fset2:compose) ((m wb-map) (s seq) &key val-compare-fn-name) (wb-map-fn-compose m (fn (x) (lookup s x)) val-compare-fn-name)) (defun wb-map-fn-compose (m fn val-compare-fn-name) (declare (type function fn)) (make-wb-map (WB-Map-Tree-Compose (wb-map-contents m) fn) (wb-map-org (empty-wb-map nil (key-compare-fn-name m) val-compare-fn-name)) - (funcall fn (map-default m)))) + (let ((dflt1 (map-default m))) + (if (eq dflt1 'no-default) 'no-default + (funcall fn dflt1))))) -(defmethod convert ((to-type (eql 'map)) (m map) &key) +(define-convert-methods (map fset2:map) ((m map) &key) m) (defmethod convert ((to-type (eql 'wb-map)) (m wb-map) @@ -3795,6 +4186,19 @@ (defmethod convert ((to-type (eql 'wb-map)) (m wb-map) (let ((tree nil)) (Do-WB-Map-Tree-Pairs (k v (wb-map-contents m) tree) (setq tree (WB-Map-Tree-With tree k v key-compare-fn val-compare-fn)))))) +(defmethod convert ((to-type (eql 'fset2:wb-map)) (m wb-map) + &key (default nil default?) no-default? key-compare-fn-name val-compare-fn-name) + "The result uses `default' if supplied, otherwise has the same default as `m'." + (when (and default? no-default?) + (error "Both a default and `no-default?' specified")) + (convert-to-wb-map m (if default? default (if no-default? 'no-default (map-default m))) + (let ((m-tmorg (wb-map-org m))) + (or (eq m-tmorg tmorg) + (and (eq key-compare-fn (tree-map-org-key-compare-fn m-tmorg)) + (eq val-compare-fn (tree-map-org-val-compare-fn m-tmorg))))) + (let ((tree nil)) + (Do-WB-Map-Tree-Pairs (k v (wb-map-contents m) tree) + (setq tree (WB-Map-Tree-With tree k v key-compare-fn val-compare-fn)))))) (defmethod convert ((to-type (eql 'list)) (m map) &key (pair-fn #'cons)) (let ((result nil)) @@ -3820,15 +4224,20 @@ (defmethod convert ((to-type (eql 'set)) (m map) &key (pair-fn #'cons)) (do-map (key val m) (setq result (WB-Set-Tree-With result (funcall pair-fn key val) #'compare))) (make-wb-set result))) +(defmethod convert ((to-type (eql 'fset2:set)) (m map) &key (pair-fn #'cons)) + (let ((result nil)) + (do-map (key val m) + (setq result (ch-set-tree-with result (funcall pair-fn key val) #'hash-value #'compare))) + (make-ch-set result +fset-default-hash-set-org+))) ;;; &&& Plist support? (defmethod convert ((to-type (eql 'map)) (l list) &key (key-fn #'car) (value-fn #'cdr) input-sorted?) (wb-map-from-sequence l key-fn value-fn input-sorted?)) -(defmethod convert ((to-type (eql 'wb-map)) (l list) - &key (key-fn #'car) (value-fn #'cdr) input-sorted? - key-compare-fn-name val-compare-fn-name) +(define-convert-methods (wb-map fset2:wb-map) ((l list) + &key (key-fn #'car) (value-fn #'cdr) input-sorted? + key-compare-fn-name val-compare-fn-name) (wb-map-from-sequence l key-fn value-fn input-sorted? key-compare-fn-name val-compare-fn-name)) (defmethod convert ((to-type (eql 'map)) (s seq) @@ -3836,19 +4245,19 @@ (defmethod convert ((to-type (eql 'map)) (s seq) (with-default (wb-map-from-sequence s key-fn value-fn input-sorted?) (seq-default s))) -(defmethod convert ((to-type (eql 'wb-map)) (s seq) - &key (key-fn #'car) (value-fn #'cdr) input-sorted? - key-compare-fn-name val-compare-fn-name) +(define-convert-methods (wb-map fset2:wb-map) + ((s seq) &key (key-fn #'car) (value-fn #'cdr) input-sorted? + key-compare-fn-name val-compare-fn-name) (with-default (wb-map-from-sequence s key-fn value-fn input-sorted? key-compare-fn-name val-compare-fn-name) - (seq-default s))) + (seq-default s))) (defmethod convert ((to-type (eql 'map)) (s sequence) &key (key-fn #'car) (value-fn #'cdr) input-sorted?) (wb-map-from-sequence s key-fn value-fn input-sorted?)) -(defmethod convert ((to-type (eql 'wb-map)) (s sequence) - &key (key-fn #'car) (value-fn #'cdr) input-sorted? - key-compare-fn-name val-compare-fn-name) +(define-convert-methods (wb-map fset2:wb-map) + ((s sequence) &key (key-fn #'car) (value-fn #'cdr) input-sorted? + key-compare-fn-name val-compare-fn-name) (wb-map-from-sequence s key-fn value-fn input-sorted? key-compare-fn-name val-compare-fn-name)) (defun wb-map-from-sequence (s key-fn value-fn input-sorted? &optional key-compare-fn-name val-compare-fn-name) @@ -3864,10 +4273,10 @@ (defmethod convert ((to-type (eql 'wb-map)) (s sequence) (WB-Map-Tree-From-Iterable (iterator s) key-fn value-fn key-compare-fn val-compare-fn)))))) -(defmethod convert ((to-type (eql 'map)) (b bag) &key) +(define-convert-methods (map fset2:map) ((b bag) &key) (convert 'wb-map b)) -(defmethod convert ((to-type (eql 'wb-map)) (b bag) &key key-compare-fn-name val-compare-fn-name) +(define-convert-methods (wb-map fset2:wb-map) ((b bag) &key key-compare-fn-name val-compare-fn-name) ;; &&& If desired, we can easily make a very fast version of this -- all it has to do is ;; build new interior nodes, reusing the leaf vectors. (But only if the compare-fns match.) (convert-to-wb-map b nil nil @@ -3875,10 +4284,10 @@ (defmethod convert ((to-type (eql 'wb-map)) (b bag) &key key-compare-fn-name val (do-bag-pairs (x n b tree) (setq tree (WB-Map-Tree-With tree x n key-compare-fn val-compare-fn)))))) -(defmethod convert ((to-type (eql 'map)) (ht hash-table) &key) +(define-convert-methods (map fset2:map) ((ht hash-table) &key) (convert 'wb-map ht)) -(defmethod convert ((to-type (eql 'wb-map)) (ht hash-table) &key key-compare-fn-name val-compare-fn-name) +(define-convert-methods (wb-map fset2:wb-map) ((ht hash-table) &key key-compare-fn-name val-compare-fn-name) (convert-to-wb-map ht nil nil (let ((tree nil)) (maphash (lambda (k v) @@ -3895,19 +4304,19 @@ (defmethod convert ((to-type (eql 'hash-table)) (m map) (defmethod find (item (m map) &key key test) (declare (optimize (speed 3) (safety 0))) - (let ((test (coerce-to-function-or-equal? test))) + (let ((test default? (coerce-to-function-or-equal? test))) (if key (let ((key (coerce-to-function key))) (do-map (x y m nil) (when (funcall test item (funcall key x)) (return (values x y))))) - (if (not (eq test #'equal?)) - (do-map (x y m nil) - (when (funcall test item x) - (return (values x y)))) + (if (and default? (eq (key-compare-fn m) #'compare)) (let ((val val? (lookup m item))) (if val? (values item val) - (values nil nil))))))) + (values nil nil))) + (do-map (x y m nil) + (when (funcall test item x) + (return (values x y)))))))) (defmethod find-if (pred (m map) &key key) (declare (optimize (speed 3) (safety 0))) @@ -3937,14 +4346,14 @@ (defmethod count (item (m map) &key key test) (declare (ignore y)) (when (funcall test item (funcall key x)) (incf total)))) - (if default? + (if (and default? (eq (key-compare-fn m) #'compare)) (if (lookup m item) 1 0) - (let ((total 0)) - (declare (fixnum total)) - (do-map (x y m total) - (declare (ignore y)) - (when (funcall test item x) - (incf total)))))))) + (let ((total 0)) + (declare (fixnum total)) + (do-map (x y m total) + (declare (ignore y)) + (when (funcall test item x) + (incf total)))))))) (defmethod count-if (pred (m map) &key key) (declare (optimize (speed 3) (safety 0))) @@ -3974,11 +4383,12 @@ (defmethod count-if-not (pred (m map) &key key) ((key-cf-name (tree-map-org-key-compare-fn-name tmorg)) (val-cf-name (tree-map-org-val-compare-fn-name tmorg)) ((key-default? (eq key-cf-name 'compare)) - (val-default? (eq val-cf-name 'compare))))) - (format nil " |}~:[[~:[~S~;~*~];~:[~S~;~*~]]~;~4*~]~@[/~S~]" + (val-default? (eq val-cf-name 'compare)))) + (dflt (map-default map))) + (format nil " |}~:[[~:[~S~;~*~];~:[~S~;~*~]]~;~4*~]~:[/~S~;~]" (and key-default? val-default?) key-default? key-cf-name val-default? val-cf-name - (map-default map)))) + (eq dflt 'no-default) dflt))) (do-map (x y map) (pprint-pop) (write-char #\Space stream) @@ -3989,8 +4399,10 @@ (defmethod count-if-not (pred (m map) &key key) (defmethod make-load-form ((m wb-map) &optional environment) (declare (ignore environment)) - `(convert 'wb-map ',(convert 'list m) :key-compare-fn-name ',(tree-map-org-key-compare-fn-name (wb-map-org m)) - :val-compare-fn-name ',(tree-map-org-val-compare-fn-name (wb-map-org m)))) + `(with-default (convert 'wb-map ',(convert 'list m) + :key-compare-fn-name ',(tree-map-org-key-compare-fn-name (wb-map-org m)) + :val-compare-fn-name ',(tree-map-org-val-compare-fn-name (wb-map-org m))) + ',(map-default m))) ;;; ================================================================================ @@ -4008,6 +4420,9 @@ (defstruct (hash-map-org (val-compare-fn nil :type function :read-only t) (val-hash-fn nil :type function :read-only t)) +(defparameter +fset-default-hash-map-org+ + (make-hash-map-org 'compare #'compare #'hash-value 'compare #'compare #'hash-value)) + (declaim (inline make-ch-map)) (defstruct (ch-map @@ -4019,17 +4434,37 @@ (defstruct (ch-map (contents nil :read-only t) (org nil :type hash-map-org :read-only t)) -(defparameter *empty-ch-map* - (make-ch-map nil (make-hash-map-org 'compare #'compare #'hash-value 'compare #'compare #'hash-value) - nil)) +(defparameter +empty-ch-map+ (make-ch-map nil +fset-default-hash-map-org+ nil)) + +(defparameter +empty-ch-map/no-default+ (make-ch-map nil +fset-default-hash-map-org+ 'no-default)) -(declaim (inline empty-ch-map)) +(declaim (inline fset2:empty-map)) +(defun fset2:empty-map (&key (default nil default?) no-default?) + "Returns an empty map of the default implementation, with the specified +default or lack of default." + (empty-ch-map-internal (fset2-default default? default no-default?) nil nil)) + +(declaim (inline empty-ch-map fset2:empty-ch-map)) (defun empty-ch-map (&optional default key-compare-fn-name val-compare-fn-name) (if (and (null key-compare-fn-name) (null val-compare-fn-name)) (if (null default) - *empty-ch-map* - (make-ch-map nil (ch-map-org *empty-ch-map*) default)) + +empty-ch-map+ + (make-ch-map nil +fset-default-hash-map-org+ default)) (empty-ch-custom-map default (or key-compare-fn-name 'compare) (or val-compare-fn-name 'compare)))) +(defun fset2:empty-ch-map (&key (default nil default?) no-default? key-compare-fn-name val-compare-fn-name) + "Returns an empty ch-map with the specified default and comparison functions. +The map's default is `nil' unless a different default is supplied, or +`no-default?' is true." + (empty-ch-map-internal (fset2-default default? default no-default?) key-compare-fn-name val-compare-fn-name)) + +(defun empty-ch-map-internal (default key-compare-fn-name val-compare-fn-name) + (cond ((or key-compare-fn-name val-compare-fn-name) + (empty-ch-custom-map default (or key-compare-fn-name 'compare) (or val-compare-fn-name 'compare))) + ((null default) + +empty-ch-map+) + ((eq default 'no-default) + +empty-ch-map/no-default+) + (t (make-ch-map nil +fset-default-hash-map-org+ default)))) (deflex +empty-ch-custom-map-cache+ (make-hash-table :test 'equal)) @@ -4041,9 +4476,8 @@ (defstruct (ch-map (symbol-package val-compare-fn-name)) () "val-compare-fn-name must be a nonnull interned symbol") (if (and (eq key-compare-fn-name 'compare) (eq val-compare-fn-name 'compare)) - (if (null default) *empty-ch-map* - (make-ch-map nil (ch-map-org *empty-ch-map*) default)) - ;; See note in `empty-wb-custom-map'. + (if (null default) +empty-ch-map+ + (make-ch-map nil +fset-default-hash-map-org+ default)) (let ((cache-key (list key-compare-fn-name val-compare-fn-name)) ((prev-instance (gethash cache-key +empty-ch-custom-map-cache+))) (key-hash-fn-name (or (get key-compare-fn-name 'hash-function) @@ -4061,17 +4495,16 @@ (defstruct (ch-map (and (eq key-compare-fn (hash-map-org-key-compare-fn prev-org)) (eq key-hash-fn (hash-map-org-key-hash-fn prev-org)) (eq val-compare-fn (hash-map-org-val-compare-fn prev-org)) - (eq val-hash-fn (hash-map-org-val-hash-fn prev-org)) - (equal?-cmp default (map-default prev-instance) val-compare-fn)))) - prev-instance + (eq val-hash-fn (hash-map-org-val-hash-fn prev-org))))) + (if (equal?-cmp default (map-default prev-instance) val-compare-fn) + prev-instance + (setf (gethash cache-key +empty-ch-custom-map-cache+) + (make-ch-map nil (ch-map-org prev-instance) default))) (setf (gethash cache-key +empty-ch-custom-map-cache+) (make-ch-map nil (make-hash-map-org key-compare-fn-name key-compare-fn key-hash-fn val-compare-fn-name val-compare-fn val-hash-fn) default)))))) -(defmethod empty-instance-function ((class-name (eql 'ch-map))) - `empty-ch-map) - (defmethod empty-map-like ((m ch-map)) (let ((hmorg (ch-map-org m))) (empty-ch-custom-map (map-default m) (hash-map-org-key-compare-fn-name hmorg) @@ -4098,6 +4531,9 @@ (defmethod val-hash-fn ((m ch-map)) (defmethod with-default ((m ch-map) new-default) (make-ch-map (ch-map-contents m) (ch-map-org m) new-default)) +(defmethod fset2:without-default ((m ch-map)) + (make-ch-map (ch-map-contents m) (ch-map-org m) 'no-default)) + (defmethod empty? ((m ch-map)) (null (ch-map-contents m))) @@ -4141,15 +4577,19 @@ (defmethod less ((m ch-map) key &optional (arg2 nil arg2?)) m (values (make-ch-map new-contents hmorg (map-default m)) range-val)))) -(defmethod lookup ((m ch-map) key) +(define-methods (lookup fset2:lookup) ((m ch-map) key) (let ((hmorg (ch-map-org m)) - ((val? val (ch-map-tree-lookup (ch-map-contents m) key - (hash-map-org-key-hash-fn hmorg) (hash-map-org-key-compare-fn hmorg))))) + ((val? val mkey (ch-map-tree-lookup (ch-map-contents m) key + (hash-map-org-key-hash-fn hmorg) (hash-map-org-key-compare-fn hmorg))))) ;; Our internal convention is the reverse of the external one. - (values (if val? val (map-default m)) val?))) + (values (if val? val + (let ((dflt (map-default m))) + (if (eq dflt 'no-default) + (error 'fset2:map-domain-error :map m :key key) + dflt))) + val? mkey))) (defmethod index ((m ch-map) key) - (declare (optimize (debug 3))) (let ((hmorg (ch-map-org m))) (ch-map-tree-index (ch-map-contents m) key (hash-map-org-key-hash-fn hmorg) (hash-map-org-key-compare-fn hmorg)))) @@ -4222,9 +4662,17 @@ (defmethod map-union ((m1 ch-map) (m2 ch-map) &optional (val-fn (fn (_v1 v2) v2) (coerce val-fn 'function) (hash-map-org-key-hash-fn hmorg) (hash-map-org-key-compare-fn hmorg) (hash-map-org-val-hash-fn hmorg) (hash-map-org-val-compare-fn hmorg)) - hmorg (let ((def1 (map-default m1)) - (def2 (map-default m2))) - (and (or def1 def2) (funcall val-fn def1 def2)))) + hmorg (let ((dflt1 (map-default m1)) + (dflt2 (map-default m2))) + (and (or dflt1 dflt2) (funcall val-fn dflt1 dflt2)))) + (call-next-method))) +(defmethod fset2:map-union ((m1 ch-map) (m2 ch-map) &optional (val-fn (fn (_v1 v2) v2))) + (if-same-ch-map-orgs (m1 m2 hmorg) + (make-ch-map (ch-map-tree-union (ch-map-contents m1) (ch-map-contents m2) + (coerce val-fn 'function) + (hash-map-org-key-hash-fn hmorg) (hash-map-org-key-compare-fn hmorg) + (hash-map-org-val-hash-fn hmorg) (hash-map-org-val-compare-fn hmorg)) + hmorg (map-union-default m1 m2 val-fn)) (call-next-method))) (defmethod map-intersection ((m1 ch-map) (m2 ch-map) &optional (val-fn (fn (_v1 v2) v2))) @@ -4237,14 +4685,31 @@ (defmethod map-intersection ((m1 ch-map) (m2 ch-map) &optional (val-fn (fn (_v1 (def2 (map-default m2))) (and (or def1 def2) (funcall val-fn def1 def2)))) (call-next-method))) +(defmethod fset2:map-intersection ((m1 ch-map) (m2 ch-map) &optional (val-fn (fn (_v1 v2) v2))) + (if-same-ch-map-orgs (m1 m2 hmorg) + (make-ch-map (ch-map-tree-intersection (ch-map-contents m1) (ch-map-contents m2) + (coerce val-fn 'function) + (hash-map-org-key-hash-fn hmorg) (hash-map-org-key-compare-fn hmorg) + (hash-map-org-val-hash-fn hmorg) (hash-map-org-val-compare-fn hmorg)) + hmorg (map-intersection-default m1 m2 val-fn)) + (call-next-method))) -(defmethod map-difference-2 ((map1 ch-map) (map2 ch-map)) - (if-same-ch-map-orgs (map1 map2 hmorg) - (let ((newc1 newc2 (ch-map-tree-diff-2 (ch-map-contents map1) (ch-map-contents map2) +(defmethod map-difference-2 ((m1 ch-map) (m2 ch-map)) + (if-same-ch-map-orgs (m1 m2 hmorg) + (let ((newc1 newc2 (ch-map-tree-diff-2 (ch-map-contents m1) (ch-map-contents m2) (hash-map-org-key-hash-fn hmorg) (hash-map-org-key-compare-fn hmorg) (hash-map-org-val-hash-fn hmorg) (hash-map-org-val-compare-fn hmorg)))) - (values (make-ch-map newc1 hmorg (map-default map1)) - (make-ch-map newc2 hmorg (map-default map2)))) + (values (make-ch-map newc1 hmorg (map-default m1)) + (make-ch-map newc2 hmorg (map-default m2)))) + (call-next-method))) +(defmethod fset2:map-difference-2 ((m1 ch-map) (m2 ch-map)) + (if-same-ch-map-orgs (m1 m2 hmorg) + (let ((newc1 newc2 (ch-map-tree-diff-2 (ch-map-contents m1) (ch-map-contents m2) + (hash-map-org-key-hash-fn hmorg) (hash-map-org-key-compare-fn hmorg) + (hash-map-org-val-hash-fn hmorg) (hash-map-org-val-compare-fn hmorg))) + (dflt1 dflt2 (map-difference-2-defaults m1 m2))) + (values (make-ch-map newc1 hmorg dflt1) + (make-ch-map newc2 hmorg dflt2))) (call-next-method))) (defmethod restrict ((m ch-map) (s ch-set)) @@ -4268,23 +4733,34 @@ (defmethod restrict-not ((m ch-map) (s ch-set)) (call-next-method)))) (defmethod compose ((map1 ch-map) (map2 map) &key val-compare-fn-name) - (let ((prototype (empty-ch-map nil (key-compare-fn-name map1) val-compare-fn-name))) - (make-ch-map (ch-map-tree-compose (ch-map-contents map1) - (fn (x) - (let ((val2 val2? (lookup map2 x))) - (if val2? val2 (map-default map2))))) - (ch-map-org prototype) - (let ((new-default? new-default - (lookup map2 (map-default map1)))) - (if new-default? new-default (map-default map2)))))) - -(defmethod compose ((m ch-map) (fn function) &key val-compare-fn-name) + (if (and (empty? map1) (eq (map-default map1) 'no-default)) + map1 + (let ((prototype (empty-ch-map nil (key-compare-fn-name map1) val-compare-fn-name))) + (make-ch-map (ch-map-tree-compose (ch-map-contents map1) + ;; This can fail if `map2' is an FSet 2 map with no default. + (fn (x) (lookup map2 x))) + (ch-map-org prototype) + (let ((new-default? new-default + (lookup map2 (map-default map1)))) + (if new-default? new-default (map-default map2))))))) +(defmethod fset2:compose ((map1 ch-map) (map2 map) &key val-compare-fn-name) + (if (and (empty? map1) (eq (map-default map1) 'no-default)) + map1 + (let ((prototype (empty-ch-map nil (key-compare-fn-name map1) val-compare-fn-name))) + (make-ch-map (ch-map-tree-compose (ch-map-contents map1) (fn (x) (lookup map2 x))) + (ch-map-org prototype) + (let ((dflt1 (map-default map1))) + (if (eq dflt1 'no-default) 'no-default + (let ((new-default new-default? (fset2:lookup map2 dflt1))) + (if new-default? new-default (map-default map2))))))))) + +(define-methods (compose fset2:compose) ((m ch-map) (fn function) &key val-compare-fn-name) (ch-map-fn-compose m fn val-compare-fn-name)) -(defmethod compose ((m ch-map) (fn symbol) &key val-compare-fn-name) +(define-methods (compose fset2:compose) ((m ch-map) (fn symbol) &key val-compare-fn-name) (ch-map-fn-compose m (symbol-function fn) val-compare-fn-name)) -(defmethod compose ((m ch-map) (s seq) &key val-compare-fn-name) +(define-methods (compose fset2:compose) ((m ch-map) (s seq) &key val-compare-fn-name) (ch-map-fn-compose m (fn (x) (lookup s x)) val-compare-fn-name)) (defun ch-map-fn-compose (m fn val-compare-fn-name) @@ -4292,7 +4768,9 @@ (defmethod compose ((m ch-map) (s seq) &key val-compare-fn-name) (let ((prototype (empty-ch-map nil (key-compare-fn-name m) val-compare-fn-name))) (make-ch-map (ch-map-tree-compose (ch-map-contents m) fn) (ch-map-org prototype) - (funcall fn (map-default m))))) + (let ((dflt1 (map-default m))) + (if (eq dflt1 'no-default) 'no-default + (funcall fn dflt1)))))) (defmethod internal-do-map ((m ch-map) elt-fn value-fn) (declare (optimize (speed 3) (safety 0)) @@ -4300,10 +4778,10 @@ (defmethod internal-do-map ((m ch-map) elt-fn value-fn) (do-ch-map-tree-pairs (x y (ch-map-contents m) (funcall value-fn)) (funcall elt-fn x y))) -(defmethod filter ((pred function) (m ch-map)) +(define-methods (filter fset2:filter) ((pred function) (m ch-map)) (ch-map-filter pred m)) -(defmethod filter ((pred symbol) (m ch-map)) +(define-methods (filter fset2:filter) ((pred symbol) (m ch-map)) (ch-map-filter (coerce-to-function pred) m)) (defun ch-map-filter (pred m) @@ -4322,9 +4800,13 @@ (defmethod filter ((pred symbol) (m ch-map)) (defmethod image ((fn function) (m ch-map) &key key-compare-fn-name val-compare-fn-name) (ch-map-image fn m key-compare-fn-name val-compare-fn-name (map-default m))) +(defmethod fset2:image ((fn function) (m ch-map) &key key-compare-fn-name val-compare-fn-name) + (ch-map-image fn m key-compare-fn-name val-compare-fn-name 'no-default)) (defmethod image ((fn symbol) (m ch-map) &key key-compare-fn-name val-compare-fn-name) (ch-map-image (coerce-to-function fn) m key-compare-fn-name val-compare-fn-name (map-default m))) +(defmethod fset2:image ((fn symbol) (m ch-map) &key key-compare-fn-name val-compare-fn-name) + (ch-map-image (coerce-to-function fn) m key-compare-fn-name val-compare-fn-name 'no-default)) (defun ch-map-image (fn m key-compare-fn-name val-compare-fn-name default) (declare (type function fn)) @@ -4349,26 +4831,21 @@ (defmethod fun-iterator ((s ch-map) &key from-end?) (ch-map-tree-rev-fun-iter (ch-map-contents s)) (ch-map-tree-fun-iter (ch-map-contents s)))) -(defmethod convert ((to-type (eql 'wb-map)) (m ch-map) &key key-compare-fn-name val-compare-fn-name) +(define-convert-methods (wb-map fset2:wb-map) ((m ch-map) &key key-compare-fn-name val-compare-fn-name) (convert-to-wb-map m nil nil (let ((tree nil)) (do-ch-map-tree-pairs (k v (ch-map-contents m) tree) (setq tree (WB-Map-Tree-With tree k v key-compare-fn val-compare-fn)))))) -(defmethod convert ((to-type (eql 'ch-map)) (m map) &key key-compare-fn-name val-compare-fn-name) - (let ((prototype (empty-ch-map nil key-compare-fn-name val-compare-fn-name)) - ((hmorg (ch-map-org prototype)) - ((key-hash-fn (hash-map-org-key-hash-fn hmorg)) - (key-compare-fn (hash-map-org-key-compare-fn hmorg)) - (val-hash-fn (hash-map-org-val-hash-fn hmorg)) - (val-compare-fn (hash-map-org-val-compare-fn hmorg)))) - (result nil)) - (do-map (k v m) - (setq result (ch-map-tree-with result k v key-hash-fn key-compare-fn val-hash-fn val-compare-fn))) - (make-ch-map result hmorg (map-default m)))) +(define-convert-methods (ch-map fset2:ch-map) ((m map) &key key-compare-fn-name val-compare-fn-name) + (convert-to-ch-map m (map-default m) nil + (let ((tree nil)) + (do-map (k v m) + (setq tree (ch-map-tree-with tree k v key-hash-fn key-compare-fn val-hash-fn val-compare-fn))) + tree))) -(defmethod convert ((to-type (eql 'ch-map)) (m ch-map) - &key (default nil default?) key-compare-fn-name val-compare-fn-name) +(define-convert-methods (ch-map fset2:ch-map) + ((m ch-map) &key (default nil default?) key-compare-fn-name val-compare-fn-name) "The result uses `default' if supplied, otherwise has the same default as `m'." (convert-to-ch-map m (if default? default (map-default m)) (let ((m-hmorg (ch-map-org m))) @@ -4382,9 +4859,8 @@ (defmethod convert ((to-type (eql 'ch-map)) (m ch-map) (setq tree (ch-map-tree-with tree k v key-hash-fn key-compare-fn val-hash-fn val-compare-fn))) tree))) -(defmethod convert ((to-type (eql 'ch-map)) (l list) - &key (key-fn #'car) (value-fn #'cdr) - key-compare-fn-name val-compare-fn-name) +(define-convert-methods (ch-map fset2:map fset2:ch-map) + ((l list) &key (key-fn #'car) (value-fn #'cdr) key-compare-fn-name val-compare-fn-name) (declare (type function key-fn value-fn)) (convert-to-ch-map l nil nil (let ((tree nil)) @@ -4393,9 +4869,8 @@ (defmethod convert ((to-type (eql 'ch-map)) (l list) key-hash-fn key-compare-fn val-hash-fn val-compare-fn))) tree))) -(defmethod convert ((to-type (eql 'ch-map)) (s seq) - &key (key-fn #'car) (value-fn #'cdr) - key-compare-fn-name val-compare-fn-name) +(define-convert-methods (ch-map fset2:map fset2:ch-map) + ((s seq) &key (key-fn #'car) (value-fn #'cdr) key-compare-fn-name val-compare-fn-name) (declare (type function key-fn value-fn)) (convert-to-ch-map l nil nil (let ((tree nil)) @@ -4404,9 +4879,8 @@ (defmethod convert ((to-type (eql 'ch-map)) (s seq) key-hash-fn key-compare-fn val-hash-fn val-compare-fn))) tree))) -(defmethod convert ((to-type (eql 'ch-map)) (s sequence) - &key (key-fn #'car) (value-fn #'cdr) - key-compare-fn-name val-compare-fn-name) +(define-convert-methods (ch-map fset2:map fset2:ch-map) + ((s sequence) &key (key-fn #'car) (value-fn #'cdr) key-compare-fn-name val-compare-fn-name) (declare (type function key-fn value-fn)) (convert-to-ch-map l nil nil (let ((tree nil)) @@ -4416,7 +4890,13 @@ (defmethod convert ((to-type (eql 'ch-map)) (s sequence) key-hash-fn key-compare-fn val-hash-fn val-compare-fn)))) tree))) -(defmethod convert ((to-type (eql 'ch-map)) (ht hash-table) &key key-compare-fn-name val-compare-fn-name) +(define-convert-methods (ch-map fset2:ch-map) ((b bag) &key key-compare-fn-name val-compare-fn-name) + (convert-to-ch-map b nil nil + (let ((tree nil)) + (do-bag-pairs (x n b tree) + (setq tree (ch-map-tree-with tree x n key-hash-fn key-compare-fn val-hash-fn val-compare-fn)))))) + +(define-convert-methods (ch-map fset2:ch-map) ((ht hash-table) &key key-compare-fn-name val-compare-fn-name) (convert-to-ch-map ht nil nil (let ((tree nil)) (maphash (lambda (k v) @@ -4431,11 +4911,12 @@ (defmethod convert ((to-type (eql 'ch-map)) (ht hash-table) &key key-compare-fn- ((key-cf-name (hash-map-org-key-compare-fn-name hmorg)) (val-cf-name (hash-map-org-val-compare-fn-name hmorg)) ((key-default? (eq key-cf-name 'compare)) - (val-default? (eq val-cf-name 'compare))))) - (format nil " |}~:[[~:[~S~;~*~];~:[~S~;~*~]]~;~4*~]~@[/~S~]" + (val-default? (eq val-cf-name 'compare)))) + (dflt (map-default map))) + (format nil " |}~:[[~:[~S~;~*~];~:[~S~;~*~]]~;~4*~]~:[/~S~;~]" (and key-default? val-default?) key-default? key-cf-name val-default? val-cf-name - (map-default map)))) + (eq dflt 'no-default) dflt))) (do-map (x y map) (pprint-pop) (write-char #\Space stream) @@ -4457,7 +4938,7 @@ (defmethod make-load-form ((m ch-map) &optional environment) (defstruct (wb-seq (:include seq) - (:constructor make-wb-seq (contents &optional default)) + (:constructor make-wb-seq (contents default)) (:predicate wb-seq?) (:print-function print-wb-seq) (:copier nil)) @@ -4467,52 +4948,98 @@ (defstruct (wb-seq (contents nil :read-only t)) -(defparameter *empty-wb-seq* (make-wb-seq nil)) +(defparameter +empty-wb-seq+ (make-wb-seq nil nil)) -(declaim (inline empty-seq)) +(defparameter +empty-wb-seq/no-default+ (make-wb-seq nil 'no-default)) + +(declaim (inline empty-seq fset2:empty-seq)) (defun empty-seq (&optional default) "Returns an empty seq of the default implementation." (if default (make-wb-seq nil default) - *empty-wb-seq*)) - -(defmethod empty-instance-function ((class-name (eql 'seq))) - 'empty-seq) - -(declaim (inline empty-wb-seq)) -(defun empty-wb-seq () + +empty-wb-seq+)) +(defun fset2:empty-seq (&key (default nil default?) no-default?) + "Returns an empty seq of the default implementation. The seq's default is +`nil' unless a different default is supplied, or `no-default?' is true." + (empty-wb-seq-internal (fset2-default default? default no-default?))) + +(declaim (inline empty-wb-seq fset2:empty-wb-seq)) +(defun empty-wb-seq (&optional default) + "Returns an empty wb-seq." + (if default (make-wb-seq nil default) + +empty-wb-seq+)) +(defun fset2:empty-wb-seq (&key (default nil default?) no-default?) "Returns an empty wb-seq." - *empty-wb-seq*) + (empty-wb-seq-internal (fset2-default default? default no-default?))) -(defmethod empty-instance-function ((class-name (eql 'wb-seq))) - 'empty-wb-seq) +(defun empty-wb-seq-internal (default) + (cond ((null default) + +empty-wb-seq+) + ((eq default 'no-default) + +empty-wb-seq/no-default+) + (t (make-wb-seq nil default)))) (defmethod empty? ((s wb-seq)) (null (wb-seq-contents s))) (defmethod default ((s seq)) - (seq-default s)) + (let ((dflt (seq-default s))) + (if (eq dflt 'no-default) (values nil nil) + (values dflt t)))) (defmethod with-default ((s wb-seq) new-default) (make-wb-seq (wb-seq-contents s) new-default)) +(defmethod fset2:without-default ((s wb-seq)) + (make-wb-seq (wb-seq-contents s) 'no-default)) + (defmethod size ((s wb-seq)) (WB-Seq-Tree-Size (wb-seq-contents s))) -(defmethod lookup ((s wb-seq) key) - (if (typep key 'fixnum) - (locally (declare (type fixnum key)) - (let ((val? val (WB-Seq-Tree-Subscript (wb-seq-contents s) key))) - (values (if val? val (seq-default s)) val?))) - (values nil nil))) +(define-condition fset2:seq-bounds-error (fset2:lookup-error) + ((fset2:seq :initarg :seq :reader fset2:seq-bounds-error-seq) + (fset2:index :initarg :index :reader fset2:seq-bounds-error-index)) + (:report (lambda (sbe stream) + (let ((*print-length* 8) + (*print-level* 3)) + (format stream "Index ~D out of bounds for seq ~A, which has no default" + (fset2:seq-bounds-error-index sbe) (fset2:seq-bounds-error-seq sbe)))))) + +(define-methods (lookup fset2:lookup) ((s wb-seq) index) + (let ((val? val (if (typep index 'fixnum) (WB-Seq-Tree-Subscript (wb-seq-contents s) index) + (values nil nil)))) + (values (if val? val + (let ((dflt (seq-default s))) + (if (eq dflt 'no-default) + (error 'fset2:seq-bounds-error :seq s :index index) + dflt))) + val?))) + +(define-condition fset2:empty-seq-error (fset2:lookup-error) + ((fset2:seq :initarg :seq :reader fset2:empty-seq-error-seq)) + (:report (lambda (sbe stream) + (let ((*print-length* 8) + (*print-level* 3)) + (format stream "Seq ~A, which has no default, is empty" + (fset2:empty-seq-error-seq sbe)))))) (defmethod first ((s wb-seq)) (let ((val? val (WB-Seq-Tree-Subscript (wb-seq-contents s) 0))) - (values (if val? val (seq-default s)) val?))) + (values (if val? val + (let ((dflt (seq-default s))) + (if (eq dflt 'no-default) + (error 'fset2:empty-seq-error :seq s) + dflt))) + 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 (if val? val (seq-default s)) val?))) + (values (if val? val + (let ((dflt (seq-default s))) + (if (eq dflt 'no-default) + (error 'fset2:empty-seq-error :esq s) + dflt))) + val?))) (defmethod with-first ((s wb-seq) val) (make-wb-seq (WB-Seq-Tree-Insert (wb-seq-contents s) 0 val) @@ -4538,12 +5065,16 @@ (defmethod with ((s wb-seq) idx &optional (val nil val?)) (let ((tree (wb-seq-contents s)) ((size (WB-Seq-Tree-Size tree)))) (when (< idx -1) + (when (eq (seq-default s) 'no-default) + (error 'fset2:seq-bounds-error :seq s :index idx)) (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) + (when (eq (seq-default s) 'no-default) + (error 'fset2:seq-bounds-error :seq s :index idx)) (setq tree (WB-Seq-Tree-Concat tree (WB-Seq-Tree-From-Vector (make-array (- idx size) :initial-element (seq-default s))))) @@ -4559,12 +5090,16 @@ (defmethod insert ((s wb-seq) idx val) (let ((tree (wb-seq-contents s)) ((size (WB-Seq-Tree-Size tree)))) (when (< idx 0) + (when (eq (seq-default s) 'no-default) + (error 'fset2:seq-bounds-error :seq s :index idx)) (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) + (when (eq (seq-default s) 'no-default) + (error 'fset2:seq-bounds-error :seq s :index idx)) (setq tree (WB-Seq-Tree-Concat tree (WB-Seq-Tree-From-Vector (make-array (- idx size) :initial-element (seq-default s))))) @@ -4577,17 +5112,19 @@ (defmethod splice ((s wb-seq) idx subseq) ((size (WB-Seq-Tree-Size tree))) (subseq-tree (wb-seq-contents (convert 'wb-seq subseq)))) (when (< idx 0) + (when (eq (seq-default s) 'no-default) + (error 'fset2:seq-bounds-error :seq s :index idx)) (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) + (when (eq (seq-default s) 'no-default) + (error 'fset2:seq-bounds-error :seq s :index idx)) (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-array (- idx size) :initial-element (seq-default s)))))) (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))) @@ -4602,7 +5139,7 @@ (defmethod less ((s wb-seq) idx &optional (arg2 nil arg2?)) (make-wb-seq (WB-Seq-Tree-Remove tree idx) (seq-default s)) s))) -(defmethod concat ((s1 seq) &rest seqs) +(define-methods (concat fset2: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))))) @@ -4639,17 +5176,8 @@ (defmethod domain ((s wb-seq)) (defmethod range ((s wb-seq)) (convert 'set s)) -(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-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 'list)) (s wb-seq) &key) + (WB-Seq-Tree-To-List (wb-seq-contents s))) (defmethod convert ((to-type (eql 'vector)) (s wb-seq) &key) (WB-Seq-Tree-To-Vector (wb-seq-contents s))) @@ -4657,25 +5185,42 @@ (defmethod convert ((to-type (eql 'vector)) (s wb-seq) &key) (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))) +(define-convert-methods (seq fset2:seq) ((s seq) &key) + s) -(defmethod convert ((to-type (eql 'wb-seq)) (l list) &key) - (make-wb-seq (WB-Seq-Tree-From-List l))) +(define-convert-methods (wb-seq fset2:wb-seq) ((s wb-seq) &key) + s) -(defmethod convert ((to-type (eql 'list)) (s wb-seq) &key) - (WB-Seq-Tree-To-List (wb-seq-contents s))) +(define-convert-methods (seq wb-seq) ((vec vector) &key) + (make-wb-seq (WB-Seq-Tree-From-Vector vec) nil)) + +(define-convert-methods (fset2:seq fset2:wb-seq) ((vec vector) &key (default nil default?) no-default?) + (make-wb-seq (WB-Seq-Tree-From-Vector vec) (fset2-default default? default no-default?))) + +(define-convert-methods (seq wb-seq) ((l list) &key reverse?) + (make-wb-seq (if reverse? (WB-Seq-Tree-From-List-Reverse l) + (WB-Seq-Tree-From-List l)) + nil)) + +(define-convert-methods (fset2:seq fset2:wb-seq) ((l list) &key reverse? (default nil default?) no-default?) + (make-wb-seq (if reverse? (WB-Seq-Tree-From-List-Reverse l) + (WB-Seq-Tree-From-List l)) + (fset2-default default? default no-default?))) + +(define-convert-methods (seq wb-seq) ((s set) &key) + (make-wb-seq (wb-seq-tree-from-iterable (iterator s) (size s)) nil)) -(defmethod convert ((to-type (eql 'seq)) (s set) &key) - (make-wb-seq (wb-seq-tree-from-iterable (iterator s) (size s)))) +(define-convert-methods (fset2:seq fset2:wb-seq) ((s set) &key (default nil default?) no-default?) + (make-wb-seq (wb-seq-tree-from-iterable (iterator s) (size s)) (fset2-default default? default no-default?))) -(defmethod convert ((to-type (eql 'wb-seq)) (s set) &key) - (make-wb-seq (wb-seq-tree-from-iterable (iterator s) (size s)))) +(define-convert-methods (seq wb-seq) ((b bag) &key pairs? (pair-fn #'cons)) + (bag-to-seq b pairs? pair-fn nil)) -(defmethod convert ((to-type (eql 'seq)) (b bag) &key pairs? (pair-fn #'cons)) - (convert 'wb-seq b :pairs? pairs? :pair-fn pair-fn)) +(define-convert-methods (fset2:seq fset2:wb-seq) + ((b bag) &key pairs? (pair-fn #'cons) (default nil default?) no-default?) + (bag-to-seq b pairs? pair-fn (fset2-default default? default no-default?))) -(defmethod convert ((to-type (eql 'wb-seq)) (b bag) &key pairs? (pair-fn #'cons)) +(defun bag-to-seq (b pairs? pair-fn default) (make-wb-seq (wb-seq-tree-from-iterable (if pairs? (let ((it (iterator b :pairs? t))) (lambda (op) @@ -4684,19 +5229,23 @@ (defmethod convert ((to-type (eql 'wb-seq)) (b bag) &key pairs? (pair-fn #'cons) (funcall pair-fn v n)) (funcall it op)))) (iterator b)) - (if pairs? (set-size b) (size b))))) + (if pairs? (set-size b) (size b))) + default)) -(defmethod convert ((to-type (eql 'seq)) (m map) &key (pair-fn #'cons)) - (convert 'wb-seq m :pair-fn pair-fn)) +(define-convert-methods (seq wb-seq) ((m map) &key (pair-fn #'cons)) + (map-to-seq m pair-fn nil)) -(defmethod convert ((to-type (eql 'wb-seq)) (m map) &key (pair-fn #'cons)) +(define-convert-methods (fset2:seq fset2:wb-seq) ((m map) &key (pair-fn #'cons)) + (map-to-seq m pair-fn (map-default m))) + +(defun map-to-seq (m pair-fn default) (make-wb-seq (wb-seq-tree-from-iterable (let ((m-it (iterator m))) (lambda (op) (ecase op (:get (let ((k v (funcall m-it ':get))) (funcall pair-fn k v)))))) (size m)) - (map-default m))) + default)) ;;; Prior to FSet 1.4.0, this method ignored the defaults, so two seqs with the same ;;; elements but different defaults compared `:equal'. While that was clearly a bug, @@ -4712,6 +5261,9 @@ (defmethod compare ((s1 wb-seq) (s2 wb-seq)) ':unequal ':equal)))))) +(defun compare-seqs-lexicographically (a b &optional (val-compare-fn #'compare)) + (WB-Seq-Tree-Compare-Lexicographically (wb-seq-contents a) (wb-seq-contents b) val-compare-fn)) + (defmethod hash-value ((s wb-seq)) ;; Currently doing bounded hashing, but &&& am considering changing it to do caching ;; with incremental update. @@ -4746,7 +5298,6 @@ (defmethod internal-do-seq ((s wb-seq) elt-fn value-fn index? (declare (optimize (speed 3) (safety 0)) (type function elt-fn value-fn)) (assert (and (typep start 'fixnum) (typep end 'fixnum))) - ;; Expect Python notes about "can't use known return convention" (if index? (let ((i start)) (declare (type fixnum i)) @@ -4777,20 +5328,22 @@ (defmethod range-contains? ((s seq) x) (when (equal? y x) (return t)))) -(defmethod filter ((fn function) (s seq)) +(define-methods (filter fset2:filter) ((fn function) (s seq)) (seq-filter fn s)) -(defmethod filter ((fn symbol) (s seq)) +(define-methods (filter fset2:filter) ((fn symbol) (s seq)) (seq-filter (coerce-to-function fn) s)) (defmethod filter ((fn map) (s seq)) (seq-filter #'(lambda (x) (lookup fn x)) s)) +(defmethod fset2:filter ((fn map) (s seq)) + (seq-filter #'(lambda (x) (fset2:lookup fn x)) s)) -(defmethod filter ((fn set) (s seq)) - (seq-filter #'(lambda (x) (lookup fn x)) s)) +(define-methods (filter fset2:filter) ((fn set) (s seq)) + (seq-filter #'(lambda (x) (contains? fn x)) s)) -(defmethod filter ((fn bag) (s seq)) - (seq-filter #'(lambda (x) (lookup fn x)) s)) +(define-methods (filter fset2:filter) ((fn bag) (s seq)) + (seq-filter #'(lambda (x) (contains? fn x)) s)) (defun seq-filter (fn s) (declare (optimize (speed 3) (safety 0)) @@ -4802,20 +5355,22 @@ (defmethod filter ((fn bag) (s seq)) (make-wb-seq (WB-Seq-Tree-From-List (nreverse result)) (seq-default s)))) -(defmethod partition ((fn function) (s seq)) +(define-methods (partition fset2:partition) ((fn function) (s seq)) (seq-partition fn s)) -(defmethod partition ((fn symbol) (s seq)) +(define-methods (partition fset2:partition) ((fn symbol) (s seq)) (seq-partition (coerce-to-function fn) s)) (defmethod partition ((fn map) (s seq)) (seq-partition #'(lambda (x) (lookup fn x)) s)) +(defmethod fset2:partition ((fn map) (s seq)) + (seq-partition #'(lambda (x) (fset2:lookup fn x)) s)) -(defmethod partition ((fn set) (s seq)) - (seq-partition #'(lambda (x) (lookup fn x)) s)) +(define-methods (partition fset2:partition) ((fn set) (s seq)) + (seq-partition #'(lambda (x) (contains? fn x)) s)) -(defmethod partition ((fn bag) (s seq)) - (seq-partition #'(lambda (x) (lookup fn x)) s)) +(define-methods (partition fset2:partition) ((fn bag) (s seq)) + (seq-partition #'(lambda (x) (contains? fn x)) s)) (defun seq-partition (fn s) (declare (optimize (speed 3) (safety 0)) @@ -4849,21 +5404,31 @@ (defmethod sort-and-group ((s seq) pred &key key) (with-last result group)))) (defmethod image ((fn function) (s seq) &key) - (seq-image fn s)) + (seq-image fn s (seq-default s))) +(defmethod fset2:image ((fn function) (s seq) &key (default nil default?) no-default?) + (seq-image fn s (fset2-default default? default no-default?))) (defmethod image ((fn symbol) (s seq) &key) - (seq-image (coerce-to-function fn) s)) + (seq-image (coerce-to-function fn) s (seq-default s))) +(defmethod fset2:image ((fn symbol) (s seq) &key (default nil default?) no-default?) + (seq-image (coerce-to-function fn) s (fset2-default default? default no-default?))) (defmethod image ((fn map) (s seq) &key) - (seq-image #'(lambda (x) (lookup fn x)) s)) + (seq-image #'(lambda (x) (lookup fn x)) s (seq-default s))) +(defmethod fset2:image ((fn map) (s seq) &key (default nil default?) no-default?) + (seq-image #'(lambda (x) (fset2:lookup fn x)) s (fset2-default default? default no-default?))) (defmethod image ((fn set) (s seq) &key) - (seq-image #'(lambda (x) (lookup fn x)) s)) + (seq-image #'(lambda (x) (lookup fn x)) s (seq-default s))) +(defmethod fset2:image ((fn set) (s seq) &key (default nil default?) no-default?) + (seq-image #'(lambda (x) (fset2:lookup fn x)) s (fset2-default default? default no-default?))) (defmethod image ((fn bag) (s seq) &key) - (seq-image #'(lambda (x) (lookup fn x)) s)) + (seq-image #'(lambda (x) (lookup fn x)) s (seq-default s))) +(defmethod fset2:image ((fn bag) (s seq) &key (default nil default?) no-default?) + (seq-image #'(lambda (x) (fset2:lookup fn x)) s (fset2-default default? default no-default?))) -(defun seq-image (fn s) +(defun seq-image (fn s default) (declare (optimize (speed 3) (safety 0)) (type function fn)) ;; This is not bad, but we could do better by walking the tree of `s' and building @@ -4871,8 +5436,7 @@ (defmethod image ((fn bag) (s seq) &key) (let ((result nil)) (do-seq (x s) (push (funcall fn x) result)) - (make-wb-seq (WB-Seq-Tree-From-List (nreverse result)) - (seq-default s)))) + (make-wb-seq (WB-Seq-Tree-From-List (nreverse result)) default))) (defmethod reduce ((fn function) (s seq) &key key (initial-value nil init?) @@ -4895,21 +5459,11 @@ (defmethod reduce ((fn symbol) (s seq) (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)))))) + (do-seq (x s :start start :end end :from-end? from-end?) + (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) @@ -4989,7 +5543,7 @@ (defmethod count-if-not (pred (s seq) &key key start end from-end) (defmethod position (item (s seq) &key key test start end from-end) (declare (optimize (speed 3) (safety 0)) (type (or fixnum null) start end)) - (let ((test default? (coerce-to-function-or-equal? test)) + (let ((test (coerce-to-function-or-equal? test)) (start (or start 0)) ((pos start)) (end (or end (size s)))) @@ -4999,24 +5553,14 @@ (defmethod position (item (s seq) &key key test start end from-end) (if from-end (the fixnum (+ start (the fixnum (- end pos 1)))) pos)))) (if key (let ((key (coerce-to-function key))) - (if default? - (do-seq (x s :start start :end end :from-end? from-end) - (when (equal? item (funcall key x)) - (done)) - (incf pos)) - (do-seq (x s :start start :end end :from-end? from-end) - (when (funcall test item (funcall key x)) - (done)) - (incf pos)))) - (if default? - (do-seq (x s :start start :end end :from-end? from-end) - (when (equal? item x) - (done)) - (incf pos)) (do-seq (x s :start start :end end :from-end? from-end) - (when (funcall test item x) + (when (funcall test item (funcall key x)) (done)) - (incf pos)))))))) + (incf pos))) + (do-seq (x s :start start :end end :from-end? from-end) + (when (funcall test item x) + (done)) + (incf pos))))))) (defmethod position-if (pred (s seq) &key key start end from-end) (declare (optimize (speed 3) (safety 0)) @@ -5136,17 +5680,19 @@ (defmethod substitute-if-not (newitem pred (s seq) &key key start end from-end c (defun print-wb-seq (seq stream level) (declare (ignore level)) - (pprint-logical-block (stream nil :prefix "#[") + (pprint-logical-block (stream nil :prefix "#[" + :suffix (let ((dflt (seq-default seq))) + (format nil " ]~:[/~A~;~]" + (eq dflt 'no-default) dflt))) (do-seq (x seq) (pprint-pop) (write-char #\Space stream) (pprint-newline :linear stream) - (write x :stream stream)) - (format stream " ]~:[~;/~:*~S~]" (seq-default seq)))) + (write x :stream stream)))) (defmethod make-load-form ((s wb-seq) &optional environment) (declare (ignore environment)) - `(convert 'wb-seq ',(convert 'list s))) + `(with-default (convert 'wb-seq ',(convert 'list s)) ',(seq-default s))) ;;; ================================================================================ @@ -5163,13 +5709,13 @@ (defmethod empty? ((s sequence)) (defmethod size ((s sequence)) (length s)) -(defmethod lookup ((s sequence) (idx integer)) +(define-methods (lookup fset2:lookup) ((s sequence) (idx integer)) (values (elt s idx) t)) -(defmethod lookup ((fn function) (v t)) +(define-methods (lookup fset2:lookup) ((fn function) (v t)) (funcall fn v)) -(defmethod lookup ((fn symbol) (v t)) +(define-methods (lookup fset2:lookup) ((fn symbol) (v t)) (funcall fn v)) (defmethod convert ((to-type (eql 'list)) (v vector) &key) @@ -5179,39 +5725,32 @@ (defmethod convert ((to-type (eql 'vector)) (l list) &key) (coerce l 'vector)) (defmethod convert ((to-type (eql 'list)) (s sequence) &key) - (let ((result nil)) - (dotimes (i (length s)) - (push (elt s i) result)) - (nreverse result))) + (coerce s 'list)) (defmethod convert ((to-type (eql 'vector)) (s sequence) &key) - (let* ((seq-len (length s)) - (result (make-array seq-len))) - (dotimes (i seq-len result) - (setf (svref result i) (elt s i))))) + (coerce s 'vector)) (declaim (inline compose-with-key-fn)) (defun compose-with-key-fn (fn collection) + (declare (type function fn)) (lambda (key) (lookup collection (funcall fn key)))) -(defmethod compose ((fn function) (m map) &key) - (compose-with-key-fn fn m)) - -(defmethod compose ((fn symbol) (m map) &key) +(define-methods (compose fset2:compose) ((fn function) (m map) &key) (compose-with-key-fn fn m)) -(defmethod compose ((fn function) (s seq) &key) - (compose-with-key-fn fn s)) +(define-methods (compose fset2:compose) ((fn symbol) (m map) &key) + (compose-with-key-fn (coerce fn 'function) m)) -(defmethod compose ((fn symbol) (s seq) &key) +(define-methods (compose fset2:compose) ((fn function) (s seq) &key) (compose-with-key-fn fn s)) +(define-methods (compose fset2:compose) ((fn symbol) (s seq) &key) + (compose-with-key-fn (coerce fn 'function) s)) ;;; ================================================================================ ;;; Miscellany -;;; Oooops -- I somehow thought CL already had this. (define-condition simple-program-error (simple-condition program-error) ()) diff --git a/Code/macros.lisp b/Code/macros.lisp index 0bf20e097ebcfb769dd085c2da2c2662337f2bda..becfaba9ff463756f62a0da65e63c82e4227e800 100644 --- a/Code/macros.lisp +++ b/Code/macros.lisp @@ -24,6 +24,15 @@ ;; seems to give better code, at least on SBCL on AMD64. `(1- (incf ,place ,delta))) +(defmacro n-values (n expr) + "Forces the return of exactly `n' values from `expr'. `n' must be a compile-time +constant." + (assert (typep n 'fixnum)) + (let ((vars (gmap (:result list) (fn (_i) (gensym)) + (:index 0 n)))) + `(multiple-value-bind ,vars ,expr + (values . ,vars)))) + ;;; ================================================================================ ;;; Macros related to order.lisp @@ -85,6 +94,8 @@ (defmethod compare ((f1 frob) (f2 frob)) ((and (listp fn) (eq (car fn) 'lambda)) `(,fn ,arg)) + ((and (listp fn) (eq (car fn) 'fn)) + (call (macroexpand fn) arg)) ((and (listp fn) (eq (car fn) 'quote) (symbolp (cadr fn))) @@ -168,6 +179,23 @@ (defmethod compare ((f1 frob) (f2 frob)) been generated, and against which subsequent such methods will be generated. This is a list in reverse order.")) +(defmacro define-generics (names parameter-list &body body) + `(progn . ,(mapcar (fn (name) + `(defgeneric ,name ,parameter-list . ,body)) + names))) + +(defmacro define-methods (methods parameter-list &body body) + `(progn . ,(mapcar (fn (method) + `(defmethod ,method ,parameter-list . ,body)) + methods))) + +(defmacro define-convert-methods (to-types parameter-list-rest &body body) + `(progn . ,(mapcar (fn (to-type) + `(defmethod convert ,(cons `(to-type (eql ',to-type)) + parameter-list-rest) + . ,body)) + to-types))) + ;;; 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 @@ -254,7 +282,7 @@ (define-class part ((part-number :equality ...) ...))" (defmethod compare ((a ,class) (b ,class)) (compare-slots a b . ,slots/accessors)) (defmethod hash-value ((x ,class)) - (hash-slots x . ,(if (eq (last slots/accessors) ':eql) (butlast slots/accessors) + (hash-slots x . ,(if (eq (car (cl:last slots/accessors)) ':eql) (butlast slots/accessors) slots/accessors))))) (defmacro define-comparison-slots (class &rest slots/accessors) @@ -263,6 +291,23 @@ (defmethod hash-value ((x ,class)) ;;; &&& Add `(:cache slot/acc)' syntax for auto-caching (defmacro hash-slots (obj &rest slots/accessors) + "A handy macro for writing the bodies of `hash-value' methods for user classes. +Computes a hash value by combining the hash values of the specified slots +and/or accessors applied to the object. For standard classes, best performance +is gotten by supplying the slot names as \(quoted\) symbols; for structure +classes, it is best to supply accessor functions. \(Actually, any function on +the object can be used.\) For example: + + (defstruct point x y) + (defmethod hash-value ((p point)) + (hash-slots p #'x #'y)) + + (defclass part () ((part-number ...) ...)) + (defmethod hash-value ((p part)) + (hash-slots part 'part-number)) + +In most cases, it is better to use `define-equality-slots' instead of calling +this macro directly, to keep the `hash-value' and `compare' methods consistent." (unless slots/accessors (error "At least one slot/accessor must be supplied")) (let ((x-var (gensymx #:x-))) @@ -281,6 +326,8 @@ (defmethod hash-value ((x ,class)) ((and (listp fn) (eq (car fn) 'lambda)) `(,fn ,arg)) + ((and (listp fn) (eq (car fn) 'fn)) + (call (macroexpand fn) arg)) ((and (listp fn) (eq (car fn) 'quote) (symbolp (cadr fn))) @@ -334,7 +381,9 @@ (defmethod hash-value ((x ,class)) (defmacro internal-concat (&rest args) `(concat . ,args)) (defmacro internal-insert (&rest args) - `(insert . ,args))) + `(insert . ,args)) + (defmacro internal-splice (&rest args) + `(splice . ,args))) #-FSet-Use-Package-Locks (progn @@ -391,7 +440,10 @@ (defmethod hash-value ((x ,class)) (apply #'concat seq1 seqs)) (declaim (inline internal-insert)) (defun internal-insert (seq idx val) - (insert seq idx val))) + (insert seq idx val)) + (declaim (inline internal-splice)) + (defun internal-splice (seq idx val) + (splice seq idx val))) ;;; -------------------------------- ;;; Modify macros @@ -495,6 +547,9 @@ (define-modify-macro prependf (seq) (define-modify-macro insertf (idx value) internal-insert) +(define-modify-macro splicef (idx subseq) + internal-splice) + (declaim (inline xconcat)) (defun xconcat (seq1 seq2) (concat seq2 seq1)) @@ -509,20 +564,31 @@ (define-setf-expander lookup (collection key &environment env) sequence; it modifies the place (generalized variable) HOLDING the map or sequence (just like `(setf (ldb ...) ...)'). That is, the `collection' subform must be `setf'able itself." + (expand-setf-of-lookup 'lookup collection key env)) +(define-setf-expander fset2:lookup (collection key &environment env) + "Adds a pair to a map or updates an existing pair, or adds an element to a +sequence or updates an existing element. This does NOT modify the map or +sequence; it modifies the place (generalized variable) HOLDING the map or +sequence (just like `(setf (ldb ...) ...)'). That is, the `collection' subform +must be `setf'able itself." + (expand-setf-of-lookup 'fset2:lookup collection key env)) + +(defun expand-setf-of-lookup (name collection key env) (let ((temps vals stores store-form access-form (get-setf-expansion collection env)) (key-temp (gensymx #:key-)) (val-temp (gensymx #:val-)) - ((coll-temp (car stores)))) + ((coll-temp (car stores))) + (lookup-fn (intern (string 'internal-lookup) (symbol-package name)))) (when (cdr stores) - (error "Too many values required in `setf' of `lookup'")) + (error "Too many values required in `setf' of `~A'" name)) (values (cons key-temp temps) (cons key vals) (list val-temp) `(let ((,coll-temp (internal-with ,access-form ,key-temp ,val-temp))) ,store-form ,val-temp) - `(internal-lookup ,access-form ,key-temp)))) + `(,lookup-fn ,access-form ,key-temp)))) (defmacro @ (fn-or-collection &rest args) "A little hack with two purposes: (1) to make it easy to make FSet maps @@ -537,14 +603,32 @@ (define-setf-expander lookup (collection key &environment env) side-effect-free functions. Also, though this doc string has spoken only of FSet maps, `@' can be used with any type that `lookup' works on. Can be used with `setf', but only on collections, not functions, of course." + (expand-@ '@ fn-or-collection args)) +(defmacro fset2:@ (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 +pain of writing higher-order code in a two-namespace Lisp like Common Lisp. +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 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 +FSet maps, `@' can be used with any type that `lookup' works on. Can be used +with `setf', but only on collections, not functions, of course." + (expand-@ 'fset2:@ fn-or-collection args)) + +(defun expand-@ (name fn-or-collection args) (if (= (length args) 1) (let ((fn-var (gensymx #:fn-)) - (arg-var (gensymx #:arg-))) + (arg-var (gensymx #:arg-)) + (lookup-fn (intern (string 'internal-lookup) (symbol-package name)))) `(let ((,fn-var ,fn-or-collection) (,arg-var ,(car args))) (if (functionp ,fn-var) (funcall ,fn-var ,arg-var) - (internal-lookup ,fn-var ,arg-var)))) + (,lookup-fn ,fn-var ,arg-var)))) `(funcall ,fn-or-collection . ,args))) ;;; Have to do the same thing for `@', since `setf' would not know what to @@ -555,24 +639,21 @@ (define-setf-expander @ (collection key &environment env) sequence; it modifies the place (generalized variable) HOLDING the map or sequence (just like `(setf (ldb ...) ...)'). That is, the `collection' subform must be `setf'able itself." - (let ((temps vals stores store-form access-form - (get-setf-expansion collection env)) - (key-temp (gensymx #:key-)) - (val-temp (gensymx #:val-)) - ((coll-temp (car stores)))) - (when (cdr stores) - (error "Too many values required in `setf' of `@'")) - (values (cons key-temp temps) - (cons key vals) - (list val-temp) - `(let ((,coll-temp (internal-with ,access-form ,key-temp ,val-temp))) - ,store-form - ,val-temp) - `(internal-lookup ,access-form ,key-temp)))) + (expand-setf-of-lookup '@ collection key env)) +(define-setf-expander fset2:@ (collection key &environment env) + "Adds a pair to a map or updates an existing pair, or adds an element to a +sequence or updates an existing element. This does NOT modify the map or +sequence; it modifies the place (generalized variable) HOLDING the map or +sequence (just like `(setf (ldb ...) ...)'). That is, the `collection' subform +must be `setf'able itself." + (expand-setf-of-lookup 'fset2:@ collection key env)) (declaim (inline internal-lookup)) (defun internal-lookup (&rest args) (apply #'lookup args)) +(declaim (inline fset2::internal-lookup)) +(defun fset2::internal-lookup (&rest args) + (apply #'fset2:lookup args)) ;;; -------------------------------- @@ -765,19 +846,34 @@ (define-setf-expander @ (collection key &environment env) "Yields the elements of `set'." `((the function (iterator ,set)) #'(lambda (it) (funcall it ':done?)) - #'(lambda (it) (funcall it ':get)))) + #'(lambda (it) (funcall it ':get)) + nil nil nil + (do-set ,set))) + +(gmap:def-arg-type-synonym fset2:set set) -(gmap:def-gmap-res-type set (&key filterp) +(gmap:def-arg-type-synonym fun-set fun-sequence) + +;;; The only reason to use the functional iterators in `gmap' forms is that you want +;;; to iterate in reverse order for some reason. But I do want to test them +(gmap:def-gmap-arg-type fun-set (set &key from-end?) + `((fun-iterator ,set :from-end? ,from-end?) + #'(lambda (it) (funcall it ':empty?)) + #'(lambda (it) (funcall it ':first)) + #'(lambda (it) (funcall it ':rest)))) + +(gmap:def-result-type set (&key filterp) "Returns a set of the values, optionally filtered by `filterp'." `(nil #'(lambda (s x) (WB-Set-Tree-With s x #'compare)) #'make-wb-set ,filterp)) - -;;; A bit faster than `set', if you know it's a `wb-set'. +;;; Faster than `set', if you know it's a `wb-set'. (gmap: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)) + #'WB-Set-Tree-Iterator-Get + nil nil nil + (Do-WB-Set-Tree-Members (wb-set-contents ,set)))) (gmap:def-gmap-res-type wb-set (&key filterp compare-fn-name) "Returns a set of the values, optionally filtered by `filterp'. If @@ -793,27 +889,20 @@ (define-setf-expander @ (collection key &environment env) ((,org-var (wb-set-org (empty-wb-set ,compare-fn-name))) ((,cf-var (tree-set-org-compare-fn ,org-var))))))) - -(gmap:def-gmap-res-type union (&key filterp) - "Returns the union of the sets, optionally filtered by `filterp'." - ;; Written to take the implementation and organization from the first value. - `(nil #'(lambda (s x) (if (null s) x (union s x))) - #'(lambda (s) (or s (set))) - ,filterp)) - -(gmap:def-gmap-res-type intersection (&key filterp) - "Returns the intersection of the sets, optionally filtered by `filterp'. -\(If zero sets are supplied, returns the full set; see `full-set'.\)" - ;; Written to take the implementation and organization from the first value. - `(nil #'(lambda (s x) (if (null s) x (intersection s x))) - #'(lambda (s) (or s (full-set))) - ,filterp)) - -;;; A bit faster than `set', if you know it's a `ch-set'. +;;; Faster than `set', if you know it's a `ch-set'. (gmap:def-gmap-arg-type ch-set (set) `((make-ch-set-tree-iterator-internal (ch-set-contents ,set)) #'ch-set-tree-iterator-done? - #'ch-set-tree-iterator-get)) + #'ch-set-tree-iterator-get + nil nil nil + (do-ch-set-tree-members (ch-set-contents ,set)))) + +(gmap:def-result-type fset2:set (&key filterp) + "Returns a set of the values, optionally filtered by `filterp'. If +`compare-fn-name' is nonnull, it specifies a custom ordering." + `(nil #'(lambda (s x) (ch-set-tree-with s x #'hash-value #'compare)) + #'(lambda (s) (make-ch-set s +fset-default-hash-set-org+)) + ,filterp)) (gmap:def-gmap-res-type ch-set (&key filterp compare-fn-name) "Returns a set of the values, optionally filtered by `filterp'. If @@ -828,6 +917,21 @@ (define-setf-expander @ (collection key &environment env) ((,hf-var (hash-set-org-hash-fn ,org-var)) (,cf-var (hash-set-org-compare-fn ,org-var))))))) +(gmap:def-gmap-res-type union (&key filterp) + "Returns the union of the sets, optionally filtered by `filterp'." + ;; Written to take the implementation and organization from the first value. + `(nil #'(lambda (s x) (if (null s) x (union s x))) + #'(lambda (s) (or s (set))) + ,filterp)) + +(gmap:def-gmap-res-type intersection (&key filterp) + "Returns the intersection of the sets, optionally filtered by `filterp'. +\(If zero sets are supplied, returns the full set; see `full-set'.\)" + ;; Written to take the implementation and organization from the first value. + `(nil #'(lambda (s x) (if (null s) x (intersection s x))) + #'(lambda (s) (or s (full-set))) + ,filterp)) + ;;; ---------------- ;;; Bags @@ -835,25 +939,33 @@ (define-setf-expander @ (collection key &environment env) "Yields each element of `bag', as many times as its multiplicity." `((the function (iterator ,bag)) #'(lambda (it) (funcall it ':done?)) - #'(lambda (it) (funcall it ':get)))) + #'(lambda (it) (funcall it ':get)) + nil nil nil + (do-bag ,bag))) (gmap:def-gmap-arg-type bag-pairs (bag) "Yields each element of `bag' and its multiplicity as two values." `((the function (iterator ,bag :pairs? t)) #'(lambda (it) (funcall it ':done?)) - (:values 2 #'(lambda (it) (funcall it ':get))))) + (:values 2 #'(lambda (it) (funcall it ':get))) + nil nil nil + (do-bag-pairs ,bag))) (gmap: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)) + #'WB-Bag-Tree-Iterator-Get)) ; no `Do-WB-Bag-Tree-Elements' (gmap: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))) + (:values 2 #'WB-Bag-Tree-Pair-Iterator-Get) + nil nil nil + (Do-WB-Bag-Tree-Pairs (wb-bag-contents ,bag)))) + +(gmap:def-arg-type-synonym fun-bag fun-sequence) (gmap:def-arg-type fun-bag-pairs (bag &key from-end?) `((fun-iterator ,bag :pairs? t :from-end? ,from-end?) @@ -914,13 +1026,21 @@ (define-setf-expander @ (collection key &environment env) "Yields each pair of `map', as two values." `((the function (iterator ,map)) #'(lambda (it) (funcall it ':done?)) - (:values 2 #'(lambda (it) (funcall it ':get))))) + (:values 2 #'(lambda (it) (funcall it ':get))) + nil nil nil + (do-map ,map))) + +(gmap:def-arg-type-synonym fset2:map map) (gmap: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))) + (:values 2 #'WB-Map-Tree-Iterator-Get) + nil nil nil + (Do-WB-Map-Tree-Pairs (wb-map-contents ,map)))) + +(gmap:def-arg-type-synonym fset2:wb-map wb-map) (gmap:def-arg-type fun-map (map &key from-end?) `((fun-iterator ,map :from-end? ,from-end?) @@ -928,14 +1048,22 @@ (define-setf-expander @ (collection key &environment env) (:values 2 #'(lambda (it) (funcall it ':first))) #'(lambda (it) (funcall it ':rest)))) -(gmap:def-gmap-res-type map (&key filterp default) +(gmap:def-result-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 #'(lambda (m x y) (WB-Map-Tree-With m x y #'compare #'compare))) - #'(lambda (tree) (make-wb-map tree (wb-map-org *empty-wb-map*) ,default)) - ,filterp)) + #'(lambda (tree) (make-wb-map tree +fset-default-tree-map-org+ ,default)) + ,filterp)) -(gmap:def-gmap-res-type wb-map (&key filterp default key-compare-fn-name val-compare-fn-name) +(gmap:def-result-type fset2:map (&key filterp (default nil default?) no-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 #'(lambda (m x y) (ch-map-tree-with m x y #'hash-value #'compare #'hash-value #'compare))) + #'(lambda (tree) (make-ch-map tree +fset-default-hash-map-org+ + (fset2-default ,default? ,default ,no-default?))) + ,filterp)) + +(gmap:def-result-type wb-map (&key filterp default key-compare-fn-name val-compare-fn-name) "Consumes two values from the mapped function; returns a wb-map of the pairs. Note that `filterp', if supplied, must take two arguments." (let ((proto-var (gensymx #:prototype-)) @@ -948,6 +1076,66 @@ (define-setf-expander @ (collection key &environment env) ((,kcf-var (tree-map-org-key-compare-fn (wb-map-org ,proto-var))) (,vcf-var (tree-map-org-val-compare-fn (wb-map-org ,proto-var)))))))) +(gmap:def-result-type fset2:wb-map (&key filterp (default nil default?) no-default? + key-compare-fn-name val-compare-fn-name) + "Consumes two values from the mapped function; returns a wb-map of the pairs. +Note that `filterp', if supplied, must take two arguments." + (let ((proto-var (gensymx #:prototype-)) + (kcf-var (gensymx #:key-cmp-)) + (vcf-var (gensymx #:val-cmp-))) + `(nil (:consume 2 #'(lambda (tree k v) (WB-Map-Tree-With tree k v ,kcf-var ,vcf-var))) + #'(lambda (tree) (make-wb-map tree (wb-map-org ,proto-var) + (fset2-default ,default? ,default ,no-default?))) + ,filterp + ((,proto-var (empty-wb-map nil ,key-compare-fn-name ,val-compare-fn-name)) + ((,kcf-var (tree-map-org-key-compare-fn (wb-map-org ,proto-var))) + (,vcf-var (tree-map-org-val-compare-fn (wb-map-org ,proto-var)))))))) + +(gmap:def-gmap-arg-type ch-map (map) + "Yields each pair of `map', as two values." + `((make-ch-map-tree-iterator-internal (ch-map-contents ,map)) + #'ch-map-tree-iterator-done? + (:values 2 #'ch-map-tree-iterator-get) + nil nil nil + (do-ch-map-tree-pairs (ch-map-contents ,map)))) + +(gmap:def-arg-type-synonym fset2:ch-map ch-map) + +(gmap:def-result-type ch-map (&key filterp default key-compare-fn-name val-compare-fn-name) + "Consumes two values from the mapped function; returns a wb-map of the pairs. +Note that `filterp', if supplied, must take two arguments." + (let ((org-var (gensymx #:org-)) + (khf-var (gensymx #:key-hash-)) + (kcf-var (gensymx #:key-cmp-)) + (vhf-var (gensymx #:val-hash-)) + (vcf-var (gensymx #:val-cmp-))) + `(nil (:consume 2 #'(lambda (tree k v) (ch-map-tree-with tree k v ,khf-var ,kcf-var ,vhf-var ,vcf-var))) + #'(lambda (tree) (make-ch-map tree ,org-var ,default)) + ,filterp + ((,org-var (ch-map-org (empty-ch-map nil ,key-compare-fn-name ,val-compare-fn-name))) + ((,khf-var (hash-map-org-key-hash-fn ,org-var)) + (,kcf-var (hash-map-org-key-compare-fn ,org-var)) + (,vhf-var (hash-map-org-val-hash-fn ,org-var)) + (,vcf-var (hash-map-org-val-compare-fn ,org-var))))))) + +(gmap:def-result-type fset2:ch-map (&key filterp (default nil default?) no-default? + key-compare-fn-name val-compare-fn-name) + "Consumes two values from the mapped function; returns a wb-map of the pairs. +Note that `filterp', if supplied, must take two arguments." + (let ((org-var (gensymx #:org-)) + (khf-var (gensymx #:key-hash-)) + (kcf-var (gensymx #:key-cmp-)) + (vhf-var (gensymx #:val-hash-)) + (vcf-var (gensymx #:val-cmp-))) + `(nil (:consume 2 #'(lambda (tree k v) (ch-map-tree-with tree k v ,khf-var ,kcf-var ,vhf-var ,vcf-var))) + #'(lambda (tree) (make-ch-map tree ,org-var (fset2-default ,default? ,default ,no-default?))) + ,filterp + ((,org-var (ch-map-org (empty-ch-map nil ,key-compare-fn-name ,val-compare-fn-name))) + ((,khf-var (hash-map-org-key-hash-fn ,org-var)) + (,kcf-var (hash-map-org-key-compare-fn ,org-var)) + (,vhf-var (hash-map-org-val-hash-fn ,org-var)) + (,vcf-var (hash-map-org-val-compare-fn ,org-var))))))) + (gmap:def-gmap-res-type map-union (&key (val-fn nil val-fn?) (default nil default?) filterp) "Returns the map-union of the values, optionally filtered by `filterp'. If `val-fn' @@ -957,10 +1145,12 @@ (define-setf-expander @ (collection key &environment env) `(nil #'(lambda (prev-m m) (if (null prev-m) m - ,(if val-fn? `(map-union prev-m m ,val-fn-var) '#'map-union))) + ,(if val-fn? `(map-union prev-m m ,val-fn-var) '(map-union prev-m m)))) ,(and default? `#'(lambda (m) (with-default (or m (empty-wb-map)) ,default))) ,filterp - ((,val-fn-var ,val-fn))))) + (,@(and val-fn? `((,val-fn-var ,val-fn))))))) + +(gmap:def-result-type-synonym fset2:map-union map-union) (gmap:def-gmap-res-type map-intersection (&key (val-fn nil val-fn?) (default nil default?) filterp) @@ -972,42 +1162,36 @@ (define-setf-expander @ (collection key &environment env) `(nil #'(lambda (prev-m m) (if (null prev-m) m - ,(if val-fn? `(map-intersection prev-m m ,val-fn-var) '#'map-intersection))) + ,(if val-fn? `(map-intersection prev-m m ,val-fn-var) '(map-intersection prev-m m)))) ,(and default? `#'(lambda (m) (and m (with-default m ,default)))) ,filterp - ((,val-fn-var ,val-fn))))) + (,@(and val-fn? `((,val-fn-var ,val-fn))))))) + +(gmap:def-result-type-synonym fset2:map-intersection map-intersection) -(gmap:def-gmap-res-type map-to-sets (&key filterp key-compare-fn-name val-compare-fn-name) +(gmap:def-result-type map-to-sets (&key filterp key-compare-fn-name val-compare-fn-name) "Consumes two values from the mapped function. Returns a map from the first values, with each one mapped to a set of the corresponding second values. -Note that `filterp', if supplied, must take two arguments." - `((empty-wb-map (set) ,key-compare-fn-name ,val-compare-fn-name) - ;; &&& Could use `WB-Map-Tree-Update-Value' here. - (:consume 2 #'(lambda (m x y) (with m x (with (lookup m x) y)))) - nil ,filterp)) +Note, if you supply `val-compare-fn-name', to customize the ordering of the +range sets, the returned map will use `eql-compare' as its `val-compare-fn'. +Also note that `filterp', if supplied, must take two arguments." + (let ((vcfn-var (gensymx #:vcfn-))) + `((empty-wb-map (empty-wb-set ,vcfn-var) ,key-compare-fn-name (and ,vcfn-var 'eql-compare)) + (:consume 2 #'(lambda (m x y) (with m x (with (lookup m x) y)))) + nil ,filterp + ((,vcfn-var ,val-compare-fn-name))))) +(gmap:def-result-type fset2:map-to-sets (&key filterp key-compare-fn-name val-compare-fn-name) + "Consumes two values from the mapped function. Returns a map from the first +values, with each one mapped to a set of the corresponding second values. +Note, if you supply `val-compare-fn-name', to customize the ordering of the +range sets, the returned map will use `eql-compare' as its `val-compare-fn'. +Also note that `filterp', if supplied, must take two arguments." + (let ((vcfn-var (gensymx #:vcfn-))) + `((empty-ch-map (empty-ch-set ,vcfn-var) ,key-compare-fn-name (and ,vcfn-var 'eql-compare)) + (:consume 2 #'(lambda (m x y) (with m x (with (lookup m x) y)))) + nil ,filterp + ((,vcfn-var ,val-compare-fn-name))))) -(gmap:def-gmap-arg-type ch-map (map) - "Yields each pair of `map', as two values." - `((make-ch-map-tree-iterator-internal (ch-map-contents ,map)) - #'ch-map-tree-iterator-done? - (:values 2 #'ch-map-tree-iterator-get))) - -(gmap:def-gmap-res-type ch-map (&key filterp default key-compare-fn-name val-compare-fn-name) - "Consumes two values from the mapped function; returns a wb-map of the pairs. -Note that `filterp', if supplied, must take two arguments." - (let ((org-var (gensymx #:org-)) - (khf-var (gensymx #:key-hash-)) - (kcf-var (gensymx #:key-cmp-)) - (vhf-var (gensymx #:val-hash-)) - (vcf-var (gensymx #:val-cmp-))) - `(nil (:consume 2 #'(lambda (tree k v) (ch-map-tree-with tree k v ,khf-var ,kcf-var ,vhf-var ,vcf-var))) - #'(lambda (tree) (make-ch-map tree ,org-var ,default)) - ,filterp - ((,org-var (ch-map-org (empty-ch-map nil ,key-compare-fn-name ,val-compare-fn-name))) - ((,khf-var (hash-map-org-key-hash-fn ,org-var)) - (,kcf-var (hash-map-org-key-compare-fn ,org-var)) - (,vhf-var (hash-map-org-val-hash-fn ,org-var)) - (,vcf-var (hash-map-org-val-compare-fn ,org-var))))))) ;;; ---------------- ;;; Seqs @@ -1021,41 +1205,64 @@ (define-setf-expander @ (collection key &environment env) #'(lambda (it) (funcall it ':done?)) #'(lambda (it) (funcall it ':get)))) +(gmap:def-arg-type-synonym fset2:seq seq) + (gmap:def-gmap-arg-type wb-seq (seq &key start end from-end?) "Yields the elements of `seq'. The keyword arguments `start' and `end' can be supplied to restrict the range of the iteration; `start' is inclusive and defaults to 0, while `end' is exclusive and defaults to the size of the seq. If `from-end?' is true, the elements will be yielded in reverse order." - (flet ((fwd () - `((Make-WB-Seq-Tree-Iterator-Internal (wb-seq-contents ,seq) ,start ,end) - #'WB-Seq-Tree-Iterator-Done? - #'WB-Seq-Tree-Iterator-Get)) - (rev () - `((Make-WB-Seq-Tree-Rev-Iterator-Internal (wb-seq-contents ,seq) ,start ,end) - #'WB-Seq-Tree-Rev-Iterator-Done? - #'WB-Seq-Tree-Rev-Iterator-Get))) - (cond ((null from-end?) (fwd)) - ((atom from-end?) (rev)) - (t `(if ,from-end? ,(rev) ,(fwd)))))) - -(gmap:def-gmap-res-type seq (&key filterp) + (let ((seq-var (gensymx #:seq-))) + (cond ((null from-end?) + `((Make-WB-Seq-Tree-Iterator-Internal (wb-seq-contents ,seq-var) ,start ,end) + #'WB-Seq-Tree-Iterator-Done? + #'WB-Seq-Tree-Iterator-Get + nil ((,seq-var ,seq)) nil + (Do-WB-Seq-Tree-Members-Gen (wb-seq-contents ,seq-var) + (or ,start 0) (or ,end (size ,seq-var)) nil))) + ((eq from-end? 't) + `((Make-WB-Seq-Tree-Rev-Iterator-Internal (wb-seq-contents ,seq-var) ,start ,end) + #'WB-Seq-Tree-Rev-Iterator-Done? + #'WB-Seq-Tree-Rev-Iterator-Get + nil ((,seq-var ,seq)) nil + (Do-WB-Seq-Tree-Members-Gen (wb-seq-contents ,seq-var) + (or ,start 0) (or ,end (size ,seq-var)) t))) + (t + ;; Can't do much better than this if we don't statically know the direction. + `((the function (iterator ,seq :start ,start :end ,end :from-end? ,from-end?)) + #'(lambda (it) (funcall it ':done?)) + #'(lambda (it) (funcall it ':get))))))) + +(gmap:def-arg-type-synonym fset2:wb-seq wb-seq) + +(gmap:def-result-type-synonym seq wb-seq) + +(gmap:def-result-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)) -(gmap:def-gmap-res-type wb-seq (&key filterp) +(gmap:def-result-type-synonym fset2:seq fset2:wb-seq) + +(gmap:def-result-type fset2:wb-seq (&key filterp default no-default?) "Returns a seq of the values, optionally filtered by `filterp'." `(nil #'(lambda (a b) (cons b a)) - #'(lambda (s) (convert 'seq (nreverse s))) + #'(lambda (s) (convert 'fset2:seq (nreverse s) + ,@(and default `(:default ,default)) + ,@(and no-default? `(:no-default? ,no-default?)))) ,filterp)) -(gmap:def-gmap-res-type concat (&key filterp) +(gmap:def-result-type concat (&key filterp) "Returns the concatenation of the seq values, optionally filtered by `filterp'." `((empty-seq) #'concat nil ,filterp)) +(gmap:def-result-type fset2:concat (&key filterp) + "Returns the concatenation of the seq values, optionally filtered by `filterp'." + `((fset2:empty-seq) #'fset2:concat nil ,filterp)) + ;;; ---------------- ;;; Tuples @@ -1072,22 +1279,23 @@ (define-setf-expander @ (collection key &environment env) ;;; ---------------- ;;; Relations -(gmap:def-arg-type-synonym 2-relation wb-2-relation) - -(gmap:def-gmap-arg-type wb-2-relation (rel) +(gmap:def-arg-type 2-relation (rel) "Yields each pair of `rel', as two values." `((the function (iterator ,rel)) #'(lambda (it) (funcall it ':done?)) - (:values 2 #'(lambda (it) (funcall it ':get))))) + (:values 2 #'(lambda (it) (funcall it ':get))) + nil nil nil + (do-2-relation ,rel))) -(gmap:def-arg-type-synonym ch-2-relation wb-2-relation) +(gmap:def-arg-type-synonym wb-2-relation 2-relation) +(gmap:def-arg-type-synonym ch-2-relation 2-relation) ;;; People might expect it under this name. (gmap:def-arg-type-synonym fun-2-relation fun-map) -(gmap:def-result-type-synonym 2-relation wb-2-relation) +(gmap:def-result-type-synonym 2-relation ch-2-relation) -(gmap:def-gmap-res-type wb-2-relation (&key filterp key-compare-fn-name val-compare-fn-name) +(gmap:def-result-type wb-2-relation (&key filterp key-compare-fn-name val-compare-fn-name) "Consumes two values from the mapped function; returns a wb-2-relation of the pairs. Note that `filterp', if supplied, must take two arguments." (let ((org-var (gensymx #:org-)) @@ -1109,7 +1317,7 @@ (define-setf-expander @ (collection key &environment env) (,vcf-var (tree-map-org-val-compare-fn ,org-var))) (,size-var 0))))) -(gmap:def-gmap-res-type ch-2-relation (&key filterp key-compare-fn-name val-compare-fn-name) +(gmap:def-result-type ch-2-relation (&key filterp key-compare-fn-name val-compare-fn-name) "Consumes two values from the mapped function; returns a ch-2-relation of the pairs. Note that `filterp', if supplied, must take two arguments." (let ((org-var (gensymx #:org-)) @@ -1136,28 +1344,37 @@ (define-setf-expander @ (collection key &environment env) (,vhf-var (hash-map-org-val-hash-fn ,org-var))) (,size-var 0))))) -(gmap:def-gmap-arg-type list-relation (rel) - `((Make-WB-Set-Tree-Iterator-Internal (wb-set-contents (wb-list-relation-tuples ,rel))) +(gmap:def-arg-type list-relation (rel) + `((the function (iterator (convert 'set ,rel))) + #'(lambda (it) (funcall it ':done?)) + (:values 2 #'(lambda (it) (funcall it ':get))))) + +(gmap:def-arg-type wb-list-relation (rel) + `((Make-WB-Set-Tree-Iterator-Internal (wb-list-relation-tuples ,rel)) #'WB-Set-Tree-Iterator-Done? - #'WB-Set-Tree-Iterator-Get)) + #'WB-Set-Tree-Iterator-Get + nil nil nil + (Do-WB-Set-Tree-Members (wb-list-relation-tuples ,rel)))) + +(gmap:def-arg-type ch-list-relation (rel) + `((make-ch-set-tree-iterator-internal (ch-list-relation-tuples ,rel)) + #'ch-set-tree-iterator-done? + #'ch-set-tree-iterator-get + nil nil nil + (do-ch-set-tree-members (ch-list-relation-tuples ,rel)))) ;;; ---------------- ;;; Replay sets -;;; A bit faster than `set', if you know it's a `replay-set'. +;;; Faster than `set', if you know it's a `replay-set'. (gmap:def-arg-type replay-set (set) "Yields the elements of `set'." `((make-wb-seq-tree-iterator-internal (replay-set-ordering ,set)) #'wb-seq-tree-iterator-done? - #'wb-seq-tree-iterator-get)) - -;;; Deprecated in favor of arg type `replay-set', above. -(gmap:def-gmap-arg-type wb-replay-set (set) - "Yields the elements of `set'." - `((make-wb-seq-tree-iterator-internal (replay-set-ordering ,set)) - #'wb-seq-tree-iterator-done? - #'wb-seq-tree-iterator-get)) + #'wb-seq-tree-iterator-get + nil nil nil + (Do-WB-Seq-Tree-Members (replay-set-ordering ,set)))) ;;; CHAMP is the default now. (gmap:def-result-type replay-set (&key filterp) @@ -1169,7 +1386,7 @@ (define-setf-expander @ (collection key &environment env) (push x ,ordering-var)) ts)) #'(lambda (s) (make-ch-replay-set s (wb-seq-tree-from-list (nreverse ,ordering-var)) - (ch-set-org *empty-ch-set*))) + +fset-default-hash-set-org+)) ,filterp ((,ordering-var nil))))) @@ -1177,21 +1394,12 @@ (define-setf-expander @ (collection key &environment env) "Returns a wb-replay-set of the values, optionally filtered by `filterp'. If `compare-fn-name' is nonnull, it specifies a custom ordering for the internal set, though, of course, this doesn't affect the iteration order." + ;; I don't care enough about this now to rewrite it to use internal trees. `((empty-wb-replay-set ,compare-fn-name) #'with nil ,filterp)) -(gmap:def-gmap-res-type append-unique () - "Returns a list of the unique elements of the lists returned by the -mapped function, in the order in which they were first encountered." - `((empty-ch-replay-set) - #'(lambda (rs new-elts) - (dolist (x new-elts) - (includef rs x)) - rs) - #'(lambda (rs) (convert 'list rs)))) - (gmap:def-result-type ch-replay-set (&key filterp compare-fn-name) "Returns a ch-replay-set of the values, optionally filtered by `filterp'. If `compare-fn-name' is nonnull, it specifies a custom ordering for the internal @@ -1213,6 +1421,16 @@ (define-setf-expander @ (collection key &environment env) (,cf-var (hash-set-org-compare-fn ,org-var))) (,ordering-var nil))))) +(gmap:def-gmap-res-type append-unique () + "Returns a list of the unique elements of the lists returned by the +mapped function, in the order in which they were first encountered." + `((empty-ch-replay-set) + #'(lambda (rs new-elts) + (dolist (x new-elts) + (includef rs x)) + rs) + #'(lambda (rs) (convert 'list rs)))) + ;;; ---------------- ;;; Replay maps @@ -1236,11 +1454,11 @@ (define-setf-expander @ (collection key &environment env) (let ((ordering-var (gensymx #:ordering-))) `(nil (:consume 2 #'(lambda (s k v) (let ((ts (ch-map-tree-with s k v #'hash-value #'compare #'hash-value #'compare))) - (unless (eq ts s) + (unless (= (ch-map-tree-size ts) (ch-map-tree-size s)) (push k ,ordering-var)) ts))) #'(lambda (s) (make-ch-replay-map s (wb-seq-tree-from-list (nreverse ,ordering-var)) - (ch-map-org *empty-ch-map*) ,default)) + +fset-default-hash-map-org+ ,default)) ,filterp ((,ordering-var nil))))) @@ -1256,7 +1474,7 @@ (define-setf-expander @ (collection key &environment env) (ordering-var (gensymx #:ordering-))) `(nil (:consume 2 #'(lambda (s k v) (let ((ts (wb-map-tree-with s k v ,kcf-var ,vcf-var))) - (unless (eq ts s) + (unless (= (wb-map-tree-size ts) (wb-map-tree-size s)) (push k ,ordering-var)) ts))) #'(lambda (s) (make-wb-replay-map s (wb-seq-tree-from-list (nreverse ,ordering-var)) @@ -1281,7 +1499,7 @@ (define-setf-expander @ (collection key &environment env) (ordering-var (gensymx #:ordering-))) `(nil (:consume 2 #'(lambda (s k v) (let ((ts (ch-map-tree-with s k v ,khf-var ,kcf-var ,vhf-var ,vcf-var))) - (unless (eq ts s) + (unless (= (ch-map-tree-size ts) (ch-map-tree-size s)) (push k ,ordering-var)) ts))) #'(lambda (s) (make-ch-replay-map s (wb-seq-tree-from-list (nreverse ,ordering-var)) @@ -1310,6 +1528,18 @@ (define-setf-expander @ (collection key &environment env) :format-control "~A on a ~A takes three arguments" :format-arguments (list ,(copy-tree op) ,(copy-tree type))))) +(defmacro equal?-fn (cmp-fn) + `(lambda (a b) (eq (funcall ,cmp-fn a b) ':equal))) + +(defmacro equal?-cmp (a b cmp-fn) + `(eq (funcall ,cmp-fn ,a ,b) ':equal)) + +(defmacro less-than?-cmp (a b cmp-fn) + `(eq (funcall ,cmp-fn ,a ,b) ':less)) + +(defmacro greater-than?-cmp (a b cmp-fn) + `(eq (funcall ,cmp-fn ,a ,b) ':greater)) + (defmacro define-wb-set-method (name param-list &body body) (let ((decls nil) (doc-string body (if (stringp (car body)) (values (car body) (cdr body)) @@ -1358,7 +1588,7 @@ (defmethod ,name ,(mod-param-list 'wb-custom-set) ;; the O(n) algorithms. The downside, of course, would have been that if you did ;; actually change the function, things would have broken badly. This way, changing ;; the function could cause reduced performance, but correctness is maintained - ;; (unless you're depending on how `compare` orders two sets). + ;; (unless you're depending on how `compare' orders two sets). `(if (eq (wb-set-compare-fn ,coll1) (wb-set-compare-fn ,coll2)) ,then @@ -1367,6 +1597,11 @@ (defmethod ,name ,(mod-param-list 'wb-custom-set) `(make-wb-custom-set ,contents (wb-custom-set-org ,like-coll)))) . ,body)))))) +(defmacro define-wb-set-methods (methods parameter-list &body body) + `(progn . ,(mapcar (fn (method) + `(define-wb-set-method ,method ,parameter-list . ,body)) + methods))) + (defmacro if-same-ch-set-orgs ((s1 s2 hsorg-var) then else) (let ((s1-var (gensymx #:s1-)) (s2-var (gensymx #:s2-)) diff --git a/Code/order.lisp b/Code/order.lisp index ca557a2d1645a9eedf47634da566364965e18974..290b9ae449efdafbd749161de59d127c281d0ec5 100644 --- a/Code/order.lisp +++ b/Code/order.lisp @@ -19,12 +19,6 @@ compares `:less' or `:greater' to C, then B must compare to C the same way; and no more than one of A and B can compare `:equal' to C.")) -(defun less-than? (a b) - (eq (compare a b) ':less)) - -(defun greater-than? (a b) - (eq (compare a b) ':greater)) - (defun equal? (a b) (or (eql a b) (eq (compare a b) ':equal))) @@ -174,6 +168,7 @@ (define-cross-type-compare-methods list) (define-cross-type-compare-methods package) (define-cross-type-compare-methods pathname) (define-cross-type-compare-methods array) +(define-cross-type-compare-methods class) ;;; FSet types (define-cross-type-compare-methods set) @@ -409,6 +404,10 @@ (defmethod compare ((a sequence) (b sequence)) (setq unequal? t))))))))))) +;;; Classes +;;; [Moved to `post.lisp'] + + ;;; ================================================================================ ;;; Lexicographic comparison of sequences @@ -420,6 +419,9 @@ (defmethod compare ((a sequence) (b sequence)) can be strings, vectors, lists, or seqs.")) (defmethod compare-lexicographically ((a string) (b string) &key) + (compare-strings-lexicographically a b)) + +(defun compare-strings-lexicographically (a b) (if (eq a b) ':equal (let ((len-a (length a)) @@ -446,6 +448,9 @@ (defmethod compare-lexicographically ((a list) (b list) &key (val-compare-fn #'c (compare-lists-lexicographically a b val-compare-fn)) (defmethod compare-lexicographically ((a vector) (b vector) &key (val-compare-fn #'compare)) + (compare-vectors-lexicographically a b val-compare-fn)) + +(defun compare-vectors-lexicographically (a b &optional (val-compare-fn #'compare)) (declare (type function val-compare-fn)) (if (eq a b) ':equal @@ -471,3 +476,4 @@ (defmethod compare-lexicographically ((a vector) (b vector) &key (val-compare-fn (return res)) (when (eq res ':unequal) (setq default ':unequal)))))))) + diff --git a/Code/port.lisp b/Code/port.lisp index 5595b662246b277ea6bcad3b749e27d9c0703409..f138650520ca2f79a24aff74a80003f2462f13a7 100644 --- a/Code/port.lisp +++ b/Code/port.lisp @@ -288,19 +288,22 @@ ;;; package the same way that `cl:' is locked, so that an attempt to fbind one of its exported ;;; functions or macros will cause a warning or error. For the rest, the best we can do is to ;;; define unexported aliases, and use those in the macro expansions instead. -#+(or) ; #+sbcl +#+(and sbcl (not FSet-Disable-Package-Lock)) (progn (pushnew ':FSet-Use-Package-Locks *features*) - (defun lock-fset-package () - (sb-ext:lock-package (symbol-package 'lock-fset-package)))) + (defun lock-fset-packages () + (sb-ext:lock-package (symbol-package 'lookup)) + (sb-ext:lock-package (symbol-package 'fset2:lookup)))) -#+(or) ; #+allegro +#+(and allegro (not FSet-Disable-Package-Lock)) (progn (pushnew ':FSet-Use-Package-Locks *features*) - (defun lock-fset-package () - (let ((pkg (symbol-package 'lock-fset-package))) - (setf (excl:package-lock pkg) t) - (setf (excl:package-definition-lock pkg) t)))) + (defun lock-fset-packages () + (flet ((lock-pkg (pkg) + (setf (excl:package-lock pkg) t) + (setf (excl:package-definition-lock pkg) t))) + (lock-pkg (symbol-package 'lookup)) + (lock-pkg (symbol-package 'fset2:lookup))))) ;;; ---------------- @@ -492,6 +495,7 @@ (define-modify-macro hash-unmixf (hash &rest to-unmix) (and (or (eq a b) (and a b)) (gmap (:result and) (fn (x) (or (eq x a) (and x a))) (:arg list more)))) +(declaim (inline swap-if)) (defun swap-if (pred x y) (if pred (values y x) (values x y))) diff --git a/Code/post.lisp b/Code/post.lisp index bd31b9ad0731c7f0d39b82f94324ac672a3d62ff..a9f80647ffce069f6a41f3c5a37cc592efcf3de3 100644 --- a/Code/post.lisp +++ b/Code/post.lisp @@ -16,5 +16,21 @@ (declaim (ftype (function (t &key (:from-end? t) &allow-other-keys) function) fun-iterator)) +;;; Copy class definitions from `fset:' symbols to `fset2:' symbols that shadow them, +;;; so `defmethod', `typep', etc. will work without package prefixes. +(dolist (sym '(set map wb-map ch-map seq wb-seq replay-map wb-replay-map ch-replay-map)) + (let ((fset2-sym (intern (string sym) :fset2))) + (setf (find-class fset2-sym) (find-class sym)) + ;; Needed in CCL for `typep' to work. + #+ccl (setf (ccl::info-type-kind fset2-sym) ':instance))) + + +;;; Moved here from `order.lisp' because its expansion depends on stuff after that file. +(define-equality-slots class + #'class-name) + + +;;; Must be last! #+FSet-Use-Package-Locks -(lock-fset-package) +(lock-fset-packages) + diff --git a/Code/reader.lisp b/Code/reader.lisp index be1af08a6ed70bffd0e36a20236d87415bdaa337..2274b716039049a9273e8d22bc11e3be2a92463e 100644 --- a/Code/reader.lisp +++ b/Code/reader.lisp @@ -11,9 +11,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. (Note 2008-10-25: the reader macros +;;; invocations of the constructor macros. My impression is that 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.) +;;; 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 @@ -34,13 +34,17 @@ ;;; The reader macros expand directly into invocations of the constructor macros, ;;; so the syntax is similar. Loading this file does _not_ cause these macros ;;; to be defined in the current readtable. To use them, the recommended approach -;;; is to load system Named-Readables (it's in Quicklisp), and then do: +;;; is to do: ;;; ;;; > (named-readtables:in-readtable fset:fset-readtable) ;;; -;;; If you don't want to do that, you can use `*fset-readtable', or call +;;; If you don't want to do that, you can use `*fset-readtable*', or call ;;; `fset-setup-readtable' on an existing readtable. ;;; +;;; The syntaxes shown here are all for the older WB implementations. The syntaxes +;;; for the newer CHAMP implementations all start with `##' instead of `#' (the +;;; first `#' is pronounced "sharp", and the second `#' is pronounced "hash" :-) +;;; ;;; Set syntax: ;;; ;;; #{