Corrected a define-modify-macro form (function should be a symbol). Thanks to Dimitri...
[com-informatimago:com-informatimago.git] / common-lisp / cesarum / list.lisp
1 ;;;; -*- coding:utf-8 -*-
2 ;;;;****************************************************************************
3 ;;;;FILE:              list.lisp
4 ;;;;LANGUAGE:          common-lisp
5 ;;;;SYSTEM:            UNIX
6 ;;;;USER-INTERFACE:    UNIX
7 ;;;;DESCRIPTION
8 ;;;;    This module exports some list utility functions.
9 ;;;;AUTHORS
10 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
11 ;;;;MODIFICATIONS
12 ;;;;    2012-03-14 <PJB> Added plist-keys.
13 ;;;;    2012-02-19 <PJB> Moved HASHED-* functions that work on sequence to
14 ;;;;                     COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SEQUENCE.
15 ;;;;    2011-04-03 <PJB> Added LIST-LENGTHS.
16 ;;;;    2008-06-24 <PJB> Added ENSURE-CIRCULAR, MAKE-CIRCULAR-LIST, CIRCULAR-LENGTH.
17 ;;;;    2007-01-05 <PJB> Added REPLACE-TREE (should move to a new package later).
18 ;;;;    2005-09-02 <PJB> Moved EQUIVALENCE-CLASSES in from ECMA048.
19 ;;;;    2005-08-10 <PJB> Moved TRIM-LIST in from make-depends.
20 ;;;;    2004-10-15 <PJB> Added IOTA.
21 ;;;;    2004-08-24 <PJB> Added TRANSPOSE, HASHED-REMOVE-DUPLICATE.
22 ;;;;    2003-06-10 <PJB> Added NSPLIT-LIST
23 ;;;;    2002-12-03 <PJB> Common-Lisp'ized.
24 ;;;;    2001-11-30 <PJB> Added list-remove-elements.
25 ;;;;    199?-??-?? <PJB> Creation.
26 ;;;;BUGS
27 ;;;;LEGAL
28 ;;;;    AGPL3
29 ;;;;    
30 ;;;;    Copyright Pascal J. Bourguignon 2002 - 2013
31 ;;;;    
32 ;;;;    This program is free software: you can redistribute it and/or modify
33 ;;;;    it under the terms of the GNU Affero General Public License as published by
34 ;;;;    the Free Software Foundation, either version 3 of the License, or
35 ;;;;    (at your option) any later version.
36 ;;;;    
37 ;;;;    This program is distributed in the hope that it will be useful,
38 ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
39 ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
40 ;;;;    GNU Affero General Public License for more details.
41 ;;;;    
42 ;;;;    You should have received a copy of the GNU Affero General Public License
43 ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>
44 ;;;;****************************************************************************
45
46 (in-package "COMMON-LISP-USER")
47 (defpackage "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.LIST"
48   (:use "COMMON-LISP")
49   (:export
50    "PREPENDF"  "PUSH*"
51    "DLL-NEXT" "DLL-PREVIOUS" "DLL-NODE" "LIST-TO-DOUBLE-LINKED-LIST"
52    "EQUIVALENCE-CLASSES" "SUBSETS" "COMBINE" "IOTA"
53    "MAKE-LIST-OF-RANDOM-NUMBERS" "LIST-INSERT-SEPARATOR"
54    "NSPLIT-LIST-ON-INDICATOR" "NSPLIT-LIST" "DEEPEST-REC" "DEEPEST" "DEPTH"
55    "FLATTEN" "LIST-TRIM" "TRANSPOSE" "AGET" "MEMQ"
56    "PLIST-KEYS" "PLIST-REMOVE" "PLIST-GET"
57    "PLIST-PUT" "PLIST-CLEANUP" "HASHED-INTERSECTION" 
58    ;; "HASHED-REMOVE-DUPLICATES" moved to COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SEQUENCE
59    "ENSURE-LIST" "PROPER-LIST-P" "LIST-LENGTHS" "LIST-ELEMENTS"
60    "ENSURE-CIRCULAR" "MAKE-CIRCULAR-LIST" "CIRCULAR-LENGTH"
61    "TREE-FIND" "TREE-DIFFERENCE" "REPLACE-TREE" "MAPTREE")
62   (:documentation
63    "
64 This package exports list processing functions.
65     
66
67 License:
68
69     AGPL3
70     
71     Copyright Pascal J. Bourguignon 2003 - 2013
72     
73     This program is free software: you can redistribute it and/or modify
74     it under the terms of the GNU Affero General Public License as published by
75     the Free Software Foundation, either version 3 of the License, or
76     (at your option) any later version.
77     
78     This program is distributed in the hope that it will be useful,
79     but WITHOUT ANY WARRANTY; without even the implied warranty of
80     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
81     GNU Affero General Public License for more details.
82     
83     You should have received a copy of the GNU Affero General Public License
84     along with this program.
85     If not, see <http://www.gnu.org/licenses/>
86
87 "))
88 (in-package "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.LIST")
89
90
91 (defun prepend (tail &rest lists)
92   (apply (function append) (append lists (list tail))))
93 (define-modify-macro prependf (place &rest lists) prepend)
94
95 (defmacro push* (&rest elements-and-place)
96   `(prependf ,(car (last elements-and-place))
97              (list ,@(butlast elements-and-place))))
98
99 (assert (equal (let ((i -1)
100                      (v (vector nil)))
101                  (push* 5 6 7 8 (aref v (incf i)))
102                  (decf i)
103                  (push* 1 2 3 4 (aref v (incf i)))
104                  (aref v 0))
105                '(1 2 3 4 5 6 7 8)))
106
107
108 (defun ensure-list (item)
109   "
110 RETURN: item if it's a list or (list item) otherwise.
111 "
112   (if (listp item) item (list item)))
113
114
115 (defun proper-list-p (object)
116   "
117 RETURN: whether OBJECT is a proper list
118 NOTE:   terminates with any kind of list, dotted, circular, etc.
119 "
120   (and (listp object)
121        (loop
122          :named proper
123          :for current = object :then (cddr current)
124          :for slow = (cons nil object) :then (cdr slow)
125          :do (cond
126                ((null current)       (return-from proper t))
127                ((atom current)       (return-from proper nil))
128                ((null (cdr current)) (return-from proper t))
129                ((atom (cdr current)) (return-from proper nil))
130                ((eq current slow)    (return-from proper nil)))))
131   #-(and)
132   (labels ((proper (current slow)
133              (cond ((null current)       t)
134                    ((atom current)       nil)
135                    ((null (cdr current)) t)
136                    ((atom (cdr current)) nil)
137                    ((eq current slow)    nil)
138                    (t                    (proper (cddr current) (cdr slow))))))
139     (and (listp object) (proper object (cons nil object)))))
140
141
142 (defun dotted-list-length (dotted-list)
143   "
144 DOTTED-LIST must be a dotted list or a proper list.
145 RETURN:  the number of cons cells in the list.
146 "
147   (loop
148     :for length :from 0
149     :for current = dotted-list :then (cdr current)
150     :until (atom current)
151     :finally (return length)))
152
153
154 (defun circular-list-lengths (circular-list)
155   "
156 CIRCULAR-LIST must be a circular list.
157 RETURN:  the length of the stem; the length of the circle.
158 "
159   (let ((cells (make-hash-table)))
160     (loop
161       :for index :from 0
162       :for cell = circular-list :then (cdr cell)
163       :for previous = (gethash cell cells)
164       :do (if previous
165               (return-from circular-list-lengths
166                 (values previous (- index previous)))
167               (setf (gethash cell cells) index)))))
168
169
170 (defun list-lengths (list)
171   "
172 LIST is any kind of list: proper-list, circular-list or dotted-list.
173 RETURN: for a proper list, the length of the list and 0;
174         for a circular list, the length of the stem, and the length of the circle;
175         for a dotted list, the number of cons cells, and nil;
176         for an atom, 0, and nil.
177 "
178   (typecase list
179     (cons  (loop
180              :named proper
181              :for current = list :then (cddr current)
182              :for slow = (cons nil list) :then (cdr slow)
183              :do (cond
184                    ((null current)       (return-from proper (values (list-length        list) 0)))
185                    ((atom current)       (return-from proper (values (dotted-list-length list) nil)))
186                    ((null (cdr current)) (return-from proper (values (list-length        list) 0)))
187                    ((atom (cdr current)) (return-from proper (values (dotted-list-length list) nil)))
188                    ((eq current slow)    (return-from proper (circular-list-lengths list))))))
189     (null  (values 0 0))
190     (t     (values 0 nil)))
191   #-(and)
192   (labels ((proper (current slow)
193              ;; (print (list 'proper current slow))
194              (cond ((null current)       (values (list-length        list) 0))
195                    ((atom current)       (values (dotted-list-length list) nil))
196                    ((null (cdr current)) (values (list-length        list) 0))
197                    ((atom (cdr current)) (values (dotted-list-length list) nil))
198                    ((eq current slow)    (circular-list-lengths list))
199                    (t                    (proper (cddr current) (cdr slow))))))
200     (typecase list
201       (cons  (proper list (cons nil list)))
202       (null  (values 0 0))
203       (t     (values 0 nil)))))
204
205 (defun test/list-lengths ()
206   (dolist (test
207             '( ;; proper lists
208               (()  0 0)
209               ((a)  1 0)
210               ((a b)  2 0)
211               ((a b c)  3 0)
212               ((a b c d)  4 0)
213               ((a b c d e)  5 0)
214               ;; dotted lists
215               (a  0 nil)
216               ((a . b)  1 nil)
217               ((a b . c) 2 nil)
218               ((a b c . d) 3 nil)
219               ((a b c d . e) 4 nil)
220               ((a b c d e . f) 5 nil)
221               ;; circular lists
222               (#1=(a . #1#) 0 1)
223               (#2=(a b . #2#) 0 2)
224               (#3=(a b c . #3#) 0 3)
225               (#4=(a b c d . #4#) 0 4)
226               (#5=(a b c d e . #5#) 0 5)
227               ((a . #6=(b . #6#)) 1 1)
228               ((a . #7=(b c . #7#)) 1 2)
229               ((a . #8=(b c d . #8#)) 1 3)
230               ((a . #9=(b c d e . #9#)) 1 4)
231               ((a b . #10=(c . #10#)) 2 1)
232               ((a b . #11=(c d . #11#)) 2 2)
233               ((a b . #12=(c d e . #12#)) 2 3)
234               ((a b c . #13=(d . #13#)) 3 1)
235               ((a b c . #14=(d e . #14#)) 3 2)
236               ((a b c d . #15=(e . #15#)) 4 1)
237               ((a b c d e . #16=(#16#)) 6 0) ; a proper list! :-)
238               )
239            :success)
240     (destructuring-bind (list . expected) test
241       (let ((result  (multiple-value-list (list-lengths list)))
242             (*print-circle* t))
243         (assert (equal expected result)
244                 (result)
245                 "(list-lengths '~S)~%  returned ~S~%  expected ~S~%"
246                 list result expected)))))
247
248
249
250 (defun list-elements (clist)
251   "
252 CLIST is any kind of list: proper-list, circular-list or dotted-list.
253 RETURN: for a proper list:     a copy of clist, the length of the list and 0;
254         for a circular list:   a list of elements in the clist, the length of the stem, and the length of the circle;
255         for a dotted list:     a list of the elements in the clist, the number of cons cells, and nil;
256         for an atom:           a list of the atom, 0, and nil.
257 "
258   (cond
259     ((null clist) ; a proper list
260      (values '() 0 0))
261     ((atom clist)
262      (values (list clist) 0 nil))
263     (t
264      (loop
265        :named scan
266        :with cells = (make-hash-table)
267        :with elements = '()
268        :for index :from 0
269        :for cell = clist :then (cdr cell)
270        :for previous = (gethash cell cells)
271        :do (cond
272              ((null cell)             ; proper list
273               (return-from scan (values (nreverse elements) index 0)))
274              ((atom cell)             ; dotted list
275               (push cell elements)
276               (return-from scan (values (nreverse elements) index nil)))
277              (previous                ; a circular list
278               (return-from scan (values (nreverse elements) previous (- index previous))))
279              (t                       ; in the middle
280               (setf (gethash cell cells) index)
281               (push (car cell) elements)))))))
282
283
284 (defun test/list-elements ()
285   (dolist (test
286             '( ;; proper lists
287               (()  ()  0 0)
288               ((a)  (a) 1 0)
289               ((a b)  (a b) 2 0)
290               ((a b c)  (a b c) 3 0)
291               ((a b c d)  (a b c d) 4 0)
292               ((a b c d e)  (a b c d e) 5 0)
293               ;; dotted lists
294               (a  (a) 0 nil)
295               ((a . b) (a b) 1 nil)
296               ((a b . c) (a b c) 2 nil)
297               ((a b c . d) (a b c d) 3 nil)
298               ((a b c d . e) (a b c d e) 4 nil)
299               ((a b c d e . f) (a b c d e f) 5 nil)
300               ;; circular lists
301               (#1=(a . #1#)  (a) 0 1)
302               (#2=(a b . #2#)  (a b) 0 2)
303               (#3=(a b c . #3#) (a b c) 0 3)
304               (#4=(a b c d . #4#) (a b c d) 0 4)
305               (#5=(a b c d e . #5#) (a b c d e) 0 5)
306               ((a . #6=(b . #6#)) (a b) 1 1)
307               ((a . #7=(b c . #7#)) (a b c) 1 2)
308               ((a . #8=(b c d . #8#)) (a b c d) 1 3)
309               ((a . #9=(b c d e . #9#)) (a b c d e) 1 4)
310               ((a b . #10=(c . #10#)) (a b c) 2 1)
311               ((a b . #11=(c d . #11#)) (a b c d) 2 2)
312               ((a b . #12=(c d e . #12#)) (a b c d e) 2 3)
313               ((a b c . #13=(d . #13#)) (a b c d) 3 1)
314               ((a b c . #14=(d e . #14#)) (a b c d e) 3 2)
315               ((a b c d . #15=(e . #15#)) (a b c d e) 4 1)
316               ((a b c d e . #16=(#16#)) (a b c d e #16#) 6 0) ; a proper list! :-)
317               )
318            :success)
319     (destructuring-bind (list . expected) test
320       (let ((result  (multiple-value-list (list-elements list)))
321             (*print-circle* t))
322         (assert (equal expected result)
323                 (result)
324                 "(~A '~S)~%  returned ~S~%  expected ~S~%"
325                 'list-elements list result expected)))))
326
327
328
329 (defun ensure-circular (list)
330   "
331 If list is not a circular list, then modify it to make it circular.
332 RETURN: LIST
333 "
334   (if (proper-list-p list)
335       (setf (cdr (last list)) list)
336       list))
337
338 (defun make-circular-list (size &key initial-element)
339   "
340 RETURN: a new circular list of length SIZE.
341 POST: (circular-length (make-circular-list size)) == (values size 0 size)
342 "
343   (let ((list (make-list size :initial-element initial-element)))
344     (setf (cdr (last list)) list)
345     list))
346
347
348 (defun circular-length (list)
349   "LIST must be either a proper-list or a circular-list, not a dotted-list.
350 RETURN: the total length ; the length of the stem ; the length of the circle.
351 "
352   (let ((indexes (make-hash-table)))
353     (loop
354       :for i :from 0
355       :for current :on list
356       :do (let ((index (gethash current indexes)))
357             (if index
358                 ;; found loop
359                 (return (values i index (- i index)))
360                 (setf (gethash current indexes) i)))
361       :finally (return (values i i 0)))))
362
363
364 (defun plist-keys (plist)
365   "Returns a list of the properties in PLIST."
366   (remove-duplicates (loop :for (key) :on plist :by (function cddr) :collect key)))
367
368
369 (defun plist-cleanup (plist)
370   "Returns a plist that has the same associations than PLIST, but with
371 a single occurence of each key and the first value found.
372
373 EXAMPLE:        (plist-cleanup '(:a 1 :b 2 :a 11 :c 3)) --> (:b 2 :c 3 :a 1)
374 "
375   (loop
376     :with h =  (make-hash-table)
377     :for (key value) :on plist :by (function cddr)
378     :do (when (eq h (gethash key h h))
379           (setf (gethash key h) value))
380     :finally (let ((result '()))
381                (maphash (lambda (key value) (push value result) (push key result)) h)
382                (return result))))
383
384
385
386 (defun plist-put (plist prop value)
387   "
388  Change value in PLIST of PROP to VALUE.
389  PLIST is a property list, which is a list of the form
390  (PROP1 VALUE1 PROP2 VALUE2 ...).  PROP is a symbol and VALUE is any object.
391  If PROP is already a property on the list, its value is set to VALUE,
392  otherwise the new PROP VALUE pair is added.  The new plist is returned;
393  use `(setq x (plist-put x prop val))' to be sure to use the new value.
394  The PLIST is modified by side effects.
395 "
396   (setf (getf plist prop) value)
397   plist)
398
399
400 (defun plist-get (plist prop)
401   "
402  Extract a value from a property list.
403  PLIST is a property list, which is a list of the form
404  (PROP1 VALUE1 PROP2 VALUE2...).  This function returns the value
405  corresponding to the given PROP, or nil if PROP is not
406  one of the properties on the list.
407 "
408   (getf plist prop))
409
410
411 (defun plist-remove (plist prop)
412   "
413 DO:      (REMF PLIST PROP)
414 RETURN:  The modified PLIST.
415 "
416   (remf plist prop)
417   plist)
418
419
420 (defun memq (item list)
421   "
422 RETURN:   (MEMBER ITEM LIST :TEST (FUNCTION EQ))
423 "
424   (member item list :test (function eq)))
425
426 (declaim (inline plist-put plist-get plist-remove memq))
427
428
429 (defun transpose (tree)
430   "
431 RETURN: A tree where all the CAR and CDR are exchanged.
432 "
433   (if (atom tree)
434       tree
435       (cons (transpose (cdr tree)) (transpose (car tree)))))
436
437
438
439 (defun list-trim (bag list
440                   &key (test (function eql)) (key (function identity)))
441   "
442 RETURN: A sublist of LIST with the elements in the BAG removed from
443         both ends.
444 "
445   (do ((list (reverse list) (cdr list)))
446       ((or (null list) (not (member (car list) bag :test test :key key)))
447        (do ((list (nreverse list) (cdr list)))
448            ((or (null list) (not (member (car list) bag :test test :key key)))
449             list)))))
450
451
452 (defun list-trim-test ()
453   (every
454    (lambda (x) (equalp '(d e f) x))
455    (list
456     (list-trim '(a b c) '( a b c d e f a b c c c ))
457     (list-trim '((a 1)(b 2)(c 3)) '( a b c d e f a b c c ) :key (function car))
458     (list-trim '(:a :b :c) '( a b c d e f a b c c ) :test (function string=))
459     (list-trim '(a b c) '( a b c d e f))
460     (list-trim '(a b c) '( d e f a b c c c )))))
461
462
463 (defun maptree (fun &rest trees)
464   "
465 DO:     Calls FUN on each non-null atom of the TREES.
466 PRE:    The trees in TREES must be congruent, or else the result is
467         pruned like the smallest tree.
468 RETURN: A tree congruent to the TREES, each node being the result of
469         FUN (it may be a subtree).
470 "
471   (cond ((null trees) nil)
472         ((every (function null)  trees) nil)
473         ((every (function atom)  trees) (apply fun trees))
474         ((every (function consp) trees)
475          (cons (apply (function maptree) fun (mapcar (function car) trees))
476                (apply (function maptree) fun (mapcar (function cdr) trees))))
477         (t nil)))
478
479
480 (defun flatten (tree)
481   "
482 RETURN: A list containing all the elements of the `tree'.
483 "
484   (loop
485     :with result = nil
486     :with stack = nil
487     :while (or tree stack)
488     :do (cond
489           ((null tree)
490            (setq tree (pop stack)))
491           ((atom tree)
492            (push tree result)
493            (setq tree (pop stack)))
494           ((listp (car tree))
495            (push (cdr tree) stack)
496            (setq tree (car tree)))
497           (t
498            (push (car tree) result)
499            (setq tree (cdr tree))))
500     :finally (return (nreverse result))))
501
502
503 (defun depth (tree)
504   "
505 RETURN:     The depth of the tree.
506 "
507   (if (atom tree)
508       0
509       (1+ (apply (function max) 
510                  0
511                  (do ((tree tree (cdr tree))
512                       (results '()))
513                      ((atom tree) results)
514                    (if (listp (car tree)) (push (depth (car tree)) results)))))))
515
516
517 (defun deepest-rec (tree)
518   "
519 RETURN:     The deepest list in the tree.
520 NOTE:       Recursive algorithm.
521 SEE-ALSO:   deepest-iti
522 "
523   (let ((subtree (delete-if (function atom) tree)))
524     (cond
525       ((null subtree)    tree)
526       ((every (lambda (item) (every (function atom) item)) subtree)
527        (car subtree))
528       (t
529        (deepest-rec (apply 'concatenate 'list subtree))))))
530
531
532 (defun deepest (tree)
533   "
534 RETURN:     The deepest list in the tree.
535 NOTE:       Iterative algorithm.
536 SEE-ALSO:   deepest-rec
537 "
538   (do* ((tree tree (apply 'concatenate 'list subtree))
539         (subtree (delete-if (function atom) tree)
540                  (delete-if (function atom) tree)))
541        ((or (null subtree)
542             (every (lambda (item) (every (function atom) item)) subtree))
543         (if (null subtree) tree (car subtree)))))
544
545
546 (defun nsplit-list (list position &key (from-end nil))
547   "
548 PRE:            0<=POSITION<=(LENGTH LIST)
549 DO:             SPLIT THE LIST IN TWO AT THE GIVEN POSITION.
550                 (NSPLIT-LIST (LIST 'A 'B 'C) 0) --> NIL ; (A B C)
551                 (NSPLIT-LIST (LIST 'A 'B 'C) 1) --> (A) ; (B C)
552                 (NSPLIT-LIST (LIST 'A 'B 'C) 2) --> (A B) ; (C)
553                 (NSPLIT-LIST (LIST 'A 'B 'C) 3) --> (A B C) ; NIL
554 POSITION:       POSITION OF THE SPLIT; 
555                 WHEN FROM-START AND 0<=POSITION<=(LENGTH LIST),
556                 THAT'S THE LENGTH OF THE FIRST RESULT
557 FROM-START:     THE DEFAULT, SPLIT COUNTING FROM THE START.
558 FROM-END:       WHEN SET, COUNT FROM THE END OF THE LIST.
559                  (NSPLIT-LIST L P :FROM-END T)
560                  === (NSPLIT-LIST L (- (LENGTH L) P))
561 RETURN:         THE FIRST PART ; THE LAST PART
562 "
563   (if from-end
564       (nsplit-list list (- (length list) position))
565       (do* ((prev nil  rest)
566             (rest list (cdr rest)))
567            ((or (null rest) (zerop position))
568             (progn
569               (if prev
570                   (setf (cdr prev) nil)
571                   (setf list nil))
572               (values list rest)))
573         (decf position))))
574
575
576 (defun nsplit-list-on-indicator (list indicator)
577   "
578 RETURN: a list of sublists of list (the conses from list are reused),
579         the list is splited between items a and b for which (indicator a b).
580 "
581   (declare (type (function (t t) t) indicator))
582   (let* ((result nil)
583          (sublist list)
584          (current list)
585          (next    (cdr current)))
586     (loop :while next :do
587       (if (funcall indicator (car current) (car next))
588           (progn ;; split
589             (setf (cdr current) nil)
590             (push sublist result)
591             (setq current next)
592             (setq next (cdr current))
593             (setq sublist current))
594           (progn ;; keep
595             (setq current next)
596             (setq next (cdr current)))))
597     (push sublist result)
598     (nreverse result)))
599
600
601 (defun list-insert-separator (list separator)
602   "
603 RETURN:  A list composed of all the elements in `list'
604          with `separator' in-between.
605 EXAMPLE: (list-insert-separator '(a b (d e f)  c) 'x)
606          ==> (a x b x (d e f) x c)
607 "
608   (cond
609     ((null list)       '())
610     ((null (cdr list)) (list (car list)))
611     (t  (do ((result '())
612              (items list (cdr items)))
613             ((endp items) (nreverse (cdr result)))
614           (push (car items) result)
615           (push separator result)))))
616
617
618
619 (defun iota (count &optional (start 0)(step 1))
620   "
621 RETURN:   A list containing the elements 
622           (start start+step ... start+(count-1)*step)
623           The start and step parameters default to 0 and 1, respectively. 
624           This procedure takes its name from the APL primitive.
625 EXAMPLE:  (iota 5) => (0 1 2 3 4)
626           (iota 5 0 -0.1) => (0 -0.1 -0.2 -0.3 -0.4)
627 "
628   (when (< 0 count)
629     (do ((result '())
630          (item (+ start (* step (1- count))) (- item step)))
631         ((< item start) result)
632       (push item result)))) ;;iota
633
634
635 (defun make-list-of-random-numbers (length &key (modulo most-positive-fixnum))
636   "
637 RETURN:  A list of length `length' filled with random numbers
638 MODULO:  The argument to RANDOM.
639 "
640   (loop while (< 0 length)
641      collect (random modulo) into result
642      do (setq length (1- length))
643      finally (return result)))
644
645
646 (defun combine (&rest args)
647   "
648 RETURN:  (elt args 0) x (elt args 1) x ... x (elt args (1- (length args)))
649          = the set of tuples built taking one item in order from each list
650            in args.
651 EXAMPLE: (COMBINE '(WWW FTP) '(EXA) '(COM ORG))) 
652            --> ((WWW EXA COM) (WWW EXA ORG) (FTP EXA COM) (FTP EXA ORG))
653 "
654   (cond
655     ((null args)        '(nil))
656     ((null  (car args)) (apply (function combine) (cdr args)))
657     ((consp (car args)) (mapcan (lambda (item)
658                                   (apply (function combine) item (cdr args)))
659                                 (car args)))
660     (t                  (mapcan (lambda (rest) (list (cons (car args) rest)))
661                                 (apply (function combine) (cdr args))))))
662
663 ;; Sets:
664
665 (defun hashed-intersection (set1 set2)
666   "
667 AUTHORS: Paul F. Dietz <dietz@dls.net>
668          Thomas A. Russ <tar@sevak.isi.edu>
669 "
670   (declare (optimize speed (safety 0) (debug 0))
671            (list set1 set2))
672   (let ((table (make-hash-table :size (length set2)))
673         (result nil))
674     (dolist (e set2) (setf (gethash e table) t))
675     (dolist (e set1) (when (gethash e table)
676                        (push e result)
677                        (setf (gethash e table) nil)))
678     result))
679
680
681 (defun subsets (set)
682   "
683 RETURN: The set of all subsets of the strict SET.
684 "
685   (loop
686     :with card = (length set)
687     :for indicator :from 0 :below (expt 2 card)
688     :collect (loop
689                :for index :from 0 :below card
690                :for item :in set
691                :nconc (if (logbitp index indicator) (list item) nil) 
692                :into result 
693                :finally (return result)) :into result
694     :finally (return result)))
695
696
697 (defun equivalence-classes (set &key (test (function eql))
698                             (key (function identity)))
699   "
700 RETURN: The equivalence classes of SET, via KEY, modulo TEST.
701 "
702   (loop
703     :with classes = '()
704     :for item :in set
705     :for item-key = (funcall key item)
706     :for class = (car (member item-key classes
707                               :test test :key (function second)))
708     :do (if class
709             (push item (cddr class))
710             (push (list :class item-key item ) classes))
711     :finally (return (mapcar (function cddr) classes))))
712
713
714
715 ;; A-lists:
716
717 (defun aget (place indicator &optional default)
718   "
719 RETURN:   The value of the entry INDICATOR of the a-list PLACE, or DEFAULT.
720 "
721   (let ((a (assoc indicator place)))
722     (if a (cdr a) default)))
723
724
725 ;; (DEFSETF AGET (PLACE INDICATOR &OPTIONAL DEFAULT) (VALUE)
726 ;;   "
727 ;; DO:       Set or add a new entry INDICATOR in the a-list at PLACE.
728 ;; "
729 ;;   (DECLARE (IGNORE DEFAULT))
730 ;;   (ERROR "THIS DOES NOT WORK. DEALING WITH SETF EXPANSION IS NEEDED HERE!")
731 ;;   (LET ((ACS (GENSYM "AC")))
732 ;;     `(LET* ((,ACS (ASSOC ,INDICATOR ,PLACE)))
733 ;;        (IF ,ACS
734 ;;            (SETF (CDR ,ACS) ,VALUE)
735 ;;            (SETF ,PLACE (ACONS ,INDICATOR ,VALUE ,PLACE)))
736 ;;        ,VALUE)))
737
738
739 (define-setf-expander aget (place indicator &optional default &environment env)
740   (declare (ignore default))
741   (multiple-value-bind (vars vals store-vars writer-form reader-form)
742       (get-setf-expansion place env)
743     (let* ((vindicator (gensym "INDICATOR"))
744            (vvalue     (gensym "VALUE"))
745            (vstore     (first store-vars))
746            (acs        (gensym "PAIR")))
747       (values (list* vindicator vars)
748               (list* indicator  vals)
749               (list  vvalue)
750               `(let* ((,acs (assoc ,vindicator ,reader-form)))
751                  (if ,acs
752                      (setf (cdr ,acs) ,vvalue)
753                      (let ((,vstore (acons ,vindicator ,vvalue ,reader-form)))
754                        ,writer-form))
755                  ,vvalue)
756               `(assoc ,vindicator ,reader-form)))))
757
758
759 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
760 ;; Double-Linked Lists
761
762 (defun list-to-double-linked-list (single)
763   "
764 RETURN:  A double-linked-list.
765 NOTE:    Use dll-node, dll-next and dll-previous to walk the double-linked-list.
766 EXAMPLE: (setq d (list-to-double-linked-list '( a b c)))
767          ==> (a nil b #0 c (b #0 c #1))
768          (dll-node d)
769          ==> a
770          (dll-next d)
771          ==> (b (a nil b #1 c #0) c #0)
772          (dll-previous (dll-next d))
773          ==> (a nil b #0 c (b #0 c #1))
774 "
775   (loop with head = nil
776      for previous = nil then current
777      for element in single
778      for current = (list element previous)
779      unless head do (setq head current)
780      when previous do (setf (cdr (cdr previous))  current)
781      finally (return head)))
782
783
784 (defun dll-node     (dll-cons)
785   "
786 RETURN:  The node in the `dll-cons' double-linked-list node.
787 "
788   (car  dll-cons))
789
790
791 (defun dll-previous (dll-cons)
792   "
793 RETURN:  The previous dll-cons in the `dll-cons' double-linked-list node.
794 "
795   (cadr dll-cons))
796
797
798 (defun dll-next     (dll-cons)
799   "
800 RETURN:  The next dll-cons in the `dll-cons' double-linked-list node.
801 "
802   (cddr dll-cons))
803
804
805 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
806
807 (defun tree-find (object tree &key (key (function identity)) (test (function eql)))
808   "
809 RETURN: The object in TREE that matches OBJECT (using the KEY and TEST functions.
810 TREE:   A sexp.
811 "
812   (if (atom tree)
813       (if (funcall test object (funcall key tree))
814           tree
815           nil)
816       (or (tree-find object (car tree) :key key :test test)
817           (tree-find object (cdr tree) :key key :test test))))
818
819 (defun test/tree-find ()
820   (assert (equal 'x (tree-find 'x 'x)))
821   (assert (equal 'x (tree-find 'x '(x))))
822   (assert (equal 'x (tree-find 'x '(a b c x d e f))))
823   (assert (equal 'x (tree-find 'x '(a b c d . x))))
824   (assert (equal 'x (tree-find 'x '(() (a b c d . x)))))
825   (assert (equal 'x (tree-find 'x '((a b (a b c d . x) x)))))
826
827   (assert (equal 'x (tree-find "x" 'x :test (function string-equal))))
828   (assert (equal 'x (tree-find "x" '(x) :test (function string-equal))))
829   (assert (equal 'x (tree-find "x" '(a b c x d e f) :test (function string-equal))))
830   (assert (equal 'x (tree-find "x" '(a b c d . x) :test (function string-equal))))
831   (assert (equal 'x (tree-find "x" '(() (a b c d . x)) :test (function string-equal))))
832   (assert (equal 'x (tree-find "x" '((a b (a b c d . x) |x|)) :test (function string-equal))))
833
834   (assert (equal 'x (tree-find "x" 'x :test (function string=) :key (function string-downcase))))
835   (assert (equal 'x (tree-find "x" '(x) :test (function string=) :key (function string-downcase))))
836   (assert (equal 'x (tree-find "x" '(a b c x d e f) :test (function string=) :key (function string-downcase))))
837   (assert (equal 'x (tree-find "x" '(a b c d . x) :test (function string=) :key (function string-downcase))))
838   (assert (equal 'x (tree-find "x" '(() (a b c d . x)) :test (function string=) :key (function string-downcase))))
839   (assert (equal 'x (tree-find "x" '((a b (a b c d . x) |x|)) :test (function string=) :key (function string-downcase))))
840   :success)
841
842
843 (defun tree-difference (a b &key (test (function eql)))
844   "
845 RETURN: A tree congruent to A and B where each node is = when the
846         corresponding nodes are equal (as indicated by TEST),
847         or (/= a-elem b-elem) otherwise.
848
849 EXAMPLE: (tree-difference '((a b c) 1 (d e f)) '((a b c) (1) (d x f)))
850          --> ((= = = . =) (/= 1 (1)) (= (/= e x) = . =) . =)
851 "
852   (cond
853     ((funcall test a b)     '=)
854     ((or (atom a) (atom b)) `(/= ,a ,b))
855     (t (cons (tree-difference (car a) (car b) :test test)
856              (tree-difference (cdr a) (cdr b) :test test)))))
857
858
859 (defun tree-structure-and-leaf-difference (a b &key (test (function eql)))
860   (cond
861     ((and (null a) (null b)) '=)
862     ((or (null a) (null b)) `(/= ,a ,b))
863     ((and (atom a) (atom b))
864      (if (funcall test a b)
865          '=
866          `(/= ,a ,b)))
867     ((or (atom a) (atom b)) `(/= ,a ,b))
868     (t (cons (tree-structure-and-leaf-difference (car a) (car b) :test test)
869              (tree-structure-and-leaf-difference (cdr a) (cdr b) :test test)))))
870
871 (defun replace-tree (dst src)
872   "
873 DO:     Copies the elements of the src tree into the dst tree.
874         If dst is missing cons cells, structure sharing occurs.
875 RETURN: dst
876 "
877   (cond ((atom dst)  src)
878         ((atom src) nil)
879         (t (if (or (atom (car dst)) (atom (car src)))
880                (setf (car dst) (car src))
881                (replace-tree (car dst) (car src)))
882            (if (or (atom (cdr dst)) (atom (cdr src)))
883                (setf (cdr dst) (cdr src))
884                (replace-tree (cdr dst) (cdr src)))
885            dst)))
886
887
888 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
889 ;;; ;; Sets
890
891
892 ;;; (DEFUN CONS-LESSP (A B)
893 ;;;   "PRIVATE.
894 ;;; RETURN: a<=b
895 ;;; "
896 ;;;   (DO* ( (AP A (CDR AP))
897 ;;;          (AI (CAR AP) (CAR AP))
898 ;;;          (BP B (CDR BP))
899 ;;;          (BI (CAR BP) (CAR BP)) )
900 ;;;       ( (NOT (AND AI BI (EQ AI BI)))
901 ;;;         (ANY-LESSP AI BI) )
902 ;;;     )
903 ;;;   ) ;;cons-lessp
904
905
906 ;;; (DEFUN FORMATED-LESSP (A B)
907 ;;;   "PRIVATE.
908 ;;; RETURN: a<=b
909 ;;; "
910 ;;;   (STRING-LESSP (FORMAT NIL "~S" A) (FORMAT NIL "~S" B))
911 ;;;   );;formated-lessp
912
913
914 ;;; (DEFUN SYMBOL-LESSP (A B)
915 ;;;   "PRIVATE.
916 ;;; RETURN: a<=b
917 ;;; "
918 ;;;   (STRING-LESSP (SYMBOL-NAME A) (SYMBOL-NAME B))
919 ;;;   );;symbol-lessp
920
921
922 ;;; (DEFUN VECTOR-LESSP (A B)
923 ;;;   "PRIVATE.
924 ;;; RETURN: a<=b
925 ;;; "
926 ;;;   (IF (= (LENGTH A) (LENGTH B))
927 ;;;       (LOOP FOR I FROM 0 BELOW (LENGTH A)
928 ;;;             FOR AI = (AREF A I)
929 ;;;             FOR BI = (AREF B I)
930 ;;;             WHILE (EQ AI BI)
931 ;;;             ;;do (show ai bi)
932 ;;;             ;;finally (show ai bi) (show (or bi (not ai)))
933 ;;;             FINALLY (RETURN (ANY-LESSP AI BI)))
934 ;;;     (< (LENGTH A) (LENGTH B)))
935 ;;;   );;vector-lessp
936
937
938 ;;; (DEFUN ANY-LESSP (A B)
939 ;;;   "PRIVATE.
940 ;;; RETURN: a<=b
941 ;;; "
942 ;;;   (IF (EQ (TYPE-OF A) (TYPE-OF B))
943 ;;;       (FUNCALL
944 ;;;        (CDR (ASSOC
945 ;;;              (TYPE-OF A)
946 ;;;              '((BOOL-VECTOR . VECTOR-LESSP)
947 ;;;                (BUFFER . FORMATED-LESSP)
948 ;;;                (CHAR-TABLE . VECTOR-LESSP)
949 ;;;                (COMPILED-FUNCTION . VECTOR-LESSP)
950 ;;;                (CONS . CONS-LESSP)
951 ;;;                (FLOAT . <=)
952 ;;;                (FRAME . FORMATED-LESSP)
953 ;;;                (INTEGER . <=)
954 ;;;                (MARKER . <=)
955 ;;;                (OVERLAY . FORMATED-LESSP)
956 ;;;                (PROCESS . FORMATED-LESSP)
957 ;;;                (STRING . STRING-LESSP)
958 ;;;                (SUBR . FORMATED-LESSP)
959 ;;;                (SYMBOL . SYMBOL-LESSP)
960 ;;;                (VECTOR . VECTOR-LESSP)
961 ;;;                (WINDOW . FORMATED-LESSP)
962 ;;;                (WINDOW-CONFIGURATION . FORMATED-LESSP)
963 ;;;                ))) A B)
964 ;;;     (STRING-LESSP (SYMBOL-NAME (TYPE-OF A))
965 ;;;                   (SYMBOL-NAME (TYPE-OF B))))
966 ;;;   );;any-lessp
967
968
969 ;;; (DEFUN LIST-TO-SET-SORTED (LIST)
970 ;;;   "
971 ;;; RETURN: A set, that is a list where duplicate elements from `list' are removed.
972 ;;; NOTE:   This implementation first sorts the list, so its complexity should be
973 ;;;         of the order of O(N*(1+log(N))) [N==(length list)]
974 ;;;         BUT, it's still slower than list-to-set
975 ;;; "
976 ;;;   (IF (NULL LIST)
977 ;;;       NIL
978 ;;;     (LET* ((SORTED-LIST (SORT LIST 'ANY-LESSP))
979 ;;;            (FIRST (CAR SORTED-LIST))
980 ;;;            (REST  (CDR SORTED-LIST))
981 ;;;            (SET NIL))
982 ;;;       (LOOP WHILE REST DO
983 ;;;         (IF (EQ FIRST (CAR REST))
984 ;;;             (SETQ REST (CDR REST))
985 ;;;           (PROGN
986 ;;;             (PUSH FIRST SET)
987 ;;;             (SETQ FIRST (CAR REST)
988 ;;;                   REST  (CDR REST)))))
989 ;;;       SET)));;list-to-set-sorted
990
991 ;;; (loop for size = 10 then (* 10 size)
992 ;;;       for l1 = (make-list-of-random-numbers size)
993 ;;;       for l2 = (copy-seq l1)
994 ;;;       do
995 ;;;       (format t "~%-----------~%list-to-set        (~s)~%-----------" size)
996 ;;;       (finish-output)
997 ;;;       (time (setf l1 (list-to-set l1)))
998 ;;;       (format t "~%-----------~%list-to-set-sorted (~s)~%-----------" size)
999 ;;;       (finish-output)
1000 ;;;       (time (setf l2 (list-to-set l2))))
1001 ;; (array->list array) --> (coerce array 'list)
1002
1003 (defun test ()
1004   (test/list-lengths)
1005   (test/list-elements)
1006   (test/tree-find))
1007
1008 (test)
1009 ;;;; THE END ;;;;