Changeset 37963 in project


Ignore:
Timestamp:
10/19/19 21:43:12 (4 weeks ago)
Author:
Kon Lovett
Message:

add C5 (still buggy)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • wiki/Chase Sequence

    r34937 r37963  
    11<enscript highlight="scheme">
    22;;;; chase-sequence.scm
    3 ;;;; Kon Lovett, Oct '17
     3;;;; Kon Lovett, Oct '19
    44;;;; License: Public Domain
    55
    66;;; Generates all combinations in near-perfect minimal-change order.
    77
    8 ;(define cs (make-sequence #(1 2 3 4 5 6) 3))
     8;(define cs (make-sequence #(1 2 3 4 5 6) 3)) ;s + t = 6 = 3 + 3
    99;(next-permutation cs)
    10 ;=> #(1 2 3 4 5 6)
     10;=> #(1 2 3 4 5 6) ;...
    1111
    1212(module chase-sequence
     
    1616  next-permutation)
    1717
    18 (import scheme chicken)
    19 (use lolevel srfi-4 iset fx-utils)
    20 
    21 ;;
    22 
     18(cond-expand
     19  (chicken-4
     20    (import scheme chicken)
     21    (use
     22      (only lolevel object-copy)
     23      (only srfi-4 make-u32vector u32vector-ref u32vector-set!)
     24      (only iset make-bit-vector bit-vector-ref bit-vector-set!)) )
     25  (chicken-5
     26    (import scheme
     27      (chicken base)
     28      (chicken type)
     29      (only (chicken memory representation) object-copy)
     30      (only (srfi 4) make-u32vector u32vector-ref u32vector-set!)
     31      (only iset make-bit-vector bit-vector-ref bit-vector-set!)) )
     32  (else
     33    (error "unknown CHICKEN; not chicken-4 or chicken-5") ) )
     34
     35;;
     36
     37(: u32vector-swap! (u32vector fixnum fixnum -> void))
     38;
    2339(define (u32vector-swap! u32v i j)
    2440  (let ((tmp (u32vector-ref u32v i)))
     
    2642    (u32vector-set! u32v j tmp) ) )
    2743
     44;;;
     45
     46;FIXME brittle
     47(define-type bit-vector u8vector)
     48
     49(define-type chase-result (or boolean procedure fixnum vector bit-vector))
     50
     51(define-type chase-sequence (#!optional symbol -> chase-result))
     52
     53(define-type swap-listener (fixnum -> void))
     54
     55(define-type chase-permutation (list-of vector))
     56
    2857;; Returns the next vector permutation of the specified chase sequence
    2958;; procedure, or #f when no more permutations.
    3059
     60(: next-permutation (chase-sequence -> (or boolean chase-permutation)))
     61;
    3162(define (next-permutation cs)
    3263  (let (
    33     (siz (cs 'num) )
    34     (cs-permutation (cs) ) )
    35     ;
     64    (siz (cs 'num))
     65    (cs-permutation (cs)) )
    3666    (and
    3767      cs-permutation
    3868      (let ((v (make-vector siz)))
    39         (do ((i 0 (fxadd1 i)))
    40             ((fx= i siz) v)
     69        (do ((i 0 (add1 i)))
     70            ((= i siz) v)
    4171          (vector-set! v i (cs-permutation i)))) ) ) )
    4272
     
    6595;; of section 7.2.1.3)
    6696
     97(: make-sequence (vector #!optional fixnum swap-listener --> chase-sequence))
     98;
    6799(define (make-sequence data-vector #!optional cut-point (swap-listener void))
    68100  ;
    69101  (let* (
    70     (num (vector-length data-vector) )
     102    (num (vector-length data-vector))
    71103    (t  ;t = k
    72       (if (and (fixnum? cut-point) (fx<= 1 cut-point) (fx<= cut-point num))
     104      (if (and cut-point (<= 1 cut-point num))
    73105        cut-point
    74         num ) )
    75     (s (fx- num t) )
    76     (r (if (fxpositive? s) s t) )
    77     (data (object-copy data-vector) )
    78     (swaps 0 )
    79     (comb (make-u32vector num) )
    80     (ix (make-u32vector num) )
    81     (w (make-bit-vector (fxadd1 num) #t) )
    82     (a (make-bit-vector num) )
     106        num))
     107    (s      (- num t))
     108    (r      (if (positive? s) s t))
     109    (data   (object-copy data-vector))
     110    (swaps  0)
     111    (comb   (make-u32vector num))
     112    (ix     (make-u32vector num))
     113    (w      (make-bit-vector (add1 num) #t))
     114    (a      (make-bit-vector num))
    83115    ;
    84116    (swap-listener
    85117      (lambda (i)
    86         (set! swaps (fxadd1 swaps))
    87         (swap-listener i) ) ) )
     118        (set! swaps (add1 swaps))
     119        (swap-listener i))) )
    88120    ;
    89     (do ((i 0 (fxadd1 i)))
    90         ((fx= i num))
     121    (do ((i 0 (add1 i)))
     122        ((= i num))
    91123      (u32vector-set! comb i i)
    92124      (u32vector-set! ix i i)
    93       (bit-vector-set! a i (fx>= i s)) )
     125      (bit-vector-set! a i (>= i s)) )
    94126    ;
    95     (letrec (
     127    (let ()
    96128      ;swap i and (i+1)
    97       (adjacent-swap
    98       (lambda (i)
    99         #;(assert (and (fx>= i 0) (fx< i (fxsub1 num))))
    100         ;
    101         (u32vector-set! ix (u32vector-ref comb i) (fxadd1 i))
    102         (u32vector-set! ix (u32vector-ref comb (fxadd1 i)) i)
    103         (u32vector-swap! comb i (fxadd1 i))
    104         ;
    105         #;(assert (fx= (u32vector-ref ix (u32vector-ref comb i)) i))
    106         #;(assert (fx= (u32vector-ref ix (u32vector-ref comb (fxadd1 i))) (fxadd1 i)))
    107         ;
    108         (swap-listener i) ) )
     129      (define (adjacent-swap i)
     130        #;(assert (and (>= i 0) (< i (sub1 num))))
     131        ;
     132        (u32vector-set! ix (u32vector-ref comb i) (add1 i))
     133        (u32vector-set! ix (u32vector-ref comb (add1 i)) i)
     134        (u32vector-swap! comb i (add1 i))
     135        ;
     136        #;(assert (= (u32vector-ref ix (u32vector-ref comb i)) i))
     137        #;(assert (= (u32vector-ref ix (u32vector-ref comb (add1 i))) (add1 i)))
     138        ;
     139        (swap-listener i) )
    109140      ;"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               (adjacent-swap i) )
    119             (do ((i (fxsub1 f) (fxsub1 i)))
    120                 ((fx< i t))
    121               (adjacent-swap 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            (adjacent-swap i) )
     149          (do ((i (sub1 f) (sub1 i)))
     150              ((< i t))
     151            (adjacent-swap i) ) ) )
    122152      ;move the object at index 'left' to the index immediately left of the cut,
    123153      ;and move the object at index 'right' to the index immediate right of the
    124154      ;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>= (u32vector-ref ix l) s))  ;currently right of cut
    131           (move (u32vector-ref ix l) s)             ;move it to immediate right of cut
    132           #;(assert (fx< (u32vector-ref ix r) s))   ;currently left of cut
    133           (move (u32vector-ref ix r) (fxsub1 s))    ;move it to immediate left of cut
    134           (adjacent-swap (fxsub1 s))                ;trade sides just across the cut
    135           ;
    136           #;(assert (bit-vector-ref a l))
    137           (bit-vector-set! a l #f)
    138           #;(assert (not (bit-vector-ref a r)))
    139           (bit-vector-set! 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 (>= (u32vector-ref ix l) s))  ;currently right of cut
     160        (move (u32vector-ref ix l) s)           ;move it to immediate right of cut
     161        #;(assert (< (u32vector-ref ix r) s))   ;currently left of cut
     162        (move (u32vector-ref ix r) (sub1 s))    ;move it to immediate left of cut
     163        (adjacent-swap (sub1 s))                ;trade sides just across the cut
     164        ;
     165        #;(assert (bit-vector-ref a l))
     166        (bit-vector-set! a l #f)
     167        #;(assert (not (bit-vector-ref a r)))
     168        (bit-vector-set! a r #t) )
    140169      ;C4
    141       (move-right-one
    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 (move-right-one 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) ) ) )
    151179      ;C5
    152       (move-right-two
    153         (lambda (j)
    154           #;(assert (fx> j 1))
    155           ;
    156           (if (bit-vector-ref a (fx- j 2))
    157             (move-right-one 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 (move-right-two j)
     181        #;(assert (> j 1))
     182        ;
     183        (if (bit-vector-ref a (- j 2))
     184          (move-right-one 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)) ) ) ) ) )
    165192      ;C6
    166       (move-left-one
    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 (move-left-one 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) ) ) )
    176202      ;C7
    177       (move-left-two
    178         (lambda (j)
    179           #;(assert (fx> j 0))
    180           ;
    181           (if (bit-vector-ref a (fxsub1 j))
    182             (move-left-one 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 (move-left-two j)
     204        #;(assert (> j 0))
     205        ;
     206        (if (bit-vector-ref a (sub1 j))
     207          (move-left-one 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)) ) ) ) ) )
    192217      ;retrieve the permuted data at index i
    193       (ref-proc
    194         (lambda (i)
    195           (vector-ref data (u32vector-ref comb i) ) ) )
     218      (define (ref-proc i)
     219        (vector-ref data (u32vector-ref comb i) ) )
    196220      ;
    197       (gen-partition
    198         (lambda ()
    199           ;C3: Find j and branch
    200           (let ((j #f))
    201             (do ((i r (fxadd1 i)))
    202                 ((bit-vector-ref w i) (set! j i))
    203               (bit-vector-set! w i #t) )
    204             (and
    205               (not (fx= j num))
    206               (let ((aj (bit-vector-ref a j)))
    207                 (bit-vector-set! w j #f)
    208                 (set! swaps 0)
    209                 (if (fxodd? j)
    210                   (if aj
    211                     (move-right-one j)
    212                     (move-left-two j) )
    213                   (if aj
    214                     (move-right-two j)
    215                     (move-left-one j) ) )
    216                 ref-proc ) ) ) ) )
     221      (define (gen-partition)
     222        ;C3: Find j and branch
     223        (let ((j #f))
     224          (do ((i r (add1 i)))
     225              ((bit-vector-ref w i) (set! j i))
     226            (bit-vector-set! w i #t) )
     227          (and
     228            (not (= j num))
     229            (let ((aj (bit-vector-ref a j)))
     230              (bit-vector-set! w j #f)
     231              (set! swaps 0)
     232              (if (odd? j)
     233                (if aj
     234                  (move-right-one j)
     235                  (move-left-two j) )
     236                (if aj
     237                  (move-right-two j)
     238                  (move-left-one j) ) )
     239              ref-proc ) ) ) )
    217240      ;1st call is a "freebie" since already initialized
    218       (next-partition
    219         (lambda ()
    220           (set! next-partition gen-partition)
    221           ref-proc ) ) )
     241      (define (next-partition)
     242        (set! next-partition gen-partition)
     243        ref-proc )
    222244      ;turn this into the next combination. false when there are no more.
    223       (lambda swapf
    224         (case (optional swapf #f)
     245      (lambda (#!optional swapf)
     246        (case swapf
    225247          ((swaps)  swaps )
    226248          ((num)    num )
    227249          ((data)   data )
    228250          ((a)      a )
    229           (else
    230             (next-partition) ) ) ) ) ) )
     251          (else     (next-partition) ) ) ) ) ) )
    231252
    232253) ;module chase-sequence
Note: See TracChangeset for help on using the changeset viewer.