Initial commit. Needs some rewriting
Doug Coleman
parent
8914e9b640
commit
818d086988
|
|
@ -0,0 +1,7 @@
|
|||
USING: kernel parser sequences words compiler ;
|
||||
IN: scratchpad
|
||||
|
||||
{
|
||||
"utils"
|
||||
"random-tester"
|
||||
} [ "contrib/random-tester/" swap ".factor" append3 run-file ] each
|
||||
|
|
@ -0,0 +1,384 @@
|
|||
USING: kernel math sequences namespaces errors hashtables words arrays parser
|
||||
compiler syntax lists io ;
|
||||
USING: inspector prettyprint ;
|
||||
USING: optimizer compiler-frontend compiler-backend inference ;
|
||||
IN: random-tester
|
||||
|
||||
! Tweak me
|
||||
: max-length 5 ; inline
|
||||
: max-value 1000000000 ; inline
|
||||
|
||||
|
||||
! varying bit-length random number
|
||||
: random-bits ( n -- int )
|
||||
random-int 2 swap ^ random-int ;
|
||||
|
||||
: random-seq ( -- seq )
|
||||
{ [ ] { } V{ } "" } nth-rand
|
||||
[ max-length random-int [ max-value random-int , ] times ] swap make ;
|
||||
|
||||
SYMBOL: special-integers
|
||||
[ { -1 0 1 } % most-negative-fixnum , most-positive-fixnum , first-bignum , ]
|
||||
{ } make \ special-integers set
|
||||
: special-integers ( -- seq ) \ special-integers get ;
|
||||
SYMBOL: special-floats
|
||||
[ { 0.0 } % e , pi , inf , -inf , 0/0. , epsilon , epsilon neg , ]
|
||||
{ } make \ special-floats set
|
||||
: special-floats ( -- seq ) \ special-floats get ;
|
||||
SYMBOL: special-complexes
|
||||
[
|
||||
{ -1 0 1 i -i } %
|
||||
e , pi , 0 pi rect> , 0 pi neg rect> , pi neg 0 rect> , pi pi rect> ,
|
||||
pi pi neg rect> , pi neg pi rect> , pi neg pi neg rect> ,
|
||||
e neg e neg rect> , e e rect> ,
|
||||
] { } make \ special-complexes set
|
||||
|
||||
: special-complexes ( -- seq ) \ special-complexes get ;
|
||||
|
||||
: random-fixnum ( -- fixnum )
|
||||
most-positive-fixnum random-int 1+ coin-flip [ neg 1- ] when >fixnum ;
|
||||
|
||||
: random-bignum ( -- bignum )
|
||||
400 random-bits first-bignum + coin-flip [ neg ] when ;
|
||||
|
||||
: random-integer
|
||||
coin-flip [
|
||||
random-fixnum
|
||||
] [
|
||||
coin-flip [ random-bignum ] [ special-integers nth-rand ] if
|
||||
] if ;
|
||||
|
||||
: random-positive-integer ( -- int )
|
||||
random-integer dup 0 < [
|
||||
neg
|
||||
] [
|
||||
dup 0 = [ 1 + ] when
|
||||
] if ;
|
||||
|
||||
: random-ratio ( -- ratio )
|
||||
1000000000 dup [ random-int ] 2apply 1+ / coin-flip [ neg ] when dup [ drop random-ratio ] unless ;
|
||||
|
||||
: random-float ( -- float )
|
||||
coin-flip [ random-ratio ] [ special-floats nth-rand ] if
|
||||
coin-flip
|
||||
[ .0000000000000000001 /f ] [ coin-flip [ .00000000000000001 * ] when ] if
|
||||
>float ;
|
||||
|
||||
: random-number ( -- number )
|
||||
{
|
||||
[ random-integer ]
|
||||
[ random-ratio ]
|
||||
[ random-float ]
|
||||
} do-one ;
|
||||
|
||||
: random-complex ( -- C{ } )
|
||||
random-number random-number rect> ;
|
||||
|
||||
|
||||
! Math vocabulary words
|
||||
: math-1 ( -- seq )
|
||||
{
|
||||
1+ 1- >bignum >digit >fixnum abs absq arg
|
||||
bitnot bits>double bits>float ceiling cis conjugate cos cosec cosech
|
||||
cosh cot coth denominator double>bits exp float>bits floor imaginary
|
||||
log neg next-power-of-2 numerator quadrant real sec
|
||||
sech sgn sin sinh sq sqrt tan tanh truncate
|
||||
} ;
|
||||
! TODO: take this out eventually
|
||||
: math-throw-1
|
||||
{
|
||||
recip
|
||||
asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh
|
||||
} ;
|
||||
|
||||
: integer>x
|
||||
{
|
||||
1+ 1- >bignum >digit >fixnum abs absq arg
|
||||
bitnot bits>double bits>float ceiling cis conjugate cos cosec cosech
|
||||
cosh cot coth denominator double>bits exp float>bits floor imaginary
|
||||
log neg next-power-of-2 numerator quadrant real sec
|
||||
sech sgn sin sinh sq sqrt tan tanh truncate
|
||||
} ;
|
||||
|
||||
: ratio>x
|
||||
{
|
||||
1+ 1- >bignum >digit >fixnum abs absq arg
|
||||
cis conjugate cos cosec cosech
|
||||
cosh cot coth double>bits exp float>bits floor imaginary
|
||||
log neg next-power-of-2 quadrant real sec
|
||||
sech sgn sin sinh sq sqrt tan tanh truncate
|
||||
} ;
|
||||
|
||||
! ceiling, truncate, floor eventually
|
||||
: float>x ( float -- x )
|
||||
{
|
||||
1+ 1- >bignum >digit >fixnum abs absq arg
|
||||
cis conjugate cos cosec cosech
|
||||
cosh cot coth double>bits exp float>bits imaginary
|
||||
log neg next-power-of-2 quadrant real sec
|
||||
sech sgn sin sinh sq sqrt tan tanh
|
||||
} ;
|
||||
|
||||
: complex>x
|
||||
{
|
||||
1+ 1- abs absq arg
|
||||
conjugate cos cosec cosech
|
||||
cosh cot coth exp imaginary
|
||||
log neg quadrant real sec
|
||||
sech sin sinh sq sqrt tan tanh
|
||||
} ;
|
||||
|
||||
: integer>integer
|
||||
{
|
||||
1+ 1- >bignum >digit >fixnum abs absq
|
||||
bitnot ceiling conjugate
|
||||
denominator double>bits float>bits floor imaginary
|
||||
neg next-power-of-2 numerator quadrant
|
||||
real sgn sq truncate
|
||||
} ;
|
||||
|
||||
: ratio>ratio
|
||||
{
|
||||
1+ 1- >digit abs absq conjugate neg real sq
|
||||
} ;
|
||||
|
||||
: float>float
|
||||
{
|
||||
1+ 1- >digit abs absq arg
|
||||
conjugate cos cosec cosech
|
||||
cosh cot coth exp neg real sec
|
||||
sech sin sinh sq tan tanh
|
||||
} ;
|
||||
|
||||
: complex>complex
|
||||
{
|
||||
1+ 1- abs absq arg
|
||||
conjugate cosec cosech
|
||||
cosh cot coth exp
|
||||
log neg quadrant
|
||||
sech sin sinh sq sqrt tanh
|
||||
} ;
|
||||
|
||||
|
||||
|
||||
|
||||
: math-2 ( -- seq )
|
||||
{ * + - /f max min polar> bitand bitor bitxor align shift } ;
|
||||
: math-throw-2 ( -- seq ) { / /i ^ mod rem } ;
|
||||
|
||||
! shift too but can't test with bignums..
|
||||
: 2integer>x ( n n -- x ) ( -- word )
|
||||
{ * + - /f max min polar> bitand bitor bitxor align } ;
|
||||
: 2ratio>x ( r r -- x ) ( -- word ) { * + - /f max min polar> } ;
|
||||
: 2float>x ( f f -- x ) ( -- word ) { * + - /f max min polar> } ;
|
||||
: 2complex>x ( c c -- x ) ( -- word ) { * + - /f } ;
|
||||
|
||||
: 2integer>integer ( n n -- n ) ( -- word )
|
||||
{ * + - /f max min polar> bitand bitor bitxor align } ;
|
||||
: 2ratio>ratio ( r r -- r ) ( -- word ) { * + - /f max min } ;
|
||||
: 2float>float ( f f -- f ) ( -- word ) { * + - /f max min polar> } ;
|
||||
: 2complex>complex ( c c -- c ) ( -- word ) { * + - /f } ;
|
||||
|
||||
|
||||
|
||||
|
||||
: random-integer-quotation ( -- quot )
|
||||
[
|
||||
random-integer ,
|
||||
max-length random-int
|
||||
[
|
||||
[
|
||||
[ integer>integer nth-rand , ]
|
||||
[ random-integer , 2integer>integer nth-rand , ]
|
||||
] do-one
|
||||
] times
|
||||
] [ ] make ;
|
||||
|
||||
: random-ratio-quotation ( -- quot )
|
||||
[
|
||||
random-ratio ,
|
||||
max-length random-int
|
||||
[
|
||||
[
|
||||
[ ratio>ratio nth-rand , ]
|
||||
[ random-ratio , 2ratio>ratio nth-rand , ]
|
||||
] do-one
|
||||
] times
|
||||
] [ ] make ;
|
||||
|
||||
: random-float-quotation ( -- quot )
|
||||
[
|
||||
random-float ,
|
||||
max-length random-int
|
||||
[
|
||||
[
|
||||
[ float>float nth-rand , ]
|
||||
[ random-float , 2float>float nth-rand , ]
|
||||
] do-one
|
||||
] times
|
||||
] [ ] make ;
|
||||
|
||||
: random-complex-quotation ( -- quot )
|
||||
[
|
||||
random-complex ,
|
||||
max-length random-int
|
||||
[
|
||||
[
|
||||
[ complex>complex nth-rand , ]
|
||||
[ random-complex , 2complex>complex nth-rand , ]
|
||||
] do-one
|
||||
] times
|
||||
] [ ] make ;
|
||||
|
||||
|
||||
: interp-compile-check ( quot -- )
|
||||
dup . [ call ] keep compile-1
|
||||
2dup swap unparse write " " write unparse print
|
||||
= [ "problem in math" throw ] unless ;
|
||||
|
||||
! 1-arg tests
|
||||
: test-integer>x ( -- )
|
||||
random-integer integer>x nth-rand f cons cons interp-compile-check ;
|
||||
|
||||
: test-ratio>x ( -- )
|
||||
random-ratio ratio>x nth-rand f cons cons interp-compile-check ;
|
||||
|
||||
: test-float>x ( -- )
|
||||
random-float float>x nth-rand f cons cons interp-compile-check ;
|
||||
|
||||
: test-complex>x ( -- )
|
||||
random-complex complex>x nth-rand f cons cons interp-compile-check ;
|
||||
|
||||
|
||||
! 2-arg tests
|
||||
: test-2integer>x ( -- )
|
||||
random-integer random-integer 2integer>x nth-rand f cons cons cons interp-compile-check ;
|
||||
|
||||
: test-2ratio>x ( -- )
|
||||
random-ratio random-ratio 2ratio>x nth-rand f cons cons cons interp-compile-check ;
|
||||
|
||||
: test-2float>x ( -- )
|
||||
random-float random-float 2float>x nth-rand f cons cons cons interp-compile-check ;
|
||||
|
||||
: test-2complex>x ( -- )
|
||||
random-complex random-complex 2complex>x nth-rand f cons cons cons interp-compile-check ;
|
||||
|
||||
|
||||
: test-2random>x ( -- )
|
||||
random-number random-number math-2 nth-rand f cons cons cons interp-compile-check ;
|
||||
|
||||
|
||||
! quotation tests
|
||||
: test-integer random-integer-quotation interp-compile-check ;
|
||||
: test-ratio random-ratio-quotation interp-compile-check ;
|
||||
: test-float random-float-quotation interp-compile-check ;
|
||||
: test-complex random-complex-quotation interp-compile-check ;
|
||||
|
||||
: test-math {
|
||||
[ test-integer ]
|
||||
[ test-ratio ]
|
||||
[ test-float ]
|
||||
[ test-complex ]
|
||||
} do-one ;
|
||||
|
||||
: if-quot ( -- )
|
||||
max-length [
|
||||
] times ;
|
||||
|
||||
|
||||
! : test-if
|
||||
! nested-if-quot compile-check-output ;
|
||||
|
||||
|
||||
: stack-identity-0
|
||||
H{
|
||||
{ 1 drop }
|
||||
{ 1000000000000000000000000001 drop }
|
||||
{ -11111111111111111111111111 drop }
|
||||
{ -1 drop }
|
||||
{ 1.203 drop }
|
||||
{ -1.203 drop }
|
||||
{ "asdf" drop }
|
||||
} ; inline
|
||||
: stack-identity-1
|
||||
H{
|
||||
{ dup drop }
|
||||
{ >r r> }
|
||||
} ; inline
|
||||
: stack-identity-2
|
||||
H{
|
||||
{ swap swap }
|
||||
{ over drop }
|
||||
{ dupd nip }
|
||||
{ 2dup 2drop }
|
||||
} ; inline
|
||||
: stack-identity-3
|
||||
H{
|
||||
{ rot -rot }
|
||||
{ pick drop }
|
||||
{ 3dup 3drop }
|
||||
} ; inline
|
||||
: stack-identity-4
|
||||
H{
|
||||
{ 2swap 2swap }
|
||||
} ; inline
|
||||
|
||||
: get-stack-identity-table ( n -- hash )
|
||||
{
|
||||
{ [ dup 0 = ] [ drop stack-identity-0 ] }
|
||||
{ [ dup 1 = ] [ drop stack-identity-1 ] }
|
||||
{ [ dup 2 = ] [ drop stack-identity-2 ] }
|
||||
{ [ dup 3 = ] [ drop stack-identity-3 ] }
|
||||
{ [ dup 4 = ] [ drop stack-identity-4 ] }
|
||||
{ [ t ] [ drop f ] }
|
||||
} cond ;
|
||||
|
||||
: get-stack-identity-table<= ( n -- hash )
|
||||
1+ random-int get-stack-identity-table ;
|
||||
|
||||
|
||||
: random-stack-identity ( n -- quot )
|
||||
#! n is number of items on stack
|
||||
[
|
||||
max-length random-int
|
||||
[ dup get-stack-identity-table<= random-hash-entry swap , , ] times
|
||||
drop
|
||||
] [ ] make ;
|
||||
|
||||
|
||||
: stack-identity ; ! dummy
|
||||
|
||||
: define-random-stack-identity ( n -- )
|
||||
random-stack-identity \ stack-identity dup reset-generic swap
|
||||
define-compound \ stack-identity compile ;
|
||||
|
||||
: test-random-stack-identity ( -- )
|
||||
4 define-random-stack-identity
|
||||
1 2 3 4 stack-identity 4array { 1 2 3 4 } =
|
||||
[ \ stack-identity see "bad stack-identity!" throw ] unless ;
|
||||
|
||||
: (test-random-seq-iterate) ( seq -- )
|
||||
[ [ 2 3 4 stack-identity 3drop ] keep = [ "not equal" throw ] unless ] each ;
|
||||
|
||||
: test-random-seq-iterate ( -- )
|
||||
4 define-random-stack-identity
|
||||
! \ stack-identity see
|
||||
random-seq
|
||||
! dup .
|
||||
(test-random-seq-iterate) ;
|
||||
|
||||
|
||||
: random-test
|
||||
{ test-random-stack-identity test-random-seq-iterate test-math }
|
||||
nth-rand execute ;
|
||||
|
||||
: random-test-loop ( n -- )
|
||||
[ random-test ] times ;
|
||||
|
||||
: watch-simplifier
|
||||
[
|
||||
dup word-def dataflow optimize
|
||||
linearize [ split-blocks simplify . ] hash-each
|
||||
] with-compiler ;
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
USING: kernel math sequences namespaces errors hashtables words arrays parser
|
||||
compiler syntax lists io ;
|
||||
USING: optimizer compiler-frontend compiler-backend inference
|
||||
inspector prettyprint ;
|
||||
IN: random-tester
|
||||
|
||||
! SEQUENCES
|
||||
: nth-rand ( seq -- elem ) [ length random-int ] keep nth ;
|
||||
|
||||
! HASHTABLES
|
||||
: random-hash-entry ( hash -- key value ) hash>alist nth-rand first2 ;
|
||||
|
||||
! ARRAYS
|
||||
: 4array ( a b c d -- seq ) 2array >r 2array r> append ;
|
||||
|
||||
: coin-flip ( -- bool ) 2 random-int 1 = ;
|
||||
|
||||
! UNCOMPILABLES
|
||||
: do-one ( seq -- ) nth-rand call ;
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue