Changeset 34967 in project


Ignore:
Timestamp:
12/29/17 20:04:43 (6 months ago)
Author:
kon
Message:

a mission needs support . common test runner .

Location:
release/4/srfi-27/trunk
Files:
2 added
6 edited

Legend:

Unmodified
Added
Removed
  • release/4/srfi-27/trunk/moa.scm

    r34780 r34967  
    229229        ((null? ss) state)
    230230      (let ((x (car ss)))
     231        ;(if {integer?(x) && 0 <= x <= 4294967295}
     232        ;(if {integer?(x) && 0 <= x && x <= 4294967295}
    231233        (if (and (integer? x) (<= 0 x 4294967295))
    232234          (u32vector-set! state i x)
  • release/4/srfi-27/trunk/mrg32k3a.scm

    r34867 r34967  
    376376                (b2h (fpquotient  (f64vector-ref b j2) fpW))
    377377                (b2l (fpmodulo (f64vector-ref b j2) fpW)))
     378            ;#{fp}{ modulo m}
    378379            (fpmodulo
    379               (fp+ (fp+ (fp* (fp+ (fp* a0h b0h)
     380              (fp+
     381                (fp+ (fp* (fp+ (fp* a0h b0h)
    380382                                  (fp+ (fp* a1h b1h)
    381383                                       (fp* a2h b2h)))
  • release/4/srfi-27/trunk/random-source.scm

    r34867 r34967  
    3434(use source-registration)
    3535
     36#; ;NO YOU 'EFFING MORON
    3637(use typed-define)
    3738
    3839;;
    3940
     41#; ;NO YOU 'EFFING MORON
    4042(define:-record-type random-source
     43  (*make-random-source
     44    ctor
     45    name docu
     46    log2-period maxrng
     47    es
     48    state-ref state-set!
     49    randomize! pseudo-randomize!
     50    make-integers make-reals)
     51  random-source?
     52  (ctor               @random-source-constructor)
     53  (name               *random-source-name)
     54  (docu               *random-source-documentation)
     55  (log2-period        *random-source-log2-period)
     56  (maxrng             *random-source-maximum-range)
     57  (es                 *random-source-entropy-source *random-source-entropy-source-set!)
     58  (state-ref          @random-source-state-ref)
     59  (state-set!         @random-source-state-set!)
     60  (randomize!         @random-source-randomize!)
     61  (pseudo-randomize!  @random-source-pseudo-randomize!)
     62  (make-integers      @random-source-make-integers)
     63  (make-reals         @random-source-make-reals) )
     64(define-record-type random-source
    4165  (*make-random-source
    4266    ctor
  • release/4/srfi-27/trunk/srfi-27-distributions.scm

    r34780 r34967  
    11;;;; srfi-27-distributions.scm
     2;;;; Kon Lovett, Dec '17
    23;;;; Kon Lovett, Jun '17
    34;;;; Kon Lovett, May '06
     
    2324  make-random-weibulls)
    2425
    25 (import scheme)
    26 
    27 (import chicken)
    28 
    29 (import (only type-errors error-argument-type))
    30 (require-library type-errors)
    31 
    32 (import
     26(import scheme chicken)
     27
     28(use
     29  (only type-errors error-argument-type)
    3330  (only type-checks
    3431    define-check+error-type
     
    3734    check-real
    3835    check-open-interval
    39     check-closed-interval))
    40 (require-library type-checks)
    41 
    42 (use srfi-27)
    43 
    44 ;;; Chicken Generic Arithmetic Argument Checks
    45 
    46 (define (nonzero-real? obj)
    47   (and (real? obj) (not (zero? obj))) )
    48 
    49 (define (nonnegative-real? obj)
    50   (and (real? obj) (not (negative? obj))) )
    51 
    52 (define (positive-real? obj)
    53   (and (real? obj) (positive? obj)) )
    54 
    55 (define-check+error-type nonzero-real)
    56 (define-check+error-type nonnegative-real)
    57 (define-check+error-type positive-real)
    58 
    59 (define (check-real-open-interval loc obj mn mx #!optional argnam)
    60   (check-real loc obj argnam)
    61   (check-real loc mn argnam)
    62   (check-real loc mx argnam)
    63   (check-open-interval loc obj mn mx argnam)
    64   obj )
    65 
    66 (define (check-real-closed-interval loc obj mn mx #!optional argnam)
    67   (check-real loc obj argnam)
    68   (check-real loc mn argnam)
    69   (check-real loc mx argnam)
    70   (check-closed-interval loc obj mn mx argnam)
    71   obj )
    72 
    73 (define (check-real-unit loc obj #!optional argnam)
    74   (check-real-closed-interval loc obj 0 1 argnam) )
    75 
    76 ;;;
    77 
    78 (define-constant PI     3.1415926535897932384626433832795028841972)
    79 (define-constant FP1/3  0.3333333333333333333333333333333333333333)
    80 
    81 ;;;
    82 
    83 ; (in case special processing needed near limits TBD)
    84 (define (*reciprocal n) (/ 1.0 n))
    85 (define (*-reciprocal n) (/ -1.0 n))
     36    check-closed-interval)
     37  srfi-27
     38  srfi-27-distributions-support)
    8639
    8740;;; Normal distribution
     
    9851          (+ mu (* sigma result)))
    9952        (let loop ()
    100           (let* ((v1 (- (* 2.0 (randoms)) 1.0))
    101                  (v2 (- (* 2.0 (randoms)) 1.0))
    102                  (s (+ (* v1 v1) (* v2 v2))) )
     53          (let* (
     54            (v1 (- (* 2.0 (randoms)) 1.0) )
     55            (v2 (- (* 2.0 (randoms)) 1.0) )
     56            (s (+ (* v1 v1) (* v2 v2)) ) )
     57            ;
    10358            (if (<= 1.0 s)
    10459              (loop)
     
    14095        (d2 (- l s))
    14196        (d3 (sqrt (- l m))))
    142     (let ((q1 (/ d1 d2))
    143           (p1 (sqrt (* d1 d2))))
     97    (let (
     98      (q1 (/ d1 d2) )
     99      (p1 (sqrt (* d1 d2)) ) )
     100      ;
    144101      (lambda ()
    145102        (let ((u (randoms)))
     
    231188
    232189(define (*make-random-lognormals mu sigma randoms)
    233   (let ((normals (*make-random-normals 0.0 1.0 randoms))
    234         (nmu (log (* mu (/ mu (sqrt (+ (* sigma sigma) (* mu mu)))))))
    235         (nsigma (sqrt (log (+ 1.0 (* sigma (/ sigma mu mu)))))) )
     190  (let (
     191    (normals (*make-random-normals 0.0 1.0 randoms) )
     192    (nmu (log (* mu (/ mu (sqrt (+ (* sigma sigma) (* mu mu)))))) )
     193    (nsigma (sqrt (log (+ 1.0 (* sigma (/ sigma mu mu))))) ) )
     194    ;
    236195    (lambda ()
    237196      (exp (+ nmu (* (normals) nsigma))))) )
     
    249208(define (*make-random-cauchys median sigma randoms)
    250209  (lambda ()
    251     (+ median (* sigma (tan (* PI (- (randoms) 0.5)))))) )
     210    (+ median (* sigma (tan (* *pi* (- (randoms) 0.5)))))) )
    252211
    253212(define (make-random-cauchys #!key (median 0.0) (sigma 1.0) (randoms (random-real/current)))
     
    267226  (if (= 1.0 alpha)
    268227    ;then special case
    269     (lambda () (* theta (- (log (randoms)))) )
     228    (if (= 1.0 theta)
     229      (lambda () (- (log (randoms))))
     230      (lambda () (* theta (- (log (randoms))))) )
    270231    ;else general case
    271     (let ((norms (*make-random-normals 0.0 1.0 randoms))
    272           (unis
    273             (if (< alpha 1.0)
    274               (let ((inv-alpha (*reciprocal alpha)))
    275                 (lambda () (expt (randoms) inv-alpha) ) )
    276               randoms)))
    277       (let* ((d (- (if (< alpha 1.0) (+ 1.0 alpha) alpha) FP1/3))
    278              (c (*reciprocal (sqrt (* 9.0 d)))))
     232    (let (
     233      (normals (*make-random-normals 0.0 1.0 randoms) )
     234      (uniforms
     235        (if (< alpha 1.0)
     236          (let ((alpha-inv (*reciprocal alpha)))
     237            (lambda () (expt (randoms) alpha-inv) ) )
     238          randoms) ) )
     239      ;
     240      (let* (
     241        (d (- (if (< alpha 1.0) (+ 1.0 alpha) alpha) *one-third*) )
     242        (c (*reciprocal (sqrt (* 9.0 d))) ) )
     243        ;
    279244        (lambda ()
    280245          (*
    281246            theta
    282247            (let loop ()
    283               (let* ((x (norms))
    284                      (v (+ 1.0 (* c x))))
    285                 (if (and
    286                       (< 0.0 v)
    287                       (let ((v (* v v v))
    288                             (u (unis))
    289                             (x^2 (* x x)))
    290                         (or
    291                           (< u (- 1.0 (* 0.0331 x^2 x^2)))
    292                           (< (log u) (+ (* 0.5 x^2) (* d (- 1.0 (+ v (log v)))))))))
     248              (let* (
     249                (x (normals) )
     250                (v (+ 1.0 (* c x)) ) )
     251                ;
     252                (define (gamma?)
     253                  (let (
     254                    (u (uniforms) )
     255                    (x^2 (* x x) )
     256                    (v^3 (* v v v) ) )
     257                    ;
     258                    (or
     259                      (< u (- 1.0 (* 0.0331 x^2 x^2)))
     260                      (< (log u) (+ (* 0.5 x^2) (* d (- 1.0 (+ v^3 (log v^3)))))) ) ) )
     261                ;
     262                (if (and (< 0.0 v) (gamma?))
    293263                   (* d v)
    294264                   (loop) ) ) ) ) ) ) ) ) )
  • release/4/srfi-27/trunk/srfi-27.setup

    r34867 r34967  
    119119  #:compile-options `(-scrutinize ,@publoptn) )
    120120
     121(setup-shared-extension-module 'srfi-27-distributions-support (extension-version "3.3.0")
     122  #:inline? #t
     123  #:types? #t
     124  #:compile-options `(-scrutinize ,@publoptn) )
     125
    121126(setup-shared-extension-module 'srfi-27-distributions (extension-version "3.3.0")
    122127  #:inline? #t
  • release/4/srfi-27/trunk/tests/run.scm

    r34210 r34967  
    11;;;; srfi-27 run.scm
    2 ;;;; Kon Lovett, Jun '17
    3 ;;;; Kon Lovett, Jun '09
     2;;;; Kon Lovett, Dec '17
    43
    5 (use test)
     4;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
     5
     6(define *this-egg-name* "srfi-27")
     7
     8(use files)
     9
     10;no -disable-interrupts
     11(define *csc-options* "-inline-global -scrutinize -optimize-leaf-routines -local -inline -specialize -unsafe -no-trace -no-lambda-info -clustering -lfa2")
     12
     13(define *args* (argv))
     14
     15(define (test-name #!optional (eggnam *this-egg-name*))
     16  (string-append eggnam "-test") )
     17
     18(define (this-egg-name #!optional (def *this-egg-name*))
     19  (cond
     20    ((<= 4 (length *args*))
     21      (cadddr *args*) )
     22    (def
     23      def )
     24    (else
     25      (error 'test "cannot determine egg-name") ) ) )
    626
    727;;;
    828
    9 ;FIXME real tests
     29(set! *this-egg-name* (this-egg-name))
    1030
    11 ;;
    12 
    13 (use srfi-27)
    14 
    15 (define-constant SRFI-27-TEST-TITLE "SRFI 27 Extensions")
    16 
    17 (test-begin SRFI-27-TEST-TITLE)
    18 
    19 ;
    20 
    21 (use (srfi 1) (srfi 4) data-structures)
    22 
    23 ;
    24 
    25 (use random-source entropy-source)
    26 
    27 (test-group "basics entropy"
    28   (test-assert (entropy-source? (current-entropy-source)))
    29   (test-assert (->string (entropy-source-kind (current-entropy-source))) #t)
    30 )
    31 
    32 (test-group "basics random"
    33   (test-assert (random-source? default-random-source))
    34   (test-assert (random-source? (current-random-source)))
    35   (test-assert (->string (random-source-kind (current-random-source))) #t)
    36   (test-assert (procedure? random-integer))
    37   (test-assert (procedure? random-real))
    38 )
    39 
    40 ;
    41 
    42 (test-group "SRFI-4 vector"
    43 
    44   (test-group "u8vector"
    45     ;(test-assert (procedure? random-u8vector))
    46     (let ((v10 (random-u8vector 10)))
    47       (test-assert (u8vector? v10))
    48       (test 10 (u8vector-length v10)) ) )
    49 
    50   (test-group "f64vector"
    51     ;(test-assert (procedure? random-f64vector))
    52     (let ((v10 (random-f64vector 10)))
    53       (test-assert (f64vector? v10))
    54       (test 10 (f64vector-length v10)) ) )
    55 )
    56 
    57 ;
    58 
    59 (use srfi-27-uniform-random)
    60 
    61 (test-group "uniform-random"
    62 
    63   (test-group "integers"
    64     (let-values (
    65         ((gen init)
    66           (make-uniform-random-integers high: 27 low: 16 precision: 2)))
    67       (let-values (((high low precision source) (init)))
    68         (test-assert (= 27 high))
    69         (test-assert (= 16 low))
    70         (test-assert (= 2 precision))
    71         (do ((i 0 (add1 i))
    72              (rv (gen) (gen)) )
    73             ((= 100 i))
    74           (unless (<= 16 rv) (test-assert (<= 16 rv)))
    75           (unless (<= rv 27) (test-assert (<= rv 27)))
    76           (unless (zero? (modulo rv 2)) (test-assert (zero? (modulo rv 2)))) ) ) ) )
    77 
    78   ;FIXME needs real test
    79   (test-group "reals"
    80     (let-values (
    81         ((gen init)
    82           (make-uniform-random-reals precision: 0.000000000003)))
    83       (let-values (((precision source) (init)))
    84         (test-assert (= 0.000000000003 precision))
    85         ;(flonum-print-precision 53)
    86         (do ((i 0 (add1 i))
    87              (rv (gen) (gen)) )
    88             ((= 100 i))
    89             ) ) ) )
    90 )
    91 
    92 ; Vectors
    93 
    94 (use srfi-27-vector)
    95 
    96 (define-constant VECTOR-LENGTH-LIMIT 10)
    97 (define-constant VECTOR-EXAMPLES-LIMIT 3)
    98 
    99 (define +known-vectors+  `(
    100   (,make-random-permutations ,integer? "permutations")
    101   (,make-random-vector ,real? "vector")
    102   (,make-random-hollow-sphere ,real? "hollow-sphere")
    103   (,make-random-solid-sphere ,real? "solid-sphere")
    104 ))
    105 
    106 (test-group "vector"
    107   (for-each
    108     (lambda (vect-data)
    109       (let ((vect-ctor (car vect-data))
    110             (vect-pred (cadr vect-data))
    111             (vect-name (caddr vect-data)) )
    112         (test-group vect-name
    113           (let* ((ctor (vect-ctor))
    114                  (vec (ctor VECTOR-LENGTH-LIMIT)) )
    115             (test-assert "collection" (vector? vec))
    116             ;(test-assert "elements" (every vect-pred (vector->list vec)))
    117             (test "constructed length" VECTOR-LENGTH-LIMIT (vector-length vec))
    118             (do ((i 1 (add1 i)))
    119                 ((> i VECTOR-EXAMPLES-LIMIT))
    120               (let ((res (vector-ref vec i)))
    121                 (test-assert (->string res) (vect-pred res)) ) ) ) ) ) )
    122     +known-vectors+)
    123 )
    124 
    125 ; Distributions
    126 
    127 (use srfi-27-distributions)
    128 
    129 (define-constant DISTRIBUTION-EXAMPLES-LIMIT 3)
    130 
    131 (define +known-distributions+  `(
    132   (,make-random-normals ,real? "normals")
    133   (,make-random-exponentials ,real? "exponentials")
    134   (,make-random-triangles ,real? "triangles")
    135   (,make-random-poissons ,integer? "poissons")
    136   (,make-random-bernoullis ,boolean? "bernoullis")
    137   (,make-random-binomials ,integer? "binomials")
    138   (,make-random-geometrics ,integer? "geometrics")
    139   (,make-random-lognormals ,real? "lognormals")
    140   (,make-random-cauchys ,real? "cauchys")
    141   (,make-random-gammas ,real? "gammas")
    142   (,make-random-erlangs ,real? "erlangs")
    143   (,make-random-paretos ,real? "paretos")
    144   (,make-random-levys ,real? "levys")
    145   (,make-random-weibulls ,real? "weibulls")
    146 ))
    147 
    148 (test-group "distributions"
    149   (for-each
    150     (lambda (distr-data)
    151       (let ((distr-ctor (car distr-data))
    152             (distr-pred (cadr distr-data))
    153             (distr-name (caddr distr-data)) )
    154         (test-group distr-name
    155           (receive (genny params) (distr-ctor)
    156             (test-assert "generator" (procedure? genny))
    157             (test-assert "parameters" (procedure? params))
    158             (let ((param-list (call-with-values params list)))
    159               (test-assert (->string param-list) (list? param-list)) )
    160             (do ((i 1 (add1 i)))
    161                 ((> i DISTRIBUTION-EXAMPLES-LIMIT))
    162               (let ((res (genny)))
    163                   (test-assert (->string res) (distr-pred res)) ) ) ) ) ) )
    164     +known-distributions+)
    165 )
    166 
    167 ; Composite Entropy (experimental - at best)
    168 
    169 (use entropy-clock)
    170 
    171 (use composite-entropy-source)
    172 
    173 (cond-expand
    174   (windows
    175     (use entropy-windows) )
    176   (unix
    177     (use entropy-unix) ) )
    178 
    179 ;FIXME use entropy name
    180 (define-constant COMPOSITE-ENTROPY-TITLE
    181   (string-append
    182     "composite entropy : "
    183     (cond-expand
    184       (windows
    185         "crypt" )
    186       (unix
    187         (string-append "random-device" " + " "urandom-device")))))
    188 
    189 (test-group COMPOSITE-ENTROPY-TITLE
    190   (let* ((ces-ctor
    191           (composite-entropy-source
    192             (make-entropy-source-system-clock)
    193             (cond-expand
    194               (windows
    195                 (make-entropy-source-crypt) )
    196               (unix
    197                 (make-entropy-source-random-device)
    198                 (make-entropy-source-urandom-device) ) ) ) )
    199          (ces (ces-ctor) )
    200          (genu8 (entropy-source-u8 ces) )
    201          (genf64 (entropy-source-f64 ces) ) )
    202     (test-assert (integer? (genu8)))
    203     (test-assert (<= 0 (genu8)))
    204     (test-assert (<= (genu8) 255))
    205     (test-assert (flonum? (genf64)))
    206     (test-assert (u8vector? (entropy-source-u8vector ces 2)))
    207     (test-assert (= 2 (u8vector-length (entropy-source-u8vector ces 2))))
    208     (test-assert (f64vector? (entropy-source-f64vector ces 2)))
    209     (test-assert (= 2 (f64vector-length (entropy-source-f64vector ces 2))))
    210   )
    211 )
    212 
    213 ; Composite Random (experimental - at best)
    214 
    215 (use composite-random-source)
    216 (use mwc mrg32k3a moa)
    217 
    218 ;FIXME use random name
    219 (test-group "composite random : mwc + mrg32k3a + moa"
    220   (let* ((crs-ctor
    221           (composite-random-source
    222             (make-random-source-mwc)
    223             (make-random-source-mrg32k3a)
    224             (make-random-source-moa)) )
    225          (crs (crs-ctor) )
    226          (rndint (random-source-make-integers crs) )
    227          (rnd (random-source-make-reals crs) ) )
    228     (test-assert (procedure? rndint))
    229     (test-assert (procedure? rnd))
    230     (test-assert (integer? (rndint 10)))
    231     (test-assert (<= 0 (rndint 10)))
    232     (test-assert (<= (rndint 10) 10))
    233     (test-assert (inexact? (rnd)))
    234     (test-assert (random-source-randomize! crs))
    235     (test-assert (random-source-pseudo-randomize! crs 1 2))
    236   )
    237 )
    238 
    239 ;;
    240 
    241 (test-end SRFI-27-TEST-TITLE)
     31(define (run-test #!optional (eggnam *this-egg-name*) (cscopts *csc-options*))
     32  (let ((tstnam (test-name eggnam)))
     33    (print "*** csi ***")
     34    (system (string-append "csi -s " (make-pathname #f tstnam "scm")))
     35    (newline)
     36    (print "*** csc (" cscopts ") ***")
     37    (system (string-append "csc" " " cscopts " " (make-pathname #f tstnam "scm")))
     38    (system (make-pathname (cond-expand (unix "./") (else #f)) tstnam)) ) )
    24239
    24340;;;
    24441
    245 (print "*** Original Tests ***")
    246 
    247 (use utils)
    248 
    249 (system* "csi -n -s test-mrg32k3a.scm")
    250 (system* "csi -n -s test-confidence")
    251 ;(system* "csi -n -s test-diehard") ;errors
    252 
    253 ;;;
    254 
    255 (test-exit)
     42(run-test)
Note: See TracChangeset for help on using the changeset viewer.