Changeset 39353 in project

Timestamp:

11/23/20 19:34:41 (5 months ago)

Author:

Kon Lovett

Message:

add merge & sorted, based on list, add tests

Location:

release/5/micro-stats/trunk

Files:

• micro-stats.scm (modified) (4 diffs)
• seq-utils.scm (modified) (3 diffs)
• tests/micro-stats-test.scm (modified) (2 diffs)

release/5/micro-stats/trunk/micro-stats.scm

@@ -125 +125 @@
 
 ;;
+
+(define *empty-vector* (vector))
 
 (define NORMAL-STATISTICS '(
@@ -311 +313 @@
 ;
 (define (chi-square observed expected)
-  (seq:smap seq*:*empty-vector* (cut chi-sample <> expected) observed) )
+  (seq:smap *empty-vector* (cut chi-sample <> expected) observed) )
 
 ;samples : (seq-of observed)
@@ -318 +320 @@
 ;
 (define (chi-squares samples expected)
-  (seq:smap seq*:*empty-vector* (cut chi-square <> expected) samples) )
-
-;;
-
-(define (component o e) (let ((r (o - e))) (/ (* r r) e)))
+  (seq:smap *empty-vector* (cut chi-square <> expected) samples) )
+
+;;
+
+(define (component o e) (let ((r (- o e))) (/ (* r r) e)))
 
 ;observed : (seq-of real)
@@ -332 +334 @@
       (if (seq:sequence? expected)
         (seq:smap*
-          seq*:*empty-vector*
-          (lambda (value it)
-            (component value (seq:elt expected (seq:index it))) )
+          *empty-vector*
+          (lambda (value it) (component value (seq:elt expected (seq:index it))))
           observed)
-        (seq:smap seq*:*empty-vector* (cut component <> expected) observed) ) ) )
+        (seq:smap *empty-vector* (cut component <> expected) observed) ) ) )
     (seq:foldl + 0 components) ) )
 

release/5/micro-stats/trunk/seq-utils.scm

@@ -7 +7 @@
 
 (;export
-  sort! sort
+  merge merge!
+  sort sort! sorted?
   histogram
-  unfold-alist
-  *empty-vector*)
+  unfold-alist)
 
 (import scheme
@@ -29 +29 @@
 (define-type histogram-list list)
 
+(: sorted? (seq binary-predicate --> boolean))
+(: merge! (seq seq binary-predicate -> seq))
+(: merge (seq seq binary-predicate -> seq))
 (: sort! (seq binary-predicate -> seq))
 (: sort (seq binary-predicate -> seq))
@@ -37 +40 @@
 ;;
 
-(define *empty-vector* (vector))
+(define *empty-list* (list))
 
+(define (sorted? seq less?)
+  (let ((seqv (if (or (list? seq) (vector? seq)) seq (seq:coerce *empty-list* seq))))
+    (chicken:sorted? seqv less?) ) )
+
+(define (merge! a b less?)
+  (let* (
+    (as (if (list? a) a (seq:coerce *empty-list* a)))
+    (bs (if (list? b) b (seq:coerce *empty-list* b)))
+    (rs (chicken:merge! as bs less?)) )
+    (if (list? a) rs (seq:coerce a rs)) ) )
+
+(define (merge a b less?)
+  (let* (
+    (as (if (list? a) a (seq:coerce *empty-list* a)))
+    (bs (if (list? b) b (seq:coerce *empty-list* b)))
+    (rs (chicken:merge as bs less?)) )
+    (if (list? a) rs (seq:coerce a rs)) ) )
 
 (define (sort! seq less?)
-  ;FIXME yes, i know, a very special case
+  ;FIXME fill-in original from sorted-list
   (let* (
-    (seqv (if (vector? seq) seq (seq:coerce *empty-vector* seq)))
-    (resv (chicken:sort! seqv less?)) )
-    (if (vector? seq) resv (seq:coerce seq resv)) ) )
+    (seqv (if (or (list? seq) (vector? seq)) seq (seq:coerce *empty-list* seq)))
+    (rs (chicken:sort! seqv less?)) )
+    (if (or (list? seq) (vector? seq)) rs (seq:coerce seq rs)) ) )
 
 (define (sort seq less?)
-  (seq:coerce seq (chicken:sort! (seq:coerce *empty-vector* seq) less?)) )
+  (seq:coerce seq (chicken:sort! (seq:coerce *empty-list* seq) less?)) )
 
 ;;

release/5/micro-stats/trunk/tests/micro-stats-test.scm

@@ -4 +4 @@
 
 (include "test-gloss.incl")
+
+;;;
+
+(define R1 #(1 2 3 4 5 6 7 8 9))
+(define R2 '(1.1 2.2 3.3 4.4 5.5 6.6 7.7 8.8 9.9))
+
+;;;
+
+(test-begin "seq-utils")
+
+(import seq-utils)
+
+(test-group "sort"
+  (define V1 #(5 3 4 2 1 9 7 8 6))
+  (test "Performs Sort" R1 (sort V1 <))
+  (test-assert "And Source is Unsorted" (not (sorted? V1 <)))
+  (test "Performs Sort!" R1 (sort! V1 <))
+  (test-assert "And Source is Sorted" (sorted? V1 <))
+)
+
+(test-group "merge"
+  (define RV #(1 1.1 2 2.2 3 3.3 4 4.4 5 5.5 6 6.6 7 7.7 8 8.8 9 9.9))
+  (define RS '(1 2 3 4 5 6 7 8 9))
+  (define R2x '(1.1 2.2 3.3 4.4 5.5 6.6 7.7 8.8 9.9))
+  (test "Merges into same type" RV (merge R1 R2 <))
+  ;must copy R2 since destructive, but only defined on lists so vector ok
+  (test "Merges into same type" RV (merge! R1 (append R2 '()) <))
+  ;must copy R2 since destructive, but only defined on lists so vector ok
+  (test "Merges into same list" RS (merge! RS (append R2 '()) <))
+)
+
+(test-end "seq-utils")
+
+;;;
 
 (test-begin "micro-stats")
@@ -16 +50 @@
   (test (alist-ref 'normal (statistics-sets) eq?) (statistics-set #f))
   (test (alist-ref 'verbose (statistics-sets) eq?) (statistics-set #t))
-)
-
-(define R1 #(1 2 3 4 5 6 7 8 9))
-(define R2 '(1.1 2.2 3.3 4.4 5.5 6.6 7.7 8.8 9.9))
-
-(test-group "sort"
-  (import seq-utils)
-  (define V1 #(5 3 4 2 1 9 7 8 6))
-  (test "Performs Sort" R1 (sort V1 <))
-  (test "And Source is Unsorted" V1 #(5 3 4 2 1 9 7 8 6))
-  (test "Performs Sort!" R1 (sort! V1 <))
-  (test "And Source is Sorted" V1 #(1 2 3 4 5 6 7 8 9))
 )