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
`;;; 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)]
[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)
(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)
```	   (assert (= (u32vector-ref ix (u32vector-ref comb i)) 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])
(do ([i (sub1 f) (sub1 i)]) ([< i t])
```	   ;; 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
```	   (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)))))))))))```