lists.lisp 10.1 KB
Newer Older
Nikodemus Siivola's avatar
Nikodemus Siivola committed
1 2
(in-package :alexandria)

3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19
(defun alist-plist (alist)
  "Returns a property list containing the same keys and values as the
association list ALIST in the same order."
  (let (plist)
    (dolist (pair alist)
      (push (car pair) plist)
      (push (cdr pair) plist))
    (nreverse plist)))

(defun plist-alist (plist)
  "Returns an association list containing the same keys and values as the
property list PLIST in the same order."
  (let (alist)
    (do ((tail plist (cddr tail)))
        ((endp tail) (nreverse alist))
      (push (cons (car tail) (cadr tail)) alist))))

Nikodemus Siivola's avatar
Nikodemus Siivola committed
20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53
(defun malformed-plist (plist)
  (error "Malformed plist: ~S" plist))

(defmacro doplist ((key val plist &optional values) &body body)
  "Iterates over elements of PLIST. BODY can be preceded by
declarations, and is like a TAGBODY. RETURN may be used to terminate
the iteration early. If RETURN is not used, returns VALUES."
  (multiple-value-bind (forms declarations) (parse-body body)
    (with-gensyms (tail loop results)
      `(block nil
         (flet ((,results ()
                  (let (,key ,val)
                    (declare (ignorable ,key ,val))
                    (return ,values))))
           (let* ((,tail ,plist)
                  (,key (if ,tail
                            (pop ,tail)
                            (,results)))
                 (,val (if ,tail
                           (pop ,tail)
                           (malformed-plist ',plist))))
            (declare (ignorable ,key ,val))
            ,@declarations
            (tagbody
               ,loop
               ,@forms
               (setf ,key (if ,tail
                              (pop ,tail)
                              (,results))
                     ,val (if ,tail
                              (pop ,tail)
                              (malformed-plist ',plist)))
               (go ,loop))))))))

Nikodemus Siivola's avatar
Nikodemus Siivola committed
54 55 56 57
(define-modify-macro appendf (&rest lists) append
  "Modify-macro for APPEND. Appends LISTS to the place designated by the first
argument.")

Luis Oliveira's avatar
Luis Oliveira committed
58 59 60 61
(define-modify-macro nconcf (&rest lists) nconc
  "Modify-macro for NCONC. Concatenates LISTS to place designated by the first
argument.")

62 63 64 65 66 67 68 69 70
(define-modify-macro unionf (list) union
  "Modify-macro for UNION. Saves the union of LIST and the contents of the
place designated by the first argument to the designated place.")

(define-modify-macro nunionf (list) nunion
  "Modify-macro for NUNION. Saves the union of LIST and the contents of the
place designated by the first argument to the designated place. May modify
either argument.")

Nikodemus Siivola's avatar
Nikodemus Siivola committed
71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118
(defun circular-list (&rest elements)
  "Creates a circular list of ELEMENTS."
  (let ((cycle (copy-list elements)))
    (nconc cycle cycle)))

(defun circular-list-p (object)
  "Returns true if OBJECT is a circular list, NIL otherwise."
  (and (listp object)
       (do ((fast object (cddr fast))
            (slow (cons (car object) (cdr object)) (cdr slow)))
           (nil)
         (unless (and (consp fast) (listp (cdr fast)))
           (return nil))
         (when (eq fast slow)
           (return t)))))

(defun circular-tree-p (object)
  "Returns true if OBJECT is a circular tree, NIL otherwise."
  (labels ((circularp (object seen)
             (and (consp object)
                  (do ((fast (cons (car object) (cdr object)) (cddr fast))
                       (slow object (cdr slow)))
                      ((or (not (consp fast)) (not (consp (cdr slow))))
                       (do ((tail object (cdr tail)))
                           ((not (consp tail))
                            nil)
                         (let ((elt (car tail)))
                           (circularp elt (cons object seen)))))
                    (when (or (eq fast slow) (member slow seen))
                      (return-from circular-tree-p t))))))
    (circularp object nil)))

(defun proper-list-p (object)
  "Returns true if OBJECT is a proper list."
  (cond ((not object)
         t)
        ((consp object)
         (do ((fast object (cddr fast))
              (slow (cons (car object) (cdr object)) (cdr slow)))
             (nil)
           (unless (and (listp fast) (consp (cdr fast)))
             (return (and (listp fast) (not (cdr fast)))))
           (when (eq fast slow)
             (return nil))))
        (t
         nil)))

(deftype proper-list ()
Nikodemus Siivola's avatar
Nikodemus Siivola committed
119 120
  "Type designator for proper lists. Implemented as a SATISFIES type, hence
not recommended for performance intensive use. Main usefullness as a type
Attila Lendvai's avatar
Attila Lendvai committed
121
designator of the expected type in a TYPE-ERROR."
Nikodemus Siivola's avatar
Nikodemus Siivola committed
122 123 124 125 126 127 128 129 130 131 132 133 134
  `(satisfies proper-list-p))

(defun lastcar (list)
  "Returns the last element of LIST. Signals a type-error if LIST is not a
proper list."
  (do ((last list fast)
       (fast list (cddr fast))
       (slow (cons (car list) (cdr list)) (cdr slow)))
      (nil)
    (when (endp fast)
      (return (cadr last)))
    (when (endp (cdr fast))
      (return (car fast)))
135 136
    (when (eq fast slow)
      (error 'type-error
Nikodemus Siivola's avatar
Nikodemus Siivola committed
137 138 139
             :datum list
             :expected-type '(and list (not circular-list))))))

140 141 142 143 144 145 146 147 148 149 150
(defun (setf lastcar) (object list)
  "Sets the last element of LIST. Signals a type-error if LIST is not a proper
list."
  (do ((last list fast)
       (fast list (cddr fast))
       (slow (cons (car list) (cdr list)) (cdr slow)))
      (nil)
    (when (endp fast)
      (return (setf (cadr last) object)))
    (when (endp (cdr fast))
      (return (setf (car fast) object)))
151 152
    (when (eq fast slow)
      (error 'type-error
153 154 155
             :datum list
             :expected-type '(and list (not circular-list))))))

Nikodemus Siivola's avatar
Nikodemus Siivola committed
156 157 158 159 160 161
(defun make-circular-list (length &key initial-element)
  "Creates a circular list of LENGTH with the given INITIAL-ELEMENT."
  (let ((cycle (make-list length :initial-element initial-element)))
    (nconc cycle cycle)))

(deftype circular-list ()
Nikodemus Siivola's avatar
Nikodemus Siivola committed
162 163 164
  "Type designator for circular lists. Implemented as a SATISFIES type, so not
recommended for performance intensive use. Main usefullness as the
expected-type designator of a TYPE-ERROR."
Nikodemus Siivola's avatar
Nikodemus Siivola committed
165 166
  `(satisfies circular-list-p))

Nikodemus Siivola's avatar
Nikodemus Siivola committed
167 168 169 170 171 172
(defun ensure-car (thing)
  "If THING is a CONS, its CAR is returned. Otherwise THING is returned."
  (if (consp thing)
      (car thing)
      thing))

173 174 175 176 177 178 179
(defun ensure-cons (cons)
  "If CONS is a cons, it is returned. Otherwise returns a fresh cons with CONS
  in the car, and NIL in the cdr."
  (if (consp cons)
      cons
      (cons cons nil)))

Nikodemus Siivola's avatar
Nikodemus Siivola committed
180 181 182 183 184 185
(defun ensure-list (list)
  "If LIST is a list, it is returned. Otherwise returns the list designated by LIST."
  (if (listp list)
      list
      (list list)))

186
(defun remove-from-plist (plist &rest keys)
187 188 189
  "Returns a propery-list with same keys and values as PLIST, except that keys
in the list designated by KEYS and values corresponding to them are removed.
The returned property-list may share structure with the PLIST, but PLIST is
190
not destructively modified. Keys are compared using EQ."
191
  (declare (optimize (speed 3)))
192 193
  ;; FIXME: unoptimal: (sans '(:a 1 :b 2) :a) has no need to copy the
  ;; tail.
194 195 196 197 198 199 200
  (loop for cell = plist :then (cddr cell)
        for key = (car cell)
        while cell
        unless (member key keys :test #'eq)
        collect key
        and do (assert (cdr cell) () "Not a proper plist")
        and collect (cadr cell)))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
201

202 203 204 205 206 207
(defun delete-from-plist (plist &rest keys)
  "Just like REMOVE-FROM-PLIST, but this version may destructively modify the
provided plist."
  ;; FIXME unoptimal
  (apply 'remove-from-plist plist keys))

208 209
(define-modify-macro remove-from-plistf (&rest keys) remove-from-plist)
(define-modify-macro delete-from-plistf (&rest keys) delete-from-plist)
210

211 212 213 214 215
(declaim (inline sans))
(defun sans (plist &rest keys)
  "Alias of REMOVE-FROM-PLIST for backward compatibility."
  (apply #'remove-from-plist plist keys))

Nikodemus Siivola's avatar
Nikodemus Siivola committed
216 217 218 219 220 221
(defun mappend (function &rest lists)
  "Applies FUNCTION to respective element(s) of each LIST, appending all the
all the result list to a single list. FUNCTION must return a list."
  (loop for results in (apply #'mapcar function lists)
        append results))

222 223 224 225 226 227 228
(defun setp (object &key (test #'eql) (key #'identity))
  "Returns true if OBJECT is a list that denotes a set, NIL otherwise. A list
denotes a set if each element of the list is unique under KEY and TEST."
  (and (listp object)
       (let (seen)
         (dolist (elt object t)
           (let ((key (funcall key elt)))
229
             (if (member key seen :test test)
230 231 232 233
                 (return nil)
                 (push key seen)))))))

(defun set-equal (list1 list2 &key (test #'eql) (key nil keyp))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
234 235
  "Returns true if every element of LIST1 matches some element of LIST2 and
every element of LIST2 matches some element of LIST1. Otherwise returns false."
236 237 238 239 240 241 242 243 244 245 246 247 248 249 250
  (let ((keylist1 (if keyp (mapcar key list1) list1))
        (keylist2 (if keyp (mapcar key list2) list2)))
    (and (dolist (elt keylist1 t)
           (or (member elt keylist2 :test test)
               (return nil)))
         (dolist (elt keylist2 t)
           (or (member elt keylist1 :test test)
               (return nil))))))

(defun map-product (function list &rest more-lists)
  "Returns a list containing the results of calling FUNCTION with one argument
from LIST, and one from each of MORE-LISTS for each combination of arguments.
In other words, returns the product of LIST and MORE-LISTS using FUNCTION.

Example:
251 252

 (map-product 'list '(1 2) '(3 4) '(5 6)) => ((1 3 5) (1 3 6) (1 4 5) (1 4 6)
253 254 255 256 257 258 259 260 261 262
                                              (2 3 5) (2 3 6) (2 4 5) (2 4 6))
"
  (labels ((%map-product (f lists)
             (let ((more (cdr lists))
                   (one (car lists)))
               (if (not more)
                   (mapcar f one)
                   (mappend (lambda (x)
                              (%map-product (curry f x) more))
                            one)))))
263
    (%map-product (if (functionp function)
264 265 266
                      function
                      (fdefinition function))
                  (cons list more-lists))))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
267

268 269 270 271 272 273
(defun flatten (tree)
  "Traverses the tree in order, collecting non-null leaves into a list."
  (let (list)
    (labels ((traverse (subtree)
               (when subtree
                 (if (consp subtree)
274
                     (progn
275 276 277 278 279
                       (traverse (car subtree))
                       (traverse (cdr subtree)))
                     (push subtree list)))))
      (traverse tree))
    (nreverse list)))