[MLton-commit] r5585
Vesa Karvonen
vesak at mlton.org
Mon Jun 4 11:24:23 PDT 2007
Turning random into a separate library.
----------------------------------------------------------------------
A mltonlib/trunk/com/ssh/random/
A mltonlib/trunk/com/ssh/random/unstable/
A mltonlib/trunk/com/ssh/random/unstable/LICENSE
A mltonlib/trunk/com/ssh/random/unstable/detail/
A mltonlib/trunk/com/ssh/random/unstable/detail/mk-random-gen.fun
A mltonlib/trunk/com/ssh/random/unstable/detail/numerical-recipes.sml
A mltonlib/trunk/com/ssh/random/unstable/detail/random-dev-mlton.sml
A mltonlib/trunk/com/ssh/random/unstable/detail/ranqd1-gen.sml
A mltonlib/trunk/com/ssh/random/unstable/lib.mlb
A mltonlib/trunk/com/ssh/random/unstable/public/
A mltonlib/trunk/com/ssh/random/unstable/public/export.sml
A mltonlib/trunk/com/ssh/random/unstable/public/random-dev.sig
A mltonlib/trunk/com/ssh/random/unstable/public/random-gen.sig
A mltonlib/trunk/com/ssh/random/unstable/public/rng.sig
----------------------------------------------------------------------
Copied: mltonlib/trunk/com/ssh/random/unstable/LICENSE (from rev 5583, mltonlib/trunk/com/ssh/misc-util/unstable/LICENSE)
Copied: mltonlib/trunk/com/ssh/random/unstable/detail/mk-random-gen.fun (from rev 5583, mltonlib/trunk/com/ssh/misc-util/unstable/mk-random-gen.fun)
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/mk-random-gen.fun 2007-06-04 16:57:26 UTC (rev 5583)
+++ mltonlib/trunk/com/ssh/random/unstable/detail/mk-random-gen.fun 2007-06-04 18:24:21 UTC (rev 5585)
@@ -0,0 +1,121 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+functor MkRandomGen (RNG : RNG) :>
+ RANDOM_GEN where type RNG.t = RNG.t
+ where type RNG.Seed.t = RNG.Seed.t =
+struct
+ structure A = Array and R = Real and V = Vector and W = Word
+
+ fun assert th = if th () then () else fail "assertion failed"
+
+ structure RNG = RNG
+
+ type 'a dom = Int.t * RNG.t and 'a cod = 'a
+ type 'a t = 'a dom -> 'a cod
+
+ fun generate n t =
+ pass (W.toInt (RNG.value t mod (W.fromInt n)), RNG.next t)
+
+ fun lift r2a = r2a o Pair.snd
+
+ structure Monad =
+ MkMonad (type 'a monad = 'a t
+ val return = const
+ fun (m >>= k) (n, r) =
+ k (m (n, RNG.split 0w314 r)) (n, RNG.split 0w159 r))
+
+ open Monad
+
+ fun map a2b ga = a2b o ga
+
+ fun promote a2b (n, r) a = a2b a (n, r)
+
+ fun variant v m = m o Pair.map (id, RNG.split (W.fromInt v + 0w1))
+
+ fun mapUnOp (to, from) eG2eG = let
+ fun map f g = f o g
+ in
+ Fn.map (map to, map from) eG2eG
+ end
+
+ fun sized i2g (n, r) = i2g n (n, r)
+ fun resize f g = g o Pair.map (f, id)
+ fun bool (_, r) = RNG.maxValue div 0w2 < RNG.value r
+
+ fun Y ? = Tie.pure (fn () => let
+ val r = ref (raising Fix.Fix)
+ fun f x = !r x
+ in
+ (resize (op div /> 2) f,
+ fn f' => (r := f' ; f'))
+ end) ?
+
+ fun inRange bInRange (a2b, b2a) =
+ map b2a o bInRange o Pair.map (Sq.mk a2b)
+
+ fun wordInRange (l, h) =
+ (assert (fn () => l <= h)
+ ; let val n = h - l + 0w1 (* XXX may overflow *)
+ val d = RNG.maxValue div n (* XXX may result in zero *)
+ val m = n * d
+ in lift (fn r => RNG.value r mod m div d + l)
+ end)
+
+ fun intInRange (l, h) =
+ (assert (fn () => l <= h)
+ ; map (op + /> l)
+ (inRange wordInRange (Iso.swap W.isoInt) (0, h - l)))
+
+ local
+ val w2r = R.fromLargeInt o W.toLargeInt
+ in
+ fun realInRange (l, h) =
+ (assert (fn () => l <= h)
+ ; let val m = (h - l) / w2r RNG.maxValue
+ in fn (_, r) => w2r (RNG.value r) * m + l
+ end)
+ end
+
+ fun elements xs =
+ let val xs = V.fromList xs
+ in map (xs <\ V.sub) (intInRange (0, V.length xs))
+ end
+
+ fun oneOf gs = elements gs >>= id
+
+ fun frequency xs = let
+ val xs = A.fromList xs
+ val tot = A.foldli (fn (i, (n, g), tot) =>
+ (A.update (xs, i, (n+tot, g)) ; n+tot))
+ 0 xs
+ fun pick i n = let
+ val (k, x) = A.sub (xs, i)
+ in
+ if n <= k then x else pick (i+1) n
+ end
+ in
+ intInRange (1, tot) >>= pick 0
+ end
+
+ local
+ fun unfold px sx x2y = let
+ fun lp ys x =
+ if px x then
+ rev ys
+ else
+ lp (x2y x::ys) (sx x)
+ in
+ lp []
+ end
+ in
+ fun list ga m (n, r) =
+ unfold (op = /> 0w0)
+ (op - /> 0w1)
+ (fn i => ga (n, RNG.split i r))
+ (W.fromInt m)
+ end
+end
Copied: mltonlib/trunk/com/ssh/random/unstable/detail/numerical-recipes.sml (from rev 5583, mltonlib/trunk/com/ssh/misc-util/unstable/misc.sml)
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/misc.sml 2007-06-04 16:57:26 UTC (rev 5583)
+++ mltonlib/trunk/com/ssh/random/unstable/detail/numerical-recipes.sml 2007-06-04 18:24:21 UTC (rev 5585)
@@ -0,0 +1,40 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+structure NumericalRecipes :> sig
+ val ranqd1 : Word32.t UnOp.t
+ (**
+ * This implements the quick-and-dirty linear congruential pseudo
+ * random number generator described on page 284 of the book Numerical
+ * Recipes in C. Perhaps the most important feature of this generator
+ * is that it cycles through all 32-bit words. This is useful if you
+ * want to generate unique 32-bit identifiers.
+ *
+ * Warning: If you need a high-quality pseudo random number generator
+ * for simulation purposes, then this isn't for you.
+ *)
+
+ val psdes : Word32.t Sq.t UnOp.t
+ (**
+ * This implements the "Pseudo-DES" algorithm described in section 7.5
+ * of the book Numerical Recipes in C.
+ *)
+end = struct
+ fun ranqd1 s : Word32.t = s * 0w1664525 + 0w1013904223
+
+ val psdes =
+ flip (foldl (fn ((c1, c2), (lw, rw)) => let
+ open Word32
+ val a = rw xorb c1
+ val al = a andb 0wxFFFF
+ val ah = a >> 0w16
+ val b = al*al + notb (ah*ah)
+ in (rw,
+ lw xorb (al*ah + (c2 xorb (b >> 0w16 orb b << 0w16))))
+ end))
+ [(0wxBAA96887, 0wx4B0F3B58), (0wx1E17D32C, 0wxE874F0C3),
+ (0wx03BCDC3C, 0wx6955C5A6), (0wx0F33D1B2, 0wx55A7CA46)]
+end
Copied: mltonlib/trunk/com/ssh/random/unstable/detail/random-dev-mlton.sml (from rev 5583, mltonlib/trunk/com/ssh/misc-util/unstable/random-dev-mlton.sml)
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/random-dev-mlton.sml 2007-06-04 16:57:26 UTC (rev 5583)
+++ mltonlib/trunk/com/ssh/random/unstable/detail/random-dev-mlton.sml 2007-06-04 18:24:21 UTC (rev 5585)
@@ -0,0 +1,7 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+structure RandomDev : RANDOM_DEV = MLton.Random
Copied: mltonlib/trunk/com/ssh/random/unstable/detail/ranqd1-gen.sml (from rev 5583, mltonlib/trunk/com/ssh/misc-util/unstable/ranqd1-gen.sml)
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/ranqd1-gen.sml 2007-06-04 16:57:26 UTC (rev 5583)
+++ mltonlib/trunk/com/ssh/random/unstable/detail/ranqd1-gen.sml 2007-06-04 18:24:21 UTC (rev 5585)
@@ -0,0 +1,15 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+structure RanQD1Gen :> RANDOM_GEN where type RNG.Seed.t = Word32.t =
+ MkRandomGen
+ (type t = Word32.t
+ structure Seed = Word32
+ val make = id
+ val (value, seed) = Iso.<--> (Iso.swap Word.isoLarge, Word32.isoLarge)
+ val next = NumericalRecipes.ranqd1
+ fun split w = #2 o NumericalRecipes.psdes /> seed w
+ val maxValue = value Word32.maxValue)
Added: mltonlib/trunk/com/ssh/random/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/random/unstable/lib.mlb 2007-06-04 17:46:37 UTC (rev 5584)
+++ mltonlib/trunk/com/ssh/random/unstable/lib.mlb 2007-06-04 18:24:21 UTC (rev 5585)
@@ -0,0 +1,34 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+local
+ $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+in
+ ann
+ "forceUsed"
+ "sequenceNonUnit warn"
+ "warnUnused true"
+ in
+ local
+ public/rng.sig
+ public/random-gen.sig
+
+ detail/mk-random-gen.fun
+
+ detail/numerical-recipes.sml
+ detail/ranqd1-gen.sml
+
+ public/random-dev.sig
+ local
+ $(MLTON_ROOT)/basis/mlton.mlb
+ in
+ detail/random-dev-mlton.sml
+ end
+ in
+ public/export.sml
+ end
+ end
+end
Property changes on: mltonlib/trunk/com/ssh/random/unstable/lib.mlb
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/random/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/random/unstable/public/export.sml 2007-06-04 17:46:37 UTC (rev 5584)
+++ mltonlib/trunk/com/ssh/random/unstable/public/export.sml 2007-06-04 18:24:21 UTC (rev 5585)
@@ -0,0 +1,26 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(** == Exported Signatures == *)
+
+signature RNG = RNG
+signature RANDOM_GEN = RANDOM_GEN
+signature RANDOM_DEV = RANDOM_DEV
+
+
+(** == Exported Structures == *)
+
+structure RandomDev : RANDOM_DEV = RandomDev
+(** The default/system random device. *)
+
+structure RanQD1Gen : RANDOM_GEN where type RNG.Seed.t = Word32.t = RanQD1Gen
+(** A quick-and-dirty random value generator. *)
+
+
+(** == Exported Functors == *)
+
+functor MkRandomGen (RNG : RNG) : RANDOM_GEN = MkRandomGen (RNG)
+(** Makes a random value generator combinators from a RNG. *)
Property changes on: mltonlib/trunk/com/ssh/random/unstable/public/export.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Copied: mltonlib/trunk/com/ssh/random/unstable/public/random-dev.sig (from rev 5583, mltonlib/trunk/com/ssh/misc-util/unstable/random-dev.sig)
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/random-dev.sig 2007-06-04 16:57:26 UTC (rev 5583)
+++ mltonlib/trunk/com/ssh/random/unstable/public/random-dev.sig 2007-06-04 18:24:21 UTC (rev 5585)
@@ -0,0 +1,26 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(**
+ * A signature for accessing some (unspecified) source of randomness
+ * (e.g. /dev/random and /dev/urandom). Modules implementing this
+ * signature should not be used as general purpose random number
+ * generators, but should rather be used to seed other pseudo random
+ * number generators.
+ *)
+signature RANDOM_DEV = sig
+ val seed : Word.t Option.t Thunk.t
+ (**
+ * Returns a high-quality random word. A call to seed may block until
+ * enough random bits are available.
+ *)
+
+ val useed : Word.t Option.t Thunk.t
+ (**
+ * Returns a random word. If there aren't enough high-quality random
+ * bits available, a lower quality random word will be returned.
+ *)
+end
Copied: mltonlib/trunk/com/ssh/random/unstable/public/random-gen.sig (from rev 5583, mltonlib/trunk/com/ssh/misc-util/unstable/random-gen.sig)
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/random-gen.sig 2007-06-04 16:57:26 UTC (rev 5583)
+++ mltonlib/trunk/com/ssh/random/unstable/public/random-gen.sig 2007-06-04 18:24:21 UTC (rev 5585)
@@ -0,0 +1,49 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(**
+ * A signature for functional random value generators. The design is
+ * based on the [http://www.cs.chalmers.se/~rjmh/QuickCheck/ QuickCheck]
+ * library by Koen Claessen and John Hughes.
+ *)
+signature RANDOM_GEN = sig
+ structure RNG : RNG
+
+ type 'a dom and 'a cod
+ type 'a t = 'a dom -> 'a cod
+
+ val generate : Int.t -> RNG.t -> 'a t -> 'a
+
+ val lift : (RNG.t -> 'a) -> 'a t
+
+ include MONAD_CORE where type 'a monad = 'a t
+
+ structure Monad : MONAD where type 'a monad = 'a t
+
+ val promote : ('a -> 'b t) -> ('a -> 'b) t
+
+ val Y : 'a t Tie.t
+
+ val variant : Int.t -> 'a t UnOp.t
+ val mapUnOp : ('a, 'b) Iso.t -> 'b t UnOp.t -> 'a t UnOp.t
+
+ val sized : (Int.t -> 'a t) -> 'a t
+ val resize : Int.t UnOp.t -> 'a t UnOp.t
+
+ val elements : 'a List.t -> 'a t
+ val oneOf : 'a t List.t -> 'a t
+ val frequency : (Int.t * 'a t) List.t -> 'a t
+
+ val inRange : ('b Sq.t -> 'b t) -> ('a, 'b) Iso.t -> 'a Sq.t -> 'a t
+
+ val intInRange : Int.t Sq.t -> Int.t t
+ val realInRange : Real.t Sq.t -> Real.t t
+ val wordInRange : Word.t Sq.t -> Word.t t
+
+ val bool : Bool.t t
+
+ val list : 'a t -> Int.t -> 'a List.t t
+end
Copied: mltonlib/trunk/com/ssh/random/unstable/public/rng.sig (from rev 5583, mltonlib/trunk/com/ssh/misc-util/unstable/rng.sig)
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/rng.sig 2007-06-04 16:57:26 UTC (rev 5583)
+++ mltonlib/trunk/com/ssh/random/unstable/public/rng.sig 2007-06-04 18:24:21 UTC (rev 5585)
@@ -0,0 +1,33 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(**
+ * Signature for functional random number generators (RNG).
+ *)
+signature RNG = sig
+ type t
+ (** The type of RNG state. *)
+
+ structure Seed : sig
+ type t
+ (** The type of RNG seed. *)
+ end
+
+ val make : Seed.t -> t
+ (** Makes a RNG state given an initial seed. *)
+
+ val value : t -> Word.t
+ (** Extracts the current random word from the state. *)
+
+ val next : t UnOp.t
+ (** Computes the next state. *)
+
+ val split : Word.t -> t UnOp.t
+ (** Computes a new RNG state based on the given state and word index. *)
+
+ val maxValue : Word.t
+ (** The range of generated random words is {{0w0, ..., maxValue}}. *)
+end
More information about the MLton-commit
mailing list