Changeset 34210 in project


Ignore:
Timestamp:
06/26/17 10:47:04 (3 months ago)
Author:
kon
Message:

re-flow, use macros, preds for types, more tests

Location:
release/4/srfi-27/trunk
Files:
7 edited

Legend:

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

    r34208 r34210  
    103103(define-syntax chkerr
    104104  (syntax-rules ()
    105     ((_ loc res msg) (unless res (last-err loc msg)) ) ) )
     105    ((_ ?loc ?res ?msg)
     106      (unless ?res (last-err ?loc ?msg)) ) ) )
    106107
    107108(define-constant DEFAULT-CRYPT-BUFFLEN 64)
  • release/4/srfi-27/trunk/moa.scm

    r34208 r34210  
    222222
    223223(define (moa-pack-state external-state)
    224   (unless
    225     (and
    226       (pair? external-state)
    227       (eq? EXTERNAL-ID (car external-state))
    228       (fx= (fx+ STATE-LENGTH 1) (length external-state)))
     224  (unless (moa-external-state? external-state)
    229225    (error 'moa-pack-state "malformed state" external-state) )
    230226  (let ((state (make-state)))
     
    236232          (u32vector-set! state i x)
    237233          (error 'moa-pack-state "illegal value" x) ) ) ) ) )
     234
     235(define (moa-external-state? obj)
     236  (and
     237    (pair? obj)
     238    (eq? EXTERNAL-ID (car obj))
     239    (fx= (fx+ STATE-LENGTH 1) (length obj)) ) )
    238240
    239241(define (moa-randomize-state state entropy-source)
  • release/4/srfi-27/trunk/mrg32k3a.scm

    r34208 r34210  
    279279          (error 'mrg32k3a-pack-state "illegal degenerate state" external-state) ) )
    280280      ;
    281       (unless (and
    282                 (pair? external-state)
    283                 (eq? EXTERNAL-ID (car external-state))
    284                 (fx= STATE-LENGTH (length (cdr external-state))))
     281      (unless (mrg32k3a-external-state? external-state)
    285282          (error 'mrg32k3a-pack-state "malformed state" external-state) )
    286283      ;
     
    300297              state )
    301298          (checked-set! state (car ss) i (car ms)) ) ) ) ) )
     299
     300(define (mrg32k3a-external-state? obj)
     301  (and
     302    (pair? obj)
     303    (eq? EXTERNAL-ID (car obj))
     304    (fx= STATE-LENGTH (length (cdr obj))) ) )
    302305
    303306; Pseudo-Randomization
  • release/4/srfi-27/trunk/mwc.scm

    r34208 r34210  
    216216
    217217(define (mwc-pack-state external-state)
    218   (unless (and
    219             (pair? external-state)
    220             (eq? EXTERNAL-ID (car external-state))
    221             (fx= (fx+ STATE-LENGTH 1) (length external-state)))
     218  (unless (mwc-external-state? external-state)
    222219      (error 'mwc-pack-state "malformed state" external-state) )
    223220  (let* ((state (make-state))
     
    230227    (setter 1 (caddr external-state))
    231228    state ) )
     229
     230(define (mwc-external-state? obj)
     231  (and
     232    (pair? obj)
     233    (eq? EXTERNAL-ID (car obj))
     234    (fx= (fx+ STATE-LENGTH 1) (length obj)) ) )
    232235
    233236;; 64 bit entropy used as a bit source, not a number source!
  • release/4/srfi-27/trunk/srfi-27-numbers.scm

    r34208 r34210  
    2323  native-real-precision?)
    2424
     25;NOTE that the module language is not Scheme so one cannot create a list of identifiers,
     26;respective of context, then use that list for import except or only, or declare.
     27
    2528(import
    2629  (except scheme
     
    3942    integer? real?
    4043    exact->inexact inexact->exact
    41     floor)
     44    floor))
     45(require-library numbers)
     46
     47(import
    4248  (only type-checks
     49    define-check+error-type
    4350    check-real)
    4451  (only type-errors
    45     error-argument-type error-open-interval error-closed-interval))
    46 (require-library numbers type-checks type-errors)
     52    error-argument-type
     53    error-open-interval error-closed-interval))
     54(require-library type-checks type-errors)
    4755
    4856(declare
     
    5765;;
    5866
    59 (define (check-integer loc obj #!optional argnam)
    60   (unless (integer? obj)
    61     (error-argument-type loc obj "integer" argnam)) )
     67; use 'number' conditioned checks
    6268
    63 #;
    64 (define (check-cardinal-integer loc obj #!optional argnam)
    65   (unless (and (integer? obj) (<= 0 obj))
    66     (error-argument-type loc obj "cardinal-integer" argnam)) )
     69(define (positive-integer? obj)
     70  (and (integer? obj) (positive? obj)) )
    6771
    68 (define (check-positive-integer loc obj #!optional argnam)
    69   (unless (and (integer? obj) (positive? obj))
    70     (error-argument-type loc obj "positive-integer" argnam)) )
     72#;(define (cardinal-integer? obj)
     73  (and (integer? obj) (<= 0 obj)) )
    7174
    72 ;;
     75#;(define (nonzero-real? obj)
     76  (and (real? obj) (not (zero? obj))) )
    7377
    74 #;
    75 (define (check-real loc obj #!optional argnam)
    76   (unless (real? obj)
    77     (error-argument-type loc obj "real" argnam)) )
     78#;(define (nonnegative-real? obj)
     79  (and (real? obj) (not (negative? obj))) )
    7880
    79 #;
    80 (define (check-nonzero-real loc obj #!optional argnam)
    81   (unless (and (real? obj) (not (zero? obj)))
    82     (error-argument-type loc obj "nonzero-real" argnam)) )
     81#;(define (positive-real? obj)
     82  (and (real? obj) (positive? obj)) )
    8383
    84 #;
    85 (define (check-nonnegative-real loc obj #!optional argnam)
    86   (unless (and (real? obj) (not (negative? obj)))
    87     (error-argument-type loc obj "nonnegative-real" argnam)) )
    88 
    89 #;
    90 (define (check-positive-real loc obj #!optional argnam)
    91   (unless (and (real? obj) (positive? obj))
    92     (error-argument-type loc obj "positive-real" argnam)) )
    93 
    94 ;;
     84(define-check+error-type integer)
     85#;(define-check+error-type cardinal-integer)
     86(define-check+error-type positive-integer)
     87#;(define-check+error-type real)
     88#;(define-check+error-type nonzero-real)
     89#;(define-check+error-type nonnegative-real)
     90#;(define-check+error-type positive-real)
    9591
    9692(define (check-real-open-interval loc obj mn mx #!optional argnam)
    9793  (check-real loc obj argnam)
    9894  (unless (< mn obj mx)
    99     (error-open-interval loc obj mn mx argnam)) )
     95    (error-open-interval loc obj mn mx argnam) )
     96  obj )
    10097
    10198#;
     
    103100  (check-real loc obj argnam)
    104101  (unless (<= mn obj mx)
    105     (error-closed-interval loc obj mn mx argnam)) )
     102    (error-closed-interval loc obj mn mx argnam) )
     103  obj )
    106104
    107105(define (check-real-precision loc obj #!optional argnam)
  • release/4/srfi-27/trunk/srfi-27.scm

    r34208 r34210  
    11;;;; srfi-27.scm
     2;;;; Kon Lovett, Jun '17
    23;;;; Kon Lovett, Oct '09
    34
     
    193194    (ctor) ) )
    194195
    195 (define (new-random-source rs)
     196(define (new-random-source #!optional (rs (current-random-source)))
    196197  ((@random-source-constructor (check-random-source 'new-random-source rs))) )
    197198
     
    232233
    233234(define (random-source-randomize! rs #!optional es)
    234   (check-random-source 'random-source-randomize! rs)
    235   ((@random-source-randomize! rs)
     235  ((@random-source-randomize! (check-random-source 'random-source-randomize! rs))
    236236    (or
    237237      (and es (check-entropy-source 'random-source-randomize! es))
  • release/4/srfi-27/trunk/tests/run.scm

    r34208 r34210  
     1;;;; srfi-27 run.scm
     2;;;; Kon Lovett, Jun '17
     3;;;; Kon Lovett, Jun '09
    14
    25(use test)
    36
     7;;;
     8
     9;FIXME real tests
     10
    411;;
    512
    613(use srfi-27)
    714
    8 ;(print "Current Random Source: " (random-source-kind (current-random-source)))
    9 ;(print "Current Entropy Source: " (entropy-source-kind (current-entropy-source)))
    10 ;(newline)
    11 
    12 #|
    13 (use bsdrnd)
    14 
    15 (make-random-source 'bsd)
    16 |#
    17 
    18 #|
    19 (use composite-random-source)
    20 (use mwc mrg32k3a moa)
    21 
    22 (test-group "composite random"
    23   (let* (
    24       (crs-ctor
    25         (composite-random-source
    26           (make-random-source-mwc)
    27           (make-random-source-mrg32k3a)
    28           (make-random-source-moa)) )
    29       (crs (crs-ctor) )
    30       (rndint (random-source-make-integers crs) )
    31       (rnd (random-source-make-reals crs) ) )
    32     (test-assert (procedure? rndint))
    33     (test-assert (procedure? rnd))
    34     (test-assert (integer? (rndint 10)))
    35     (test-assert (<= 0 (rndint 10)))
    36     (test-assert (<= (rndint 10) 10))
    37     (test-assert (inexact? (rnd)))
    38     (test-assert (random-source-randomize! crs))
    39     (test-assert (random-source-pseudo-randomize! crs 1 2))
    40   )
    41 )
    42 |#
    43 
    44 #|
    45 (use composite-entropy-source)
    46 (use entropy-clock entropy-unix)
    47 (use srfi-4)
    48 
    49 (test-group "composite entropy"
    50   (let* (
    51       (ces-ctor
    52         (composite-entropy-source
    53           (make-entropy-source-system-clock)
    54           (make-entropy-source-random-device)
    55           (make-entropy-source-urandom-device)) )
    56       (ces (ces-ctor) )
    57       (genu8 (entropy-source-u8 ces) )
    58       (genf64 (entropy-source-f64 ces) ) )
    59     (test-assert (integer? (genu8)))
    60     (test-assert (<= 0 (genu8)))
    61     (test-assert (<= (genu8) 255))
    62     (test-assert (flonum? (genf64)))
    63     (test-assert (u8vector? (entropy-source-u8vector ces 2)))
    64     (test-assert (= 2 (u8vector-length (entropy-source-u8vector ces 2))))
    65     (test-assert (f64vector? (entropy-source-f64vector ces 2)))
    66     (test-assert (= 2 (f64vector-length (entropy-source-f64vector ces 2))))
    67   )
    68 )
    69 |#
    70 
    71 ;;;
    72 
    73 (test-begin "SRFI 27")
     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)
    7422
    7523;
     
    7927(test-group "basics entropy"
    8028  (test-assert (entropy-source? (current-entropy-source)))
     29  (test-assert (->string (entropy-source-kind (current-entropy-source))) #t)
    8130)
    8231
     
    8433  (test-assert (random-source? default-random-source))
    8534  (test-assert (random-source? (current-random-source)))
    86 
     35  (test-assert (->string (random-source-kind (current-random-source))) #t)
    8736  (test-assert (procedure? random-integer))
    8837  (test-assert (procedure? random-real))
     
    9039
    9140;
    92 
    93 (use srfi-4)
    9441
    9542(test-group "SRFI-4 vector"
     
    9845    ;(test-assert (procedure? random-u8vector))
    9946    (let ((v10 (random-u8vector 10)))
    100       (test #t (u8vector? v10))
     47      (test-assert (u8vector? v10))
    10148      (test 10 (u8vector-length v10)) ) )
    10249
     
    10451    ;(test-assert (procedure? random-f64vector))
    10552    (let ((v10 (random-f64vector 10)))
    106       (test #t (f64vector? v10))
     53      (test-assert (f64vector? v10))
    10754      (test 10 (f64vector-length v10)) ) )
    10855)
     
    14390)
    14491
    145 ;
     92; Vectors
    14693
    14794(use srfi-27-vector)
    14895
     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
    149106(test-group "vector"
    150 
    151   (test-group "random-permutations"
    152     (let ((gen (make-random-permutations)))
    153       (test-assert (procedure? gen))
    154       (let ((vec (gen 10)))
    155         (test-assert (vector? vec))
    156         (test 10 (vector-length vec)) ) ) )
    157 
    158   (test-group "random-vector"
    159     (let ((gen (make-random-vector)))
    160       (test-assert (procedure? gen))
    161       (let ((vec (gen 10)))
    162         (test-assert (vector? vec))
    163         (test 10 (vector-length vec)) ) ) )
    164 
    165   (test-group "random-hollow-sphere"
    166     (let ((gen (make-random-hollow-sphere)))
    167       (test-assert (procedure? gen))
    168       (let ((vec (gen 10)))
    169         (test-assert (vector? vec))
    170         (test 10 (vector-length vec)) ) ) )
    171 
    172   (test-group "random-solid-sphere"
    173     (let ((gen (make-random-solid-sphere)))
    174       (test-assert (procedure? gen))
    175       (let ((vec (gen 10)))
    176         (test-assert (vector? vec))
    177         (test 10 (vector-length vec)) ) ) )
     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+)
    178123)
    179124
    180125; Distributions
    181126
    182 (use data-structures)
    183 
    184127(use srfi-27-distributions)
     128
     129(define-constant DISTRIBUTION-EXAMPLES-LIMIT 3)
    185130
    186131(define +known-distributions+  `(
     
    198143  (,make-random-paretos ,real? "paretos")
    199144  (,make-random-levys ,real? "levys")
    200   (,make-random-weibulls ,real? "weibulls")))
     145  (,make-random-weibulls ,real? "weibulls")
     146))
    201147
    202148(test-group "distributions"
     
    213159              (test-assert (->string param-list) (list? param-list)) )
    214160            (do ((i 1 (add1 i)))
    215                 ((> i 3))
    216                 (let ((res (genny)))
     161                ((> i DISTRIBUTION-EXAMPLES-LIMIT))
     162              (let ((res (genny)))
    217163                  (test-assert (->string res) (distr-pred res)) ) ) ) ) ) )
    218164    +known-distributions+)
    219165)
    220166
     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
    221239;;
    222240
    223 (test-end "SRFI 27")
     241(test-end SRFI-27-TEST-TITLE)
    224242
    225243;;;
    226244
     245(print "*** Original Tests ***")
     246
    227247(use utils)
    228 
    229 (print "*** Original Tests ***")
    230248
    231249(system* "csi -n -s test-mrg32k3a.scm")
Note: See TracChangeset for help on using the changeset viewer.