Changeset 36391 in project

Timestamp:

08/25/18 10:11:15 (11 months 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:

• statistics/branches/collections/statistics.scm (modified) (15 diffs)
• statistics/trunk/statistics.scm (modified) (1 diff)
• yasos/trunk/collections.scm (modified) (16 diffs)
• yasos/trunk/tests/run.scm (modified) (3 diffs)

release/5/statistics/branches/collections/statistics.scm

@@ -179 +179 @@
   (import scheme (chicken base) (chicken foreign) (chicken format)
           (chicken keyword) (prefix (chicken sort) list.)
-          (prefix (only srfi-1 fold iota filter find delete-duplicates every) list.)
+          (prefix (only srfi-1 fold iota filter find delete-duplicates every first last) list.)
           (only srfi-13 string<) srfi-25 srfi-69 vector-lib
           yasos yasos-collections)
@@ -273 +273 @@
   (define PI 3.1415926535897932385)
 
+  
   (define (position item sequence)
-    (let ((index -1))
-      (do-items-while (lambda (x)
-                        (let ((res (equal? item (cadr x))))
-                          (if res (set! index (car x)))
-                          (not res)))
-                      sequence)
-      (if (> index -1)
-        index
+    (let ((found-item 
+           (g-find
+            (lambda (x) (equal? item (cadr x)))
+            (g-map list 
+                   (gen-keys sequence)
+                   (gen-elts sequence)))))
+      (if (not (eof-object? found-item))
+        (car found-item)
         (error "Position: item not in sequence"))))
+
+  (define (positions item sequence)
+    (let ((found-items
+           (g-filter
+            (lambda (x) (equal? item (cadr x)))
+            (g-map list 
+                   (gen-keys sequence)
+                   (gen-elts sequence)))))
+      (map car found-items)))
 
   (define (array-shape arr)
@@ -296 +306 @@
   ;; but lisp is 0 based, so add 1!
   (define (average-rank value sorted-values)
-    (let ((first (position value sorted-values))
-          (last (- (- (length sorted-values) 1)
-                   (position value (reverse sorted-values)))))
-      (+ 1 (if (= first last)
-             first
-             (/ (+ first last) 2)))))
+    (let* ((idxs (positions value sorted-values)))
+      (let ((result (+ 1 (mean idxs))))
+        result)))
 
   ;; BIN-AND-COUNT
@@ -320 +327 @@
                          bin
                          (reduce 
-                          (lambda (ax x)
+                          (lambda (x ax)
                             (if (and (>= x (+ smallest (* bin increment)))
                                      (< x  (+ smallest (* (+ 1 bin) increment))))
@@ -404 +411 @@
     (if (empty? sequence)
         0
-        (reverse (reduce* (lambda (ax x) (cons (+ x (car ax)) ax))
-                          sequence))))
+        (let ((g (gen-elts sequence)))
+          (reverse (g-reduce (lambda (x ax) (cons (+ x (car ax)) ax))
+                             (list (g)) g))
+          )
+        ))
 
   (define (sign x)
@@ -462 +472 @@
             (else
              (let* ((keys (map-elts (lambda (w) (expt (random-uniform) (/ 1 w))) weights))
-                    (sorted-items (sort (lambda (x y) (> (car (cadr x)) (car (cadr y))))
-                                        (zip-elts keys sequence))))
+                    (sorted-items (sort (lambda (x y) (> (car x) (car y)))
+                                        (g-map list (gen-elts keys) (gen-elts sequence)))))
                (elt-take sorted-items m))
              ))
@@ -489 +499 @@
   (define (mode sequence)
     (if (empty? sequence)
-      (error "Mode: Sequence must not be null")
+      (error "Mode: Sequence must not be empty")
       (let ((count-table (make-hash-table eqv?))
             (modes (make-parameter '()))
             (mode-count (make-parameter 0)))
         (for-each-elt
-         (lambda (item) 
+         (lambda (item)
            (hash-table-set! count-table
                             item
-                            (+ 1 (hash-table-ref count-table item (lambda () 0)))))
+                            (+ 1 (hash-table-ref/default count-table item  0))))
          sequence)
         (for-each
          (lambda (key) 
-           (let ((val (hash-table-ref count-table key (lambda () #f))))
+           (let ((val (hash-table-ref/default count-table key #f)))
              (cond ((> val (mode-count)) ; keep mode
                     (modes (list key))
@@ -570 +580 @@
   (define (standard-error-of-the-mean sequence)
     (/ (standard-deviation sequence)
-       (sqrt (length sequence))))
+       (sqrt (size sequence))))
 
   ;; MEAN-SD-N
@@ -578 +588 @@
     (values (mean sequence)
             (standard-deviation sequence)
-            (length sequence)))
+            (size sequence)))
 
   ;; ---------------------------------------------------------------------------
@@ -796 +806 @@
   (define (normal-variance-ci-on-sequence sequence alpha)
     (let ((variance (variance sequence))
-          (n (length sequence)))
+          (n (size sequence)))
       (normal-variance-ci variance n alpha)))
 
@@ -809 +819 @@
   (define (normal-sd-ci-on-sequence sequence alpha)
     (let ((sd (standard-deviation sequence))
-          (n (length sequence)))
+          (n (size sequence)))
       (normal-sd-ci sd n alpha)))
 
@@ -846 +856 @@
           (tails (get-keyword #:tails args (lambda () ':both))))
       (let ((x-bar (mean sequence))
-            (n (length sequence)))
+            (n (size sequence)))
         (z-test x-bar n #:mu mu #:sigma sigma #:tails tails))))
 
@@ -1145 +1155 @@
           (tails (get-keyword #:tails args (lambda () ':both))))
       (let* ((differences (map-elts - sequence1 sequence2))
-             (plus-count (reduce (lambda (ax x) (if (positive? x) (+ 1 ax) ax)) 0 differences))
-             (minus-count (reduce (lambda (ax x) (if (negative? x) (+ 1 ax) ax)) 0 differences)))
+             (plus-count (reduce (lambda (x ax) (if (positive? x) (+ 1 ax) ax)) 0 differences))
+             (minus-count (reduce (lambda (x ax) (if (negative? x) (+ 1 ax) ax)) 0 differences)))
         (sign-test plus-count minus-count :exact? exact :tails tails))))
 
@@ -1466 +1476 @@
              (y-bar (mean ys))
              (n (size points))
-             (Lxx (reduce + 0
-                        (map (lambda (xi) (square (- xi x-bar))) xs)))
-             (Lyy (reduce + 0
-                        (map (lambda (yi) (square (- yi y-bar))) ys)))
-             (Lxy (reduce + 0
+             (Lxx (reduce + 0.0
+                        (map-elts (lambda (xi) (square (- xi x-bar))) xs)))
+             (Lyy (reduce + 0.0
+                        (map-elts (lambda (yi) (square (- yi y-bar))) ys)))
+             (Lxy (reduce + 0.0
                           (map-elts (lambda (point) (let ((xi (car point))
-                                                          (yi (car point)))
+                                                          (yi (cadr point)))
                                                       (* (- xi x-bar) (- yi y-bar))))
                              points)))
@@ -1542 +1552 @@
              (sorted-xis (sort (lambda (xi x yi y) (< x y)) xis))
              (sorted-yis (sort (lambda (xi x yi y) (< x y))  yis))
-             (average-x-ranks (map (lambda (x) (average-rank x sorted-xis)) xis))
-             (average-y-ranks (map (lambda (y) (average-rank y sorted-yis)) yis))
+             (average-x-ranks (map-elts (lambda (x) (average-rank x sorted-xis)) xis))
+             (average-y-ranks (map-elts (lambda (y) (average-rank y sorted-yis)) yis))
              (mean-x-rank (mean average-x-ranks))
              (mean-y-rank (mean average-y-ranks))

release/5/statistics/trunk/statistics.scm

@@ -289 +289 @@
              first
              (/ (+ first last) 2)))))
+  (define (average-rank value sorted-values)
+    (let ((first (position value sorted-values))
+          (last (- (- (length sorted-values) 1)
+                   (position value (reverse sorted-values)))))
+      (let ((result (+ 1 (if (= first last)
+                             first
+                             (/ (+ first last) 2)))))
+        (print "average-rank: value = " value " first = "  first " last = " last " result = " result)
+        result)))
 
   ;; BIN-AND-COUNT

release/5/yasos/trunk/collections.scm

@@ -3 +3 @@
 
  (collection? random-access? empty? size gen-keys gen-elts 
-              do-elts do-keys do-items do-items-while
+              do-elts do-keys do-items 
               map-elts map-keys map-items
               for-each-key for-each-elt elt-ref elt-set! elt-take elt-drop
-              reduce reduce* reduce-items reduce-items* any-elt? every-elt? zip-elts sort! sort
-              make-vec-gen-elts list-gen-elts vector-gen-elts
-              string-gen-elts hash-table-gen-elts
+              reduce reduce* reduce-items reduce-items* sort! sort
+              make-vector-generator list->generator vector->generator
+              string->generator hash-table->generator
+              g-map g-reduce g-find g-filter
               )
  
- (import scheme (chicken base) (chicken format) srfi-69
+ (import scheme (chicken base) (chicken format) srfi-69 
          (except yasos object object-with-ancestors))
 
@@ -18 +19 @@
 
 ;; (collection? obj)  -- predicate
+;;
+;; (empty? collection)  -- I bet you can guess what these do as well...
+;; (size collection)
 ;;
 ;; (do-elts proc coll+) -- apply proc element-wise to collections
@@ -30 +34 @@
 ;;
 ;; (reduce proc seed coll+) -- e.g. (reduce + 0 (vector 1 2 3))
-;; (any?   predicate coll+) -- e.g. (any? odd? (list 2 3 4 5))
-;; (every? predicate coll+) -- e.g. (every? collection collections)
-;;
-;; (empty? collection)  -- I bet you can guess what these do as well...
-;; (size collection)
 ;;
 ;;==============================
@@ -55 +54 @@
 ;; elt-drop
 ;;
-;;==============================
+ ;;==============================
+ 
+ (define *eof-object* (read (open-input-string "")))
+ (define (eof-object) *eof-object*)
+
+ (define (list-any pred lis)
+   (and (not (null? lis))
+        (let lp ((head (car lis)) (tail (cdr lis)))
+          (if (null? tail)
+              (pred head)               ; Last PRED app is tail call.
+              (or (pred head) (lp (car tail) (cdr tail)))))))
 
  (define (list-zip list1 . more-lists) (apply map list list1 more-lists))
@@ -144 +153 @@
     ))
 
- (define-operation (gen-elts <collection>);; return element generator
+ (define-operation (gen-elts <collection>);; return SRFI-121 element generator
   ;; default behavior
-   (cond                     ;; see utilities, below, for generators
-    ((vector? <collection>) (vector-gen-elts <collection>)) 
-    ((list?   <collection>) (list-gen-elts   <collection>))
-    ((string? <collection>) (string-gen-elts <collection>))
-    ((hash-table? <collection>) (hash-table-gen-elts <collection>))
+   (cond                     
+    ((vector? <collection>) (vector->generator <collection>)) 
+    ((list?   <collection>) (list->generator   <collection>))
+    ((string? <collection>) (string->generator <collection>))
+    ((hash-table? <collection>) (hash-table->generator <collection>))
     (else 
      (error "operation not supported: gen-elts "))
@@ -166 +175 @@
              (index (add1 i))
              i)
-            (else (error "no more keys in generator"))
+            (else (eof-object))
             ))
          ))
      )
     ((hash-table? collection)
-     (list-gen-elts (hash-table-keys collection)))
+     (list->generator (hash-table-keys collection)))
     (else
      (error "operation not handled: gen-keys " collection))
@@ -218 +227 @@
         )  )
      ) )
-  
- (define (do-items-while <proc> . <collections>)
-   (let ( (max+1 (size (car <collections>)))
-          (elt-generators (map gen-elts <collections>))
-          (key-generators (map gen-keys <collections>)) )
-     (let loop ( (counter 0) )
-       (cond
-        ((< counter max+1)
-         (let ((res (apply <proc> (list-zip (map (lambda (g) (g)) key-generators)
-                                            (map (lambda (g) (g)) elt-generators)))))
-           (if res (loop (add1 counter)))
-           ))
-        (else 'unspecific)  ; done
-        ))
-     ))
 
  (define (map-elts <proc> . <collections>)
@@ -281 +275 @@
      ) )
 
- (define-operation (for-each-key <collection> <proc>)
+ (define-operation (for-each-key <proc> <collection>)
   ;; default
    (do-keys <proc> <collection>) ;; talk about lazy!
    )
 
- (define-operation (for-each-elt <collection> <proc>)
+ (define-operation (for-each-elt <proc> <collection>)
    (do-elts <proc> <collection>)
    )
@@ -298 +292 @@
        (cond
         ((< count max+1)
-         (ax (apply <proc> (cons (ax) (map (lambda (g) (g)) elt-generators))))
+         (ax (apply <proc> (append (map (lambda (g) (g)) elt-generators) (list (ax)))))
          (loop (add1 count))
          )
@@ -315 +309 @@
        (cond
         ((< count max+1)
-         (ax (apply <proc> (cons (ax) (list-zip (map (lambda (g) (g)) key-generators)
-                                                  (map (lambda (g) (g)) elt-generators)))))
+         (ax (apply <proc> (append (list-zip (map (lambda (g) (g)) key-generators)
+                                             (map (lambda (g) (g)) elt-generators))
+                                   (list (ax)))))
          (loop (add1 count))
          )
@@ -333 +328 @@
        (cond
         ((< count max+1)
-         (ax (apply <proc> (append (ax) (map (lambda (g) (g)) elt-generators))))
+         (let ((args (append (map (lambda (g) (g)) elt-generators) (ax))))
+           (ax (list (apply <proc> args))))
          (loop (add1 count))
          )
-        (else (ax))
+        (else (car (ax)))
         ) )
      )  )
@@ -350 +346 @@
        (cond
         ((< count max+1)
-         (ax (apply <proc> (append (ax) (list-zip (map (lambda (g) (g)) key-generators)
-                                                  (map (lambda (g) (g)) elt-generators)))))
+         (ax (list (apply <proc> (append (list-zip (map (lambda (g) (g)) key-generators)
+                                                   (map (lambda (g) (g)) elt-generators))
+                                         (ax)))))
          (loop (add1 count))
          )
-        (else (ax))
+        (else (car (ax)))
         ) )
      )  )
 
-;; pred true for every elt?
- (define (every-elt? <pred?> . <collections>)
-   (let ( (max+1 (size (car <collections>)))
-          (generators (map gen-elts <collections>))
-          )
-     (let loop ( (count 0) )
-       (cond
-        ((< count max+1)
-         (if (apply <pred?> (map (lambda (g) (g)) generators))
-             (loop (add1 count))
-             #f)
-         )
-        (else #t)
-        ) )
-     )  )
-
-;; pred true for any elt?
- (define (any-elt? <pred?> . <collections>)
-   (let ( (max+1 (size (car <collections>)))
-          (generators (map gen-elts <collections>))
-          )
-     (let loop ( (count 0) )
-       (cond
-        ((< count max+1)
-         (if (apply <pred?> (map (lambda (g) (g)) generators))
-             #t
-             (loop (add1 count))
-             ))
-        (else #f)
-        ) )
-     )  )
-
-
-
-
+ 
 ;; generator for list elements
- (define (list-gen-elts <list>)
+ (define (list->generator <list>)
    (let ((l (make-parameter <list>)))
      (lambda ()
        (if (null? (l))
-           (error "no more list elements in generator")
+           (eof-object)
            (let ( (elt (car (l))) )
              (l (cdr (l)))
@@ -405 +368 @@
    )
 
- (define (make-vec-gen-elts <accessor>)
+ (define (make-vector-generator <accessor>)
    (lambda (vec)
      (let ( (max+1 (size vec))
@@ -416 +379 @@
                   (<accessor> vec i)
                   )
-                 (else #f)
+                 (else (eof-object))
                  ))
          ))
      ))
 
- (define vector-gen-elts (make-vec-gen-elts vector-ref))
-
- (define string-gen-elts (make-vec-gen-elts string-ref))
-
- (define (hash-table-gen-elts table)
+ (define vector->generator (make-vector-generator vector-ref))
+
+ (define string->generator (make-vector-generator string-ref))
+
+ (define (hash-table->generator table)
    (let ((keys (make-parameter (hash-table-keys table))))
      (lambda () 
-       (cond ((null? keys) #f)
+       (cond ((null? keys) (eof-object))
              (else (let ((res (hash-table-ref table (car (keys)))))
                      (keys (cdr (keys)))
@@ -434 +397 @@
              ))
      ))
-
- 
- (define (zip-elts <collection> . <rest>)
-   (let* (
-          (<collections> (cons <collection> <rest>))
-          (max+1 (- (size (car <collections>)) 1))
-          (generators (map gen-elts <collections>))
-          (result (make-vector (+ 1 max+1)))
-          )
-     (let loop ( (count 0) )
-       (cond
-        ((< count max+1)
-         (vector-set! result count (map (lambda (g) (g)) generators))
-         (loop (add1 count))
-         )
-        (else result)
-        ))
-     ))
-
 
 
@@ -568 +512 @@
  (define (sort elt< x)
    (let* ((n (size x))
-          (a (make-vector n))
-          (b (make-vector n)))
+          (a (make-vector n)))
      (do-items (lambda (item) (vector-set! a (car item) (cadr item))) x)
-     (let recur ((m 1))
-       (if (< m n)
-           (let inner-recur ((p 0))
-             (if (< p (- n m))
-                 (let ((q (+ p m))
-                       (r (min (+ p (* 2 m)) n)))
-                   (vector-merge! elt< a p q r b p)
-                   (vector-blit! b p r a p)
-                   (inner-recur (+ p (* 2 m)))
-                   )
-                 (recur (* m 2))))
-           b))
+     (if (< n 2)
+         a
+         (let ((b (make-vector n)))
+           (let recur ((m 1))
+             (if (< m n)
+                 (let inner-recur ((p 0))
+                   (if (< p (- n m))
+                       (let ((q (+ p m))
+                             (r (min (+ p (* 2 m)) n)))
+                         (vector-merge! elt< a p q r b p)
+                         (vector-blit! b p r a p)
+                         (inner-recur (+ p (* 2 m)))
+                         )
+                       (recur (* m 2))))
+                 b))
+           ))
      ))
             
 
+  ;; Generator combinators
+  (define (g-map f . gs)
+    (lambda ()
+      (let ((vs (map (lambda (g) (g)) gs)))
+        (if (list-any eof-object? vs)
+            (eof-object)
+            (apply f vs))
+        ))
+    )
+
+
+  (define (g-reduce f seed . gs)
+    (define (inner-fold seed)
+      (let ((vs (map (lambda (g) (g)) gs)))
+        (if (list-any eof-object? vs)
+            seed
+            (inner-fold (apply f (append vs (list seed)))))))
+    (inner-fold seed))
+
+
+  (define (g-find pred g)
+    (let loop ((v (g)))
+      (if (or (pred v) (eof-object? v))
+          v
+          (loop (g)))
+      ))
+
+  (define (g-filter pred g)
+    (let loop ((v (g)) (res '()))
+      (cond ((eof-object? v) res)
+            ((pred v) (loop (g) (cons v res)))
+            (else (loop (g) res)))
+      ))
+
 
  )

release/5/yasos/trunk/tests/run.scm

@@ -306 +306 @@
       ;; collection behaviors
       ((collection? self) #t)
-      ((gen-keys self) (list-gen-elts (map car table)))
-      ((gen-elts self) (list-gen-elts (map cdr table)))
+      ((gen-keys self) (list->generator (map car table)))
+      ((gen-elts self) (list->generator (map cdr table)))
       ((for-each-key self proc)
        (for-each (lambda (bucket) (proc (car bucket))) table)
@@ -320 +320 @@
 (test-group "collections"
 
+    (for-each-elt
+         (lambda (item)
+           (print "item: " item))
+         '(1 2 3))
     (test-assert (collection? t))
     (test-assert (empty? t))
@@ -332 +336 @@
     (test "map-elts" #(2 1) (map-elts identity t))
     (test "reduce" 3 (reduce + 0 t))
-    (test "reduce-items" 3 (reduce-items (lambda (ax item)
+    (test "reduce-items" 3 (reduce-items (lambda (item ax)
                                            (+ (cadr item) ax)) 0 t))
+    (test "reduce*" 1 (reduce* min '(1 2 3 4 10 5 6 8 7 9)))
     (test "sort!" #(1 2 3 4 5) (sort! (lambda (i vi j vj) (< vi vj))
                                       #( 5 2 4 3 1)))