Changeset 36370 in project


Ignore:
Timestamp:
08/24/18 20:39:07 (3 months ago)
Author:
iraikov
Message:

yasos: additional operations on collections

Location:
release/5/yasos/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/5/yasos/trunk/collections.scm

    r36339 r36370  
    22(module yasos-collections
    33
    4         (collection? gen-keys gen-elts
    5          do-elts do-keys do-items map-elts map-keys map-items
    6          for-each-key for-each-elt
    7          reduce any? every? empty? size make-vec-gen-elts
    8          list-gen-elts vector-gen-elts string-gen-elts)
    9        
    10         (import scheme (chicken base) (chicken format)
    11                 (except yasos object object-with-ancestors))
    12 
    13        
     4 (collection? random-access? empty? size gen-keys gen-elts
     5              do-elts do-keys do-items do-items-while
     6              map-elts map-keys map-items
     7              for-each-key for-each-elt elt-ref elt-set! elt-take elt-drop
     8              reduce reduce* any-elt? every-elt? zip-elts sort! sort
     9              make-vec-gen-elts list-gen-elts vector-gen-elts
     10              string-gen-elts hash-table-gen-elts
     11              )
     12 
     13 (import scheme (chicken base) (chicken format) srfi-69
     14         (except yasos object object-with-ancestors))
     15
     16 
    1417;; COLLECTION INTERFACE
    1518
     
    4447;;  for-each-key
    4548;;  for-each-elt
     49;;
     50;; Collections may optionally implement random access operations:
     51;;
     52;; elt-ref
     53;; elt-set!
     54;; elt-take
     55;; elt-drop
     56;;
    4657;;==============================
    4758
    48 (define (zip list1 . more-lists) (apply map list list1 more-lists))
    49        
    50 (define-operation (collection? obj)
    51  ;; default
    52   (cond
    53     ((or (list? obj) (vector? obj) (string obj)) #t)
     59 (define (list-zip list1 . more-lists) (apply map list list1 more-lists))
     60
     61 (define (list-take lis k)
     62  (let recur ((lis lis) (k k))
     63    (if (eq? 0 k) '()
     64        (cons (car lis)
     65              (recur (cdr lis) (- k 1))))))
     66
     67 (define (list-drop lis k)
     68   (let iter ((lis lis) (k k))
     69    (if (eq? 0 k) lis (iter (cdr lis) (- k 1)))))
     70 
     71 
     72 (define-operation (collection? obj)
     73  ;; default
     74   (cond
     75    ((or (list? obj) (vector? obj) (string? obj) (hash-table? obj)) #t)
    5476    (else #f)
    55 ) )
    56 
    57 (define (empty? collection) (zero? (size collection)))
    58 
    59 (define-operation (gen-elts <collection>) ;; return element generator
     77    ))
     78 
     79 (define-operation (random-access? obj)
     80  ;; default
     81   (cond
     82    ((or (list? obj) (vector? obj) (string? obj) (hash-table? obj)) #t)
     83    (else #f)
     84    ))
     85 
     86 
     87 (define (empty? collection) (zero? (size collection)))
     88 
     89 (define-operation (elt-ref <collection> i);; random access collection
    6090  ;; default behavior
    61   (cond                      ;; see utilities, below, for generators
     91   (cond                     
     92    ((vector? <collection>) (vector-ref <collection> i))
     93    ((list?   <collection>) (list-ref  <collection> i))
     94    ((string? <collection>) (string-ref  <collection> i))
     95    ((hash-table? <collection>) (hash-table-ref <collection> i))
     96    (else
     97     (error "operation not supported: elt-ref"))
     98    ))
     99 
     100 (define-operation (elt-set! <collection> i v);; random access collection
     101  ;; default behavior
     102   (cond                     
     103    ((vector? <collection>) (vector-set! <collection> i v))
     104    ((list?   <collection>) (list-set!  <collection> i v))
     105    ((string? <collection>) (string-set!  <collection> i v))
     106    ((hash-table? <collection>) (hash-table-set! <collection> i v))
     107    (else
     108     (error "operation not supported: elt-set!"))
     109    ))
     110
     111 (define-operation (elt-take <collection> n);; random access collection
     112  ;; default behavior
     113   (cond                     
     114    ((vector? <collection>) (subvector <collection> 0 n))
     115    ((list?   <collection>) (list-take  <collection> n))
     116    ((string? <collection>) (substring  <collection> 0 n))
     117    ((hash-table? <collection>)
     118     (let ((keys (hash-table-keys <collection>))
     119           (result (make-hash-table)))
     120       (for-each
     121        (lambda (k) (hash-table-set! result k (hash-table-ref <collection> k)))
     122        (list-take keys n))
     123       result))
     124    (else
     125     (error "operation not supported: elt-take"))
     126    ))
     127
     128
     129 (define-operation (elt-drop <collection> n);; random access collection
     130  ;; default behavior
     131   (cond                     
     132    ((vector? <collection>) (subvector <collection> n))
     133    ((list?   <collection>) (list-drop  <collection> n))
     134    ((string? <collection>) (substring  <collection> n))
     135    ((hash-table? <collection>)
     136     (let ((keys (hash-table-keys <collection>))
     137           (result (make-hash-table)))
     138       (for-each
     139        (lambda (k) (hash-table-set! result k (hash-table-ref <collection> k)))
     140        (list-drop keys n))
     141       result))
     142    (else
     143     (error "operation not supported: elt-take"))
     144    ))
     145
     146 (define-operation (gen-elts <collection>);; return element generator
     147  ;; default behavior
     148   (cond                     ;; see utilities, below, for generators
    62149    ((vector? <collection>) (vector-gen-elts <collection>))
    63150    ((list?   <collection>) (list-gen-elts   <collection>))
    64151    ((string? <collection>) (string-gen-elts <collection>))
     152    ((hash-table? <collection>) (hash-table-gen-elts <collection>))
    65153    (else
    66       (error "operation not supported: gen-elts "))
    67 ) )
    68 
    69 (define-operation (gen-keys collection)
    70   (if (or (vector? collection) (list? collection) (string? collection))
    71       (let ( (max+1 (size collection)) (index 0) )
    72          (lambda ()
    73             (cond
    74               ((< index max+1)
    75                (set! index (add1 index))
    76                (sub1 index))
    77               (else (error "no more keys in generator"))
    78       ) ) )
    79       (error "operation not handled: gen-keys " collection)
    80 ) )
    81 
    82 (define (do-elts <proc> . <collections>)
    83   (let ( (max+1 (size (car <collections>)))
    84          (generators (map gen-elts <collections>))
    85        )
    86     (let loop ( (counter 0) )
    87        (cond
    88           ((< counter max+1)
    89            (apply <proc> (map (lambda (g) (g)) generators))
    90            (loop (add1 counter))
    91           )
    92           (else 'unspecific)  ; done
    93     )  )
    94 ) )
    95 
    96 (define (do-keys <proc> . <collections>)
    97   (let ( (max+1 (size (car <collections>)))
    98          (generators (map gen-keys <collections>))
    99        )
    100     (let loop ( (counter 0) )
    101        (cond
    102           ((< counter max+1)
    103            (apply <proc> (map (lambda (g) (g)) generators))
    104            (loop (add1 counter))
    105           )
    106           (else 'unspecific)  ; done
    107     )  )
    108 ) )
    109 
    110 (define (do-items <proc> . <collections>)
    111   (let ( (max+1 (size (car <collections>)))
    112          (elt-generators (map gen-elts <collections>))
    113          (key-generators (map gen-keys <collections>)) )
    114     (let loop ( (counter 0) )
    115        (cond
    116           ((< counter max+1)
    117            (apply <proc> (zip (map (lambda (g) (g)) key-generators)
    118                               (map (lambda (g) (g)) elt-generators)))
    119            (loop (add1 counter))
    120           )
    121           (else 'unspecific)  ; done
    122     )  )
    123 ) )
    124 
    125 (define (map-elts <proc> . <collections>)
    126   (let ( (max+1 (size (car <collections>)))
    127          (generators (map gen-elts <collections>))
    128          (vec (make-vector (size (car <collections>))))
    129        )
    130     (let loop ( (index 0) )
    131        (cond
    132           ((< index max+1)
    133            (vector-set! vec index (apply <proc> (map (lambda (g) (g)) generators)))
    134            (loop (add1 index))
    135           )
    136           (else vec)  ; done
    137     )  )
    138 ) )
    139 
    140 (define (map-keys <proc> . <collections>)
    141   (let ( (max+1 (size (car <collections>)))
    142          (generators (map gen-keys <collections>))
    143          (vec (make-vector (size (car <collections>))))
    144        )
    145     (let loop ( (index 0) )
    146        (cond
    147           ((< index max+1)
    148            (vector-set! vec index (apply <proc> (map (lambda (g) (g)) generators)))
    149            (loop (add1 index))
    150           )
    151           (else vec)  ; done
    152     )  )
    153 ) )
    154 
    155 (define (map-items <proc> . <collections>)
    156   (let ( (max+1 (size (car <collections>)))
    157          (key-generators (map gen-keys <collections>))
    158          (elt-generators (map gen-elts <collections>))
    159          (vec (make-vector (size (car <collections>))))
    160        )
    161     (let loop ( (index 0) )
    162        (cond
    163           ((< index max+1)
    164            (vector-set! vec index (apply <proc> (zip (map (lambda (g) (g)) key-generators)
    165                                                      (map (lambda (g) (g)) elt-generators))))
    166            (loop (add1 index))
    167           )
    168           (else vec)  ; done
    169     )  )
    170 ) )
    171 
    172 (define-operation (for-each-key <collection> <proc>)
    173    ;; default
    174    (do-keys <proc> <collection>)  ;; talk about lazy!
    175 )
    176 
    177 (define-operation (for-each-elt <collection> <proc>)
    178    (do-elts <proc> <collection>)
    179 )
    180 
    181 (define (reduce <proc> <seed> . <collections>)
     154     (error "operation not supported: gen-elts "))
     155    ))
     156
     157
     158 (define-operation (gen-keys collection)
     159   (cond
     160    ((or (vector? collection) (list? collection) (string? collection))
     161     (let ( (max+1 (size collection)) (index (make-parameter 0) ))
     162       (lambda ()
     163         (let ((i (index)))
     164           (cond
     165            ((< i max+1)
     166             (index (add1 i))
     167             i)
     168            (else (error "no more keys in generator"))
     169            ))
     170         ))
     171     )
     172    ((hash-table? collection)
     173     (list-gen-elts (hash-table-keys collection)))
     174    (else
     175     (error "operation not handled: gen-keys " collection))
     176    ))
     177
     178 (define (do-elts <proc> . <collections>)
     179   (let ( (max+1 (size (car <collections>)))
     180          (generators (map gen-elts <collections>))
     181          )
     182     (let loop ( (counter 0) )
     183       (cond
     184        ((< counter max+1)
     185         (apply <proc> (map (lambda (g) (g)) generators))
     186         (loop (add1 counter))
     187         )
     188        (else 'unspecific)  ; done
     189        )  )
     190     ) )
     191
     192 (define (do-keys <proc> . <collections>)
     193   (let ( (max+1 (size (car <collections>)))
     194          (generators (map gen-keys <collections>))
     195          )
     196     (let loop ( (counter 0) )
     197       (cond
     198        ((< counter max+1)
     199         (apply <proc> (map (lambda (g) (g)) generators))
     200         (loop (add1 counter))
     201         )
     202        (else 'unspecific)  ; done
     203        )  )
     204     ) )
     205
     206 (define (do-items <proc> . <collections>)
     207   (let ( (max+1 (size (car <collections>)))
     208          (elt-generators (map gen-elts <collections>))
     209          (key-generators (map gen-keys <collections>)) )
     210     (let loop ( (counter 0) )
     211       (cond
     212        ((< counter max+1)
     213         (apply <proc> (list-zip (map (lambda (g) (g)) key-generators)
     214                                 (map (lambda (g) (g)) elt-generators)))
     215         (loop (add1 counter))
     216         )
     217        (else 'unspecific)  ; done
     218        )  )
     219     ) )
     220 
     221 (define (do-items-while <proc> . <collections>)
     222   (let ( (max+1 (size (car <collections>)))
     223          (elt-generators (map gen-elts <collections>))
     224          (key-generators (map gen-keys <collections>)) )
     225     (let loop ( (counter 0) )
     226       (cond
     227        ((< counter max+1)
     228         (let ((res (apply <proc> (list-zip (map (lambda (g) (g)) key-generators)
     229                                            (map (lambda (g) (g)) elt-generators)))))
     230           (if res (loop (add1 counter)))
     231           ))
     232        (else 'unspecific)  ; done
     233        ))
     234     ))
     235
     236 (define (map-elts <proc> . <collections>)
     237   (let ( (max+1 (size (car <collections>)))
     238          (generators (map gen-elts <collections>))
     239          (vec (make-vector (size (car <collections>))))
     240          )
     241     (let loop ( (index 0) )
     242       (cond
     243        ((< index max+1)
     244         (vector-set! vec index (apply <proc> (map (lambda (g) (g)) generators)))
     245         (loop (add1 index))
     246         )
     247        (else vec)  ; done
     248        )  )
     249     ) )
     250
     251 (define (map-keys <proc> . <collections>)
     252   (let ( (max+1 (size (car <collections>)))
     253          (generators (map gen-keys <collections>))
     254          (vec (make-vector (size (car <collections>))))
     255          )
     256     (let loop ( (index 0) )
     257       (cond
     258        ((< index max+1)
     259         (vector-set! vec index (apply <proc> (map (lambda (g) (g)) generators)))
     260         (loop (add1 index))
     261         )
     262        (else vec)  ; done
     263        )  )
     264     ) )
     265
     266 (define (map-items <proc> . <collections>)
    182267   (let ( (max+1 (size (car <collections>)))
    183268          (key-generators (map gen-keys <collections>))
    184269          (elt-generators (map gen-elts <collections>))
    185         )
     270          (vec (make-vector (size (car <collections>))))
     271          )
     272     (let loop ( (index 0) )
     273       (cond
     274        ((< index max+1)
     275         (vector-set! vec index (apply <proc> (list-zip (map (lambda (g) (g)) key-generators)
     276                                                        (map (lambda (g) (g)) elt-generators))))
     277         (loop (add1 index))
     278         )
     279        (else vec)  ; done
     280        )  )
     281     ) )
     282
     283 (define-operation (for-each-key <collection> <proc>)
     284  ;; default
     285   (do-keys <proc> <collection>) ;; talk about lazy!
     286   )
     287
     288 (define-operation (for-each-elt <collection> <proc>)
     289   (do-elts <proc> <collection>)
     290   )
     291
     292 (define (reduce <proc> <seed> . <collections>)
     293   (let ( (max+1 (size (car <collections>)))
     294          (key-generators (map gen-keys <collections>))
     295          (elt-generators (map gen-elts <collections>))
     296          (ax (make-parameter <seed>))
     297          )
    186298     (let loop ( (count 0) )
    187299       (cond
    188           ((< count max+1)
    189            (set! <seed>
    190                  (apply <proc> <seed> (zip (map (lambda (g) (g)) key-generators)
    191                                            (map (lambda (g) (g)) elt-generators))))
    192            (loop (add1 count))
    193           )
    194           (else <seed>)
    195      ) )
    196 )  )
     300        ((< count max+1)
     301         (ax (apply <proc> (ax) (list-zip (map (lambda (g) (g)) key-generators)
     302                                          (map (lambda (g) (g)) elt-generators))))
     303         (loop (add1 count))
     304         )
     305        (else (ax))
     306        ) )
     307     )  )
     308 
     309;; reduce operation where the first element of the collection is the seed
     310
     311 (define (reduce* <proc> . <collections>)
     312   (let* ( (max+1 (size (car <collections>)))
     313           (key-generators (map gen-keys <collections>))
     314           (elt-generators (map gen-elts <collections>))
     315           (ax (make-parameter (list-zip (map (lambda (g) (g)) key-generators)
     316                                         (map (lambda (g) (g)) elt-generators))))
     317           )
     318     (let loop ( (count 0) )
     319       (cond
     320        ((< count max+1)
     321         (ax (apply <proc> (ax) (list-zip (map (lambda (g) (g)) key-generators)
     322                                          (map (lambda (g) (g)) elt-generators))))
     323         (loop (add1 count))
     324         )
     325        (else (ax))
     326        ) )
     327     )  )
    197328
    198329;; pred true for every elt?
    199 (define (every? <pred?> . <collections>)
     330 (define (every-elt? <pred?> . <collections>)
    200331   (let ( (max+1 (size (car <collections>)))
    201332          (generators (map gen-elts <collections>))
    202         )
     333          )
    203334     (let loop ( (count 0) )
    204335       (cond
    205           ((< count max+1)
    206            (if (apply <pred?> (map (lambda (g) (g)) generators))
    207                (loop (add1 count))
    208                #f)
    209           )
    210           (else #t)
    211      ) )
    212 )  )
     336        ((< count max+1)
     337         (if (apply <pred?> (map (lambda (g) (g)) generators))
     338             (loop (add1 count))
     339             #f)
     340         )
     341        (else #t)
     342        ) )
     343     )  )
    213344
    214345;; pred true for any elt?
    215 (define (any? <pred?> . <collections>)
     346 (define (any-elt? <pred?> . <collections>)
    216347   (let ( (max+1 (size (car <collections>)))
    217348          (generators (map gen-elts <collections>))
    218         )
     349          )
    219350     (let loop ( (count 0) )
    220351       (cond
    221           ((< count max+1)
    222            (if (apply <pred?> (map (lambda (g) (g)) generators))
    223                #t
    224                (loop (add1 count))
     352        ((< count max+1)
     353         (if (apply <pred?> (map (lambda (g) (g)) generators))
     354             #t
     355             (loop (add1 count))
     356             ))
     357        (else #f)
     358        ) )
     359     )  )
     360
     361
     362
     363
     364;; generator for list elements
     365 (define (list-gen-elts <list>)
     366   (let ((l (make-parameter <list>)))
     367     (lambda ()
     368       (if (null? (l))
     369           (error "no more list elements in generator")
     370           (let ( (elt (car (l))) )
     371             (l (cdr (l)))
     372             elt))
     373       ))
     374   )
     375
     376 (define (make-vec-gen-elts <accessor>)
     377   (lambda (vec)
     378     (let ( (max+1 (size vec))
     379            (index (make-parameter 0))
     380            )
     381       (lambda ()
     382         (let ((i (index)))
     383           (cond ((< i max+1)
     384                  (index (add1 i))
     385                  (<accessor> vec i)
     386                  )
     387                 (else #f)
     388                 ))
     389         ))
     390     ))
     391
     392 (define vector-gen-elts (make-vec-gen-elts vector-ref))
     393
     394 (define string-gen-elts (make-vec-gen-elts string-ref))
     395
     396 (define (hash-table-gen-elts table)
     397   (let ((keys (make-parameter (hash-table-keys table))))
     398     (lambda ()
     399       (cond ((null? keys) #f)
     400             (else (let ((res (hash-table-ref table (car (keys)))))
     401                     (keys (cdr (keys)))
     402                     res))
     403             ))
     404     ))
     405
     406 
     407 (define (zip-elts <collection> . <rest>)
     408   (let* (
     409          (<collections> (cons <collection> <rest>))
     410          (max+1 (- (size (car <collections>)) 1))
     411          (generators (map gen-elts <collections>))
     412          (result (make-vector (+ 1 max+1)))
     413          )
     414     (let loop ( (count 0) )
     415       (cond
     416        ((< count max+1)
     417         (vector-set! result count (map (lambda (g) (g)) generators))
     418         (loop (add1 count))
     419         )
     420        (else result)
     421        ))
     422     ))
     423
     424
     425
     426;; nota bene:  list-set! is bogus for element 0
     427
     428 (define (list-set! <list> <index> <value>)
     429
     430   (define (set-loop last this idx)
     431     (cond
     432      ((zero? idx)
     433       (set-cdr! last (cons <value> (cdr this)))
     434       <list>
     435       )
     436      (else (set-loop (cdr last) (cdr this) (sub1 idx)))
     437      )  )
     438
     439  ;; main
     440   (if (zero? <index>)
     441       (cons <value> (cdr <list>)) ;; return value
     442       (set-loop <list> (cdr <list>) (sub1 <index>)))
     443   )
     444
     445 
     446 ;;
     447 ;; In-place quick sort from SRFI-32 reference implementation.
     448 ;; Modified so that the comparison function uses element indices as
     449 ;; well as element values:
     450 ;;
     451 ;; elt< :: i1 v1 i2 v2 -> boolean
     452 ;;
     453 ;; Copyright (c) 1998 by Olin Shivers. You may do as you please with
     454 ;; this code, as long as you do not delete this notice or hold me
     455 ;; responsible for any outcome related to its use.
     456 ;;
     457 
     458 (define (sort! elt< v . rest)
     459   (let-optionals rest ((start 0) (end (size v)))
     460    (let recur ((l start) (r end))      ; Sort the range [l,r).
     461      (if (< 1 (- r l))
     462         
     463          ;; Choose the median of V[l], V[r], and V[middle] for the pivot.
     464          (let ((median
     465                 (lambda (i1 i2 i3)
     466                   (let ((v1 (elt-ref v i1))
     467                         (v2 (elt-ref v i2))
     468                         (v3 (elt-ref v i3)))
     469                     (receive (ilittle little ibig big)
     470                              (if (elt< i1 v1 i2 v2)
     471                                  (values i1 v1 i2 v2)
     472                                  (values i2 v2 i1 v1))
     473                              (if (elt< ibig big i3 v3)
     474                                  (values ibig big)
     475                                  (if (elt< ilittle little i3 v3)
     476                                      (values i3 v3)
     477                                      (values ilittle little))))))))
     478           
     479            (let-values (((ipivot pivot) (median l (quotient (+ l r) 2) (- r 1))))
     480              (let loop ((i l) (j (- r 1)))
     481                (let ((i (let scan ((i i)) (if (elt< i (elt-ref v i) ipivot pivot)
     482                                               (scan (+ i 1))
     483                                               i)))
     484                      (j (let scan ((j j)) (if (elt< ipivot pivot j (elt-ref v j))
     485                                               (scan (- j 1))
     486                                               j))))
     487                  (if (< i j)
     488                      (let ((tmp (elt-ref v j)))               
     489                        (elt-set! v j (elt-ref v i))    ; Swap V[I]
     490                        (elt-set! v i tmp)              ;  and V[J].
     491                        (loop (+ i 1) (- j 1)))
     492                     
     493                      (begin (recur l i) (recur (+ j 1) r)))))))
     494          v)
     495      ))
     496   )
     497
     498 ;; Blit FROM[I,END) to TO[J,?].
     499 
     500 (define (vector-blit! from i end to j)
     501    (assert (< i end))
     502    (let recur ((i i) (j j))
     503      (if (< i end)
     504          (let ((vi (elt-ref from i)))
     505            (vector-set! to j vi)
     506            (recur (+ i 1) (+ j 1)))
    225507          ))
    226           (else #f)
    227      ) )
    228 )  )
    229 
    230 
    231 
    232 ;; nota bene:  list-set! is bogus for element 0
    233 
    234 (define (list-set! <list> <index> <value>)
    235 
    236   (define (set-loop last this idx)
    237      (cond
    238         ((zero? idx)
    239          (set-cdr! last (cons <value> (cdr this)))
    240          <list>
    241         )
    242         (else (set-loop (cdr last) (cdr this) (sub1 idx)))
    243   )  )
    244 
    245   ;; main
    246   (if (zero? <index>)
    247       (cons <value> (cdr <list>))  ;; return value
    248       (set-loop <list> (cdr <list>) (sub1 <index>)))
    249 )
    250 
    251 
    252 ;; generator for list elements
    253 (define (list-gen-elts <list>)
    254   (lambda ()
    255      (if (null? <list>)
    256          (error "no more list elements in generator")
    257          (let ( (elt (car <list>)) )
    258            (set! <list> (cdr <list>))
    259            elt))
    260 ) )
    261 
    262 (define (make-vec-gen-elts <accessor>)
    263   (lambda (vec)
    264     (let ( (max+1 (size vec))
    265            (index 0)
    266          )
    267       (lambda ()
    268          (cond ((< index max+1)
    269                 (set! index (add1 index))
    270                 (<accessor> vec (sub1 index))
    271                )
    272                (else #f)
    273       )  )
    274   ) )
    275 )
    276 
    277 (define vector-gen-elts (make-vec-gen-elts vector-ref))
    278 
    279 (define string-gen-elts (make-vec-gen-elts string-ref))
    280 
    281 )
     508      )
     509
     510 
     511 ;; Given array A and indices p, q, r such that p < q < r,
     512 ;; merge subarray A[p..q) and subarray A[q..r) into array B[n..]
     513
     514(define (vector-merge! elt< a p q r b n)
     515    (assert (and (< p q) (< q r)))
     516    (let recur ((i p) (j q) (k n))
     517      (if (and (< i q) (< j r))
     518          (let ((ai (elt-ref a i))
     519                (aj (elt-ref a j)))
     520            (if (elt< i ai j aj)
     521                (begin
     522                  (vector-set! b k ai)
     523                  (recur (+ 1 i) j (+ 1 k)))
     524                (begin
     525                  (vector-set! b k aj)
     526                  (recur i (+ 1 j) (+ 1 k)))
     527                ))
     528          (if (< i q)
     529              (vector-blit! a i q b k)
     530              (if (< j r)
     531                  (vector-blit! a j r b k))))
     532      )
     533    b)
     534
     535 
     536 ;; Collection merge sort
     537 (define (sort elt< x)
     538   (let* ((n (size x))
     539          (a (make-vector n))
     540          (b (make-vector n)))
     541     (do-items (lambda (item) (vector-set! a (car item) (cadr item))) x)
     542      (let recur ((m 1))
     543        (if (< m n)
     544            (let inner-recur ((p 0))
     545              (if (< p (- n m))
     546                  (let ((q (+ p m))
     547                        (r (min (+ p (* 2 m)) n)))
     548                    (vector-merge! elt< a p q r b p)
     549                    (vector-blit! b p r a p)
     550                    (inner-recur (+ p (* 2 m)))
     551                    )
     552                  (recur (* m 2))))
     553            b))
     554      ))
     555           
     556
     557
     558 )
  • release/5/yasos/trunk/tests/run.scm

    r36339 r36370  
    331331    (test "map-keys" #(b a) (map-keys identity t))
    332332    (test "map-elts" #(2 1) (map-elts identity t))
    333     (test "reduce" 3 (reduce (lambda (ax item) (+ (cadr item) ax)) 0 t))
    334 
    335     )
     333    (test "reduce" 3 (reduce (lambda (ax item)
     334                               (+ (cadr item) ax)) 0 t))
     335    (test "sort!" #(1 2 3 4 5) (sort! (lambda (i vi j vj) (< vi vj))
     336                                      #( 5 2 4 3 1)))
     337    (test "sort" #(7 8 9 10 11) (sort (lambda (i vi j vj) (< vi vj))
     338                                    '( 11 8 10 7 9)))
     339   
     340    )
  • release/5/yasos/trunk/yasos.egg

    r36339 r36370  
    55 (category oop)
    66 (author "Kenneth Dickey")
    7  (dependencies )
     7 (dependencies srfi-69)
    88 (test-dependencies test)
    99 (components (extension yasos)
Note: See TracChangeset for help on using the changeset viewer.