How to generate all the permutations of elements in a list one at a time in Lisp?
Asked Answered
H

2

3

I already have the code to generate all the permutations for a list of elements. However, I realized that if I want to manipulate the lists that are generated, I would need to traverse this list. This list can be potentially massive and therefore expensive to keep. I wanted to know if there was a way to generate the permutations by each call so that I can check if the list matches with what I need and if not I will generate the next permutation. (Each time the function will return a list one at a time.)

My code:

(defun allPermutations (list) 
  (cond
     ((null list)  nil) 
     ((null (cdr list))  (list list)) 
     (t  (loop for element in list 
               append (mapcar (lambda (l) (cons element l))
                              (allPermutations (remove element list))))))) 
Hormonal answered 16/4, 2018 at 2:49 Comment(0)
F
5

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.

Fervent answered 16/4, 2018 at 7:25 Comment(7)
I've edited the OP's code into the question, from their comment. It's hard to see how your general guideline can be applied to get the answer. If we insert the return-from into the mapcar's lambda function, the list that is mapped over will still have to be created in full. A solution seems to be creating the n nested loops for the argument list of length n (returning the first acceptable permutation from the deepest level); but how? Is writing a macro the only way to achieve this?Kilkenny
@WillNess (1) Remove append, just "do". (2) Wrap the callback in a lambda, which receives a permutation and builds the next ones, and eventually calls the original callback. You get a tower of callback functions that reference each others, which is going to allocate, too, but it works in principle.Fervent
ok, so yeah, you do create the nested loops structure with recursion, which is nice and good. your EMPTY marking trick though feels a bit like cheating, too ad-hoc. :) I was expecting to see the indices manipulated and permutation created from them as you do, yes, but I hoped also to see the shrinking domains as we pick items one by one on our way down. thinking a bit more about it, I now see this done all with just surgical list manipulations, building the permutation by consing. Passing the updated state down the recursion depths BTW would give us roughly a Prolog implementation, I think.Kilkenny
I think this is a good, interesting question. I wish it weren't negatively scored, at least. --- re surgical manipulations, it'd follow your code structure: pluck an item from the list, cons it onto the permutation being built, recurse, uncons, restore the item into the list in its original place. will need to save few pointers (cells) fro that. start the recursion with the copied list of course, maybe also prepending a head sentinel to simplify the coding. Interesting stuff!Kilkenny
@WillNess Re shrinking domain: I could use a preallocated list instead, and point to a cons-cell inside it while recursing; that would require to rotate elements inside that list. I thought about the vector approach first. I see nothing wrong with gensym, I needed a fresh object, that could have been a fresh cons or a hash-table, but gensym works fine.Fervent
@Fervent I wasn't referring to gensym per se with the "cheating" remark, just that there were no shrinking domains. No need to rotate, just pluck an element out and heal the wound, while keeping the "current" node (the one after which was the picked element situated, in the list ... that's why the head sentinel trick looks like it'd be useful here), and the next-after-the-chosen node as well, as state on each level of recursion. just a few RPLACD calls is all that's needed. Gotta love those RPLACDs! :) Maybe I'll code it up and post an answer here...Kilkenny
@Fervent OK, I've posted the solution I was talking about, if this still interests you.Kilkenny
K
5

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 a pastebin with the working code, or a github gist.)

update: this technique is known as , creating the n nested loops backtracking computational structure by recursion.

Kilkenny answered 18/4, 2018 at 19:12 Comment(1)
Nice approach, I saw you changed your answer to avoid consing for each permutation. Well done.Fervent

© 2022 - 2024 — McMap. All rights reserved.