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是排列的数量。）

从递归版本看，我希望必须有一个* plain * 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，将＃'打印用＃'消息替换， C-h e 以查看结果）：

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

更好的排列生成算法

2 个答案: