Source

qtility / list.lisp

Full commit
;;;; list.lisp
;;;; Copyright (c) 2011 Robert Smith

;;;; List voodoo.

(in-package #:qtility)

(defun range (start end &key (step 1) (key 'identity))
  "Return the list of numbers n such that START <= n < END and n =
START + k*STEP. If a function KEY is provided, then apply KEY to each
number."
  (assert (<= start end))
  (loop :for i :from start :below end :by step :collecting (funcall key i)))

(defun iota (n)
  "Return [0, ..., N-1]."
  (assert (non-negative-p n))
  (range 0 n))

(defun iota+1 (n)
  "Return [1, ..., N]."
  (assert (>= n 1))
  (range 1 (1+ n)))

(defun replicate (n x)
  "Make a list of N copies of X."
  (declare (type (integer 0) n))
  (make-list n :initial-element x))

(defun slice (list indexes)
  "Compute the slice of a list LIST at indexes INDEXES."
  (loop
    :for i :in indexes
    :collect (nth i list) :into s
    :finally (return s)))

(defun transpose (lists)
  "Analog to matrix transpose for a list of lists given by LISTS."
  (loop
     :for ls := lists :then (mapcar #'cdr ls)
     :until (position-if #'null ls)
     :collecting (mapcar #'car ls)))

(defun zip (&rest lists)
  "Equivalent to UNZIP. Hooray for idempotency."
  (transpose lists))

(defun unzip (&rest lists)
  "Equivalent to ZIP. Hooray for idempotency."
  (transpose lists))

(defun long-zip (fill &rest lists)
  "ZIP using the longest, rather than shortest list, filling with
FILL."
  (let ((longest (reduce #'max lists :key #'length)))
    (apply #'zip (loop
		    :for i :in lists
		    :collect (append i (make-list (- longest (length i))
                                                  :initial-element fill))))))

(defun enumerate (list)
  "Equivalent to (zip (iota (length list)) list)."
  (loop
     :for i :in list
     :for j :from 0
     :collect (list j i)))
  
(defun flatten-once (list)
  "Flatten LIST once."
  (reduce #'append list :key #'listify))

(defun flatten (&rest xs)
  "Flatten (and append) all lists XS completely."
  (labels ((rec (xs acc)
             (cond ((null xs)  acc)
                   ((consp xs) (rec (car xs) (rec (cdr xs) acc)))
                   (t          (cons xs acc)))))
    (rec xs nil)))

(defun ncycle (list)
  "Mutate LIST into a circlular list."
  (and list
       (setf (rest (last list)) list)))

(defun cycle (list)
  "Make LIST into a circular list."
  (and list
       (ncycle (copy-list list))))

(defun nest (function initial-value count)
  "Compute a COUNT compositions of FUNCTION on INITIAL-VALUE."
  (loop
    :repeat count
    :for y := initial-value :then (funcall function y)
    :finally (return y)))

(defun nest-list (function initial-value count)
  "Compute a list of COUNT compositions of FUNCTION on INITIAL-VALUE."
  (loop
    :repeat count
    :for y := initial-value :then (funcall function y)
    :collect y))

(defun safe-nth (n list &optional if-out-of-bounds)
  "Find the Nth element of LIST. If N is out of bounds, return
IF-OUT-OF-BOUNDS (NIL by default)."
  (if (>= n (length list))
      if-out-of-bounds
      (nth n list)))

(defun mapply (f list)
  "Apply F to each list of arguments contained within LIST and collect
the results."
  (mapcar #'(lambda (x) (apply f x)) list))

(defun cartesian-product (l1 l2 &optional (f 'cl:list))
  "Compute the cartesian product of L1 and L2 as if they were
sets. Optionally, map the function F across the product."
  (loop
     :for i :in l1
     :appending (loop
                   :for j :in l2
                   :collecting (funcall f i j))))

;;; TODO: Define a SETF method for END.
(defun end (list)
  "Return the last element of LIST and whether or not it was
  empty."
  (values (car (last list)) (null list)))

(defun tabulate (f n)
  "Return a list evaluations of F over the integers [0,n). Mimics the
SML function of the same name."
  (mapcar f (iota n)))

(defun collect-reduce (f list &key (initial-value (car list) initial-value-p?))
  "Collects intermediate reduction results of applying F to LIST. More
  or less equivalent to (loop :for i :in list :collect (reduce f i))."
  (loop
     :for j :in (if (not initial-value-p?) (cdr list) list)
     :for r := (funcall f initial-value j) :then (funcall f r j)
     :collect r))

(defun weave (&rest lists)
  "Return a list whose elements alternate between LIST1 and LIST2."
  (flatten-once (transpose lists)))

(defun riffle (list x)
  "Insert the item X in between each element of LIST."
  (weave list (replicate (1- (length list)) x)))

(defun extend (xs x)
  "Adjoin X to the end of XS."
  (append xs (list x)))

(defun list-to-vector (list)
  "Convert LIST into a vector."
  (make-array (length list) :initial-contents list))

(defun sequence-to-list (seq)
  "Convert the sequence SEQ into a list."
  (concatenate 'list seq))

(defun explode (string)
  "The classic EXPLODE function. Take a string and return a list of
  its characters."
  (sequence-to-list string))

(defun implode (list-of-characters)
  "The classic IMPLODE function. Take a list of characters and return
  the corresponding string."
  (coerce (list-to-vector list-of-characters) 'string))