You are looking at historical revision 1620 of this page. It may differ significantly from its current revision.

;;;; chase-sequence.scm
;;;; Kon Lovett, Jan '06
;;;; License: BSD

;;; Generates all combinations in near-perfect minimal-change order.

(use lolevel srfi-4 iset)

(eval-when (compile)
  (declare
    (fixnum)
    (unsafe)
  )
)

;; Returns the next vector permutation of the specified chase sequence
;; procedure, or #f when no more permutations.

(define (next-chase-permutation cs)
  (let ([num (cs 'num)] [pcs (cs)])
    (if pcs
      (let ([v (make-vector num)])
 (do ([i 0 (add1 i)]) ([= i num] v)
   (vector-set! v i (pcs i))))
      #f)))

;; Enumerate the permutations of a vector, data-vec, at the cut,
;; cut-point. The optional third argument is a procedure of one
;; argument, called for every swap with the index of the swap.
;;
;; Returns a procedure of one, optional, argument.
;; When missing the called procedure will return a
;; procedure of one argument, an fixnum index where 0 <= index <
;; (vector-length data-vec), or #f when permutations exhausted. This
;; procedure when called will return the value of the data-vec at index
;; in the current permutation.
;;
;; When the optional argument is present it must be one of 'swaps, 'num, 'a,
;; or 'data. The corresponding internal variable state will be returned.
;; 'swaps = total # of swaps performed, 'num = length of the data,
;; 'data = original data-vec, 'a = bit-vector where #t bit is a swap.
;;
;; Chase's Sequence is an algorithm for enumerating the permutations of
;; a data-set by adjacent swaps.
;; (Knuth's "The Art of Computer Programming" pre-fascicle 2C, the draft
;; of section 7.2.1.3)

(define (make-chase-sequence data-vec cut-point . swap-proc)
  (let ([num (vector-length data-vec)])
    (let ([t (if (<= 1 cut-point num) cut-point num)]) ; t = k
      (let ([s (- num t)])
 (let ([r (if (positive? s) s t)]
       [data (object-copy data-vec)]
       [swaps 0]
       [swap-proc (:optional swap-proc noop)])
   (let ([swap-at (lambda (i) (add1 swaps) (swap-proc i))]
	 [comb (make-u32vector num)]
	 [ix (make-u32vector num)]
	 [w (make-bit-vector (add1 num) #t)]
	 [a (make-bit-vector num)]
	 [u32vector-swap! (lambda (u32v i j)
	   (let ([oi (u32vector-ref u32v i)])
	     (u32vector-set! u32v i (u32vector-ref u32v j))
	     (u32vector-set! u32v j oi)))])
     (do ([i 0 (add1 i)]) ([= i num])
       (u32vector-set! comb i i)
       (u32vector-set! ix i i)
       (bit-vector-set! a i (>= i s)))
     (letrec (

	   ;; swap i and (i+1)
	 [adjacent-swap (lambda (i)
	   (assert (and (>= i 0) (< i (sub1 num))))

	   (u32vector-set! ix (u32vector-ref comb i) (add1 i))
	   (u32vector-set! ix (u32vector-ref comb (add1 i)) i)
	   (u32vector-swap! comb i (add1 i))

	   (assert (= (u32vector-ref ix (u32vector-ref comb i)) i))
	   (assert (= (u32vector-ref ix (u32vector-ref comb (add1 i))) (add1 i)))

	   (swap-at i))]

	   ;; "bubble" the object at [[from] to [[to] by swapping
	 [move (lambda (f t)
	   (assert (and (>= f 0) (< f num)))
	   (assert (and (>= t 0) (< t num)))

	   (if (< f t)
	     (do ([i f (add1 i)]) ([= i t])
	       (adjacent-swap i))
	     (do ([i (sub1 f) (sub1 i)]) ([< i t])
	       (adjacent-swap i))))]

	   ;; move the object at index 'left' to the index immediately left of the cut,
	   ;; and move the object at index 'right' to the index immediate right of the
	   ;; cut
	 [exchange (lambda (l r)
	   (assert (and (>= l 0) (< l num)))
	   (assert (and (>= r 0) (< r num)))

	   (assert (>= (u32vector-ref ix l) s))  ; currently right of cut
	   (move (u32vector-ref ix l) s)         ; move it to immediate right of cut
	   (assert (< (u32vector-ref ix r) s))   ; currently left of cut
	   (move (u32vector-ref ix r) (sub1 s))  ; move it to immediate left of cut
	   (adjacent-swap (sub1 s))              ; trade sides just across the cut

	   (assert (bit-vector-ref a l))
	   (bit-vector-set! a l #f)
	   (assert (not (bit-vector-ref a r)))
	   (bit-vector-set! a r #t))]

	   ;; C4
	 [move-right-one (lambda (j)
	   (assert (> j 0))

	   (exchange j (sub1 j))
	   (cond
	     ((and (= r j)
	       (> j 1)) (set! r (sub1 j)))
	     ((= r (sub1 j))
	       (set! r j))))]

	   ;; C5
	 [move-right-two (lambda (j)
	   (assert (> j 1))

	   (if (bit-vector-ref a (- j 2))
	     (move-right-one j)
	     (begin
	       (exchange j (- j 2))
	       (cond
		 ((= r j)
		   (set! r (if (> j 3) (- j 2) 1)))
		 ((= r (- j 2))
		   (set! r (sub1 j)))))))]

	   ;; C6
	 [move-left-one (lambda (j)
	   (assert (> j 0))

	   (exchange (sub1 j) j)
	   (cond
	     ((and (= r j) (> j 1))
	       (set! r (sub1 j)))
	     ((= r (sub1 j))
	       (set! r j))))]

	   ;; C7
	 [move-left-two (lambda (j)
	   (assert (> j 0))

	   (if (bit-vector-ref a (sub1 j))
	     (move-left-one j)
	     (begin
	       (assert (> j 1))

	       (exchange (- j 2) j)
	       (cond
		 ((= r (- j 2))
		   (set! r j))
		 ((= r (sub1 j))
		   (set! r (- j 2)))))))]

	   ;; retrieve the permuted data at index i
	 [ref-proc (lambda (i)
	   (vector-ref data (u32vector-ref comb i)))]

	 [gen-partition (lambda ()
	     ; C3: Find j and branch
	   (let ([j #f])
	     (do ([i r (add1 i)]) ([bit-vector-ref w i] (set! j i))
	       (bit-vector-set! w i #t))
	     (if (= j num)
	       #f
	       (let ([[aj (bit-vector-ref a j)])
		 (bit-vector-set! w j #f)
		 (set! swaps 0)
		 (if (odd? j)
		   (if aj
		     (move-right-one j)
		     (move-left-two j))
		   (if aj
		     (move-right-two j)
		     (move-left-one j)))
		 ref-proc))))]

	 [next-partition (lambda ()
	   (set! next-partition gen-partition)
	    ref-proc)])

	 ;; turn this into the next combination. false when there are no more.
       (lambda swapf
	 (switch (:optional swapf #f)
	   ('swaps swaps)
	   ('num num)
	   ('data data)
	   ('a a)
	   (else (next-partition)))))))))))