You are looking at historical revision 34936 of this page. It may differ significantly from its current revision.
- ;;; chase-sequence.scm
- ;;; Kon Lovett, Oct '17
- ;;; License
- Public Domain
- ;; Generates all combinations in near-perfect minimal-change order.
- (define cs (make-sequence #(1 2 3 4 5 6) 3))
- (next-permutation cs)
- => #(1 2 3 4 5 6)
(module chase-sequence
(;export
make-sequence next-permutation)
(import scheme chicken) (use lolevel srfi-4 iset fx-utils)
- ;
(define (u32vector-swap! u32v i j)
(let ((tmp (u32vector-ref u32v i))) (u32vector-set! u32v i (u32vector-ref u32v j)) (u32vector-set! u32v j tmp) ) )
- ; Returns the next vector permutation of the specified chase sequence
- ; procedure, or #f when no more permutations.
(define (next-permutation cs)
(let (
(siz (cs 'num) )
(cs-permutation (cs) ) )
;
(and
cs-permutation
(let ((v (make-vector siz)))
(do ((i 0 (fxadd1 i)))
((fx= i siz) v)
(vector-set! v i (cs-permutation i)))) ) ) )
- ; Enumerate the permutations of the data-vector at the, optional,
- ; cut-point. The default is data-vector length.
- ;
- ; The optional swap-listener is a procedure of one argument, the index,
- ; called for every swap.
- ;
- ; Returns a procedure of one, optional, argument.
- ;
- ; When missing the called procedure will return a procedure of one argument,
- ; a fixnum index where 0 <= index < (vector-length data-vector), or #f
- ; when permutations are exhausted. This procedure when called will return the
- ; value of the data-vector at index in the current permutation.
- ;
- ; When the optional argument is present it must be one of
- ; 'swaps => total # of swaps performed
- ; 'num => length of the data,
- ; 'data => original data-vector
- ; '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-sequence data-vector #!optional cut-point (swap-listener void))
;
(let* (
(num (vector-length data-vector) )
(t ;t = k
(if (and (fixnum? cut-point) (fx<= 1 cut-point) (fx<= cut-point num))
cut-point
num ) )
(s (fx- num t) )
(r (if (fxpositive? s) s t) )
(data (object-copy data-vector) )
(swaps 0 )
(comb (make-u32vector num) )
(ix (make-u32vector num) )
(w (make-bit-vector (fxadd1 num) #t) )
(a (make-bit-vector num) )
;
(swap-listener
(lambda (i)
(set! swaps (fxadd1 swaps))
(swap-listener i) ) ) )
;
(do ((i 0 (fxadd1 i)))
((fx= i num))
(u32vector-set! comb i i)
(u32vector-set! ix i i)
(bit-vector-set! a i (fx>= i s)) )
;
(letrec (
;swap i and (i+1)
(adjacent-swap
(lambda (i)
#;(assert (and (fx>= i 0) (fx< i (fxsub1 num))))
;
(u32vector-set! ix (u32vector-ref comb i) (fxadd1 i))
(u32vector-set! ix (u32vector-ref comb (fxadd1 i)) i)
(u32vector-swap! comb i (fxadd1 i))
;
#;(assert (fx= (u32vector-ref ix (u32vector-ref comb i)) i))
#;(assert (fx= (u32vector-ref ix (u32vector-ref comb (fxadd1 i))) (fxadd1 i)))
;
(swap-listener i) ) )
;"bubble" the object from {{f}} to {{t}} by swapping
(move
(lambda (f t)
#;(assert (and (fx>= f 0) (fx< f num)))
#;(assert (and (fx>= t 0) (fx< t num)))
;
(if (fx< f t)
(do ((i f (fxadd1 i)))
((fx= i t))
(adjacent-swap i) )
(do ((i (fxsub1 f) (fxsub1 i)))
((fx< 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 (fx>= l 0) (fx< l num)))
#;(assert (and (fx>= r 0) (fx< r num)))
;
#;(assert (fx>= (u32vector-ref ix l) s)) ;currently right of cut
(move (u32vector-ref ix l) s) ;move it to immediate right of cut
#;(assert (fx< (u32vector-ref ix r) s)) ;currently left of cut
(move (u32vector-ref ix r) (fxsub1 s)) ;move it to immediate left of cut
(adjacent-swap (fxsub1 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 (fx> j 0))
;
(exchange j (fxsub1 j))
(cond
((and (fx= r j) (fx> j 1))
(set! r (fxsub1 j)) )
((fx= r (fxsub1 j))
(set! r j) ) ) ) )
;C5
(move-right-two
(lambda (j)
#;(assert (fx> j 1))
;
(if (bit-vector-ref a (fx- j 2))
(move-right-one j)
(begin
(exchange j (fx- j 2))
(cond
((fx= r j)
(set! r (if (fx> j 3) (fx- j 2) 1)))
((fx= r (fx- j 2))
(set! r (fxsub1 j)) ) ) ) ) ) )
;C6
(move-left-one
(lambda (j)
#;(assert (fx> j 0))
;
(exchange (fxsub1 j) j)
(cond
((and (fx= r j) (fx> j 1))
(set! r (fxsub1 j)) )
((fx= r (fxsub1 j))
(set! r j) ) ) ) )
;C7
(move-left-two
(lambda (j)
#;(assert (fx> j 0))
;
(if (bit-vector-ref a (fxsub1 j))
(move-left-one j)
(begin
#;(assert (fx> j 1))
;
(exchange (fx- j 2) j)
(cond
((fx= r (fx- j 2))
(set! r j) )
((fx= r (fxsub1 j))
(set! r (fx- 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 (fxadd1 i)))
((bit-vector-ref w i) (set! j i))
(bit-vector-set! w i #t) )
(and
(not (fx= j num))
(let ((aj (bit-vector-ref a j)))
(bit-vector-set! w j #f)
(set! swaps 0)
(if (fxodd? j)
(if aj
(move-right-one j)
(move-left-two j) )
(if aj
(move-right-two j)
(move-left-one j) ) )
ref-proc ) ) ) ) )
;1st call is a "freebie" since already initialized
(next-partition
(lambda ()
(set! next-partition gen-partition)
ref-proc ) ) )
;turn this into the next combination. false when there are no more.
(lambda swapf
(case (optional swapf #f)
((swaps) swaps )
((num) num )
((data) data )
((a) a )
(else
(next-partition) ) ) ) ) ) )
) ;module chase-sequence