Changeset 34936 in project
 Timestamp:
 12/15/17 16:35:37 (3 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

wiki/Chase Sequence
r7800 r34936 1 <enscript highlight=scheme> 2 ;;;; chasesequence.scm 3 ;;;; Kon Lovett, Jan '08 4 ;;;; License: Public Domain 5 6 ;;; 7 8 (definemacro (ASSERT ?form) 9 ;`(assert ,?form) ; Uncomment to activate assertion checking 10 '(begin) ) ; Comment to activate assertion checking 11 12 ;;; Generates all combinations in nearperfect minimalchange order. 13 14 (use srfi4) 15 (use iset) 16 17 (evalwhen (compile) 18 (declare 19 (usualintegrations) 20 (inline) 21 (fixnum) 22 (noprocedurechecksforusualbindings) 23 (export 24 makechasesequence 25 makechasesequenceindexswapper 26 foreachpermutation 27 foldpermutation) ) ) 28 29 ;; Enumerate the permutations of count items, at the cutpoint, 30 ;; cut. The optional third argument is a procedure of one 31 ;; argument, swpprc, called for every swap with the indicies of the swap. 32 ;; 33 ;; Returns a procedure to generate the next combination. When invoked the 34 ;; procedure will return a bitvector where a #t bit is an element of the 35 ;; current combination. Returns #f when combinations are exhausted. 36 ;; 37 ;; Chase's Sequence is an algorithm for enumerating the combinations of 1 ;;;; chasesequence.scm 2 ;;;; Kon Lovett, Oct '17 3 ;;;; License: Public Domain 4 5 ;;; Generates all combinations in nearperfect minimalchange order. 6 7 ;(define cs (makesequence #(1 2 3 4 5 6) 3)) 8 ;(nextpermutation cs) 9 ;=> #(1 2 3 4 5 6) 10 11 (module chasesequence 12 13 (;export 14 makesequence 15 nextpermutation) 16 17 (import scheme chicken) 18 (use lolevel srfi4 iset fxutils) 19 20 ;; 21 22 (define (u32vectorswap! u32v i j) 23 (let ((tmp (u32vectorref u32v i))) 24 (u32vectorset! u32v i (u32vectorref u32v j)) 25 (u32vectorset! u32v j tmp) ) ) 26 27 ;; Returns the next vector permutation of the specified chase sequence 28 ;; procedure, or #f when no more permutations. 29 30 (define (nextpermutation cs) 31 (let ( 32 (siz (cs 'num) ) 33 (cspermutation (cs) ) ) 34 ; 35 (and 36 cspermutation 37 (let ((v (makevector siz))) 38 (do ((i 0 (fxadd1 i))) 39 ((fx= i siz) v) 40 (vectorset! v i (cspermutation i)))) ) ) ) 41 42 ;; Enumerate the permutations of the {{datavector}} at the, optional, 43 ;; {{cutpoint}}. The default is {{datavector}} length. 44 ;; 45 ;; The optional {{swaplistener}} is a procedure of one argument, the index, 46 ;; called for every swap. 47 ;; 48 ;; Returns a procedure of one, optional, argument. 49 ;; 50 ;; When missing the called procedure will return a procedure of one argument, 51 ;; a fixnum index where {{0 <= index < (vectorlength datavector)}}, or {{#f}} 52 ;; when permutations are exhausted. This procedure when called will return the 53 ;; value of the {{datavector}} at {{index}} in the current permutation. 54 ;; 55 ;; When the optional argument is present it must be one of: 56 ;; 'swaps => total # of swaps performed 57 ;; 'num => length of the data, 58 ;; 'data => original {{datavector}} 59 ;; 'a => bitvector where #t bit is a swap. 60 ;; 61 ;; Chase's Sequence is an algorithm for enumerating the permutations of 38 62 ;; a dataset by adjacent swaps. 39 63 ;; (Knuth's "The Art of Computer Programming" prefascicle 2C, the draft 40 64 ;; of section 7.2.1.3) 41 65 42 (define (makechasesequence cnt cut #!optional (swpprc noop)) 43 (let* ([n (if (positive? cnt) cnt 1)] 44 [k (if (< 0 cut n) cut n)] 45 [s ( n k)] 46 [r (if (positive? s) s k)] ) 47 (let ([fence (makebitvector (add1 n) #t)] ; w 48 [delta (makebitvector n #f)] ) ; a 49 ; Initialize the 1st combination 50 (do ([i s (add1 i)]) 51 [(= i n)] 52 (bitvectorset! delta i #t) ) 53 ; The algorithm 54 (letrec ( 55 ;; Move the object at index 'left' to the index immediately left of the cut, 56 ;; and move the object at index 'right' to the index immediate right of the 57 ;; cut 58 [exchange 59 (lambda (lt rt) 60 (ASSERT (bitvectorref delta lt)) 61 (bitvectorset! delta lt #f) 62 (ASSERT (not (bitvectorref delta rt))) 63 (bitvectorset! delta rt #t) 64 (swpprc lt rt) ) ] 65 ;; C4 66 [moverightone 67 (lambda (j) 68 (ASSERT (> j 0)) 69 (let ([r1 (sub1 j)]) 70 (exchange j r1) 71 (cond [(and (= r j) (> j 1)) 72 (set! r r1) ] 73 [(= r r1) 74 (set! r j) ] ) ) ) ] 75 ;; C5 76 [moverighttwo 77 (lambda (j) 78 (ASSERT (> j 1)) 79 (let ([r2 ( j 2)]) 80 (if (bitvectorref delta r2) 81 (moverightone j) 82 (begin 83 (exchange j r2) 84 (cond [(= r j) 85 (set! r (if (> j 2) r2 1)) ] 86 [(= r r2) 87 (set! r (sub1 j)) ] ) ) ) ) ) ] 88 ;; C6 89 [moveleftone 90 (lambda (j) 91 (ASSERT (> j 0)) 92 (let ([r1 (sub1 j)]) 93 (exchange r1 j) 94 (cond [(and (= r j) (> j 1)) 95 (set! r r1) ] 96 [(= r r1) 97 (set! r j) ] ) ) ) ] 98 ;; C7 99 [movelefttwo 100 (lambda (j) 101 (ASSERT (> j 0)) 102 (if (bitvectorref delta (sub1 j)) 103 (moveleftone j) 104 (begin 105 (ASSERT (> j 1)) 106 (let ([r2 ( j 2)]) 107 (exchange r2 j) 108 (cond ((= r r2) 109 (set! r j) ) 110 ((= r (sub1 j)) 111 (set! r r2) ) ) ) ) ) ) ] 112 ;; C3: Find j and branch 113 [genpartition 114 (lambda () 115 (swpprc 'init) 116 (let ([j (do ([i r (add1 i)]) 117 [(bitvectorref fence i) i] 118 (bitvectorset! fence i #t) ) ] ) 119 (and (not (= j n)) 120 (let ([aj (bitvectorref delta j)]) 121 (bitvectorset! fence j #f) 122 (if (odd? j) 123 (if aj 124 (moverightone j) 125 (movelefttwo j) ) 126 (if aj 127 (moverighttwo j) 128 (moveleftone j) ) ) ) ) ) ) ] 129 ;; Return the index procedure for the next partition 130 [nextpartition 131 (lambda () 132 ; Subsequent partitions 133 (set! nextpartition genpartition) 134 #t ) ] ) 135 ;; Return a control procedure. 66 (define (makesequence datavector #!optional cutpoint (swaplistener void)) 67 ; 68 (let* ( 69 (num (vectorlength datavector) ) 70 (t ;t = k 71 (if (and (fixnum? cutpoint) (fx<= 1 cutpoint) (fx<= cutpoint num)) 72 cutpoint 73 num ) ) 74 (s (fx num t) ) 75 (r (if (fxpositive? s) s t) ) 76 (data (objectcopy datavector) ) 77 (swaps 0 ) 78 (comb (makeu32vector num) ) 79 (ix (makeu32vector num) ) 80 (w (makebitvector (fxadd1 num) #t) ) 81 (a (makebitvector num) ) 82 ; 83 (swaplistener 84 (lambda (i) 85 (set! swaps (fxadd1 swaps)) 86 (swaplistener i) ) ) ) 87 ; 88 (do ((i 0 (fxadd1 i))) 89 ((fx= i num)) 90 (u32vectorset! comb i i) 91 (u32vectorset! ix i i) 92 (bitvectorset! a i (fx>= i s)) ) 93 ; 94 (letrec ( 95 ;swap i and (i+1) 96 (adjacentswap 97 (lambda (i) 98 #;(assert (and (fx>= i 0) (fx< i (fxsub1 num)))) 99 ; 100 (u32vectorset! ix (u32vectorref comb i) (fxadd1 i)) 101 (u32vectorset! ix (u32vectorref comb (fxadd1 i)) i) 102 (u32vectorswap! comb i (fxadd1 i)) 103 ; 104 #;(assert (fx= (u32vectorref ix (u32vectorref comb i)) i)) 105 #;(assert (fx= (u32vectorref ix (u32vectorref comb (fxadd1 i))) (fxadd1 i))) 106 ; 107 (swaplistener i) ) ) 108 ;"bubble" the object from {{f}} to {{t}} by swapping 109 (move 110 (lambda (f t) 111 #;(assert (and (fx>= f 0) (fx< f num))) 112 #;(assert (and (fx>= t 0) (fx< t num))) 113 ; 114 (if (fx< f t) 115 (do ((i f (fxadd1 i))) 116 ((fx= i t)) 117 (adjacentswap i) ) 118 (do ((i (fxsub1 f) (fxsub1 i))) 119 ((fx< i t)) 120 (adjacentswap i) ) ) ) ) 121 ;move the object at index 'left' to the index immediately left of the cut, 122 ;and move the object at index 'right' to the index immediate right of the 123 ;cut 124 (exchange 125 (lambda (l r) 126 #;(assert (and (fx>= l 0) (fx< l num))) 127 #;(assert (and (fx>= r 0) (fx< r num))) 128 ; 129 #;(assert (fx>= (u32vectorref ix l) s)) ;currently right of cut 130 (move (u32vectorref ix l) s) ;move it to immediate right of cut 131 #;(assert (fx< (u32vectorref ix r) s)) ;currently left of cut 132 (move (u32vectorref ix r) (fxsub1 s)) ;move it to immediate left of cut 133 (adjacentswap (fxsub1 s)) ;trade sides just across the cut 134 ; 135 #;(assert (bitvectorref a l)) 136 (bitvectorset! a l #f) 137 #;(assert (not (bitvectorref a r))) 138 (bitvectorset! a r #t) ) ) 139 ;C4 140 (moverightone 141 (lambda (j) 142 #;(assert (fx> j 0)) 143 ; 144 (exchange j (fxsub1 j)) 145 (cond 146 ((and (fx= r j) (fx> j 1)) 147 (set! r (fxsub1 j)) ) 148 ((fx= r (fxsub1 j)) 149 (set! r j) ) ) ) ) 150 ;C5 151 (moverighttwo 152 (lambda (j) 153 #;(assert (fx> j 1)) 154 ; 155 (if (bitvectorref a (fx j 2)) 156 (moverightone j) 157 (begin 158 (exchange j (fx j 2)) 159 (cond 160 ((fx= r j) 161 (set! r (if (fx> j 3) (fx j 2) 1))) 162 ((fx= r (fx j 2)) 163 (set! r (fxsub1 j)) ) ) ) ) ) ) 164 ;C6 165 (moveleftone 166 (lambda (j) 167 #;(assert (fx> j 0)) 168 ; 169 (exchange (fxsub1 j) j) 170 (cond 171 ((and (fx= r j) (fx> j 1)) 172 (set! r (fxsub1 j)) ) 173 ((fx= r (fxsub1 j)) 174 (set! r j) ) ) ) ) 175 ;C7 176 (movelefttwo 177 (lambda (j) 178 #;(assert (fx> j 0)) 179 ; 180 (if (bitvectorref a (fxsub1 j)) 181 (moveleftone j) 182 (begin 183 #;(assert (fx> j 1)) 184 ; 185 (exchange (fx j 2) j) 186 (cond 187 ((fx= r (fx j 2)) 188 (set! r j) ) 189 ((fx= r (fxsub1 j)) 190 (set! r (fx j 2)) ) ) ) ) ) ) 191 ;retrieve the permuted data at index i 192 (refproc 193 (lambda (i) 194 (vectorref data (u32vectorref comb i) ) ) ) 195 ; 196 (genpartition 136 197 (lambda () 137 (and (nextpartition) 138 delta) ) ) ) ) ) 139 140 ;;; 141 142 (define (u32vectorswap! u32v i j) 143 (let ([oi (u32vectorref u32v i)]) 144 (u32vectorset! u32v i (u32vectorref u32v j)) 145 (u32vectorset! u32v j oi) ) ) 146 147 ;; Make a indicies swapper for count items, at the cutpoint, 148 ;; cut. 149 ;; 150 ;; Returns a procedure to be supplied as a swapprocedure to 151 ;; the chasesequence combination generator. 152 ;; 153 ;; When the returned procedure is called without arguments it 154 ;; returns a procedure of one argument, an index in the original 155 ;; order. This procedure then returns the index in the current 156 ;; order, or #f when the index argument is outofrange. 157 158 (define (makechasesequenceindexswapper cnt cut) 159 (let* ([n (if (positive? cnt) cnt 1)] 160 [k (if (< 0 cut n) cut n)] 161 [s ( n k)] ) 162 (let ([swaps 0] 163 [comb (makeu32vector n)] 164 [ix (makeu32vector n)]) 165 ; 166 (do ([i 0 (add1 i)]) 167 [(= i n)] 168 (u32vectorset! comb i i) 169 (u32vectorset! ix i i) ) 170 ; 171 (letrec ( 172 ;; Swap i and (i+1) 173 [adjacentswap 174 (lambda (i) 175 (ASSERT (and (<= 0 i) (< i (sub1 n)))) 176 (let ([i1 (add1 i)]) 177 (u32vectorset! ix (u32vectorref comb i) i1) 178 (u32vectorset! ix (u32vectorref comb i1) i) 179 (u32vectorswap! comb i i1) 180 (ASSERT (= (u32vectorref ix (u32vectorref comb i)) i)) 181 (ASSERT (= (u32vectorref ix (u32vectorref comb i1)) i1)) 182 (set! swaps (add1 swaps)) ) ) ] 183 ;; "Bubble" the object at f to t by swapping 184 [move 185 (lambda (f t) 186 (ASSERT (and (>= f 0) (< f n))) 187 (ASSERT (and (>= t 0) (< t n))) 188 (if (< f t) 189 (do ([i f (add1 i)]) 190 [(= i t)] 191 (adjacentswap i) ) 192 (do ([i (sub1 f) (sub1 i)]) 193 [(< i t)] 194 (adjacentswap i) ) ) ) ] 195 ;; Move the object at index 'left' to the index immediately left of the cut, 196 ;; and move the object at index 'right' to the index immediate right of the 197 ;; cut 198 [exchange 199 (lambda (lt rt) 200 (ASSERT (and (>= lt 0) (< lt n))) 201 (ASSERT (and (>= rt 0) (< rt n))) 202 (ASSERT (>= (u32vectorref ix lt) s)) ; currently right of cut 203 (move (u32vectorref ix lt) s) ; move it to immediate right of cut 204 (ASSERT (< (u32vectorref ix rt) s)) ; currently left of cut 205 (move (u32vectorref ix rt) (sub1 s)) ; move it to immediate left of cut 206 (adjacentswap (sub1 s)) ) ] ; trade sides just across the cut 207 ;; Retrieve the permuted index at index i 208 [getindex 209 (lambda (i) 210 (and (< 1 i n) 211 (u32vectorref comb i) ) ) ] ) 212 ; 213 (lambda args 214 (cond [(null? args) 215 getindex] 216 [(= 2 (length args)) 217 (exchange (car args) (cadr args))] 218 [else 219 (set! swaps 0)] ) ) ) ) ) ) 220 221 ;;; Permutation index mappers 222 223 ;; Calls the function 224 225 (define (foreachpermutation idxfnc prc) 226 (let loop ([i 0]) 227 (andlet* ([j (idxfnc i)]) 228 (prc i j) 229 (loop (add1 i)) ) ) ) 230 231 ;; Calls the function 232 233 (define (foldpermutation idxfnc fnc int) 234 (let loop ([i 0] [acc int]) 235 (let ([j (idxfnc i)]) 236 (if j 237 (loop (add1 i) (fnc i j acc)) 238 acc ) ) ) ) 239 240 ;;; Display & exercise helpers 241 242 (define (bitvectordisplay bv #!optional (len (bitvectorlength bv))) 243 (display "#<") 244 (let ([len1 (sub1 len)]) 245 (let loop ([i 0]) 246 (display (bitvectorref bv i)) 247 (if (< i len1) 248 (begin 249 (display #\space) 250 (loop (add1 i)) ) 251 (display #\>) ) ) ) ) 252 253 (define (printindicies idxfnc) 254 (foreachpermutation idxfnc (lambda (i j) (print i #\space j))) ) 255 256 (define (printpermutation prmprc #!optional swpprc vec) 257 (andlet* ([delta (prmprc)]) 258 (bitvectordisplay delta 5) (newline) 259 (when swpprc 260 (if vec 261 (begin 262 (foreachpermutation (swpprc) 263 (lambda (i j) 264 (display (vectorref vec j)) (display #\space))) 265 (newline) ) 266 (printindicies (swpprc)) ) ) 267 #t ) ) 268 269 (define (factorial n) 270 (let loop ([n n] [m 1]) 271 (if (zero? n) 272 m 273 (loop (sub1 n) (* m n)) ) ) ) 274 275 (define (permutationcount n r) 276 (/ (factorial n) (factorial ( n r))) ) 277 278 (define (combinationcount n r) 279 (/ (factorial n) (* (factorial r) (factorial ( n r)))) ) 280 281 ;;; Example 282 283 # 284 (use miscmacros) 285 (define s1 (makechasesequenceindexswapper 5 2)) 286 (define cs1 (makechasesequence 5 2 s1)) 287 (define v1 '#(1 2 3 4 5)) 288 (combinationcount 5 2) 289 (while (printpermutation cs1 s1 v1)) 290 # 291 </enscript> 198 ;C3: Find j and branch 199 (let ((j #f)) 200 (do ((i r (fxadd1 i))) 201 ((bitvectorref w i) (set! j i)) 202 (bitvectorset! w i #t) ) 203 (and 204 (not (fx= j num)) 205 (let ((aj (bitvectorref a j))) 206 (bitvectorset! w j #f) 207 (set! swaps 0) 208 (if (fxodd? j) 209 (if aj 210 (moverightone j) 211 (movelefttwo j) ) 212 (if aj 213 (moverighttwo j) 214 (moveleftone j) ) ) 215 refproc ) ) ) ) ) 216 ;1st call is a "freebie" since already initialized 217 (nextpartition 218 (lambda () 219 (set! nextpartition genpartition) 220 refproc ) ) ) 221 ;turn this into the next combination. false when there are no more. 222 (lambda swapf 223 (case (optional swapf #f) 224 ((swaps) swaps ) 225 ((num) num ) 226 ((data) data ) 227 ((a) a ) 228 (else 229 (nextpartition) ) ) ) ) ) ) 230 231 ) ;module chasesequence
Note: See TracChangeset
for help on using the changeset viewer.