steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2008-04-03 16:46:41 -05:00
parent 292cfd14ce 53d21c6c7a
commit a829e0c1fa
21 changed files with 156 additions and 153 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
extra/crypto/barrett/barrett.factor
View File

@ -4,5 +4,11 @@ IN: crypto.barrett
: barrett-mu ( n size -- mu )
#! Calculates Barrett's reduction parameter mu
#! size = word size in bits (8, 16, 32, 64, ...)
over log2 1+ over / 2 * >r 2 swap ^ r> ^ swap / floor ;
! over log2 1+ over / 2 * >r 2 swap ^ r> ^ swap / floor ;
[
[ log2 1+ ] [ / 2 * ] bi*
] [
2^ rot ^ swap /i
] 2bi ;

17
extra/crypto/common/common-docs.factor
View File

@ -2,23 +2,6 @@ USING: help.markup help.syntax kernel math sequences quotations
math.private ;
IN: crypto.common
HELP: >32-bit
{ $values { "x" integer } { "y" integer } }
{ $description "Used to implement 32-bit integer overflow." } ;
HELP: >64-bit
{ $values { "x" integer } { "y" integer } }
{ $description "Used to implement 64-bit integer overflow." } ;
HELP: bitroll
{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } }
{ $description "Roll n by s bits to the left, wrapping around after w bits." }
{ $examples
{ $example "USING: crypto.common prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" }
{ $example "USING: crypto.common prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" }
} ;
HELP: hex-string
{ $values { "seq" "a sequence" } { "str" "a string" } }
{ $description "Converts a sequence of values from 0-255 to a string of hex numbers from 0-ff." }

27
extra/crypto/common/common.factor
View File

@ -1,11 +1,8 @@
USING: arrays kernel io io.binary sbufs splitting strings sequences
namespaces math math.parser parser hints ;
namespaces math math.parser parser hints math.bitfields.lib ;
IN: crypto.common
: >32-bit ( x -- y ) HEX: ffffffff bitand ; inline
: >64-bit ( x -- y ) HEX: ffffffffffffffff bitand ; inline
: w+ ( int int -- int ) + >32-bit ; inline
: w+ ( int int -- int ) + 32 bits ; inline
: (nth-int) ( string n -- int )
2 shift dup 4 + rot <slice> ; inline
@ -39,26 +36,9 @@ SYMBOL: big-endian?
3 shift 8 rot [ >be ] [ >le ] if %
] "" make 64 group ;
: shift-mod ( n s w -- n )
>r shift r> 2^ 1- bitand ; inline
: update-old-new ( old new -- )
[ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline
: bitroll ( x s w -- y )
[ 1 - bitand ] keep
over 0 < [ [ + ] keep ] when
[ shift-mod ] 3keep
[ - ] keep shift-mod bitor ; inline
: bitroll-32 ( n s -- n' ) 32 bitroll ;
HINTS: bitroll-32 bignum fixnum ;
: bitroll-64 ( n s -- n' ) 64 bitroll ;
HINTS: bitroll-64 bignum fixnum ;
: hex-string ( seq -- str )
[ [ >hex 2 48 pad-left % ] each ] "" make ;
@ -70,9 +50,8 @@ HINTS: bitroll-64 bignum fixnum ;
: 2seq>seq ( seq1 seq2 -- seq )
#! { aceg } { bdfh } -> { abcdefgh }
swap ! error?
[ 2array flip concat ] keep like ;
: mod-nth ( n seq -- elt )
#! 5 "abcd" -> b
[ length mod ] keep nth ;
[ length mod ] [ nth ] bi ;

1
extra/crypto/hmac/hmac-tests.factor
View File

@ -9,4 +9,3 @@ IN: crypto.hmac.tests
[ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 <string> "Hi There" >byte-array byte-array>sha1-hmac >string ] unit-test
[ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" >byte-array byte-array>sha1-hmac >string ] unit-test
[ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa <string> 50 HEX: dd <repetition> >byte-array byte-array>sha1-hmac >string ] unit-test

1
extra/crypto/hmac/hmac.factor
View File

@ -37,7 +37,6 @@ MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
: byte-array>sha1-hmac ( K string -- hmac )
binary <byte-reader> stream>sha1-hmac ;
: stream>md5-hmac ( K stream -- hmac )
[ init-hmac md5-hmac ] with-stream ;

6
extra/crypto/md5/md5.factor
View File

@ -3,7 +3,7 @@
USING: kernel io io.binary io.files io.streams.byte-array math
math.functions math.parser namespaces splitting strings
sequences crypto.common byte-arrays locals sequences.private
io.encodings.binary symbols ;
io.encodings.binary symbols math.bitfields.lib ;
IN: crypto.md5
<PRIVATE
@ -43,11 +43,11 @@ SYMBOLS: a b c d old-a old-b old-c old-d ;
: F ( X Y Z -- FXYZ )
#! F(X,Y,Z) = XY v not(X) Z
pick bitnot bitand >r bitand r> bitor ;
pick bitnot bitand [ bitand ] [ bitor ] bi* ;
: G ( X Y Z -- GXYZ )
#! G(X,Y,Z) = XZ v Y not(Z)
dup bitnot rot bitand >r bitand r> bitor ;
dup bitnot rot bitand [ bitand ] [ bitor ] bi* ;
: H ( X Y Z -- HXYZ )
#! H(X,Y,Z) = X xor Y xor Z

6
extra/crypto/rsa/rsa.factor
View File

@ -1,5 +1,5 @@
USING: math.miller-rabin kernel math math.functions namespaces
sequences ;
sequences accessors ;
IN: crypto.rsa
! The private key is the only secret.
@ -39,7 +39,7 @@ PRIVATE>
public-key <rsa> ;
: rsa-encrypt ( message rsa -- encrypted )
[ rsa-public-key ] keep rsa-modulus ^mod ;
[ public-key>> ] [ modulus>> ] bi ^mod ;
: rsa-decrypt ( encrypted rsa -- message )
[ rsa-private-key ] keep rsa-modulus ^mod ;
[ private-key>> ] [ modulus>> ] bi ^mod ;

4
extra/crypto/sha1/sha1.factor
View File

@ -1,7 +1,7 @@
USING: arrays combinators crypto.common kernel io
io.encodings.binary io.files io.streams.byte-array math.vectors
strings sequences namespaces math parser sequences vectors
io.binary hashtables symbols ;
io.binary hashtables symbols math.bitfields.lib ;
IN: crypto.sha1
! Implemented according to RFC 3174.
@ -66,7 +66,7 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
K get nth ,
A get 5 bitroll-32 ,
E get ,
] { } make sum >32-bit ; inline
] { } make sum 32 bits ; inline
: set-vars ( temp -- )
! E = D; D = C; C = S^30(B); B = A; A = TEMP;

21
extra/crypto/sha2/sha2.factor
View File

@ -1,19 +1,19 @@
USING: crypto.common kernel splitting math sequences namespaces
io.binary symbols ;
io.binary symbols math.bitfields.lib ;
IN: crypto.sha2
<PRIVATE
SYMBOLS: vars M K H S0 S1 process-M word-size block-size >word ;
SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
: a 0 ;
: b 1 ;
: c 2 ;
: d 3 ;
: e 4 ;
: f 5 ;
: g 6 ;
: h 7 ;
: a 0 ; inline
: b 1 ; inline
: c 2 ; inline
: d 3 ; inline
: e 4 ; inline
: f 5 ; inline
: g 6 ; inline
: h 7 ; inline
: initial-H-256 ( -- seq )
{
@ -124,7 +124,6 @@ PRIVATE>
initial-H-256 H set
4 word-size set
64 block-size set
\ >32-bit >word set
byte-array>sha2
] with-scope ;

5
extra/crypto/timing/timing.factor
View File

@ -1,7 +1,6 @@
USING: kernel math threads system ;
IN: crypto.timing
: with-timing ( ... quot n -- )
: with-timing ( quot n -- )
#! force the quotation to execute in, at minimum, n milliseconds
millis 2slip millis - + sleep ;
millis 2slip millis - + sleep ; inline

6
extra/crypto/xor/xor.factor
View File

@ -1,8 +1,8 @@
USING: crypto.common kernel math sequences ;
IN: crypto.xor
TUPLE: no-xor-key ;
ERROR: no-xor-key ;
: xor-crypt ( key seq -- seq )
over empty? [ no-xor-key construct-empty throw ] when
: xor-crypt ( key seq -- seq' )
over empty? [ no-xor-key ] when
dup length rot [ mod-nth bitxor ] curry 2map ;

3
extra/hardware-info/backend/backend.factor
View File

@ -1,8 +1,7 @@
USING: system ;
IN: hardware-info.backend
SYMBOL: os
HOOK: cpus os ( -- n )
HOOK: memory-load os ( -- n )
HOOK: physical-mem os ( -- n )
HOOK: available-mem os ( -- n )

15
extra/hardware-info/hardware-info.factor
View File

@ -1,10 +1,13 @@
USING: alien.syntax kernel math prettyprint
USING: alien.syntax kernel math prettyprint io math.parser
combinators vocabs.loader hardware-info.backend system ;
IN: hardware-info
: kb. ( x -- ) 10 2^ /f . ;
: megs. ( x -- ) 20 2^ /f . ;
: gigs. ( x -- ) 30 2^ /f . ;
: write-unit ( x n str -- )
[ 2^ /i number>string write bl ] [ write ] bi* ;
: kb ( x -- ) 10 "kB" write-unit ;
: megs ( x -- ) 20 "MB" write-unit ;
: gigs ( x -- ) 30 "GB" write-unit ;
<< {
{ [ os windows? ] [ "hardware-info.windows" ] }
@ -12,3 +15,7 @@ IN: hardware-info
{ [ os macosx? ] [ "hardware-info.macosx" ] }
{ [ t ] [ f ] }
} cond [ require ] when* >>
: hardware-report. ( -- )
"CPUs: " write cpus number>string write nl
"Physical RAM: " write physical-mem megs nl ;

28
extra/hardware-info/macosx/macosx.factor
View File

@ -1,10 +1,8 @@
USING: alien alien.c-types alien.syntax byte-arrays kernel
namespaces sequences unix hardware-info.backend ;
namespaces sequences unix hardware-info.backend system
io.unix.backend ;
IN: hardware-info.macosx
TUPLE: macosx ;
T{ macosx } os set-global
! See /usr/include/sys/sysctl.h for constants
LIBRARY: libc
@ -14,14 +12,11 @@ FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, voi
[ <int> ] map concat ;
: (sysctl-query) ( name namelen oldp oldlenp -- oldp error/f )
over >r
f 0 sysctl -1 = [ err_no strerror ] [ f ] if
r> swap ;
over >r f 0 sysctl io-error r> ;
: sysctl-query ( seq n -- byte-array )
>r [ make-int-array ] keep length r>
[ <byte-array> ] keep <uint>
(sysctl-query) [ throw ] when* ;
>r [ make-int-array ] [ length ] bi r>
[ <byte-array> ] [ <uint> ] bi (sysctl-query) ;
: sysctl-query-string ( seq -- n )
4096 sysctl-query alien>char-string ;
@ -36,8 +31,15 @@ FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, voi
: model ( -- str ) { 6 2 } sysctl-query-string ;
M: macosx cpus ( -- n ) { 6 3 } sysctl-query-uint ;
: byte-order ( -- n ) { 6 4 } sysctl-query-uint ;
: user-mem ( -- n ) { 6 4 } sysctl-query-uint ;
M: macosx physical-mem ( -- n ) { 6 5 } sysctl-query-uint ;
: user-mem ( -- n ) { 6 6 } sysctl-query-uint ;
: page-size ( -- n ) { 6 7 } sysctl-query-uint ;
: disknames ( -- n ) { 6 8 } 8 sysctl-query ;
: diskstats ( -- n ) { 6 9 } 8 sysctl-query ;
: epoch ( -- n ) { 6 10 } sysctl-query-uint ;
: floating-point ( -- n ) { 6 11 } sysctl-query-uint ;
: machine-arch ( -- n ) { 6 12 } sysctl-query-string ;
: vector-unit ( -- n ) { 6 13 } sysctl-query-uint ;
: bus-frequency ( -- n ) { 6 14 } sysctl-query-uint ;
: cpu-frequency ( -- n ) { 6 15 } sysctl-query-uint ;
: cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ;
@ -47,7 +49,7 @@ M: macosx cpus ( -- n ) { 6 3 } sysctl-query-uint ;
: l2-cache-size ( -- n ) { 6 20 } sysctl-query-uint ;
: l3-cache-settings ( -- n ) { 6 21 } sysctl-query-uint ;
: l3-cache-size ( -- n ) { 6 22 } sysctl-query-uint ;
: bus-frequency2 ( -- n ) { 6 23 } sysctl-query-uint ;
M: macosx physical-mem ( -- n ) { 6 24 } sysctl-query-ulonglong ;
: tb-frequency ( -- n ) { 6 23 } sysctl-query-uint ;
: mem-size ( -- n ) { 6 24 } sysctl-query-ulonglong ;
: available-cpus ( -- n ) { 6 25 } sysctl-query-uint ;

19
extra/hardware-info/windows/ce/ce.factor
View File

@ -2,33 +2,30 @@ USING: alien.c-types hardware-info kernel math namespaces
windows windows.kernel32 hardware-info.backend ;
IN: hardware-info.windows.ce
TUPLE: wince-os ;
T{ wince-os } os set-global
: memory-status ( -- MEMORYSTATUS )
"MEMORYSTATUS" <c-object>
"MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength
[ GlobalMemoryStatus ] keep ;
M: wince-os cpus ( -- n ) 1 ;
M: wince cpus ( -- n ) 1 ;
M: wince-os memory-load ( -- n )
M: wince memory-load ( -- n )
memory-status MEMORYSTATUS-dwMemoryLoad ;
M: wince-os physical-mem ( -- n )
M: wince physical-mem ( -- n )
memory-status MEMORYSTATUS-dwTotalPhys ;
M: wince-os available-mem ( -- n )
M: wince available-mem ( -- n )
memory-status MEMORYSTATUS-dwAvailPhys ;
M: wince-os total-page-file ( -- n )
M: wince total-page-file ( -- n )
memory-status MEMORYSTATUS-dwTotalPageFile ;
M: wince-os available-page-file ( -- n )
M: wince available-page-file ( -- n )
memory-status MEMORYSTATUS-dwAvailPageFile ;
M: wince-os total-virtual-mem ( -- n )
M: wince total-virtual-mem ( -- n )
memory-status MEMORYSTATUS-dwTotalVirtual ;
M: wince-os available-virtual-mem ( -- n )
M: wince available-virtual-mem ( -- n )
memory-status MEMORYSTATUS-dwAvailVirtual ;

21
extra/hardware-info/windows/nt/nt.factor
View File

@ -1,15 +1,12 @@
USING: alien alien.c-types
kernel libc math namespaces hardware-info.backend
windows windows.advapi32 windows.kernel32 ;
windows windows.advapi32 windows.kernel32 system ;
IN: hardware-info.windows.nt
TUPLE: winnt-os ;
T{ winnt-os } os set-global
: system-info ( -- SYSTEM_INFO )
"SYSTEM_INFO" <c-object> [ GetSystemInfo ] keep ;
M: winnt-os cpus ( -- n )
M: winnt cpus ( -- n )
system-info SYSTEM_INFO-dwNumberOfProcessors ;
: memory-status ( -- MEMORYSTATUSEX )
@ -17,25 +14,25 @@ M: winnt-os cpus ( -- n )
"MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength
[ GlobalMemoryStatusEx ] keep swap zero? [ win32-error ] when ;
M: winnt-os memory-load ( -- n )
M: winnt memory-load ( -- n )
memory-status MEMORYSTATUSEX-dwMemoryLoad ;
M: winnt-os physical-mem ( -- n )
M: winnt physical-mem ( -- n )
memory-status MEMORYSTATUSEX-ullTotalPhys ;
M: winnt-os available-mem ( -- n )
M: winnt available-mem ( -- n )
memory-status MEMORYSTATUSEX-ullAvailPhys ;
M: winnt-os total-page-file ( -- n )
M: winnt total-page-file ( -- n )
memory-status MEMORYSTATUSEX-ullTotalPageFile ;
M: winnt-os available-page-file ( -- n )
M: winnt available-page-file ( -- n )
memory-status MEMORYSTATUSEX-ullAvailPageFile ;
M: winnt-os total-virtual-mem ( -- n )
M: winnt total-virtual-mem ( -- n )
memory-status MEMORYSTATUSEX-ullTotalVirtual ;
M: winnt-os available-virtual-mem ( -- n )
M: winnt available-virtual-mem ( -- n )
memory-status MEMORYSTATUSEX-ullAvailVirtual ;
: computer-name ( -- string )

16
extra/math/bitfields/lib/lib-docs.factor Normal file
View File

@ -0,0 +1,16 @@
USING: help.markup help.syntax kernel math sequences ;
IN: math.bitfields.lib
HELP: bits
{ $values { "m" integer } { "n" integer } { "m'" integer } }
{ $description "Keep only n bits from the integer m." }
{ $example "USING: math.bitfields.lib prettyprint ;" "HEX: 123abcdef 16 bits .h" "cdef" } ;
HELP: bitroll
{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } }
{ $description "Roll n by s bits to the left, wrapping around after w bits." }
{ $examples
{ $example "USING: math.bitfields.lib prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" }
{ $example "USING: math.bitfields.lib prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" }
} ;

5
extra/crypto/test/common.factor → extra/math/bitfields/lib/lib-tests.factor
View File

@ -1,4 +1,5 @@
USING: kernel math test namespaces crypto ;
USING: math.bitfields.lib tools.test ;
IN: math.bitfields.lib.test
[ 0 ] [ 1 0 0 bitroll ] unit-test
[ 1 ] [ 1 0 1 bitroll ] unit-test
@ -11,5 +12,3 @@ USING: kernel math test namespaces crypto ;
[ 1 ] [ 1 -32 8 bitroll ] unit-test
[ 128 ] [ 1 -1 8 bitroll ] unit-test
[ 8 ] [ 1 3 32 bitroll ] unit-test

31
extra/math/bitfields/lib/lib.factor Normal file
View File

@ -0,0 +1,31 @@
USING: hints kernel math ;
IN: math.bitfields.lib
: clear-bit ( x n -- y ) 2^ bitnot bitand ; foldable
: set-bit ( x n -- y ) 2^ bitor ; foldable
: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable
: bit-set? ( x n -- ? ) bit-clear? not ; foldable
: unmask ( x n -- ? ) bitnot bitand ; foldable
: unmask? ( x n -- ? ) unmask 0 > ; foldable
: mask ( x n -- ? ) bitand ; foldable
: mask? ( x n -- ? ) mask 0 > ; foldable
: wrap ( m n -- m' ) 1- bitand ; foldable
: bits ( m n -- m' ) 2^ wrap ; inline
: mask-bit ( m n -- m' ) 1- 2^ mask ; inline
: shift-mod ( n s w -- n )
>r shift r> 2^ wrap ; inline
: bitroll ( x s w -- y )
[ wrap ] keep
[ shift-mod ] 3keep
[ - ] keep shift-mod bitor ; inline
: bitroll-32 ( n s -- n' ) 32 bitroll ;
HINTS: bitroll-32 bignum fixnum ;
: bitroll-64 ( n s -- n' ) 64 bitroll ;
HINTS: bitroll-64 bignum fixnum ;

9
extra/math/functions/functions.factor
View File

@ -30,15 +30,6 @@ M: real sqrt
2dup >r >r >r odd? r> call r> 2/ r> each-bit
] if ; inline
: clear-bit ( x n -- y ) 2^ bitnot bitand ; foldable
: set-bit ( x n -- y ) 2^ bitor ; foldable
: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable
: bit-set? ( x n -- ? ) bit-clear? not ; foldable
: unmask ( x n -- ? ) bitnot bitand ; foldable
: unmask? ( x n -- ? ) unmask 0 > ; foldable
: mask ( x n -- ? ) bitand ; foldable
: mask? ( x n -- ? ) mask 0 > ; foldable
GENERIC: (^) ( x y -- z ) foldable
: ^n ( z w -- z^w )

60
extra/random/mersenne-twister/mersenne-twister.factor
View File

@ -2,9 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
! mersenne twister based on
! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
USING: arrays kernel math namespaces sequences system init
accessors math.ranges random circular ;
accessors math.ranges random circular math.bitfields.lib
combinators ;
IN: random.mersenne-twister
<PRIVATE
@ -14,40 +14,38 @@ TUPLE: mersenne-twister seq i ;
: mt-n 624 ; inline
: mt-m 397 ; inline
: mt-a HEX: 9908b0df ; inline
: mt-hi HEX: 80000000 bitand ; inline
: mt-lo HEX: 7fffffff bitand ; inline
: set-generated ( y from-elt to seq -- )
>r >r >r [ 2/ ] [ odd? mt-a 0 ? ] bi
r> bitxor bitxor r> r> set-nth ; inline
: calculate-y ( y1 y2 mt -- y )
tuck [ nth mt-hi ] [ nth mt-lo ] 2bi* bitor ; inline
tuck
[ nth 32 mask-bit ]
[ nth 31 bits ] 2bi* bitor ; inline
: (mt-generate) ( n mt-seq -- y to from-elt )
[ >r dup 1+ r> calculate-y ]
[ >r mt-m + r> nth ]
[ drop ] 2tri ;
: (mt-generate) ( n mt-seq -- next-mt )
[
[ dup 1+ ] [ calculate-y ] bi*
[ 2/ ] [ odd? mt-a 0 ? ] bi bitxor
] [
[ mt-m + ] [ nth ] bi*
] 2bi bitxor ;
: mt-generate ( mt -- )
[ >r mt-n r> seq>> [ [ (mt-generate) ] keep set-generated ] curry each ]
[ 0 >>i drop ] bi ;
[
mt-n swap seq>> [
[ (mt-generate) ] [ set-nth ] 2bi
] curry each
] [ 0 >>i drop ] bi ;
: init-mt-first ( seed -- seq )
>r mt-n 0 <array> <circular> r>
HEX: ffffffff bitand 0 pick set-nth ;
: init-mt-formula ( seq i -- f(seq[i]) )
tuck swap nth dup -30 shift bitxor 1812433253 * +
1+ HEX: ffffffff bitand ;
: init-mt-formula ( i seq -- f(seq[i]) )
dupd nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ;
: init-mt-rest ( seq -- )
mt-n 1- [0,b) [
dupd [ init-mt-formula ] keep 1+ rot set-nth
] with each ;
mt-n 1- swap [
[ init-mt-formula ] [ >r 1+ r> set-nth ] 2bi
] curry each ;
: init-mt-seq ( seed -- seq )
init-mt-first dup init-mt-rest ;
32 bits mt-n 0 <array> <circular>
[ set-first ] [ init-mt-rest ] [ ] tri ;
: mt-temper ( y -- yt )
dup -11 shift bitxor
@ -55,6 +53,9 @@ TUPLE: mersenne-twister seq i ;
dup 15 shift HEX: efc60000 bitand bitxor
dup -18 shift bitxor ; inline
: next-index ( mt -- i )
dup i>> dup mt-n < [ nip ] [ drop mt-generate 0 ] if ;
PRIVATE>
: <mersenne-twister> ( seed -- obj )
@ -65,7 +66,6 @@ M: mersenne-twister seed-random ( mt seed -- )
init-mt-seq >>seq drop ;
M: mersenne-twister random-32* ( mt -- r )
dup [ i>> ] [ seq>> ] bi
over mt-n < [ nip >r dup mt-generate 0 r> ] unless
nth mt-temper
swap [ 1+ ] change-i drop ;
[ next-index ]
[ seq>> nth mt-temper ]
[ [ 1+ ] change-i drop ] tri ;