You can edit this page using wiki syntax for markup.

Article contents:<enscript highlight="scheme"> ;;;; 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 </enscript> Description of your changes:

I would like to authenticate

Spam control

What do you get when you add 17 to 24?