Changeset 36391 in project


Ignore:
Timestamp:
08/25/18 10:11:15 (4 weeks ago)
Author:
iraikov
Message:

yasos: simplified collections operations and added several basic combinators for generator functions
statistics: completed conversion to yasos-collections interface

Location:
release/5
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/5/statistics/branches/collections/statistics.scm

    r36388 r36391  
    179179  (import scheme (chicken base) (chicken foreign) (chicken format)
    180180          (chicken keyword) (prefix (chicken sort) list.)
    181           (prefix (only srfi-1 fold iota filter find delete-duplicates every) list.)
     181          (prefix (only srfi-1 fold iota filter find delete-duplicates every first last) list.)
    182182          (only srfi-13 string<) srfi-25 srfi-69 vector-lib
    183183          yasos yasos-collections)
     
    273273  (define PI 3.1415926535897932385)
    274274
     275 
    275276  (define (position item sequence)
    276     (let ((index -1))
    277       (do-items-while (lambda (x)
    278                         (let ((res (equal? item (cadr x))))
    279                           (if res (set! index (car x)))
    280                           (not res)))
    281                       sequence)
    282       (if (> index -1)
    283         index
     277    (let ((found-item
     278           (g-find
     279            (lambda (x) (equal? item (cadr x)))
     280            (g-map list
     281                   (gen-keys sequence)
     282                   (gen-elts sequence)))))
     283      (if (not (eof-object? found-item))
     284        (car found-item)
    284285        (error "Position: item not in sequence"))))
     286
     287  (define (positions item sequence)
     288    (let ((found-items
     289           (g-filter
     290            (lambda (x) (equal? item (cadr x)))
     291            (g-map list
     292                   (gen-keys sequence)
     293                   (gen-elts sequence)))))
     294      (map car found-items)))
    285295
    286296  (define (array-shape arr)
     
    296306  ;; but lisp is 0 based, so add 1!
    297307  (define (average-rank value sorted-values)
    298     (let ((first (position value sorted-values))
    299           (last (- (- (length sorted-values) 1)
    300                    (position value (reverse sorted-values)))))
    301       (+ 1 (if (= first last)
    302              first
    303              (/ (+ first last) 2)))))
     308    (let* ((idxs (positions value sorted-values)))
     309      (let ((result (+ 1 (mean idxs))))
     310        result)))
    304311
    305312  ;; BIN-AND-COUNT
     
    320327                         bin
    321328                         (reduce
    322                           (lambda (ax x)
     329                          (lambda (x ax)
    323330                            (if (and (>= x (+ smallest (* bin increment)))
    324331                                     (< x  (+ smallest (* (+ 1 bin) increment))))
     
    404411    (if (empty? sequence)
    405412        0
    406         (reverse (reduce* (lambda (ax x) (cons (+ x (car ax)) ax))
    407                           sequence))))
     413        (let ((g (gen-elts sequence)))
     414          (reverse (g-reduce (lambda (x ax) (cons (+ x (car ax)) ax))
     415                             (list (g)) g))
     416          )
     417        ))
    408418
    409419  (define (sign x)
     
    462472            (else
    463473             (let* ((keys (map-elts (lambda (w) (expt (random-uniform) (/ 1 w))) weights))
    464                     (sorted-items (sort (lambda (x y) (> (car (cadr x)) (car (cadr y))))
    465                                         (zip-elts keys sequence))))
     474                    (sorted-items (sort (lambda (x y) (> (car x) (car y)))
     475                                        (g-map list (gen-elts keys) (gen-elts sequence)))))
    466476               (elt-take sorted-items m))
    467477             ))
     
    489499  (define (mode sequence)
    490500    (if (empty? sequence)
    491       (error "Mode: Sequence must not be null")
     501      (error "Mode: Sequence must not be empty")
    492502      (let ((count-table (make-hash-table eqv?))
    493503            (modes (make-parameter '()))
    494504            (mode-count (make-parameter 0)))
    495505        (for-each-elt
    496          (lambda (item) 
     506         (lambda (item)
    497507           (hash-table-set! count-table
    498508                            item
    499                             (+ 1 (hash-table-ref count-table item (lambda () 0)))))
     509                            (+ 1 (hash-table-ref/default count-table item  0))))
    500510         sequence)
    501511        (for-each
    502512         (lambda (key)
    503            (let ((val (hash-table-ref count-table key (lambda () #f))))
     513           (let ((val (hash-table-ref/default count-table key #f)))
    504514             (cond ((> val (mode-count)) ; keep mode
    505515                    (modes (list key))
     
    570580  (define (standard-error-of-the-mean sequence)
    571581    (/ (standard-deviation sequence)
    572        (sqrt (length sequence))))
     582       (sqrt (size sequence))))
    573583
    574584  ;; MEAN-SD-N
     
    578588    (values (mean sequence)
    579589            (standard-deviation sequence)
    580             (length sequence)))
     590            (size sequence)))
    581591
    582592  ;; ---------------------------------------------------------------------------
     
    796806  (define (normal-variance-ci-on-sequence sequence alpha)
    797807    (let ((variance (variance sequence))
    798           (n (length sequence)))
     808          (n (size sequence)))
    799809      (normal-variance-ci variance n alpha)))
    800810
     
    809819  (define (normal-sd-ci-on-sequence sequence alpha)
    810820    (let ((sd (standard-deviation sequence))
    811           (n (length sequence)))
     821          (n (size sequence)))
    812822      (normal-sd-ci sd n alpha)))
    813823
     
    846856          (tails (get-keyword #:tails args (lambda () ':both))))
    847857      (let ((x-bar (mean sequence))
    848             (n (length sequence)))
     858            (n (size sequence)))
    849859        (z-test x-bar n #:mu mu #:sigma sigma #:tails tails))))
    850860
     
    11451155          (tails (get-keyword #:tails args (lambda () ':both))))
    11461156      (let* ((differences (map-elts - sequence1 sequence2))
    1147              (plus-count (reduce (lambda (ax x) (if (positive? x) (+ 1 ax) ax)) 0 differences))
    1148              (minus-count (reduce (lambda (ax x) (if (negative? x) (+ 1 ax) ax)) 0 differences)))
     1157             (plus-count (reduce (lambda (x ax) (if (positive? x) (+ 1 ax) ax)) 0 differences))
     1158             (minus-count (reduce (lambda (x ax) (if (negative? x) (+ 1 ax) ax)) 0 differences)))
    11491159        (sign-test plus-count minus-count :exact? exact :tails tails))))
    11501160
     
    14661476             (y-bar (mean ys))
    14671477             (n (size points))
    1468              (Lxx (reduce + 0
    1469                         (map (lambda (xi) (square (- xi x-bar))) xs)))
    1470              (Lyy (reduce + 0
    1471                         (map (lambda (yi) (square (- yi y-bar))) ys)))
    1472              (Lxy (reduce + 0
     1478             (Lxx (reduce + 0.0
     1479                        (map-elts (lambda (xi) (square (- xi x-bar))) xs)))
     1480             (Lyy (reduce + 0.0
     1481                        (map-elts (lambda (yi) (square (- yi y-bar))) ys)))
     1482             (Lxy (reduce + 0.0
    14731483                          (map-elts (lambda (point) (let ((xi (car point))
    1474                                                           (yi (car point)))
     1484                                                          (yi (cadr point)))
    14751485                                                      (* (- xi x-bar) (- yi y-bar))))
    14761486                             points)))
     
    15421552             (sorted-xis (sort (lambda (xi x yi y) (< x y)) xis))
    15431553             (sorted-yis (sort (lambda (xi x yi y) (< x y))  yis))
    1544              (average-x-ranks (map (lambda (x) (average-rank x sorted-xis)) xis))
    1545              (average-y-ranks (map (lambda (y) (average-rank y sorted-yis)) yis))
     1554             (average-x-ranks (map-elts (lambda (x) (average-rank x sorted-xis)) xis))
     1555             (average-y-ranks (map-elts (lambda (y) (average-rank y sorted-yis)) yis))
    15461556             (mean-x-rank (mean average-x-ranks))
    15471557             (mean-y-rank (mean average-y-ranks))
  • release/5/statistics/trunk/statistics.scm

    r36303 r36391  
    289289             first
    290290             (/ (+ first last) 2)))))
     291  (define (average-rank value sorted-values)
     292    (let ((first (position value sorted-values))
     293          (last (- (- (length sorted-values) 1)
     294                   (position value (reverse sorted-values)))))
     295      (let ((result (+ 1 (if (= first last)
     296                             first
     297                             (/ (+ first last) 2)))))
     298        (print "average-rank: value = " value " first = "  first " last = " last " result = " result)
     299        result)))
    291300
    292301  ;; BIN-AND-COUNT
  • release/5/yasos/trunk/collections.scm

    r36388 r36391  
    33
    44 (collection? random-access? empty? size gen-keys gen-elts
    5               do-elts do-keys do-items do-items-while
     5              do-elts do-keys do-items
    66              map-elts map-keys map-items
    77              for-each-key for-each-elt elt-ref elt-set! elt-take elt-drop
    8               reduce reduce* reduce-items reduce-items* 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
     8              reduce reduce* reduce-items reduce-items* sort! sort
     9              make-vector-generator list->generator vector->generator
     10              string->generator hash-table->generator
     11              g-map g-reduce g-find g-filter
    1112              )
    1213 
    13  (import scheme (chicken base) (chicken format) srfi-69
     14 (import scheme (chicken base) (chicken format) srfi-69 
    1415         (except yasos object object-with-ancestors))
    1516
     
    1819
    1920;; (collection? obj)  -- predicate
     21;;
     22;; (empty? collection)  -- I bet you can guess what these do as well...
     23;; (size collection)
    2024;;
    2125;; (do-elts proc coll+) -- apply proc element-wise to collections
     
    3034;;
    3135;; (reduce proc seed coll+) -- e.g. (reduce + 0 (vector 1 2 3))
    32 ;; (any?   predicate coll+) -- e.g. (any? odd? (list 2 3 4 5))
    33 ;; (every? predicate coll+) -- e.g. (every? collection collections)
    34 ;;
    35 ;; (empty? collection)  -- I bet you can guess what these do as well...
    36 ;; (size collection)
    3736;;
    3837;;==============================
     
    5554;; elt-drop
    5655;;
    57 ;;==============================
     56 ;;==============================
     57 
     58 (define *eof-object* (read (open-input-string "")))
     59 (define (eof-object) *eof-object*)
     60
     61 (define (list-any pred lis)
     62   (and (not (null? lis))
     63        (let lp ((head (car lis)) (tail (cdr lis)))
     64          (if (null? tail)
     65              (pred head)               ; Last PRED app is tail call.
     66              (or (pred head) (lp (car tail) (cdr tail)))))))
    5867
    5968 (define (list-zip list1 . more-lists) (apply map list list1 more-lists))
     
    144153    ))
    145154
    146  (define-operation (gen-elts <collection>);; return element generator
     155 (define-operation (gen-elts <collection>);; return SRFI-121 element generator
    147156  ;; default behavior
    148    (cond                     ;; see utilities, below, for generators
    149     ((vector? <collection>) (vector-gen-elts <collection>))
    150     ((list?   <collection>) (list-gen-elts   <collection>))
    151     ((string? <collection>) (string-gen-elts <collection>))
    152     ((hash-table? <collection>) (hash-table-gen-elts <collection>))
     157   (cond                     
     158    ((vector? <collection>) (vector->generator <collection>))
     159    ((list?   <collection>) (list->generator   <collection>))
     160    ((string? <collection>) (string->generator <collection>))
     161    ((hash-table? <collection>) (hash-table->generator <collection>))
    153162    (else
    154163     (error "operation not supported: gen-elts "))
     
    166175             (index (add1 i))
    167176             i)
    168             (else (error "no more keys in generator"))
     177            (else (eof-object))
    169178            ))
    170179         ))
    171180     )
    172181    ((hash-table? collection)
    173      (list-gen-elts (hash-table-keys collection)))
     182     (list->generator (hash-table-keys collection)))
    174183    (else
    175184     (error "operation not handled: gen-keys " collection))
     
    218227        )  )
    219228     ) )
    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      ))
    235229
    236230 (define (map-elts <proc> . <collections>)
     
    281275     ) )
    282276
    283  (define-operation (for-each-key <collection> <proc>)
     277 (define-operation (for-each-key <proc> <collection>)
    284278  ;; default
    285279   (do-keys <proc> <collection>) ;; talk about lazy!
    286280   )
    287281
    288  (define-operation (for-each-elt <collection> <proc>)
     282 (define-operation (for-each-elt <proc> <collection>)
    289283   (do-elts <proc> <collection>)
    290284   )
     
    298292       (cond
    299293        ((< count max+1)
    300          (ax (apply <proc> (cons (ax) (map (lambda (g) (g)) elt-generators))))
     294         (ax (apply <proc> (append (map (lambda (g) (g)) elt-generators) (list (ax)))))
    301295         (loop (add1 count))
    302296         )
     
    315309       (cond
    316310        ((< count max+1)
    317          (ax (apply <proc> (cons (ax) (list-zip (map (lambda (g) (g)) key-generators)
    318                                                   (map (lambda (g) (g)) elt-generators)))))
     311         (ax (apply <proc> (append (list-zip (map (lambda (g) (g)) key-generators)
     312                                             (map (lambda (g) (g)) elt-generators))
     313                                   (list (ax)))))
    319314         (loop (add1 count))
    320315         )
     
    333328       (cond
    334329        ((< count max+1)
    335          (ax (apply <proc> (append (ax) (map (lambda (g) (g)) elt-generators))))
     330         (let ((args (append (map (lambda (g) (g)) elt-generators) (ax))))
     331           (ax (list (apply <proc> args))))
    336332         (loop (add1 count))
    337333         )
    338         (else (ax))
     334        (else (car (ax)))
    339335        ) )
    340336     )  )
     
    350346       (cond
    351347        ((< count max+1)
    352          (ax (apply <proc> (append (ax) (list-zip (map (lambda (g) (g)) key-generators)
    353                                                   (map (lambda (g) (g)) elt-generators)))))
     348         (ax (list (apply <proc> (append (list-zip (map (lambda (g) (g)) key-generators)
     349                                                   (map (lambda (g) (g)) elt-generators))
     350                                         (ax)))))
    354351         (loop (add1 count))
    355352         )
    356         (else (ax))
     353        (else (car (ax)))
    357354        ) )
    358355     )  )
    359356
    360 ;; pred true for every elt?
    361  (define (every-elt? <pred?> . <collections>)
    362    (let ( (max+1 (size (car <collections>)))
    363           (generators (map gen-elts <collections>))
    364           )
    365      (let loop ( (count 0) )
    366        (cond
    367         ((< count max+1)
    368          (if (apply <pred?> (map (lambda (g) (g)) generators))
    369              (loop (add1 count))
    370              #f)
    371          )
    372         (else #t)
    373         ) )
    374      )  )
    375 
    376 ;; pred true for any elt?
    377  (define (any-elt? <pred?> . <collections>)
    378    (let ( (max+1 (size (car <collections>)))
    379           (generators (map gen-elts <collections>))
    380           )
    381      (let loop ( (count 0) )
    382        (cond
    383         ((< count max+1)
    384          (if (apply <pred?> (map (lambda (g) (g)) generators))
    385              #t
    386              (loop (add1 count))
    387              ))
    388         (else #f)
    389         ) )
    390      )  )
    391 
    392 
    393 
    394 
     357 
    395358;; generator for list elements
    396  (define (list-gen-elts <list>)
     359 (define (list->generator <list>)
    397360   (let ((l (make-parameter <list>)))
    398361     (lambda ()
    399362       (if (null? (l))
    400            (error "no more list elements in generator")
     363           (eof-object)
    401364           (let ( (elt (car (l))) )
    402365             (l (cdr (l)))
     
    405368   )
    406369
    407  (define (make-vec-gen-elts <accessor>)
     370 (define (make-vector-generator <accessor>)
    408371   (lambda (vec)
    409372     (let ( (max+1 (size vec))
     
    416379                  (<accessor> vec i)
    417380                  )
    418                  (else #f)
     381                 (else (eof-object))
    419382                 ))
    420383         ))
    421384     ))
    422385
    423  (define vector-gen-elts (make-vec-gen-elts vector-ref))
    424 
    425  (define string-gen-elts (make-vec-gen-elts string-ref))
    426 
    427  (define (hash-table-gen-elts table)
     386 (define vector->generator (make-vector-generator vector-ref))
     387
     388 (define string->generator (make-vector-generator string-ref))
     389
     390 (define (hash-table->generator table)
    428391   (let ((keys (make-parameter (hash-table-keys table))))
    429392     (lambda ()
    430        (cond ((null? keys) #f)
     393       (cond ((null? keys) (eof-object))
    431394             (else (let ((res (hash-table-ref table (car (keys)))))
    432395                     (keys (cdr (keys)))
     
    434397             ))
    435398     ))
    436 
    437  
    438  (define (zip-elts <collection> . <rest>)
    439    (let* (
    440           (<collections> (cons <collection> <rest>))
    441           (max+1 (- (size (car <collections>)) 1))
    442           (generators (map gen-elts <collections>))
    443           (result (make-vector (+ 1 max+1)))
    444           )
    445      (let loop ( (count 0) )
    446        (cond
    447         ((< count max+1)
    448          (vector-set! result count (map (lambda (g) (g)) generators))
    449          (loop (add1 count))
    450          )
    451         (else result)
    452         ))
    453      ))
    454 
    455399
    456400
     
    568512 (define (sort elt< x)
    569513   (let* ((n (size x))
    570           (a (make-vector n))
    571           (b (make-vector n)))
     514          (a (make-vector n)))
    572515     (do-items (lambda (item) (vector-set! a (car item) (cadr item))) x)
    573      (let recur ((m 1))
    574        (if (< m n)
    575            (let inner-recur ((p 0))
    576              (if (< p (- n m))
    577                  (let ((q (+ p m))
    578                        (r (min (+ p (* 2 m)) n)))
    579                    (vector-merge! elt< a p q r b p)
    580                    (vector-blit! b p r a p)
    581                    (inner-recur (+ p (* 2 m)))
    582                    )
    583                  (recur (* m 2))))
    584            b))
     516     (if (< n 2)
     517         a
     518         (let ((b (make-vector n)))
     519           (let recur ((m 1))
     520             (if (< m n)
     521                 (let inner-recur ((p 0))
     522                   (if (< p (- n m))
     523                       (let ((q (+ p m))
     524                             (r (min (+ p (* 2 m)) n)))
     525                         (vector-merge! elt< a p q r b p)
     526                         (vector-blit! b p r a p)
     527                         (inner-recur (+ p (* 2 m)))
     528                         )
     529                       (recur (* m 2))))
     530                 b))
     531           ))
    585532     ))
    586533           
    587534
     535  ;; Generator combinators
     536  (define (g-map f . gs)
     537    (lambda ()
     538      (let ((vs (map (lambda (g) (g)) gs)))
     539        (if (list-any eof-object? vs)
     540            (eof-object)
     541            (apply f vs))
     542        ))
     543    )
     544
     545
     546  (define (g-reduce f seed . gs)
     547    (define (inner-fold seed)
     548      (let ((vs (map (lambda (g) (g)) gs)))
     549        (if (list-any eof-object? vs)
     550            seed
     551            (inner-fold (apply f (append vs (list seed)))))))
     552    (inner-fold seed))
     553
     554
     555  (define (g-find pred g)
     556    (let loop ((v (g)))
     557      (if (or (pred v) (eof-object? v))
     558          v
     559          (loop (g)))
     560      ))
     561
     562  (define (g-filter pred g)
     563    (let loop ((v (g)) (res '()))
     564      (cond ((eof-object? v) res)
     565            ((pred v) (loop (g) (cons v res)))
     566            (else (loop (g) res)))
     567      ))
     568
    588569
    589570 )
  • release/5/yasos/trunk/tests/run.scm

    r36387 r36391  
    306306      ;; collection behaviors
    307307      ((collection? self) #t)
    308       ((gen-keys self) (list-gen-elts (map car table)))
    309       ((gen-elts self) (list-gen-elts (map cdr table)))
     308      ((gen-keys self) (list->generator (map car table)))
     309      ((gen-elts self) (list->generator (map cdr table)))
    310310      ((for-each-key self proc)
    311311       (for-each (lambda (bucket) (proc (car bucket))) table)
     
    320320(test-group "collections"
    321321
     322    (for-each-elt
     323         (lambda (item)
     324           (print "item: " item))
     325         '(1 2 3))
    322326    (test-assert (collection? t))
    323327    (test-assert (empty? t))
     
    332336    (test "map-elts" #(2 1) (map-elts identity t))
    333337    (test "reduce" 3 (reduce + 0 t))
    334     (test "reduce-items" 3 (reduce-items (lambda (ax item)
     338    (test "reduce-items" 3 (reduce-items (lambda (item ax)
    335339                                           (+ (cadr item) ax)) 0 t))
     340    (test "reduce*" 1 (reduce* min '(1 2 3 4 10 5 6 8 7 9)))
    336341    (test "sort!" #(1 2 3 4 5) (sort! (lambda (i vi j vj) (< vi vj))
    337342                                      #( 5 2 4 3 1)))
Note: See TracChangeset for help on using the changeset viewer.