remove-aux.lsp 11.2 KB
Newer Older
1 2 3 4 5
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sun Sep 15 07:42:36 2002
;;;; Contains: Auxiliary functions for testing REMOVE and related functions

6

7 8 9

(defun make-random-element (type)
  (cond
10
   ((subtypep* 'fixnum type)
11
    (random most-positive-fixnum))
12
   ((and (listp type)
sds's avatar
sds committed
13 14 15 16
         (eql (car type) 'integer)
         (integerp (cadr type))
         (integerp (caddr type))
         (null (cdddr type)))
17
    (+ (cadr type) (random (- (1+ (caddr type)) (cadr type)))))
18
   ((subtypep* '(integer 0 255) type)
19
    (random 255))
20
   ((subtypep* '(integer 0 7) type)
21
    (random 8))
22
   ((subtypep* 'bit type)
23
    (random 2))
24
   ((subtypep* 'symbol type)
25
    (elt '(a b c d e f g h) (random 8)))
26
   ((subtypep* '(member #\a #\b #\c #\d #\e #\f #\g #\h) type)
27 28 29 30 31 32 33 34 35 36
    (elt "abcdefgh" (random 8)))
   (t (error "Can't get random element of type ~A~%." type))))

(defun make-random-remove-input (len type element-type)

  "Randomly generate a test case for REMOVE.  Given a length
   a sequence type, and an element type, produce a random
   sequence of length LEN of sequence type TYPE, and either
   generate a random member of the sequence or a random
   element of the element type to delete from the sequence."
sds's avatar
sds committed
37

38
  (let* ((seq (if (subtypep* type 'list)
sds's avatar
sds committed
39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55
                  (loop for i from 1 to len collect
                        (make-random-element element-type))
                (let ((seq (if (and (subtypep type 'vector)
                                    (coin 3))
                               (make-array
                                (list (+ len (random (1+ len))))
                                :initial-element (make-random-element element-type)
                                :fill-pointer len
                                :element-type element-type)
                               (make-sequence type len))))
                  (dotimes (i len)
                    (setf (elt seq i) (make-random-element element-type)))
                  seq)))
         (e (if (and (> len 0) (coin))
                (elt seq (random len))
              (make-random-element element-type)))
         )
56 57 58
    (values len seq e)))

(defun my-remove (element
sds's avatar
sds committed
59 60 61 62 63 64 65 66 67
                  sequence
                  &key
                  (start 0)
                  (end nil)
                  (test #'eql test-p)
                  (test-not nil test-not-p)
                  (key nil)
                  (from-end nil)
                  (count nil))
68 69
  (assert (not (and test-p test-not-p)))
  (my-remove-if
70
   (cond (test-p
sds's avatar
sds committed
71 72 73 74 75 76
          (setf test (coerce test 'function))
          #'(lambda (x) (funcall (the function test) element x)))
         (test-not-p
          (setf test-not (coerce test-not 'function))
          #'(lambda (x) (not (funcall (the function test-not) element x))))
         (t #'(lambda (x) (eql element x))))
77
   sequence :start start :end end :key key :from-end from-end :count count))
sds's avatar
sds committed
78

79
(defun my-remove-if (predicate
sds's avatar
sds committed
80 81 82 83 84 85
                     original-sequence
                     &key (from-end nil)
                     (start 0)
                     (end nil)
                     (count nil)
                     (key #'identity))
86
  (let ((len (length original-sequence))
sds's avatar
sds committed
87
        (sequence (copy-seq original-sequence)))
88 89 90
    (unless end (setq end len))
    (unless key (setq key #'identity))
    (unless count (setq count len))
sds's avatar
sds committed
91

92 93 94 95 96 97
    ;; Check that everything's kosher
    (assert (<= 0 start end len))
    (assert (typep sequence 'sequence))
    (assert (integerp count))
    (assert (or (symbolp predicate) (functionp predicate)))
    (assert (or (symbolp key) (functionp key)))
98 99 100

    (setf predicate (coerce predicate 'function))
    (setf key (coerce key 'function))
sds's avatar
sds committed
101

102 103 104 105
    ;; If FROM-END, reverse the sequence and flip
    ;; start, end
    (when from-end
      (psetq sequence (nreverse sequence)
sds's avatar
sds committed
106 107
             start (- len end)
             end (- len start)))
108 109 110

    ;; Accumulate a list of elements for the result
    (let ((pos 0)
sds's avatar
sds committed
111
          (result nil)) ;; accumulate in reverse order
112
      (map nil
sds's avatar
sds committed
113 114 115 116 117 118 119 120 121 122
           #'(lambda (e)
               (if (and (> count 0)
                        (>= pos start)
                        (< pos end)
                        (funcall (the function predicate)
                                 (funcall (the function key) e)))
                   (decf count)
                 (push e result))
               (incf pos))
           sequence)
123
      (unless from-end
sds's avatar
sds committed
124
        (setq result (nreverse result)))
125 126
      ;; Convert to the correct type
      (if (listp sequence)
sds's avatar
sds committed
127 128 129 130
          result
        (let ((element-type (array-element-type original-sequence)))
          (make-array (length result) :element-type element-type
                      :initial-contents result))))))
131 132

(defun my-remove-if-not (pred &rest args)
133 134 135
  (when (symbolp pred)
    (setq pred (coerce pred 'function)))
  (assert (typep pred 'function))
136 137 138 139
  (apply #'my-remove-if (complement pred) args))

(defun make-random-rd-params (maxlen)
  "Generate random paramaters for remove/delete/etc. functions."
140
  (let* ((element-type
sds's avatar
sds committed
141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187
          (rcase
           (2 t)
           (1 'bit)
           (1 '(integer 0 2))
           (1 'symbol)))
         (type-select (random 7))
         (type
          (case type-select
            (0 'list)
            (1 'vector)
            (2 (setq element-type 'character) 'string)
            (3 (setq element-type 'bit) 'bit-vector)
            (4 'simple-vector)
            (5 (setq element-type '(integer 0 255))
               '(vector (integer 0 255)))
            (6 (setq element-type 'fixnum) '(vector fixnum))
            (t (error "Can't happen?!~%"))))
         (len (random maxlen))
         (start (and (coin) (> len 0)
                     (random len)))
         (end (and (coin)
                   (if start (+ start (random (- len start)))
                     (random (1+ len)))))
         (from-end (coin))
         (count (case (random 5)
                  ((0 1) nil)
                  ((2 3) (random (1+ len)))
                  (t (if (coin) -1 -10000000000000))))
         (seq (multiple-value-bind (x y z) (make-random-remove-input len type element-type)
                (declare (ignore x z))
                y))
         (key (and (coin)
                   (case type-select
                     (2 (random-case
                         #'char-upcase 'char-upcase
                         #'char-downcase 'char-downcase))
                     (3 #'(lambda (x) (- 1 x)))
                     ((5 6) (random-case #'1+ '1+ #'1- '1-))
                     (t (random-case 'identity #'identity)))))
         (test (and (eql (random 3) 0)
                    (random-case 'eq 'eql 'equal
                                 #'eq #'eql #'equal)))
         (test-not (and (not test)
                        (coin)
                        (random-case 'eq 'eql 'equal
                                     #'eq #'eql #'equal)))
         )
188 189 190 191 192 193 194
    ;; Return parameters
    (values
     element-type type len start end from-end count seq key test test-not)))

(defun random-test-remove-args (maxlen)
  (multiple-value-bind (element-type type len start end from-end count seq key test test-not)
      (make-random-rd-params maxlen)
pfdietz's avatar
pfdietz committed
195
    (declare (ignore type))
196
    (let ((element (if (and (coin) (> len 0))
sds's avatar
sds committed
197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214
                       (random-from-seq seq)
                     (make-random-element element-type)))
          (arg-list
           (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 (count (list :count count))
                           ((coin) (list :count nil)))
                     (cond (key (list :key key))
                           ;; ((coin) (list :key nil))
                           )
                     (when test (list :test test))
                     (when test-not (list :test test-not)))))))
215 216
      (values element seq arg-list))))

217 218
(defparameter *remove-fail-args* nil)

219
(defun random-test-remove (maxlen &key (tested-fn #'remove)
sds's avatar
sds committed
220 221
                                  (check-fn #'my-remove)
                                  (pure t))
222 223
  (setf tested-fn (coerce tested-fn 'function))
  (setf check-fn (coerce check-fn 'function))
224 225 226
  (multiple-value-bind (element seq arg-list)
      (random-test-remove-args maxlen)
    (let* ((seq1 (copy-seq seq))
sds's avatar
sds committed
227 228 229
           (seq2 (copy-seq seq))
           (seq1r (apply (the function tested-fn) element seq1 arg-list))
           (seq2r (apply (the function check-fn) element seq2 arg-list)))
230
      (setq *remove-fail-args* (list* element seq arg-list))
231
      (cond
232 233
       ((and pure (not (equalp seq seq1))) :fail1)
       ((and pure (not (equalp seq seq2))) :fail2)
234 235
       ((not (equalp seq1r seq2r)) :fail3)
       (t t)))))
236 237 238 239 240

(defun random-test-remove-if (maxlen &optional (negate nil))
  (multiple-value-bind (element seq arg-list)
      (random-test-remove-args maxlen)
    (let ((fn (getf arg-list :key))
sds's avatar
sds committed
241
          (test (getf arg-list :test)))
242 243 244 245
      (remf arg-list :key)
      (remf arg-list :test)
      (remf arg-list :test-not)
      (unless test (setq test #'eql))
246
      (setf test (coerce test 'function))
247
      (if fn
sds's avatar
sds committed
248 249 250 251 252 253 254
          (case (random 3)
            (0 (setf arg-list (list* :key 'identity arg-list)))
            (1 (setf arg-list (list* :key #'identity arg-list)))
            (t nil))
        (setf fn (if (coin) 'identity
                   #'(lambda (x) (funcall (the function test)
                                          element x)))))
255
      (let* ((seq1 (copy-seq seq))
sds's avatar
sds committed
256 257 258 259 260 261 262 263 264 265 266
             (seq2 (copy-seq seq))
             (seq1r (apply (if negate #'remove-if-not #'remove-if)
                           fn seq1 arg-list))
             (seq2r (apply (if negate #'my-remove-if-not #'my-remove-if)
                           fn seq2 arg-list)))
        (setq *remove-fail-args* (cons seq1 arg-list))
        (cond
         ((not (equalp seq seq1)) :fail1)
         ((not (equalp seq seq2)) :fail2)
         ((not (equalp seq1r seq2r)) :fail3)
         (t t))))))
267 268 269 270 271 272 273 274

(defun random-test-delete (maxlen)
  (random-test-remove maxlen :tested-fn #'delete :pure nil))

(defun random-test-delete-if (maxlen &optional (negate nil))
  (multiple-value-bind (element seq arg-list)
      (random-test-remove-args maxlen)
    (let ((fn (getf arg-list :key))
sds's avatar
sds committed
275
          (test (getf arg-list :test)))
276 277 278 279
      (remf arg-list :key)
      (remf arg-list :test)
      (remf arg-list :test-not)
      (unless test (setq test #'eql))
280
      (setf test (coerce test 'function))
281
      (if fn
sds's avatar
sds committed
282 283 284 285 286 287
          (case (random 3)
            (0 (setf arg-list (list* :key 'identity arg-list)))
            (1 (setf arg-list (list* :key #'identity arg-list)))
            (t nil))
        (setf fn (if (coin) 'identity
                   #'(lambda (x) (funcall (the function test) element x)))))
288
      (setq *remove-fail-args* (list* seq arg-list))
289
      (let* ((seq1 (copy-seq seq))
sds's avatar
sds committed
290 291 292 293 294 295 296 297
             (seq2 (copy-seq seq))
             (seq1r (apply (if negate #'delete-if-not #'delete-if)
                           fn seq1 arg-list))
             (seq2r (apply (if negate #'my-remove-if-not #'my-remove-if)
                           fn seq2 arg-list)))
        (cond
         ((not (equalp seq1r seq2r)) :fail3)
         (t t))))))