;;;; chase-sequence.scm
;;;; Kon Lovett, Oct '19
;;;; License: Public Domain

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

;(define cs (make-sequence #(1 2 3 4 5 6) 3)) ;s + t = 6 = 3 + 3
;(next-permutation cs)
;=> #(1 2 3 4 5 6) ;...

(module chase-sequence

(;export
  make-sequence
  next-permutation)

(cond-expand
  (chicken-4
    (import scheme chicken)
    (use
      (only lolevel object-copy)
      (only srfi-4 make-u32vector u32vector-ref u32vector-set!)
      (only iset make-bit-vector bit-vector-ref bit-vector-set!)) )
  (chicken-5
    (import scheme
      (chicken base)
      (chicken type)
      (only (chicken memory representation) object-copy)
      (only (srfi 4) make-u32vector u32vector-ref u32vector-set!)
      (only iset make-bit-vector bit-vector-ref bit-vector-set!)) )
  (else
    (error "unknown CHICKEN; not chicken-4 or chicken-5") ) )

;;

(: u32vector-swap! (u32vector fixnum fixnum -> void))
;
(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) ) )

;;;

;FIXME brittle
(define-type bit-vector u8vector)

(define-type chase-result (or boolean procedure fixnum vector bit-vector))

(define-type chase-sequence (#!optional symbol -> chase-result))

(define-type swap-listener (fixnum -> void))

(define-type chase-permutation (list-of vector))

;; Returns the next vector permutation of the specified chase sequence
;; procedure, or #f when no more permutations.

(: next-permutation (chase-sequence -> (or boolean chase-permutation)))
;
(define (next-permutation cs)
  (let (
    (siz (cs 'num))
    (cs-permutation (cs)) )
    (and
      cs-permutation
      (let ((v (make-vector siz)))
        (do ((i 0 (add1 i)))
            ((= 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)

(: make-sequence (vector #!optional fixnum swap-listener --> chase-sequence))
;
(define (make-sequence data-vector #!optional cut-point (swap-listener void))
  ;
  (let* (
    (num (vector-length data-vector))
    (t  ;t = k
      (if (and cut-point (<= 1 cut-point num))
        cut-point
        num))
    (s      (- num t))
    (r      (if (positive? s) s t))
    (data   (object-copy data-vector))
    (swaps  0)
    (comb   (make-u32vector num))
    (ix     (make-u32vector num))
    (w      (make-bit-vector (add1 num) #t))
    (a      (make-bit-vector num))
    ;
    (swap-listener
      (lambda (i)
        (set! swaps (add1 swaps))
        (swap-listener i))) )
    ;
    (do ((i 0 (add1 i)))
        ((= i num))
      (u32vector-set! comb i i)
      (u32vector-set! ix i i)
      (bit-vector-set! a i (>= i s)) )
    ;
    (let ()
      ;swap i and (i+1)
      (define (adjacent-swap 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-listener i) )
      ;"bubble" the object from {{f}} to {{t}} by swapping
      (define (move 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
      (define (exchange 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
      (define (move-right-one 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
      (define (move-right-two 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
      (define (move-left-one 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
      (define (move-left-two 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
      (define (ref-proc i)
        (vector-ref data (u32vector-ref comb i) ) )
      ;
      (define (gen-partition)
        ;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) )
          (and
            (not (= j num))
            (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 ) ) ) )
      ;1st call is a "freebie" since already initialized
      (define (next-partition)
        (set! next-partition gen-partition)
        ref-proc )
      ;turn this into the next combination. false when there are no more.
      (lambda (#!optional swapf)
        (case swapf
          ((swaps)  swaps )
          ((num)    num )
          ((data)   data )
          ((a)      a )
          (else     (next-partition) ) ) ) ) ) )

) ;module chase-sequence