3

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

(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 写起来更舒服，欢迎你！

4

2 回答 2

2

这就是我现在所拥有的，感谢这个博客：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）

于 2012-12-03T22:01:17.380 回答
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"
于 2012-12-04T03:17:46.367 回答