diff --git a/collects/tests/typed-scheme/succeed/foldo.scm b/collects/tests/typed-scheme/succeed/foldo.scm new file mode 100644 index 0000000000..c8de9df63a --- /dev/null +++ b/collects/tests/typed-scheme/succeed/foldo.scm @@ -0,0 +1,58 @@ +(module foldo mzscheme + (require (lib "file.ss")(lib "match.ss")) + (provide apply-to-scheme-files) + + (define-syntax (define-excluder stx) + + (define (path->clause c) + (syntax-case c () + [(item ...) + #`[`(#,@(reverse (syntax-e #'(item ...))) ,_ (... ...)) #t]] + [item + #`[`(item) #t]])) + + (syntax-case stx () + [(_ name path ...) + (with-syntax ([(match-clause ...) (map path->clause (syntax-e #'(path ...)))]) + #`(define (name p ) + (let* ([dirnames (map path->string (explode-path p))]) + (match (reverse dirnames) ; goofy backwards matching because ... matches greedily + match-clause ... + [_ #f]))))])) + + (define-excluder default-excluder + "compiled" ".svn" #;("collects" "drscheme") #;("collects" "framework")) + + (define exclude-directory? (make-parameter default-excluder)) + + ;; ---------------------------------------- + ;; apply-to-scheme-files: (path[file] -> X) path[directory] -> (listof X) + ;; applies the given function to each .ss or .scm file in the given directory + ;; hierarchy; returns all results in a list + (define (apply-to-scheme-files f root ) + ;;FOLD-FILES + + (fold-files + (lambda (path kind acc) + (case kind + [(file) + (let ([extension (filename-extension path)]) + (cond + [(not extension) acc ] + [(regexp-match #rx"(ss|scm)$" extension) + (let ([resl (f path)]) + (if resl + (cons resl acc) + acc ))] + [else acc ]))] + [(dir) + (let* ([p (normalize-path path root)]) + (if ((exclude-directory?) p) + (values acc #f) + acc ))] + [(link) acc ] + [else (error "never happen")])) + '() + root + )) + ) \ No newline at end of file diff --git a/collects/tests/typed-scheme/succeed/list-ref-vec.ss b/collects/tests/typed-scheme/succeed/list-ref-vec.ss new file mode 100644 index 0000000000..a602f90349 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/list-ref-vec.ss @@ -0,0 +1,6 @@ +#lang typed-scheme + +(: x : (Listof (Vectorof Integer))) +(define x (list (vector 1 2 3))) + +(list-ref x 0) \ No newline at end of file diff --git a/collects/tests/typed-scheme/succeed/metrics.ss b/collects/tests/typed-scheme/succeed/metrics.ss new file mode 100644 index 0000000000..078d8152d1 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/metrics.ss @@ -0,0 +1,539 @@ +#lang typed-scheme +(provide results run-all-tests) + +#;(require "../list.scm" + "../etc.ss") +(require/typed apply-to-scheme-files + ((Path -> (Listof (Listof (U #f (Listof (U Number #f)))))) + Path + -> (Listof (U #f (Listof (Listof ( U #f (Listof (U Number #f)))))))) "foldo.scm") + +(define-type-alias top Any) +(define-type-alias str String) + +(require/typed filename-extension (Path -> (U #f Bytes)) (lib "file.ss")) +(require/typed normalize-path (Path Path -> Path) (lib "file.ss")) +(require/typed explode-path (Path -> (Listof Path)) (lib "file.ss")) +(require/typed srfi48::format ( Port String String top .. -> top) "patch.ss") +;; FIXME - prefix +#;(require/typed srfi48:format ( Port String String top .. -> top) (prefix srfi48: (lib "48.ss" "srfi"))) +(require (lib "match.ss") + ;(lib "file.ss") + ;(lib "list.ss") + ;(lib "etc.ss") + (prefix-in srfi13: (lib "13.ss" "srfi")) + ;(prefix srfi48: (lib "48.ss" "srfi")) + ) + +(define-type-alias Sexpr Any) +(define-type-alias number Number) +(define-type-alias boolean Boolean) +(define-type-alias NumF (U number #f)) +(define-type-alias NumB (U boolean number)) +;;C is either Sexpr or Listof Sepr +;;X = (Listof (U number #f)) - not needed as a parameter +(define-type-alias (Unit X C) ((C -> X) -> (Path -> (Listof (U #f X))))) + +;; ============================================================ +;; CONFIG +(define: COLLECTS-PATH : (Parameter Path Path ) (make-parameter (build-path "/proj/scheme/plt/collects" #;"~/svn/plt/collects/"))) +(define: PLANET-CODE-PATH : (Parameter Path Path) (make-parameter (build-path "~/Desktop/most-recent-archives/" #;"~/local/src/planet/most-recent-archives/"))) + +; collects-path : a path to the collects directory to compare +; planet-code-path : a path to the "other" code to compare (i.e. unpacked, most recent versions +; of all planet packages) + +;; ============================================================ +;; STATS + +;; t-test : (listof number) (listof number) -> number +;; computes t value for the given sequences. t-tests measure +;; the extent to which difference in mean between two sets of +;; _interval-valued_ samples (e.g. distances, times, weights, counts ...) +;; can be explained by chance. Generally speaking, higher absolute +;; values of t correspond to higher confidence that an observed difference +;; in mean cannot be explained by chance. +(define: (t-test [seqA : (Listof number)] [seqB : (Listof number)]) : number + (manual-t-test + (avg seqA) (avg seqB) + (variance seqA) (variance seqB) + (length seqA) (length seqB))) + +(define: (manual-t-test [avga : number] [avgb : number] [vara : number] + [varb : number] [cta : number] [ctb : number]) : number + (/ (- avga avgb) + (sqrt (+ (/ vara cta) (/ varb ctb))))) + +;; chi-square : (listof [0,1]) (listof [0,1]) -> number +;; chi-square is a simple measure of the extent to which the +;; difference in the frequency of 0's and 1's in the first +;; sequence and their frequency in the second sequence can +;; be explained by chance. higher numbers means higher confidence +;; that they cannot. +(define: (chi-square [seqA : (Listof number)] [seqB : (Listof number)]) : number + (with-handlers ([exn:fail? (lambda: ([e : str]) +nan.0)]) + (let* ([ct-a (length seqA)] + [ct-b (length seqB)] + [total-subjects (+ ct-a ct-b)] + [a-hits (apply + seqA)] + [b-hits (apply + seqB)] ;; these assume that the data is coded as 1 = present, 0 = not present + [a-misses (- ct-a a-hits)] + [b-misses (- ct-b b-hits)] + [table + `((,a-hits ,b-hits) + (,a-misses ,b-misses))] + [expected (lambda: ([i : Integer] [j : Integer]) + (/ (* (row-total i table) (col-total j table)) total-subjects))]) + (exact->inexact + (table-sum + (lambda: ([i : Integer] [j : Integer]) + (/ (sqr (- (expected i j) (table-ref i j table))) (expected i j))) + table))))) + +;; ============================================================ +;; UNITS OF MEASUREMENT IMPLEMENTATIONS + +;; per-module : path ((listof expr) -> (number | #f)) -> (path -> (listof (number | #f))) === Unit P +(pdefine: (X) (per-module [f : ((Listof Sexpr) -> X )]) : (Path -> (cons (U #f X) '())) + (lambda: ([path : Path]) + (with-handlers ([exn:fail:read? (lambda: ([e : Void]) (list #f))]) ;; with handler + (let ([initial-sexp (with-input-from-file path read)]) + (match initial-sexp + [`(module ,_ ,_ . , (? list? bodies)) ;; FIXME - use ... instead of . + (list (f bodies))] + [_ (list #f)]))))) + + +;; per-module-top-level-expression : path (expr -> (number | #f)) -> (path -> (listof (number | #f))) +(define: (per-module-top-level-expression [f : (Sexpr -> (Listof NumF))] ) : ( Path -> (Listof (U #f (Listof NumF)))) + (let ([calc (per-module (lambda: ([exprs : (Listof Sexpr)]) (map f exprs)))]) + (lambda: ([p : Path]) (let* ([r (calc p)] + [carr (car r)]) ;;carr added + (if carr carr + (list carr)))))) ;; list carr instead of r + +;; ============================================================ +;; BASIC CALCULATIONS +;; (for use with metric definitions below) + +;; ---------------------------------------- +;; depth + +(define: (sexp-depth [sexp : Any]) : number + (cond + [(list? sexp) ;; (pair? sexp) + (+ (max-sexp-depth sexp) 1)] + [else 0])) + +(define: (max-sexp-depth [losx : (Listof Any)]) : number + (improper-foldr (lambda: ([t : Any] [r : number]) (max (sexp-depth t) r)) 0 losx)) + +(define: (avg-sexp-depth [sexps : (Listof Any)]) : number + (cond + [(null? sexps) 0] + [else (avg (map sexp-depth sexps))])) + +;; ---------------------------------------- +;; setbang counts + +(define-type-alias (IList e) (mu x (Un e '() (cons e x)))) + +;; count-setbangs/ilist : ((ilistof expr) -> number) +(define: (count-setbangs/ilist [exprs : (Listof Any)]) : number + (apply + (imap count-setbangs/expr exprs))) + +;; FIXME - changes having to do with match ... +(define: (count-setbangs/expr [expr : Any]) : number + (match expr + [`(,(? setbang?) . ,rest ) ;(,(? setbang?) ,rest ...) + (if (list? rest) + (+ 1 (count-setbangs/ilist rest)) + 0)] ;; mostly occurs in syntax patterns + [('quote _) 0] + [('quasiquote _) 0] ; undercount potentially, but how many `,(set! ...)'s can there be? + [`(,e1 . ,e2) + (if (list? expr) + (count-setbangs/ilist expr) + (error " l" expr ))] ;;FIXME - do something intelligent here + [_ 0])) + +;; setbang? : sexp -> boolean +(define: (setbang? [v : Any]) : Any + (and (symbol? v) + (regexp-match #rx"^set(-.*)?!" (symbol->string v)))) + +;; count-fns +(define: (count-fns-with-setbangs [exprs : (Listof Sexpr)]) : number + (apply + (map (lambda: ([e : Sexpr]) (if (= (count-setbangs/expr e) 0) 0 1)) exprs))) +(define: (module-has-setbangs? [exprs : (Listof Sexpr)]) : Boolean + (ormap expr-uses-setbangs? exprs)) +(define: (expr-uses-setbangs? [expr : Sexpr]) : Boolean + (not (= (count-setbangs/expr expr) 0))) + +(define: (setbangs-per-1000-atoms [exprs : (Listof Any)]) : NumF + (if (null? exprs) + #f + (let ([set!s (count-setbangs/ilist exprs)] + [atoms (atoms exprs)]) + (* (/ set!s atoms) 1000.0)))) + +;; ---------------------------------------- +;; contracts + + +(define: (uses-contracts [exprs : (Listof Sexpr)]) : Boolean + (ormap (lambda: ([e : Sexpr]) + (match e + [`(provide/contract . ,_) #t] + [_ #f])) + exprs)) + +(define: (contracted-provides [exprs : (Listof Sexpr)]): number + (foldl + (lambda: ([t : Sexpr] [r : number]) + (match t + ;; FIXME match ... + [`(provide/contract . ,p ) ;(provide/contract ,p ...) + (if (list? p) + (+ (length p) r) + r)] ;; extra case added + [_ r])) + 0 + exprs)) + +;; FIXME - same problem with match ... +(define: (uncontracted-provides [exprs : (Listof Sexpr)]) : number + (foldl + (lambda: ([t : Sexpr] [r : number]) + (match t + [`(provide . ,p ) ;(provide ,p ...) + (if (list? p) + (+ (length p) r) + r)] + [_ r])) + 0 + exprs)) + +;; ---------------------------------------- +;; macros + +(define: (number-of-macro-definitions [expr : Sexpr]) : number + (match expr + [`(define-syntax ,_ ...) 1] + [`(define-syntaxes (,s . ,r ). ,_ ) ;`(define-syntaxes (,s ...) ,_ ...) + (if (and (list? expr)(list? r)) + (length (cons s r));;s -> cadr expr + (error "corrupted file"))] + [`(define-syntax-set (,s . ,r) . ,_ ) ;(define-syntax-set (,s ...) ,_ ...) + (if (and (list? expr) (list? r)) + (length (cons s r)) + (error "corrupted file"))] + [_ 0])) + +(define: (num-of-define-syntax [exprs : (Listof Sexpr)]) : number + (foldl (lambda: ([t : Sexpr] [r : number]) (+ (number-of-macro-definitions t) r)) 0 exprs)) + +;; ---------------------------------------- +;; expression size + +(define: (atoms [sexp : Any]) : number + (cond + [(null? sexp) 0] + [(not (pair? sexp)) 1] + [else (+ (atoms (car sexp)) (atoms (cdr sexp)))])) + +(define: (max-atoms [exprs : (Listof Sexpr)]) : NumF + (let ([atom-counts (map atoms exprs)]) + (if (null? atom-counts) + #f + (apply max 0 atom-counts)))) ;; FIXME: expected at least 2 argument---> 0 added !!! + +(define: (avg-atoms [exprs : (Listof Sexpr)]) : NumF + (let ([atom-counts (map atoms exprs)]) + (if (null? atom-counts) + #f + (avg (map atoms exprs))))) + +(define: (total-atoms [exprs : (Listof Sexpr)]) : number + (apply + (map atoms exprs))) + + +;; ============================================================ +;; METRIC DEFINITIONS +;; 'a 'b metric : (string * (listof sexp -> 'a option) * ((listof 'a) (listof 'a) -> 'b) +(define-typed-struct (b c d) metric ([analysis-unit : (Unit (Listof NumF) c)] + [computation : (c -> d)] + [>display : ((Listof d) (Listof d) -> b)])) +(define-type-alias Metric metric) +(define-type-alias Table (Listof (Listof Number))) +(define-type-alias Atom-display (cons Symbol (Listof Number))) + +(define: (standard-display [name : Symbol] + [summarize : ((Listof number) -> number)] + [significance-test : ((Listof number)(Listof number) -> number)]) + : ((Listof NumF) (Listof NumF) -> Atom-display) + ;; FIXME - use lambda instead of (define (( + (lambda: ([seqA : (Listof NumF)] [seqB : (Listof NumF)]) + (let ([clean-seqA (nonfalses seqA)] + [clean-seqB (nonfalses seqB)]) + (list name (summarize clean-seqA) (summarize clean-seqB) (significance-test clean-seqA clean-seqB))))) + +(pdefine: (c) (interval [u : (Unit (Listof NumF) c)] + [name : Symbol] + [compute : (c -> NumF)]) + : (Metric Atom-display c NumF) + (make-metric u compute (standard-display name avg t-test))) + +(pdefine: (c) (count [u : (Unit (Listof NumF) c)] + [name : Symbol] + [compute : (c -> Boolean)]) + : (Metric Atom-display c NumF) + (make-metric u (lambda: ([es : c]) #{(if (compute es) 1 0) :: NumF}) (standard-display name avg chi-square))) + +(pdefine: (c) (combine-metrics [ms : (Listof (Metric Atom-display c NumF))]) + : (Metric (Listof Atom-display) c (Listof NumF)) + (let ([u (metric-analysis-unit (car ms))]) + ;; This test now redundant b/c of typechecking + (unless (andmap (lambda: ([m : (Metric Atom-display c NumF) ]) (eq? u (metric-analysis-unit m))) ms) + (error 'combine-metrics "all combined metrics must operate on the same unit of analysis")) + + (make-metric + u + (lambda: ([exprs : c] ) (map (lambda: ([m : (Metric Atom-display c NumF)]) ((metric-computation m) exprs)) ms)) + (lambda: ([seqA : (Listof (Listof NumF))] [seqB : (Listof (Listof NumF))]) + (map (lambda: ([m : (Metric Atom-display c NumF)] + [sA : (Listof NumF)] + [sB : (Listof NumF)]) + ((metric->display m) sA sB)) ms (pivot seqA) (pivot seqB)))))) + +;; FIXME - should go in helper file +;; FIXME - (filter (lambda (x) x) l) +(pdefine: (X) (nonfalses [l : (Listof (U #f X))]) : (Listof X) + (let: loop : (Listof X) ([lst :(Listof (U #f X)) l]) + (if (null? lst) + '() + (let ([x (car lst)]) + (if x + (cons x (loop (cdr lst))) + (loop (cdr lst))))))) + +(define: (avg [l : (Listof number)]) : number + (/ (exact->inexact (apply + l)) (length l))) +(define: (avg* [l : (Listof number)]) : number + (avg (nonfalses l))) + +(define-syntax define-metrics + (syntax-rules () + [(define-metrics all-metrics-id unit-of-analysis type (name kind fn) ...) ;;TYPE ADDED !!!! + (begin + (define: u : ((type -> (Listof NumF)) -> (Path -> (Listof (U #f(Listof NumF))))) unit-of-analysis ) + (define: name : (Metric Atom-display type NumF) (kind u 'name fn )) ... + (define: all-metrics-id : (Metric (Listof Atom-display) type (Listof NumF)) (combine-metrics (list name ...))))])) + +(define-metrics module-metrics #{ per-module @ (Listof NumF)} (Listof Sexpr) + (maximum-sexp-depth interval max-sexp-depth) + (average-sexp-depth interval avg-sexp-depth) + (number-of-setbangs/mod interval count-setbangs/ilist) + (number-of-exprs interval #{length @ (Listof Sexpr)}) + (uses-setbang?/mod count module-has-setbangs?) + (uses-contracts? count uses-contracts) + (number-of-contracts interval contracted-provides) + (num-uncontracted-provides interval uncontracted-provides) + (number-of-macro-defs interval num-of-define-syntax) + (maximum-num-atoms interval max-atoms) + (average-num-atoms interval avg-atoms) + (total-num-atoms/mod interval total-atoms) + (set!s-per-1000-atoms interval setbangs-per-1000-atoms)) + +(define-metrics tl-expr-metrics per-module-top-level-expression Sexpr + (uses-setbang?/fn count expr-uses-setbangs?) + (number-of-setbangs/fn interval count-setbangs/expr) + (total-num-atoms/fn interval atoms)) + +(define: all-metrics : (cons (Metric (Listof Atom-display) (Listof Sexpr) (Listof NumF)) + (cons (Metric (Listof Atom-display) Sexpr (Listof NumF)) + '() )) + (list module-metrics tl-expr-metrics)) + +;; ============================================================ +;; EXPERIMENT RUNNING + +;; FIXME - everything in untyped file (foldo.ss) b/c fold-files has terrible api +#;(define-syntax (define-excluder stx) + + (define (path->clause c) + (syntax-case c () + [(item ...) + #`[`(#,@(reverse (syntax-e #'(item ...))) ,_ (... ...)) #t]] + [item + #`[`(item) #t]])) + + (syntax-case stx () + [(_ name path ...) + (with-syntax ([(match-clause ...) (map path->clause (syntax-e #'(path ...)))]) + #`(define: (name [p : Path]) : top + (let* ([dirnames (map path->string (explode-path p))]) + (match (reverse dirnames) ; goofy backwards matching because ... matches greedily + match-clause ... + [_ #f]))))])) + +#;(define-excluder default-excluder + "compiled" ".svn" #;("collects" "drscheme") #;("collects" "framework")) + +#;(define: exclude-directory? : (Parameter (Path -> Any)) (make-parameter default-excluder)) + +;; ---------------------------------------- +;; apply-to-scheme-files: (path[file] -> X) path[directory] -> (listof X) +;; applies the given function to each .ss or .scm file in the given directory +;; hierarchy; returns all results in a list +#;(define: (apply-to-scheme-files [f : (Path -> (Listof(Listof(Listof NumF))))] + [root : Path]) + : (Listof (Listof(Listof(Listof NumF)))) ;;FOLD-FILES + + (fold-files + (lambda: ([path : Path] [kind : Symbol] + [acc : (Listof (Listof(Listof(Listof NumF))))]) + (case kind + [(file) + (let ([extension (filename-extension path)]) + (cond + [(not extension) #;acc (values acc #t)] + [(regexp-match #rx"(ss|scm)$" extension) + (let ([resl (f path)]) + (if resl + #;(cons resl acc) (values (cons resl acc) #t) ;;values added + #;acc (values acc #t)))] + [else #;acc (values acc #t)]))] + [(dir) + (let* ([p (normalize-path path root)]) + (if ((exclude-directory?) p) + #; acc (values acc #f) + #;acc (values acc #t)))] ;; values added + [(link) #;acc (values acc #t)] + [else (error "never happen")])) ;;error added + '() + root + #t)) ;;value added + +(define-typed-struct (a b c) result ([metric : (Metric b c a)] [seqA : (Listof a)] [seqB : (Listof a)])) +(define-type-alias Result result) + +;; get-sequences : (listof 'a metric) path -> (listof (listof 'a)) + +(pdefine: (b c C) (get-sequences [metrics : (Listof (U(Metric b c (Listof NumF))(Metric b C (Listof NumF))))] + [path : Path]) + : (Listof (Listof (Listof NumF))) + (let* ([metric-fns ; : (Listof (Path -> (Listof (U #f(Listof NumF))))) + (map (lambda: ([m : (Metric b c (Listof NumF))]) + ((metric-analysis-unit m) + (metric-computation m))) metrics)] + [result-seqs ; : (Listof (U #f (Listof (Listof ( U #f (Listof NumF)))))) + (apply-to-scheme-files + (lambda: ([file : Path]) + (map (lambda: ([fn : (Path -> (Listof (U #f (Listof NumF))))]) (fn file)) metric-fns)) path)]) + (map (lambda: ([l : (Listof(Listof (Listof NumF)))]) + ;; FIXME - problem with inference and ordering + (#{nonfalses @ (Listof NumF)} (apply append l))) + (pivot (#{nonfalses @ (Listof(Listof (U #f (Listof NumF))))} result-seqs))))) + +;; compare : (listof metric) -> (listof result) +(pdefine: ( b c C) (compare* [metrics : (Listof (U (Metric b c (Listof NumF)) (Metric b C (Listof NumF))))]) : (Listof (U (Result (Listof NumF) b C)(Result (Listof NumF) b c))) + (let* ([seqAs (get-sequences metrics (COLLECTS-PATH))] + [seqBs (get-sequences metrics (PLANET-CODE-PATH))]) + (map #{make-result @ (Listof NumF) b c} metrics seqAs seqBs))) + +(pdefine: (a b c) (show [result : (Result a b c)]) : b + ((metric->display (result-metric result)) + (result-seqA result ) + (result-seqB result ))) + +(define: (pretty-print-result [result : (Result (Listof NumF) (Listof Atom-display) Any)]) : Void + (for-each + (lambda: ([l : (Listof top)]) + (apply srfi48::format ;;sfri48:format + (current-output-port) + "~26F | ~8,2F | ~6,2F | ~12,2F\n" + (format "~a" (car l)) + (cdr l))) + #{(list* '("test name" "collects" "planet" "significance") ;;list instead of list* + '("---------" "--------" "------" "------------") + (show result )) :: List})) + +;; applies only to the combined metric [or more generally to listof-answer results] +(pdefine: (a b c) (total [experiment-number : Integer] [result : (Result (Listof number) b c)]) : (Listof number) + (define: (total/s [s : Table]) : number (apply + (list-ref (pivot s) experiment-number))) + (list (total/s (result-seqA result)) (total/s (result-seqB result)))) + +;; ============================================================ +;; UTILITY + +(pdefine: (X Y) (imap [f : (X -> Y)] [il : (Listof X)]) : (Listof Y) + (cond + [(null? il) '()] + [(not (pair? il)) (list (f il))] + [else (cons (f (car il)) (imap f (cdr il)))])) + +(pdefine: (X) (pivot [l : (Listof (Listof X))]): (Listof (Listof X)) + (cond + [(null? l) '()] + [else + (let ([n (length (car l))]) + (build-list n (lambda: ([i : Integer]) (map (lambda: ([j : (Listof X)]) (list-ref j i)) l))))])) + +(define: (sqr [x : number]) : number (* x x)) +(define: (variance [xs : (Listof number)]): number + (let ([avg (/ (apply + xs) (length xs))]) + (/ (apply + (map (lambda: ([x : number]) (sqr (- x avg))) xs)) + (sub1 (length xs))))) + +(define: (table-ref [i : Integer] [j : Integer] [table : Table]): number + (list-ref (list-ref table i) j)) +(define: (row-total [i : Integer] [table : Table]) : number + (apply + (list-ref table i))) +(define: (col-total [j : Integer] [table : Table]) : number + (apply + (map (lambda: ([x : (Listof number)]) (list-ref x j)) table))) +(define: (table-sum [f : (Integer Integer -> number)] [table : Table]) : number + (let ([rows (length table)] + [cols (length (car table))]) + (let: loop : number ([i : Integer 0] [j : Integer 0] [sum : number 0]) + (cond + [(>= j cols) sum] + [(>= i rows) (loop 0 (add1 j) sum)] + [else (loop (add1 i) j (+ sum (f i j)))])))) + +(pdefine: (Y) (improper-foldr [f : (Any Y -> Y)] [b : Y] [l : Any]) : Y + (cond + [(null? l) b] + [(not (pair? l)) + (f l b)] + [else + (f (car l) (improper-foldr f b (cdr l)))])) + +;; unused (and untypeable) +#;(define: (/* . [args : (Listof number)]) : number ;;((number)) against (number) and USELESS + (apply map (lambda: ([ns : number]) (apply / ns)) args)) + + +;; ============================================================ +;; MAIN ENTRY POINT + +(define: results : + Any + ;; FIXME bug in typed scheme when this type is used + #; + (Listof (U (Result (Listof NumF) (Listof Atom-display) (Listof Sexpr)) + (Result (Listof NumF) (Listof Atom-display) Sexpr))) + '()) +; just in case i want to do some more analysis on the results afterwards, +; so i don't have to waste a minute if i forget to bind the return value to something +(define: (run-all-tests) : top + (let: ([rs : (Listof (U (Result (Listof NumF) (Listof Atom-display) (Listof Sexpr)) + (Result (Listof NumF) (Listof Atom-display) Sexpr))) + (compare* + #{all-metrics :: + (Listof (U (Metric (Listof Atom-display) (Listof Sexpr) (Listof NumF)) + (Metric (Listof Atom-display) Sexpr (Listof NumF))))})]) + (set! results rs) + (for-each pretty-print-result rs) + rs)) + diff --git a/collects/tests/typed-scheme/succeed/patch.ss b/collects/tests/typed-scheme/succeed/patch.ss new file mode 100644 index 0000000000..c4d18dc0f5 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/patch.ss @@ -0,0 +1,3 @@ +(module patch scheme + (define srfi48::format format) + (provide srfi48::format)) \ No newline at end of file diff --git a/collects/tests/typed-scheme/succeed/random-bits.ss b/collects/tests/typed-scheme/succeed/random-bits.ss new file mode 100644 index 0000000000..094cb2f471 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/random-bits.ss @@ -0,0 +1,621 @@ +; MODULE DEFINITION FOR SRFI-27 +; ============================= +; +; Sebastian.Egner@philips.com, Mar-2002, in PLT 204 +; +; This file contains the top-level definition for the 54-bit integer-only +; implementation of SRFI 27 for the PLT 204 DrScheme system. +; +; 1. The core generator is implemented in 'mrg32k3a-a.scm'. +; 2. The generic parts of the interface are in 'mrg32k3a.scm'. +; 3. The non-generic parts (record type, time, error) are here. +; +; load the module with +; (require (lib "random-bits.ss" "srfi")) +; +; history of this file: +; SE, 17-May-2003: initial version + +(module random-bits typed-scheme + #;(require (lib "9.ss" "srfi")) + #;(require (lib "23.ss" "srfi")) + + (provide + random-integer random-real default-random-source + make-random-source random-source? random-source-state-ref + random-source-state-set! random-source-randomize! + random-source-pseudo-randomize! + random-source-make-integers random-source-make-reals) + + (define-type-alias Nb Integer) + (define-type-alias Flt Number) + (define-type-alias Nbs (Listof Nb)) + (define-type-alias State (Vectorof Integer)) + (define-type-alias SpList (cons 'lecuyer-mrg32k3a (Listof Nb))) + (define-typed-struct :random-source ( + [state-ref : ( -> SpList)] + [state-set! : ((Listof Nb)-> Void)] + [randomize! : ( -> Void)] + [pseudo-randomize! : (Integer Integer -> Void)] + [make-integers : (-> (Integer -> Integer)) ] + [make-reals : ( Nb .. -> ( -> Number))])) + (define-type-alias Random :random-source) + (define: (:random-source-make + [state-ref : ( -> SpList)] + [state-set! : ((Listof Nb)-> Void)] + [randomize! : ( -> Void)] + [pseudo-randomize! : (Integer Integer -> Void)] + [make-integers : (-> (Integer -> Integer)) ] + [make-reals : (Nb .. -> (-> Number))]) + : Random + (make-:random-source state-ref state-set! randomize! pseudo-randomize! make-integers make-reals )) + + #;(define-record-type :random-source + (:random-source-make + state-ref + state-set! + randomize! + pseudo-randomize! + make-integers + make-reals) + :random-source? + (state-ref :random-source-state-ref) + (state-set! :random-source-state-set!) + (randomize! :random-source-randomize!) + (pseudo-randomize! :random-source-pseudo-randomize!) + (make-integers :random-source-make-integers) + (make-reals :random-source-make-reals)) + + (define: :random-source-current-time : ( -> Nb ) + current-milliseconds) ;;on verra apres + +; implementation begins here + +; 54-BIT INTEGER IMPLEMENTATION OF THE "MRG32K3A"-GENERATOR +; ========================================================= +; +; Sebastian.Egner@philips.com, Mar-2002. +; +; This file is an implementation of Pierre L'Ecuyer's MRG32k3a +; pseudo random number generator. Please refer to 'mrg32k3a.scm' +; for more information. +; +; compliance: +; Scheme R5RS with integers covering at least {-2^53..2^53-1}. +; +; history of this file: +; SE, 18-Mar-2002: initial version +; SE, 22-Mar-2002: comments adjusted, range added +; SE, 25-Mar-2002: pack/unpack just return their argument + +; the actual generator + + +(define: (mrg32k3a-random-m1 [state : State]) : Nb + (let ((x11 (vector-ref state 0)) + (x12 (vector-ref state 1)) + (x13 (vector-ref state 2)) + (x21 (vector-ref state 3)) + (x22 (vector-ref state 4)) + (x23 (vector-ref state 5))) + (let ((x10 (modulo (- (* 1403580 x12) (* 810728 x13)) 4294967087)) + (x20 (modulo (- (* 527612 x21) (* 1370589 x23)) 4294944443))) + (vector-set! state 0 x10) + (vector-set! state 1 x11) + (vector-set! state 2 x12) + (vector-set! state 3 x20) + (vector-set! state 4 x21) + (vector-set! state 5 x22) + (modulo (- x10 x20) 4294967087)))) + +; interface to the generic parts of the generator + +(define: (mrg32k3a-pack-state [unpacked-state : State]) : State + unpacked-state) + +(define: (mrg32k3a-unpack-state [state : State] ) : State + state) + +(define: (mrg32k3a-random-range) : Integer ; m1 + 4294967087) + +(define: (mrg32k3a-random-integer [state : State] [range : Nb]) : Nb ; rejection method + (let* ((q (quotient 4294967087 range)) + (qn (* q range))) + (do: : Nb ((x : Nb (mrg32k3a-random-m1 state) (mrg32k3a-random-m1 state))) ;;no alias accepted + ((< x qn) (quotient x q))))) + +(define: (mrg32k3a-random-real [state : State]) : Number ; normalization is 1/(m1+1) + (* 0.0000000002328306549295728 (+ 1.0 (mrg32k3a-random-m1 state)))) + + +; GENERIC PART OF MRG32k3a-GENERATOR FOR SRFI-27 +; ============================================== +; +; Sebastian.Egner@philips.com, 2002. +; +; This is the generic R5RS-part of the implementation of the MRG32k3a +; generator to be used in SRFI-27. It is based on a separate implementation +; of the core generator (presumably in native code) and on code to +; provide essential functionality not available in R5RS (see below). +; +; compliance: +; Scheme R5RS with integer covering at least {-2^53..2^53-1}. +; In addition, +; SRFI-23: error +; +; history of this file: +; SE, 22-Mar-2002: refactored from earlier versions +; SE, 25-Mar-2002: pack/unpack need not allocate +; SE, 27-Mar-2002: changed interface to core generator +; SE, 10-Apr-2002: updated spec of mrg32k3a-random-integer + +; Generator +; ========= +; +; Pierre L'Ecuyer's MRG32k3a generator is a Combined Multiple Recursive +; Generator. It produces the sequence {(x[1,n] - x[2,n]) mod m1 : n} +; defined by the two recursive generators +; +; x[1,n] = ( a12 x[1,n-2] + a13 x[1,n-3]) mod m1, +; x[2,n] = (a21 x[2,n-1] + a23 x[2,n-3]) mod m2, +; +; where the constants are +; m1 = 4294967087 = 2^32 - 209 modulus of 1st component +; m2 = 4294944443 = 2^32 - 22853 modulus of 2nd component +; a12 = 1403580 recursion coefficients +; a13 = -810728 +; a21 = 527612 +; a23 = -1370589 +; +; The generator passes all tests of G. Marsaglia's Diehard testsuite. +; Its period is (m1^3 - 1)(m2^3 - 1)/2 which is nearly 2^191. +; L'Ecuyer reports: "This generator is well-behaved in all dimensions +; up to at least 45: ..." [with respect to the spectral test, SE]. +; +; The period is maximal for all values of the seed as long as the +; state of both recursive generators is not entirely zero. +; +; As the successor state is a linear combination of previous +; states, it is possible to advance the generator by more than one +; iteration by applying a linear transformation. The following +; publication provides detailed information on how to do that: +; +; [1] P. L'Ecuyer, R. Simard, E. J. Chen, W. D. Kelton: +; An Object-Oriented Random-Number Package With Many Long +; Streams and Substreams. 2001. +; To appear in Operations Research. +; +; Arithmetics +; =========== +; +; The MRG32k3a generator produces values in {0..2^32-209-1}. All +; subexpressions of the actual generator fit into {-2^53..2^53-1}. +; The code below assumes that Scheme's "integer" covers this range. +; In addition, it is assumed that floating point literals can be +; read and there is some arithmetics with inexact numbers. +; +; However, for advancing the state of the generator by more than +; one step at a time, the full range {0..2^32-209-1} is needed. + + +; Required: Backbone Generator +; ============================ +; +; At this point in the code, the following procedures are assumed +; to be defined to execute the core generator: +; +; (mrg32k3a-pack-state unpacked-state) -> packed-state +; (mrg32k3a-unpack-state packed-state) -> unpacked-state +; pack/unpack a state of the generator. The core generator works +; on packed states, passed as an explicit argument, only. This +; allows native code implementations to store their state in a +; suitable form. Unpacked states are #(x10 x11 x12 x20 x21 x22) +; with integer x_ij. Pack/unpack need not allocate new objects +; in case packed and unpacked states are identical. +; +; (mrg32k3a-random-range) -> m-max +; (mrg32k3a-random-integer packed-state range) -> x in {0..range-1} +; advance the state of the generator and return the next random +; range-limited integer. +; Note that the state is not necessarily advanced by just one +; step because we use the rejection method to avoid any problems +; with distribution anomalies. +; The range argument must be an exact integer in {1..m-max}. +; It can be assumed that range is a fixnum if the Scheme system +; has such a number representation. +; +; (mrg32k3a-random-real packed-state) -> x in (0,1) +; advance the state of the generator and return the next random +; real number between zero and one (both excluded). The type of +; the result should be a flonum if possible. + +; Required: Record Data Type +; ========================== +; +; At this point in the code, the following procedures are assumed +; to be defined to create and access a new record data type: +; +; (:random-source-make a0 a1 a2 a3 a4 a5) -> s +; constructs a new random source object s consisting of the +; objects a0 .. a5 in this order. +; +; (:random-source? obj) -> bool +; tests if a Scheme object is a :random-source. +; +; (:random-source-state-ref s) -> a0 +; (:random-source-state-set! s) -> a1 +; (:random-source-randomize! s) -> a2 +; (:random-source-pseudo-randomize! s) -> a3 +; (:random-source-make-integers s) -> a4 +; (:random-source-make-reals s) -> a5 +; retrieve the values in the fields of the object s. + +; Required: Current Time as an Integer +; ==================================== +; +; At this point in the code, the following procedure is assumed +; to be defined to obtain a value that is likely to be different +; for each invokation of the Scheme system: +; +; (:random-source-current-time) -> x +; an integer that depends on the system clock. It is desired +; that the integer changes as fast as possible. + + +; Accessing the State +; =================== + +(define: (mrg32k3a-state-ref [packed-state : State ]) : (cons 'lecuyer-mrg32k3a (Listof Nb)) + (cons 'lecuyer-mrg32k3a + (vector->list (mrg32k3a-unpack-state packed-state)))) + +(define: (mrg32k3a-state-set [external-state : (Listof Nb)]) : State + + (define: (check-value [x : Nb] [m : Nb]) : Boolean + (if (and (integer? x) + (exact? x) + (<= 0 x (- m 1))) + #t + (error "illegal value" x))) + + (if (and (list? external-state) + (= (length external-state) 7) + (eq? (car external-state) 'lecuyer-mrg32k3a)) + (let: ((s : (Listof Nb) (cdr external-state))) + (check-value (list-ref s 0) mrg32k3a-m1) + (check-value (list-ref s 1) mrg32k3a-m1) + (check-value (list-ref s 2) mrg32k3a-m1) + (check-value (list-ref s 3) mrg32k3a-m2) + (check-value (list-ref s 4) mrg32k3a-m2) + (check-value (list-ref s 5) mrg32k3a-m2) + (when (or (zero? (+ (list-ref s 0) (list-ref s 1) (list-ref s 2))) + (zero? (+ (list-ref s 3) (list-ref s 4) (list-ref s 5)))) + (error "illegal degenerate state" external-state)) + (mrg32k3a-pack-state (list->vector s))) + (error "malformed state" external-state))) + + +; Pseudo-Randomization +; ==================== +; +; Reference [1] above shows how to obtain many long streams and +; substream from the backbone generator. +; +; The idea is that the generator is a linear operation on the state. +; Hence, we can express this operation as a 3x3-matrix acting on the +; three most recent states. Raising the matrix to the k-th power, we +; obtain the operation to advance the state by k steps at once. The +; virtual streams and substreams are now simply parts of the entire +; periodic sequence (which has period around 2^191). +; +; For the implementation it is necessary to compute with matrices in +; the ring (Z/(m1*m1)*Z)^(3x3). By the Chinese-Remainder Theorem, this +; is isomorphic to ((Z/m1*Z) x (Z/m2*Z))^(3x3). We represent such a pair +; of matrices +; [ [[x00 x01 x02], +; [x10 x11 x12], +; [x20 x21 x22]], mod m1 +; [[y00 y01 y02], +; [y10 y11 y12], +; [y20 y21 y22]] mod m2] +; as a vector of length 18 of the integers as writen above: +; #(x00 x01 x02 x10 x11 x12 x20 x21 x22 +; y00 y01 y02 y10 y11 y12 y20 y21 y22) +; +; As the implementation should only use the range {-2^53..2^53-1}, the +; fundamental operation (x*y) mod m, where x, y, m are nearly 2^32, +; is computed by breaking up x and y as x = x1*w + x0 and y = y1*w + y0 +; where w = 2^16. In this case, all operations fit the range because +; w^2 mod m is a small number. If proper multiprecision integers are +; available this is not necessary, but pseudo-randomize! is an expected +; to be called only occasionally so we do not provide this implementation. + +(define: mrg32k3a-m1 : Nb 4294967087) ; modulus of component 1 +(define: mrg32k3a-m2 : Nb 4294944443) ; modulus of component 2 + +(define: mrg32k3a-initial-state : (Vectorof Nb); 0 3 6 9 12 15 of A^16, see below + '#( 1062452522 + 2961816100 + 342112271 + 2854655037 + 3321940838 + 3542344109)) + +(define: mrg32k3a-generators : (Listof State) '(#(0 0 0 0 0)) ) ; computed when needed -> Changer #f by a State to hava right type. +(define: (mrg32k3a-pseudo-randomize-state [i : Integer] [j : Integer]) : State + + (define: (product [A : State] [B : State]) : State ; A*B in ((Z/m1*Z) x (Z/m2*Z))^(3x3) + + (define: w : Nb 65536) ; wordsize to split {0..2^32-1} + (define: w-sqr1 : Nb 209) ; w^2 mod m1 + (define: w-sqr2 : Nb 22853) ; w^2 mod m2 + + (define: (lc [i0 : Nb] [i1 : Nb] [i2 : Nb] [j0 : Nb] [j1 : Nb] [j2 : Nb] [m : Nb ] [w-sqr : Nb ]): Nb ; linear combination + (let ((a0h (quotient (vector-ref A i0) w)) + (a0l (modulo (vector-ref A i0) w)) + (a1h (quotient (vector-ref A i1) w)) + (a1l (modulo (vector-ref A i1) w)) + (a2h (quotient (vector-ref A i2) w)) + (a2l (modulo (vector-ref A i2) w)) + (b0h (quotient (vector-ref B j0) w)) + (b0l (modulo (vector-ref B j0) w)) + (b1h (quotient (vector-ref B j1) w)) + (b1l (modulo (vector-ref B j1) w)) + (b2h (quotient (vector-ref B j2) w)) + (b2l (modulo (vector-ref B j2) w))) + (modulo + (+ (* (+ (* a0h b0h) + (* a1h b1h) + (* a2h b2h)) + w-sqr) + (* (+ (* a0h b0l) + (* a0l b0h) + (* a1h b1l) + (* a1l b1h) + (* a2h b2l) + (* a2l b2h)) + w) + (* a0l b0l) + (* a1l b1l) + (* a2l b2l)) + m))) + + (vector + (lc 0 1 2 0 3 6 mrg32k3a-m1 w-sqr1) ; (A*B)_00 mod m1 + (lc 0 1 2 1 4 7 mrg32k3a-m1 w-sqr1) ; (A*B)_01 + (lc 0 1 2 2 5 8 mrg32k3a-m1 w-sqr1) + (lc 3 4 5 0 3 6 mrg32k3a-m1 w-sqr1) ; (A*B)_10 + (lc 3 4 5 1 4 7 mrg32k3a-m1 w-sqr1) + (lc 3 4 5 2 5 8 mrg32k3a-m1 w-sqr1) + (lc 6 7 8 0 3 6 mrg32k3a-m1 w-sqr1) + (lc 6 7 8 1 4 7 mrg32k3a-m1 w-sqr1) + (lc 6 7 8 2 5 8 mrg32k3a-m1 w-sqr1) + (lc 9 10 11 9 12 15 mrg32k3a-m2 w-sqr2) ; (A*B)_00 mod m2 + (lc 9 10 11 10 13 16 mrg32k3a-m2 w-sqr2) + (lc 9 10 11 11 14 17 mrg32k3a-m2 w-sqr2) + (lc 12 13 14 9 12 15 mrg32k3a-m2 w-sqr2) + (lc 12 13 14 10 13 16 mrg32k3a-m2 w-sqr2) + (lc 12 13 14 11 14 17 mrg32k3a-m2 w-sqr2) + (lc 15 16 17 9 12 15 mrg32k3a-m2 w-sqr2) + (lc 15 16 17 10 13 16 mrg32k3a-m2 w-sqr2) + (lc 15 16 17 11 14 17 mrg32k3a-m2 w-sqr2))) + + (define: (power [A : State ] [e : Nb]) : State ; A^e + (cond + ((zero? e) + '#(1 0 0 0 1 0 0 0 1 1 0 0 0 1 0 0 0 1)) + ((= e 1) + A) + ((even? e) + (power (product A A) (quotient e 2))) + (else + (product (power A (- e 1)) A)))) + + (define: (power-power [A : State] [b : Nb]) : State ; A^(2^b) + (if (zero? b) + A + (power-power (product A A) (- b 1)))) + + (define: A : State ; the MRG32k3a recursion + '#( 0 1403580 4294156359 + 1 0 0 + 0 1 0 + 527612 0 4293573854 + 1 0 0 + 0 1 0)) + + ; check arguments + (when (not (and (integer? i) + (exact? i) + (integer? j) + (exact? j))) + (error "i j must be exact integer" i j)) + + ; precompute A^(2^127) and A^(2^76) only once + + (when #t #;(not mrg32k3a-generators) + (set! mrg32k3a-generators + (list (power-power A 127) + (power-power A 76) + (power A 16)))) + + ; compute M = A^(16 + i*2^127 + j*2^76) + (let ((M (product + (list-ref mrg32k3a-generators 2) + (product + (power (list-ref mrg32k3a-generators 0) + (modulo i (expt 2 28))) + (power (list-ref mrg32k3a-generators 1) + (modulo j (expt 2 28))))))) + (mrg32k3a-pack-state + (vector + (vector-ref M 0) + (vector-ref M 3) + (vector-ref M 6) + (vector-ref M 9) + (vector-ref M 12) + (vector-ref M 15))))) + +; True Randomization +; ================== +; +; The value obtained from the system time is feed into a very +; simple pseudo random number generator. This in turn is used +; to obtain numbers to randomize the state of the MRG32k3a +; generator, avoiding period degeneration. + +(define: (mrg32k3a-randomize-state [state : State]) : State + + ; G. Marsaglia's simple 16-bit generator with carry + (define: m : Nb 65536) + (define: x : Nb (modulo (:random-source-current-time) m)) + (define: (random-m) : Nb + (let ((y (modulo x m))) + (set! x (+ (* 30903 y) (quotient x m))) + y)) + (define: (random [n : Nb]) : Nb ; m < n < m^2 + (modulo (+ (* (random-m) m) (random-m)) n)) + + ; modify the state + (let ((m1 mrg32k3a-m1) + (m2 mrg32k3a-m2) + (s (mrg32k3a-unpack-state state))) + (mrg32k3a-pack-state + (vector + (+ 1 (modulo (+ (vector-ref s 0) (random (- m1 1))) (- m1 1))) + (modulo (+ (vector-ref s 1) (random m1)) m1) + (modulo (+ (vector-ref s 2) (random m1)) m1) + (+ 1 (modulo (+ (vector-ref s 3) (random (- m2 1))) (- m2 1))) + (modulo (+ (vector-ref s 4) (random m2)) m2) + (modulo (+ (vector-ref s 5) (random m2)) m2))))) + + +; Large Integers +; ============== +; +; To produce large integer random deviates, for n > m-max, we first +; construct large random numbers in the range {0..m-max^k-1} for some +; k such that m-max^k >= n and then use the rejection method to choose +; uniformly from the range {0..n-1}. + +(define: mrg32k3a-m-max : Integer + (mrg32k3a-random-range)) + +(define: (mrg32k3a-random-power [state : State] [k : Nb]) : Nb ; n = m-max^k, k >= 1 + (if (= k 1) + (mrg32k3a-random-integer state mrg32k3a-m-max) + (+ (* (mrg32k3a-random-power state (- k 1)) mrg32k3a-m-max) + (mrg32k3a-random-integer state mrg32k3a-m-max)))) + +(define: (mrg32k3a-random-large [state : State] [n : Nb]) : Nb ; n > m-max + (do: : Integer ((k : Integer 2 (+ k 1)) + (mk : Integer (* mrg32k3a-m-max mrg32k3a-m-max) (* mk mrg32k3a-m-max))) + ((>= mk n) + (let* ((mk-by-n (quotient mk n)) + (a (* mk-by-n n))) + (do: : Integer ((x : Integer (mrg32k3a-random-power state k) + (mrg32k3a-random-power state k))) + ((< x a) (quotient x mk-by-n))))))) + + +; Multiple Precision Reals +; ======================== +; +; To produce multiple precision reals we produce a large integer value +; and convert it into a real value. This value is then normalized. +; The precision goal is unit <= 1/(m^k + 1), or 1/unit - 1 <= m^k. +; If you know more about the floating point number types of the +; Scheme system, this can be improved. + +(define: (mrg32k3a-random-real-mp [state : State] [unit : Number]) : Number + (do: : Number ((k : Integer 1 (+ k 1)) + (u : Number (- (/ 1 unit) 1) (/ u mrg32k3a-m1))) + ((<= u 1) + (/ (exact->inexact (+ (mrg32k3a-random-power state k) 1)) + (exact->inexact (+ (expt mrg32k3a-m-max k) 1)))))) + + +; Provide the Interface as Specified in the SRFI +; ============================================== +; +; An object of type random-source is a record containing the procedures +; as components. The actual state of the generator is stored in the +; binding-time environment of make-random-source. + +(define: (make-random-source) : Random + (let: ((state : State (mrg32k3a-pack-state ; make a new copy + (list->vector (vector->list mrg32k3a-initial-state))))) + (:random-source-make + (lambda: () + (mrg32k3a-state-ref state)) + (lambda: ([new-state : (Listof Integer)]) + (set! state (mrg32k3a-state-set new-state))) + (lambda: () + (set! state (mrg32k3a-randomize-state state))) + (lambda: ([i : Integer] [j : Integer]) + (set! state (mrg32k3a-pseudo-randomize-state i j))) + (lambda: () + (lambda: ([n : Nb]) + (cond + ((not (and (integer? n) (exact? n) (positive? n))) + (error "range must be exact positive integer" n)) + ((<= n mrg32k3a-m-max) + (mrg32k3a-random-integer state n)) + (else + (mrg32k3a-random-large state n))))) + (lambda: [args : Nb] + (cond + ((null? args) + (lambda () + (mrg32k3a-random-real state))) + ((null? (cdr args)) + (let: ((unit : Flt (car args))) + (cond + ((not (and (real? unit) (< 0 unit 1))) + (error "unit must be real in (0,1)" unit)) + ((<= (- (/ 1 unit) 1) mrg32k3a-m1) + (lambda: () + (mrg32k3a-random-real state))) + (else + (lambda: () + (mrg32k3a-random-real-mp state unit)))))) + (else + (error "illegal arguments" args))))))) + +(define: random-source? : (Any -> Boolean : Random) + :random-source?) + +(define: (random-source-state-ref [s : Random]) : SpList + ((:random-source-state-ref s))) + +(define: (random-source-state-set! [s : Random] [state : Nbs]) : Void + ((:random-source-state-set! s) state)) + +(define: (random-source-randomize! [s : Random]) : Void + ((:random-source-randomize! s))) + +(define: (random-source-pseudo-randomize! [s : Random] [i : Nb] [j : Nb]): Void + ((:random-source-pseudo-randomize! s) i j)) + +; --- + +(define: (random-source-make-integers [s : Random]): (Nb -> Nb) + ((:random-source-make-integers s))) + +(define: (random-source-make-reals [s : Random] . [unit : Nb]) : ( -> Flt) + (apply (:random-source-make-reals s) unit)) + +; --- + +(define: default-random-source : Random + (make-random-source)) + +(define: random-integer : (Nb -> Nb) + (random-source-make-integers default-random-source)) + +(define: random-real : ( -> Flt ) + (random-source-make-reals default-random-source)) + + +) ; module ends