Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Implemented Mersenne-Twister RNG.

  • Loading branch information...
commit d592c1b7743f9bc7fc464a683b2e2652a146e701 1 parent 1fd1b05
@nineties authored
View
10 rowl1/Makefile
@@ -3,7 +3,7 @@
# Copyright (C) 2010 nineties
#
-# $Id: Makefile 2013-02-14 17:53:11 nineties $
+# $Id: Makefile 2013-03-16 13:09:52 nineties $
TOPDIR = ..
ROWL0DIR = $(TOPDIR)/rowl0
@@ -64,7 +64,8 @@ VMOBJECTS = vm-main.o\
vm-prim-vector.o\
vm-prim-tuple.o\
vm-prim-idtable.o\
- vm-prim-wrtable.o
+ vm-prim-wrtable.o\
+ vm-prim-random.o
vm-compile.o : rlci stdlib.rlc config.rlc
vm-main.o : rlci stdlib.rlc vm-compile.rlc
@@ -78,7 +79,8 @@ vm-prim-string.o : rlci stdlib.rlc vm-compile.rlc
vm-prim-vector.o : rlci stdlib.rlc vm-compile.rlc
vm-prim-tuple.o : rlci stdlib.rlc vm-compile.rlc
vm-prim-idtable.o : rlci stdlib.rlc vm-compile.rlc
-vm-prim-idtable.o : rlci stdlib.rlc vm-compile.rlc
+vm-prim-wrtable.o : rlci stdlib.rlc vm-compile.rlc
+vm-prim-random.o : rlci stdlib.rlc vm-compile.rlc
RLC1OBJECTS = rowl1-main.rlo\
rowl1-util.rlo\
@@ -96,6 +98,7 @@ RLC1OBJECTS = rowl1-main.rlo\
rowl1-numeric.rlo\
rowl1-bigint.rlo\
rowl1-float.rlo\
+ rowl1-random.rlo\
rowl1-math.rlo\
rowl1-string.rlo\
rowl1-list.rlo\
@@ -133,6 +136,7 @@ rowl1-symbol.rlo: $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo
rowl1-numeric.rlo : $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo rowl1-compile.rlo rowl1-error.rlo rowl1-module.rlo
rowl1-bigint.rlo : $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo rowl1-compile.rlo
rowl1-float.rlo : $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo rowl1-module.rlo rowl1-compile.rlo rowl1-assemble.rlo rowl1-error.rlo
+rowl1-random.rlo : $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo rowl1-module.rlo rowl1-compile.rlo rowl1-assemble.rlo rowl1-error.rlo rowl1-bigint.rlo rowl1-float.rlo
rowl1-math.rlo : $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo rowl1-float.rlo rowl1-numeric.rlo rowl1-module.rlo rowl1-compile.rlo rowl1-assemble.rlo rowl1-error.rlo
rowl1-string.rlo : $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo rowl1-module.rlo rowl1-compile.rlo rowl1-error.rlo
rowl1-list.rlo : $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo rowl1-module.rlo rowl1-compile.rlo rowl1-assemble.rlo rowl1-error.rlo
View
13 rowl1/rowl1-bigint.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2012 nineties
;
-; $Id: rowl1-bigint.rlc 2013-03-05 01:12:44 nineties $
+; $Id: rowl1-bigint.rlc 2013-03-16 13:04:16 nineties $
;
(import "rlvm-compile")
@@ -26,11 +26,18 @@
(export fun bint_digit (u i) (
(return (array_get int (field_get u 0) i))
))
+(export fun bint_digits (u) (
+ (return (field_get u 0))
+ ))
(export fun bint_set_digit (u i d) (
(array_set int (field_get u 0) i d)
))
+(export fun bint_ndigit (u) (
+ (return (field_get u 1))
+ ))
+
(export fun bint_set_ndigit (u len) (
(field_set u 1 len)
))
@@ -39,6 +46,10 @@
(if (& v 1) (return (== v 1)))
(return (&& (== (field_get v 1) 1) (== (array_get int (field_get v 0) 0) 0)))
))
+(export fun bint_is_negative (v) (
+ (if (& v 1) (return (< v 0)))
+ (return (field_get v 3))
+ ))
(export fun int_to_bint (v) (
(var b (allocate_bint 1))
View
14 rowl1/rowl1-float.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2012 nineties
;
-; $Id: rowl1-float.rlc 2013-02-14 05:59:07 nineties $
+; $Id: rowl1-float.rlc 2013-03-16 15:29:13 nineties $
;
(import "rlvm-compile")
@@ -362,7 +362,7 @@
(= k (- k))))
(var d 1000)
(while (== (/ k d) 0) (/= d 10))
- (while (> k 0) (do
+ (while (> d 0) (do
(array_set char s i (+ (/ k d) '0'))
(%= k d)
(/= d 10)
@@ -461,6 +461,16 @@
(return (bint_shiftR b (box shift)))
))
+(export fun uitof (n) (
+ (if (>= n 0) (return (itof n)))
+ (var f (allocate_float))
+ (&= n 0x7fffffff)
+ ; exp = 31 because n >= 2^31
+ (field_set f 1 (| @(<< (+ 31 1023) 20) (>> n 11)))
+ (field_set f 0 (<< n 21))
+ (return f)
+ ))
+
(fun int_to_f (n) (
(return (itof (unbox n)))
))
View
4 rowl1/rowl1-interp.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2010 nineties
;
-; $Id: rowl1-interp.rlc 2013-03-14 20:33:34 nineties $
+; $Id: rowl1-interp.rlc 2013-03-16 13:09:26 nineties $
;
(import "rlvm-compile")
@@ -577,6 +577,7 @@
(extern fun setup_numeric)
(extern fun setup_bigint)
(extern fun setup_float)
+(extern fun setup_random)
(extern fun setup_math)
(extern fun setup_string)
(extern fun setup_io)
@@ -599,6 +600,7 @@
(setup_string std)
(setup_bigint std)
(setup_float std)
+ (setup_random std)
(setup_io std)
(setup_list std)
View
96 rowl1/rowl1-random.rlc
@@ -0,0 +1,96 @@
+;
+; rowl - 1st generation
+; Copyright (C) 2010 nineties
+;
+; $Id: rowl1-random.rlc 2013-03-16 16:08:21 nineties $
+;
+
+(import "rlvm-compile")
+(import "rowl1-types")
+
+(compile `object `(
+
+(import "rowl1-node")
+(import "rowl1-compile")
+(import "rowl1-util")
+(import "rowl1-error")
+(import "rowl1-module")
+(import "rowl1-bigint")
+(import "rowl1-float")
+
+(extern object current_loc)
+
+(fun srand0 () (
+ (srand (field_get (gettimeofday) 0)) ; get second
+ (return @C_TRUE)
+ ))
+
+(fun srandi (seed) (
+ (if (& seed 1) (do
+ (if (< seed 0) (goto seed_error))
+ (srand (unbox seed))
+ (return @C_TRUE)
+ ))
+ (if (!= (node_type seed) @BigIntE) (goto seed_error))
+ (if (bint_is_negative seed) (goto seed_error))
+
+ (srand_array (bint_digits seed) (bint_ndigit seed))
+ (return @C_TRUE)
+
+ (label seed_error)
+ (throw (invalid_argument current_loc
+ (string "Seed must be a non-negative integer")
+ seed))
+ ))
+
+(var inv4294967296
+ (float_from_s "2.32830643653869629e-10")) ; 1.0/4294967296.0
+
+(fun randf () (
+ (return (fmul (uitof (randui)) inv4294967296))
+ ))
+
+(fun randi (n) (
+ (= n (unbox n))
+ (if (<= n 0) (throw (invalid_argument current_loc
+ (string "Upper limit must be positive")
+ n
+ )))
+ (var mask (- (<< 1 (+ (bsr n) 1)) 1))
+ (var x (& (randui) mask))
+ (while (>= x n) (= x (& (randui) mask)))
+ (return (box x))
+ ))
+
+(fun randbi (n) (
+ (if (bint_is_negative n) (throw (invalid_argument current_loc
+ (string "Upper limit must be positive")
+ n
+ )))
+ (var m (- (bint_ndigit n) 1))
+
+ (var x (allocate_bint (+ m 1)))
+ (bint_set_ndigit x (+ m 1))
+
+ (var mask (- (<< 1 (+ (bsr (bint_digit n m)) 1)) 1))
+
+ (for i 0 m (bint_set_digit x i (randui)))
+ (bint_set_digit x m (& (randui) mask))
+ (while (>= (bigcmp x n) 0) (bint_set_digit x m (& (randui) mask)))
+ ; compute the length
+ (while (&& (>= m 0) (== (bint_digit x m) 0)) (-= m 1))
+ (if (< m 0) (= m 0))
+ (bint_set_ndigit x (+ m 1))
+ (return x)
+ ))
+
+(export fun setup_random (std) (
+ (srand0)
+ (add_function0 std (to_sym "srand") srand0 0)
+ (add_function1 std (to_sym "srand") (domainP Int) srandi 0)
+ (add_function0 std (to_sym "rand") randf 0)
+ (add_function1 std (to_sym "rand") intT randi 0)
+ (add_function1 std (to_sym "rand") bintT randbi 0)
+ ))
+
+ ))
View
4 rowl1/vm-prim-inc.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2010 nineties
;
-; $Id: vm-prim-inc.rlc 2013-02-04 12:57:54 nineties $
+; $Id: vm-prim-inc.rlc 2013-03-16 12:50:56 nineties $
;
; primitive functions
@@ -44,6 +44,8 @@
allocate_bint resize_bint copy_bint clear_bint
; floating point
allocate_float copy_float
+ ; random number
+ srand srand_array randui
; sequences
allocate_array allocate_iarray allocate_carray
allocate_tuple seq_size seq_clear
View
115 rowl1/vm-prim-random.rlc
@@ -0,0 +1,115 @@
+;
+; rowl - 1st generation
+; Copyright (C) 2010 nineties
+;
+; $Id: vm-prim-random.rlc 2013-03-16 13:33:56 nineties $
+;
+
+; Implementation of Mersenne Twister (MT19937).
+; This code is based on
+; http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
+
+
+(import "stdlib")
+(import "vm-compile")
+
+; period parameters
+(var N 624)
+(var M 397)
+(var MATRIX_A 0x9908b0df) ; constant vector ASK
+(var UPPER_MASK 0x80000000) ; most significant w-r bits
+(var LOWER_MASK 0x7fffffff) ; least significant r bits
+
+(var vm-prim-code `(
+
+(int[] @N mt) ; the array for the state vector
+(int mti 0)
+
+(export prim_srand)
+(fun prim_srand (seed) (
+ (set mt 0 seed)
+ (= mti 1)
+ (while (< mti @N) (
+ (set mt mti (+ mti (* 1812433253
+ (^ (get mt (- mti 1))
+ (>> (get mt (- mti 1)) 30)))))
+ (+= mti 1)
+ ))
+ ))
+
+(export prim_srand_array)
+(fun prim_srand_array (key len) (
+ (int i 1)
+ (int j 0)
+ (int k 0)
+ (if (> @N len)
+ ((= k @N))
+ ((= k len))
+ )
+ (prim_srand 19650218)
+ (while k (
+ (set mt i (+ (+ (^ (get mt i) (*
+ (^ (get mt (- i 1)) (>> (get mt (- i 1)) 30))
+ 1664525))
+ (get key j)) j))
+ (+= i 1)
+ (+= j 1)
+ (if (>= i @N) (
+ (set mt 0 (get mt @(- N 1)))
+ (= i 1)
+ ))
+ (if (>= j len) ((= j 0)))
+ (-= k 1)
+ ))
+ (= k @(- N 1))
+ (while k (
+ (set mt i (- (^ (get mt i) (*
+ (^ (get mt (- i 1)) (>> (get mt (- i 1)) 30))
+ 1566083941)) i))
+ (+= i 1)
+ (if (>= i @N) (
+ (set mt 0 (get mt @(- N 1)))
+ (= i 1)
+ ))
+ (-= k 1)
+ ))
+ (set mt 0 0x80000000)
+ ))
+
+(int[] 2 mag01 (0 @MATRIX_A))
+(export prim_randui)
+(fun prim_randui () (
+ (int y)
+ (if (>= mti @N) (
+ (int kk 0)
+ (while (< kk @(- N M)) (
+ (= y (| (& (get mt kk) @UPPER_MASK) (& (get mt (+ kk 1)) @LOWER_MASK)))
+ (set mt kk (^ (^ (get mt (+ kk @M)) (>> y 1)) (get mag01 (& y 1))))
+ (+= kk 1)
+ ))
+ (while (< kk @(- N 1)) (
+ (= y (| (& (get mt kk) @UPPER_MASK) (& (get mt (+ kk 1)) @LOWER_MASK)))
+ (set mt kk (^ (^ (get mt (+ kk @(- M N))) (>> y 1)) (get mag01 (& y 1))))
+ (+= kk 1)
+ ))
+ (= y (| (& (get mt @(- N 1)) @UPPER_MASK) (& (get mt 0) @LOWER_MASK)))
+ (set mt @(- N 1) (^ (^ (get mt @(- M 1)) (>> y 1)) (get mag01 (& y 1))))
+ (= mti 0)
+ ))
+ (= y (get mt mti))
+ (+= mti 1)
+
+ ; Tempering
+ (^= y (>> y 11))
+ (^= y (& (<< y 7) 0x9d2c5680))
+ (^= y (& (<< y 15) 0xefc60000))
+ (^= y (>> y 18))
+
+ (return y)
+ ))
+
+ ))
+
+(vtable_push)
+(compile vm-prim-code)
+(vtable_pop)
Please sign in to comment.
Something went wrong with that request. Please try again.