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