Changeset 37963 in project
 Timestamp:
 10/19/19 21:43:12 (4 months ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

wiki/Chase Sequence
r34937 r37963 1 1 <enscript highlight="scheme"> 2 2 ;;;; chasesequence.scm 3 ;;;; Kon Lovett, Oct '1 73 ;;;; Kon Lovett, Oct '19 4 4 ;;;; License: Public Domain 5 5 6 6 ;;; Generates all combinations in nearperfect minimalchange order. 7 7 8 ;(define cs (makesequence #(1 2 3 4 5 6) 3)) 8 ;(define cs (makesequence #(1 2 3 4 5 6) 3)) ;s + t = 6 = 3 + 3 9 9 ;(nextpermutation cs) 10 ;=> #(1 2 3 4 5 6) 10 ;=> #(1 2 3 4 5 6) ;... 11 11 12 12 (module chasesequence … … 16 16 nextpermutation) 17 17 18 (import scheme chicken) 19 (use lolevel srfi4 iset fxutils) 20 21 ;; 22 18 (condexpand 19 (chicken4 20 (import scheme chicken) 21 (use 22 (only lolevel objectcopy) 23 (only srfi4 makeu32vector u32vectorref u32vectorset!) 24 (only iset makebitvector bitvectorref bitvectorset!)) ) 25 (chicken5 26 (import scheme 27 (chicken base) 28 (chicken type) 29 (only (chicken memory representation) objectcopy) 30 (only (srfi 4) makeu32vector u32vectorref u32vectorset!) 31 (only iset makebitvector bitvectorref bitvectorset!)) ) 32 (else 33 (error "unknown CHICKEN; not chicken4 or chicken5") ) ) 34 35 ;; 36 37 (: u32vectorswap! (u32vector fixnum fixnum > void)) 38 ; 23 39 (define (u32vectorswap! u32v i j) 24 40 (let ((tmp (u32vectorref u32v i))) … … 26 42 (u32vectorset! u32v j tmp) ) ) 27 43 44 ;;; 45 46 ;FIXME brittle 47 (definetype bitvector u8vector) 48 49 (definetype chaseresult (or boolean procedure fixnum vector bitvector)) 50 51 (definetype chasesequence (#!optional symbol > chaseresult)) 52 53 (definetype swaplistener (fixnum > void)) 54 55 (definetype chasepermutation (listof vector)) 56 28 57 ;; Returns the next vector permutation of the specified chase sequence 29 58 ;; procedure, or #f when no more permutations. 30 59 60 (: nextpermutation (chasesequence > (or boolean chasepermutation))) 61 ; 31 62 (define (nextpermutation cs) 32 63 (let ( 33 (siz (cs 'num) ) 34 (cspermutation (cs) ) ) 35 ; 64 (siz (cs 'num)) 65 (cspermutation (cs)) ) 36 66 (and 37 67 cspermutation 38 68 (let ((v (makevector siz))) 39 (do ((i 0 ( fxadd1 i)))40 (( fx= i siz) v)69 (do ((i 0 (add1 i))) 70 ((= i siz) v) 41 71 (vectorset! v i (cspermutation i)))) ) ) ) 42 72 … … 65 95 ;; of section 7.2.1.3) 66 96 97 (: makesequence (vector #!optional fixnum swaplistener > chasesequence)) 98 ; 67 99 (define (makesequence datavector #!optional cutpoint (swaplistener void)) 68 100 ; 69 101 (let* ( 70 (num (vectorlength datavector) 102 (num (vectorlength datavector)) 71 103 (t ;t = k 72 (if (and (fixnum? cutpoint) (fx<= 1 cutpoint) (fx<=cutpoint num))104 (if (and cutpoint (<= 1 cutpoint num)) 73 105 cutpoint 74 num ))75 (s (fx num t))76 (r (if (fxpositive? s) s t))77 (data (objectcopy datavector))78 (swaps 0)79 (comb (makeu32vector num))80 (ix (makeu32vector num))81 (w (makebitvector (fxadd1 num) #t))82 (a (makebitvector num))106 num)) 107 (s ( num t)) 108 (r (if (positive? s) s t)) 109 (data (objectcopy datavector)) 110 (swaps 0) 111 (comb (makeu32vector num)) 112 (ix (makeu32vector num)) 113 (w (makebitvector (add1 num) #t)) 114 (a (makebitvector num)) 83 115 ; 84 116 (swaplistener 85 117 (lambda (i) 86 (set! swaps ( fxadd1 swaps))87 (swaplistener i) )) )118 (set! swaps (add1 swaps)) 119 (swaplistener i))) ) 88 120 ; 89 (do ((i 0 ( fxadd1 i)))90 (( fx= i num))121 (do ((i 0 (add1 i))) 122 ((= i num)) 91 123 (u32vectorset! comb i i) 92 124 (u32vectorset! ix i i) 93 (bitvectorset! a i ( fx>= i s)) )125 (bitvectorset! a i (>= i s)) ) 94 126 ; 95 (let rec (127 (let () 96 128 ;swap i and (i+1) 97 (adjacentswap 98 (lambda (i) 99 #;(assert (and (fx>= i 0) (fx< i (fxsub1 num)))) 100 ; 101 (u32vectorset! ix (u32vectorref comb i) (fxadd1 i)) 102 (u32vectorset! ix (u32vectorref comb (fxadd1 i)) i) 103 (u32vectorswap! comb i (fxadd1 i)) 104 ; 105 #;(assert (fx= (u32vectorref ix (u32vectorref comb i)) i)) 106 #;(assert (fx= (u32vectorref ix (u32vectorref comb (fxadd1 i))) (fxadd1 i))) 107 ; 108 (swaplistener i) ) ) 129 (define (adjacentswap i) 130 #;(assert (and (>= i 0) (< i (sub1 num)))) 131 ; 132 (u32vectorset! ix (u32vectorref comb i) (add1 i)) 133 (u32vectorset! ix (u32vectorref comb (add1 i)) i) 134 (u32vectorswap! comb i (add1 i)) 135 ; 136 #;(assert (= (u32vectorref ix (u32vectorref comb i)) i)) 137 #;(assert (= (u32vectorref ix (u32vectorref comb (add1 i))) (add1 i))) 138 ; 139 (swaplistener i) ) 109 140 ;"bubble" the object from {{f}} to {{t}} by swapping 110 (move 111 (lambda (f t) 112 #;(assert (and (fx>= f 0) (fx< f num))) 113 #;(assert (and (fx>= t 0) (fx< t num))) 114 ; 115 (if (fx< f t) 116 (do ((i f (fxadd1 i))) 117 ((fx= i t)) 118 (adjacentswap i) ) 119 (do ((i (fxsub1 f) (fxsub1 i))) 120 ((fx< i t)) 121 (adjacentswap i) ) ) ) ) 141 (define (move f t) 142 #;(assert (and (>= f 0) (< f num))) 143 #;(assert (and (>= t 0) (< t num))) 144 ; 145 (if (< f t) 146 (do ((i f (add1 i))) 147 ((= i t)) 148 (adjacentswap i) ) 149 (do ((i (sub1 f) (sub1 i))) 150 ((< i t)) 151 (adjacentswap i) ) ) ) 122 152 ;move the object at index 'left' to the index immediately left of the cut, 123 153 ;and move the object at index 'right' to the index immediate right of the 124 154 ;cut 125 (exchange 126 (lambda (l r) 127 #;(assert (and (fx>= l 0) (fx< l num))) 128 #;(assert (and (fx>= r 0) (fx< r num))) 129 ; 130 #;(assert (fx>= (u32vectorref ix l) s)) ;currently right of cut 131 (move (u32vectorref ix l) s) ;move it to immediate right of cut 132 #;(assert (fx< (u32vectorref ix r) s)) ;currently left of cut 133 (move (u32vectorref ix r) (fxsub1 s)) ;move it to immediate left of cut 134 (adjacentswap (fxsub1 s)) ;trade sides just across the cut 135 ; 136 #;(assert (bitvectorref a l)) 137 (bitvectorset! a l #f) 138 #;(assert (not (bitvectorref a r))) 139 (bitvectorset! a r #t) ) ) 155 (define (exchange l r) 156 #;(assert (and (>= l 0) (< l num))) 157 #;(assert (and (>= r 0) (< r num))) 158 ; 159 #;(assert (>= (u32vectorref ix l) s)) ;currently right of cut 160 (move (u32vectorref ix l) s) ;move it to immediate right of cut 161 #;(assert (< (u32vectorref ix r) s)) ;currently left of cut 162 (move (u32vectorref ix r) (sub1 s)) ;move it to immediate left of cut 163 (adjacentswap (sub1 s)) ;trade sides just across the cut 164 ; 165 #;(assert (bitvectorref a l)) 166 (bitvectorset! a l #f) 167 #;(assert (not (bitvectorref a r))) 168 (bitvectorset! a r #t) ) 140 169 ;C4 141 (moverightone 142 (lambda (j) 143 #;(assert (fx> j 0)) 144 ; 145 (exchange j (fxsub1 j)) 146 (cond 147 ((and (fx= r j) (fx> j 1)) 148 (set! r (fxsub1 j)) ) 149 ((fx= r (fxsub1 j)) 150 (set! r j) ) ) ) ) 170 (define (moverightone j) 171 #;(assert (> j 0)) 172 ; 173 (exchange j (sub1 j)) 174 (cond 175 ((and (= r j) (> j 1)) 176 (set! r (sub1 j)) ) 177 ((= r (sub1 j)) 178 (set! r j) ) ) ) 151 179 ;C5 152 (moverighttwo 153 (lambda (j) 154 #;(assert (fx> j 1)) 155 ; 156 (if (bitvectorref a (fx j 2)) 157 (moverightone j) 158 (begin 159 (exchange j (fx j 2)) 160 (cond 161 ((fx= r j) 162 (set! r (if (fx> j 3) (fx j 2) 1))) 163 ((fx= r (fx j 2)) 164 (set! r (fxsub1 j)) ) ) ) ) ) ) 180 (define (moverighttwo j) 181 #;(assert (> j 1)) 182 ; 183 (if (bitvectorref a ( j 2)) 184 (moverightone j) 185 (begin 186 (exchange j ( j 2)) 187 (cond 188 ((= r j) 189 (set! r (if (> j 3) ( j 2) 1))) 190 ((= r ( j 2)) 191 (set! r (sub1 j)) ) ) ) ) ) 165 192 ;C6 166 (moveleftone 167 (lambda (j) 168 #;(assert (fx> j 0)) 169 ; 170 (exchange (fxsub1 j) j) 171 (cond 172 ((and (fx= r j) (fx> j 1)) 173 (set! r (fxsub1 j)) ) 174 ((fx= r (fxsub1 j)) 175 (set! r j) ) ) ) ) 193 (define (moveleftone j) 194 #;(assert (> j 0)) 195 ; 196 (exchange (sub1 j) j) 197 (cond 198 ((and (= r j) (> j 1)) 199 (set! r (sub1 j)) ) 200 ((= r (sub1 j)) 201 (set! r j) ) ) ) 176 202 ;C7 177 (movelefttwo 178 (lambda (j) 179 #;(assert (fx> j 0)) 180 ; 181 (if (bitvectorref a (fxsub1 j)) 182 (moveleftone j) 183 (begin 184 #;(assert (fx> j 1)) 185 ; 186 (exchange (fx j 2) j) 187 (cond 188 ((fx= r (fx j 2)) 189 (set! r j) ) 190 ((fx= r (fxsub1 j)) 191 (set! r (fx j 2)) ) ) ) ) ) ) 203 (define (movelefttwo j) 204 #;(assert (> j 0)) 205 ; 206 (if (bitvectorref a (sub1 j)) 207 (moveleftone j) 208 (begin 209 #;(assert (> j 1)) 210 ; 211 (exchange ( j 2) j) 212 (cond 213 ((= r ( j 2)) 214 (set! r j) ) 215 ((= r (sub1 j)) 216 (set! r ( j 2)) ) ) ) ) ) 192 217 ;retrieve the permuted data at index i 193 (refproc 194 (lambda (i) 195 (vectorref data (u32vectorref comb i) ) ) ) 218 (define (refproc i) 219 (vectorref data (u32vectorref comb i) ) ) 196 220 ; 197 (genpartition 198 (lambda () 199 ;C3: Find j and branch 200 (let ((j #f)) 201 (do ((i r (fxadd1 i))) 202 ((bitvectorref w i) (set! j i)) 203 (bitvectorset! w i #t) ) 204 (and 205 (not (fx= j num)) 206 (let ((aj (bitvectorref a j))) 207 (bitvectorset! w j #f) 208 (set! swaps 0) 209 (if (fxodd? j) 210 (if aj 211 (moverightone j) 212 (movelefttwo j) ) 213 (if aj 214 (moverighttwo j) 215 (moveleftone j) ) ) 216 refproc ) ) ) ) ) 221 (define (genpartition) 222 ;C3: Find j and branch 223 (let ((j #f)) 224 (do ((i r (add1 i))) 225 ((bitvectorref w i) (set! j i)) 226 (bitvectorset! w i #t) ) 227 (and 228 (not (= j num)) 229 (let ((aj (bitvectorref a j))) 230 (bitvectorset! w j #f) 231 (set! swaps 0) 232 (if (odd? j) 233 (if aj 234 (moverightone j) 235 (movelefttwo j) ) 236 (if aj 237 (moverighttwo j) 238 (moveleftone j) ) ) 239 refproc ) ) ) ) 217 240 ;1st call is a "freebie" since already initialized 218 (nextpartition 219 (lambda () 220 (set! nextpartition genpartition) 221 refproc ) ) ) 241 (define (nextpartition) 242 (set! nextpartition genpartition) 243 refproc ) 222 244 ;turn this into the next combination. false when there are no more. 223 (lambda swapf224 (case (optional swapf #f)245 (lambda (#!optional swapf) 246 (case swapf 225 247 ((swaps) swaps ) 226 248 ((num) num ) 227 249 ((data) data ) 228 250 ((a) a ) 229 (else 230 (nextpartition) ) ) ) ) ) ) 251 (else (nextpartition) ) ) ) ) ) ) 231 252 232 253 ) ;module chasesequence
Note: See TracChangeset
for help on using the changeset viewer.