Changeset 11545
- Timestamp:
- Dec 18, 2008, 3:29:04 PM (12 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/source/lib/sequences.lisp
r10942 r11545 1219 1219 ;;; Delete-Duplicates: 1220 1220 1221 (defparameter *delete-duplicates-hash-threshold* 200) 1222 1221 1223 (defun list-delete-duplicates* (list test test-not key from-end start end) 1222 1224 ;;(%print "test:" test "test-not:" test-not "key:" key) 1223 (let ((handle (cons nil list))) 1224 (do ((current (nthcdr start list) (cdr current)) 1225 (previous (nthcdr start handle)) 1226 (index start (1+ index))) 1227 ((or (= index end) (null current)) 1228 (cdr handle)) 1229 ;;(%print "outer loop top current:" current "previous:" previous) 1230 (if (do ((x (if from-end 1231 (nthcdr (1+ start) handle) 1232 (cdr current)) 1233 (cdr x)) 1234 (i (1+ index) (1+ i))) 1235 ((or (null x) 1236 (and (not from-end) (= i end)) 1237 (eq x current)) 1238 nil) 1239 ;;(%print "inner loop top x:" x "i:" i) 1240 (if (list-delete-duplicates*-aux current x test test-not key) 1241 (return t))) 1242 (rplacd previous (cdr current)) 1243 (setq previous (cdr previous)))))) 1225 (let* ((len (- end start)) 1226 (handle (cons nil list)) 1227 (previous (nthcdr start handle))) 1228 (declare (dynamic-extent handle)) 1229 (if (and (> len *delete-duplicates-hash-threshold*) 1230 (or (eq test 'eq) (eq test 'eql) (eq test 'equal) (eq test 'equalp) 1231 (eq test #'eq) (eq test #'eql) (eq test #'equal) (eq test #'equalp))) 1232 (let ((hash (make-hash-table :size len :test test :shared nil))) 1233 (loop for i from start below end as obj in (cdr previous) 1234 do (incf (gethash (funcall key obj) hash 0))) 1235 (loop for i from start below end while (cdr previous) 1236 do (let* ((current (cdr previous)) 1237 (obj (car current)) 1238 (obj-key (funcall key obj))) 1239 (if (if from-end 1240 ;; Keep first ref 1241 (prog1 (gethash obj-key hash) (setf (gethash obj-key hash) nil)) 1242 ;; Keep last ref 1243 (eql (decf (gethash obj-key hash)) 0)) 1244 (setq previous current) 1245 (rplacd previous (cdr current)))))) 1246 (do ((current (cdr previous) (cdr current)) 1247 (index start (1+ index))) 1248 ((or (= index end) (null current))) 1249 ;;(%print "outer loop top current:" current "previous:" previous) 1250 (if (do ((x (if from-end 1251 (nthcdr (1+ start) handle) 1252 (cdr current)) 1253 (cdr x)) 1254 (i (1+ index) (1+ i))) 1255 ((or (null x) 1256 (and (not from-end) (= i end)) 1257 (eq x current)) 1258 nil) 1259 ;;(%print "inner loop top x:" x "i:" i) 1260 (if (list-delete-duplicates*-aux current x test test-not key) 1261 (return t))) 1262 (rplacd previous (cdr current)) 1263 (setq previous (cdr previous))))) 1264 (cdr handle))) 1244 1265 1245 1266 (defun list-delete-duplicates*-aux (current x test test-not key) … … 1256 1277 &optional (length (length vector))) 1257 1278 (declare (vector vector)) 1258 (do ((index start (1+ index)) 1259 (jndex start)) 1260 ((= index end) 1261 (do ((index index (1+ index)) ; copy the rest of the vector 1262 (jndex jndex (1+ jndex))) 1263 ((= index length) 1264 (setq vector (shrink-vector vector jndex))) 1265 (aset vector jndex (aref vector index)))) 1266 (aset vector jndex (aref vector index)) 1267 (unless (position (funcall key (aref vector index)) vector :key key 1268 :start (if from-end start (1+ index)) :test test 1269 :end (if from-end jndex end) :test-not test-not) 1270 (setq jndex (1+ jndex))))) 1279 (let* ((len (- end start)) 1280 (index start) 1281 (jndex start)) 1282 (if (and (not test-not) 1283 (> len *delete-duplicates-hash-threshold*) 1284 (or (eq test 'eq) (eq test 'eql) (eq test 'equal) (eq test 'equalp) 1285 (eq test #'eq) (eq test #'eql) (eq test #'equal) (eq test #'equalp))) 1286 (let ((hash (make-hash-table :size len :test test :shared nil))) 1287 (loop for i from start below end as obj = (aref vector i) 1288 do (incf (gethash (funcall key obj) hash 0))) 1289 (loop while (< index end) as obj = (aref vector index) as obj-key = (funcall key obj) 1290 do (incf index) 1291 do (when (if from-end 1292 (prog1 (gethash obj-key hash) (setf (gethash obj-key hash) nil)) 1293 (eql (decf (gethash obj-key hash)) 0)) 1294 (aset vector jndex obj) 1295 (incf jndex)))) 1296 (loop while (< index end) as obj = (aref vector index) 1297 do (incf index) 1298 do (unless (position (funcall key obj) vector :key key 1299 :start (if from-end start index) :test test 1300 :end (if from-end jndex end) :test-not test-not) 1301 (aset vector jndex obj) 1302 (incf jndex)))) 1303 (do ((index index (1+ index)) ; copy the rest of the vector 1304 (jndex jndex (1+ jndex))) 1305 ((= index length) 1306 (setq vector (shrink-vector vector jndex))) 1307 (aset vector jndex (aref vector index))))) 1308 1271 1309 1272 1310 (defun delete-duplicates (sequence &key (test #'eql) test-not (start 0) from-end end key)
Note: See TracChangeset
for help on using the changeset viewer.