From sjl’s utilities (thanks so much for the nice docstrings). The goal here is to read some code and learn about (hidden) gems.

The following snippets should be copy-pastable. They are the ones I find most interesting, I left some behind.

To reduce the dependency load, Alexandria or Quickutil functions can be imported one by one with Quickutil.

Table of Contents

Higher order functions

See also https://github.com/mikelevins/folio2 and How to do functional programming in CL.

(defun juxt (&rest functions)
  "Return a function that will juxtapose the results of `functions`.
  This is like Clojure's `juxt`.  Given functions `(f0 f1 ... fn)`, this will
  return a new function which, when called with some arguments, will return
  `(list (f0 ...args...) (f1 ...args...) ... (fn ...args...))`.
  Example:
    (funcall (juxt #'list #'+ #'- #'*) 1 2)
    => ((1 2) 3 -1 2)
  "
  (lambda (&rest args)
    (mapcar (alexandria:rcurry #'apply args) functions)))
(defun nullary (function &optional result)
  "Return a new function that acts as a nullary-patched version of `function`.
  The new function will return `result` when called with zero arguments, and
  delegate to `function` otherwise.
  Examples:
    (max 1 10 2) ; => 10
    (max)        ; => invalid number of arguments
    (funcall (nullary #'max))          ; => nil
    (funcall (nullary #'max 0))        ; => 0
    (funcall (nullary #'max 0) 1 10 2) ; => 10
    (reduce #'max nil)                  ; => invalid number of arguments
    (reduce (nullary #'max) nil)        ; => nil
    (reduce (nullary #'max :empty) nil) ; => :empty
    (reduce (nullary #'max) '(1 10 2))  ; => 10
  "
  (lambda (&rest args)
    (if (null args) result (apply function args))))
(defmacro gathering (&body body)
  ;; https://github.com/sjl/cl-losh/blob/master/losh.lisp#L515
  "Run `body` to gather some things and return a fresh list of them.
  `body` will be executed with the symbol `gather` bound to a function of one
  argument.  Once `body` has finished, a list of everything `gather` was called
  on will be returned.
  It's handy for pulling results out of code that executes procedurally and
  doesn't return anything, like `maphash` or Alexandria's `map-permutations`.
  The `gather` function can be passed to other functions, but should not be
  retained once the `gathering` form has returned (it would be useless to do so
  anyway).
  Examples:
    (gathering
      (dotimes (i 5)
        (gather i))
    =>
    (0 1 2 3 4)
    (gathering
      (mapc #'gather '(1 2 3))
      (mapc #'gather '(a b)))
    =>
    (1 2 3 a b)
  "
  (with-gensyms (result)
    `(let ((,result (make-queue)))
      (flet ((gather (item)
               (enqueue item ,result)))
        (declare (dynamic-extent #'gather))
        ,@body)
      (queue-contents ,result))))

Here we need the queue struct.

(defstruct (queue (:constructor make-queue))
  (contents nil :type list)
  (last nil :type list)
  (size 0 :type fixnum))

;; real code is richer, with inline and inlinable function declarations.

(defun make-queue ()
  "Allocate and return a fresh queue."
  (make-queue%))

(defun queue-empty-p (queue)
  "Return whether `queue` is empty."
  (zerop (queue-size queue)))

(defun enqueue (item queue)
  "Enqueue `item` in `queue`, returning the new size of the queue."
  (let ((cell (cons item nil)))
    (if (queue-empty-p queue)
      (setf (queue-contents queue) cell)
      (setf (cdr (queue-last queue)) cell))
    (setf (queue-last queue) cell))
  (incf (queue-size queue)))

(defun dequeue (queue)
  "Dequeue an item from `queue` and return it."
  (when (zerop (decf (queue-size queue)))
    (setf (queue-last queue) nil))
  (pop (queue-contents queue)))

(defun queue-append (queue list)
  "Enqueue each element of `list` in `queue` and return the queue's final size."
  (loop :for item :in list
        :for size = (enqueue item queue)
        :finally (return size)))

Sequences

(defun frequencies (sequence &key (test 'eql))
  ;; https://github.com/sjl/cl-losh/blob/master/losh.lisp#L1910
  "Return a hash table containing the frequencies of the items in `sequence`.
  Uses `test` for the `:test` of the hash table.
  Example:
    (frequencies '(foo foo bar))
    => {foo 2
        bar 1}
  "
  (iterate
    (with result = (make-hash-table :test test))
    (for i :in-whatever sequence)
    (incf (gethash i result 0))
    (finally (return result))))
(defun proportions (sequence &key (test 'eql) (float t))
  "Return a hash table containing the proportions of the items in `sequence`.
  Uses `test` for the `:test` of the hash table.
  If `float` is `t` the hash table values will be coerced to floats, otherwise
  they will be left as rationals.
  Example:
    (proportions '(foo foo bar))
    => {foo 0.66666
        bar 0.33333}
    (proportions '(foo foo bar) :float nil)
    => {foo 2/3
        bar 1/3}
  "
  (let* ((freqs (frequencies sequence :test test))
         (total (reduce #'+ (hash-table-values freqs)
                        :initial-value (if float 1.0 1))))
    (mutate-hash-values (lambda (v) (/ v total))
                        freqs)))
(defun group-by (function sequence &key (test #'eql) (key #'identity))
  "Return a hash table of the elements of `sequence` grouped by `function`.
  This function groups the elements of `sequence` into buckets.  The bucket for
  an element is determined by calling `function` on it.
  The result is a hash table (with test `test`) whose keys are the bucket
  identifiers and whose values are lists of the elements in each bucket.  The
  order of these lists is unspecified.
  If `key` is given it will be called on each element before passing it to
  `function` to produce the bucket identifier.  This does not effect what is
  stored in the lists.
  Examples:
    (defparameter *items* '((1 foo) (1 bar) (2 cats) (3 cats)))
    (group-by #'first *items*)
    ; => { 1 ((1 foo) (1 bar))
    ;      2 ((2 cats))
    ;      3 ((3 cats)) }
    (group-by #'second *items*)
    ; => { foo  ((1 foo))
    ;      bar  ((1 bar))
    ;      cats ((2 cats) (3 cats)) }
    (group-by #'evenp *items* :key #'first)
    ; => { t   ((2 cats))
    ;      nil ((1 foo) (1 bar) (3 cats)) }
  "
  (iterate
    (with result = (make-hash-table :test test))
    (for i :in-whatever sequence)
    (push i (gethash (funcall function (funcall key i)) result))
    (finally (return result))))


(defun take-list (n list)
  (iterate (declare (iterate:declare-variables))
           (repeat n)
           (for item :in list)
           (collect item)))

(defun take-seq (n seq)
  (subseq seq 0 (min n (length seq))))
(defmacro do-repeat (n &body body)
  "Perform `body` `n` times."
  `(dotimes (,(gensym) ,n)
     ,@body))
(defmacro do-range (ranges &body body)
  "Perform `body` on the given `ranges`.

  Each range in `ranges` should be of the form `(variable from below)`.  During
  iteration `body` will be executed with `variable` bound to successive values
  in the range [`from`, `below`).

  If multiple ranges are given they will be iterated in a nested fashion.

  Example:

    (do-range ((x  0  3)
               (y 10 12))
      (pr x y))
    ; =>
    ; 0 10
    ; 0 11
    ; 1 10
    ; 1 11
    ; 2 10
    ; 2 11

  "
  (if (null ranges)
    `(progn ,@body)
    (destructuring-bind (var from below) (first ranges)
      `(loop :for ,var :from ,from :below ,below
             :do (do-range ,(rest ranges) ,@body)))))
(defun enumerate (sequence &key (start 0) (step 1) key)
  "Return an alist of `(n . element)` for each element of `sequence`.
  `start` and `step` control the values generated for `n`, NOT which elements of
  the sequence are enumerated.
  Examples:
    (enumerate '(a b c))
    ; => ((0 . A) (1 . B) (2 . C))
    (enumerate '(a b c) :start 1)
    ; => ((1 . A) (2 . B) (3 . C))
    (enumerate '(a b c) :key #'ensure-keyword)
    ; => ((0 . :A) (1 . :B) (2 . :C))
  "
  (iterate (for el :in-whatever sequence)
           (for n :from start :by step)
           (collect (cons n (if key
                              (funcall key el)
                              el)))))

uses iterate, on Quicklisp (see also Shinmera’s For).

The followingtake is taken from Serapeum (also available in CL21).

The original helpers (take-list, etc) are originally inlined for optimal performance with a custom “defun-inline”.

(defun take (n seq)
  "Return a fresh sequence of the first `n` elements of `seq`.
  The result will be of the same type as `seq`.
  If `seq` is shorter than `n` a shorter result will be returned.
  Example:
    (take 2 '(a b c))
    => (a b)
    (take 4 #(1))
    => #(1)
  From Serapeum.
  "
  (check-type n array-index)
  (ctypecase seq
    (list (take-list n seq))
    (sequence (take-seq n seq))))

(defun take-list (n list)
  (iterate (declare (iterate:declare-variables))
           (repeat n)
           (for item :in list)
           (collect item)))

(defun take-seq (n seq)
  (subseq seq 0 (min n (length seq))))
(defun take-while-list (predicate list)
  (iterate (for item :in list)
           (while (funcall predicate item))
           (collect item)))

(defun take-while-seq (predicate seq)
  (subseq seq 0 (position-if-not predicate seq)))

(defun take-while (predicate seq)
  "Take elements from `seq` as long as `predicate` remains true.
  The result will be a fresh sequence of the same type as `seq`.
  Example:
    (take-while #'evenp '(2 4 5 6 7 8))
    ; => (2 4)
    (take-while #'evenp #(1))
    ; => #()
  "
  (ctypecase seq
    (list (take-while-list predicate seq))
    (sequence (take-while-seq predicate seq))))
(defun drop-list (n list)
  (copy-list (nthcdr n list)))

(defun drop-seq (n seq)
  (subseq seq (min n (length seq))))

(defun drop (n seq)
  "Return a fresh copy of the `seq` without the first `n` elements.
  The result will be of the same type as `seq`.
  If `seq` is shorter than `n` an empty sequence will be returned.
  Example:
    (drop 2 '(a b c))
    => (c)
    (drop 4 #(1))
    => #()
  From Serapeum.
  "
  (check-type n array-index)
  (ctypecase seq
    (list (drop-list n seq))
    (sequence (drop-seq n seq))))
(defun drop-while-list (predicate list)
  (iterate (for tail :on list)
           (while (funcall predicate (first tail)))
           (finally (return (copy-list tail)))))

(defun drop-while-seq (predicate seq)
  (let ((start (position-if-not predicate seq)))
    (if start
      (subseq seq start)
      (subseq seq 0 0))))

(defun drop-while (predicate seq)
  "Drop elements from `seq` as long as `predicate` remains true.
  The result will be a fresh sequence of the same type as `seq`.
  Example:
    (drop-while #'evenp '(2 4 5 6 7 8))
    ; => (5 6 7 8)
    (drop-while #'evenp #(2))
    ; => #(2)
  "
  (ctypecase seq
    (list (drop-while-list predicate seq))
    (sequence (drop-while-seq predicate seq))))
(defun extrema (predicate sequence)
  "Return the smallest and largest elements of `sequence` according to `predicate`.
  `predicate` should be a strict ordering predicate (e.g. `<`).
  Returns the smallest and largest elements in the sequence as two values,
  respectively.
  "
  (iterate (with min = (elt sequence 0))
           (with max = (elt sequence 0))
           (for el :in-whatever sequence)
           (when (funcall predicate el min) (setf min el))
           (when (funcall predicate max el) (setf max el))
           (finally (return (values min max)))))
(defun summation (sequence &key key)
  "Return the sum of all elements of `sequence`.
  If `key` is given, it will be called on each element to compute the addend.
  This function's ugly name was chosen so it wouldn't clash with iterate's `sum`
  symbol.  Sorry.
  Examples:
    (sum #(1 2 3))
    ; => 6
    (sum '(\"1\" \"2\" \"3\") :key #'parse-integer)
    ; => 6
    (sum '(\"1\" \"2\" \"3\") :key #'length)
    ; => 3
  "
  (if key
    (iterate (for n :in-whatever sequence)
             (sum (funcall key n)))
    (iterate (for n :in-whatever sequence)
             (sum n))))
(defun product (sequence &key key)
  ;; https://github.com/sjl/cl-losh/blob/master/losh.lisp#L2181
  "Return the product of all elements of `sequence`.
  If `key` is given, it will be called on each element to compute the
  multiplicand.
  Examples:
    (product #(1 2 3))
    ; => 6
    (product '(\"1\" \"2\" \"3\") :key #'parse-integer)
    ; => 6
    (product '(\"1\" \"2\" \"3\") :key #'length)
    ; => 1
  "
  (if key
    (iterate (for n :in-whatever sequence)
             (multiplying (funcall key n)))
    (iterate (for n :in-whatever sequence)
             (multiplying n))))

Debugging and logging

(defun pr (&rest args)
  "Print `args` readably, separated by spaces and followed by a newline.
  Returns the first argument, so you can just wrap it around a form without
  interfering with the rest of the program.
  This is what `print` should have been.
  "
  (format t "~{~S~^ ~}~%" args)
  (finish-output)
  (first args))
(defmacro prl (&rest args)
  "Print `args` labeled and readably.
  Each argument form will be printed, then evaluated and the result printed.
  One final newline will be printed after everything.
  Returns the last result.
  Examples:
    (let ((i 1)
          (l (list 1 2 3)))
      (prl i (second l)))
    ; =>
    i 1
    (second l) 2
  "
  `(prog1
    (progn ,@(mapcar (lambda (arg) `(pr ',arg ,arg)) args))
    (terpri)
    (finish-output)))
(defmacro shut-up (&body body)
  "Run `body` with stdout and stderr redirected to the void."
  `(let ((*standard-output* (make-broadcast-stream))
         (*error-output* (make-broadcast-stream)))
    ,@body))
(defmacro comment (&body body)
  "Do nothing with a bunch of forms.
  Handy for block-commenting multiple expressions.
  "
  (declare (ignore body))
  nil)

Pretty-print a table.

Didn’t test.

See also https://github.com/vindarel/cl-ansi-term

(defun print-table (rows)
  ;; https://github.com/sjl/cl-losh/blob/master/losh.lisp#L2334
  "Print `rows` as a nicely-formatted table.
  Each row should have the same number of colums.
  Columns will be justified properly to fit the longest item in each one.
  Example:
    (print-table '((1 :red something)
                   (2 :green more)))
    =>
    1 | RED   | SOMETHING
    2 | GREEN | MORE
  "
  (when rows
    (iterate
      (with column-sizes =
            (reduce (alexandria:curry #'mapcar #'max)
                    (mapcar (alexandria:curry #'mapcar (compose #'length #'aesthetic-string))
                            rows))) ; lol
      (for row :in rows)
      (format t "~{~vA~^ | ~}~%" (weave column-sizes row))))
  (values))


;; from Quickutil.
(defun ensure-function (function-designator)
    "Returns the function designated by `function-designator`:
if `function-designator` is a function, it is returned, otherwise
it must be a function name and its `fdefinition` is returned."
    (if (functionp function-designator)
        function-designator
        (fdefinition function-designator)))

;; from Quickutil.
(defun compose (function &rest more-functions)
    "Returns a function composed of `function` and `more-functions` that applies its ;
arguments to to each in turn, starting from the rightmost of `more-functions`,
and then calling the next one with the primary value of the last."
    (declare (optimize (speed 3) (safety 1) (debug 1)))
    (reduce (lambda (f g)
              (let ((f (ensure-function f))
                    (g (ensure-function g)))
                (lambda (&rest arguments)
                  (declare (dynamic-extent arguments))
                  (funcall f (apply g arguments)))))
            more-functions
            :initial-value function))

(defun make-gensym-list (length &optional (x "G"))
    "Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`,
using the second (optional, defaulting to `\"G\"`) argument."
    (let ((g (if (typep x '(integer 0)) x (string x))))
      (loop repeat length
            collect (gensym g))))

  (define-compiler-macro compose (function &rest more-functions)
    (labels ((compose-1 (funs)
               (if (cdr funs)
                   `(funcall ,(car funs) ,(compose-1 (cdr funs)))
                   `(apply ,(car funs) arguments))))
      (let* ((args (cons function more-functions))
             (funs (make-gensym-list (length args) "COMPOSE")))
        `(let ,(loop for f in funs for arg in args
                     collect `(,f (ensure-function ,arg)))
           (declare (optimize (speed 3) (safety 1) (debug 1)))
           (lambda (&rest arguments)
             (declare (dynamic-extent arguments))
             ,(compose-1 funs))))))


;; from Quickutil.
(defun weave (&rest lists)
    "Return a list whose elements alternate between each of the lists
`lists`. Weaving stops when any of the lists has been exhausted."
    (apply #'mapcan #'list lists))

(defun aesthetic-string (thing)
  "Return the string used to represent `thing` when printing aesthetically."
  (format nil "~A" thing))

Pretty print a hash-table:

(defun print-hash-table (hash-table &optional (stream t))
  "Print a pretty representation of `hash-table` to `stream.`
  Respects `*print-length*` when printing the elements.
  "
  (let* ((keys (alexandria:hash-table-keys hash-table))
         (vals (alexandria:hash-table-values hash-table))
         (count (hash-table-count hash-table))
         (key-width (-<> keys
                      (mapcar (alexandria:compose #'length #'prin1-to-string) <>)
                      (reduce #'max <> :initial-value 0)
                      (clamp 0 20 <>))))
    (print-unreadable-object (hash-table stream :type t)
      (princ
        ;; Something shits the bed and output gets jumbled (in SBCL at least) if
        ;; we try to print to `stream` directly in the format statement inside
        ;; `print-unreadable-object`, so instead we can just render to a string
        ;; and `princ` that.
        (format nil ":test ~A :count ~D {~%~{~{  ~vs ~s~}~%~}}"
                (hash-table-test hash-table)
                count
                (loop
                  :with limit = (or *print-length* 40)
                  :for key :in keys
                  :for val :in vals
                  :for i :from 0 :to limit
                  :collect
                  (if (= i limit)
                    (list key-width :too-many-items (list (- count i) :more))
                    (list key-width key val))))
        stream)))
  (terpri stream)
  (values))

(defun pht (hash-table &optional (stream t))
  "Synonym for `print-hash-table` for less typing at the REPL."
  (print-hash-table hash-table stream))

(defun print-hash-table-concisely (hash-table &optional (stream t))
  "Print a concise representation of `hash-table` to `stream.`
  Should respect `*print-length*` when printing the elements.
  "
  (print-unreadable-object (hash-table stream :type t)
    (prin1 (hash-table-test hash-table))
    (write-char #\space stream)
    (prin1 (hash-table-contents hash-table) stream)))

;; needed:
(defun clamp (from to value)
  "Clamp `value` between `from` and `to`."
  (let ((max (max from to))
        (min (min from to)))
    (cond
      ((> value max) max)
      ((< value min) min)
      (t value))))

;; see
(defmacro -<> (expr &rest forms)
  "Thread the given forms, with `<>` as a placeholder."
  ;; I am going to lose my fucking mind if I have to program lisp without
  ;; a threading macro, but I don't want to add another dep to this library, so
  ;; here we are.
  `(let* ((<> ,expr)
          ,@(mapcar (lambda (form)
                      (if (symbolp form)
                        `(<> (,form <>))
                        `(<> ,form)))
                    forms))
     <>))

For the -<> threading macro, see cl-arrows and arrow-macros.

Profiling (with SBCL)

#+sbcl
(defun dump-profile (filename)
  (with-open-file (*standard-output* filename
                                     :direction :output
                                     :if-exists :supersede)
    (sb-sprof:report :type :graph
                     :sort-by :cumulative-samples
                     :sort-order :ascending)
    (sb-sprof:report :type :flat
                     :min-percent 0.5)))

#+sbcl
(defun start-profiling (&key call-count-packages (mode :cpu))
  "Start profiling performance.  SBCL only.
  `call-count-packages` should be a list of package designators.  Functions in
  these packages will have their call counts recorded via
  `sb-sprof::profile-call-counts`.
  "
  (sb-sprof::reset)
  (-<> call-count-packages
    (mapcar #'mkstr <>)
    (mapcar #'string-upcase <>)
    (mapc #'sb-sprof::profile-call-counts <>))
  (sb-sprof::start-profiling :max-samples 50000
                             :mode mode
                             ; :mode :time
                             :sample-interval 0.01
                             :threads :all))

#+sbcl
(defun stop-profiling (&optional (filename "lisp.prof"))
  "Stop profiling performance and dump a report to `filename`.  SBCL only."
  (sb-sprof::stop-profiling)
  (dump-profile filename))

#+sbcl
(defmacro profile (&body body)
  "Profile `body` and dump the report to `lisp.prof`."
  `(progn
     (start-profiling)
     (unwind-protect
         (time (progn ,@body))
       (stop-profiling))))