Changeset 17331 in project


Ignore:
Timestamp:
02/21/10 02:35:28 (10 years ago)
Author:
Kon Lovett
Message:

argchk for rndints. ren of vecsupp.

Location:
release/4/srfi-27/trunk
Files:
1 added
9 edited

Legend:

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

    r17328 r17331  
    1212          srfi-4
    1313          (only numbers <= - /)
     14          (only type-errors error-positive-integer)
    1415          random-source
    1516          entropy-source
     
    1920    srfi-4
    2021    numbers
     22    type-errors
    2123    random-source entropy-source srfi-27-numbers)
    2224
     
    299301      (lambda ()
    300302        (lambda (n)
    301           (cond ((<= n MAXIMUM-RANGE) (moa-random-integer state n))
     303          (cond ((<= n 0)             (error-positive-integer 'moa n 'range))
     304                ((<= n MAXIMUM-RANGE) (moa-random-integer state n))
    302305                (else                 (moa-random-large state n)))))
    303306      ;
  • release/4/srfi-27/trunk/mrg32k3a.scm

    r17328 r17331  
    1616          srfi-4
    1717          (only numbers <= - /)
     18          (only type-errors error-positive-integer)
    1819          random-source
    1920          entropy-source
     
    2324    srfi-4
    2425    numbers
     26    type-errors
    2527    random-source entropy-source srfi-27-numbers)
    2628
     
    424426      (lambda ()
    425427        (lambda (n)
    426           (cond ((<= n MAXIMUM-RANGE) (mrg32k3a_random_integer state n))
     428          (cond ((<= n 0)             (error-positive-integer 'mrg32k3a n 'range))
     429                ((<= n MAXIMUM-RANGE) (mrg32k3a_random_integer state n))
    427430                (else                 (mrg32k3a-random-large state n)))))
    428431      ;
  • release/4/srfi-27/trunk/mwc.scm

    r17328 r17331  
    1212          srfi-4
    1313          (only numbers <= - /)
     14          (only type-errors error-positive-integer)
    1415          random-source
    1516          entropy-source
     
    1920    srfi-4
    2021    numbers
     22    type-errors
    2123    random-source entropy-source srfi-27-numbers)
    2224
     
    250252      (lambda ()
    251253        (lambda (n)
    252           (cond ((<= n MAXIMUM-RANGE) (mwc-random-integer state n))
     254          (cond ((<= n 0)             (error-positive-integer 'mwc n 'range))
     255                ((<= n MAXIMUM-RANGE) (mwc-random-integer state n))
    253256                (else                 (mwc-random-large state n)))))
    254257      ;
  • release/4/srfi-27/trunk/srfi-27-distributions.scm

    r17330 r17331  
    5353(define-inline (*-inverse n) (/ -1.0 n))
    5454
     55(define (fxadd1 n) (fx+ 1 n))
     56
    5557;;; Normal distribution
    5658
     
    6668            (+ mu (* sigma result)))
    6769          (let loop ()
    68             (let* ((v1 (- (* 2 (randoms)) 1.0))
    69                    (v2 (- (* 2 (randoms)) 1.0))
     70            (let* ((v1 (- (* 2.0 (randoms)) 1.0))
     71                   (v2 (- (* 2.0 (randoms)) 1.0))
    7072                   (s (+ (* v1 v1) (* v2 v2))))
    7173              (if (<= 1.0 s)
    7274                  (loop)
    73                   (let ((scale (sqrt (/ (* -2 (log s)) s))))
     75                  (let ((scale (sqrt (/ (* -2.0 (log s)) s))))
    7476                    (set! next (* scale v2))
    7577                    (+ mu (* sigma scale v1))))))))) )
     
    131133    (lambda ()
    132134      ; FIXME O(mu) but O(log(mu)) desired for >> mu
    133       (do ((m 0 (fx+ 1 m))
     135      (do ((m 0 (fxadd1 m))
    134136           (prod (randoms) (* prod (randoms))))
    135137          ((<= prod emu) m)))) )
     
    145147
    146148(define (*make-random-bernoullis p randoms)
    147   (cond ((zero? p) (lambda () #f))
     149  (cond ((= 0.0 p) (lambda () #f))
    148150        ((= 1.0 p) (lambda () #t))
    149151        (else      (lambda () (<= (randoms) p)))) )
     
    161163  (let ((bernoullis (*make-random-bernoullis p randoms)))
    162164    ;FIXME O(t) but O(log(t)) desired for >> t
    163     (if (< t most-positive-fixnum)
     165    (if (fixnum? t)
    164166        (lambda ()
    165           (do ((i 0 (fx+ 1 i))
    166                (n 0 (if (bernoullis) (fx+ 1 n) n)))
     167          (do ((i 0 (fxadd1 i))
     168               (n 0 (if (bernoullis) (fxadd1 n) n)))
    167169              ((fx<= t i) n)))
    168170        (lambda ()
    169           (do ((i 0 (+ 1 i))
    170                (n 0 (if (bernoullis) (+ 1 n) n)))
     171          (do ((i 0 (add1 i))
     172               (n 0 (if (bernoullis) (add1 n) n)))
    171173              ((<= t i) n))))) )
    172174
     
    197199  (let ((normals (*make-random-normals 0.0 1.0 randoms))
    198200        (nmu (log (* mu (/ mu (sqrt (+ (* sigma sigma) (* mu mu)))))))
    199         (nsigma (sqrt (log (+ 1 (* sigma (/ sigma mu mu)))))))
     201        (nsigma (sqrt (log (+ 1.0 (* sigma (/ sigma mu mu)))))) )
    200202    (lambda () (exp (+ nmu (* (normals) nsigma))))) )
    201203
     
    310312  (let ((invscale (*-inverse scale))
    311313        (invshape (*inverse shape)) )
    312     (lambda () (expt (* invscale (log (- 1 (randoms)))) invshape)) ) )
     314    (lambda () (expt (* invscale (log (- 1.0 (randoms)))) invshape)) ) )
    313315
    314316(define (make-random-weibulls #!key (shape 1.0) (scale 1.0) (randoms (make-uniform-random-reals)))
  • release/4/srfi-27/trunk/srfi-27-srfi-4.scm

    r17330 r17331  
    1515  (import scheme
    1616          chicken
    17           foreign
    18            (only srfi-4
     17          (only srfi-4
    1918            u8vector-length u8vector-ref u8vector-set!)
    2019            f32vector-length f32vector-ref f32vector-set!)
  • release/4/srfi-27/trunk/srfi-27-uniform-random.scm

    r17330 r17331  
    3838  (check-integer 'make-uniform-random-integers low 'low)
    3939  (check-positive-integer 'make-uniform-random-integers precision 'precision)
     40  ; Just allow it
    4041  (unless (< low high) (exchange! low high))
     42  ; Better be true now (cannot have a 0 range)
     43  (unless (< low high)
     44    (error 'make-uniform-random-integers "`low' must be strictly less-than `high'" low high))
    4145  (values
    4246    (*make-uniform-random-integers high low precision ((@random-source-make-integers source)))
  • release/4/srfi-27/trunk/srfi-27-vector.scm

    r17330 r17331  
    2727  (import (except scheme + * / sqrt expt)
    2828          chicken
    29           (only srfi-4
    30             f32vector? f32vector-length f32vector-ref f32vector-set!
    31             f64vector? f64vector-length f64vector-ref f64vector-set!)
    3229          (only numbers + * / sqrt expt)
    33           (only vector-lib vector-map! vector-fold)
    3430          (only type-checks check-cardinal-integer check-vector)
    3531          (only type-errors error-vector)
    3632          random-source
    37           srfi-27
    3833          srfi-27-uniform-random
    39           (only srfi-27-numbers check-real))
     34          (only srfi-27-numbers check-real)
     35          srfi-27-vector-support)
    4036
    4137  (require-library
    42     srfi-4
    4338    numbers
    44     vector-lib
    4539    type-checks type-errors
    46     random-source srfi-27 srfi-27-uniform-random srfi-27-numbers)
     40    random-source srfi-27-uniform-random srfi-27-numbers srfi-27-vector-support)
    4741
    4842  (declare (not usual-integrations + * / sqrt expt))
     
    5246; (in case special processing needed near limits TBD)
    5347(define (*inverse n) (/ 1.0 n))
    54 
    55 ;;; Vector% Support
    56 
    57 #; ;NOT YET
    58 (define (array-rank/1? obj) (and (array? obj) (fx= 1 (array-rank obj))))
    59 
    60 (define (check-vector% loc obj #!optional argnam)
    61   (unless (or (vector? obj)
    62               (f32vector? obj)
    63               (f64vector? obj)
    64               #; ;NOT YET
    65               (array-rank/1? vec) )
    66     (error-vector loc obj argnam) ) )
    67 
    68 (define (vector%-length vec)
    69   (cond ((vector? vec)        (vector-length vec))
    70         ((f32vector? vec)     (f32vector-length vec))
    71         ((f64vector? vec)     (f64vector-length vec))
    72         #; ;NOT YET
    73         ((array-rank/1? vec)  (car (array-dimensions vec)))
    74         (else
    75           (error-vector #f vec))) )
    76 
    77 (define (vector%-mapi!/1 proc vec)
    78   (cond ((vector? vec)        (vector-map! proc vec))
    79         ((f32vector? vec)     (f32vector-mapi!/1 proc vec))
    80         ((f64vector? vec)     (f64vector-mapi!/1 proc vec))
    81         #; ;NOT YET
    82         ((array-rank/1? vec)  (array-map! vec (cut proc #f <>)))
    83         (else
    84           (error-vector #f vec))) )
    85 
    86 (define (vector%-foldi/1 proc seed vec)
    87   (cond ((vector? vec)        (vector-fold proc seed vec))
    88         ((f32vector? vec)     (f32vector-foldi/1 proc seed vec))
    89         ((f64vector? vec)     (f64vector-foldi/1 proc seed vec))
    90         #; ;NOT YET
    91         ((array-rank/1? vec)  (array-fold (cut proc #f <> <>) seed vec))
    92         (else
    93           (error-vector #f vec))) )
    94 
    95 (define (vector%-scale! vec factor)
    96   (vector%-mapi!/1 (lambda (i elm) (* elm factor)) vec) )
    97 
    98 (define (vector%-sum-squares vec)
    99   (vector%-foldi/1 (lambda (i sum elm) (+ sum (* elm elm))) 0 vec) )
    10048
    10149;;;
  • release/4/srfi-27/trunk/srfi-27.meta

    r17330 r17331  
    33((egg "srfi-27.egg")
    44 (category data)
    5  (author "[[kon lovett]]")
     5 (author "Sebastian Egner & [[kon lovett]]")
    66 (license "BSD")
    77 (doc-from-wiki)
    88 (synopsis "Sources of Random Bits")
    9  (needs setup-helper dollar easyffi miscmacros vector-lib numbers synch mathh)
     9 (needs setup-helper check-errors miscmacros vector-lib numbers synch)
    1010 (files
    1111  "tests"
     
    3030        "srfi-27-uniform-random.scm"
    3131        "srfi-27-numbers.scm"
    32         "srfi-27-srfi-4.scm"
     32        "srfi-27-vector-support.scm"
    3333        "srfi-27.scm"
    3434  "srfi-27.setup") )
  • release/4/srfi-27/trunk/srfi-27.setup

    r16556 r17331  
    1717    #;-no-procedure-checks) )
    1818
     19(setup-shared-extension-module 'thread-reaper (extension-version "3.0.0")
     20  #:compile-options '(
     21    -optimize-level 3
     22    ;-debug-level 0
     23    #;-no-procedure-checks) )
     24
    1925(setup-shared-extension-module 'timed-resource (extension-version "3.0.0")
     26  #:compile-options '(
     27    -optimize-level 3
     28    ;-debug-level 0
     29    #;-no-procedure-checks) )
     30
     31(setup-shared-extension-module 'srfi-27-numbers (extension-version "3.0.0")
     32  #:compile-options '(
     33    -optimize-level 3
     34    ;-debug-level 0
     35    #;-no-procedure-checks) )
     36
     37(setup-shared-extension-module 'srfi-27-vector-support (extension-version "3.0.0")
    2038  #:compile-options '(
    2139    -optimize-level 3
     
    7997    #;-no-procedure-checks) )
    8098
    81 (setup-shared-extension-module 'srfi-27-large-numbers (extension-version "3.0.0")
    82   #:compile-options '(
    83     -optimize-level 3
    84     ;-debug-level 0
    85     #;-no-procedure-checks) )
    86 
    8799(setup-shared-extension-module 'mrg32k3a (extension-version "3.0.0")
    88100  #:compile-options '(
     
    109121    #;-no-procedure-checks) )
    110122
     123(setup-shared-extension-module 'srfi-27-uniform-random (extension-version "3.0.0")
     124  #:compile-options '(
     125    -optimize-level 3
     126    ;-debug-level 0
     127    #;-no-procedure-checks) )
     128
    111129(setup-shared-extension-module 'srfi-27-distributions (extension-version "3.0.0")
    112130  #:compile-options '(
     
    114132    ;-debug-level 0
    115133    #;-no-procedure-checks) )
     134
     135(setup-shared-extension-module 'srfi-27-vector (extension-version "3.0.0")
     136  #:compile-options '(
     137    -optimize-level 3
     138    ;-debug-level 0
     139    #;-no-procedure-checks) )
Note: See TracChangeset for help on using the changeset viewer.