How to generate all the permutations of elements in a list one at a time in Lisp?
Here's a way (following the code structure by @coredump from their answer; runs about 4x faster on tio.run):
(defun permutations (list callback)
(if (null list)
(funcall callback #())
(let* ((all (cons 'head (copy-list list))) ; head sentinel FTW!
(perm (make-array (length list))))
(labels
((g (p i &aux (q (cdr p))) ; pick all items in arbitrary order:
(cond
((cdr q) ; two or more items left:
(loop while q do ; for each item in q:
(setf (svref perm i) (car q)) ; grab the item
(rplacd p (cdr q)) ; pluck it out
(g all (1+ i)) ; get the rest!
(rplacd p q) ; then, put it back
(pop p) ; and advance
(pop q))) ; the pointers
(T ; one last item left in q:
(setf (svref perm i) (car q)) ; grab the last item
(funcall callback perm))))) ; and call the callback
(g all 0)))))
Testing:
; [20]> (permutations '(1 2 3) #'(lambda (x) (princ x) (princ #\ )))
; #(1 2 3) #(1 3 2) #(2 1 3) #(2 3 1) #(3 1 2) #(3 2 1)
; [58]> (let ((acc (list))) (permutations '(1 2 3) #'(lambda (x)
; (push (coerce x 'list) acc))) (reverse acc))
; ((1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1))
; [59]> (let ((acc (list))) (permutations '() #'(lambda (x)
; (push (coerce x 'list) acc))) (reverse acc))
; (NIL)
This uses recursion to build the n nested loops computational structure for the n-long input list, at run time, with the fixed i = 0, 1, ..., n-1 in each nested loop being the position in the result-holding permutation array to put the picked item into. And when all the n positions in the array are filled, once we're inside the innermost loop (which isn't even a loop anymore as it has just one element left to process), the user-supplied callback is called with that permutation array as its argument. The array is reused for each new permutation.
Implements the "shrinking domains" paradigm as in this high-level pseudocode with list splicing and pattern matching:
perms [] = [[]]
perms xs = [[x, ...p]
FOR [as, [x, ...bs]] IN (splits xs) -- pluck x out
FOR p IN perms [...as, ...bs]] -- and recurse
(where splits of a list produces all possible pairs of its sublists which, appended together, reconstitute the list; in particular, splits [] = [ [[],[]] ] and splits [1] = [ [[],[1]] , [[1],[]] ]); or, in a simple imperative pseudocode,
for item1 in list:
domain2 = remove item1 from list by position
for item2 in domain2:
domain3 = remove item2 from domain2 by position
for item3 in domain3:
......
......
for item_n in domain_n:
(callback
(make-array n :initial-contents
(list item1 item2 ... item_n)))
but in the real code we do away with all the quadratic interim storage used by this pseudocode, completely, by surgically manipulating the list structure. About the only advantage of the linked lists is their O(1) node removal capability; we might as well use it!
update: special-casing the last two elements of a permutation as well (by unrolling the last loop into the corresponding two calls to the callback) gives about ~ 1.5x additional speedup.
(In case the TIO link ever rots, here's the pastebin with the working code.)
update: this technique is known as recursive-backtracking, creating the n nested loops backtracking computational structure by recursion.
General principle
Suppose you have the following range function:
(defun range (start end &optional (step 1))
(loop for x from start below end by step collect x))
You can accept another parameter, a function, and call it for each element:
(defun range-generator (callback start end &optional (step 1))
(loop for x from start below end by step do (funcall callback x)))
This gives the caller control over the iteration process:
(block root
(range-generator (lambda (v)
(print v)
(when (>= v 10)
(return-from root)))
0 300))
0
1
2
3
4
5
6
7
8
9
10
See RETURN, BLOCK.
Permutations
If you want to avoid allocating too much memory, you can arrange for your code to allocate intermediate data-structures once and reuse them for each call to the callback. Here is an annotated example:
(defun permutations% (list callback)
(when list
(let* (;; Size of input list
(size (length list))
;; EMPTY is a sentinel value which is guaranteed to
;; never be equal to any element from LIST.
(empty (gensym "SENTINEL"))
;; Working vector containing elements from LIST, or
;; EMPTY. This vector is mutated to remember which
;; element from the input LIST was already added to the
;; permutation.
(items (make-array size :initial-contents list))
;; Working vector containing the current
;; permutation. It contains a FILL-POINTER so that we
;; can easily call VECTOR-PUSH and VECTOR-POP to
;; add/remove elements.
(permutation (make-array (length items) :fill-pointer 0)))
;; Define a local recursive function named POPULATE, which
;; accepts a COUNT argument. The count starts at SIZE and
;; decreases at each recursive invocation, allowing the
;; function to know when it should end.
(labels ((populate (count)
(if (plusp count)
;; Loop over ITEMS by index
(dotimes (item-index size)
(let ((item (svref items item-index)))
;; We found an ITEM which is not yet
;; present in PERMUTATION.
(unless (eq item empty)
;; Push that element
(vector-push item permutation)
;; Replace current value in ITEMS by EMPTY
(setf (svref items item-index) empty)
;; POPULATE will recursively populate
;; the remaining elements in
;; PERMUTATION and call CALLBACK. Once
;; it is done, it will return here.
(populate (1- count))
;; There are other items to process in
;; current loop. Reset the state to how
;; it was before calling POPULATE.
;; Replace the EMPTY value by the
;; original ITEM at current index.
(setf (svref items item-index) item)
;; Remove ITEM from PERMUTATION.
(vector-pop permutation))))
;; We filled PERMUTATION with SIZE elements.
;; Call CALLBACK with PERMUTATION. Note: the
;; callback function is always given the same
;; vector, but its content changes over
;; time. The value passed to CALLBACK is thus
;; valid only during the time we are
;; executing CALLBACK. If the caller needs to
;; keep a copy of the current permutation, it
;; should COPY-LIST the value.
(funcall callback permutation))))
;; Initiate recursive function with current SIZE.
(populate size)))))
The function accepts a list and a callback, which is a function accepting one parameter, the current permutation. Note that this parameter is valid only during the dynamic extent of the call, because once the call returns, the same data-structure that was passed to the callback is modified.
As explained above, you can call any function, in particular closure which refers to other variable in the lexical environment. Here, the anonymous lambda increment the count variable, which allows to count the number of permutations, without storing them in a list and getting the size of the list:
(time
(let ((count 0))
(permutations% '(a b c d e f g h i j k) (lambda (p) (incf count)))
count))
=> 39916800
Evaluation took:
6.455 seconds of real time
6.438200 seconds of total run time (6.437584 user, 0.000616 system)
99.74% CPU
17,506,444,509 processor cycles
0 bytes consed
In the above report, 0 bytes consed represents the approximate number of memory allocated (not counting stack allocation). You can also offer a safer version of the function which copies each permutation before sending it to the callback function.
(defun permutations (list callback)
(permutations% list (lambda (permutation)
(funcall callback (coerce permutation 'list)))))
See also
See also the answer from Will Ness, which manages to handle the set of remaining elements with a list, thus avoiding the need to filter through EMPTY elements.