diff --git a/hackett-lib/hackett/data/random.rkt b/hackett-lib/hackett/data/random.rkt new file mode 100644 index 0000000..95b903b --- /dev/null +++ b/hackett-lib/hackett/data/random.rkt @@ -0,0 +1,161 @@ +#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) + make-io-prng prng/seeded + random-below random-double random-range random random/io) + + +(def make-io-prng : (IO PRNG) + (io (λ [w] + (let ([prng (unsafe-make-prng unit)]) + (seq prng + (tuple w prng)))))) + +(defn prng/seeded : {Integer -> PRNG} + [[k] (let ([prng (unsafe-make-prng/seed k)]) + (seq prng prng))]) + +(require "state.rkt") + +; With the State Monad, we can define the following three functions to extract +; random numbers with a (State PRNG) as the backend: + +(def draw-double : (State PRNG Double) + (state (λ [prng] + (case (random-double prng) [{d tuple prng*} { prng* tuple d }])))) + +(defn draw-range : {Integer -> Integer -> (State PRNG Integer)} + [[lo hi] (state (λ [prng] + (case (random-range lo hi prng) [{d tuple prng*} { prng* tuple d }])))]) + +(defn draw-below : {Integer -> (State PRNG Integer)} + [[hi] (state (λ [prng] + (case (random-below hi prng) [{d tuple prng*} { prng* tuple d }])))]) + + +#| +; (provide example-of-the-draw-functions) +(def example-of-the-draw-functions : (State PRNG (List Double)) + (do + [d0 <- draw-double] + [d1 <- draw-double] + (put (prng/seeded 1337)) + [d2 <- draw-double] + [d3 <- draw-double] + (put (prng/seeded 1337)) + [d4 <- draw-double] + [d5 <- draw-double] + (pure {d0 :: d1 :: d2 :: d3 :: d4 :: d5 :: nil }) + )) +And here is an example of the above three being used: +(main (do + + ; In IO, get a PRNG seeded by the current time: + [prng <- make-io-prng] + + (println " First two numbers in the following are different, and different on each run of this program, confirming the IO-seed PRNG is \"proceeding\",") + (println " and the third and fifth are the same, as as the fourth and sixth, to show the 'put' has reseeded deterministically") + + ; run an example State computation with the prng we just got from IO + {(runState example-of-the-draw-functions prng) & fst & show & println} + + ; And finally, with a deterministally-seeded PRNG (i.e. not created in IO) + {(runState example-of-the-draw-functions (prng/seeded 1337)) & fst & show & println} + )) +|# + +(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} <$> make-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))]) +|# diff --git a/hackett-lib/hackett/data/state.rkt b/hackett-lib/hackett/data/state.rkt new file mode 100644 index 0000000..22235a4 --- /dev/null +++ b/hackett-lib/hackett/data/state.rkt @@ -0,0 +1,53 @@ +#lang hackett + +; a simple State, with Monad/Applicative/Functor instances +; with operations 'put', 'get' and 'modify' to run in the Monad. +; See also 'runState' and 'runUndefinedState' + +#| Example + +; define a State with Integer as the internal state. + +(def stateInteger : (State Integer (List Integer)) + (do + (put 42) ; set the internal state + [i1 <- get] ; query the internal state + (modify (+ 10)) ; modify the internal state, adding 10 to it + [i2 <- get] ; query again + (modify (+ 10)) ; modify again + (pure {i1 :: i2 :: nil}))) ; return the two intermediate internal states + )) + +(main {(runUndefinedState stateInteger ) & show & println}) + |# + + +(provide (data State) put get modify runState runUndefinedState) + +(data (State s a) (state {s -> { s Tuple a }})) + +(instance (forall [a] (Functor (State a))) + [map (λ [f (state mx)] (state (λ [rw] (case (mx rw) [(tuple rw* a) (tuple rw* (f a))]))))]) + +(instance (forall [a] (Applicative (State a))) + [pure (λ [x] (state (λ [rw] (tuple rw x))))] + [<*> undefined!]) + +(instance (forall [a] (Monad (State a))) + [join (λ [(state outer)] (state (λ [rw] + (case (outer rw) + [(tuple rw* m-inner) (case m-inner [(state inner) (inner rw*)])]))))]) + +(defn put : (forall [a] {a -> (State a Unit)}) + [[s] (state (λ [_] {s tuple unit}))]) +(def get : (forall [a] (State a a)) + (state (λ [s] {s tuple s}))) +(defn modify : (forall [a] {{a -> a} -> (State a Unit)}) + [[modifier] (state (λ [rw] {(modifier rw) tuple unit}))]) + +(defn runState + [[(state mx) initialstate] + (case (mx initialstate) [(tuple a b) (tuple b a)]) + ]) + +(def runUndefinedState ((flip runState) undefined!)) ; if the first step is 'put', then the initial state doesn't matter and we can use undefined! as the initial state