Changeset 39353 in project
- Timestamp:
- 11/23/20 19:34:41 (8 weeks ago)
- Location:
- release/5/micro-stats/trunk
- Files:
-
- 3 edited
Legend:
- Unmodified
- Added
- Removed
-
release/5/micro-stats/trunk/micro-stats.scm
r39349 r39353 125 125 126 126 ;; 127 128 (define *empty-vector* (vector)) 127 129 128 130 (define NORMAL-STATISTICS '( … … 311 313 ; 312 314 (define (chi-square observed expected) 313 (seq:smap seq*:*empty-vector* (cut chi-sample <> expected) observed) )315 (seq:smap *empty-vector* (cut chi-sample <> expected) observed) ) 314 316 315 317 ;samples : (seq-of observed) … … 318 320 ; 319 321 (define (chi-squares samples expected) 320 (seq:smap seq*:*empty-vector* (cut chi-square <> expected) samples) )321 322 ;; 323 324 (define (component o e) (let ((r ( o -e))) (/ (* r r) e)))322 (seq:smap *empty-vector* (cut chi-square <> expected) samples) ) 323 324 ;; 325 326 (define (component o e) (let ((r (- o e))) (/ (* r r) e))) 325 327 326 328 ;observed : (seq-of real) … … 332 334 (if (seq:sequence? expected) 333 335 (seq:smap* 334 seq*:*empty-vector* 335 (lambda (value it) 336 (component value (seq:elt expected (seq:index it))) ) 336 *empty-vector* 337 (lambda (value it) (component value (seq:elt expected (seq:index it)))) 337 338 observed) 338 (seq:smap seq*:*empty-vector* (cut component <> expected) observed) ) ) )339 (seq:smap *empty-vector* (cut component <> expected) observed) ) ) ) 339 340 (seq:foldl + 0 components) ) ) 340 341 -
release/5/micro-stats/trunk/seq-utils.scm
r39348 r39353 7 7 8 8 (;export 9 sort! sort 9 merge merge! 10 sort sort! sorted? 10 11 histogram 11 unfold-alist 12 *empty-vector*) 12 unfold-alist) 13 13 14 14 (import scheme … … 29 29 (define-type histogram-list list) 30 30 31 (: sorted? (seq binary-predicate --> boolean)) 32 (: merge! (seq seq binary-predicate -> seq)) 33 (: merge (seq seq binary-predicate -> seq)) 31 34 (: sort! (seq binary-predicate -> seq)) 32 35 (: sort (seq binary-predicate -> seq)) … … 37 40 ;; 38 41 39 (define *empty- vector* (vector))42 (define *empty-list* (list)) 40 43 44 (define (sorted? seq less?) 45 (let ((seqv (if (or (list? seq) (vector? seq)) seq (seq:coerce *empty-list* seq)))) 46 (chicken:sorted? seqv less?) ) ) 47 48 (define (merge! a b less?) 49 (let* ( 50 (as (if (list? a) a (seq:coerce *empty-list* a))) 51 (bs (if (list? b) b (seq:coerce *empty-list* b))) 52 (rs (chicken:merge! as bs less?)) ) 53 (if (list? a) rs (seq:coerce a rs)) ) ) 54 55 (define (merge a b less?) 56 (let* ( 57 (as (if (list? a) a (seq:coerce *empty-list* a))) 58 (bs (if (list? b) b (seq:coerce *empty-list* b))) 59 (rs (chicken:merge as bs less?)) ) 60 (if (list? a) rs (seq:coerce a rs)) ) ) 41 61 42 62 (define (sort! seq less?) 43 ;FIXME yes, i know, a very special case63 ;FIXME fill-in original from sorted-list 44 64 (let* ( 45 (seqv (if ( vector? seq) seq (seq:coerce *empty-vector* seq)))46 (r esv(chicken:sort! seqv less?)) )47 (if ( vector? seq) resv (seq:coerce seq resv)) ) )65 (seqv (if (or (list? seq) (vector? seq)) seq (seq:coerce *empty-list* seq))) 66 (rs (chicken:sort! seqv less?)) ) 67 (if (or (list? seq) (vector? seq)) rs (seq:coerce seq rs)) ) ) 48 68 49 69 (define (sort seq less?) 50 (seq:coerce seq (chicken:sort! (seq:coerce *empty- vector* seq) less?)) )70 (seq:coerce seq (chicken:sort! (seq:coerce *empty-list* seq) less?)) ) 51 71 52 72 ;; -
release/5/micro-stats/trunk/tests/micro-stats-test.scm
r39349 r39353 4 4 5 5 (include "test-gloss.incl") 6 7 ;;; 8 9 (define R1 #(1 2 3 4 5 6 7 8 9)) 10 (define R2 '(1.1 2.2 3.3 4.4 5.5 6.6 7.7 8.8 9.9)) 11 12 ;;; 13 14 (test-begin "seq-utils") 15 16 (import seq-utils) 17 18 (test-group "sort" 19 (define V1 #(5 3 4 2 1 9 7 8 6)) 20 (test "Performs Sort" R1 (sort V1 <)) 21 (test-assert "And Source is Unsorted" (not (sorted? V1 <))) 22 (test "Performs Sort!" R1 (sort! V1 <)) 23 (test-assert "And Source is Sorted" (sorted? V1 <)) 24 ) 25 26 (test-group "merge" 27 (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)) 28 (define RS '(1 2 3 4 5 6 7 8 9)) 29 (define R2x '(1.1 2.2 3.3 4.4 5.5 6.6 7.7 8.8 9.9)) 30 (test "Merges into same type" RV (merge R1 R2 <)) 31 ;must copy R2 since destructive, but only defined on lists so vector ok 32 (test "Merges into same type" RV (merge! R1 (append R2 '()) <)) 33 ;must copy R2 since destructive, but only defined on lists so vector ok 34 (test "Merges into same list" RS (merge! RS (append R2 '()) <)) 35 ) 36 37 (test-end "seq-utils") 38 39 ;;; 6 40 7 41 (test-begin "micro-stats") … … 16 50 (test (alist-ref 'normal (statistics-sets) eq?) (statistics-set #f)) 17 51 (test (alist-ref 'verbose (statistics-sets) eq?) (statistics-set #t)) 18 )19 20 (define R1 #(1 2 3 4 5 6 7 8 9))21 (define R2 '(1.1 2.2 3.3 4.4 5.5 6.6 7.7 8.8 9.9))22 23 (test-group "sort"24 (import seq-utils)25 (define V1 #(5 3 4 2 1 9 7 8 6))26 (test "Performs Sort" R1 (sort V1 <))27 (test "And Source is Unsorted" V1 #(5 3 4 2 1 9 7 8 6))28 (test "Performs Sort!" R1 (sort! V1 <))29 (test "And Source is Sorted" V1 #(1 2 3 4 5 6 7 8 9))30 52 ) 31 53
Note: See TracChangeset
for help on using the changeset viewer.