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

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

Doug Coleman 2008-03-19 22:20:26 -05:00
parent 84160c8f75 e9d7e2523c
commit 693f3b9193
12 changed files with 57 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/bootstrap/stage2.factor
View File

@ -57,7 +57,7 @@ millis >r
default-image-name "output-image" set-global default-image-name "output-image" set-global
"math help handbook compiler tools ui ui.tools io" "include" set-global "math help handbook compiler random tools ui ui.tools io" "include" set-global
"" "exclude" set-global "" "exclude" set-global
parse-command-line parse-command-line

6
core/compiler/tests/intrinsics.factor
View File

@ -261,7 +261,7 @@ cell 8 = [
: compiled-fixnum* fixnum* ; : compiled-fixnum* fixnum* ;
: test-fixnum* : test-fixnum*
(random) >fixnum (random) >fixnum 32 random-bits >fixnum 32 random-bits >fixnum
2dup 2dup
[ fixnum* ] 2keep compiled-fixnum* = [ fixnum* ] 2keep compiled-fixnum* =
[ 2drop ] [ "Oops" throw ] if ; [ 2drop ] [ "Oops" throw ] if ;
@ -271,7 +271,7 @@ cell 8 = [
: compiled-fixnum>bignum fixnum>bignum ; : compiled-fixnum>bignum fixnum>bignum ;
: test-fixnum>bignum : test-fixnum>bignum
(random) >fixnum 32 random-bits >fixnum
dup [ fixnum>bignum ] keep compiled-fixnum>bignum = dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
[ drop ] [ "Oops" throw ] if ; [ drop ] [ "Oops" throw ] if ;
@ -280,7 +280,7 @@ cell 8 = [
: compiled-bignum>fixnum bignum>fixnum ; : compiled-bignum>fixnum bignum>fixnum ;
: test-bignum>fixnum : test-bignum>fixnum
5 random [ drop (random) ] map product >bignum 5 random [ drop 32 random-bits ] map product >bignum
dup [ bignum>fixnum ] keep compiled-bignum>fixnum = dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
[ drop ] [ "Oops" throw ] if ; [ drop ] [ "Oops" throw ] if ;

2
core/heaps/heaps-tests.factor
View File

@ -33,7 +33,7 @@ IN: heaps.tests
: random-alist ( n -- alist ) : random-alist ( n -- alist )
[ [
[ [
(random) dup number>string swap set 32 random-bits dup number>string swap set
] times ] times
] H{ } make-assoc ; ] H{ } make-assoc ;

7
extra/bootstrap/random/random.factor Normal file → Executable file
View File

@ -1,4 +1,6 @@
USING: vocabs.loader sequences system ; USING: vocabs.loader sequences system
random random.mersenne-twister combinators init
namespaces ;
"random.mersenne-twister" require "random.mersenne-twister" require
@ -6,3 +8,6 @@ USING: vocabs.loader sequences system ;
{ [ windows? ] [ "random.windows" require ] } { [ windows? ] [ "random.windows" require ] }
{ [ unix? ] [ "random.unix" require ] } { [ unix? ] [ "random.unix" require ] }
} cond } cond
[ millis <mersenne-twister> random-generator set-global ]
"generator.random" add-init-hook

40
extra/calendar/calendar.factor
View File

@ -59,31 +59,29 @@ SYMBOL: m
PRIVATE> PRIVATE>
: julian-day-number ( year month day -- n ) :: julian-day-number ( year month day -- n )
#! Returns a composite date number #! Returns a composite date number
#! Not valid before year -4800 #! Not valid before year -4800
[ [let* | a [ 14 month - 12 /i ]
14 pick - 12 /i a set y [ year 4800 + a - ]
pick 4800 + a get - y set m [ month 12 a * + 3 - ] |
over 12 a get * + 3 - m set day 153 m * 2 + 5 /i + 365 y * +
2nip 153 m get * 2 + 5 /i + 365 y get * + y 4 /i + y 100 /i - y 400 /i + 32045 -
y get 4 /i + y get 100 /i - y get 400 /i + 32045 - ] ;
] with-scope ;
: julian-day-number>date ( n -- year month day ) :: julian-day-number>date ( n -- year month day )
#! Inverse of julian-day-number #! Inverse of julian-day-number
[ [let* | a [ n 32044 + ]
32044 + a set b [ 4 a * 3 + 146097 /i ]
4 a get * 3 + 146097 /i b set c [ a 146097 b * 4 /i - ]
a get 146097 b get * 4 /i - c set d [ 4 c * 3 + 1461 /i ]
4 c get * 3 + 1461 /i d set e [ c 1461 d * 4 /i - ]
c get 1461 d get * 4 /i - e set m [ 5 e * 2 + 153 /i ] |
5 e get * 2 + 153 /i m set 100 b * d + 4800 -
100 b get * d get + 4800 - m 10 /i + m 3 +
m get 10 /i + m get 3 + 12 m 10 /i * -
12 m get 10 /i * - e 153 m * 2 + 5 /i - 1+
e get 153 m get * 2 + 5 /i - 1+ ] ;
] with-scope ;
: >date< ( timestamp -- year month day ) : >date< ( timestamp -- year month day )
{ year>> month>> day>> } get-slots ; { year>> month>> day>> } get-slots ;

21
extra/calendar/windows/windows.factor
View File

@ -9,13 +9,14 @@ T{ windows-calendar } calendar-backend set-global
: TIME_ZONE_ID_INVALID HEX: ffffffff ; inline : TIME_ZONE_ID_INVALID HEX: ffffffff ; inline
M: windows-calendar gmt-offset ( -- hours minutes seconds ) M: windows-calendar gmt-offset ( -- hours minutes seconds )
"TIME_ZONE_INFORMATION" <c-object> 0 0 0 ;
dup GetTimeZoneInformation { ! "TIME_ZONE_INFORMATION" <c-object>
{ [ dup TIME_ZONE_ID_INVALID = ] [ win32-error ] } ! dup GetTimeZoneInformation {
{ [ dup { TIME_ZONE_ID_UNKNOWN TIME_ZONE_ID_STANDARD } member? ] ! { [ dup TIME_ZONE_ID_INVALID = ] [ win32-error ] }
[ TIME_ZONE_INFORMATION-Bias 60 / neg ] } ! { [ dup { TIME_ZONE_ID_UNKNOWN TIME_ZONE_ID_STANDARD } member? ]
{ [ dup TIME_ZONE_ID_DAYLIGHT = ] [ ! [ TIME_ZONE_INFORMATION-Bias 60 / neg ] }
[ TIME_ZONE_INFORMATION-Bias 60 / neg ] ! { [ dup TIME_ZONE_ID_DAYLIGHT = ] [
[ TIME_ZONE_INFORMATION-DaylightBias ] bi ! [ TIME_ZONE_INFORMATION-Bias 60 / neg ]
] } ! [ TIME_ZONE_INFORMATION-DaylightBias ] bi
} cond ; ! ] }
! } cond ;

6
extra/circular/circular-tests.factor Normal file → Executable file
View File

@ -9,7 +9,6 @@ circular strings ;
[ CHAR: t ] [ "test" <circular> 0 swap nth ] unit-test [ CHAR: t ] [ "test" <circular> 0 swap nth ] unit-test
[ "test" ] [ "test" <circular> >string ] unit-test [ "test" ] [ "test" <circular> >string ] unit-test
[ "test" <circular> 5 swap nth ] must-fail
[ CHAR: e ] [ "test" <circular> 5 swap nth-unsafe ] unit-test [ CHAR: e ] [ "test" <circular> 5 swap nth-unsafe ] unit-test
[ [ 1 2 3 ] ] [ { 1 2 3 } <circular> [ ] like ] unit-test [ [ 1 2 3 ] ] [ { 1 2 3 } <circular> [ ] like ] unit-test
@ -18,10 +17,13 @@ circular strings ;
[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> -100 over change-circular-start [ ] like ] unit-test [ [ 3 1 2 ] ] [ { 1 2 3 } <circular> -100 over change-circular-start [ ] like ] unit-test
[ "fob" ] [ "foo" <circular> CHAR: b 2 pick set-nth >string ] unit-test [ "fob" ] [ "foo" <circular> CHAR: b 2 pick set-nth >string ] unit-test
[ "foo" <circular> CHAR: b 3 rot set-nth ] must-fail
[ "boo" ] [ "foo" <circular> CHAR: b 3 pick set-nth-unsafe >string ] unit-test [ "boo" ] [ "foo" <circular> CHAR: b 3 pick set-nth-unsafe >string ] unit-test
[ "ornact" ] [ "factor" <circular> 4 over change-circular-start CHAR: n 2 pick set-nth >string ] unit-test [ "ornact" ] [ "factor" <circular> 4 over change-circular-start CHAR: n 2 pick set-nth >string ] unit-test
[ "bcd" ] [ 3 <circular-string> "abcd" [ over push-circular ] each >string ] unit-test [ "bcd" ] [ 3 <circular-string> "abcd" [ over push-circular ] each >string ] unit-test
[ { 0 0 } ] [ { 0 0 } <circular> -1 over change-circular-start >array ] unit-test [ { 0 0 } ] [ { 0 0 } <circular> -1 over change-circular-start >array ] unit-test
! This no longer fails
! [ "test" <circular> 5 swap nth ] must-fail
! [ "foo" <circular> CHAR: b 3 rot set-nth ] must-fail

4
extra/circular/circular.factor Normal file → Executable file
View File

@ -18,9 +18,9 @@ M: circular length circular-seq length ;
M: circular virtual@ circular-wrap circular-seq ; M: circular virtual@ circular-wrap circular-seq ;
M: circular nth bounds-check virtual@ nth ; M: circular nth virtual@ nth ;
M: circular set-nth bounds-check virtual@ set-nth ; M: circular set-nth virtual@ set-nth ;
: change-circular-start ( n circular -- ) : change-circular-start ( n circular -- )
#! change start to (start + n) mod length #! change start to (start + n) mod length

2
extra/io/windows/nt/pipes/pipes.factor
View File

@ -56,7 +56,7 @@ TUPLE: pipe in out ;
"\\\\.\\pipe\\factor-" % "\\\\.\\pipe\\factor-" %
pipe counter # pipe counter #
"-" % "-" %
(random) # 32 random-bits #
"-" % "-" %
millis # millis #
] "" make ; ] "" make ;

5
extra/random/mersenne-twister/mersenne-twister-tests.factor Normal file → Executable file
View File

@ -1,7 +1,6 @@
USING: kernel math random namespaces random.mersenne-twister USING: kernel math random namespaces random.mersenne-twister
sequences tools.test ; sequences tools.test ;
IN: random.mersenne-twister.tests IN: random.mersenne-twister.tests
USE: tools.walker
: check-random ( max -- ? ) : check-random ( max -- ? )
dup >r random 0 r> between? ; dup >r random 0 r> between? ;
@ -17,11 +16,11 @@ USE: tools.walker
[ f ] [ 1234 [ make-100-randoms make-100-randoms = ] test-rng ] unit-test [ f ] [ 1234 [ make-100-randoms make-100-randoms = ] test-rng ] unit-test
[ 1333075495 ] [ [ 1333075495 ] [
0 [ 1000 [ drop \ random get random-32 drop ] each \ random get random-32 ] test-rng 0 [ 1000 [ drop random-generator get random-32 drop ] each random-generator get random-32 ] test-rng
] unit-test ] unit-test
[ 1575309035 ] [ [ 1575309035 ] [
0 [ 10000 [ drop \ random get random-32 drop ] each \ random get random-32 ] test-rng 0 [ 10000 [ drop random-generator get random-32 drop ] each random-generator get random-32 ] test-rng
] unit-test ] unit-test

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

@ -3,9 +3,8 @@
! mersenne twister based on ! mersenne twister based on
! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c ! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
USING: arrays kernel math namespaces sequences USING: arrays kernel math namespaces sequences system init
system init new-slots accessors new-slots accessors math.ranges combinators.cleave random ;
math.ranges combinators.cleave circular random ;
IN: random.mersenne-twister IN: random.mersenne-twister
<PRIVATE <PRIVATE
@ -76,5 +75,3 @@ M: mersenne-twister random-32 ( mt -- r )
dup mt-n < [ drop 0 pick mt-generate ] unless dup mt-n < [ drop 0 pick mt-generate ] unless
new-nth mt-temper new-nth mt-temper
swap [ 1+ ] change-i drop ; swap [ 1+ ] change-i drop ;
[ millis <mersenne-twister> \ random set-global ] "random" add-init-hook

10
extra/random/random.factor Normal file → Executable file
View File

@ -15,16 +15,14 @@ GENERIC: random-32 ( tuple -- r )
: (random-bytes) ( tuple n -- byte-array ) : (random-bytes) ( tuple n -- byte-array )
[ drop random-32 ] with map >c-uint-array ; [ drop random-32 ] with map >c-uint-array ;
DEFER: random SYMBOL: random-generator
: random-bytes ( n -- r ) : random-bytes ( n -- r )
[ [
4 /mod zero? [ 1+ ] unless 4 /mod zero? [ 1+ ] unless
\ random get swap (random-bytes) random-generator get swap (random-bytes)
] keep head ; ] keep head ;
: random-bits ( n -- r ) 2^ random ;
: random ( seq -- elt ) : random ( seq -- elt )
dup empty? [ dup empty? [
drop f drop f
@ -35,5 +33,7 @@ DEFER: random
] keep nth ] keep nth
] if ; ] if ;
: random-bits ( n -- r ) 2^ random ;
: with-random ( tuple quot -- ) : with-random ( tuple quot -- )
\ random swap with-variable ; inline random-generator swap with-variable ; inline