;;;; chase-sequence.scm
 ;;;; Kon Lovett, Jan '08
 ;;;; License: Public Domain
 
 ;;;
 
(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
      (do ([i s (add1 i)])
          [(= 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)])
      ;
      (do ([i 0 (add1 i)])
          [(= i n)]
        (u32vector-set! comb i i)
        (u32vector-set! ix i i) )
      ;
      (letrec (
            ;; Swap i and (i+1)
            [adjacent-swap
              (lambda (i)
                (ASSERT (and (<= 0 i) (< i (sub1 n))))
                (let ([i1 (add1 i)])
                  (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)
                    (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
            [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))
                  (exchange (car args) (cadr 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)
            (loop (add1 i)) )
          (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))
|#