Better permutations generating algorithm

Question

Here are some I could come up with, but I'm not happy with either of them:

(defsubst i-swap (array a b)
  (let ((c (aref array a)))
    (aset array a (aref array b))
    (aset array b c) array))

(defun i-permute-recursive (array offset length)
  (if (= offset length)
      (message "array: %s" array)
    (let ((i offset))
      (while (< i length)
        (i-permute-recursive (i-swap array i offset) (1+ offset) length)
        (i-swap array i offset)
        (incf i)))))

(defun i-permute-johnson-trotter (array)
  (let ((i 0) largest largest-pos largest-sign swap-to
        (markers (make-vector (length array) nil)))
    (while (< i (length array))
      (aset markers i (cons '1- i))
      (incf i))
    (setcar (aref markers 0) nil)
    (while (some #'car markers)
      (setq i 0 largest nil)
      (while (< i (length array))
        (destructuring-bind (tested-sign . tested-value)
            (aref markers i)
          (when (and tested-sign
                     (or (not largest)
                         (< largest tested-value)))
            (setq largest tested-value largest-pos i
                  largest-sign tested-sign)))
        (incf i))
      (when largest
        (setq swap-to (funcall largest-sign largest-pos))
        (i-swap array largest-pos swap-to)
        (i-swap markers largest-pos swap-to)
        (when (or (= swap-to 0) (= swap-to (1- (length array)))
                  (> (cdr (aref markers
                                (funcall largest-sign swap-to)))
                     largest))
          (setcar (aref markers swap-to) nil))
        (setq i 0)
        (while (< i (length array))
          (setq swap-to (cdr (aref markers i)))
          (when (> swap-to largest)
            (setcar (aref markers i)
                    (if (< i largest-pos) '1+ '1-)))
          (incf i))
        (message "array: %s <- makrers: %s" array markers)))))

The recursive variant both does extra swapping and it being recursive makes me very unhappy (I'm not concerned with the size of the stack as I'm concerned with ease of debugging - recursive functions look terrible in debugger...)

The other version I implemented from it's description on Wiki, here if you are interested: http://en.wikipedia.org/wiki/Steinhaus%E2%80%93Johnson%E2%80%93Trotter_algorithm but it is both too long (just the code itself is very long) and it's O(n*m) more or less, which, for short arrays is almost like quadratic. (m being the length of the array, and n being the number of permutations.)

From looking at recursive version I hope that there must be a *plain* O(n) variant, but I just can't wrap my head around it...

If you feel more comfortable writing it in another Lisp, you are welcome!

Answer 1

This is what I've got for now, thanks to this blog: http://www.quickperm.org/

(defun i-permute-quickperm (array)
  (let* ((len (length array))
         (markers (make-vector len 0))
         (i 1) j)
    (while (< i len)
      (if (< (aref markers i) i)
          (progn
            (setq j (if (oddp i) (aref markers i) 0))
            (i-swap array j i)
            (message "array: %s" array)
            (aset markers i (1+ (aref markers i)))
            (setq i 1))
        (aset markers i 0)
        (incf i)))))

But please feel free to suggest a better one. (Though this looks pretty to me, so idk :P)

Answer 2

(defun map-permutations (fn vector)
  "Call function FN on each permutation of A, with each successive
permutation one swap away from previous one."
  (labels ((frob (n)
             (if (zerop n) (funcall fn vector)
               (dotimes (i n (frob (1- n)))
                 (frob (1- n))
                 (rotatef (aref vector n)
                          (aref vector (if (oddp n) i 0)))))))
    (frob (1- (length vector)))))

Example (if using Emacs-Lisp, replace #'print with #'message and C-he to see the result):

CL-USER> (map-permutations #'print "123")
"123" 
"213" 
"312" 
"132" 
"231" 
"321"