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) です。これは、短い配列の場合、ほぼ 2 次のようになります。(m は配列の長さ、n は順列の数です。)

再帰バージョンを見ると、*プレーン* O(n) バリアントが必要になることを願っていますが、頭を包むことはできません...

別の Lisp で書く方が快適だと思うなら、大歓迎です!

4

2 に答える 2

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 に答える
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 に答える