diff options
Diffstat (limited to 'stdlib/source/lux/math/random.lux')
-rw-r--r-- | stdlib/source/lux/math/random.lux | 399 |
1 files changed, 0 insertions, 399 deletions
diff --git a/stdlib/source/lux/math/random.lux b/stdlib/source/lux/math/random.lux deleted file mode 100644 index 8c95c63fa..000000000 --- a/stdlib/source/lux/math/random.lux +++ /dev/null @@ -1,399 +0,0 @@ -(.module: {#.doc "Pseudo-random number generation (PRNG) algorithms."} - [lux (#- or and list i64 nat int rev char) - [abstract - [hash (#+ Hash)] - [functor (#+ Functor)] - [apply (#+ Apply)] - ["." monad (#+ Monad do)]] - [data - ["." text (#+ Char) ("#\." monoid) - ["." unicode #_ - ["#" set]]] - [collection - ["." list ("#\." fold)] - ["." array (#+ Array)] - ["." dictionary (#+ Dictionary)] - ["." queue (#+ Queue)] - ["." set (#+ Set)] - ["." stack (#+ Stack)] - ["." row (#+ Row)] - [tree - ["." finger (#+ Tree)]]]] - [math - [number (#+ hex) - ["n" nat] - ["i" int] - ["f" frac] - ["r" ratio] - ["c" complex] - ["." i64]]] - ["." time (#+ Time) - ["." instant (#+ Instant)] - ["." date (#+ Date)] - ["." duration (#+ Duration)] - ["." month (#+ Month)] - ["." day (#+ Day)]] - [type - [refinement (#+ Refiner Refined)]]]) - -(type: #export #rec PRNG - {#.doc "An abstract way to represent any PRNG."} - (-> Any [PRNG I64])) - -(type: #export (Random a) - {#.doc "A producer of random values based on a PRNG."} - (-> PRNG [PRNG a])) - -(implementation: #export functor - (Functor Random) - - (def: (map f fa) - (function (_ state) - (let [[state' a] (fa state)] - [state' (f a)])))) - -(implementation: #export apply - (Apply Random) - - (def: &functor ..functor) - - (def: (apply ff fa) - (function (_ state) - (let [[state' f] (ff state) - [state'' a] (fa state')] - [state'' (f a)])))) - -(implementation: #export monad - (Monad Random) - - (def: &functor ..functor) - - (def: (wrap a) - (function (_ state) - [state a])) - - (def: (join ffa) - (function (_ state) - (let [[state' fa] (ffa state)] - (fa state'))))) - -(def: #export (filter pred gen) - {#.doc "Retries the generator until the output satisfies a predicate."} - (All [a] (-> (-> a Bit) (Random a) (Random a))) - (do ..monad - [sample gen] - (if (pred sample) - (wrap sample) - (filter pred gen)))) - -(def: #export (one check random) - (All [a b] - (-> (-> a (Maybe b)) (Random a) (Random b))) - (do ..monad - [sample random] - (case (check sample) - (#.Some output) - (wrap output) - - #.None - (one check random)))) - -(def: #export (refine refiner gen) - {#.doc "Retries the generator until the output can be refined."} - (All [t r] (-> (Refiner t r) (Random t) (Random (Refined t r)))) - (do ..monad - [sample gen] - (case (refiner sample) - (#.Some refined) - (wrap refined) - - #.None - (refine refiner gen)))) - -(def: #export bit - (Random Bit) - (function (_ prng) - (let [[prng output] (prng [])] - [prng (|> output (i64.and 1) (n.= 1))]))) - -(def: #export i64 - (Random I64) - (function (_ prng) - (let [[prng left] (prng []) - [prng right] (prng [])] - [prng (|> left - (i64.left_shift 32) - ("lux i64 +" right))]))) - -(template [<name> <type> <cast>] - [(def: #export <name> - (Random <type>) - (\ ..monad map <cast> ..i64))] - - [nat Nat .nat] - [int Int .int] - [rev Rev .rev] - ) - -(def: #export frac - (Random Frac) - (\ ..monad map (|>> .i64 f.from_bits) ..nat)) - -(def: #export safe_frac - (Random Frac) - (let [mantissa_range (.int (i64.left_shift 53 1)) - mantissa_max (i.frac (dec mantissa_range))] - (\ ..monad map - (|>> (i.% mantissa_range) - i.frac - (f./ mantissa_max)) - ..int))) - -(def: #export (char set) - (-> unicode.Set (Random Char)) - (let [[start end] (unicode.range set) - size (n.- start end) - in_range (: (-> Char Char) - (|>> (n.% size) (n.+ start)))] - (|> ..nat - (\ ..monad map in_range) - (..filter (unicode.member? set))))) - -(def: #export (text char_gen size) - (-> (Random Char) Nat (Random Text)) - (if (n.= 0 size) - (\ ..monad wrap "") - (do ..monad - [x char_gen - xs (text char_gen (dec size))] - (wrap (text\compose (text.from_code x) xs))))) - -(template [<name> <set>] - [(def: #export <name> - (-> Nat (Random Text)) - (..text (..char <set>)))] - - [unicode unicode.character] - [ascii unicode.ascii] - [ascii/alpha unicode.ascii/alpha] - [ascii/alpha_num unicode.ascii/alpha_num] - [ascii/numeric unicode.ascii/numeric] - [ascii/upper unicode.ascii/upper] - [ascii/lower unicode.ascii/lower] - ) - -(template [<name> <type> <ctor> <gen>] - [(def: #export <name> - (Random <type>) - (do ..monad - [left <gen> - right <gen>] - (wrap (<ctor> left right))))] - - [ratio r.Ratio r.ratio ..nat] - [complex c.Complex c.complex ..safe_frac] - ) - -(def: #export (and left right) - {#.doc "Sequencing combinator."} - (All [a b] (-> (Random a) (Random b) (Random [a b]))) - (do ..monad - [=left left - =right right] - (wrap [=left =right]))) - -(def: #export (or left right) - {#.doc "Heterogeneous alternative combinator."} - (All [a b] (-> (Random a) (Random b) (Random (| a b)))) - (do {! ..monad} - [? bit] - (if ? - (do ! - [=left left] - (wrap (0 #0 =left))) - (do ! - [=right right] - (wrap (0 #1 =right)))))) - -(def: #export (either left right) - {#.doc "Homogeneous alternative combinator."} - (All [a] (-> (Random a) (Random a) (Random a))) - (do ..monad - [? bit] - (if ? - left - right))) - -(def: #export (rec gen) - {#.doc "A combinator for producing recursive random generators."} - (All [a] (-> (-> (Random a) (Random a)) (Random a))) - (function (_ state) - (let [gen' (gen (rec gen))] - (gen' state)))) - -(def: #export (maybe value_gen) - (All [a] (-> (Random a) (Random (Maybe a)))) - (do {! ..monad} - [some? bit] - (if some? - (do ! - [value value_gen] - (wrap (#.Some value))) - (wrap #.None)))) - -(template [<name> <type> <zero> <plus>] - [(def: #export (<name> size value_gen) - (All [a] (-> Nat (Random a) (Random (<type> a)))) - (if (n.> 0 size) - (do ..monad - [x value_gen - xs (<name> (dec size) value_gen)] - (wrap (<plus> x xs))) - (\ ..monad wrap <zero>)))] - - [list List (.list) #.Cons] - [row Row row.empty row.add] - ) - -(template [<name> <type> <ctor>] - [(def: #export (<name> size value_gen) - (All [a] (-> Nat (Random a) (Random (<type> a)))) - (do ..monad - [values (list size value_gen)] - (wrap (|> values <ctor>))))] - - [array Array array.from_list] - [queue Queue queue.from_list] - [stack Stack (list\fold stack.push stack.empty)] - ) - -(def: #export (set Hash<a> size value_gen) - (All [a] (-> (Hash a) Nat (Random a) (Random (Set a)))) - (if (n.> 0 size) - (do {! ..monad} - [xs (set Hash<a> (dec size) value_gen)] - (loop [_ []] - (do ! - [x value_gen - #let [xs+ (set.add x xs)]] - (if (n.= size (set.size xs+)) - (wrap xs+) - (recur []))))) - (\ ..monad wrap (set.new Hash<a>)))) - -(def: #export (dictionary Hash<a> size key_gen value_gen) - (All [k v] (-> (Hash k) Nat (Random k) (Random v) (Random (Dictionary k v)))) - (if (n.> 0 size) - (do {! ..monad} - [kv (dictionary Hash<a> (dec size) key_gen value_gen)] - (loop [_ []] - (do ! - [k key_gen - v value_gen - #let [kv+ (dictionary.put k v kv)]] - (if (n.= size (dictionary.size kv+)) - (wrap kv+) - (recur []))))) - (\ ..monad wrap (dictionary.new Hash<a>)))) - -(def: #export instant - (Random Instant) - (\ ..monad map instant.from_millis ..int)) - -(def: #export date - (Random Date) - (\ ..monad map instant.date ..instant)) - -(def: #export time - (Random Time) - (\ ..monad map instant.time ..instant)) - -(def: #export duration - (Random Duration) - (\ ..monad map duration.from_millis ..int)) - -(def: #export month - (Random Month) - (let [(^open "\.") ..monad] - (..either (..either (..either (\wrap #month.January) - (..either (\wrap #month.February) - (\wrap #month.March))) - (..either (\wrap #month.April) - (..either (\wrap #month.May) - (\wrap #month.June)))) - (..either (..either (\wrap #month.July) - (..either (\wrap #month.August) - (\wrap #month.September))) - (..either (\wrap #month.October) - (..either (\wrap #month.November) - (\wrap #month.December))))))) - -(def: #export day - (Random Day) - (let [(^open "\.") ..monad] - (..either (..either (\wrap #day.Sunday) - (..either (\wrap #day.Monday) - (\wrap #day.Tuesday))) - (..either (..either (\wrap #day.Wednesday) - (\wrap #day.Thursday)) - (..either (\wrap #day.Friday) - (\wrap #day.Saturday)))))) - -(def: #export (run prng calc) - (All [a] (-> PRNG (Random a) [PRNG a])) - (calc prng)) - -(def: #export (prng update return) - (All [a] (-> (-> a a) (-> a I64) (-> a PRNG))) - (function (recur state) - (function (_ _) - [(recur (update state)) - (return state)]))) - -(def: #export (pcg32 [increase seed]) - {#.doc (doc "An implementation of the PCG32 algorithm." - "For more information, please see: http://www.pcg-random.org/")} - (-> [(I64 Any) (I64 Any)] PRNG) - (let [magic 6364136223846793005] - (function (_ _) - [(|> seed .nat (n.* magic) ("lux i64 +" increase) [increase] pcg32) - (let [rot (|> seed .i64 (i64.right_shift 59))] - (|> seed - (i64.right_shift 18) - (i64.xor seed) - (i64.right_shift 27) - (i64.rotate_right rot) - .i64))]))) - -(def: #export (xoroshiro_128+ [s0 s1]) - {#.doc (doc "An implementation of the Xoroshiro128+ algorithm." - "For more information, please see: http://xoroshiro.di.unimi.it/")} - (-> [(I64 Any) (I64 Any)] PRNG) - (function (_ _) - [(let [s01 (i64.xor s0 s1)] - (xoroshiro_128+ [(|> s0 - (i64.rotate_left 55) - (i64.xor s01) - (i64.xor (i64.left_shift 14 s01))) - (i64.rotate_left 36 s01)])) - ("lux i64 +" s0 s1)])) - -## https://en.wikipedia.org/wiki/Xorshift#Initialization -## http://xorshift.di.unimi.it/splitmix64.c -(def: #export split_mix_64 - {#.doc (doc "An implementation of the SplitMix64 algorithm.")} - (-> Nat PRNG) - (let [twist (: (-> Nat Nat Nat) - (function (_ shift value) - (i64.xor (i64.right_shift shift value) - value))) - mix n.*] - (..prng (n.+ (hex "9E,37,79,B9,7F,4A,7C,15")) - (|>> (twist 30) - (mix (hex "BF,58,47,6D,1C,E4,E5,B9")) - - (twist 27) - (mix (hex "94,D0,49,BB,13,31,11,EB")) - - (twist 31) - .i64)))) |