home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / byte0487.arc / TELLO.ARC / DESTRUCT.LSP < prev    next >
Encoding:
Text File  |  1980-01-01  |  1.0 KB  |  41 lines
  1. ; DESTRUCT
  2. ; Destructive operation benchmark
  3.  
  4. (defun destructive (n m)
  5.   (let ((l (do ((i 10. (1- i))
  6.         (a () (push () a)))
  7.            ((= i 0) a))))
  8.     (do ((i n (1- i)))
  9.     ((= i 0))
  10.       (cond ((null (car l))
  11.          (do ((l l (cdr l)))
  12.      ((null l))
  13.            (or (car l)
  14.            (rplaca l (cons () ())))
  15.            (nconc (car l)
  16.               (do ((j m (1- j))
  17.                (a () (push () a)))
  18.               ((= j 0) a)))))
  19.         (t
  20.          (do ((l1 l (cdr l1))
  21.           (l2 (cdr l) (cdr l2)))
  22.          ((null l2))
  23.            (rplacd (do ((j (floor (length (car l2)) 2) (1- j))
  24.                 (a (car l2) (cdr a)))
  25.                ((= j 0) a)
  26.              (rplaca a i))
  27.                (let ((n (floor (length (car l1)) 2)))
  28.              (cond ((= n 0) (rplaca l1 ())
  29.                 (car l1))
  30.                    (t
  31.                 (do ((j n (1- j))
  32.                      (a (car l1) (cdr a)))
  33.                     ((= j 1)
  34.                      (prog1 (cdr a)
  35.                         (rplacd a ())))
  36.                   (rplaca a i))))))))))))
  37.  
  38. (define-timer destruct "Destruct" (destructive 600. 50.))
  39.  
  40. (qa-attempt "Destruct" (destructive 600. 50.) nil)
  41.