From 1710709b2fdb7eb12a8f07df3294497906322091 Mon Sep 17 00:00:00 2001 From: Milo Turner Date: Wed, 18 Oct 2017 00:04:44 -0400 Subject: [PATCH 1/2] initial hackett/data/random implementation --- hackett-lib/hackett/data/random.rkt | 113 ++++++++++++++++++++++++++++ 1 file changed, 113 insertions(+) create mode 100644 hackett-lib/hackett/data/random.rkt diff --git a/hackett-lib/hackett/data/random.rkt b/hackett-lib/hackett/data/random.rkt new file mode 100644 index 0000000..4d92f28 --- /dev/null +++ b/hackett-lib/hackett/data/random.rkt @@ -0,0 +1,113 @@ +#lang hackett +(require (only-in racket/base module quote)) + +;; declares an internal PRNG type, with no data constructors. +;; actual instances are to be created by the prng-unsafe submodule. +(module prng-type hackett + (require (only-in hackett/private/base + define-base-type)) + (provide PRNG) + (define-base-type PRNG)) + +;; unsafe functions that create / operate on PRNG values +;; using the racket libraries +(module prng-unsafe racket/base + (require racket/promise + (submod ".." prng-type) + (only-in hackett ∀ : -> Integer Double Unit Tuple tuple) + hackett/private/prim/type-provide) + + (provide (typed-out + [unsafe-make-prng : {Unit -> PRNG}] + [unsafe-make-prng/seed : {Integer -> PRNG}] + [unsafe-prng-next-integer : {Integer -> PRNG -> (Tuple Integer PRNG)}] + [unsafe-prng-next-double : {PRNG -> (Tuple Double PRNG)}])) + + (define (unsafe-make-prng _) + (let* ([rng (make-pseudo-random-generator)] + [rng/v (pseudo-random-generator->vector rng)]) + rng/v)) + + (define (unsafe-make-prng/seed k) + (let ([rng (make-pseudo-random-generator)]) + (parameterize ([current-pseudo-random-generator rng]) + (random-seed (force k))) + (pseudo-random-generator->vector rng))) + + (define ((unsafe-prng-next-integer k) rng/v) + (let* ([rng (vector->pseudo-random-generator (force rng/v))] + [x (random (force k) rng)]) + ((tuple x) (pseudo-random-generator->vector rng)))) + + (define (unsafe-prng-next-double rng/v) + (let* ([rng (vector->pseudo-random-generator (force rng/v))] + [x (random rng)]) + ((tuple x) (pseudo-random-generator->vector rng)))) + ) + + +(require 'prng-type 'prng-unsafe + hackett/private/prim/type + hackett/private/prim/base + hackett/data/identity + hackett/monad/trans) + +(provide PRNG + (class RandomGen) + (class RandomValue) + io-prng prng/seed + random/below random/double random/range random random-io) + + +(def io-prng : (IO PRNG) + (io (λ [w] + (let ([prng (unsafe-make-prng unit)]) + (seq prng + (tuple w prng)))))) + +(defn prng/seed : {Integer -> PRNG} + [[k] (let ([prng (unsafe-make-prng/seed k)]) + (seq prng prng))]) + + +(class (RandomGen g) + [random/below : {Integer -> g -> (Tuple Integer g)}] + [random/double : {g -> (Tuple Double g)}] + [random/range : {Integer -> Integer -> g -> (Tuple Integer g)} + (λ [lo hi g] + (case (random/below (- hi lo) g) + [(tuple x g-) (tuple (+ lo x) g)]))]) + +(instance (RandomGen PRNG) + [random/below unsafe-prng-next-integer] + [random/double unsafe-prng-next-double]) + + +(class (RandomValue a) + [random : (∀ [g] (RandomGen g) => {g -> (Tuple a g)})]) + +(instance (RandomValue Integer) + [random (random/below #x80000000)]) + +(instance (RandomValue Double) + [random random/double]) + +(instance (RandomValue Bool) + [random (λ [g] (case (random/below 2 g) + [(tuple x g-) (tuple {x == 0} g-)]))]) + +(def random-io : (∀ [a] (RandomValue a) => (IO a)) + {{fst . random} <$> io-prng}) + + +#| +(data (RandomT m a) + (random-t (∀ [g] (RandomGen g) => {g -> (m (Tuple a g))}))) + +(defn run-random-t : (∀ [g m a] (RandomGen g) => {(RandomT m a) -> g -> (m (Tuple g a))}) + [[(random-t f) g] (f g)]) + +(defn run-random : (∀ [g m a] (RandomGen g) => + {(RandomT Identity a) -> g -> (Tuple g a)}) + [[m g] (run-identity (run-random-t m g))]) +|# From 447a1bd50cdd798a5ff6a73978292bd75de5917f Mon Sep 17 00:00:00 2001 From: Milo Turner Date: Wed, 18 Oct 2017 00:09:52 -0400 Subject: [PATCH 2/2] fixed whitespace & naming for data/random --- hackett-lib/hackett/data/random.rkt | 36 ++++++++++++++--------------- 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/hackett-lib/hackett/data/random.rkt b/hackett-lib/hackett/data/random.rkt index 4d92f28..3d53531 100644 --- a/hackett-lib/hackett/data/random.rkt +++ b/hackett-lib/hackett/data/random.rkt @@ -55,49 +55,49 @@ (provide PRNG (class RandomGen) (class RandomValue) - io-prng prng/seed - random/below random/double random/range random random-io) + make-io-prng prng/seeded + random-below random-double random-range random random/io) -(def io-prng : (IO PRNG) +(def make-io-prng : (IO PRNG) (io (λ [w] (let ([prng (unsafe-make-prng unit)]) (seq prng (tuple w prng)))))) -(defn prng/seed : {Integer -> PRNG} +(defn prng/seeded : {Integer -> PRNG} [[k] (let ([prng (unsafe-make-prng/seed k)]) (seq prng prng))]) (class (RandomGen g) - [random/below : {Integer -> g -> (Tuple Integer g)}] - [random/double : {g -> (Tuple Double g)}] - [random/range : {Integer -> Integer -> g -> (Tuple Integer g)} - (λ [lo hi g] - (case (random/below (- hi lo) g) - [(tuple x g-) (tuple (+ lo x) g)]))]) + [random-below : {Integer -> g -> (Tuple Integer g)}] + [random-double : {g -> (Tuple Double g)}] + [random-range : {Integer -> Integer -> g -> (Tuple Integer g)} + (λ [lo hi g] + (case (random-below (- hi lo) g) + [(tuple x g-) (tuple (+ lo x) g)]))]) (instance (RandomGen PRNG) - [random/below unsafe-prng-next-integer] - [random/double unsafe-prng-next-double]) + [random-below unsafe-prng-next-integer] + [random-double unsafe-prng-next-double]) (class (RandomValue a) [random : (∀ [g] (RandomGen g) => {g -> (Tuple a g)})]) (instance (RandomValue Integer) - [random (random/below #x80000000)]) + [random (random-below #x80000000)]) (instance (RandomValue Double) - [random random/double]) + [random random-double]) (instance (RandomValue Bool) - [random (λ [g] (case (random/below 2 g) - [(tuple x g-) (tuple {x == 0} g-)]))]) + [random (λ [g] (case (random-below 2 g) + [(tuple x g-) (tuple {x == 0} g-)]))]) -(def random-io : (∀ [a] (RandomValue a) => (IO a)) - {{fst . random} <$> io-prng}) +(def random/io : (∀ [a] (RandomValue a) => (IO a)) + {{fst . random} <$> make-io-prng}) #|