remove-duplicates-aux.lsp 3.74 KB
Newer Older
1 2 3 4 5
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Mon Sep 23 20:59:10 2002
;;;; Contains: Aux. functions for testing REMOVE-DUPLICATES/DELETE-DUPLICATES

6

7 8

(defun my-remove-duplicates (orig-sequence
sds's avatar
sds committed
9
                             &key from-end test test-not (start 0) end key)
10 11
  (assert (typep orig-sequence 'sequence))
  (let* ((sequence orig-sequence)
sds's avatar
sds committed
12
         (len (length sequence)))
13 14
    (unless end (setq end len))
    (unless key (setq key #'identity))
15
    (setf key (coerce key 'function))
16
    (cond
17
      (test (setf test (coerce test 'function))
sds's avatar
sds committed
18
            (assert (not test-not)))
19
      (test-not (setf test-not (coerce test-not 'function))
sds's avatar
sds committed
20 21
                (setq test #'(lambda (x y)
                               (not (funcall (the function test) x y)))))
22 23 24 25
      (t (setq test #'eql)))
    (assert (integerp start))
    (assert (integerp end))
    (assert (<= 0 start end len))
26
    ;; (format t "start = ~A, end = ~A, len = ~A~%" start end len)
27
    (if from-end
sds's avatar
sds committed
28 29 30 31
        (psetq start (- len end)
               end (- len start)
               sequence (reverse sequence))
        (setq sequence (copy-seq sequence)))
32
    ;; (format t "start = ~A, end = ~A, len = ~A~%" start end len)
33 34 35
    (assert (<= 0 start end len) (start end len))
    (let ((result nil))
      (loop for i from 0 below start
sds's avatar
sds committed
36
            do (push (elt sequence i) result))
37
      (loop for i from start below end
sds's avatar
sds committed
38 39 40 41 42 43 44 45 46
            for x = (elt sequence i)
            for kx = (funcall (the function key) x)
            unless (position kx
                             sequence
                             :start (1+ i)
                             :end end
                             :test (the function test)
                             :key (the function key))
            do (push x result))
47
      (loop for i from end below len
sds's avatar
sds committed
48
            do (push (elt sequence i) result))
49 50
      (unless from-end (setq result (reverse result)))
      (cond
sds's avatar
sds committed
51 52 53 54 55
        ((listp orig-sequence) result)
        ((arrayp orig-sequence)
         (make-array (length result) :initial-contents result
                     :element-type (array-element-type orig-sequence)))
        (t (assert nil))))))
56

57 58 59
(defun make-random-rdup-params (maxlen)
  "Make random input parameters for REMOVE-DUPLICATES."
  (multiple-value-bind (element-type type len start end from-end
sds's avatar
sds committed
60
                                     count seq key test test-not)
61
      (make-random-rd-params maxlen)
62
    (declare (ignore count element-type len type))
63
    (let ((arg-list
sds's avatar
sds committed
64 65 66 67 68 69 70 71 72 73 74 75 76
           (reduce #'nconc
                   (random-permute
                    (list
                     (when start (list :start start))
                     (cond (end (list :end end))
                           ((coin) (list :end nil)))
                     (cond (from-end (list :from-end from-end))
                           ((coin) (list :from-end nil)))
                     (cond (key (list :key key))
                           ;; ((coin) (list :key nil))
                           )
                     (when test (list :test test))
                     (when test-not (list :test test-not)))))))
77
      (values seq arg-list))))
78

79 80 81 82
(defun random-test-remove-dups (maxlen &optional (pure t))
  (multiple-value-bind (seq arg-list)
      (make-random-rdup-params maxlen)
    (let* ((seq1 (copy-seq seq))
sds's avatar
sds committed
83 84 85 86 87
           (seq2 (copy-seq seq))
           (seq1r (apply (if pure #'remove-duplicates
                           #'delete-duplicates)
                         seq1 arg-list))
           (seq2r (apply #'my-remove-duplicates seq2 arg-list)))
88
      (cond
89 90 91
       ((and pure (not (equalp seq seq1))) (list :fail1 seq seq1r seq2r arg-list))
       ((and pure (not (equalp seq seq2))) (list :fail2 seq seq1r seq2r arg-list))
       ((not (equalp seq1r seq2r)) (list :fail3 seq seq1r seq2r arg-list))
92
       (t t)))))