``` ;;;; chase-sequence.scm
;;;; Kon Lovett, Jan '08

;;;

(define-macro (ASSERT ?form)
;`(assert ,?form)   ; Uncomment to activate assertion checking
'(begin) )          ; Comment to activate assertion checking

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

(use srfi-4)
(use iset)

(eval-when (compile)
(declare
(usual-integrations)
(inline)
(fixnum)
(no-procedure-checks-for-usual-bindings)
(export
make-chase-sequence
make-chase-sequence-index-swapper
for-each-permutation
fold-permutation) ) )

;; Enumerate the permutations of count items, at the cut-point,
;; cut. The optional third argument is a procedure of one
;; argument, swpprc, called for every swap with the indicies of the swap.
;;
;; Returns a procedure to generate the next combination. When invoked the
;; procedure will return a bit-vector where a #t bit is an element of the
;; current combination. Returns #f when combinations are exhausted.
;;
;; Chase's Sequence is an algorithm for enumerating the combinations 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 cnt cut #!optional (swpprc noop))
(let* ([n (if (positive? cnt) cnt 1)]
[k (if (< 0 cut n) cut n)]
[s (- n k)]
[r (if (positive? s) s k)] )
(let ([fence (make-bit-vector (add1 n) #t)] ; w
[delta (make-bit-vector n #f)] )      ; a
; Initialize the 1st combination
[(= i n)]
(bit-vector-set! delta i #t) )
; The algorithm
(letrec (
;; 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 (lt rt)
(ASSERT (bit-vector-ref delta lt))
(bit-vector-set! delta lt #f)
(ASSERT (not (bit-vector-ref delta rt)))
(bit-vector-set! delta rt #t)
(swpprc lt rt) ) ]
;; C4
[move-right-one
(lambda (j)
(ASSERT (> j 0))
(let ([r1 (sub1 j)])
(exchange j r1)
(cond [(and (= r j) (> j 1))
(set! r r1) ]
[(= r r1)
(set! r j) ] ) ) ) ]
;; C5
[move-right-two
(lambda (j)
(ASSERT (> j 1))
(let ([r2 (- j 2)])
(if (bit-vector-ref delta r2)
(move-right-one j)
(begin
(exchange j r2)
(cond [(= r j)
(set! r (if (> j 2) r2 1)) ]
[(= r r2)
(set! r (sub1 j)) ] ) ) ) ) ) ]
;; C6
[move-left-one
(lambda (j)
(ASSERT (> j 0))
(let ([r1 (sub1 j)])
(exchange r1 j)
(cond [(and (= r j) (> j 1))
(set! r r1) ]
[(= r r1)
(set! r j) ] ) ) ) ]
;; C7
[move-left-two
(lambda (j)
(ASSERT (> j 0))
(if (bit-vector-ref delta (sub1 j))
(move-left-one j)
(begin
(ASSERT (> j 1))
(let ([r2 (- j 2)])
(exchange r2 j)
(cond ((= r r2)
(set! r j) )
((= r (sub1 j))
(set! r r2) ) ) ) ) ) ) ]
;; C3: Find j and branch
[gen-partition
(lambda ()
(swpprc 'init)
(let ([j (do ([i r (add1 i)])
[(bit-vector-ref fence i) i]
(bit-vector-set! fence i #t) ) ] )
(and (not (= j n))
(let ([aj (bit-vector-ref delta j)])
(bit-vector-set! fence j #f)
(if (odd? j)
(if aj
(move-right-one j)
(move-left-two j) )
(if aj
(move-right-two j)
(move-left-one j) ) ) ) ) ) ) ]
;; Return the index procedure for the next partition
[next-partition
(lambda ()
; Subsequent partitions
(set! next-partition gen-partition)
#t ) ] )
;; Return a control procedure.
(lambda ()
(and (next-partition)
delta) ) ) ) ) )

;;;

(define (u32vector-swap! u32v i j)
(let ([oi (u32vector-ref u32v i)])
(u32vector-set! u32v i (u32vector-ref u32v j))
(u32vector-set! u32v j oi) ) )

;; Make a indicies swapper for count items, at the cut-point,
;; cut.
;;
;; Returns a procedure to be supplied as a swap-procedure to
;; the chase-sequence combination generator.
;;
;; When the returned procedure is called without arguments it
;; returns a procedure of one argument, an index in the original
;; order. This procedure then returns the index in the current
;; order, or #f when the index argument is out-of-range.

(define (make-chase-sequence-index-swapper cnt cut)
(let* ([n (if (positive? cnt) cnt 1)]
[k (if (< 0 cut n) cut n)]
[s (- n k)] )
(let ([swaps 0]
[comb (make-u32vector n)]
[ix (make-u32vector n)])
;
[(= i n)]
(u32vector-set! comb i i)
(u32vector-set! ix i i) )
;
(letrec (
;; Swap i and (i+1)
(lambda (i)
(ASSERT (and (<= 0 i) (< i (sub1 n))))
(u32vector-set! ix (u32vector-ref comb i) i1)
(u32vector-set! ix (u32vector-ref comb i1) i)
(u32vector-swap! comb i i1)
(ASSERT (= (u32vector-ref ix (u32vector-ref comb i)) i))
(ASSERT (= (u32vector-ref ix (u32vector-ref comb i1)) i1))
(set! swaps (add1 swaps)) ) ) ]
;; "Bubble" the object at f to t by swapping
[move
(lambda (f t)
(ASSERT (and (>= f 0) (< f n)))
(ASSERT (and (>= t 0) (< t n)))
(if (< f t)
[(= i t)]
(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 (lt rt)
(ASSERT (and (>= lt 0) (< lt n)))
(ASSERT (and (>= rt 0) (< rt n)))
(ASSERT (>= (u32vector-ref ix lt) s))  ; currently right of cut
(move (u32vector-ref ix lt) s)         ; move it to immediate right of cut
(ASSERT (< (u32vector-ref ix rt) s))   ; currently left of cut
(move (u32vector-ref ix rt) (sub1 s))  ; move it to immediate left of cut
(adjacent-swap (sub1 s)) ) ]           ; trade sides just across the cut
;; Retrieve the permuted index at index i
[get-index
(lambda (i)
(and (< -1 i n)
(u32vector-ref comb i) ) ) ] )
;
(lambda args
(cond [(null? args)
get-index]
[(= 2 (length args))
[else
(set! swaps 0)] ) ) ) ) ) )

;;; Permutation index mappers

;; Calls the function

(define (for-each-permutation idxfnc prc)
(let loop ([i 0])
(and-let* ([j (idxfnc i)])
(prc i j)
(loop (add1 i)) ) ) )

;; Calls the function

(define (fold-permutation idxfnc fnc int)
(let loop ([i 0] [acc int])
(let ([j (idxfnc i)])
(if j
(loop (add1 i) (fnc i j acc))
acc ) ) ) )

;;; Display & exercise helpers

(define (bit-vector-display bv #!optional (len (bit-vector-length bv)))
(display "#<")
(let ([len1 (sub1 len)])
(let loop ([i 0])
(display (bit-vector-ref bv i))
(if (< i len1)
(begin
(display #\space)
(display #\>) ) ) ) )

(define (print-indicies idxfnc)
(for-each-permutation idxfnc (lambda (i j) (print i #\space j))) )

(define (print-permutation prmprc #!optional swpprc vec)
(and-let* ([delta (prmprc)])
(bit-vector-display delta 5) (newline)
(when swpprc
(if vec
(begin
(for-each-permutation (swpprc)
(lambda (i j)
(display (vector-ref vec j)) (display #\space)))
(newline) )
(print-indicies (swpprc)) ) )
#t ) )

(define (factorial n)
(let loop ([n n] [m 1])
(if (zero? n)
m
(loop (sub1 n) (* m n)) ) ) )

(define (permutation-count n r)
(/ (factorial n) (factorial (- n r))) )

(define (combination-count n r)
(/ (factorial n) (* (factorial r) (factorial (- n r)))) )

;;; Example

#|
(use miscmacros)
(define s1 (make-chase-sequence-index-swapper 5 2))
(define cs1 (make-chase-sequence 5 2 s1))
(define v1 '#(1 2 3 4 5))
(combination-count 5 2)
(while (print-permutation cs1 s1 v1))
|#```