Changeset 34936 in project


Ignore:
Timestamp:
12/15/17 16:35:37 (5 weeks ago)
Author:
kon
Message:

update for CHICKEN 4

File:
1 edited

Legend:

Unmodified
Added
Removed
  • wiki/Chase Sequence

    r7800 r34936  
    1 <enscript highlight=scheme>
    2  ;;;; chase-sequence.scm
    3  ;;;; Kon Lovett, Jan '08
    4  ;;;; License: Public Domain
    5  
    6  ;;;
    7  
    8 (define-macro (ASSERT ?form)
    9   ;`(assert ,?form)   ; Uncomment to activate assertion checking
    10   '(begin) )          ; Comment to activate assertion checking
    11 
    12  ;;; Generates all combinations in near-perfect minimal-change order.
    13 
    14 (use srfi-4)
    15 (use iset)
    16 
    17 (eval-when (compile)
    18   (declare
    19     (usual-integrations)
    20     (inline)
    21     (fixnum)
    22     (no-procedure-checks-for-usual-bindings)
    23     (export
    24       make-chase-sequence
    25       make-chase-sequence-index-swapper
    26       for-each-permutation
    27       fold-permutation) ) )
    28 
    29 ;; Enumerate the permutations of count items, at the cut-point,
    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 bit-vector 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;;;; chase-sequence.scm
     2;;;; Kon Lovett, Oct '17
     3;;;; License: Public Domain
     4
     5;;; Generates all combinations in near-perfect minimal-change order.
     6
     7;(define cs (make-sequence #(1 2 3 4 5 6) 3))
     8;(next-permutation cs)
     9;=> #(1 2 3 4 5 6)
     10
     11(module chase-sequence
     12
     13(;export
     14  make-sequence
     15  next-permutation)
     16
     17(import scheme chicken)
     18(use lolevel srfi-4 iset fx-utils)
     19
     20;;
     21
     22(define (u32vector-swap! u32v i j)
     23  (let ((tmp (u32vector-ref u32v i)))
     24    (u32vector-set! u32v i (u32vector-ref u32v j))
     25    (u32vector-set! 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 (next-permutation cs)
     31  (let (
     32    (siz (cs 'num) )
     33    (cs-permutation (cs) ) )
     34    ;
     35    (and
     36      cs-permutation
     37      (let ((v (make-vector siz)))
     38        (do ((i 0 (fxadd1 i)))
     39            ((fx= i siz) v)
     40          (vector-set! v i (cs-permutation i)))) ) ) )
     41
     42;; Enumerate the permutations of the {{data-vector}} at the, optional,
     43;; {{cut-point}}. The default is {{data-vector}} length.
     44;;
     45;; The optional {{swap-listener}} 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 < (vector-length data-vector)}}, or {{#f}}
     52;; when permutations are exhausted. This procedure when called will return the
     53;; value of the {{data-vector}} 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 {{data-vector}}
     59;; 'a       =>  bit-vector where #t bit is a swap.
     60;;
     61;; Chase's Sequence is an algorithm for enumerating the permutations of
    3862;; a data-set by adjacent swaps.
    3963;; (Knuth's "The Art of Computer Programming" pre-fascicle 2C, the draft
    4064;; of section 7.2.1.3)
    4165
    42 (define (make-chase-sequence 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 (make-bit-vector (add1 n) #t)] ; w
    48           [delta (make-bit-vector n #f)] )      ; a
    49       ; Initialize the 1st combination
    50       (do ([i s (add1 i)])
    51           [(= i n)]
    52         (bit-vector-set! 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 (bit-vector-ref delta lt))
    61                 (bit-vector-set! delta lt #f)
    62                 (ASSERT (not (bit-vector-ref delta rt)))
    63                 (bit-vector-set! delta rt #t)
    64                 (swpprc lt rt) ) ]
    65             ;; C4
    66             [move-right-one
    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             [move-right-two
    77               (lambda (j)
    78                 (ASSERT (> j 1))
    79                 (let ([r2 (- j 2)])
    80                   (if (bit-vector-ref delta r2)
    81                       (move-right-one 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             [move-left-one
    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             [move-left-two
    100               (lambda (j)
    101                 (ASSERT (> j 0))
    102                 (if (bit-vector-ref delta (sub1 j))
    103                     (move-left-one 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             [gen-partition
    114               (lambda ()
    115                 (swpprc 'init)
    116                 (let ([j (do ([i r (add1 i)])
    117                              [(bit-vector-ref fence i) i]
    118                            (bit-vector-set! fence i #t) ) ] )
    119                   (and (not (= j n))
    120                        (let ([aj (bit-vector-ref delta j)])
    121                          (bit-vector-set! fence j #f)
    122                          (if (odd? j)
    123                              (if aj
    124                                  (move-right-one j)
    125                                  (move-left-two j) )
    126                              (if aj
    127                                  (move-right-two j)
    128                                  (move-left-one j) ) ) ) ) ) ) ]
    129             ;; Return the index procedure for the next partition
    130             [next-partition
    131               (lambda ()
    132                 ; Subsequent partitions
    133                 (set! next-partition gen-partition)
    134                 #t ) ] )
    135         ;; Return a control procedure.
     66(define (make-sequence data-vector #!optional cut-point (swap-listener void))
     67  ;
     68  (let* (
     69    (num (vector-length data-vector) )
     70    (t  ;t = k
     71      (if (and (fixnum? cut-point) (fx<= 1 cut-point) (fx<= cut-point num))
     72        cut-point
     73        num ) )
     74    (s (fx- num t) )
     75    (r (if (fxpositive? s) s t) )
     76    (data (object-copy data-vector) )
     77    (swaps 0 )
     78    (comb (make-u32vector num) )
     79    (ix (make-u32vector num) )
     80    (w (make-bit-vector (fxadd1 num) #t) )
     81    (a (make-bit-vector num) )
     82    ;
     83    (swap-listener
     84      (lambda (i)
     85        (set! swaps (fxadd1 swaps))
     86        (swap-listener i) ) ) )
     87    ;
     88    (do ((i 0 (fxadd1 i)))
     89        ((fx= i num))
     90      (u32vector-set! comb i i)
     91      (u32vector-set! ix i i)
     92      (bit-vector-set! a i (fx>= i s)) )
     93    ;
     94    (letrec (
     95      ;swap i and (i+1)
     96      (adjacent-swap
     97      (lambda (i)
     98        #;(assert (and (fx>= i 0) (fx< i (fxsub1 num))))
     99        ;
     100        (u32vector-set! ix (u32vector-ref comb i) (fxadd1 i))
     101        (u32vector-set! ix (u32vector-ref comb (fxadd1 i)) i)
     102        (u32vector-swap! comb i (fxadd1 i))
     103        ;
     104        #;(assert (fx= (u32vector-ref ix (u32vector-ref comb i)) i))
     105        #;(assert (fx= (u32vector-ref ix (u32vector-ref comb (fxadd1 i))) (fxadd1 i)))
     106        ;
     107        (swap-listener 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              (adjacent-swap i) )
     118            (do ((i (fxsub1 f) (fxsub1 i)))
     119                ((fx< i t))
     120              (adjacent-swap 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>= (u32vector-ref ix l) s))  ;currently right of cut
     130          (move (u32vector-ref ix l) s)             ;move it to immediate right of cut
     131          #;(assert (fx< (u32vector-ref ix r) s))   ;currently left of cut
     132          (move (u32vector-ref ix r) (fxsub1 s))    ;move it to immediate left of cut
     133          (adjacent-swap (fxsub1 s))                ;trade sides just across the cut
     134          ;
     135          #;(assert (bit-vector-ref a l))
     136          (bit-vector-set! a l #f)
     137          #;(assert (not (bit-vector-ref a r)))
     138          (bit-vector-set! a r #t) ) )
     139      ;C4
     140      (move-right-one
     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      (move-right-two
     152        (lambda (j)
     153          #;(assert (fx> j 1))
     154          ;
     155          (if (bit-vector-ref a (fx- j 2))
     156            (move-right-one 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      (move-left-one
     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      (move-left-two
     177        (lambda (j)
     178          #;(assert (fx> j 0))
     179          ;
     180          (if (bit-vector-ref a (fxsub1 j))
     181            (move-left-one 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      (ref-proc
     193        (lambda (i)
     194          (vector-ref data (u32vector-ref comb i) ) ) )
     195      ;
     196      (gen-partition
    136197        (lambda ()
    137           (and (next-partition)
    138                delta) ) ) ) ) )
    139 
    140 ;;;
    141 
    142 (define (u32vector-swap! u32v i j)
    143   (let ([oi (u32vector-ref u32v i)])
    144     (u32vector-set! u32v i (u32vector-ref u32v j))
    145     (u32vector-set! u32v j oi) ) )
    146 
    147 ;; Make a indicies swapper for count items, at the cut-point,
    148 ;; cut.
    149 ;;
    150 ;; Returns a procedure to be supplied as a swap-procedure to
    151 ;; the chase-sequence 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 out-of-range.
    157 
    158 (define (make-chase-sequence-index-swapper 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 (make-u32vector n)]
    164           [ix (make-u32vector n)])
    165       ;
    166       (do ([i 0 (add1 i)])
    167           [(= i n)]
    168         (u32vector-set! comb i i)
    169         (u32vector-set! ix i i) )
    170       ;
    171       (letrec (
    172             ;; Swap i and (i+1)
    173             [adjacent-swap
    174               (lambda (i)
    175                 (ASSERT (and (<= 0 i) (< i (sub1 n))))
    176                 (let ([i1 (add1 i)])
    177                   (u32vector-set! ix (u32vector-ref comb i) i1)
    178                   (u32vector-set! ix (u32vector-ref comb i1) i)
    179                   (u32vector-swap! comb i i1)
    180                   (ASSERT (= (u32vector-ref ix (u32vector-ref comb i)) i))
    181                   (ASSERT (= (u32vector-ref ix (u32vector-ref 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                       (adjacent-swap i) )
    192                     (do ([i (sub1 f) (sub1 i)])
    193                         [(< i t)]
    194                       (adjacent-swap 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 (>= (u32vector-ref ix lt) s))  ; currently right of cut
    203                 (move (u32vector-ref ix lt) s)         ; move it to immediate right of cut
    204                 (ASSERT (< (u32vector-ref ix rt) s))   ; currently left of cut
    205                 (move (u32vector-ref ix rt) (sub1 s))  ; move it to immediate left of cut
    206                 (adjacent-swap (sub1 s)) ) ]           ; trade sides just across the cut
    207             ;; Retrieve the permuted index at index i
    208             [get-index
    209               (lambda (i)
    210                 (and (< -1 i n)
    211                      (u32vector-ref comb i) ) ) ] )
    212         ;
    213         (lambda args
    214           (cond [(null? args)
    215                   get-index]
    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 (for-each-permutation idxfnc prc)
    226   (let loop ([i 0])
    227     (and-let* ([j (idxfnc i)])
    228       (prc i j)
    229       (loop (add1 i)) ) ) )
    230 
    231 ;; Calls the function
    232 
    233 (define (fold-permutation 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 (bit-vector-display bv #!optional (len (bit-vector-length bv)))
    243   (display "#<")
    244   (let ([len1 (sub1 len)])
    245     (let loop ([i 0])
    246       (display (bit-vector-ref bv i))
    247       (if (< i len1)
    248           (begin
    249             (display #\space)
    250             (loop (add1 i)) )
    251           (display #\>) ) ) ) )
    252 
    253 (define (print-indicies idxfnc)
    254   (for-each-permutation idxfnc (lambda (i j) (print i #\space j))) )
    255 
    256 (define (print-permutation prmprc #!optional swpprc vec)
    257   (and-let* ([delta (prmprc)])
    258     (bit-vector-display delta 5) (newline)
    259     (when swpprc
    260       (if vec
    261           (begin
    262             (for-each-permutation (swpprc)
    263                                   (lambda (i j)
    264                                     (display (vector-ref vec j)) (display #\space)))
    265             (newline) )
    266           (print-indicies (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 (permutation-count n r)
    276   (/ (factorial n) (factorial (- n r))) )
    277 
    278 (define (combination-count n r)
    279   (/ (factorial n) (* (factorial r) (factorial (- n r)))) )
    280 
    281 ;;; Example
    282 
    283 #|
    284 (use miscmacros)
    285 (define s1 (make-chase-sequence-index-swapper 5 2))
    286 (define cs1 (make-chase-sequence 5 2 s1))
    287 (define v1 '#(1 2 3 4 5))
    288 (combination-count 5 2)
    289 (while (print-permutation cs1 s1 v1))
    290 |#
    291 </enscript>
     198          ;C3: Find j and branch
     199          (let ((j #f))
     200            (do ((i r (fxadd1 i)))
     201                ((bit-vector-ref w i) (set! j i))
     202              (bit-vector-set! w i #t) )
     203            (and
     204              (not (fx= j num))
     205              (let ((aj (bit-vector-ref a j)))
     206                (bit-vector-set! w j #f)
     207                (set! swaps 0)
     208                (if (fxodd? j)
     209                  (if aj
     210                    (move-right-one j)
     211                    (move-left-two j) )
     212                  (if aj
     213                    (move-right-two j)
     214                    (move-left-one j) ) )
     215                ref-proc ) ) ) ) )
     216      ;1st call is a "freebie" since already initialized
     217      (next-partition
     218        (lambda ()
     219          (set! next-partition gen-partition)
     220          ref-proc ) ) )
     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            (next-partition) ) ) ) ) ) )
     230
     231) ;module chase-sequence
Note: See TracChangeset for help on using the changeset viewer.