You are looking at historical revision 4460 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)))))))))))