更好的排列生成算法

Question

这里有一些我可以想出的，但我对它们中的任何一个都不满意：

(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)))))

递归

变体既做了额外的交换，又递归让我非常不高兴（我不关心堆栈的大小，因为我关心调试的难易程度 - 递归函数在调试器中看起来很糟糕......

我从 Wiki 上的描述中实现的另一个版本，如果您有兴趣，可以在这里： http://en.wikipedia.org/wiki/Steinhaus%E2%80%93Johnson%E2%80%93Trotter_algorithm 但它太长了（只是代码本身很长），而且它或多或少是 O（n*m），对于短数组来说，这几乎就像二次数组。（m 是数组的长度，n 是排列的数量。

通过查看递归版本，我希望必须有一个*普通* O（n）变体，但我就是无法理解它......

如果你觉得用另一个 Lisp 写它更舒服，欢迎你！

Answer 1

这就是

我现在得到的，感谢这个博客：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)))))

但请随时提出更好的建议。（虽然这对我来说看起来很漂亮，所以 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)))))

示例（如果使用 Emacs-Lisp，请将 #'print 替换为 #'message 和 C-he 以查看结果）：

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