Changeset 8333 in project


Ignore:
Timestamp:
02/11/08 02:54:22 (12 years ago)
Author:
Kon Lovett
Message:

Use of uint8_t, etc. types. combined random source. fix for mwc & moa init.

Location:
release/3/srfi-27
Files:
11 edited

Legend:

Unmodified
Added
Removed
  • release/3/srfi-27/entropy-primitives.scm

    r8325 r8333  
    3232
    3333#>
    34 #include <string.h>
    3534#include <math.h>
    36 #include <float.h>
    37 #include "srfi27_defs.h"
    3835
    3936static int
     
    4441  *dtmp = (double *) p;
    4542# else
    46   ((srfi27_uint32_t *) dtmp)[0] = ((srfi27_uint32_t *) p)[0];
    47   ((srfi27_uint32_t *) dtmp)[1] = ((srfi27_uint32_t *) p)[1];
     43  ((uint32_t *) dtmp)[0] = ((uint32_t *) p)[0];
     44  ((uint32_t *) dtmp)[1] = ((uint32_t *) p)[1];
    4845# endif
    4946  if (isnormal (*dtmp)) {
  • release/3/srfi-27/entropy-structures.scm

    r6700 r8333  
    5252;;
    5353
    54 (define *registered-entropy-source-structures* '())
     54(define entropy-source-structures)
     55(define register-entropy-source-structure!)
     56(let ([*registered-entropy-source-structures* '()])
    5557
    56 (define (entropy-source-structures)
    57   (list-copy *registered-entropy-source-structures*) )
     58  (set! entropy-source-structures
     59    (lambda ()
     60      (list-copy *registered-entropy-source-structures*)))
    5861
    59 (define (register-entropy-source-structure! struct)
    60   (if (entropy-source-structure? struct)
    61       (set! *registered-entropy-source-structures*
    62             (cons struct *registered-entropy-source-structures*))
    63       (error 'register-entropy-source-structure!
    64              "not a entropy-source-structure" struct)) )
     62  (set! register-entropy-source-structure!
     63    (lambda (struct)
     64      (if (entropy-source-structure? struct)
     65          (set! *registered-entropy-source-structures*
     66                (cons struct *registered-entropy-source-structures*))
     67          (error 'register-entropy-source-structure!
     68                 "not a entropy-source-structure" struct)))) )
  • release/3/srfi-27/moa-primitives.scm

    r8325 r8333  
    1717
    1818#>
    19 /* chicken.h includes it but be specific */
    20 #include <stdlib.h>
    21 #include <math.h>
    22 
    23 #include "srfi27_defs.h"
     19/* bitsizeof is C++, sigh */
     20#define BITS_PER_BYTE 8
     21#define bitsizeof(t) (BITS_PER_BYTE * sizeof(t))
    2422
    2523/* Mother **************************************************************
     
    4240
    4341typedef struct {
    44     srfi27_int16_t mother[20];
     42  int16_t mother[20];
    4543} rstate_t;
    4644
     
    5351#define m32Double 4294967295.0   /* 2^32-1 */
    5452
    55 #define BITS_PER_BYTE 8
    56 #define bitsizeof(t) (BITS_PER_BYTE * sizeof(t))
    57 
    58 static
    59 srfi27_uint32_t uniformu32 (rstate_t *state)
    60 {
    61     srfi27_uint32_t number1, number2;
    62     srfi27_int16_t *mother1 = state->mother;
    63     srfi27_int16_t *mother2 = &state->mother[10];
    64 
    65     /* Move elements 1 to 8 to 2 to 9 */
    66     memmove (mother1 + 2, mother1 + 1, 8 * sizeof(mother1[0]));
    67     memmove (mother2 + 2, mother2 + 1, 8 * sizeof(mother2[0]));
    68 
    69     /* Put the carry values in numberi */
    70     number1 = mother1[0];
    71     number2 = mother2[0];
    72 
    73     /* Form the linear combinations */
    74 
    75     number1 += 1941 * mother1[2] + 1860 * mother1[3] + 1812 * mother1[4] + 1776 * mother1[5]
    76                 + 1492 * mother1[6] + 1215 * mother1[7] + 1066 * mother1[8] + 12013 * mother1[9];
    77 
    78     number2 += 1111 * mother2[2] + 2222 * mother2[3] + 3333 * mother2[4] + 4444 * mother2[5]
    79                 + 5555 * mother2[6] + 6666 * mother2[7] + 7777 * mother2[8] + 9272 * mother2[9];
    80 
    81     /* Save the high bits of numberi as the new carry */
    82     mother1[0] = number1 / m16Long;
    83     mother2[0] = number2 / m16Long;
    84 
    85     /* Put the low bits of numberi into motheri[1] */
    86     mother1[1] = m16Mask & number1;
    87     mother2[1] = m16Mask & number2;
    88 
    89     /* Combine the two 16 bit random numbers into one 32 bit */
    90     return (srfi27_uint32_t)((((srfi27_int32_t)mother1[1]) << bitsizeof(srfi27_int16_t)) + (srfi27_int32_t)mother2[1]);
    91 }
    92 
    93 static
    94 double uniformf64 (rstate_t *state)
    95 {
    96   return ((((double) uniformu32 (state) / m32Double)
    97               + (double) uniformu32 (state))
    98             / m32Double);
    99 }
    100 
    101 static
    102 srfi27_uint32_t randomu32 (rstate_t *state, srfi27_uint32_t m)
    103 {
    104     srfi27_uint32_t r, mask;
    105     mask = (m < 256
    106               ? masktab[m]
    107               : (m < 65536
    108                    ? masktab[m >> 8] << 8 | 0xff
    109                    : (m < 0x1000000
    110                         ? masktab[m >> 16] << 16 | 0xffff
    111                         : masktab[m >> 24] << 24 | 0xffffff)));
    112     while ((r = uniformu32 (state) & mask) >= m);
    113     return (r);
    114 }
    115 
    116 static
    117 void init_state (rstate_t *state, double seed)
    118 {
    119     int n;
    120     srfi27_int16_t *p;
    121     srfi27_uint32_t number;
    122     srfi27_uint16_t sNumber;
    123     srfi27_uint64_t iseed = (srfi27_uint64_t) seed;
    124     srfi27_int16_t *mother1 = state->mother;
    125     srfi27_int16_t *mother2 = &state->mother[10];
    126 
    127     /* Initialize motheri with 9 random values the first time */
    128     sNumber = (srfi27_uint16_t) (iseed & m16Mask); /* The low 16 bits */
    129     number = (srfi27_uint32_t) ((iseed >> bitsizeof(srfi27_uint16_t)) & m31Mask);  /* Only want 31 bits */
    130 
    131     p = mother1;
    132     for (n = 18; n--; )
    133     {
    134         /* One line multiply-with-carry */
    135         number = 30903 * sNumber + (number >> bitsizeof(srfi27_int16_t));
    136 
    137         *p++ = sNumber = number & m16Mask;
    138 
    139         if (n == 9)
    140             p = mother2;
    141     }
    142 
    143     /* make carry 15 bits */
    144     mother1[0] &= m15Mask;
    145     mother2[0] &= m15Mask;
     53static uint32_t
     54uniformu32 (rstate_t *state)
     55{
     56  uint32_t number1, number2;
     57  int16_t *mother1 = state->mother;
     58  int16_t *mother2 = &state->mother[10];
     59
     60  /* Move elements 1 to 8 to 2 to 9 */
     61  memmove (mother1 + 2, mother1 + 1, 8 * sizeof (mother1[0]));
     62  memmove (mother2 + 2, mother2 + 1, 8 * sizeof (mother2[0]));
     63
     64  /* Put the carry values in numberi */
     65  number1 = mother1[0];
     66  number2 = mother2[0];
     67
     68  /* Form the linear combinations */
     69
     70  number1 += 1941 * mother1[2] + 1860 * mother1[3] + 1812 * mother1[4] + 1776 * mother1[5]
     71              + 1492 * mother1[6] + 1215 * mother1[7] + 1066 * mother1[8] + 12013 * mother1[9];
     72
     73  number2 += 1111 * mother2[2] + 2222 * mother2[3] + 3333 * mother2[4] + 4444 * mother2[5]
     74              + 5555 * mother2[6] + 6666 * mother2[7] + 7777 * mother2[8] + 9272 * mother2[9];
     75
     76  /* Save the high bits of numberi as the new carry */
     77  mother1[0] = number1 / m16Long;
     78  mother2[0] = number2 / m16Long;
     79
     80  /* Put the low bits of numberi into motheri[1] */
     81  mother1[1] = m16Mask & number1;
     82  mother2[1] = m16Mask & number2;
     83
     84  /* Combine the two 16 bit random numbers into one 32 bit */
     85  return (uint32_t) ((((int32_t) mother1[1]) << bitsizeof (int16_t)) + (int32_t) mother2[1]);
     86}
     87
     88static double
     89uniformf64 (rstate_t *state)
     90{
     91  return (((((double) uniformu32 (state)) / m32Double) + ((double) uniformu32 (state))) / m32Double);
     92}
     93
     94static uint32_t
     95randomu32 (rstate_t *state, uint32_t m)
     96{
     97  uint32_t r, mask;
     98  mask = (m < 256
     99            ? masktab[m]
     100            : (m < 65536
     101                 ? masktab[m >> 8] << 8 | 0xff
     102                 : (m < 0x1000000
     103                      ? masktab[m >> 16] << 16 | 0xffff
     104                      : masktab[m >> 24] << 24 | 0xffffff)));
     105  while ((r = uniformu32 (state) & mask) >= m);
     106  return (r);
     107}
     108
     109static void
     110init_state (rstate_t *state, double seed)
     111{
     112  int n;
     113  int16_t *p;
     114  uint32_t number;
     115  uint16_t sNumber;
     116  uint64_t iseed = (uint64_t) seed;
     117  int16_t *mother1 = state->mother;
     118  int16_t *mother2 = &state->mother[10];
     119
     120  /* Initialize mother 1/2 with 9 random values */
     121
     122  sNumber = (uint16_t) (iseed & m16Mask); /* The low 16 bits */
     123  number = (uint32_t) ((iseed >> bitsizeof (uint16_t)) & m31Mask);  /* Only want 31 bits */
     124
     125  p = mother1;
     126  for (n = 18; n--; ) {
     127    /* One line multiply-with-carry */
     128    number = 30903 * sNumber + (number >> bitsizeof (int16_t));
     129    *p++ = sNumber = number & m16Mask;
     130    if (n == 9) p = mother2;
     131  }
     132
     133  /* make carry 15 bits */
     134  mother1[0] &= m15Mask;
     135  mother2[0] &= m15Mask;
    146136}
    147137
     
    156146
    157147#if 0
    158 static
    159 void uniformu32_ith_state (rstate_t *state, srfi27_uint32_t i)
    160 {
    161 }
    162 
    163 static
    164 void uniformu32_jth_offset_state (rstate_t *state, srfi27_uint32_t j)
     148static void
     149uniformu32_ith_state (rstate_t *state, uint32_t i)
     150{
     151}
     152
     153static void
     154uniformu32_jth_offset_state (rstate_t *state, uint32_t j)
    165155{
    166156}
     
    183173;;;
    184174
     175(define-constant INITIAL-SEED 4294967295.0)
     176
     177(define-constant MAXIMUM-RANGE 1073741823) ; 2^30-1 (MOST_POSITIVE_FIXNUM)
     178
     179(define-constant M1 1073741823)
     180
     181(define-constant M2^32 4294967296.0)
     182
    185183(define-constant LOG2-PERIOD 250)
    186 
    187 (define-constant MAXIMUM-RANGE 1073741823) ; 2^30-1 (MOST_POSITIVE_FIXNUM)
    188 
    189 (define-constant M1 1073741823)
    190 
    191 (define-constant M2^32 4294967296.0)
    192184
    193185(define-constant STATE-SIZE 20)
     
    210202(define (moa-state-ref state)
    211203  (cons 'marsaglia-moa
    212     (let loop ([n (fx- STATE-SIZE 1)] [lst '()])
    213       (if (fx= n -1)
    214           lst
    215           (loop (fx- n 1) (cons (s16vector-ref state n) lst))))) )
     204        (do ([i     (fx- STATE-SIZE 1)  (fx- i 1)]
     205             [lst   '()                 (cons (s16vector-ref state i) lst)] )
     206            [(fx= i -1) lst])) )
    216207
    217208(define (moa-state-set external-state)
    218209  (if (and (pair? external-state)
    219            (= (fx+ STATE-SIZE 1) (length external-state))
     210           (fx= (fx+ STATE-SIZE 1) (length external-state))
    220211           (eq? 'marsaglia-moa (car external-state)))
    221212      (let ([state (make-state)])
    222         (let loop ([n 0] [lst (cdr external-state)])
     213        (let loop ([i 0] [lst (cdr external-state)])
    223214          (if (null? lst)
    224215              state
     
    226217                (if (and (integer? x) (exact? x) (<= -32767 x 32768))
    227218                    (begin
    228                       (s16vector-set! state n x)
    229                       (loop (fx+ n 1) (cdr lst)))
     219                      (s16vector-set! state i x)
     220                      (loop (fx+ i 1) (cdr lst)))
    230221                    (error "malformed state" external-state)))) ) )
    231222      (error 'moa-state-set "malformed state" external-state) ) )
     
    285276                  (moa-random-large state n)])))
    286277      ;
    287       (lambda args
    288         (cond [(null? args)
     278      (lambda (#!optional unit)
     279        (cond [(not unit)
    289280                (lambda ()
    290281                  (moa-random-real state))]
    291               [(null? (cdr args))
    292                 (let ([unit (car args)])
    293                   (cond [(not (and (real? unit) (< 0 unit 1)))
    294                           (error 'moa-random-source-reals "unit must be real in (0,1)" unit)]
    295                         [(<= (- (/ 1 unit) 1) M1)
    296                           (lambda ()
    297                             (moa-random-real state))]
    298                         [else
    299                           (lambda ()
    300                             (moa-random-real-mp state unit))]))]
    301282              [else
    302                 (error 'moa-random-source-reals "illegal arguments" args)])))) )
     283                (cond [(not (and (real? unit) (< 0 unit 1)))
     284                        (error 'moa-random-source-reals "unit must be real in (0 1)" unit)]
     285                      [(<= (- (/ 1 unit) 1) M1)
     286                        (lambda ()
     287                          (moa-random-real state))]
     288                      [else
     289                        (lambda ()
     290                          (moa-random-real-mp state unit))])]))) ) )
    303291
    304292;;;
     
    307295
    308296($ void init_masktab)
    309 ($ void init_state #$*moa-initial-state* 0.0)
     297($ void init_state #$*moa-initial-state* (double INITIAL-SEED))
  • release/3/srfi-27/mrg32k3a-primitives.scm

    r8325 r8333  
    1212(declare
    1313  (not usual-integrations
    14     = >= <= <
    15     + * - /
    16     quotient
    17     expt
    18     integer? real? exact? inexact?
    19     zero? even? positive?)
     14    <= <
     15    + - /
     16    integer? real? exact? inexact? zero? positive?)
    2017  (inline)
    2118  (generic)
     
    2421
    2522#>
    26 /* chicken.h includes it but be specific */
    27 #include <stdlib.h>
    2823#include <math.h>
    2924
    30 #include "srfi27_defs.h"
    31 
    32 
    33 static
    34 double mrg32k3a_random_m1 (double *state)
     25static double
     26mrg32k3a_random_m1 (double *state)
    3527{
    3628  double x10 = (state[1] * 1403580.0) - (state[2] * 810728.0);
     
    4941}
    5042
    51 static
    52 srfi27_uint32_t mrg32k3a_random_integer (double *state, srfi27_uint32_t range)
     43static uint32_t
     44mrg32k3a_random_integer (double *state, uint32_t range)
    5345{
    5446  double n = range;
     
    5749  double x;
    5850  for (x = mrg32k3a_random_m1 (state); x >= qn; x = mrg32k3a_random_m1 (state));
    59   return ((srfi27_uint32_t) floor (x / q));
     51  return ((uint32_t) floor (x / q));
    6052}
    6153
    62 static
    63 double mrg32k3a_random_real (double *state)
     54static double
     55mrg32k3a_random_real (double *state)
    6456{
    6557  return (0.0000000002328306549295728 * (1.0 + mrg32k3a_random_m1 (state)));
     
    7567;;;
    7668
    77 (define-constant MAXIMUM-RANGE 1073741823) ; 2^30-1 (MOST_POSITIVE_FIXNUM)
    78 
    7969;; Note - The result will never exceed the fixnum range when
    8070;; called thru the surface structure. However, a direct call
     
    9080;;; mrg32k3a generic
    9181;;;
     82
     83(define-constant MAXIMUM-RANGE 1073741823) ; 2^30-1 (MOST_POSITIVE_FIXNUM)
    9284
    9385(define-constant M1 4294967087.0) ; modulus of component 1
     
    224216
    225217  (if (and (pair? external-state)
    226            (= 7 (length external-state))
     218           (fx= 7 (length external-state))
    227219           (eq? 'lecuyer-mrg32k3a (car external-state)))
    228220      (let ([s (cdr external-state)])
     
    275267
    276268(define mrg32k3a-initial-state ; 0 3 6 9 12 15 of A^16, see below
    277   '#( 1062452522
    278       2961816100
    279        342112271
    280       2854655037
    281       3321940838
    282       3542344109) )
     269  '#(1062452522
     270     2961816100
     271     342112271
     272     2854655037
     273     3321940838
     274     3542344109) )
    283275
    284276(define mrg32k3a-pseudo-randomize-state
     
    375367
    376368      ; compute M = A^(16 + i*2^127 + j*2^76)
    377       (let (
    378           [M
    379             (product (caddr mrg32k3a-generators)
    380                      (product
    381                       (power (car mrg32k3a-generators)
    382                              (exact->inexact (modulo i M2^28)))
    383                       (power (cadr mrg32k3a-generators)
    384                              (exact->inexact (modulo j M2^28)))))])
     369      (let ([M (product (caddr mrg32k3a-generators)
     370                        (product
     371                         (power (car mrg32k3a-generators)
     372                                (exact->inexact (modulo i M2^28)))
     373                         (power (cadr mrg32k3a-generators)
     374                                (exact->inexact (modulo j M2^28)))))])
    385375        (mrg32k3a-pack-state
    386          (vector
    387           (vector-ref M 0)
    388           (vector-ref M 3)
    389           (vector-ref M 6)
    390           (vector-ref M 9)
    391           (vector-ref M 12)
    392           (vector-ref M 15)))) ) ) )
     376         (vector (vector-ref M 0) (vector-ref M 3) (vector-ref M 6)
     377                 (vector-ref M 9) (vector-ref M 12) (vector-ref M 15)))) ) ) )
    393378
    394379; True Randomization
     
    484469                  (mrg32k3a-random-large state n)])) )
    485470      ;
    486       (lambda args
    487         (cond [(null? args)
     471      (lambda (#!optional unit)
     472        (cond [(not unit)
    488473                (lambda ()
    489474                  ($mrg32k3a-random-real state))]
    490               [(null? (cdr args))
    491                 (let ([unit (car args)])
    492                   (cond [(not (and (real? unit) (< 0 unit 1)))
    493                           (error 'mrg32k3a-random-source-reals
    494                                  "unit must be real in (0,1)" unit)]
    495                         [(<= (- (/ 1 unit) 1) M1)
    496                           (lambda ()
    497                             ($mrg32k3a-random-real state))]
    498                         [else
    499                           (lambda ()
    500                             (mrg32k3a-random-real-mp state unit))]))]
    501475              [else
    502                 (error 'mrg32k3a-random-source-reals
    503                        "illegal arguments" args)])))) )
     476                (cond [(not (and (real? unit) (< 0 unit 1)))
     477                        (error 'mrg32k3a-random-source-reals "unit must be real in (0 1)" unit)]
     478                      [(<= (- (/ 1 unit) 1) M1)
     479                        (lambda ()
     480                          ($mrg32k3a-random-real state))]
     481                      [else
     482                        (lambda ()
     483                          (mrg32k3a-random-real-mp state unit))])]))) ) )
  • release/3/srfi-27/mwc-primitives.scm

    r8325 r8333  
    1717
    1818#>
    19 /* Chicken.h includes it but be specific */
    20 #include <stdlib.h>
    2119#include <math.h>
    2220
    23 #include "srfi27_defs.h"
    24 
     21/* bitsizeof is C++, sigh */
    2522#define BITS_PER_BYTE 8
    2623#define bitsizeof(t) (BITS_PER_BYTE * sizeof(t))
     
    4239
    4340typedef struct {
    44   srfi27_uint32_t w;
    45   srfi27_uint32_t c;
     41  uint32_t w;
     42  uint32_t c;
    4643} rstate_t;
    4744
    4845static unsigned char masktab[256];
    4946
    50 static
    51 srfi27_uint32_t uniformu32 (rstate_t *state)
    52 {
    53   srfi27_uint64_t x = (srfi27_uint64_t) A * state->w + state->c;
    54   srfi27_uint32_t w = x & m32Uint;
     47static uint32_t
     48uniformu32 (rstate_t *state)
     49{
     50  uint64_t x = ((uint64_t) A) * state->w + state->c;
     51  uint32_t w = x & m32Uint;
    5552  state->w = w;
    56   state->c = x >> bitsizeof(srfi27_uint32_t);
     53  state->c = x >> bitsizeof (uint32_t);
    5754  return (w);
    5855}
    5956
    60 static
    61 double uniformf64 (rstate_t *state)
    62 {
    63   return ((((double) uniformu32 (state) / m32Double)
    64               + (double) uniformu32 (state))
    65             / m32Double);
    66 }
    67 
    68 static
    69 srfi27_uint32_t randomu32 (rstate_t *state, srfi27_uint32_t m)
    70 {
    71   srfi27_uint32_t r, mask;
     57static double
     58uniformf64 (rstate_t *state)
     59{
     60  return (((((double) uniformu32 (state)) / m32Double) + ((double) uniformu32 (state))) / m32Double);
     61}
     62
     63static uint32_t
     64randomu32 (rstate_t *state, uint32_t m)
     65{
     66  uint32_t r, mask;
    7267  mask = (m < 256
    7368            ? masktab[m]
     
    8176}
    8277
    83 #if 0
    84 static
    85 void init_state_n (rstate_t *state, char *seed, int n)
    86 {
    87   srfi27_uint32_t w = 0;
    88   srfi27_uint32_t c = 0;
    89   int i, m;
    90   for (i = 0; i < n; ++i, ++seed) {
    91       m = i % 8;
    92       if (m < 4)
    93         w += *seed << (8 * m);
    94       else
    95         c += *seed << (8 * (m - 4));
    96   }
     78static void
     79init_state (rstate_t *state, double seed)
     80{
     81  uint32_t w = 0;
     82  uint32_t c = 0;
     83  int i;
     84  char *b;
     85  for (i = 0, b = (char *) &seed; i < 4; ++i, ++b)
     86      w += ((uint32_t) *b) << (8 * i);
     87  for (; i < sizeof (seed); ++i, ++b)
     88      c += ((uint32_t) *b) << (8 * (i - 4));
    9789  if ((w == 0 && c == 0) || (w == -1 && c == A - 1))
    9890    ++c;
     
    10092  state->c = c;
    10193}
    102 #endif
    103 
    104 static
    105 void init_state (rstate_t *state, double seed)
    106 {
    107   srfi27_uint32_t w = 0;
    108   srfi27_uint32_t c = 0;
    109   int i;
    110   char *b;
    111   for (i = 0, b = (char *) &seed; i < 4; ++i, ++b)
    112       w += *b << (8 * i);
    113   for (; i < sizeof(seed); ++i, ++b)
    114       c += *b << (8 * (i - 4));
    115   if ((w == 0 && c == 0) || (w == -1 && c == A - 1))
    116     ++c;
    117   state->w = w;
    118   state->c = c;
    119 }
    120 
    121 static
    122 void init_masktab ()
     94
     95static void
     96init_masktab ()
    12397{
    12498  int i, m;
     
    128102}
    129103
    130 static
    131 void uniformu32_ith_state (rstate_t *state, srfi27_uint32_t i)
     104static void
     105uniformu32_ith_state (rstate_t *state, uint32_t i)
    132106{
    133107  for (; i > 0; --i) {
    134     srfi27_uint64_t x = (srfi27_uint64_t) A * state->w + state->c;
     108    uint64_t x = ((uint64_t) A) * state->w + state->c;
    135109    state->w = x & m32Uint;
    136     state->c = x >> bitsizeof(srfi27_uint32_t);
     110    state->c = x >> bitsizeof (uint32_t);
    137111  }
    138112}
    139113
    140 static
    141 void uniformu32_jth_offset_state (rstate_t *state, srfi27_uint32_t j)
    142 {
    143   srfi27_uint64_t x = (srfi27_uint64_t) powl (A, j) * state->w + state->c;
     114static void
     115uniformu32_jth_offset_state (rstate_t *state, uint32_t j)
     116{
     117  uint64_t x = ((uint64_t) powl (A, j)) * state->w + state->c;
    144118  state->w = x & m32Uint;
    145   state->c = x >> bitsizeof(srfi27_uint32_t);
     119  state->c = x >> bitsizeof (uint32_t);
    146120}
    147121
     
    156130;;
    157131
     132(define-constant INITIAL-SEED 4294967295.0)
     133
    158134(define-constant MAXIMUM-RANGE 1073741823) ; 2^30-1 (MOST_POSITIVE_FIXNUM)
    159135
     
    162138(define-constant LOG2-PERIOD 62)
    163139
     140(define-constant STATE-SIZE 2)
     141
    164142(define (make-state)
    165   (make-u32vector 2) )
     143  (make-u32vector STATE-SIZE) )
    166144
    167145(define *mwc-initial-state* (make-state))
     
    182160(define (mwc-state-set external-state)
    183161  (if (and (pair? external-state)
    184            (= 3 (length external-state))
     162           (fx= (fx+ STATE-SIZE 1) (length external-state))
    185163           (eq? 'marsaglia-mwc (car external-state)))
    186164      (let* ([state (make-state)]
    187165             [setter
    188166               (lambda (i x)
    189                  (if (and (integer? x) (exact? x) (<= 0 x))
     167                 (if (and (integer? x) (<= 0 x))
    190168                     (u32vector-set! state i x)
    191                      (error "malformed state" external-state)))])
     169                     (error 'mwc-state-set "malformed state" external-state)))])
    192170        (setter 0 (cadr external-state))
    193171        (setter 1 (caddr external-state))
     
    243221                  (mwc-random-large state n)])))
    244222      ;
    245       (lambda args
    246         (cond [(null? args)
     223      (lambda (#!optional unit)
     224        (cond [(not unit)
    247225                (lambda ()
    248226                  (mwc-random-real state))]
    249               [(null? (cdr args))
    250                 (let ([unit (car args)])
    251                   (cond [(not (and (real? unit) (< 0 unit 1)))
    252                           (error 'mwc-random-source-reals "unit must be real in (0,1)" unit)]
    253                         [(<= (- (/ 1 unit) 1) M1)
    254                           (lambda ()
    255                             (mwc-random-real state))]
    256                         [else
    257                           (lambda ()
    258                             (mwc-random-real-mp state unit))]))]
    259227              [else
    260                 (error 'mwc-random-source-reals "illegal arguments" args)])))) )
     228                (cond [(not (and (real? unit) (< 0 unit 1)))
     229                        (error 'mwc-random-source-reals "unit must be real in (0 1)" unit)]
     230                      [(<= (- (/ 1 unit) 1) M1)
     231                        (lambda ()
     232                          (mwc-random-real state))]
     233                      [else
     234                        (lambda ()
     235                          (mwc-random-real-mp state unit))])]))) ) )
    261236
    262237;;;
     
    265240
    266241($ void init_masktab)
    267 ($ void init_state #$*mwc-initial-state* 0.0)
     242($ void init_state #$*mwc-initial-state* (double INITIAL-SEED))
  • release/3/srfi-27/srfi-27-eggdoc.scm

    r6700 r8333  
    6767              "(-> %entropy-source)")
    6868            (describe entropy-source?
    69               "(-> object boolean)")
     69              "(object -> boolean)")
    7070            (describe entropy-source
    7171              "(-> %entropy-source)")
     
    7373              "(-> (or string symbol))")
    7474            (describe entropic-u8vector
    75               "(-> fixnum #!optional u8vector u8vector) Filled with fixnum in [0 255].")
     75              "((fixnum positive) #!optional u8vector -> u8vector)")
    7676            (describe entropic-f64vector
    77               "(-> fixnum #!optional f64vector f64vector) Filled with non-negative flonum.")
     77              "((fixnum positive) #!optional f64vector -> f64vector)")
    7878            (describe entropic-u8
    79               "(-> fixnum) A fixnum in [0 255].")
     79              "(-> (fixnum (<= 0 _1 255)))")
    8080            (describe entropic-f64
    81               "(-> flonum) A non-negative flonum.")))
     81              "(-> (flonum (not negative)))")))
    8282
    8383        (definition
     
    8787          (symbol-table
    8888            (describe random-integer
    89               "(-> (integer exact positive) (integer exact positive (<= 0 _) (< _ _1)))")
     89              "((integer exact positive) -> (integer exact (not negative) (< _ _1)))")
    9090            (describe random-real
    91               "(-> (real inexact  (< 0 _ 1)))")
     91              "(-> (real inexact (< 0.0 _ 1.0)))")
    9292            (describe default-random-source
    9393              "%random-source")
     
    9595              "(-> %random-source)")
    9696            (describe random-source?
    97               "(-> object boolean)")
     97              "(object -> boolean)")
    9898            (describe random-source-kind
    99               "(-> %random-source (or string symbol))")
     99              "(%random-source -> (or string symbol))")
    100100            (describe random-source-log2-period
    101               "(-> %random-source fixnum)")
     101              "(%random-source -> (fixnum positive))")
    102102            (describe random-source-maximum-modulus
    103               "(-> %random-source integer)")
     103              "(%random-source -> (integer positive))")
    104104            (describe random-source-maximum-range
    105               "(-> %random-source integer)")
     105              "(%random-source -> (integer positive))")
    106106            (describe random-source-state-ref
    107               "(-> %random-source random-state)")
     107              "(%random-source -> random-state)")
    108108            (describe random-source-state-set!
    109               "(-> %random-source random-state unspecified)")
     109              "(%random-source random-state -> unspecified)")
    110110            (describe random-source-randomize!
    111               "(-> %random-source unspecified)")
     111              "(%random-source -> unspecified)")
    112112            (describe random-source-randomize!/entropy
    113               "(-> %random-source (or entropy-structure %entropy-source) unspecified)")
     113              "(%random-source (or entropy-structure %entropy-source) -> unspecified)")
    114114            (describe random-source-pseudo-randomize!
    115               "(-> %random-source integer integer unspecified)")
     115              "(%random-source (integer exact positive) (integer exact positive (< _2 _3)) -> unspecified)")
    116116            (describe random-source-make-integers
    117               "(-> %random-source (-> (integer exact positive) (integer exact positive (<= 0 _) (< _ _1))))")
     117              "(%random-source -> ((integer exact positive) -> (integer exact (not negative) (< _ _1))))")
    118118            (describe random-source-make-reals
    119               "(-> %random-source #!optional (real inexact (< 0.0 _ 1.0)) (-> (real inexact  (< 0.0 _ 1.0))))")))
     119              "(%random-source #!optional (real inexact (< 0.0 _ 1.0)) -> (-> (real inexact  (< 0.0 _ 1.0))))")))
    120120      )
    121121
     
    267267          (p "Returns or sets the current number of seconds to wait before "
    268268          "automatically closing an open port."))
     269      )
     270
     271      (subsection "Combine Random-Source"
     272
     273        (p "The procedure " (tt "COMBINE-RANDOM-INTEGERS") " takes a list of "
     274        "the random integers generated by the combined random sources and the "
     275        "limit. It must return a combined random integer within the limit.")
     276
     277        (p "The procedure " (tt "COMBINE-RANDOM-REALS")" takes a list of the "
     278        "random reals generated by the combined random sources and an optional unit. "
     279        "It must return a combined random real with unit dispersion.")
     280
     281        (procedure "(make-combined-random-source [COMBINE-RANDOM-INTEGERS [COMBINE-RANDOM-REALS]] RANDOM-SOURCE ...)"
     282          (p "Returns a new " (code "random-source") ". Provides a default for the "
     283          (tt "COMBINE-RANDOM-INTEGERS") " (sum mod limit) and " (tt "COMBINE-RANDOM-REALS") " "
     284          "(product) when not supplied.") )
     285
     286        (procedure "(*make-combined-random-source COMBINE-RANDOM-INTEGERS COMBINE-RANDOM-REALS KIND-SYMBOL LOG2-PERIOD MAXIMUM-RANGE MAXIMUM-MODULUS RANDOM-SOURCES)"
     287          (p "Returns a new " (code "random-source") ".") )
    269288      )
    270289
     
    399418              (describe u8
    400419                "Procedure to generate an entropic unsigned 8 bit
    401                 integer. (-> number)")
     420                integer. (-> (fixnum (<= 0 _1 255)))")
    402421              (describe f64
    403422                "Procedure to generate an entropic 64 bit
    404                 floating-point. (-> number)")
     423                floating-point. (-> (flonum (not negative)))")
    405424              (describe u8vector
    406                 "Procedure to generate a vector of entropic unsigned 8 bit integer. (-> fixnum #!optional (u8vector (<= (u8vector-length _) _1)) u8vector)")
     425                "Procedure to generate a vector of entropic unsigned 8 bit integer. ((fixnum postive) #!optional (u8vector (<= (u8vector-length _2) _1)) -> u8vector)")
    407426              (describe f64vector
    408                 "Procedure to generate a vector of entropic 64 bit floating-point. (-> fixnum #!optional (f64vector (<= (f64vector-length _) _1)) f64vector)")))
     427                "Procedure to generate a vector of entropic 64 bit floating-point. ((fixnum postive) #!optional (f64vector (<= (f64vector-length _2) _1)) -> f64vector)")))
    409428
    410429          (procedure "(%entropy-source? OBJECT)"
     
    438457                "Procedure to return the random state. (-> random-state)")
    439458              (describe state-set!
    440                 "Procedure to set the random state. (-> random-state unspecified)")
     459                "Procedure to set the random state. (random-state -> unspecified)")
    441460              (describe randomize!
    442                 "Procedure to randomize the current state. (-> entropy-source unspecified)")
     461                "Procedure to randomize the current state. (entropy-source -> unspecified)")
    443462              (describe pseudo-randomize!
    444                 "Procedure to randomize current state for substreams. (-> integer integer unspecified)")
     463                "Procedure to randomize current state for substreams. ((integer exact positive) (integer exact positive (<= _1 _2)) -> unspecified)")
    445464              (describe make-integers
    446                 "Procedure to return a random integer stream generator. (-> (-> (integer exact positive) (integer exact positive (<= 0 _) (< _ _1))))")
     465                "Procedure to return a random integer stream generator. (-> ((integer exact positive) -> (integer exact (not negative) (< _ _1))))")
    447466              (describe make-reals
    448                 "Procedure to return a random inexact stream generator. (-> #!optional (real inexact (< 0.0 _ 1.0)) (-> (real inexact (< 0.0 _ 1.0))))")))
     467                "Procedure to return a random inexact stream generator. (#!optional (real inexact (< 0.0 _1 1.0)) -> (-> (real inexact (< 0.0 _ 1.0))))")))
    449468
    450469          (procedure "(%random-source? OBJECT)"
     
    537556
    538557    (history
     558      (version "2.3" "Fix for MOA & MWC. Added make-combined-random-source & *make-combined-random-source.")
    539559      (version "2.2" ""entropy-fixed" wasn't installed! Bug fix for timed file entropy sources. Added 'random-source-randomize!/entropy'.")
    540560      (version "2.101" "Refered to removed unit.")
  • release/3/srfi-27/srfi-27-large-numbers.scm

    r6699 r8333  
    77  (declare
    88    (not usual-integrations
    9       = >= <= <
    10       + * - / quotient
    11       expt
    12       integer? exact?
    13       zero? even?)
     9      <= <
     10      + * - / quotient expt
     11      integer? exact? zero? even?)
    1412    (inline)
    1513    (generic)
     
    2018;;
    2119
    22 #;
     20#; ; not tail-recursive
    2321(define (random-power rndint max state k) ; n = m-max^k, k >= 1
    24   ;FIXME not tail-recursive
    2522  (let loop ([k k])
    2623    (let ([ri (rndint state max)])
    27       (if (fx= k 1)
     24      (if (fx= 1 k)
    2825          ri
    2926          (+ ri (* (loop (fx- k 1)) max))))) )
     
    3128(define (random-power rndint max state k) ; n = m-max^k, k >= 1
    3229  (let loop ([k k] [n (rndint state max)])
    33     (if (fx= k 1)
     30    (if (fx= 1 k)
    3431        n
    3532        (loop (fx- k 1) (+ (rndint state max) (* n max))) ) ) )
     
    4643  (do ([k 2 (fx+ k 1)]
    4744       [mk (* max max) (* mk max)])
    48       ([>= mk n]
    49        (let* ((mk-by-n (quotient mk n))
    50               (a (* mk-by-n n)))
     45      [(<= n mk)
     46       (let* ([mk-by-n (quotient mk n)]
     47              [a (* mk-by-n n)] )
    5148         (let loop ()
    5249          (let ([x (random-power rndint max state k)])
    5350            (if (< x a)
    5451                (quotient x mk-by-n)
    55                 (loop) ) ) ) ) ) ) )
     52                (loop) ) ) ) ) ] ) )
    5653
    5754; Multiple Precision Reals
     
    6461; Scheme system, this can be improved.
    6562
    66 ;FIXME chicken doesn't have multi-prec reals! (but gmp does!)
    67 
    6863(define (rnd$random-large-real rndint max m state unit)
    6964  (do ([k 1 (fx+ k 1)]
    70        [u (- (/ 1.0 unit) 1.0) (/ u m)])
    71       ([<= u 1.0]
    72         (/ (exact->inexact (+ (random-power rndint max state k) 1))
    73            (exact->inexact (+ (expt max k) 1))) ) ) )
     65       [u (- (/ 1.0 unit) 1.0) (/ u m)] )
     66      [(<= u 1.0)
     67        (exact->inexact (/ (+ (random-power rndint max state k) 1)
     68                           (+ (expt max k) 1))) ] ) )
  • release/3/srfi-27/srfi-27-structures.scm

    r6700 r8333  
    99(use srfi-1 srfi-9)
    1010(use syntax-case lexmod)
     11(use mathh-float)
    1112(use entropy-parameters entropy-structures)
    1213
    1314(eval-when (compile)
    1415  (declare
    15     (usual-integrations)
     16    (not usual-integrations
     17      + * modulo )
    1618    (inline)
     19    (generic)
    1720    (export
    1821      %make-random-source
     
    2831      %make-random-source-integers
    2932      %make-random-source-reals
     33      *make-combined-random-source
     34      make-combined-random-source
    3035      random-source-structure?
    3136      COMMON-RANDOM-SOURCE-STRUCTURE
     
    3540
    3641;;
    37 
    38 ; Provide the Interface as Specified in the SRFI
    39 ; ==============================================
    40 ;
    41 ; An object of type random-source is a record containing the procedures
    42 ; as components. The actual state of the generator is stored in the
    43 ; binding-time environment of make-random-source.
    44 
    45 ; Required: Record Data Type
    46 ; ==========================
    47 ;
    48 ; At this point in the code, the following procedures are assumed
    49 ; to be defined to create and access a new record data type:
    50 ;
    51 ;   (%make-random-source a0 a1 a2 a3 a4 a5) -> s
    52 ;     constructs a new random source object s consisting of the
    53 ;     objects a0 .. a5 in this order.
    54 ;
    55 ;   (%random-source? obj) -> bool
    56 ;     tests if a Scheme object is a %random-source.
    57 ;
    58 ;   (%random-source-state-ref         s) -> a0
    59 ;   (%random-source-state-set!        s) -> a1
    60 ;   (%random-source-randomize!        s) -> a2
    61 ;   (%random-source-pseudo-randomize! s) -> a3
    62 ;   (%make-random-source-integers     s) -> a4
    63 ;   (%make-random-source-reals        s) -> a5
    64 ;     retrieve the values in the fields of the object s.
    6542
    6643(define-record-type %random-source
     
    8259  (make-reals         %make-random-source-reals) )
    8360
     61;;
     62
     63(define (*make-combined-random-source comb-int comb-real kind log2-period maxrng maxmod srcs)
     64  (let ([state-set-name (string->symbol (conc kind #\- 'state-set!))]
     65        [srcs-cnt (length srcs)] )
     66    (%make-random-source kind
     67      ;
     68      log2-period maxrng maxmod
     69      ;
     70      (lambda ()
     71        (append! (list kind)
     72                 (map (lambda (src)
     73                        ((%random-source-state-ref src)) )
     74                      srcs)) )
     75      ;
     76      (lambda (state)
     77        (unless (and (eq? kind (car state))
     78                     (fx= srcs-cnt (fx- (length state) 1)) )
     79          (error state-set-name "invalid combined state" state) )
     80        (for-each (lambda (src state)
     81                    ((%random-source-state-ref src) state) )
     82                  srcs (cdr state)) )
     83      ;
     84      (lambda (entropy-source)
     85        (for-each (lambda (src)
     86                    ((%random-source-randomize! src) entropy-source) )
     87                  srcs) )
     88      ;
     89      (lambda (i j)
     90        (for-each (lambda (src)
     91                    ((%random-source-pseudo-randomize! src) i j) )
     92                  srcs) )
     93      ;
     94      (let ([makints (map (lambda (src)
     95                            ((%make-random-source-integers src)))
     96                     srcs)])
     97        (lambda ()
     98          (lambda (n)
     99            (comb-int (map (cut <> n) makints) n) ) ) )
     100      ;
     101      (lambda args
     102        (let ([makrels (map (lambda (src)
     103                              (apply (%make-random-source-reals src) args) )
     104                            srcs)])
     105          (lambda ()
     106            (apply comb-real (map (cut <>) makrels) args) ) ) ) ) ) )
     107
     108;; combine-random-integer
     109;; ((list-of (integer exact (<= 0 _ _2))) (integer exact positive)
     110;;  -> (integer exact (<= 0 _ _2)))
     111;;
     112;; combine-random-real
     113;; ((list-of (real inexact (< 0.0 _ 1.0))) #!optional (real inexact (< 0.0 _2 1.0))
     114;;  -> (real inexact (< 0.0 _ 1.0)))
     115
     116(define (make-combined-random-source #!optional comb-int comb-real #!rest srcs0)
     117  (let ([proc-arg
     118          (lambda (arg proc)
     119            (if (procedure? arg)
     120                arg
     121                (begin
     122                  (set! srcs0 (append! (list arg) srcs0))
     123                  proc ) ) ) ] )
     124    (let ([comb-int
     125            (proc-arg comb-int
     126                      (lambda (ints n)
     127                        (modulo (apply + ints) n) ) ) ]
     128          [comb-real
     129            (proc-arg comb-real
     130                      (lambda (reals #!optional unit)
     131                        (apply * reals) ) ) ] )
     132      ;
     133      (when (null? srcs0)
     134        (error 'make-combined-random-source "no random-sources to combine") )
     135      ;
     136      (let loop ([srcs srcs0]
     137                 [kinds '()]
     138                 [log2-periods '()]
     139                 [maxrngs '()]
     140                 [maxmods '()])
     141        (if (null? srcs)
     142            ; then make composed random-source
     143            (*make-combined-random-source
     144              comb-int comb-real
     145              (string->symbol (apply string-append (reverse! (intersperse kinds "+"))))
     146              ;XXX minimum?
     147              (apply min log2-periods) (apply min maxrngs) (apply min maxmods)
     148              srcs0)
     149            ; else collect info
     150            (let ([src (car srcs)])
     151              (unless (%random-source? src)
     152                (error 'make-combined-random-source "invalid random-source" src) )
     153              (loop (cdr srcs)
     154                    (cons (->string (%random-source-kind src)) kinds)
     155                    (cons (%random-source-log2-period src) log2-periods)
     156                    (cons (%random-source-maximum-range src) maxrngs)
     157                    (cons (%random-source-maximum-modulus src) maxmods)) ) ) ) ) ) )
     158
     159;;
     160
    84161(define-interface random-source-signature
    85162  random-integer
     
    168245;;
    169246
    170 (define *registered-random-source-structures* '())
    171 
    172 (define (random-source-structures)
    173   (list-copy *registered-random-source-structures*) )
    174 
    175 (define (register-random-source-structure! struct)
    176   (if (random-source-structure? struct)
    177       (set! *registered-random-source-structures*
    178             (cons struct *registered-random-source-structures*))
    179       (error 'register-random-source-structure!
    180              "not a random-source-structure" struct)) )
     247(define random-source-structures)
     248(define register-random-source-structure!)
     249(let ([*registered-random-source-structures* '()])
     250
     251  (set! random-source-structures
     252    (lambda ()
     253      (list-copy *registered-random-source-structures*)))
     254
     255  (set! register-random-source-structure!
     256    (lambda (struct)
     257      (if (random-source-structure? struct)
     258          (set! *registered-random-source-structures*
     259                (cons struct *registered-random-source-structures*))
     260          (error 'register-random-source-structure!
     261                 "not a random-source-structure" struct)))) )
  • release/3/srfi-27/srfi-27.html

    r6700 r8333  
    183183<tr>
    184184<td class="symbol">entropy-source?</td>
    185 <td>(-&gt; object boolean)</td></tr>
     185<td>(object -&gt; boolean)</td></tr>
    186186<tr>
    187187<td class="symbol">entropy-source</td>
     
    192192<tr>
    193193<td class="symbol">entropic-u8vector</td>
    194 <td>(-&gt; fixnum #!optional u8vector u8vector) Filled with fixnum in [0 255].</td></tr>
     194<td>((fixnum positive) #!optional u8vector -&gt; u8vector)</td></tr>
    195195<tr>
    196196<td class="symbol">entropic-f64vector</td>
    197 <td>(-&gt; fixnum #!optional f64vector f64vector) Filled with non-negative flonum.</td></tr>
     197<td>((fixnum positive) #!optional f64vector -&gt; f64vector)</td></tr>
    198198<tr>
    199199<td class="symbol">entropic-u8</td>
    200 <td>(-&gt; fixnum) A fixnum in [0 255].</td></tr>
     200<td>(-&gt; (fixnum (&lt;= 0 _1 255)))</td></tr>
    201201<tr>
    202202<td class="symbol">entropic-f64</td>
    203 <td>(-&gt; flonum) A non-negative flonum.</td></tr></table></dd>
     203<td>(-&gt; (flonum (not negative)))</td></tr></table></dd>
    204204<dt class="definition"><strong>interface:</strong> (random-source-signature random-integer random-real default-random-source make-random-source random-source? random-source-kind random-source-log2-period random-source-maximum-range  random-source-maximum-modulus random-source-state-ref random-source-state-set! random-source-randomize! random-source-pseudo-randomize! random-source-make-integers random-source-make-reals)</dt>
    205205<dd><table class="symbol-table">
    206206<tr>
    207207<td class="symbol">random-integer</td>
    208 <td>(-&gt; (integer exact positive) (integer exact positive (&lt;= 0 _) (&lt; _ _1)))</td></tr>
     208<td>((integer exact positive) -&gt; (integer exact (not negative) (&lt; _ _1)))</td></tr>
    209209<tr>
    210210<td class="symbol">random-real</td>
    211 <td>(-&gt; (real inexact  (&lt; 0 _ 1)))</td></tr>
     211<td>(-&gt; (real inexact (&lt; 0.0 _ 1.0)))</td></tr>
    212212<tr>
    213213<td class="symbol">default-random-source</td>
     
    218218<tr>
    219219<td class="symbol">random-source?</td>
    220 <td>(-&gt; object boolean)</td></tr>
     220<td>(object -&gt; boolean)</td></tr>
    221221<tr>
    222222<td class="symbol">random-source-kind</td>
    223 <td>(-&gt; %random-source (or string symbol))</td></tr>
     223<td>(%random-source -&gt; (or string symbol))</td></tr>
    224224<tr>
    225225<td class="symbol">random-source-log2-period</td>
    226 <td>(-&gt; %random-source fixnum)</td></tr>
     226<td>(%random-source -&gt; (fixnum positive))</td></tr>
    227227<tr>
    228228<td class="symbol">random-source-maximum-modulus</td>
    229 <td>(-&gt; %random-source integer)</td></tr>
     229<td>(%random-source -&gt; (integer positive))</td></tr>
    230230<tr>
    231231<td class="symbol">random-source-maximum-range</td>
    232 <td>(-&gt; %random-source integer)</td></tr>
     232<td>(%random-source -&gt; (integer positive))</td></tr>
    233233<tr>
    234234<td class="symbol">random-source-state-ref</td>
    235 <td>(-&gt; %random-source random-state)</td></tr>
     235<td>(%random-source -&gt; random-state)</td></tr>
    236236<tr>
    237237<td class="symbol">random-source-state-set!</td>
    238 <td>(-&gt; %random-source random-state unspecified)</td></tr>
     238<td>(%random-source random-state -&gt; unspecified)</td></tr>
    239239<tr>
    240240<td class="symbol">random-source-randomize!</td>
    241 <td>(-&gt; %random-source unspecified)</td></tr>
     241<td>(%random-source -&gt; unspecified)</td></tr>
    242242<tr>
    243243<td class="symbol">random-source-randomize!/entropy</td>
    244 <td>(-&gt; %random-source (or entropy-structure %entropy-source) unspecified)</td></tr>
     244<td>(%random-source (or entropy-structure %entropy-source) -&gt; unspecified)</td></tr>
    245245<tr>
    246246<td class="symbol">random-source-pseudo-randomize!</td>
    247 <td>(-&gt; %random-source integer integer unspecified)</td></tr>
     247<td>(%random-source (integer exact positive) (integer exact positive (&lt; _2 _3)) -&gt; unspecified)</td></tr>
    248248<tr>
    249249<td class="symbol">random-source-make-integers</td>
    250 <td>(-&gt; %random-source (-&gt; (integer exact positive) (integer exact positive (&lt;= 0 _) (&lt; _ _1))))</td></tr>
     250<td>(%random-source -&gt; ((integer exact positive) -&gt; (integer exact (not negative) (&lt; _ _1))))</td></tr>
    251251<tr>
    252252<td class="symbol">random-source-make-reals</td>
    253 <td>(-&gt; %random-source #!optional (real inexact (&lt; 0.0 _ 1.0)) (-&gt; (real inexact  (&lt; 0.0 _ 1.0))))</td></tr></table></dd></div>
     253<td>(%random-source #!optional (real inexact (&lt; 0.0 _ 1.0)) -&gt; (-&gt; (real inexact  (&lt; 0.0 _ 1.0))))</td></tr></table></dd></div>
    254254<div class="subsection">
    255255<h4>Random Source Structures</h4>
     
    349349<dd>
    350350<p>Returns or sets the current number of seconds to wait before automatically closing an open port.</p></dd></div>
     351<div class="subsection">
     352<h4>Combine Random-Source</h4>
     353<p>The procedure <tt>COMBINE-RANDOM-INTEGERS</tt> takes a list of the random integers generated by the combined random sources and the limit. It must return a combined random integer within the limit.</p>
     354<p>The procedure <tt>COMBINE-RANDOM-REALS</tt> takes a list of the random reals generated by the combined random sources and an optional unit. It must return a combined random real with unit dispersion.</p>
     355<dt class="definition"><strong>procedure:</strong> (make-combined-random-source [COMBINE-RANDOM-INTEGERS [COMBINE-RANDOM-REALS]] RANDOM-SOURCE ...)</dt>
     356<dd>
     357<p>Returns a new <code>random-source</code>. Provides a default for the <tt>COMBINE-RANDOM-INTEGERS</tt> (sum mod limit) and <tt>COMBINE-RANDOM-REALS</tt> (product) when not supplied.</p></dd>
     358<dt class="definition"><strong>procedure:</strong> (*make-combined-random-source COMBINE-RANDOM-INTEGERS COMBINE-RANDOM-REALS KIND-SYMBOL LOG2-PERIOD MAXIMUM-RANGE MAXIMUM-MODULUS RANDOM-SOURCES)</dt>
     359<dd>
     360<p>Returns a new <code>random-source</code>.</p></dd></div>
    351361<div class="subsection">
    352362<h4>Distributions</h4>
     
    476486<td class="symbol">u8</td>
    477487<td>Procedure to generate an entropic unsigned 8 bit
    478                 integer. (-&gt; number)</td></tr>
     488                integer. (-&gt; (fixnum (&lt;= 0 _1 255)))</td></tr>
    479489<tr>
    480490<td class="symbol">f64</td>
    481491<td>Procedure to generate an entropic 64 bit
    482                 floating-point. (-&gt; number)</td></tr>
     492                floating-point. (-&gt; (flonum (not negative)))</td></tr>
    483493<tr>
    484494<td class="symbol">u8vector</td>
    485 <td>Procedure to generate a vector of entropic unsigned 8 bit integer. (-&gt; fixnum #!optional (u8vector (&lt;= (u8vector-length _) _1)) u8vector)</td></tr>
     495<td>Procedure to generate a vector of entropic unsigned 8 bit integer. ((fixnum postive) #!optional (u8vector (&lt;= (u8vector-length _2) _1)) -&gt; u8vector)</td></tr>
    486496<tr>
    487497<td class="symbol">f64vector</td>
    488 <td>Procedure to generate a vector of entropic 64 bit floating-point. (-&gt; fixnum #!optional (f64vector (&lt;= (f64vector-length _) _1)) f64vector)</td></tr></table></dd>
     498<td>Procedure to generate a vector of entropic 64 bit floating-point. ((fixnum postive) #!optional (f64vector (&lt;= (f64vector-length _2) _1)) -&gt; f64vector)</td></tr></table></dd>
    489499<dt class="definition"><strong>procedure:</strong> (%entropy-source? OBJECT)</dt>
    490500<dd>
     
    523533<tr>
    524534<td class="symbol">state-set!</td>
    525 <td>Procedure to set the random state. (-&gt; random-state unspecified)</td></tr>
     535<td>Procedure to set the random state. (random-state -&gt; unspecified)</td></tr>
    526536<tr>
    527537<td class="symbol">randomize!</td>
    528 <td>Procedure to randomize the current state. (-&gt; entropy-source unspecified)</td></tr>
     538<td>Procedure to randomize the current state. (entropy-source -&gt; unspecified)</td></tr>
    529539<tr>
    530540<td class="symbol">pseudo-randomize!</td>
    531 <td>Procedure to randomize current state for substreams. (-&gt; integer integer unspecified)</td></tr>
     541<td>Procedure to randomize current state for substreams. ((integer exact positive) (integer exact positive (&lt;= _1 _2)) -&gt; unspecified)</td></tr>
    532542<tr>
    533543<td class="symbol">make-integers</td>
    534 <td>Procedure to return a random integer stream generator. (-&gt; (-&gt; (integer exact positive) (integer exact positive (&lt;= 0 _) (&lt; _ _1))))</td></tr>
     544<td>Procedure to return a random integer stream generator. (-&gt; ((integer exact positive) -&gt; (integer exact (not negative) (&lt; _ _1))))</td></tr>
    535545<tr>
    536546<td class="symbol">make-reals</td>
    537 <td>Procedure to return a random inexact stream generator. (-&gt; #!optional (real inexact (&lt; 0.0 _ 1.0)) (-&gt; (real inexact (&lt; 0.0 _ 1.0))))</td></tr></table></dd>
     547<td>Procedure to return a random inexact stream generator. (#!optional (real inexact (&lt; 0.0 _1 1.0)) -&gt; (-&gt; (real inexact (&lt; 0.0 _ 1.0))))</td></tr></table></dd>
    538548<dt class="definition"><strong>procedure:</strong> (%random-source? OBJECT)</dt>
    539549<dd>
     
    616626<h3>Version</h3>
    617627<ul>
     628<li>2.3 Fix for MOA &amp; MWC. Added make-combined-random-source &amp; *make-combined-random-source.</li>
    618629<li>2.2 entropy-fixed wasn't installed! Bug fix for timed file entropy sources. Added 'random-source-randomize!/entropy'.</li>
    619630<li>2.101 Refered to removed unit.</li>
  • release/3/srfi-27/srfi-27.setup

    r6700 r8333  
    1010  'numbers                "1.8")
    1111
    12 (install-dynld entropy-structures "2.2")
     12(install-dynld entropy-structures "2.3")
    1313
    14 (install-dynld entropy-primitives "2.2" -O3 -d0)
     14(install-dynld entropy-primitives "2.3" -O3 -d0)
    1515
    16 (install-dynld entropy-clock "2.2" -O3 -d0)
     16(install-dynld entropy-clock "2.3" -O3 -d0)
    1717#+windows
    18 (install-dynld entropy-windows "2.2" -O3 -d0)
     18(install-dynld entropy-windows "2.3" -O3 -d0)
    1919#+unix
    20 (install-dynld entropy-unix "2.2" -O3 -d0)
    21 (install-dynld entropy-fixed "2.2")
     20(install-dynld entropy-unix "2.3" -O3 -d0)
     21(install-dynld entropy-fixed "2.3")
    2222
    23 (install-dynld entropy-parameters "2.2")
     23(install-dynld entropy-parameters "2.3")
    2424
    25 (install-dynld srfi-27-structures "2.2")
     25(install-dynld srfi-27-structures "2.3")
    2626
    27 (install-dynld srfi-27-large-numbers "2.2" -O3 -d0)
     27(install-dynld srfi-27-large-numbers "2.3" -O3 -d0)
    2828
    29 (install-dynld mrg32k3a-primitives "2.2" -O3 -d0 +easyffi +dollar)
    30 (install-dynld mrg32k3a "2.2")
     29(install-dynld mrg32k3a-primitives "2.3" -O3 -d0 +easyffi +dollar)
     30(install-dynld mrg32k3a "2.3")
    3131
    32 (install-dynld mwc-primitives "2.2" -O3 -d0 +easyffi +dollar)
    33 (install-dynld mwc "2.2")
     32(install-dynld mwc-primitives "2.3" -O3 -d0 +easyffi +dollar)
     33(install-dynld mwc "2.3")
    3434
    35 (install-dynld moa-primitives "2.2" -O3 -d0 +easyffi +dollar)
    36 (install-dynld moa "2.2")
     35(install-dynld moa-primitives "2.3" -O3 -d0 +easyffi +dollar)
     36(install-dynld moa "2.3")
    3737
    38 (install-dynld srfi-27-parameters "2.2")
     38(install-dynld srfi-27-parameters "2.3")
    3939
    40 (install-dynld srfi-27-distributions "2.2")
     40(install-dynld srfi-27-distributions "2.3")
    4141
    42 (install-dynld+docu srfi-27 "2.2")
     42(install-dynld+docu srfi-27 "2.3")
  • release/3/srfi-27/tests/conf-test.scm

    r6699 r8333  
    11; Chicken
    22
     3(use utils)
    34(use srfi-27)
     5(use mrg32k3a mwc moa)
    46(use md5) ; for diehard
    57
     
    911      = <= <
    1012      + * -
    11       quotient modulo expt abs
    12       equal?) ) )
     13      expt abs ) ) )
    1314
    1415;; Select platform specific entropy source
     
    2324  [else] )
    2425
    25 ;; Say what sources we are using
    26 
    2726(newline)
    28 (print "Entropy Source = " (entropy-kind))
    29 (print " Random Source = " (random-source-kind default-random-source))
     27(print "Entropy Source: " (entropy-kind))
    3028(newline)
    3129
     
    9391;   SE, 04-Apr-2002: some quick timings; check up
    9492
    95 
    9693; (check expr)
    9794;    evals expr and issues an error if it is not #t.
     
    104101; ============================
    105102
    106 (define (my-random-integer n)
     103(define (checked-random-integer n)
    107104  (let ((x (random-integer n)))
    108105    (if (<= 0 x (- n 1))
    109106        x
    110         (error "(random-integer n) returned illegal value" x))))
    111 
    112 (define (my-random-real)
     107        (begin
     108          (flush-output)
     109          (error 'checked-random-integer "(random-integer n) returned illegal value" x)))))
     110
     111(define (checked-random-real)
    113112  (let ((x (random-real)))
    114113    (if (< 0 x 1)
    115114        x
    116         (error "(random-real) returned illegal value" x))))
     115        (begin
     116          (flush-output)
     117          (error 'checked-random-real "(random-real) returned illegal value" x)))))
    117118
    118119(define (check-basics-1)
    119120
    120121  ; generate increasingly large numbers
    121   (display "; generating large numbers [bits]: ")
    122122  (do ((k 0 (fx+ k 1))
    123123       (n 1 (* n 2)))
    124124      ((fx> k 1024))
    125     (display k)
    126     (display " ")
    127     (my-random-integer n))
    128   (print "ok")
     125    (print* "; generating large numbers: " k " bits") (display #\return)
     126    (checked-random-integer n))
     127  (print "; generating large numbers: [1 1024] bits - ok")
    129128
    130129  ; generate some reals
    131   (display "; generating reals [1000 times]: ")
    132   (do ((k 0 (fx+ k 1))
    133        (x (my-random-real) (+ x (my-random-real))))
    134       ((fx= k 1000)
    135        x))
     130  (display "; generating reals [1000 times]: ") (flush-output)
     131  (do ((k 0 (fx+ k 1)))
     132      ((fx= k 1000))
     133      (checked-random-real))
    136134  (print "ok")
    137135
    138136  ; get/set the state
    139   (display "; get/set state: ")
     137  (display "; get/set state: ") (flush-output)
    140138  (let* ((state1 (random-source-state-ref default-random-source))
    141          (x1 (my-random-integer (expt 2 32)))
     139         (x1 (checked-random-integer (expt 2 32)))
    142140         (state2 (random-source-state-ref default-random-source))
    143          (x2 (my-random-integer (expt 2 32))))
     141         (x2 (checked-random-integer (expt 2 32))))
    144142    (random-source-state-set! default-random-source state1)
    145     (let ((y1 (my-random-integer (expt 2 32))))
     143    (let ((y1 (checked-random-integer (expt 2 32))))
    146144      (unless (= x1 y1)
    147         (error "state get/set doesn't work" x1 y1 state1)))
     145        (error 'check-basics-1 "state 1 get/set doesn't work" x1 y1 state1)))
    148146    (random-source-state-set! default-random-source state2)
    149     (let ((y2 (my-random-integer (expt 2 32))))
     147    (let ((y2 (checked-random-integer (expt 2 32))))
    150148      (unless (= x2 y2)
    151         (error "state get/set doesn't work" x2 y2 state2))))
     149        (error 'check-basics-1 "state 2 get/set doesn't work" x2 y2 state2))))
    152150  (print "ok")
    153151
    154152  ; randomize!
    155   (display "; randomize!: ")
     153  (display "; randomize!: ") (flush-output)
    156154  (let* ((state1 (random-source-state-ref default-random-source))
    157          (x1 (my-random-integer (expt 2 32))))
     155         (x1 (checked-random-integer (expt 2 32))))
    158156    (random-source-state-set! default-random-source state1)
    159157    (random-source-randomize! default-random-source)
    160     (let ((y1 (my-random-integer (expt 2 32))))
     158    (let ((y1 (checked-random-integer (expt 2 32))))
    161159      (when (= x1 y1)
    162         (error "random-source-randomize! didn't work" x1 state1))))
     160        (error 'check-basics-1 "random-source-randomize! didn't work" x1 state1))))
    163161  (print "ok")
    164162
    165163  ; pseudo-randomize!
    166   (display "; pseudo-randomize!: ")
     164  (display "; pseudo-randomize!: ") (flush-output)
    167165  (let* ((state1 (random-source-state-ref default-random-source))
    168          (x1 (my-random-integer (expt 2 32))))
     166         (x1 (checked-random-integer (expt 2 32))))
    169167    (random-source-state-set! default-random-source state1)
    170168    (random-source-pseudo-randomize! default-random-source 0 1)
    171     (let ((y1 (my-random-integer (expt 2 32))))
     169    (let ((y1 (checked-random-integer (expt 2 32))))
    172170      (when (= x1 y1)
    173         (error "random-source-pseudo-randomize! didn't work" x1 state1)))
     171        (error 'check-basics-1 "random-source-pseudo-randomize! didn't work" x1 y1 state1)))
    174172    (random-source-state-set! default-random-source state1)
    175173    (random-source-pseudo-randomize! default-random-source 1 0)
    176     (let ((y1 (my-random-integer (expt 2 32))))
     174    (let ((y1 (checked-random-integer (expt 2 32))))
    177175      (when (= x1 y1)
    178         (error "random-source-pseudo-randomize! didn't work" x1 state1))))
    179   (print "ok") )
     176        (error 'check-basics-1 "random-source-pseudo-randomize! didn't work" x1 y1 state1))))
     177  (print "ok")
     178
     179  (print "passed (check-basics-1)") )
    180180
    181181
     
    191191(define (check-mrg32k3a)
    192192
     193  (current-random-source-structure MRG32k3a)
     194
    193195  ; check if the initial state is A^16 * (1 0 0 1 0 0)
    194   (display "; check A^16 * (1 0 0 1 0 0): ")
     196  (display "; check A^16 * (1 0 0 1 0 0): ") (flush-output)
    195197  (let* ((s (make-random-source))
    196198         (state1 (random-source-state-ref s))
     
    201203         (let ((state2 (random-source-state-ref s)))
    202204           (unless (equal? state1 state2)
    203              (error "16-th state after (1 0 0 1 0 0) is wrong" state1 state2))))
     205             (error 'check-mrg32k3a "16-th state after (1 0 0 1 0 0) is wrong" state1 state2))))
    204206      (rand) ) )
    205207  (print "ok")
    206208
    207209  ; check if pseudo-randomize! advances properly
    208   (display "; checking (random-source-pseudo-randomize! s 1 2): ")
     210  (display "; checking random-source-pseudo-randomize! in [1 2] advance: ") (flush-output)
    209211  (let ((s (make-random-source)))
    210212    (random-source-pseudo-randomize! s 1 2)
     
    217219                        623307378
    218220                       2983662421)))
    219   (error "pseudo-randomize! gives wrong result")))
     221  (error 'check-mrg32k3a "pseudo-randomize! gives wrong result")))
    220222  (print "ok")
    221223
     
    225227  ;   L'Ecuyer's original proposal. However, for the first 10^7 reals
    226228  ;   that makes no difference as m1-1 is not generated.
    227   (display "; (Please wait. This will take awhile!)") (newline)
    228   (display "; checking (random-source-pseudo-randomize! s 1 2)...: ")
     229  (print "; (Please wait. This will take awhile!)")
     230  (display "; checking random-source-pseudo-randomize! in [1 2] summation: ") (flush-output)
    229231  (let* ((x 0.0)
    230232         (s (make-random-source))
     
    235237        ((fx= k 10000000)
    236238         (unless (< (abs (- x 5001090.95)) 0.01)
    237            (error "bad sum over 10^7 reals" x)))
     239           (error 'check-mrg32k3a "bad sum over 10^7 reals" x)))
    238240      (set! x (+ x (rand))) ) )
    239241  (print "ok") )
     
    285287;    The message digest is md5sum = 750ac219ff40c50bb2d04ff5eff9b24c.
    286288
    287 (define (%write-diehard s bytes-per-call calls)
    288   (let ((rand (random-source-make-integers s))
    289         (n (expt 256 bytes-per-call))
    290         [errprt (current-error-port)])
    291     (do ((i 0 (fx+ i 1)))
    292         ((fx= i calls))
    293       (display i errprt) (display #\return errprt)
    294       (let loop ([x (rand n)] [k bytes-per-call])
    295         (unless (fx= 0 k)
    296           (write-char (integer->char (modulo x 256)))
    297           (loop (quotient x 256) (fx- k 1)))))
    298     (newline errprt)))
    299 
    300 (define (diehard-file filename s bytes-per-call calls)
     289(define (write-diehard filename s bytes-per-call calls)
    301290  (let ([port (open-output-file filename)])
    302291    (with-output-to-port port
    303292      (lambda ()
    304         (%write-diehard s bytes-per-call calls)
     293        (let ((rand (random-source-make-integers s))
     294              (n (expt 256 bytes-per-call))
     295              [errprt (current-error-port)])
     296          (do ((i 0 (fx+ i 1)))
     297              ((fx= i calls))
     298            (when (fx= 0 (fxmod i 1000))
     299              (display i errprt) (display #\return errprt))
     300            (do ([x (rand n) (fx/ x 256)]
     301                 [k bytes-per-call (fx- k 1)])
     302                [(fx= 0 k)]
     303                (write-char (integer->char (fxmod x 256))))))
     304        (newline errprt)
    305305        (close-output-port port)))))
    306306
    307307(define (check-diehard s bytes-per-call calls mdexpt)
    308   (print "; (diehard :randomsource " bytes-per-call " " calls ") ...")
    309   (diehard-file "/tmp/diehard.out" s bytes-per-call calls)
    310   (let ([port (open-input-file "/tmp/diehard.out")])
    311     (let ([md (md5:digest port)])
    312       (close-input-port port)
    313       (if (equal? mdexpt md)
    314           (print "; Ok")
    315           (print "; Expected: " mdexpt " Received: " md)))))
     308  (let ([diehard-filename (create-temporary-file "diehard")])
     309    (print "; (diehard :randomsource " bytes-per-call " " calls ") ...")
     310    (write-diehard diehard-filename s bytes-per-call calls)
     311    (let ([port (open-input-file diehard-filename)])
     312      (let ([md (md5:digest port)])
     313        (close-input-port port)
     314        (if (equal? mdexpt md)
     315            (print "; Ok")
     316            (print "; Expected: " mdexpt " Received: " md))))))
    316317
    317318;;; run some tests
    318319
    319 (check-basics-1)
    320 (print "passed (check-basics-1)")
    321 (newline)
     320(for-each (lambda (rs)
     321            (current-random-source-structure rs)
     322            (print "Random Source: " (random-source-kind default-random-source))
     323            (time (check-basics-1))
     324            (newline) )
     325          (random-source-structures))
    322326
    323327(check-mrg32k3a)
     
    325329(newline)
    326330
    327 #|
    328331; These fail!
    329332(print "; (Please wait. This will take a long while!)")
     333(current-random-source-structure MRG32k3a)
    330334(check-diehard (make-random-source) 4 2867200 "4df554f56cb5ed251bd04b0d50767443")
    331335(check-diehard (make-random-source) 3 3822934 "750ac219ff40c50bb2d04ff5eff9b24c")
    332 |#
Note: See TracChangeset for help on using the changeset viewer.