Changeset 33848 in project


Ignore:
Timestamp:
02/11/17 16:41:38 (3 years ago)
Author:
Kon Lovett
Message:

re-flow, add "catalog" supp

Location:
release/4/srfi-27
Files:
38 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/srfi-27/tags/3.1.9/composite-random-source.scm

    r27249 r33848  
    2424  (let ((random-states?
    2525         (lambda (obj k n)
    26            (and (pair? obj)
    27                 (eq? k (car obj))
    28                 (list? obj)
    29                 (fx= n (fx- (length obj) 1)))))
    30         (state-ref (lambda (s) ((@random-source-state-ref s))))
    31         (state-set! (lambda (s state) ((@random-source-state-ref s) state)))
    32         (getmakints (lambda (s) ((@random-source-make-integers s)))) )
     26           (and
     27            (pair? obj)
     28            (eq? k (car obj))
     29            (list? obj)
     30            (= n (- (length obj) 1)))))
     31        (state-ref
     32          (lambda (s)
     33            ((@random-source-state-ref s))))
     34        (state-set!
     35          (lambda (s state)
     36            ((@random-source-state-ref s) state)))
     37        (make-integers
     38          (lambda (s)
     39            ((@random-source-make-integers s)))) )
    3340    (lambda (comb-int comb-real name docu log2-period maxrng srcs)
    3441      (let ((srcs-cnt (length srcs))
    35             (make-integers (map getmakints srcs)) )
     42            (make-integers (map make-integers srcs)) )
    3643        (letrec ((ctor
    3744                  (lambda (#!optional (name name) (docu docu))
     
    6370                      ;randomize!
    6471                      (lambda (e)
    65                         (for-each (lambda (s) ((@random-source-randomize! s) e)) srcs))
     72                        (for-each
     73                          (lambda (s)
     74                            ((@random-source-randomize! s) e))
     75                          srcs) )
    6676                      ;pseudo-randomize!
    6777                      (lambda (i j)
    68                         (for-each (lambda (s) ((@random-source-pseudo-randomize! s) i j) ) srcs) )
     78                        (for-each
     79                          (lambda (s)
     80                            ((@random-source-pseudo-randomize! s) i j) )
     81                          srcs) )
    6982                      ;make-integers
    7083                      (lambda ()
    71                         (lambda (n) (comb-int (map (cut <> n) make-integers) n)))
     84                        (lambda (n)
     85                          (comb-int (map (cut <> n) make-integers) n)))
    7286                      ;make-reals
    7387                      (lambda (unit)
    7488                        (let ((makrels
    75                                 (map (lambda (s) ((@random-source-make-reals s) unit)) srcs)))
     89                                (map
     90                                  (lambda (s)
     91                                    ((@random-source-make-reals s) unit) )
     92                                  srcs)))
    7693                          (lambda ()
    7794                            (comb-real (map (cut <>) makrels) unit) ) ) ) ) ) ) )
  • release/4/srfi-27/tags/3.1.9/entropy-clock.scm

    r23071 r33848  
    1010    scheme
    1111    chicken
    12     foreign
    13     entropy-source
    14     entropy-support)
     12    foreign)
    1513
    16   (require-library entropy-source entropy-support)
     14  (use entropy-source entropy-support)
    1715
    1816;;;
    1917
     18#|
    2019#>
    2120#include <time.h>
     
    3635<#
    3736
    38 
    3937(define f64init (foreign-lambda double "f64init"))
    4038(define f64rand (foreign-lambda double "f64rand" double))
     39|#
     40
     41(import extras)
     42
     43(define (f64init) (randomize))
     44(define (f64rand n) (random n))
    4145
    4246;;; Entropy from system clock
    4347
    4448(define (make-entropy-source-system-clock)
    45   (let ((f64seed (f64init)))
    46     (let ((_f64rand (lambda () (set! f64seed (f64rand f64seed)) f64seed)))
    47       (*make-entropy-source
    48         ;
    49         make-entropy-source-system-clock
    50         ;
    51         'system-clock
    52         ;
    53         "Entropy from system clock"
    54         ;
    55         (make-entropic-u8/f64 _f64rand)
    56         ;
    57         _f64rand
    58         ;
    59         (lambda (u8cnt u8vec) (entropic-u8vector-filled/f64 u8cnt u8vec _f64rand) )
    60         ;
    61         (lambda (f64cnt f64vec) (entropic-f64vector-filled f64cnt f64vec _f64rand) ) ) ) ) )
     49  (let* ((f64seed (f64init))
     50         (_f64rand (lambda () (set! f64seed (f64rand f64seed)) f64seed)) )
     51    (*make-entropy-source
     52      ;
     53      make-entropy-source-system-clock
     54      ;
     55      'system-clock
     56      ;
     57      "Entropy from system clock"
     58      ;
     59      (make-entropic-u8/f64 _f64rand)
     60      ;
     61      _f64rand
     62      ;
     63      (lambda (u8cnt u8vec) (entropic-u8vector-filled/f64 u8cnt u8vec _f64rand) )
     64      ;
     65      (lambda (f64cnt f64vec) (entropic-f64vector-filled f64cnt f64vec _f64rand) ) ) ) )
    6266
    6367(register-entropy-source! 'system-clock make-entropy-source-system-clock)
  • release/4/srfi-27/tags/3.1.9/entropy-port.scm

    r20956 r33848  
    99    ;
    1010    make-entropy-source/port
    11     make-entropy-source/port-open
    12     make-entropy-source/port-open-timed
    13     make-entropy-source/file)
     11    make-entropy-source/port-open make-entropy-source/port-open-timed
     12    make-entropy-source/file make-entropy-source/file-timed)
    1413
    1514  (import
    1615    scheme
    1716    chicken
    18     (only type-checks
    19       check-input-port check-procedure check-symbol check-string)
    20     (only type-errors warning-argument-type)
    21     entropy-source
    22     entropy-support
    23     timed-resource)
     17    (only type-checks check-input-port check-procedure check-symbol check-string)
     18    (only type-errors warning-argument-type))
    2419
    2520  (require-library
    26     type-checks type-errors
    27     entropy-source entropy-support
    28     timed-resource)
     21    type-checks type-errors)
     22
     23(use entropy-source entropy-support timed-resource miscmacros)
    2924
    3025;;
     
    10095  (let ((to (entropy-port-lifetime)))
    10196    (if to
    102         ;then auto-close on timeout
    103         (*make-entropy-source/port-open-timed opener to name docu)
    104         ;else keep open
    105         (let ((port (opener)))
    106           (set-finalizer! port close-input-port)
    107           (*make-entropy-source/port port name docu) ) ) ) )
     97      ;then auto-close on timeout
     98      (*make-entropy-source/port-open-timed opener to name docu)
     99      ;else keep open
     100      (let ((port (opener)))
     101        (set-finalizer! port close-input-port)
     102        (*make-entropy-source/port port name docu) ) ) ) )
    108103
    109104;;; Timeout Seconds
     
    111106(define-constant DEFAULT-ENTROPY-PORT-CLOSE-SECONDS 60.0)
    112107
    113 (define entropy-port-lifetime
    114   (let ((lt DEFAULT-ENTROPY-PORT-CLOSE-SECONDS))
    115     (lambda args
    116       (if (null? args) lt
    117           (let ((x (car args)))
    118             (cond
    119               ((not x)                        (set! lt #f) )
    120               ((and (real? x) (positive? x))  (set! lt x) )
    121               (else
    122                 (warning-argument-type 'entropy-port-lifetime x 'seconds) ) ) ) ) ) ) )
     108(define-parameter entropy-port-lifetime DEFAULT-ENTROPY-PORT-CLOSE-SECONDS
     109  (lambda (x)
     110    (cond
     111      ((boolean? x)
     112        (and x DEFAULT-ENTROPY-PORT-CLOSE-SECONDS) )
     113      ((and (real? x) (positive? x))
     114        x )
     115      (else
     116        (warning-argument-type 'entropy-port-lifetime x 'seconds)
     117        (entropy-port-lifetime) ) ) ) )
    123118
    124119;;; Entropy from some port
     
    126121(define (make-entropy-source/port port
    127122          #!optional
    128             (name (gensym 'port-))
    129             (docu "Entropy from an open port"))
     123          (name (gensym 'port-))
     124          (docu "Entropy from an open port"))
    130125  (check-input-port 'make-entropy-source/port port)
    131126  (check-symbol 'make-entropy-source/port name 'name)
     
    137132(define (make-entropy-source/port-open opener
    138133          #!optional
    139             (name (gensym 'port-))
    140             (docu "Entropy from port"))
     134          (name (gensym 'port-))
     135          (docu "Entropy from port"))
    141136  (check-procedure 'make-entropy-source/port-open opener 'open-procedure)
    142137  (check-symbol 'make-entropy-source/port-open name 'name)
     
    148143(define (make-entropy-source/port-open-timed opener timeout
    149144          #!optional
    150             (name (gensym 'timed-port-))
    151             (docu "Entropy from timed open port"))
     145          (name (gensym 'timed-port-))
     146          (docu "Entropy from timed open port"))
    152147  (check-procedure 'make-entropy-source/port-open-timed opener 'open-procedure)
     148  ;(check- timeout 'timeout)
    153149  (check-symbol 'make-entropy-source/port-open-timed name 'name)
    154150  (check-string 'make-entropy-source/port-open-timed docu 'documentation)
    155151  (*make-entropy-source/port-open-timed opener timeout name docu) )
     152
     153;;;
     154
     155(define (make-entropy-open-file namstr)
     156  (make-open-binary-input-file namstr) )
    156157
    157158;;; Entropy from some file (binary)
     
    159160(define (make-entropy-source/file namstr
    160161          #!optional
    161             (name (gensym 'file-))
    162             (docu (string-append "Entropy from file \"" namstr "\"")))
     162          (name (gensym 'file-))
     163          (docu (string-append "Entropy from file \"" namstr "\"")))
    163164  (check-string 'make-entropy-source/file namstr 'filename)
    164165  (check-symbol 'make-entropy-source/file name 'name)
    165166  (check-string 'make-entropy-source/file docu 'documentation)
    166   (*make-entropy-source/port-open (make-open-binary-input-file namstr) name docu) )
     167  (*make-entropy-source/port-open (make-entropy-open-file namstr) name docu) )
     168
     169(define (make-entropy-source/file-timed namstr timeout
     170          #!optional
     171          (name (gensym 'file-))
     172          (docu (string-append "Entropy from file \"" namstr "\"")))
     173  (check-string 'make-entropy-source/file-timed namstr 'filename)
     174  ;(check- timeout 'timeout)
     175  (check-symbol 'make-entropy-source/file-timed name 'name)
     176  (check-string 'make-entropy-source/file-timed docu 'documentation)
     177  (*make-entropy-source/port-open-timed (make-entropy-open-file namstr) timeout name docu) )
    167178
    168179) ;module entropy-port
  • release/4/srfi-27/tags/3.1.9/entropy-source.scm

    r28099 r33848  
    99    *entropy-source-name
    1010    *entropy-source-documentation
    11     @entropy-source-construtor
     11    @entropy-source-constructor
    1212    @entropy-source-u8
    1313    @entropy-source-f64
     
    1515    @entropy-source-f64vector
    1616    ;
     17    entropy-source-integer
    1718    entropy-source-f64-integer
    1819    ;
     
    2829    (only srfi-1 alist-cons alist-delete!)
    2930    (only type-checks define-check+error-type check-procedure check-symbol))
     31  (require-library data-structures srfi-1 type-checks)
    3032
    31   (require-library data-structures srfi-1 type-checks)
     33  (use registration)
    3234
    3335;;
     
    3638  (*make-entropy-source ctor name docu u8 f64 u8vec f64vec)
    3739  entropy-source?
    38   (ctor       @entropy-source-construtor)
     40  (ctor       @entropy-source-constructor)
    3941  (name       *entropy-source-name)
    4042  (docu       *entropy-source-documentation)
     
    4850;;
    4951
    50 (define (entropy-source-f64-integer entropy-source)
     52(define (entropy-source-integer entropy-source)
    5153  ;ugly but ...
    5254  (let ((get-f64 (@entropy-source-f64 entropy-source)))
     
    5658        (loop (get-f64)) ) ) ) )
    5759
     60(define entropy-source-f64-integer entropy-source-integer)
     61
    5862;; Entropy Source Constructor Registry
    5963
    60 (define +sources+ '())
     64(define +reg+ (make-registration 'entropy-source '()))
    6165
    62 (define (registered-entropy-sources) (map car +sources+))
     66(define (registered-entropy-sources)
     67  ((@registration-key +reg+)) )
    6368
    64 (define (registered-entropy-source name) (alist-ref name +sources+ eq?))
     69(define (registered-entropy-source name)
     70  ((@registration-ref +reg+) name) )
    6571
    66 (define (unregister-entropy-source name) (set! +sources+ (alist-delete! name +sources+ eq?)))
     72(define (unregister-entropy-source name)
     73  ((@registration-deref! +reg+) name) )
    6774
    6875(define (register-entropy-source! name ctor)
    69   (check-symbol 'register-entropy-source! name)
    70   (check-procedure 'register-entropy-source! ctor)
    71   (set! +sources+ (alist-update! name ctor +sources+ eq?)) )
     76  ((@registration-register! +reg+) name ctor) )
    7277
    7378) ;entropy-source
  • release/4/srfi-27/tags/3.1.9/entropy-support.scm

    r23071 r33848  
    7676        (dbl 0.0) )
    7777    (lambda ()
    78       (if (fx= idx BYTES/F64) (begin (set! dbl (f64gen)) (set! idx 0))
    79           (set! idx (fx+ idx 1)) )
     78      (if (fx= idx BYTES/F64)
     79        (begin
     80          (set! dbl (f64gen))
     81          (set! idx 0))
     82        (set! idx (fx+ idx 1)) )
    8083      (double_peek_byte dbl idx) ) ) )
    8184
     
    8790        (let loop ()
    8891          (u8vector-filled! f64buf u8gen 0 BYTES/F64)
    89           (if (good_positive_double f64buf #$tmpdbl) tmpdbl
    90               (loop) ) ) ) ) ) )
     92          (if (good_positive_double f64buf #$tmpdbl)
     93            tmpdbl
     94            (loop) ) ) ) ) ) )
    9195
    9296(define (make-entropic-f64/u8 u8gen)
     
    96100        (u8vector-filled! f64buf u8gen 0 BYTES/F64)
    97101        (let ((tmpdbl (good_positive_double f64buf)))
    98           (if (fp= -1.0 tmpdbl) (loop)
     102          (if (fp= -1.0 tmpdbl)
     103            (loop)
    99104            tmpdbl ) ) ) ) ) )
    100105
     
    106111
    107112(define (entropic-u8vector-filled/f64 u8cnt u8vec f64gen)
    108   (let ((u8vec (or u8vec (make-u8vector u8cnt))))
    109     (let* ((f64cnt (fx/ u8cnt BYTES/F64))
    110            (f64vec (f64vector-filled! (make-f64vector f64cnt) f64gen))
    111            (u8rem (fxmod u8cnt BYTES/F64))
    112            (u8len (fx- u8cnt u8rem)) )
    113         (move-memory! f64vec u8vec u8len)               ; whole
    114         (when (fx< 0 u8rem)
    115           (let ((u8gen (make-entropic-u8/f64 f64gen)))  ; remaining
    116             (do ((idx u8len (fx+ idx 1)))
    117                 ((fx>= idx u8cnt))
    118               (u8vector-set! u8vec idx (u8gen)) ) ) ) )
    119     u8vec ) )
     113  (let* ((u8vec (or u8vec (make-u8vector u8cnt)))
     114         (f64cnt (fx/ u8cnt BYTES/F64))
     115         (f64vec (f64vector-filled! (make-f64vector f64cnt) f64gen))
     116         (u8rem (fxmod u8cnt BYTES/F64))
     117         (u8len (fx- u8cnt u8rem)) )
     118    (move-memory! f64vec u8vec u8len)               ; whole
     119    (when (fx< 0 u8rem)
     120      (let ((u8gen (make-entropic-u8/f64 f64gen)))  ; remaining
     121        (do ((idx u8len (fx+ idx 1)))
     122            ((fx>= idx u8cnt))
     123          (u8vector-set! u8vec idx (u8gen)) ) ) ) )
     124    u8vec )
    120125
    121126(define (entropic-f64vector-filled/u8 f64cnt f64vec u8gen)
     
    145150        (let loop ()
    146151          (let ((len (read-u8vector! BYTES/F64 f64buf port)))
    147             (cond ((< len BYTES/F64)                      0.0)
    148                   ((good_positive_double f64buf #$tmpdbl) tmpdbl)
    149                   (else                                   (loop) ) ) ) ) ) ) ) )
     152            (cond
     153              ((< len BYTES/F64)                      0.0)
     154              ((good_positive_double f64buf #$tmpdbl) tmpdbl)
     155              (else                                   (loop) ) ) ) ) ) ) ) )
    150156
    151157(define port-entropic-f64
     
    154160      (let loop ()
    155161        (let ((len (read-u8vector! BYTES/F64 f64buf port)))
    156           (if (< len BYTES/F64) 0.0
     162          (if (< len BYTES/F64)
     163            0.0
    157164            (let ((tmpdbl (good_positive_double f64buf)))
    158               (if (fp= -1.0 tmpdbl) (loop)
     165              (if (fp= -1.0 tmpdbl)
     166                (loop)
    159167                tmpdbl ) ) ) ) ) ) ) )
    160168
    161169(define (port-entropic-u8vector port u8cnt u8vec)
    162   (if u8vec (begin (read-u8vector! u8cnt u8vec port) u8vec)
    163       (read-u8vector u8cnt port) ) )
     170  (if u8vec
     171    (begin
     172      (read-u8vector! u8cnt u8vec port)
     173      u8vec)
     174    (read-u8vector u8cnt port) ) )
    164175
    165176(define (port-entropic-f64vector port f64cnt f64vec #!optional (f64get port-entropic-f64))
  • release/4/srfi-27/tags/3.1.9/moa.scm

    r28099 r33848  
    218218
    219219(define (moa-pack-state external-state)
    220   (if (not (and (pair? external-state)
    221                 (eq? EXTERNAL-ID (car external-state))
    222                 (fx= (fx+ STATE-LENGTH 1) (length external-state))))
    223       (error 'moa-pack-state "malformed state" external-state)
    224       (let ((state (make-state)))
    225         (do ((i 0 (fx+ i 1))
    226              (ss (cdr external-state) (cdr ss)) )
    227             ((null? ss) state)
    228           (let ((x (car ss)))
    229             (if (and (integer? x) (<= 0 x 4294967295)) (u32vector-set! state i x)
    230                 (error 'moa-pack-state "illegal value" x) ) ) ) ) ) )
     220  (unless
     221    (and
     222      (pair? external-state)
     223      (eq? EXTERNAL-ID (car external-state))
     224      (fx= (fx+ STATE-LENGTH 1) (length external-state)))
     225    (error 'moa-pack-state "malformed state" external-state) )
     226  (let ((state (make-state)))
     227    (do ((i 0 (fx+ i 1))
     228         (ss (cdr external-state) (cdr ss)) )
     229        ((null? ss) state)
     230      (let ((x (car ss)))
     231        (if (and (integer? x) (<= 0 x 4294967295))
     232          (u32vector-set! state i x)
     233          (error 'moa-pack-state "illegal value" x) ) ) ) ) )
    231234
    232235(define (moa-randomize-state state entropy-source)
    233   (init_state state (exact->inexact (modulo (fpabs (entropy-source-f64-integer entropy-source)) (expt 2 64))))
     236  (init_state
     237    state
     238    (exact->inexact
     239      (modulo
     240        (fpabs (entropy-source-f64-integer entropy-source))
     241        (expt 2 64))))
    234242  state )
    235243
     
    292300      ;
    293301      (lambda (prec)
    294         (cond ((native-real-precision? prec eMAX)
    295                 (lambda () (moa-random-real state)))
    296               (else
    297                 (lambda () (moa-random-real-mp state prec)))))) ) )
     302        (cond
     303          ((native-real-precision? prec eMAX)
     304            (lambda () (moa-random-real state)))
     305          (else
     306            (lambda () (moa-random-real-mp state prec)))))) ) )
    298307
    299308;;;
  • release/4/srfi-27/tags/3.1.9/mrg32k3a.scm

    r23730 r33848  
    266266        (when (fpzero? (fp+ a (fp+ b c)))
    267267          (error 'mrg32k3a-pack-state "illegal degenerate state" external-state) ) )
    268       (if (not (and (pair? external-state)
    269                     (eq? EXTERNAL-ID (car external-state))
    270                     (fx= STATE-LENGTH (length (cdr external-state)))))
    271           (error 'mrg32k3a-pack-state "malformed state" external-state)
    272           (let ((state (make-state)))
    273             (do ((i 0 (fx+ i 1))
    274                  (ss (cdr external-state) (cdr ss))
    275                  (ms state-M (cdr ms)) )
    276                 ((null? ss)
    277                   (check-m-state
    278                     (f64vector-ref state 0)
    279                     (f64vector-ref state 1)
    280                     (f64vector-ref state 2))
    281                   (check-m-state
    282                     (f64vector-ref state 3)
    283                     (f64vector-ref state 4)
    284                     (f64vector-ref state 5))
    285                   state )
    286               (checked-set! state (car ss) i (car ms)) ) ) ) ) ) )
     268      (unless (and
     269                (pair? external-state)
     270                (eq? EXTERNAL-ID (car external-state))
     271                (fx= STATE-LENGTH (length (cdr external-state))))
     272          (error 'mrg32k3a-pack-state "malformed state" external-state) )
     273      (let ((state (make-state)))
     274        (do ((i 0 (fx+ i 1))
     275             (ss (cdr external-state) (cdr ss))
     276             (ms state-M (cdr ms)) )
     277            ((null? ss)
     278              (check-m-state
     279                (f64vector-ref state 0)
     280                (f64vector-ref state 1)
     281                (f64vector-ref state 2))
     282              (check-m-state
     283                (f64vector-ref state 3)
     284                (f64vector-ref state 4)
     285                (f64vector-ref state 5))
     286              state )
     287          (checked-set! state (car ss) i (car ms)) ) ) ) ) )
    287288
    288289; Pseudo-Randomization
     
    393394
    394395      (define (power a e) ; A^e
    395         (cond ((fpzero? e)  A^0)
    396               ((fp= e 1.0)  a)
    397               ((fpeven? e)  (power (product a a) (fpquotient e 2.0)))
    398               (else         (product (power a (fp- e 1.0)) a)) ) )
     396        (cond
     397          ((fpzero? e)  A^0)
     398          ((fp= e 1.0)  a)
     399          ((fpeven? e)  (power (product a a) (fpquotient e 2.0)))
     400          (else         (product (power a (fp- e 1.0)) a)) ) )
    399401
    400402      ; precompute A^(2^127) and A^(2^76)
     
    403405        (letrec ((power-power  ; A^(2^b)
    404406                  (lambda (a b)
    405                     (if (fpzero? b) a
    406                         (power-power (product a a) (fp- b 1.0))))))
     407                    (if (fpzero? b)
     408                      a
     409                      (power-power (product a a) (fp- b 1.0))))))
    407410          (set! mrg32k3a-gen0 (power-power A 127.0))
    408411          (set! mrg32k3a-gen1 (power-power A 76.0))
     
    410413
    411414      ; compute M = A^(16 + i*2^127 + j*2^76)
    412       (let ((M (product mrg32k3a-gen2
    413                         (product (power mrg32k3a-gen0 (fpremainder i fp2^28))
    414                                  (power mrg32k3a-gen1 (fpremainder j fp2^28))))))
     415      (let ((M
     416              (product
     417                mrg32k3a-gen2
     418                (product
     419                  (power mrg32k3a-gen0 (fpremainder i fp2^28))
     420                  (power mrg32k3a-gen1 (fpremainder j fp2^28))))))
    415421        ; the new state
    416422        (f64vector
     
    422428         (f64vector-ref M 15)) ) ) ) )
    423429
     430; G. Marsaglia's simple 16-bit generator with carry
     431(define (make-gms16wc entropy-source)
     432  (let ((random-m
     433         (let ((x (fpremainder ((@entropy-source-f64 entropy-source)) fp2^16)))
     434           (lambda ()
     435             (let ((y (fpremainder x fp2^16)))
     436               (set! x (fp+ (fp* 30903.0 y) (fpquotient x fp2^16)))
     437               y ) ) ) ) )
     438    (lambda (n)
     439      ; m < n < m^2
     440      (fpremainder (fp+ (fp* (random-m) fp2^16) (random-m)) n) ) ) )
     441
    424442; True Randomization
    425443; ==================
     
    432450(define (mrg32k3a-randomize-state state entropy-source)
    433451  ;; G. Marsaglia's simple 16-bit generator with carry
    434   (let ((random
    435          (let ((random-m
    436                  (let ((x (fpremainder ((@entropy-source-f64 entropy-source)) fp2^16)))
    437                    (lambda ()
    438                      (let ((y (fpremainder x fp2^16)))
    439                        (set! x (fp+ (fp* 30903.0 y) (fpquotient x fp2^16)))
    440                        y ) ) ) ) )
    441            (lambda (n)      ; m < n < m^2
    442              (fpremainder (fp+ (fp* (random-m) fp2^16) (random-m)) n) ) ) ) )
     452  (let ((random (make-gms16wc entropy-source)))
    443453    ; the new state
    444454    (f64vector
     
    503513      ;
    504514      (lambda (prec)
    505         (cond ((native-real-precision? prec eM1)
    506                 (lambda () (mrg32k3a-random-real state)))
    507               (else
    508                 (lambda () (mrg32k3a-random-real-mp state prec)))))) ) )
     515        (cond
     516          ((native-real-precision? prec eM1)
     517            (lambda () (mrg32k3a-random-real state)))
     518          (else
     519            (lambda () (mrg32k3a-random-real-mp state prec)))))) ) )
    509520
    510521;;;
  • release/4/srfi-27/tags/3.1.9/mwc.scm

    r28099 r33848  
    212212
    213213(define (mwc-pack-state external-state)
    214   (if (not (and (pair? external-state)
    215                 (eq? EXTERNAL-ID (car external-state))
    216                 (fx= (fx+ STATE-LENGTH 1) (length external-state))))
    217       (error 'mwc-pack-state "malformed state" external-state)
    218       (let* ((state (make-state))
    219              (setter
    220                (lambda (i x)
    221                  (if (and (integer? x) (<= 0 x 4294967295)) (u32vector-set! state i x)
    222                      (error 'mwc-pack-state "illegal value" x)))) )
    223         (setter 0 (cadr external-state))
    224         (setter 1 (caddr external-state))
    225         state ) ) )
     214  (unless (and
     215            (pair? external-state)
     216            (eq? EXTERNAL-ID (car external-state))
     217            (fx= (fx+ STATE-LENGTH 1) (length external-state)))
     218      (error 'mwc-pack-state "malformed state" external-state) )
     219  (let* ((state (make-state))
     220         (setter
     221          (lambda (i x)
     222            (if (and (integer? x) (<= 0 x 4294967295))
     223              (u32vector-set! state i x)
     224              (error 'mwc-pack-state "illegal value" x)))) )
     225    (setter 0 (cadr external-state))
     226    (setter 1 (caddr external-state))
     227    state ) )
    226228
    227229;; 64 bit entropy used as a bit source, not a number source!
    228230(define (mwc-randomize-state state entropy-source)
    229   (init_state state (exact->inexact (modulo (fpabs (entropy-source-f64-integer entropy-source)) (expt 2 64))))
     231  (init_state
     232    state
     233    (exact->inexact
     234      (modulo
     235        (fpabs (entropy-source-f64-integer entropy-source))
     236        (expt 2 64))))
    230237  state )
    231238
     
    290297      ;
    291298      (lambda (prec)
    292         (cond ((native-real-precision? prec eMAX)
    293                 (lambda () (mwc-random-real state)))
    294               (else
    295                 (lambda () (mwc-random-real-mp state prec)))))) ) )
     299        (cond
     300          ((native-real-precision? prec eMAX)
     301              (lambda () (mwc-random-real state)))
     302          (else
     303            (lambda () (mwc-random-real-mp state prec)))))) ) )
    296304
    297305;;;
  • release/4/srfi-27/tags/3.1.9/random-source.scm

    r19090 r33848  
    1212    *random-source-maximum-range
    1313    *random-source-entropy-source *random-source-entropy-source-set!
    14     @random-source-construtor
    15     @random-source-state-ref
    16     @random-source-state-set!
    17     @random-source-randomize!
    18     @random-source-pseudo-randomize!
    19     @random-source-make-integers
    20     @random-source-make-reals
     14    @random-source-constructor
     15    @random-source-state-ref @random-source-state-set!
     16    @random-source-randomize! @random-source-pseudo-randomize!
     17    @random-source-make-integers @random-source-make-reals
    2118    ;
    2219    registered-random-sources
     
    3128    (only srfi-1 alist-cons alist-delete!)
    3229    (only type-checks define-check+error-type check-procedure check-symbol))
     30  (require-library data-structures srfi-1 type-checks)
    3331
    34   (require-library data-structures srfi-1 type-checks)
     32  (use registration)
    3533
    3634;;
     
    4644    make-integers make-reals)
    4745  random-source?
    48   (ctor               @random-source-construtor)
     46  (ctor               @random-source-constructor)
    4947  (name               *random-source-name)
    5048  (docu               *random-source-documentation)
     
    6361;; Random Source Constructor Registry
    6462
    65 (define +sources+ '())
     63(define +reg+ (make-registration 'random-source '()))
    6664
    67 (define (registered-random-sources) (map car +sources+))
     65(define (registered-random-sources)
     66  ((@registration-key +reg+)) )
    6867
    69 (define (registered-random-source name) (alist-ref name +sources+ eq?))
     68(define (registered-random-source name)
     69  ((@registration-ref +reg+) name) )
    7070
    71 (define (unregister-random-source name) (set! +sources+ (alist-delete! name +sources+ eq?)))
     71(define (unregister-random-source name)
     72  ((@registration-deref! +reg+) name) )
    7273
    7374(define (register-random-source! name ctor)
    74   (check-symbol 'register-random-source! name)
    75   (check-procedure 'register-random-source! ctor)
    76   (set! +sources+ (alist-update! name ctor +sources+ eq?)) )
     75  ((@registration-register! +reg+) name ctor) )
    7776
    7877) ; module random-source
  • release/4/srfi-27/tags/3.1.9/srfi-27-distributions.scm

    r22477 r33848  
    4444(define (check-nonzero-real loc obj #!optional argnam)
    4545  (unless (and (real? obj) (not (zero? obj)))
    46     (error-argument-type loc obj "nonzero-real" argnam)) )
     46    (error-argument-type loc obj "nonzero-real" argnam))
     47  obj )
    4748
    4849(define (check-nonnegative-real loc obj #!optional argnam)
    4950  (unless (and (real? obj) (not (negative? obj)))
    50     (error-argument-type loc obj "nonnegative-real" argnam)) )
     51    (error-argument-type loc obj "nonnegative-real" argnam))
     52  obj )
    5153
    5254(define (check-positive-real loc obj #!optional argnam)
    5355  (unless (and (real? obj) (positive? obj))
    54     (error-argument-type loc obj "positive-real" argnam)) )
     56    (error-argument-type loc obj "positive-real" argnam))
     57  obj )
    5558
    5659(define (check-real-open-interval loc obj mn mx #!optional argnam)
    5760  (check-real loc obj argnam)
    58   (check-open-interval loc obj mn mx argnam) )
     61  (check-open-interval loc obj mn mx argnam)
     62  obj )
    5963
    6064(define (check-real-closed-interval loc obj mn mx #!optional argnam)
    6165  (check-real loc obj argnam)
    62   (check-closed-interval loc obj mn mx argnam) )
     66  (check-closed-interval loc obj mn mx argnam)
     67  obj )
    6368
    6469#;
    6570(define (check-real-precision loc obj #!optional argnam)
    66   (check-real-open-interval loc obj 0 1 argnam) )
     71  (check-real-open-interval loc obj 0 1 argnam)
     72  obj )
    6773
    6874(define (check-real-unit loc obj #!optional argnam)
    69   (check-real-closed-interval loc obj 0 1 argnam) )
     75  (check-real-closed-interval loc obj 0 1 argnam)
     76  obj )
    7077
    7178;;;
     
    7784
    7885; (in case special processing needed near limits TBD)
    79 (define-inline (*reciprocal n) (/ 1.0 n))
    80 (define-inline (*-reciprocal n) (/ -1.0 n))
    81 
    82 (define (fxadd1 n) (fx+ 1 n))
     86(define (*reciprocal n) (/ 1.0 n))
     87(define (*-reciprocal n) (/ -1.0 n))
    8388
    8489;;; Normal distribution
     
    9196    (lambda ()
    9297      (if next
    93           (let ((result next))
    94             (set! next #f)
    95             (+ mu (* sigma result)))
    96           (let loop ()
    97             (let* ((v1 (- (* 2.0 (randoms)) 1.0))
    98                    (v2 (- (* 2.0 (randoms)) 1.0))
    99                    (s (+ (* v1 v1) (* v2 v2))))
    100               (if (<= 1.0 s)
    101                   (loop)
    102                   (let ((scale (sqrt (/ (* -2.0 (log s)) s))))
    103                     (set! next (* scale v2))
    104                     (+ mu (* sigma scale v1))))))))) )
    105 
    106 (define (make-random-normals #!key (mu 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
     98        (let ((result next))
     99          (set! next #f)
     100          (+ mu (* sigma result)))
     101        (let loop ()
     102          (let* ((v1 (- (* 2.0 (randoms)) 1.0))
     103                 (v2 (- (* 2.0 (randoms)) 1.0))
     104                 (s (+ (* v1 v1) (* v2 v2))) )
     105            (if (<= 1.0 s)
     106              (loop)
     107              (let ((scale (sqrt (/ (* -2.0 (log s)) s))))
     108                (set! next (* scale v2))
     109                (+ mu (* sigma scale v1))))))))) )
     110
     111(define (make-random-normals
     112          #!key (mu 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
    107113  (check-real 'make-random-normals mu 'mu)
    108114  (check-nonzero-real 'make-random-normals sigma 'sigma)
     
    119125(define (*make-random-exponentials mu randoms)
    120126  (if (= 1.0 mu)
    121       (lambda () (- (log (randoms))))
    122       (lambda () (* mu (- (log (randoms)))))) )
    123 
    124 (define (make-random-exponentials #!key (mu 1.0) (randoms (make-uniform-random-reals)))
     127    (lambda () (- (log (randoms))))
     128    (lambda () (* mu (- (log (randoms)))))) )
     129
     130(define (make-random-exponentials
     131          #!key (mu 1.0) (randoms (make-uniform-random-reals)))
    125132  (check-real-unit 'make-random-exponentials mu 'mu)
    126133  (check-procedure 'make-random-exponentials randoms 'randoms)
     
    142149        (let ((u (randoms)))
    143150          (if (<= u q1)
    144               (+ s (* p1 (sqrt u)))
    145               (- l (* d3 (sqrt (- (* d2 u) d1))))))))) )
    146 
    147 (define (make-random-triangles #!key (s 0.0) (m 0.5) (l 1.0) (randoms (make-uniform-random-reals)))
     151            (+ s (* p1 (sqrt u)))
     152            (- l (* d3 (sqrt (- (* d2 u) d1))))))))) )
     153
     154(define (make-random-triangles
     155          #!key (s 0.0) (m 0.5) (l 1.0) (randoms (make-uniform-random-reals)))
    148156  (check-real 'make-random-triangles s 's)
    149157  (check-real 'make-random-triangles m 'm)
     
    162170    (lambda ()
    163171      ; FIXME O(mu) but O(log(mu)) desired for >> mu
    164       (do ((m 0 (fxadd1 m))
     172      (do ((m 0 (fx+ 1 m))
    165173           (prod (randoms) (* prod (randoms))))
    166174          ((<= prod emu) m)))) )
    167175
    168 (define (make-random-poissons #!key (mu 1.0) (randoms (make-uniform-random-reals)))
     176(define (make-random-poissons
     177          #!key (mu 1.0) (randoms (make-uniform-random-reals)))
    169178  (check-nonnegative-real 'make-random-poissons mu 'mu)
    170179  (check-procedure 'make-random-poissons randoms 'randoms)
     
    176185
    177186(define (*make-random-bernoullis p randoms)
    178   (cond ((= 0.0 p) (lambda () #f))
    179         ((= 1.0 p) (lambda () #t))
    180         (else      (lambda () (<= (randoms) p)))) )
    181 
    182 (define (make-random-bernoullis #!key (p 0.5) (randoms (make-uniform-random-reals)))
     187  (cond
     188    ((= 0.0 p) (lambda () #f))
     189    ((= 1.0 p) (lambda () #t))
     190    (else      (lambda () (<= (randoms) p)))) )
     191
     192(define (make-random-bernoullis
     193          #!key (p 0.5) (randoms (make-uniform-random-reals)))
    183194  (check-real-unit 'make-random-bernoullis p 'p)
    184195  (check-procedure 'make-random-bernoullis randoms 'randoms)
     
    193204    ;FIXME O(t) but O(log(t)) desired for >> t
    194205    (if (fixnum? t)
    195         (lambda ()
    196           (do ((i 0 (fxadd1 i))
    197                (n 0 (if (bernoullis) (fxadd1 n) n)))
    198               ((fx<= t i) n)))
    199         (lambda ()
    200           (do ((i 0 (add1 i))
    201                (n 0 (if (bernoullis) (add1 n) n)))
    202               ((<= t i) n))))) )
    203 
    204 (define (make-random-binomials #!key (t 1) (p 0.5) (randoms (make-uniform-random-reals)))
     206      (lambda ()
     207        (do ((i 0 (fx+ 1 i))
     208             (n 0 (if (bernoullis) (fx+ 1 n) n)))
     209            ((fx<= t i) n)))
     210      (lambda ()
     211        (do ((i 0 (add1 i))
     212             (n 0 (if (bernoullis) (add1 n) n)))
     213            ((<= t i) n))))) )
     214
     215(define (make-random-binomials
     216          #!key (t 1) (p 0.5) (randoms (make-uniform-random-reals)))
    205217  (check-cardinal-integer 'make-random-binomials t 't)
    206218  (check-real-unit 'make-random-binomials p 'p)
     
    214226(define (*make-random-geometrics p randoms)
    215227  (let ((log-p (log p)))
    216     (lambda () (+ 1 (inexact->exact (floor (/ (log (- 1.0 (randoms))) log-p)))))) )
    217 
    218 (define (make-random-geometrics #!key (p 0.5) (randoms (make-uniform-random-reals)))
     228    (lambda ()
     229      (+ 1 (inexact->exact (floor (/ (log (- 1.0 (randoms))) log-p)))))) )
     230
     231(define (make-random-geometrics
     232          #!key (p 0.5) (randoms (make-uniform-random-reals)))
    219233  (check-real-unit 'make-random-geometrics p 'p)
    220234  (check-procedure 'make-random-geometrics randoms 'randoms)
     
    229243        (nmu (log (* mu (/ mu (sqrt (+ (* sigma sigma) (* mu mu)))))))
    230244        (nsigma (sqrt (log (+ 1.0 (* sigma (/ sigma mu mu)))))) )
    231     (lambda () (exp (+ nmu (* (normals) nsigma))))) )
    232 
    233 (define (make-random-lognormals #!key (mu 1.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
     245    (lambda ()
     246      (exp (+ nmu (* (normals) nsigma))))) )
     247
     248(define (make-random-lognormals
     249          #!key (mu 1.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
    234250  (check-nonzero-real 'make-random-lognormals mu 'mu)
    235251  (check-nonnegative-real 'make-random-lognormals sigma 'sigma)
     
    244260  (lambda () (+ median (* sigma (tan (* PI (- (randoms) 0.5)))))) )
    245261
    246 (define (make-random-cauchys #!key (median 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
     262(define (make-random-cauchys
     263          #!key (median 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
    247264  (check-real 'make-random-cauchys median 'median)
    248265  (check-positive-real 'make-random-cauchys sigma 'sigma)
     
    259276(define (*make-random-gammas alpha theta randoms)
    260277  (if (= 1.0 alpha)
    261       ; then special case
    262       (lambda () (* theta (- (log (randoms)))) )
    263       ; else general case
    264       (let ((norms (*make-random-normals 0.0 1.0 randoms))
    265             (unis
    266               (if (< alpha 1.0)
    267                   (let ((inv-alpha (*reciprocal alpha)))
    268                     (lambda () (expt (randoms) inv-alpha) ) )
    269                   randoms)))
    270         (let* ((d (- (or (and (< alpha 1.0) (+ 1.0 alpha)) alpha) FP1/3))
    271                (c (*reciprocal (sqrt (* 9.0 d)))))
    272           (lambda ()
    273             (* theta
    274                (let loop ()
    275                  (let* ((x (norms))
    276                         (v (+ 1.0 (* c x))))
    277                    (if (and (< 0.0 v)
    278                             (let ((v (* v v v))
    279                                   (u (unis))
    280                                   (x^2 (* x x)))
    281                               (or (< u (- 1.0 (* 0.0331 x^2 x^2)))
    282                                   (< (log u) (+ (* 0.5 x^2) (* d (- 1.0 (+ v (log v)))))))))
    283                        (* d v)
    284                        (loop) ) ) ) ) ) ) ) ) )
    285 
    286 (define (make-random-gammas #!key (alpha 1.0) (theta 1.0) (randoms (make-uniform-random-reals)))
     278    ; then special case
     279    (lambda () (* theta (- (log (randoms)))) )
     280    ; else general case
     281    (let ((norms (*make-random-normals 0.0 1.0 randoms))
     282          (unis
     283            (if (< alpha 1.0)
     284              (let ((inv-alpha (*reciprocal alpha)))
     285                (lambda () (expt (randoms) inv-alpha) ) )
     286              randoms)))
     287      (let* ((d (- (if (< alpha 1.0) (+ 1.0 alpha) alpha) FP1/3))
     288             (c (*reciprocal (sqrt (* 9.0 d)))))
     289        (lambda ()
     290          (*
     291            theta
     292            (let loop ()
     293              (let* ((x (norms))
     294                     (v (+ 1.0 (* c x))))
     295                (if (and
     296                      (< 0.0 v)
     297                      (let ((v (* v v v))
     298                            (u (unis))
     299                            (x^2 (* x x)))
     300                        (or
     301                          (< u (- 1.0 (* 0.0331 x^2 x^2)))
     302                          (< (log u) (+ (* 0.5 x^2) (* d (- 1.0 (+ v (log v)))))))))
     303                   (* d v)
     304                   (loop) ) ) ) ) ) ) ) ) )
     305
     306(define (make-random-gammas
     307          #!key (alpha 1.0) (theta 1.0) (randoms (make-uniform-random-reals)))
    287308  (check-positive-real 'make-random-gammas alpha 'alpha)
    288309  (check-positive-real 'make-random-gammas theta 'theta)
     
    297318  (*make-random-gammas (exact->inexact alpha) (exact->inexact theta) randoms) )
    298319
    299 (define (make-random-erlangs #!key (alpha 1) (theta 1.0) (randoms (make-uniform-random-reals)))
     320(define (make-random-erlangs
     321          #!key (alpha 1) (theta 1.0) (randoms (make-uniform-random-reals)))
    300322  (check-positive-real 'make-random-erlangs alpha 'alpha)
    301323  (check-positive-real 'make-random-erlangs theta 'theta)
     
    311333    (*make-random-exponentials 1.0 (lambda () (*reciprocal (+ xmin (gammas)))))) )
    312334
    313 (define (make-random-paretos #!key (alpha 1.0) (xmin 1.0) (randoms (make-uniform-random-reals)))
     335(define (make-random-paretos
     336          #!key (alpha 1.0) (xmin 1.0) (randoms (make-uniform-random-reals)))
    314337  (check-positive-real 'make-random-paretos alpha 'alpha)
    315338  (check-positive-real 'make-random-paretos xmin 'xmin)
     
    325348(define (*make-random-levys gamma delta randoms)
    326349  (if (and (= 1.0 gamma) (= 0.0 delta))
    327       (lambda () (let ((r (randoms))) (*reciprocal (* r r))))
    328       (lambda () (let ((r (randoms))) (+ delta (* gamma (*reciprocal (* r r))))))) )
    329 
    330 (define (make-random-levys #!key (gamma 1.0) (delta 0.0) (randoms (make-uniform-random-reals)))
     350    (lambda () (let ((r (randoms))) (*reciprocal (* r r))))
     351    (lambda () (let ((r (randoms))) (+ delta (* gamma (*reciprocal (* r r))))))) )
     352
     353(define (make-random-levys
     354          #!key (gamma 1.0) (delta 0.0) (randoms (make-uniform-random-reals)))
    331355  (check-nonnegative-real 'make-random-levys delta 'delta)
    332356  (check-positive-real 'make-random-levys gamma 'gamma)
     
    343367    (lambda () (expt (* invscale (log (- 1.0 (randoms)))) invshape)) ) )
    344368
    345 (define (make-random-weibulls #!key (shape 1.0) (scale 1.0) (randoms (make-uniform-random-reals)))
     369(define (make-random-weibulls
     370          #!key (shape 1.0) (scale 1.0) (randoms (make-uniform-random-reals)))
    346371  (check-positive-real 'make-random-weibulls shape 'shape)
    347372  (check-positive-real 'make-random-weibulls scale 'scale)
  • release/4/srfi-27/tags/3.1.9/srfi-27-numbers.scm

    r23071 r33848  
    124124(define (random-power rndint state max m k) ; n = m^k, k >= 1
    125125  (do ((k k (fx- k 1))
    126        (n (inexact->exact (rndint state max)) (+ (inexact->exact (rndint state max)) (* n m))))
     126       (n
     127         (inexact->exact (rndint state max))
     128         (+ (inexact->exact (rndint state max)) (* n m))) )
    127129      ((fx= 1 k) n) ) )
    128130
     
    143145          (let loop ()
    144146            (let ((x (random-power rndint state max m k)))
    145               (if (< x a) (quotient x mk-by-n)
    146                   (loop) ) ) ) ) ) ) )
     147              (if (< x a)
     148                (quotient x mk-by-n)
     149                (loop) ) ) ) ) ) ) )
    147150
    148151; Multiple Precision Reals
     
    159162       (u (- (/ 1 prec) 1) (/ u m)) )
    160163      ((<= u 1)
    161         (exact->inexact (/ (+ 1 (random-power rndint state max m k))
    162                            (+ 1 (expt m k)))) ) ) )
     164        (exact->inexact
     165          (/
     166            (+ 1 (random-power rndint state max m k))
     167            (+ 1 (expt m k)))) ) ) )
    163168
    164169;;;
    165170
    166171(define (native-real-precision? prec max)
    167   (or (not prec)
    168       (<= (- (floor (/ 1 prec)) 1) max)) )
     172  (or
     173    (not prec)
     174    (<= (- (floor (/ 1 prec)) 1) max)) )
    169175
    170176) ;module srfi-27-numbers
  • release/4/srfi-27/tags/3.1.9/srfi-27-uniform-random.scm

    r19090 r33848  
    1212    (except scheme + - * quotient = <)
    1313    chicken
     14    data-structures
    1415    (only numbers + - * quotient = <)
    1516    (only miscmacros exchange!)
     
    2930;;; Uniform random integers in [low high] by precision
    3031
    31 (define (*make-uniform-random-integers low high prec rand)
    32   (let ((range (quotient (+ (- high low) 1) prec)))
    33       (cond ((and (= 0 low) (= 1 prec)) (lambda () (rand range)))
    34             ((= 0 low)                  (lambda () (* (rand range) prec)))
    35             (else                       (lambda () (+ low (* (rand range) prec))))) ) )
     32(define (*make-uniform-random-integers low high precision rand)
     33  (let ((range (quotient (+ (- high low) 1) precision)))
     34    (cond
     35      ((< (- high low) precision)
     36        (constantly precision))
     37      ((= 0 range)
     38        (constantly 0))
     39      ((and (= 0 low) (= 1 precision))
     40        (lambda () (rand range)))
     41      ((= 0 low)
     42        (lambda () (* (rand range) precision)))
     43      (else
     44        (lambda () (+ low (* (rand range) precision))))) ) )
    3645
    37 (define (make-uniform-random-integers #!key (high #f) (low 0) (precision 1)
    38                                             (source (current-random-source)))
     46(define (make-uniform-random-integers
     47          #!key (high #f) (low 0) (precision 1) (source (current-random-source)))
    3948  (check-random-source 'make-uniform-random-integers source 'source)
    40   (unless high (set! high (*random-source-maximum-range source) #;(- (*random-source-maximum-range source) 1)))
     49  (unless high (set! high (- (*random-source-maximum-range source) 1))) ;(- (*random-source-maximum-range source) 1)
    4150  (check-integer 'make-uniform-random-integers high 'high)
    4251  (check-integer 'make-uniform-random-integers low 'low)
    4352  (check-positive-integer 'make-uniform-random-integers precision 'precision)
    44   ; Handle swapped bounds (could be negative)
    45   (unless (< low high) (exchange! low high))
    46   ; Cannot have a 0 range
    47   (when (= low high)
    48     (error 'make-uniform-random-integers "`low' equals `high'" low high))
    49   ; Cannot have precision outside of range
    50   (when (< (- high low) precision)
    51     (error 'make-uniform-random-integers "`precision' greater-than range" precision low high))
    5253  (values
    5354    (*make-uniform-random-integers low high precision ((@random-source-make-integers source)))
     
    5657;;; Uniform random reals in (0.0 1.0) by precion
    5758
    58 (define (make-uniform-random-reals #!key (precision #f) (source (current-random-source)))
     59(define (make-uniform-random-reals
     60          #!key (precision #f) (source (current-random-source)))
    5961  (check-random-source 'make-uniform-random-reals source 'source)
    6062  (when precision (check-real-precision 'make-uniform-random-reals precision 'precision))
  • release/4/srfi-27/tags/3.1.9/srfi-27-vector-support.scm

    r19090 r33848  
    3737;;;
    3838
    39 (define (u8vector-filled! u8vec u8gen #!optional (start 0) (end (u8vector-length u8vec)))
    40   (do ((idx start (fx+ idx 1)))
    41       ((fx= end idx) u8vec)
    42     (u8vector-set! u8vec idx (u8gen)) ) )
     39;;
    4340
    44 (define (f64vector-filled! f64vec f64gen #!optional (start 0) (end (f64vector-length f64vec)))
    45   (do ((idx start (fx+ idx 1)))
    46       ((fx= end idx) f64vec)
    47     (f64vector-set! f64vec idx (f64gen)) ) )
     41(define (make-filled! veclenf vecsetf)
     42  (letrec ((self
     43            (case-lambda
     44              ((vec gen)
     45                (self vec gen 0) )
     46              ((vec gen start)
     47                (self vec gen start (veclenf vec)) )
     48              ((vec gen start end)
     49                (do ((idx start (fx+ idx 1)))
     50                    ((fx= end idx) vec)
     51                  (vecsetf vec idx (gen)) ) ) ) ) )
     52    self ) )
    4853
    49 (define (f32vector-filled! f32vec f32gen #!optional (start 0) (end (f32vector-length f32vec)))
    50   (do ((idx start (fx+ idx 1)))
    51       ((fx= end idx) f32vec)
    52     (f32vector-set! f32vec idx (f32gen)) ) )
    53 
    54 (define (vector-filled! vec gen #!optional (start 0) (end (vector-length vec)))
     54#;
     55(define ((make-filled! veclenf vecsetf) vec gen #!optional (start 0) (end (veclenf vec)))
    5556  (do ((idx start (fx+ idx 1)))
    5657      ((fx= end idx) vec)
    57     (vector-set! vec idx (gen)) ) )
     58    (vecsetf vec idx (gen)) ) )
    5859
    59 (define (f32vector-mapi!/1 proc vec)
    60   (let ((len (f32vector-length vec)))
     60(define ((make-mapi!/1 veclenf vecref vecsetf) proc vec)
     61  (let ((len (veclenf vec)))
    6162    (do ((i 0 (fx+ i 1)))
    6263        ((fx= i len) vec)
    63       (f32vector-set! vec i (proc i (f32vector-ref vec i))) ) ) )
     64      (vecsetf vec i (proc i (vecref vec i))) ) ) )
    6465
    65 (define (f32vector-foldi/1 proc init vec)
    66   (let ((len (f32vector-length vec)))
     66(define ((make-foldi/1 veclenf vecref) proc init vec)
     67  (let ((len (veclenf vec)))
    6768    (do ((i 0 (fx+ i 1) )
    68          (acc init (proc i acc (f32vector-ref vec i)) ) )
     69         (acc init (proc i acc (vecref vec i)) ) )
    6970        ((fx= i len) acc) ) ) )
    7071
    71 (define (f64vector-mapi!/1 proc vec)
    72   (let ((len (f64vector-length vec)))
    73     (do ((i 0 (fx+ i 1)))
    74         ((fx= i len) vec)
    75       (f64vector-set! vec i (proc i (f64vector-ref vec i))) ) ) )
     72;;
    7673
    77 (define (f64vector-foldi/1 proc init vec)
    78   (let ((len (f64vector-length vec)))
    79     (do ((i 0 (fx+ i 1) )
    80          (acc init (proc i acc (f64vector-ref vec i)) ) )
    81         ((fx= i len) acc) ) ) )
     74(define u8vector-filled!
     75  (make-filled! u8vector-length u8vector-set!) )
     76
     77(define f64vector-filled!
     78  (make-filled! f64vector-length f64vector-set!) )
     79
     80(define f32vector-filled!
     81  (make-filled! f32vector-length f32vector-set!) )
     82
     83(define vector-filled!
     84  (make-filled! vector-length vector-set!) )
     85
     86(define f32vector-mapi!/1
     87  (make-mapi!/1 f32vector-length f32vector-ref f32vector-set!) )
     88
     89(define f64vector-mapi!/1
     90  (make-mapi!/1 f64vector-length f64vector-ref f64vector-set!) )
     91
     92(define f32vector-foldi/1
     93  (make-foldi/1 f32vector-length f32vector-ref) )
     94
     95(define f64vector-foldi/1
     96  (make-foldi/1 f64vector-length f64vector-ref) )
    8297
    8398;;; Vector% Support
     
    86101(define (array-rank/1? obj) (and (array? obj) (fx= 1 (array-rank obj))))
    87102
     103(define (acceptable-vector? obj)
     104  (or
     105    (vector? obj)
     106    (f32vector? obj)
     107    (f64vector? obj)
     108    #; ;NOT YET
     109    (array-rank/1? obj) ) )
     110
    88111(define (check-vector% loc obj #!optional argnam)
    89   (unless (or (vector? obj)
    90               (f32vector? obj)
    91               (f64vector? obj)
    92               #; ;NOT YET
    93               (array-rank/1? vec) )
    94     (error-vector loc obj argnam) ) )
     112  (unless (acceptable-vector? obj)
     113    (error-vector loc obj argnam) )
     114  obj )
    95115
    96 (define (vector%-length vec)
    97   (cond ((vector? vec)        (vector-length vec))
    98         ((f32vector? vec)     (f32vector-length vec))
    99         ((f64vector? vec)     (f64vector-length vec))
    100         #; ;NOT YET
    101         ((array-rank/1? vec)  (car (array-dimensions vec)))
    102         (else
    103           (error-vector #f vec))) )
     116(define ((make-oper vec-oper f32vec-oper f64vec-oper) vec . args)
     117  (cond
     118    ((vector? vec)        (apply vec-oper vec args))
     119    ((f32vector? vec)     (apply f32vec-oper vec args))
     120    ((f64vector? vec)     (apply f64vec-oper vec args))
     121    #; ;NOT YET
     122    ((array-rank/1? vec)  (apply arr-rnk-1 vec args)) ;arr-rnk-1-oper
     123    (else
     124      (error-vector #f vec))) )
    104125
    105 (define (vector%-mapi!/1 proc vec)
    106   (cond ((vector? vec)        (vector-map! proc vec))
    107         ((f32vector? vec)     (f32vector-mapi!/1 proc vec))
    108         ((f64vector? vec)     (f64vector-mapi!/1 proc vec))
    109         #; ;NOT YET
    110         ((array-rank/1? vec)  (array-map! vec (cut proc #f <>)))
    111         (else
    112           (error-vector #f vec))) )
     126(define vector%-length
     127  (make-oper vector-length f32vector-length f64vector-length) )
    113128
    114 (define (vector%-foldi/1 proc seed vec)
    115   (cond ((vector? vec)        (vector-fold proc seed vec))
    116         ((f32vector? vec)     (f32vector-foldi/1 proc seed vec))
    117         ((f64vector? vec)     (f64vector-foldi/1 proc seed vec))
    118         #; ;NOT YET
    119         ((array-rank/1? vec)  (array-fold (cut proc #f <> <>) seed vec))
    120         (else
    121           (error-vector #f vec))) )
     129(define vector%-mapi!/1
     130  (make-oper vector-map! f32vector-mapi!/1 f64vector-mapi!/1) )  ;(lambda (vec proc ) (array-map! vec (cut proc #f <>)))
    122131
    123 (define (vector%-filled! vec func)
    124   (cond ((vector? vec)        (vector-filled! vec func))
    125         ((f32vector? vec)     (f32vector-filled! vec func))
    126         ((f64vector? vec)     (f64vector-filled! vec func))
    127         #; ;NOT YET
    128         ((array-rank/1? vec)  (array-fold (lambda (x y) (func)) #f vec))
    129         (else
    130           (error-vector #f vec))) )
     132(define vector%-foldi/1
     133  (make-oper vector-fold f32vector-foldi/1 f64vector-foldi/1) )  ;(lambda (vec proc seed) (array-fold (cut proc #f <> <>) seed vec))
     134
     135(define vector%-filled!
     136  (make-oper vector-filled! f32vector-filled! f64vector-filled!) )  ;(lambda (vec func) (array-fold (lambda (x y) (func)) #f vec))
    131137
    132138(define (vector%-scale! vec factor)
  • release/4/srfi-27/tags/3.1.9/srfi-27-vector.scm

    r27249 r33848  
    3737
    3838; (in case special processing needed near limits TBD)
    39 (define-inline (*reciprocal n) (/ 1.0 n))
     39(define (*reciprocal n) (/ 1.0 n))
     40(define (*-reciprocal n) (/ -1.0 n))
     41
     42(define (vector-iota-set! vec n)
     43  (do ((i 0 (fx+ i 1)))
     44      ((fx= i n))
     45    (vector-set! vec i i) ) )
    4046
    4147;;;
     
    4349;;
    4450
    45 ; Knuth's "The Art of Computer Programming", Vol. II, 2nd ed., Algorithm P of Section 3.4.2
     51;Knuth's "The Art of Computer Programming", Vol. II, 2nd ed., Algorithm P of
     52;Section 3.4.2
     53;
    4654(define (*random-permutation! vec randoms)
    4755  (let ((n (vector-length vec)))
    48     (do ((i 0 (fx+ i 1)))
    49         ((fx= i n))
    50       (vector-set! vec i i))
     56    (vector-iota-set! vec n)
    5157    (do ((k n (fx- k 1)))
    5258        ((fx= k 1) vec)
  • release/4/srfi-27/tags/3.1.9/srfi-27.meta

    r27249 r33848  
    1616        (numbers "2.8")
    1717        (synch "2.1.0"))
    18  (files "mrg32k3a.scm" "srfi-27.meta" "srfi-27-uniform-random.scm" "mwc.scm" "srfi-27.setup" "entropy-procedure.scm" "srfi-27.release-info" "srfi-27-implementation" "srfi-27-numbers.scm" "fp-extn-w.scm" "entropy-unix.scm" "composite-random-source.scm" "entropy-source.scm" "entropy-clock.scm" "random-source.scm" "srfi-27-vector-support.scm" "srfi-27-distributions.scm" "srfi-27-vector.scm" "srfi-27.scm" "entropy-windows.scm" "moa.scm" "fp-extn-wo.scm" "entropy-support.scm" "tests/test-diehard.scm" "tests/test-confidence.scm" "tests/test-mrg32k3a.scm" "tests/run.scm" "entropy-port.scm") )
     18 (files "mrg32k3a.scm" "srfi-27.meta" "srfi-27-uniform-random.scm" "mwc.scm" "srfi-27.setup" "entropy-procedure.scm" "srfi-27.release-info" "srfi-27-implementation" "srfi-27-numbers.scm" "fp-extn-w.scm" "entropy-unix.scm" "composite-random-source.scm" "entropy-source.scm" "entropy-clock.scm" "random-source.scm" "srfi-27-vector-support.scm" "srfi-27-distributions.scm" "srfi-27-vector.scm" "srfi-27.scm" "entropy-windows.scm" "moa.scm" "fp-extn-wo.scm" "entropy-support.scm" "registration.scm" "tests/test-diehard.scm" "tests/test-confidence.scm" "tests/test-mrg32k3a.scm" "tests/run.scm" "entropy-port.scm") )
  • release/4/srfi-27/tags/3.1.9/srfi-27.scm

    r19077 r33848  
    7575(define-parameter current-entropy-source default-entropy-source
    7676  (lambda (x)
    77     (cond ((entropy-source? x) x)
    78           (else
    79             (warning-argument-type 'current-entropy-source x 'entropy-source)
    80             (current-entropy-source) ) ) ) )
    81 
     77    (cond
     78      ((entropy-source? x)
     79        x)
     80      (else
     81        (warning-argument-type 'current-entropy-source x 'entropy-source)
     82        (current-entropy-source) ) ) ) )
     83
     84(define make-entropy-source
     85  (case-lambda
     86    (()
     87      ((@entropy-source-constructor (current-entropy-source))) )
     88    ((es)
     89      (let ((ctor
     90              (cond
     91                ((entropy-source? es)
     92                  (@entropy-source-constructor es) )
     93                ((symbol? es)
     94                  (let ((ctor (registered-entropy-source es)))
     95                    (or
     96                      ctor
     97                      (error 'make-entropy-source "unregistered entropy-source name" es) ) ) )
     98                (else
     99                  (error-argument-type
     100                    'make-entropy-source es
     101                    "valid entropy-source or registered entropy-source name") ) ) ) )
     102        (ctor) ) ) ) )
     103
     104#;
    82105(define (make-entropy-source #!optional (es (current-entropy-source)))
    83106  (let ((ctor
    84107          (cond
    85             ((entropy-source? es) (@entropy-source-construtor es) )
    86             ((symbol? es)         (registered-entropy-source es) )
     108            ((entropy-source? es)
     109              (@entropy-source-constructor es) )
     110            ((symbol? es)
     111              (registered-entropy-source es) )
    87112            (else
    88113              (error-argument-type
     
    93118(define (new-entropy-source es)
    94119  (check-entropy-source 'new-entropy-source es)
    95   ((@entropy-source-construtor es)) )
     120  ((@entropy-source-constructor es)) )
    96121
    97122(define (entropy-source-name es)
     
    131156    (lambda (n)
    132157      (check-cardinal-integer 'make-u8vector n 'length)
    133       (u8vector-filled! (make-u8vector n) (lambda () (modulo (rndint) 256))) ) ) )
     158      (u8vector-filled! (make-u8vector n) (lambda () (rndint 256))) ) ) )
    134159
    135160(define (*random-source-make-f64vectors rs prec)
     
    159184(define-parameter current-random-source default-random-source
    160185  (lambda (x)
    161     (cond ((random-source? x) x)
    162           (else
    163             (warning-argument-type 'current-random-source x 'random-source)
    164             (current-random-source) ) ) ) )
    165 
     186    (cond
     187      ((random-source? x)
     188        x)
     189      (else
     190        (warning-argument-type 'current-random-source x 'random-source)
     191        (current-random-source) ) ) ) )
     192
     193(define make-random-source
     194  (case-lambda
     195    (()
     196      ((@random-source-constructor (current-random-source))) )
     197    ((es)
     198      (let ((ctor
     199              (cond
     200                ((random-source? es)
     201                  (@random-source-constructor es) )
     202                ((symbol? es)
     203                  (registered-random-source es) )
     204                (else
     205                  (error-argument-type
     206                    'make-random-source es
     207                    "valid random-source or registered random-source name") ) ) ) )
     208        (ctor) ) ) ) )
     209
     210#;
    166211(define (make-random-source #!optional (es (current-random-source)))
    167212  (let ((ctor
    168213          (cond
    169             ((random-source? es)  (@random-source-construtor es) )
    170             ((symbol? es)         (registered-random-source es) )
     214            ((random-source? es)
     215              (@random-source-constructor es) )
     216            ((symbol? es)
     217              (registered-random-source es) )
    171218            (else
    172219              (error-argument-type
     
    177224(define (new-random-source es)
    178225  (check-random-source 'new-random-source es)
    179   ((@random-source-construtor es)) )
     226  ((@random-source-constructor es)) )
    180227
    181228(define (random-source-name rs)
  • release/4/srfi-27/tags/3.1.9/srfi-27.setup

    r28425 r33848  
    1111;; Utility Modules
    1212
    13 (setup-shared-extension-module 'srfi-27-numbers (extension-version "3.1.8")
     13(setup-shared-extension-module 'srfi-27-numbers (extension-version "3.1.9")
    1414  #:inline? #t
    1515  #:types? #t
     
    1818    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    1919
    20 (setup-shared-extension-module 'srfi-27-vector-support (extension-version "3.1.8")
     20(setup-shared-extension-module 'srfi-27-vector-support (extension-version "3.1.9")
    2121  #:inline? #t
    2222  #:types? #t
     
    2525    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    2626
    27 ;; Entropy Source Modules
    28 
    29 (setup-shared-extension-module 'entropy-source (extension-version "3.1.8")
     27(setup-shared-extension-module 'registration (extension-version "3.1.9")
    3028  #:inline? #t
    3129  #:types? #t
     
    3432    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    3533
    36 (setup-shared-extension-module 'entropy-support (extension-version "3.1.8")
     34;; Entropy Source Modules
     35
     36(setup-shared-extension-module 'entropy-source (extension-version "3.1.9")
     37  #:inline? #t
     38  #:types? #t
     39  #:compile-options '(
     40    -scrutinize -optimize-level 3 -debug-level 1
     41    -no-procedure-checks -no-argc-checks -no-bound-checks) )
     42
     43(setup-shared-extension-module 'entropy-support (extension-version "3.1.9")
    3744  #:inline? #t
    3845  #:types? #t
     
    4148    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    4249
    43 (setup-shared-extension-module 'entropy-clock (extension-version "3.1.8")
     50(setup-shared-extension-module 'entropy-clock (extension-version "3.1.9")
    4451  #:inline? #t
    4552  #:types? #t
     
    4855    -no-procedure-checks) )
    4956
    50 (setup-shared-extension-module 'entropy-procedure (extension-version "3.1.8")
     57(setup-shared-extension-module 'entropy-procedure (extension-version "3.1.9")
    5158  #:inline? #t
    5259  #:types? #t
     
    5562    -no-procedure-checks) )
    5663
    57 (setup-shared-extension-module 'entropy-port (extension-version "3.1.8")
     64(setup-shared-extension-module 'entropy-port (extension-version "3.1.9")
    5865  #:inline? #t
    5966  #:types? #t
     
    6370
    6471#+unix
    65 (setup-shared-extension-module 'entropy-unix (extension-version "3.1.8")
     72(setup-shared-extension-module 'entropy-unix (extension-version "3.1.9")
    6673  #:inline? #t
    6774  #:types? #t
     
    7178
    7279#+windows
    73 (setup-shared-extension-module 'entropy-windows (extension-version "3.1.8")
     80(setup-shared-extension-module 'entropy-windows (extension-version "3.1.9")
    7481  #:inline? #t
    7582  #:types? #t
     
    8087;; Random Source Modules
    8188
    82 (setup-shared-extension-module 'random-source (extension-version "3.1.8")
     89(setup-shared-extension-module 'random-source (extension-version "3.1.9")
    8390  #:inline? #t
    8491  #:types? #t
     
    8794    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    8895
    89 (setup-shared-extension-module 'mrg32k3a (extension-version "3.1.8")
     96(setup-shared-extension-module 'mrg32k3a (extension-version "3.1.9")
    9097  #:inline? #t
    9198  #:types? #t
     
    94101    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    95102
    96 (setup-shared-extension-module 'mwc (extension-version "3.1.8")
     103(setup-shared-extension-module 'mwc (extension-version "3.1.9")
    97104  #:inline? #t
    98105  #:types? #t
     
    101108    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    102109
    103 (setup-shared-extension-module 'moa (extension-version "3.1.8")
     110(setup-shared-extension-module 'moa (extension-version "3.1.9")
    104111  #:inline? #t
    105112  #:types? #t
     
    108115    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    109116
    110 (setup-shared-extension-module 'composite-random-source (extension-version "3.1.8")
     117(setup-shared-extension-module 'composite-random-source (extension-version "3.1.9")
    111118  #:inline? #t
    112119  #:types? #t
     
    117124;; Main Modules
    118125
    119 (setup-shared-extension-module 'srfi-27 (extension-version "3.1.8")
     126(setup-shared-extension-module 'srfi-27 (extension-version "3.1.9")
    120127  #:inline? #t
    121128  #:types? #t
     
    124131    -no-procedure-checks) )
    125132
    126 (setup-shared-extension-module 'srfi-27-uniform-random (extension-version "3.1.8")
     133(setup-shared-extension-module 'srfi-27-uniform-random (extension-version "3.1.9")
    127134  #:inline? #t
    128135  #:types? #t
     
    131138    -no-procedure-checks) )
    132139
    133 (setup-shared-extension-module 'srfi-27-distributions (extension-version "3.1.8")
     140(setup-shared-extension-module 'srfi-27-distributions (extension-version "3.1.9")
    134141  #:inline? #t
    135142  #:types? #t
     
    138145    -no-procedure-checks) )
    139146
    140 (setup-shared-extension-module 'srfi-27-vector (extension-version "3.1.8")
     147(setup-shared-extension-module 'srfi-27-vector (extension-version "3.1.9")
    141148  #:inline? #t
    142149  #:types? #t
  • release/4/srfi-27/tags/3.1.9/tests/run.scm

    r28425 r33848  
     1
     2(use test)
     3(use srfi-27)
     4(use srfi-4)
     5
     6(let ((v10 (random-u8vector 10)))
     7  (newline)
     8  (print "u8vector: " v10)
     9  (test "random-u8vector ?" #t (u8vector? v10))
     10  (test "random-u8vector 10" 10 (u8vector-length v10)) )
     11
     12(let ((v10 (random-f64vector 10)))
     13  (newline)
     14  (print "f64vector: " v10)
     15  (test "random-f64vector ?" #t (f64vector? v10))
     16  (test "random-f64vector 10" 10 (f64vector-length v10)) )
     17
    118(use utils)
    219
    320(system* "csi -n -s test-mrg32k3a.scm")
    421(system* "csi -n -s test-confidence")
    5 ;(system* "csi -n -s test-diehard")
     22;(system* "csi -n -s test-diehard") ;errors
  • release/4/srfi-27/tags/3.1.9/tests/test-diehard.scm

    r19077 r33848  
    1414  (unix
    1515    (use entropy-unix)
    16     (current-entropy-source (make-entropy-source 'entropy-random-device)) )
     16    (current-entropy-source (make-entropy-source 'random-device)) )
    1717  (else) )
    1818
     
    6666;    The message digest is md5sum = 750ac219ff40c50bb2d04ff5eff9b24c.
    6767
     68(use md5 message-digest-bv)
     69(import (only utils read-all))
     70
     71(define (md5-digest port)
     72  (message-digest-string md5-primitive (read-all port)) )
     73
    6874(define (write-diehard filename s bytes-per-call calls)
    6975  (let ((port (open-output-file filename))
     
    7581          (do ((i 0 (fx+ i 1)))
    7682              ((fx= i calls))
    77             (when (fx= 0 (fxmod i 1000)) (display i errprt) (display #\return errprt))
     83            (when (fx= 0 (fxmod i 1000))
     84              (display i errprt) (display #\return errprt))
    7885            (do ((x (rand n) (fx/ x 256))
    7986                 (k bytes-per-call (fx- k 1)))
    8087                ((fx= 0 k))
    81                 (write-char (integer->char (fxmod x 256)))))
     88                (write-char (integer->char (fxmod x 256)))) ) )
    8289          (newline errprt) )
    83         (close-output-port port)))))
     90        (close-output-port port)) ) )
    8491
    8592(define (check-diehard s bytes-per-call calls mdexpt)
     
    9198        (close-input-port port)
    9299        (if (equal? mdexpt md)
    93             (print "Ok")
    94             (print "Expected: " mdexpt " Received: " md))))))
     100          (print "Ok")
     101          (print "Expected: " mdexpt " Received: " md))))))
    95102
    96103(print "(Please wait. This will take a long while!)")
  • release/4/srfi-27/trunk/composite-random-source.scm

    r27249 r33848  
    2424  (let ((random-states?
    2525         (lambda (obj k n)
    26            (and (pair? obj)
    27                 (eq? k (car obj))
    28                 (list? obj)
    29                 (fx= n (fx- (length obj) 1)))))
    30         (state-ref (lambda (s) ((@random-source-state-ref s))))
    31         (state-set! (lambda (s state) ((@random-source-state-ref s) state)))
    32         (getmakints (lambda (s) ((@random-source-make-integers s)))) )
     26           (and
     27            (pair? obj)
     28            (eq? k (car obj))
     29            (list? obj)
     30            (= n (- (length obj) 1)))))
     31        (state-ref
     32          (lambda (s)
     33            ((@random-source-state-ref s))))
     34        (state-set!
     35          (lambda (s state)
     36            ((@random-source-state-ref s) state)))
     37        (make-integers
     38          (lambda (s)
     39            ((@random-source-make-integers s)))) )
    3340    (lambda (comb-int comb-real name docu log2-period maxrng srcs)
    3441      (let ((srcs-cnt (length srcs))
    35             (make-integers (map getmakints srcs)) )
     42            (make-integers (map make-integers srcs)) )
    3643        (letrec ((ctor
    3744                  (lambda (#!optional (name name) (docu docu))
     
    6370                      ;randomize!
    6471                      (lambda (e)
    65                         (for-each (lambda (s) ((@random-source-randomize! s) e)) srcs))
     72                        (for-each
     73                          (lambda (s)
     74                            ((@random-source-randomize! s) e))
     75                          srcs) )
    6676                      ;pseudo-randomize!
    6777                      (lambda (i j)
    68                         (for-each (lambda (s) ((@random-source-pseudo-randomize! s) i j) ) srcs) )
     78                        (for-each
     79                          (lambda (s)
     80                            ((@random-source-pseudo-randomize! s) i j) )
     81                          srcs) )
    6982                      ;make-integers
    7083                      (lambda ()
    71                         (lambda (n) (comb-int (map (cut <> n) make-integers) n)))
     84                        (lambda (n)
     85                          (comb-int (map (cut <> n) make-integers) n)))
    7286                      ;make-reals
    7387                      (lambda (unit)
    7488                        (let ((makrels
    75                                 (map (lambda (s) ((@random-source-make-reals s) unit)) srcs)))
     89                                (map
     90                                  (lambda (s)
     91                                    ((@random-source-make-reals s) unit) )
     92                                  srcs)))
    7693                          (lambda ()
    7794                            (comb-real (map (cut <>) makrels) unit) ) ) ) ) ) ) )
  • release/4/srfi-27/trunk/entropy-clock.scm

    r23071 r33848  
    1010    scheme
    1111    chicken
    12     foreign
    13     entropy-source
    14     entropy-support)
     12    foreign)
    1513
    16   (require-library entropy-source entropy-support)
     14  (use entropy-source entropy-support)
    1715
    1816;;;
    1917
     18#|
    2019#>
    2120#include <time.h>
     
    3635<#
    3736
    38 
    3937(define f64init (foreign-lambda double "f64init"))
    4038(define f64rand (foreign-lambda double "f64rand" double))
     39|#
     40
     41(import extras)
     42
     43(define (f64init) (randomize))
     44(define (f64rand n) (random n))
    4145
    4246;;; Entropy from system clock
    4347
    4448(define (make-entropy-source-system-clock)
    45   (let ((f64seed (f64init)))
    46     (let ((_f64rand (lambda () (set! f64seed (f64rand f64seed)) f64seed)))
    47       (*make-entropy-source
    48         ;
    49         make-entropy-source-system-clock
    50         ;
    51         'system-clock
    52         ;
    53         "Entropy from system clock"
    54         ;
    55         (make-entropic-u8/f64 _f64rand)
    56         ;
    57         _f64rand
    58         ;
    59         (lambda (u8cnt u8vec) (entropic-u8vector-filled/f64 u8cnt u8vec _f64rand) )
    60         ;
    61         (lambda (f64cnt f64vec) (entropic-f64vector-filled f64cnt f64vec _f64rand) ) ) ) ) )
     49  (let* ((f64seed (f64init))
     50         (_f64rand (lambda () (set! f64seed (f64rand f64seed)) f64seed)) )
     51    (*make-entropy-source
     52      ;
     53      make-entropy-source-system-clock
     54      ;
     55      'system-clock
     56      ;
     57      "Entropy from system clock"
     58      ;
     59      (make-entropic-u8/f64 _f64rand)
     60      ;
     61      _f64rand
     62      ;
     63      (lambda (u8cnt u8vec) (entropic-u8vector-filled/f64 u8cnt u8vec _f64rand) )
     64      ;
     65      (lambda (f64cnt f64vec) (entropic-f64vector-filled f64cnt f64vec _f64rand) ) ) ) )
    6266
    6367(register-entropy-source! 'system-clock make-entropy-source-system-clock)
  • release/4/srfi-27/trunk/entropy-port.scm

    r20956 r33848  
    99    ;
    1010    make-entropy-source/port
    11     make-entropy-source/port-open
    12     make-entropy-source/port-open-timed
    13     make-entropy-source/file)
     11    make-entropy-source/port-open make-entropy-source/port-open-timed
     12    make-entropy-source/file make-entropy-source/file-timed)
    1413
    1514  (import
    1615    scheme
    1716    chicken
    18     (only type-checks
    19       check-input-port check-procedure check-symbol check-string)
    20     (only type-errors warning-argument-type)
    21     entropy-source
    22     entropy-support
    23     timed-resource)
     17    (only type-checks check-input-port check-procedure check-symbol check-string)
     18    (only type-errors warning-argument-type))
    2419
    2520  (require-library
    26     type-checks type-errors
    27     entropy-source entropy-support
    28     timed-resource)
     21    type-checks type-errors)
     22
     23(use entropy-source entropy-support timed-resource miscmacros)
    2924
    3025;;
     
    10095  (let ((to (entropy-port-lifetime)))
    10196    (if to
    102         ;then auto-close on timeout
    103         (*make-entropy-source/port-open-timed opener to name docu)
    104         ;else keep open
    105         (let ((port (opener)))
    106           (set-finalizer! port close-input-port)
    107           (*make-entropy-source/port port name docu) ) ) ) )
     97      ;then auto-close on timeout
     98      (*make-entropy-source/port-open-timed opener to name docu)
     99      ;else keep open
     100      (let ((port (opener)))
     101        (set-finalizer! port close-input-port)
     102        (*make-entropy-source/port port name docu) ) ) ) )
    108103
    109104;;; Timeout Seconds
     
    111106(define-constant DEFAULT-ENTROPY-PORT-CLOSE-SECONDS 60.0)
    112107
    113 (define entropy-port-lifetime
    114   (let ((lt DEFAULT-ENTROPY-PORT-CLOSE-SECONDS))
    115     (lambda args
    116       (if (null? args) lt
    117           (let ((x (car args)))
    118             (cond
    119               ((not x)                        (set! lt #f) )
    120               ((and (real? x) (positive? x))  (set! lt x) )
    121               (else
    122                 (warning-argument-type 'entropy-port-lifetime x 'seconds) ) ) ) ) ) ) )
     108(define-parameter entropy-port-lifetime DEFAULT-ENTROPY-PORT-CLOSE-SECONDS
     109  (lambda (x)
     110    (cond
     111      ((boolean? x)
     112        (and x DEFAULT-ENTROPY-PORT-CLOSE-SECONDS) )
     113      ((and (real? x) (positive? x))
     114        x )
     115      (else
     116        (warning-argument-type 'entropy-port-lifetime x 'seconds)
     117        (entropy-port-lifetime) ) ) ) )
    123118
    124119;;; Entropy from some port
     
    126121(define (make-entropy-source/port port
    127122          #!optional
    128             (name (gensym 'port-))
    129             (docu "Entropy from an open port"))
     123          (name (gensym 'port-))
     124          (docu "Entropy from an open port"))
    130125  (check-input-port 'make-entropy-source/port port)
    131126  (check-symbol 'make-entropy-source/port name 'name)
     
    137132(define (make-entropy-source/port-open opener
    138133          #!optional
    139             (name (gensym 'port-))
    140             (docu "Entropy from port"))
     134          (name (gensym 'port-))
     135          (docu "Entropy from port"))
    141136  (check-procedure 'make-entropy-source/port-open opener 'open-procedure)
    142137  (check-symbol 'make-entropy-source/port-open name 'name)
     
    148143(define (make-entropy-source/port-open-timed opener timeout
    149144          #!optional
    150             (name (gensym 'timed-port-))
    151             (docu "Entropy from timed open port"))
     145          (name (gensym 'timed-port-))
     146          (docu "Entropy from timed open port"))
    152147  (check-procedure 'make-entropy-source/port-open-timed opener 'open-procedure)
     148  ;(check- timeout 'timeout)
    153149  (check-symbol 'make-entropy-source/port-open-timed name 'name)
    154150  (check-string 'make-entropy-source/port-open-timed docu 'documentation)
    155151  (*make-entropy-source/port-open-timed opener timeout name docu) )
     152
     153;;;
     154
     155(define (make-entropy-open-file namstr)
     156  (make-open-binary-input-file namstr) )
    156157
    157158;;; Entropy from some file (binary)
     
    159160(define (make-entropy-source/file namstr
    160161          #!optional
    161             (name (gensym 'file-))
    162             (docu (string-append "Entropy from file \"" namstr "\"")))
     162          (name (gensym 'file-))
     163          (docu (string-append "Entropy from file \"" namstr "\"")))
    163164  (check-string 'make-entropy-source/file namstr 'filename)
    164165  (check-symbol 'make-entropy-source/file name 'name)
    165166  (check-string 'make-entropy-source/file docu 'documentation)
    166   (*make-entropy-source/port-open (make-open-binary-input-file namstr) name docu) )
     167  (*make-entropy-source/port-open (make-entropy-open-file namstr) name docu) )
     168
     169(define (make-entropy-source/file-timed namstr timeout
     170          #!optional
     171          (name (gensym 'file-))
     172          (docu (string-append "Entropy from file \"" namstr "\"")))
     173  (check-string 'make-entropy-source/file-timed namstr 'filename)
     174  ;(check- timeout 'timeout)
     175  (check-symbol 'make-entropy-source/file-timed name 'name)
     176  (check-string 'make-entropy-source/file-timed docu 'documentation)
     177  (*make-entropy-source/port-open-timed (make-entropy-open-file namstr) timeout name docu) )
    167178
    168179) ;module entropy-port
  • release/4/srfi-27/trunk/entropy-source.scm

    r28099 r33848  
    99    *entropy-source-name
    1010    *entropy-source-documentation
    11     @entropy-source-construtor
     11    @entropy-source-constructor
    1212    @entropy-source-u8
    1313    @entropy-source-f64
     
    1515    @entropy-source-f64vector
    1616    ;
     17    entropy-source-integer
    1718    entropy-source-f64-integer
    1819    ;
     
    2829    (only srfi-1 alist-cons alist-delete!)
    2930    (only type-checks define-check+error-type check-procedure check-symbol))
     31  (require-library data-structures srfi-1 type-checks)
    3032
    31   (require-library data-structures srfi-1 type-checks)
     33  (use registration)
    3234
    3335;;
     
    3638  (*make-entropy-source ctor name docu u8 f64 u8vec f64vec)
    3739  entropy-source?
    38   (ctor       @entropy-source-construtor)
     40  (ctor       @entropy-source-constructor)
    3941  (name       *entropy-source-name)
    4042  (docu       *entropy-source-documentation)
     
    4850;;
    4951
    50 (define (entropy-source-f64-integer entropy-source)
     52(define (entropy-source-integer entropy-source)
    5153  ;ugly but ...
    5254  (let ((get-f64 (@entropy-source-f64 entropy-source)))
     
    5658        (loop (get-f64)) ) ) ) )
    5759
     60(define entropy-source-f64-integer entropy-source-integer)
     61
    5862;; Entropy Source Constructor Registry
    5963
    60 (define +sources+ '())
     64(define +reg+ (make-registration 'entropy-source '()))
    6165
    62 (define (registered-entropy-sources) (map car +sources+))
     66(define (registered-entropy-sources)
     67  ((@registration-key +reg+)) )
    6368
    64 (define (registered-entropy-source name) (alist-ref name +sources+ eq?))
     69(define (registered-entropy-source name)
     70  ((@registration-ref +reg+) name) )
    6571
    66 (define (unregister-entropy-source name) (set! +sources+ (alist-delete! name +sources+ eq?)))
     72(define (unregister-entropy-source name)
     73  ((@registration-deref! +reg+) name) )
    6774
    6875(define (register-entropy-source! name ctor)
    69   (check-symbol 'register-entropy-source! name)
    70   (check-procedure 'register-entropy-source! ctor)
    71   (set! +sources+ (alist-update! name ctor +sources+ eq?)) )
     76  ((@registration-register! +reg+) name ctor) )
    7277
    7378) ;entropy-source
  • release/4/srfi-27/trunk/entropy-support.scm

    r23071 r33848  
    7676        (dbl 0.0) )
    7777    (lambda ()
    78       (if (fx= idx BYTES/F64) (begin (set! dbl (f64gen)) (set! idx 0))
    79           (set! idx (fx+ idx 1)) )
     78      (if (fx= idx BYTES/F64)
     79        (begin
     80          (set! dbl (f64gen))
     81          (set! idx 0))
     82        (set! idx (fx+ idx 1)) )
    8083      (double_peek_byte dbl idx) ) ) )
    8184
     
    8790        (let loop ()
    8891          (u8vector-filled! f64buf u8gen 0 BYTES/F64)
    89           (if (good_positive_double f64buf #$tmpdbl) tmpdbl
    90               (loop) ) ) ) ) ) )
     92          (if (good_positive_double f64buf #$tmpdbl)
     93            tmpdbl
     94            (loop) ) ) ) ) ) )
    9195
    9296(define (make-entropic-f64/u8 u8gen)
     
    96100        (u8vector-filled! f64buf u8gen 0 BYTES/F64)
    97101        (let ((tmpdbl (good_positive_double f64buf)))
    98           (if (fp= -1.0 tmpdbl) (loop)
     102          (if (fp= -1.0 tmpdbl)
     103            (loop)
    99104            tmpdbl ) ) ) ) ) )
    100105
     
    106111
    107112(define (entropic-u8vector-filled/f64 u8cnt u8vec f64gen)
    108   (let ((u8vec (or u8vec (make-u8vector u8cnt))))
    109     (let* ((f64cnt (fx/ u8cnt BYTES/F64))
    110            (f64vec (f64vector-filled! (make-f64vector f64cnt) f64gen))
    111            (u8rem (fxmod u8cnt BYTES/F64))
    112            (u8len (fx- u8cnt u8rem)) )
    113         (move-memory! f64vec u8vec u8len)               ; whole
    114         (when (fx< 0 u8rem)
    115           (let ((u8gen (make-entropic-u8/f64 f64gen)))  ; remaining
    116             (do ((idx u8len (fx+ idx 1)))
    117                 ((fx>= idx u8cnt))
    118               (u8vector-set! u8vec idx (u8gen)) ) ) ) )
    119     u8vec ) )
     113  (let* ((u8vec (or u8vec (make-u8vector u8cnt)))
     114         (f64cnt (fx/ u8cnt BYTES/F64))
     115         (f64vec (f64vector-filled! (make-f64vector f64cnt) f64gen))
     116         (u8rem (fxmod u8cnt BYTES/F64))
     117         (u8len (fx- u8cnt u8rem)) )
     118    (move-memory! f64vec u8vec u8len)               ; whole
     119    (when (fx< 0 u8rem)
     120      (let ((u8gen (make-entropic-u8/f64 f64gen)))  ; remaining
     121        (do ((idx u8len (fx+ idx 1)))
     122            ((fx>= idx u8cnt))
     123          (u8vector-set! u8vec idx (u8gen)) ) ) ) )
     124    u8vec )
    120125
    121126(define (entropic-f64vector-filled/u8 f64cnt f64vec u8gen)
     
    145150        (let loop ()
    146151          (let ((len (read-u8vector! BYTES/F64 f64buf port)))
    147             (cond ((< len BYTES/F64)                      0.0)
    148                   ((good_positive_double f64buf #$tmpdbl) tmpdbl)
    149                   (else                                   (loop) ) ) ) ) ) ) ) )
     152            (cond
     153              ((< len BYTES/F64)                      0.0)
     154              ((good_positive_double f64buf #$tmpdbl) tmpdbl)
     155              (else                                   (loop) ) ) ) ) ) ) ) )
    150156
    151157(define port-entropic-f64
     
    154160      (let loop ()
    155161        (let ((len (read-u8vector! BYTES/F64 f64buf port)))
    156           (if (< len BYTES/F64) 0.0
     162          (if (< len BYTES/F64)
     163            0.0
    157164            (let ((tmpdbl (good_positive_double f64buf)))
    158               (if (fp= -1.0 tmpdbl) (loop)
     165              (if (fp= -1.0 tmpdbl)
     166                (loop)
    159167                tmpdbl ) ) ) ) ) ) ) )
    160168
    161169(define (port-entropic-u8vector port u8cnt u8vec)
    162   (if u8vec (begin (read-u8vector! u8cnt u8vec port) u8vec)
    163       (read-u8vector u8cnt port) ) )
     170  (if u8vec
     171    (begin
     172      (read-u8vector! u8cnt u8vec port)
     173      u8vec)
     174    (read-u8vector u8cnt port) ) )
    164175
    165176(define (port-entropic-f64vector port f64cnt f64vec #!optional (f64get port-entropic-f64))
  • release/4/srfi-27/trunk/moa.scm

    r28099 r33848  
    218218
    219219(define (moa-pack-state external-state)
    220   (if (not (and (pair? external-state)
    221                 (eq? EXTERNAL-ID (car external-state))
    222                 (fx= (fx+ STATE-LENGTH 1) (length external-state))))
    223       (error 'moa-pack-state "malformed state" external-state)
    224       (let ((state (make-state)))
    225         (do ((i 0 (fx+ i 1))
    226              (ss (cdr external-state) (cdr ss)) )
    227             ((null? ss) state)
    228           (let ((x (car ss)))
    229             (if (and (integer? x) (<= 0 x 4294967295)) (u32vector-set! state i x)
    230                 (error 'moa-pack-state "illegal value" x) ) ) ) ) ) )
     220  (unless
     221    (and
     222      (pair? external-state)
     223      (eq? EXTERNAL-ID (car external-state))
     224      (fx= (fx+ STATE-LENGTH 1) (length external-state)))
     225    (error 'moa-pack-state "malformed state" external-state) )
     226  (let ((state (make-state)))
     227    (do ((i 0 (fx+ i 1))
     228         (ss (cdr external-state) (cdr ss)) )
     229        ((null? ss) state)
     230      (let ((x (car ss)))
     231        (if (and (integer? x) (<= 0 x 4294967295))
     232          (u32vector-set! state i x)
     233          (error 'moa-pack-state "illegal value" x) ) ) ) ) )
    231234
    232235(define (moa-randomize-state state entropy-source)
    233   (init_state state (exact->inexact (modulo (fpabs (entropy-source-f64-integer entropy-source)) (expt 2 64))))
     236  (init_state
     237    state
     238    (exact->inexact
     239      (modulo
     240        (fpabs (entropy-source-f64-integer entropy-source))
     241        (expt 2 64))))
    234242  state )
    235243
     
    292300      ;
    293301      (lambda (prec)
    294         (cond ((native-real-precision? prec eMAX)
    295                 (lambda () (moa-random-real state)))
    296               (else
    297                 (lambda () (moa-random-real-mp state prec)))))) ) )
     302        (cond
     303          ((native-real-precision? prec eMAX)
     304            (lambda () (moa-random-real state)))
     305          (else
     306            (lambda () (moa-random-real-mp state prec)))))) ) )
    298307
    299308;;;
  • release/4/srfi-27/trunk/mrg32k3a.scm

    r23730 r33848  
    266266        (when (fpzero? (fp+ a (fp+ b c)))
    267267          (error 'mrg32k3a-pack-state "illegal degenerate state" external-state) ) )
    268       (if (not (and (pair? external-state)
    269                     (eq? EXTERNAL-ID (car external-state))
    270                     (fx= STATE-LENGTH (length (cdr external-state)))))
    271           (error 'mrg32k3a-pack-state "malformed state" external-state)
    272           (let ((state (make-state)))
    273             (do ((i 0 (fx+ i 1))
    274                  (ss (cdr external-state) (cdr ss))
    275                  (ms state-M (cdr ms)) )
    276                 ((null? ss)
    277                   (check-m-state
    278                     (f64vector-ref state 0)
    279                     (f64vector-ref state 1)
    280                     (f64vector-ref state 2))
    281                   (check-m-state
    282                     (f64vector-ref state 3)
    283                     (f64vector-ref state 4)
    284                     (f64vector-ref state 5))
    285                   state )
    286               (checked-set! state (car ss) i (car ms)) ) ) ) ) ) )
     268      (unless (and
     269                (pair? external-state)
     270                (eq? EXTERNAL-ID (car external-state))
     271                (fx= STATE-LENGTH (length (cdr external-state))))
     272          (error 'mrg32k3a-pack-state "malformed state" external-state) )
     273      (let ((state (make-state)))
     274        (do ((i 0 (fx+ i 1))
     275             (ss (cdr external-state) (cdr ss))
     276             (ms state-M (cdr ms)) )
     277            ((null? ss)
     278              (check-m-state
     279                (f64vector-ref state 0)
     280                (f64vector-ref state 1)
     281                (f64vector-ref state 2))
     282              (check-m-state
     283                (f64vector-ref state 3)
     284                (f64vector-ref state 4)
     285                (f64vector-ref state 5))
     286              state )
     287          (checked-set! state (car ss) i (car ms)) ) ) ) ) )
    287288
    288289; Pseudo-Randomization
     
    393394
    394395      (define (power a e) ; A^e
    395         (cond ((fpzero? e)  A^0)
    396               ((fp= e 1.0)  a)
    397               ((fpeven? e)  (power (product a a) (fpquotient e 2.0)))
    398               (else         (product (power a (fp- e 1.0)) a)) ) )
     396        (cond
     397          ((fpzero? e)  A^0)
     398          ((fp= e 1.0)  a)
     399          ((fpeven? e)  (power (product a a) (fpquotient e 2.0)))
     400          (else         (product (power a (fp- e 1.0)) a)) ) )
    399401
    400402      ; precompute A^(2^127) and A^(2^76)
     
    403405        (letrec ((power-power  ; A^(2^b)
    404406                  (lambda (a b)
    405                     (if (fpzero? b) a
    406                         (power-power (product a a) (fp- b 1.0))))))
     407                    (if (fpzero? b)
     408                      a
     409                      (power-power (product a a) (fp- b 1.0))))))
    407410          (set! mrg32k3a-gen0 (power-power A 127.0))
    408411          (set! mrg32k3a-gen1 (power-power A 76.0))
     
    410413
    411414      ; compute M = A^(16 + i*2^127 + j*2^76)
    412       (let ((M (product mrg32k3a-gen2
    413                         (product (power mrg32k3a-gen0 (fpremainder i fp2^28))
    414                                  (power mrg32k3a-gen1 (fpremainder j fp2^28))))))
     415      (let ((M
     416              (product
     417                mrg32k3a-gen2
     418                (product
     419                  (power mrg32k3a-gen0 (fpremainder i fp2^28))
     420                  (power mrg32k3a-gen1 (fpremainder j fp2^28))))))
    415421        ; the new state
    416422        (f64vector
     
    422428         (f64vector-ref M 15)) ) ) ) )
    423429
     430; G. Marsaglia's simple 16-bit generator with carry
     431(define (make-gms16wc entropy-source)
     432  (let ((random-m
     433         (let ((x (fpremainder ((@entropy-source-f64 entropy-source)) fp2^16)))
     434           (lambda ()
     435             (let ((y (fpremainder x fp2^16)))
     436               (set! x (fp+ (fp* 30903.0 y) (fpquotient x fp2^16)))
     437               y ) ) ) ) )
     438    (lambda (n)
     439      ; m < n < m^2
     440      (fpremainder (fp+ (fp* (random-m) fp2^16) (random-m)) n) ) ) )
     441
    424442; True Randomization
    425443; ==================
     
    432450(define (mrg32k3a-randomize-state state entropy-source)
    433451  ;; G. Marsaglia's simple 16-bit generator with carry
    434   (let ((random
    435          (let ((random-m
    436                  (let ((x (fpremainder ((@entropy-source-f64 entropy-source)) fp2^16)))
    437                    (lambda ()
    438                      (let ((y (fpremainder x fp2^16)))
    439                        (set! x (fp+ (fp* 30903.0 y) (fpquotient x fp2^16)))
    440                        y ) ) ) ) )
    441            (lambda (n)      ; m < n < m^2
    442              (fpremainder (fp+ (fp* (random-m) fp2^16) (random-m)) n) ) ) ) )
     452  (let ((random (make-gms16wc entropy-source)))
    443453    ; the new state
    444454    (f64vector
     
    503513      ;
    504514      (lambda (prec)
    505         (cond ((native-real-precision? prec eM1)
    506                 (lambda () (mrg32k3a-random-real state)))
    507               (else
    508                 (lambda () (mrg32k3a-random-real-mp state prec)))))) ) )
     515        (cond
     516          ((native-real-precision? prec eM1)
     517            (lambda () (mrg32k3a-random-real state)))
     518          (else
     519            (lambda () (mrg32k3a-random-real-mp state prec)))))) ) )
    509520
    510521;;;
  • release/4/srfi-27/trunk/mwc.scm

    r28099 r33848  
    212212
    213213(define (mwc-pack-state external-state)
    214   (if (not (and (pair? external-state)
    215                 (eq? EXTERNAL-ID (car external-state))
    216                 (fx= (fx+ STATE-LENGTH 1) (length external-state))))
    217       (error 'mwc-pack-state "malformed state" external-state)
    218       (let* ((state (make-state))
    219              (setter
    220                (lambda (i x)
    221                  (if (and (integer? x) (<= 0 x 4294967295)) (u32vector-set! state i x)
    222                      (error 'mwc-pack-state "illegal value" x)))) )
    223         (setter 0 (cadr external-state))
    224         (setter 1 (caddr external-state))
    225         state ) ) )
     214  (unless (and
     215            (pair? external-state)
     216            (eq? EXTERNAL-ID (car external-state))
     217            (fx= (fx+ STATE-LENGTH 1) (length external-state)))
     218      (error 'mwc-pack-state "malformed state" external-state) )
     219  (let* ((state (make-state))
     220         (setter
     221          (lambda (i x)
     222            (if (and (integer? x) (<= 0 x 4294967295))
     223              (u32vector-set! state i x)
     224              (error 'mwc-pack-state "illegal value" x)))) )
     225    (setter 0 (cadr external-state))
     226    (setter 1 (caddr external-state))
     227    state ) )
    226228
    227229;; 64 bit entropy used as a bit source, not a number source!
    228230(define (mwc-randomize-state state entropy-source)
    229   (init_state state (exact->inexact (modulo (fpabs (entropy-source-f64-integer entropy-source)) (expt 2 64))))
     231  (init_state
     232    state
     233    (exact->inexact
     234      (modulo
     235        (fpabs (entropy-source-f64-integer entropy-source))
     236        (expt 2 64))))
    230237  state )
    231238
     
    290297      ;
    291298      (lambda (prec)
    292         (cond ((native-real-precision? prec eMAX)
    293                 (lambda () (mwc-random-real state)))
    294               (else
    295                 (lambda () (mwc-random-real-mp state prec)))))) ) )
     299        (cond
     300          ((native-real-precision? prec eMAX)
     301              (lambda () (mwc-random-real state)))
     302          (else
     303            (lambda () (mwc-random-real-mp state prec)))))) ) )
    296304
    297305;;;
  • release/4/srfi-27/trunk/random-source.scm

    r19090 r33848  
    1212    *random-source-maximum-range
    1313    *random-source-entropy-source *random-source-entropy-source-set!
    14     @random-source-construtor
    15     @random-source-state-ref
    16     @random-source-state-set!
    17     @random-source-randomize!
    18     @random-source-pseudo-randomize!
    19     @random-source-make-integers
    20     @random-source-make-reals
     14    @random-source-constructor
     15    @random-source-state-ref @random-source-state-set!
     16    @random-source-randomize! @random-source-pseudo-randomize!
     17    @random-source-make-integers @random-source-make-reals
    2118    ;
    2219    registered-random-sources
     
    3128    (only srfi-1 alist-cons alist-delete!)
    3229    (only type-checks define-check+error-type check-procedure check-symbol))
     30  (require-library data-structures srfi-1 type-checks)
    3331
    34   (require-library data-structures srfi-1 type-checks)
     32  (use registration)
    3533
    3634;;
     
    4644    make-integers make-reals)
    4745  random-source?
    48   (ctor               @random-source-construtor)
     46  (ctor               @random-source-constructor)
    4947  (name               *random-source-name)
    5048  (docu               *random-source-documentation)
     
    6361;; Random Source Constructor Registry
    6462
    65 (define +sources+ '())
     63(define +reg+ (make-registration 'random-source '()))
    6664
    67 (define (registered-random-sources) (map car +sources+))
     65(define (registered-random-sources)
     66  ((@registration-key +reg+)) )
    6867
    69 (define (registered-random-source name) (alist-ref name +sources+ eq?))
     68(define (registered-random-source name)
     69  ((@registration-ref +reg+) name) )
    7070
    71 (define (unregister-random-source name) (set! +sources+ (alist-delete! name +sources+ eq?)))
     71(define (unregister-random-source name)
     72  ((@registration-deref! +reg+) name) )
    7273
    7374(define (register-random-source! name ctor)
    74   (check-symbol 'register-random-source! name)
    75   (check-procedure 'register-random-source! ctor)
    76   (set! +sources+ (alist-update! name ctor +sources+ eq?)) )
     75  ((@registration-register! +reg+) name ctor) )
    7776
    7877) ; module random-source
  • release/4/srfi-27/trunk/srfi-27-distributions.scm

    r22477 r33848  
    4444(define (check-nonzero-real loc obj #!optional argnam)
    4545  (unless (and (real? obj) (not (zero? obj)))
    46     (error-argument-type loc obj "nonzero-real" argnam)) )
     46    (error-argument-type loc obj "nonzero-real" argnam))
     47  obj )
    4748
    4849(define (check-nonnegative-real loc obj #!optional argnam)
    4950  (unless (and (real? obj) (not (negative? obj)))
    50     (error-argument-type loc obj "nonnegative-real" argnam)) )
     51    (error-argument-type loc obj "nonnegative-real" argnam))
     52  obj )
    5153
    5254(define (check-positive-real loc obj #!optional argnam)
    5355  (unless (and (real? obj) (positive? obj))
    54     (error-argument-type loc obj "positive-real" argnam)) )
     56    (error-argument-type loc obj "positive-real" argnam))
     57  obj )
    5558
    5659(define (check-real-open-interval loc obj mn mx #!optional argnam)
    5760  (check-real loc obj argnam)
    58   (check-open-interval loc obj mn mx argnam) )
     61  (check-open-interval loc obj mn mx argnam)
     62  obj )
    5963
    6064(define (check-real-closed-interval loc obj mn mx #!optional argnam)
    6165  (check-real loc obj argnam)
    62   (check-closed-interval loc obj mn mx argnam) )
     66  (check-closed-interval loc obj mn mx argnam)
     67  obj )
    6368
    6469#;
    6570(define (check-real-precision loc obj #!optional argnam)
    66   (check-real-open-interval loc obj 0 1 argnam) )
     71  (check-real-open-interval loc obj 0 1 argnam)
     72  obj )
    6773
    6874(define (check-real-unit loc obj #!optional argnam)
    69   (check-real-closed-interval loc obj 0 1 argnam) )
     75  (check-real-closed-interval loc obj 0 1 argnam)
     76  obj )
    7077
    7178;;;
     
    7784
    7885; (in case special processing needed near limits TBD)
    79 (define-inline (*reciprocal n) (/ 1.0 n))
    80 (define-inline (*-reciprocal n) (/ -1.0 n))
    81 
    82 (define (fxadd1 n) (fx+ 1 n))
     86(define (*reciprocal n) (/ 1.0 n))
     87(define (*-reciprocal n) (/ -1.0 n))
    8388
    8489;;; Normal distribution
     
    9196    (lambda ()
    9297      (if next
    93           (let ((result next))
    94             (set! next #f)
    95             (+ mu (* sigma result)))
    96           (let loop ()
    97             (let* ((v1 (- (* 2.0 (randoms)) 1.0))
    98                    (v2 (- (* 2.0 (randoms)) 1.0))
    99                    (s (+ (* v1 v1) (* v2 v2))))
    100               (if (<= 1.0 s)
    101                   (loop)
    102                   (let ((scale (sqrt (/ (* -2.0 (log s)) s))))
    103                     (set! next (* scale v2))
    104                     (+ mu (* sigma scale v1))))))))) )
    105 
    106 (define (make-random-normals #!key (mu 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
     98        (let ((result next))
     99          (set! next #f)
     100          (+ mu (* sigma result)))
     101        (let loop ()
     102          (let* ((v1 (- (* 2.0 (randoms)) 1.0))
     103                 (v2 (- (* 2.0 (randoms)) 1.0))
     104                 (s (+ (* v1 v1) (* v2 v2))) )
     105            (if (<= 1.0 s)
     106              (loop)
     107              (let ((scale (sqrt (/ (* -2.0 (log s)) s))))
     108                (set! next (* scale v2))
     109                (+ mu (* sigma scale v1))))))))) )
     110
     111(define (make-random-normals
     112          #!key (mu 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
    107113  (check-real 'make-random-normals mu 'mu)
    108114  (check-nonzero-real 'make-random-normals sigma 'sigma)
     
    119125(define (*make-random-exponentials mu randoms)
    120126  (if (= 1.0 mu)
    121       (lambda () (- (log (randoms))))
    122       (lambda () (* mu (- (log (randoms)))))) )
    123 
    124 (define (make-random-exponentials #!key (mu 1.0) (randoms (make-uniform-random-reals)))
     127    (lambda () (- (log (randoms))))
     128    (lambda () (* mu (- (log (randoms)))))) )
     129
     130(define (make-random-exponentials
     131          #!key (mu 1.0) (randoms (make-uniform-random-reals)))
    125132  (check-real-unit 'make-random-exponentials mu 'mu)
    126133  (check-procedure 'make-random-exponentials randoms 'randoms)
     
    142149        (let ((u (randoms)))
    143150          (if (<= u q1)
    144               (+ s (* p1 (sqrt u)))
    145               (- l (* d3 (sqrt (- (* d2 u) d1))))))))) )
    146 
    147 (define (make-random-triangles #!key (s 0.0) (m 0.5) (l 1.0) (randoms (make-uniform-random-reals)))
     151            (+ s (* p1 (sqrt u)))
     152            (- l (* d3 (sqrt (- (* d2 u) d1))))))))) )
     153
     154(define (make-random-triangles
     155          #!key (s 0.0) (m 0.5) (l 1.0) (randoms (make-uniform-random-reals)))
    148156  (check-real 'make-random-triangles s 's)
    149157  (check-real 'make-random-triangles m 'm)
     
    162170    (lambda ()
    163171      ; FIXME O(mu) but O(log(mu)) desired for >> mu
    164       (do ((m 0 (fxadd1 m))
     172      (do ((m 0 (fx+ 1 m))
    165173           (prod (randoms) (* prod (randoms))))
    166174          ((<= prod emu) m)))) )
    167175
    168 (define (make-random-poissons #!key (mu 1.0) (randoms (make-uniform-random-reals)))
     176(define (make-random-poissons
     177          #!key (mu 1.0) (randoms (make-uniform-random-reals)))
    169178  (check-nonnegative-real 'make-random-poissons mu 'mu)
    170179  (check-procedure 'make-random-poissons randoms 'randoms)
     
    176185
    177186(define (*make-random-bernoullis p randoms)
    178   (cond ((= 0.0 p) (lambda () #f))
    179         ((= 1.0 p) (lambda () #t))
    180         (else      (lambda () (<= (randoms) p)))) )
    181 
    182 (define (make-random-bernoullis #!key (p 0.5) (randoms (make-uniform-random-reals)))
     187  (cond
     188    ((= 0.0 p) (lambda () #f))
     189    ((= 1.0 p) (lambda () #t))
     190    (else      (lambda () (<= (randoms) p)))) )
     191
     192(define (make-random-bernoullis
     193          #!key (p 0.5) (randoms (make-uniform-random-reals)))
    183194  (check-real-unit 'make-random-bernoullis p 'p)
    184195  (check-procedure 'make-random-bernoullis randoms 'randoms)
     
    193204    ;FIXME O(t) but O(log(t)) desired for >> t
    194205    (if (fixnum? t)
    195         (lambda ()
    196           (do ((i 0 (fxadd1 i))
    197                (n 0 (if (bernoullis) (fxadd1 n) n)))
    198               ((fx<= t i) n)))
    199         (lambda ()
    200           (do ((i 0 (add1 i))
    201                (n 0 (if (bernoullis) (add1 n) n)))
    202               ((<= t i) n))))) )
    203 
    204 (define (make-random-binomials #!key (t 1) (p 0.5) (randoms (make-uniform-random-reals)))
     206      (lambda ()
     207        (do ((i 0 (fx+ 1 i))
     208             (n 0 (if (bernoullis) (fx+ 1 n) n)))
     209            ((fx<= t i) n)))
     210      (lambda ()
     211        (do ((i 0 (add1 i))
     212             (n 0 (if (bernoullis) (add1 n) n)))
     213            ((<= t i) n))))) )
     214
     215(define (make-random-binomials
     216          #!key (t 1) (p 0.5) (randoms (make-uniform-random-reals)))
    205217  (check-cardinal-integer 'make-random-binomials t 't)
    206218  (check-real-unit 'make-random-binomials p 'p)
     
    214226(define (*make-random-geometrics p randoms)
    215227  (let ((log-p (log p)))
    216     (lambda () (+ 1 (inexact->exact (floor (/ (log (- 1.0 (randoms))) log-p)))))) )
    217 
    218 (define (make-random-geometrics #!key (p 0.5) (randoms (make-uniform-random-reals)))
     228    (lambda ()
     229      (+ 1 (inexact->exact (floor (/ (log (- 1.0 (randoms))) log-p)))))) )
     230
     231(define (make-random-geometrics
     232          #!key (p 0.5) (randoms (make-uniform-random-reals)))
    219233  (check-real-unit 'make-random-geometrics p 'p)
    220234  (check-procedure 'make-random-geometrics randoms 'randoms)
     
    229243        (nmu (log (* mu (/ mu (sqrt (+ (* sigma sigma) (* mu mu)))))))
    230244        (nsigma (sqrt (log (+ 1.0 (* sigma (/ sigma mu mu)))))) )
    231     (lambda () (exp (+ nmu (* (normals) nsigma))))) )
    232 
    233 (define (make-random-lognormals #!key (mu 1.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
     245    (lambda ()
     246      (exp (+ nmu (* (normals) nsigma))))) )
     247
     248(define (make-random-lognormals
     249          #!key (mu 1.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
    234250  (check-nonzero-real 'make-random-lognormals mu 'mu)
    235251  (check-nonnegative-real 'make-random-lognormals sigma 'sigma)
     
    244260  (lambda () (+ median (* sigma (tan (* PI (- (randoms) 0.5)))))) )
    245261
    246 (define (make-random-cauchys #!key (median 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
     262(define (make-random-cauchys
     263          #!key (median 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
    247264  (check-real 'make-random-cauchys median 'median)
    248265  (check-positive-real 'make-random-cauchys sigma 'sigma)
     
    259276(define (*make-random-gammas alpha theta randoms)
    260277  (if (= 1.0 alpha)
    261       ; then special case
    262       (lambda () (* theta (- (log (randoms)))) )
    263       ; else general case
    264       (let ((norms (*make-random-normals 0.0 1.0 randoms))
    265             (unis
    266               (if (< alpha 1.0)
    267                   (let ((inv-alpha (*reciprocal alpha)))
    268                     (lambda () (expt (randoms) inv-alpha) ) )
    269                   randoms)))
    270         (let* ((d (- (or (and (< alpha 1.0) (+ 1.0 alpha)) alpha) FP1/3))
    271                (c (*reciprocal (sqrt (* 9.0 d)))))
    272           (lambda ()
    273             (* theta
    274                (let loop ()
    275                  (let* ((x (norms))
    276                         (v (+ 1.0 (* c x))))
    277                    (if (and (< 0.0 v)
    278                             (let ((v (* v v v))
    279                                   (u (unis))
    280                                   (x^2 (* x x)))
    281                               (or (< u (- 1.0 (* 0.0331 x^2 x^2)))
    282                                   (< (log u) (+ (* 0.5 x^2) (* d (- 1.0 (+ v (log v)))))))))
    283                        (* d v)
    284                        (loop) ) ) ) ) ) ) ) ) )
    285 
    286 (define (make-random-gammas #!key (alpha 1.0) (theta 1.0) (randoms (make-uniform-random-reals)))
     278    ; then special case
     279    (lambda () (* theta (- (log (randoms)))) )
     280    ; else general case
     281    (let ((norms (*make-random-normals 0.0 1.0 randoms))
     282          (unis
     283            (if (< alpha 1.0)
     284              (let ((inv-alpha (*reciprocal alpha)))
     285                (lambda () (expt (randoms) inv-alpha) ) )
     286              randoms)))
     287      (let* ((d (- (if (< alpha 1.0) (+ 1.0 alpha) alpha) FP1/3))
     288             (c (*reciprocal (sqrt (* 9.0 d)))))
     289        (lambda ()
     290          (*
     291            theta
     292            (let loop ()
     293              (let* ((x (norms))
     294                     (v (+ 1.0 (* c x))))
     295                (if (and
     296                      (< 0.0 v)
     297                      (let ((v (* v v v))
     298                            (u (unis))
     299                            (x^2 (* x x)))
     300                        (or
     301                          (< u (- 1.0 (* 0.0331 x^2 x^2)))
     302                          (< (log u) (+ (* 0.5 x^2) (* d (- 1.0 (+ v (log v)))))))))
     303                   (* d v)
     304                   (loop) ) ) ) ) ) ) ) ) )
     305
     306(define (make-random-gammas
     307          #!key (alpha 1.0) (theta 1.0) (randoms (make-uniform-random-reals)))
    287308  (check-positive-real 'make-random-gammas alpha 'alpha)
    288309  (check-positive-real 'make-random-gammas theta 'theta)
     
    297318  (*make-random-gammas (exact->inexact alpha) (exact->inexact theta) randoms) )
    298319
    299 (define (make-random-erlangs #!key (alpha 1) (theta 1.0) (randoms (make-uniform-random-reals)))
     320(define (make-random-erlangs
     321          #!key (alpha 1) (theta 1.0) (randoms (make-uniform-random-reals)))
    300322  (check-positive-real 'make-random-erlangs alpha 'alpha)
    301323  (check-positive-real 'make-random-erlangs theta 'theta)
     
    311333    (*make-random-exponentials 1.0 (lambda () (*reciprocal (+ xmin (gammas)))))) )
    312334
    313 (define (make-random-paretos #!key (alpha 1.0) (xmin 1.0) (randoms (make-uniform-random-reals)))
     335(define (make-random-paretos
     336          #!key (alpha 1.0) (xmin 1.0) (randoms (make-uniform-random-reals)))
    314337  (check-positive-real 'make-random-paretos alpha 'alpha)
    315338  (check-positive-real 'make-random-paretos xmin 'xmin)
     
    325348(define (*make-random-levys gamma delta randoms)
    326349  (if (and (= 1.0 gamma) (= 0.0 delta))
    327       (lambda () (let ((r (randoms))) (*reciprocal (* r r))))
    328       (lambda () (let ((r (randoms))) (+ delta (* gamma (*reciprocal (* r r))))))) )
    329 
    330 (define (make-random-levys #!key (gamma 1.0) (delta 0.0) (randoms (make-uniform-random-reals)))
     350    (lambda () (let ((r (randoms))) (*reciprocal (* r r))))
     351    (lambda () (let ((r (randoms))) (+ delta (* gamma (*reciprocal (* r r))))))) )
     352
     353(define (make-random-levys
     354          #!key (gamma 1.0) (delta 0.0) (randoms (make-uniform-random-reals)))
    331355  (check-nonnegative-real 'make-random-levys delta 'delta)
    332356  (check-positive-real 'make-random-levys gamma 'gamma)
     
    343367    (lambda () (expt (* invscale (log (- 1.0 (randoms)))) invshape)) ) )
    344368
    345 (define (make-random-weibulls #!key (shape 1.0) (scale 1.0) (randoms (make-uniform-random-reals)))
     369(define (make-random-weibulls
     370          #!key (shape 1.0) (scale 1.0) (randoms (make-uniform-random-reals)))
    346371  (check-positive-real 'make-random-weibulls shape 'shape)
    347372  (check-positive-real 'make-random-weibulls scale 'scale)
  • release/4/srfi-27/trunk/srfi-27-numbers.scm

    r23071 r33848  
    124124(define (random-power rndint state max m k) ; n = m^k, k >= 1
    125125  (do ((k k (fx- k 1))
    126        (n (inexact->exact (rndint state max)) (+ (inexact->exact (rndint state max)) (* n m))))
     126       (n
     127         (inexact->exact (rndint state max))
     128         (+ (inexact->exact (rndint state max)) (* n m))) )
    127129      ((fx= 1 k) n) ) )
    128130
     
    143145          (let loop ()
    144146            (let ((x (random-power rndint state max m k)))
    145               (if (< x a) (quotient x mk-by-n)
    146                   (loop) ) ) ) ) ) ) )
     147              (if (< x a)
     148                (quotient x mk-by-n)
     149                (loop) ) ) ) ) ) ) )
    147150
    148151; Multiple Precision Reals
     
    159162       (u (- (/ 1 prec) 1) (/ u m)) )
    160163      ((<= u 1)
    161         (exact->inexact (/ (+ 1 (random-power rndint state max m k))
    162                            (+ 1 (expt m k)))) ) ) )
     164        (exact->inexact
     165          (/
     166            (+ 1 (random-power rndint state max m k))
     167            (+ 1 (expt m k)))) ) ) )
    163168
    164169;;;
    165170
    166171(define (native-real-precision? prec max)
    167   (or (not prec)
    168       (<= (- (floor (/ 1 prec)) 1) max)) )
     172  (or
     173    (not prec)
     174    (<= (- (floor (/ 1 prec)) 1) max)) )
    169175
    170176) ;module srfi-27-numbers
  • release/4/srfi-27/trunk/srfi-27-uniform-random.scm

    r19090 r33848  
    1212    (except scheme + - * quotient = <)
    1313    chicken
     14    data-structures
    1415    (only numbers + - * quotient = <)
    1516    (only miscmacros exchange!)
     
    2930;;; Uniform random integers in [low high] by precision
    3031
    31 (define (*make-uniform-random-integers low high prec rand)
    32   (let ((range (quotient (+ (- high low) 1) prec)))
    33       (cond ((and (= 0 low) (= 1 prec)) (lambda () (rand range)))
    34             ((= 0 low)                  (lambda () (* (rand range) prec)))
    35             (else                       (lambda () (+ low (* (rand range) prec))))) ) )
     32(define (*make-uniform-random-integers low high precision rand)
     33  (let ((range (quotient (+ (- high low) 1) precision)))
     34    (cond
     35      ((< (- high low) precision)
     36        (constantly precision))
     37      ((= 0 range)
     38        (constantly 0))
     39      ((and (= 0 low) (= 1 precision))
     40        (lambda () (rand range)))
     41      ((= 0 low)
     42        (lambda () (* (rand range) precision)))
     43      (else
     44        (lambda () (+ low (* (rand range) precision))))) ) )
    3645
    37 (define (make-uniform-random-integers #!key (high #f) (low 0) (precision 1)
    38                                             (source (current-random-source)))
     46(define (make-uniform-random-integers
     47          #!key (high #f) (low 0) (precision 1) (source (current-random-source)))
    3948  (check-random-source 'make-uniform-random-integers source 'source)
    40   (unless high (set! high (*random-source-maximum-range source) #;(- (*random-source-maximum-range source) 1)))
     49  (unless high (set! high (- (*random-source-maximum-range source) 1))) ;(- (*random-source-maximum-range source) 1)
    4150  (check-integer 'make-uniform-random-integers high 'high)
    4251  (check-integer 'make-uniform-random-integers low 'low)
    4352  (check-positive-integer 'make-uniform-random-integers precision 'precision)
    44   ; Handle swapped bounds (could be negative)
    45   (unless (< low high) (exchange! low high))
    46   ; Cannot have a 0 range
    47   (when (= low high)
    48     (error 'make-uniform-random-integers "`low' equals `high'" low high))
    49   ; Cannot have precision outside of range
    50   (when (< (- high low) precision)
    51     (error 'make-uniform-random-integers "`precision' greater-than range" precision low high))
    5253  (values
    5354    (*make-uniform-random-integers low high precision ((@random-source-make-integers source)))
     
    5657;;; Uniform random reals in (0.0 1.0) by precion
    5758
    58 (define (make-uniform-random-reals #!key (precision #f) (source (current-random-source)))
     59(define (make-uniform-random-reals
     60          #!key (precision #f) (source (current-random-source)))
    5961  (check-random-source 'make-uniform-random-reals source 'source)
    6062  (when precision (check-real-precision 'make-uniform-random-reals precision 'precision))
  • release/4/srfi-27/trunk/srfi-27-vector-support.scm

    r19090 r33848  
    3737;;;
    3838
    39 (define (u8vector-filled! u8vec u8gen #!optional (start 0) (end (u8vector-length u8vec)))
    40   (do ((idx start (fx+ idx 1)))
    41       ((fx= end idx) u8vec)
    42     (u8vector-set! u8vec idx (u8gen)) ) )
     39;;
    4340
    44 (define (f64vector-filled! f64vec f64gen #!optional (start 0) (end (f64vector-length f64vec)))
    45   (do ((idx start (fx+ idx 1)))
    46       ((fx= end idx) f64vec)
    47     (f64vector-set! f64vec idx (f64gen)) ) )
     41(define (make-filled! veclenf vecsetf)
     42  (letrec ((self
     43            (case-lambda
     44              ((vec gen)
     45                (self vec gen 0) )
     46              ((vec gen start)
     47                (self vec gen start (veclenf vec)) )
     48              ((vec gen start end)
     49                (do ((idx start (fx+ idx 1)))
     50                    ((fx= end idx) vec)
     51                  (vecsetf vec idx (gen)) ) ) ) ) )
     52    self ) )
    4853
    49 (define (f32vector-filled! f32vec f32gen #!optional (start 0) (end (f32vector-length f32vec)))
    50   (do ((idx start (fx+ idx 1)))
    51       ((fx= end idx) f32vec)
    52     (f32vector-set! f32vec idx (f32gen)) ) )
    53 
    54 (define (vector-filled! vec gen #!optional (start 0) (end (vector-length vec)))
     54#;
     55(define ((make-filled! veclenf vecsetf) vec gen #!optional (start 0) (end (veclenf vec)))
    5556  (do ((idx start (fx+ idx 1)))
    5657      ((fx= end idx) vec)
    57     (vector-set! vec idx (gen)) ) )
     58    (vecsetf vec idx (gen)) ) )
    5859
    59 (define (f32vector-mapi!/1 proc vec)
    60   (let ((len (f32vector-length vec)))
     60(define ((make-mapi!/1 veclenf vecref vecsetf) proc vec)
     61  (let ((len (veclenf vec)))
    6162    (do ((i 0 (fx+ i 1)))
    6263        ((fx= i len) vec)
    63       (f32vector-set! vec i (proc i (f32vector-ref vec i))) ) ) )
     64      (vecsetf vec i (proc i (vecref vec i))) ) ) )
    6465
    65 (define (f32vector-foldi/1 proc init vec)
    66   (let ((len (f32vector-length vec)))
     66(define ((make-foldi/1 veclenf vecref) proc init vec)
     67  (let ((len (veclenf vec)))
    6768    (do ((i 0 (fx+ i 1) )
    68          (acc init (proc i acc (f32vector-ref vec i)) ) )
     69         (acc init (proc i acc (vecref vec i)) ) )
    6970        ((fx= i len) acc) ) ) )
    7071
    71 (define (f64vector-mapi!/1 proc vec)
    72   (let ((len (f64vector-length vec)))
    73     (do ((i 0 (fx+ i 1)))
    74         ((fx= i len) vec)
    75       (f64vector-set! vec i (proc i (f64vector-ref vec i))) ) ) )
     72;;
    7673
    77 (define (f64vector-foldi/1 proc init vec)
    78   (let ((len (f64vector-length vec)))
    79     (do ((i 0 (fx+ i 1) )
    80          (acc init (proc i acc (f64vector-ref vec i)) ) )
    81         ((fx= i len) acc) ) ) )
     74(define u8vector-filled!
     75  (make-filled! u8vector-length u8vector-set!) )
     76
     77(define f64vector-filled!
     78  (make-filled! f64vector-length f64vector-set!) )
     79
     80(define f32vector-filled!
     81  (make-filled! f32vector-length f32vector-set!) )
     82
     83(define vector-filled!
     84  (make-filled! vector-length vector-set!) )
     85
     86(define f32vector-mapi!/1
     87  (make-mapi!/1 f32vector-length f32vector-ref f32vector-set!) )
     88
     89(define f64vector-mapi!/1
     90  (make-mapi!/1 f64vector-length f64vector-ref f64vector-set!) )
     91
     92(define f32vector-foldi/1
     93  (make-foldi/1 f32vector-length f32vector-ref) )
     94
     95(define f64vector-foldi/1
     96  (make-foldi/1 f64vector-length f64vector-ref) )
    8297
    8398;;; Vector% Support
     
    86101(define (array-rank/1? obj) (and (array? obj) (fx= 1 (array-rank obj))))
    87102
     103(define (acceptable-vector? obj)
     104  (or
     105    (vector? obj)
     106    (f32vector? obj)
     107    (f64vector? obj)
     108    #; ;NOT YET
     109    (array-rank/1? obj) ) )
     110
    88111(define (check-vector% loc obj #!optional argnam)
    89   (unless (or (vector? obj)
    90               (f32vector? obj)
    91               (f64vector? obj)
    92               #; ;NOT YET
    93               (array-rank/1? vec) )
    94     (error-vector loc obj argnam) ) )
     112  (unless (acceptable-vector? obj)
     113    (error-vector loc obj argnam) )
     114  obj )
    95115
    96 (define (vector%-length vec)
    97   (cond ((vector? vec)        (vector-length vec))
    98         ((f32vector? vec)     (f32vector-length vec))
    99         ((f64vector? vec)     (f64vector-length vec))
    100         #; ;NOT YET
    101         ((array-rank/1? vec)  (car (array-dimensions vec)))
    102         (else
    103           (error-vector #f vec))) )
     116(define ((make-oper vec-oper f32vec-oper f64vec-oper) vec . args)
     117  (cond
     118    ((vector? vec)        (apply vec-oper vec args))
     119    ((f32vector? vec)     (apply f32vec-oper vec args))
     120    ((f64vector? vec)     (apply f64vec-oper vec args))
     121    #; ;NOT YET
     122    ((array-rank/1? vec)  (apply arr-rnk-1 vec args)) ;arr-rnk-1-oper
     123    (else
     124      (error-vector #f vec))) )
    104125
    105 (define (vector%-mapi!/1 proc vec)
    106   (cond ((vector? vec)        (vector-map! proc vec))
    107         ((f32vector? vec)     (f32vector-mapi!/1 proc vec))
    108         ((f64vector? vec)     (f64vector-mapi!/1 proc vec))
    109         #; ;NOT YET
    110         ((array-rank/1? vec)  (array-map! vec (cut proc #f <>)))
    111         (else
    112           (error-vector #f vec))) )
     126(define vector%-length
     127  (make-oper vector-length f32vector-length f64vector-length) )
    113128
    114 (define (vector%-foldi/1 proc seed vec)
    115   (cond ((vector? vec)        (vector-fold proc seed vec))
    116         ((f32vector? vec)     (f32vector-foldi/1 proc seed vec))
    117         ((f64vector? vec)     (f64vector-foldi/1 proc seed vec))
    118         #; ;NOT YET
    119         ((array-rank/1? vec)  (array-fold (cut proc #f <> <>) seed vec))
    120         (else
    121           (error-vector #f vec))) )
     129(define vector%-mapi!/1
     130  (make-oper vector-map! f32vector-mapi!/1 f64vector-mapi!/1) )  ;(lambda (vec proc ) (array-map! vec (cut proc #f <>)))
    122131
    123 (define (vector%-filled! vec func)
    124   (cond ((vector? vec)        (vector-filled! vec func))
    125         ((f32vector? vec)     (f32vector-filled! vec func))
    126         ((f64vector? vec)     (f64vector-filled! vec func))
    127         #; ;NOT YET
    128         ((array-rank/1? vec)  (array-fold (lambda (x y) (func)) #f vec))
    129         (else
    130           (error-vector #f vec))) )
     132(define vector%-foldi/1
     133  (make-oper vector-fold f32vector-foldi/1 f64vector-foldi/1) )  ;(lambda (vec proc seed) (array-fold (cut proc #f <> <>) seed vec))
     134
     135(define vector%-filled!
     136  (make-oper vector-filled! f32vector-filled! f64vector-filled!) )  ;(lambda (vec func) (array-fold (lambda (x y) (func)) #f vec))
    131137
    132138(define (vector%-scale! vec factor)
  • release/4/srfi-27/trunk/srfi-27-vector.scm

    r27249 r33848  
    3737
    3838; (in case special processing needed near limits TBD)
    39 (define-inline (*reciprocal n) (/ 1.0 n))
     39(define (*reciprocal n) (/ 1.0 n))
     40(define (*-reciprocal n) (/ -1.0 n))
     41
     42(define (vector-iota-set! vec n)
     43  (do ((i 0 (fx+ i 1)))
     44      ((fx= i n))
     45    (vector-set! vec i i) ) )
    4046
    4147;;;
     
    4349;;
    4450
    45 ; Knuth's "The Art of Computer Programming", Vol. II, 2nd ed., Algorithm P of Section 3.4.2
     51;Knuth's "The Art of Computer Programming", Vol. II, 2nd ed., Algorithm P of
     52;Section 3.4.2
     53;
    4654(define (*random-permutation! vec randoms)
    4755  (let ((n (vector-length vec)))
    48     (do ((i 0 (fx+ i 1)))
    49         ((fx= i n))
    50       (vector-set! vec i i))
     56    (vector-iota-set! vec n)
    5157    (do ((k n (fx- k 1)))
    5258        ((fx= k 1) vec)
  • release/4/srfi-27/trunk/srfi-27.meta

    r27249 r33848  
    1616        (numbers "2.8")
    1717        (synch "2.1.0"))
    18  (files "mrg32k3a.scm" "srfi-27.meta" "srfi-27-uniform-random.scm" "mwc.scm" "srfi-27.setup" "entropy-procedure.scm" "srfi-27.release-info" "srfi-27-implementation" "srfi-27-numbers.scm" "fp-extn-w.scm" "entropy-unix.scm" "composite-random-source.scm" "entropy-source.scm" "entropy-clock.scm" "random-source.scm" "srfi-27-vector-support.scm" "srfi-27-distributions.scm" "srfi-27-vector.scm" "srfi-27.scm" "entropy-windows.scm" "moa.scm" "fp-extn-wo.scm" "entropy-support.scm" "tests/test-diehard.scm" "tests/test-confidence.scm" "tests/test-mrg32k3a.scm" "tests/run.scm" "entropy-port.scm") )
     18 (files "mrg32k3a.scm" "srfi-27.meta" "srfi-27-uniform-random.scm" "mwc.scm" "srfi-27.setup" "entropy-procedure.scm" "srfi-27.release-info" "srfi-27-implementation" "srfi-27-numbers.scm" "fp-extn-w.scm" "entropy-unix.scm" "composite-random-source.scm" "entropy-source.scm" "entropy-clock.scm" "random-source.scm" "srfi-27-vector-support.scm" "srfi-27-distributions.scm" "srfi-27-vector.scm" "srfi-27.scm" "entropy-windows.scm" "moa.scm" "fp-extn-wo.scm" "entropy-support.scm" "registration.scm" "tests/test-diehard.scm" "tests/test-confidence.scm" "tests/test-mrg32k3a.scm" "tests/run.scm" "entropy-port.scm") )
  • release/4/srfi-27/trunk/srfi-27.scm

    r19077 r33848  
    7575(define-parameter current-entropy-source default-entropy-source
    7676  (lambda (x)
    77     (cond ((entropy-source? x) x)
    78           (else
    79             (warning-argument-type 'current-entropy-source x 'entropy-source)
    80             (current-entropy-source) ) ) ) )
    81 
     77    (cond
     78      ((entropy-source? x)
     79        x)
     80      (else
     81        (warning-argument-type 'current-entropy-source x 'entropy-source)
     82        (current-entropy-source) ) ) ) )
     83
     84(define make-entropy-source
     85  (case-lambda
     86    (()
     87      ((@entropy-source-constructor (current-entropy-source))) )
     88    ((es)
     89      (let ((ctor
     90              (cond
     91                ((entropy-source? es)
     92                  (@entropy-source-constructor es) )
     93                ((symbol? es)
     94                  (let ((ctor (registered-entropy-source es)))
     95                    (or
     96                      ctor
     97                      (error 'make-entropy-source "unregistered entropy-source name" es) ) ) )
     98                (else
     99                  (error-argument-type
     100                    'make-entropy-source es
     101                    "valid entropy-source or registered entropy-source name") ) ) ) )
     102        (ctor) ) ) ) )
     103
     104#;
    82105(define (make-entropy-source #!optional (es (current-entropy-source)))
    83106  (let ((ctor
    84107          (cond
    85             ((entropy-source? es) (@entropy-source-construtor es) )
    86             ((symbol? es)         (registered-entropy-source es) )
     108            ((entropy-source? es)
     109              (@entropy-source-constructor es) )
     110            ((symbol? es)
     111              (registered-entropy-source es) )
    87112            (else
    88113              (error-argument-type
     
    93118(define (new-entropy-source es)
    94119  (check-entropy-source 'new-entropy-source es)
    95   ((@entropy-source-construtor es)) )
     120  ((@entropy-source-constructor es)) )
    96121
    97122(define (entropy-source-name es)
     
    131156    (lambda (n)
    132157      (check-cardinal-integer 'make-u8vector n 'length)
    133       (u8vector-filled! (make-u8vector n) (lambda () (modulo (rndint) 256))) ) ) )
     158      (u8vector-filled! (make-u8vector n) (lambda () (rndint 256))) ) ) )
    134159
    135160(define (*random-source-make-f64vectors rs prec)
     
    159184(define-parameter current-random-source default-random-source
    160185  (lambda (x)
    161     (cond ((random-source? x) x)
    162           (else
    163             (warning-argument-type 'current-random-source x 'random-source)
    164             (current-random-source) ) ) ) )
    165 
     186    (cond
     187      ((random-source? x)
     188        x)
     189      (else
     190        (warning-argument-type 'current-random-source x 'random-source)
     191        (current-random-source) ) ) ) )
     192
     193(define make-random-source
     194  (case-lambda
     195    (()
     196      ((@random-source-constructor (current-random-source))) )
     197    ((es)
     198      (let ((ctor
     199              (cond
     200                ((random-source? es)
     201                  (@random-source-constructor es) )
     202                ((symbol? es)
     203                  (registered-random-source es) )
     204                (else
     205                  (error-argument-type
     206                    'make-random-source es
     207                    "valid random-source or registered random-source name") ) ) ) )
     208        (ctor) ) ) ) )
     209
     210#;
    166211(define (make-random-source #!optional (es (current-random-source)))
    167212  (let ((ctor
    168213          (cond
    169             ((random-source? es)  (@random-source-construtor es) )
    170             ((symbol? es)         (registered-random-source es) )
     214            ((random-source? es)
     215              (@random-source-constructor es) )
     216            ((symbol? es)
     217              (registered-random-source es) )
    171218            (else
    172219              (error-argument-type
     
    177224(define (new-random-source es)
    178225  (check-random-source 'new-random-source es)
    179   ((@random-source-construtor es)) )
     226  ((@random-source-constructor es)) )
    180227
    181228(define (random-source-name rs)
  • release/4/srfi-27/trunk/srfi-27.setup

    r28425 r33848  
    1111;; Utility Modules
    1212
    13 (setup-shared-extension-module 'srfi-27-numbers (extension-version "3.1.8")
     13(setup-shared-extension-module 'srfi-27-numbers (extension-version "3.1.9")
    1414  #:inline? #t
    1515  #:types? #t
     
    1818    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    1919
    20 (setup-shared-extension-module 'srfi-27-vector-support (extension-version "3.1.8")
     20(setup-shared-extension-module 'srfi-27-vector-support (extension-version "3.1.9")
    2121  #:inline? #t
    2222  #:types? #t
     
    2525    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    2626
    27 ;; Entropy Source Modules
    28 
    29 (setup-shared-extension-module 'entropy-source (extension-version "3.1.8")
     27(setup-shared-extension-module 'registration (extension-version "3.1.9")
    3028  #:inline? #t
    3129  #:types? #t
     
    3432    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    3533
    36 (setup-shared-extension-module 'entropy-support (extension-version "3.1.8")
     34;; Entropy Source Modules
     35
     36(setup-shared-extension-module 'entropy-source (extension-version "3.1.9")
     37  #:inline? #t
     38  #:types? #t
     39  #:compile-options '(
     40    -scrutinize -optimize-level 3 -debug-level 1
     41    -no-procedure-checks -no-argc-checks -no-bound-checks) )
     42
     43(setup-shared-extension-module 'entropy-support (extension-version "3.1.9")
    3744  #:inline? #t
    3845  #:types? #t
     
    4148    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    4249
    43 (setup-shared-extension-module 'entropy-clock (extension-version "3.1.8")
     50(setup-shared-extension-module 'entropy-clock (extension-version "3.1.9")
    4451  #:inline? #t
    4552  #:types? #t
     
    4855    -no-procedure-checks) )
    4956
    50 (setup-shared-extension-module 'entropy-procedure (extension-version "3.1.8")
     57(setup-shared-extension-module 'entropy-procedure (extension-version "3.1.9")
    5158  #:inline? #t
    5259  #:types? #t
     
    5562    -no-procedure-checks) )
    5663
    57 (setup-shared-extension-module 'entropy-port (extension-version "3.1.8")
     64(setup-shared-extension-module 'entropy-port (extension-version "3.1.9")
    5865  #:inline? #t
    5966  #:types? #t
     
    6370
    6471#+unix
    65 (setup-shared-extension-module 'entropy-unix (extension-version "3.1.8")
     72(setup-shared-extension-module 'entropy-unix (extension-version "3.1.9")
    6673  #:inline? #t
    6774  #:types? #t
     
    7178
    7279#+windows
    73 (setup-shared-extension-module 'entropy-windows (extension-version "3.1.8")
     80(setup-shared-extension-module 'entropy-windows (extension-version "3.1.9")
    7481  #:inline? #t
    7582  #:types? #t
     
    8087;; Random Source Modules
    8188
    82 (setup-shared-extension-module 'random-source (extension-version "3.1.8")
     89(setup-shared-extension-module 'random-source (extension-version "3.1.9")
    8390  #:inline? #t
    8491  #:types? #t
     
    8794    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    8895
    89 (setup-shared-extension-module 'mrg32k3a (extension-version "3.1.8")
     96(setup-shared-extension-module 'mrg32k3a (extension-version "3.1.9")
    9097  #:inline? #t
    9198  #:types? #t
     
    94101    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    95102
    96 (setup-shared-extension-module 'mwc (extension-version "3.1.8")
     103(setup-shared-extension-module 'mwc (extension-version "3.1.9")
    97104  #:inline? #t
    98105  #:types? #t
     
    101108    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    102109
    103 (setup-shared-extension-module 'moa (extension-version "3.1.8")
     110(setup-shared-extension-module 'moa (extension-version "3.1.9")
    104111  #:inline? #t
    105112  #:types? #t
     
    108115    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    109116
    110 (setup-shared-extension-module 'composite-random-source (extension-version "3.1.8")
     117(setup-shared-extension-module 'composite-random-source (extension-version "3.1.9")
    111118  #:inline? #t
    112119  #:types? #t
     
    117124;; Main Modules
    118125
    119 (setup-shared-extension-module 'srfi-27 (extension-version "3.1.8")
     126(setup-shared-extension-module 'srfi-27 (extension-version "3.1.9")
    120127  #:inline? #t
    121128  #:types? #t
     
    124131    -no-procedure-checks) )
    125132
    126 (setup-shared-extension-module 'srfi-27-uniform-random (extension-version "3.1.8")
     133(setup-shared-extension-module 'srfi-27-uniform-random (extension-version "3.1.9")
    127134  #:inline? #t
    128135  #:types? #t
     
    131138    -no-procedure-checks) )
    132139
    133 (setup-shared-extension-module 'srfi-27-distributions (extension-version "3.1.8")
     140(setup-shared-extension-module 'srfi-27-distributions (extension-version "3.1.9")
    134141  #:inline? #t
    135142  #:types? #t
     
    138145    -no-procedure-checks) )
    139146
    140 (setup-shared-extension-module 'srfi-27-vector (extension-version "3.1.8")
     147(setup-shared-extension-module 'srfi-27-vector (extension-version "3.1.9")
    141148  #:inline? #t
    142149  #:types? #t
  • release/4/srfi-27/trunk/tests/run.scm

    r28425 r33848  
     1
     2(use test)
     3(use srfi-27)
     4(use srfi-4)
     5
     6(let ((v10 (random-u8vector 10)))
     7  (newline)
     8  (print "u8vector: " v10)
     9  (test "random-u8vector ?" #t (u8vector? v10))
     10  (test "random-u8vector 10" 10 (u8vector-length v10)) )
     11
     12(let ((v10 (random-f64vector 10)))
     13  (newline)
     14  (print "f64vector: " v10)
     15  (test "random-f64vector ?" #t (f64vector? v10))
     16  (test "random-f64vector 10" 10 (f64vector-length v10)) )
     17
    118(use utils)
    219
    320(system* "csi -n -s test-mrg32k3a.scm")
    421(system* "csi -n -s test-confidence")
    5 ;(system* "csi -n -s test-diehard")
     22;(system* "csi -n -s test-diehard") ;errors
  • release/4/srfi-27/trunk/tests/test-diehard.scm

    r19077 r33848  
    1414  (unix
    1515    (use entropy-unix)
    16     (current-entropy-source (make-entropy-source 'entropy-random-device)) )
     16    (current-entropy-source (make-entropy-source 'random-device)) )
    1717  (else) )
    1818
     
    6666;    The message digest is md5sum = 750ac219ff40c50bb2d04ff5eff9b24c.
    6767
     68(use md5 message-digest-bv)
     69(import (only utils read-all))
     70
     71(define (md5-digest port)
     72  (message-digest-string md5-primitive (read-all port)) )
     73
    6874(define (write-diehard filename s bytes-per-call calls)
    6975  (let ((port (open-output-file filename))
     
    7581          (do ((i 0 (fx+ i 1)))
    7682              ((fx= i calls))
    77             (when (fx= 0 (fxmod i 1000)) (display i errprt) (display #\return errprt))
     83            (when (fx= 0 (fxmod i 1000))
     84              (display i errprt) (display #\return errprt))
    7885            (do ((x (rand n) (fx/ x 256))
    7986                 (k bytes-per-call (fx- k 1)))
    8087                ((fx= 0 k))
    81                 (write-char (integer->char (fxmod x 256)))))
     88                (write-char (integer->char (fxmod x 256)))) ) )
    8289          (newline errprt) )
    83         (close-output-port port)))))
     90        (close-output-port port)) ) )
    8491
    8592(define (check-diehard s bytes-per-call calls mdexpt)
     
    9198        (close-input-port port)
    9299        (if (equal? mdexpt md)
    93             (print "Ok")
    94             (print "Expected: " mdexpt " Received: " md))))))
     100          (print "Ok")
     101          (print "Expected: " mdexpt " Received: " md))))))
    95102
    96103(print "(Please wait. This will take a long while!)")
Note: See TracChangeset for help on using the changeset viewer.