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)))))))
Will Ness
  • 62,652
  • 8
  • 86
  • 167
Michelle
  • 355
  • 1
  • 11

2 Answers2

4

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.

coredump
  • 32,298
  • 4
  • 39
  • 63
  • 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? – Will Ness Apr 17 '18 at 09:34
  • @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. – coredump Apr 17 '18 at 13:08
  • 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. – Will Ness Apr 18 '18 at 09:57
  • 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! – Will Ness Apr 18 '18 at 10:07
  • @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. – coredump Apr 18 '18 at 12:37
  • @coredump 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... – Will Ness Apr 18 '18 at 15:57
  • @coredump OK, I've posted the solution I was talking about, if this still interests you. – Will Ness Apr 18 '18 at 19:13
4

Here's a way (following the code structure by @coredump from their answer; runs about 4x faster on tio.run):

(defun permutations (list callback)
  (when list
    (let* ((all (cons 'head (copy-list list)))           ; head sentinel FTW!
           (perm (make-array (length list))))
      (labels ((g (p i &aux (q (cdr p)))
                (cond
                  ((null (cdr q))   
                     (setf (svref perm i) (car q))       ; the last item
                     (funcall callback perm))
                  (T (loop while q do 
                        (setf (svref perm i) (car q))    ; pick the item
                        (rplacd p (cdr q))               ; pluck it out
                        (g all (1+ i))                   ; recurse!
                        (rplacd p q)                     ; heal the list back
                        (pop p)  
                        (pop q))))))                     ; advance the pointers
        (g all 0))))) 

; > (permutations '(1 2 3) #'princ)
; #(1 2 3)#(1 3 2)#(2 1 3)#(2 3 1)#(3 1 2)#(3 2 1)

This uses recursion to build an n nested loops 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, in 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 perm array as an argument. The array is reused for each new permutation.

Implements the "shrinking domains" paradigm as in this pseudocode:

for item1 in list:
   domain2 = remove item1 from list by position
   for item2 in domain2:
      domain3 = remove item2 domain2 by position
      for item3 in domain3:
             ......
             ......
             (callback (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 , creating the n nested loops backtracking computational structure by recursion.

Will Ness
  • 62,652
  • 8
  • 86
  • 167