Common Lisp is not dead. Fear it!
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))))