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

Minor random tester cleanup

release
Daniel Ehrenberg 2007-12-09 01:35:26 -05:00
parent 4a29e2e707
commit c8e63057a0
2 changed files with 10 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
extra/random-tester/random/random.factor
View File

@ -1,22 +1,12 @@
USING: kernel math sequences namespaces errors hashtables words
arrays parser compiler syntax io tools prettyprint optimizer
inference ;
USING: kernel math sequences namespaces hashtables words math.functions
arrays parser compiler syntax io random prettyprint optimizer layouts
inference math.constants random-tester.utils ;
IN: random-tester
! Tweak me
: max-length 15 ; inline
: max-value 1000000000 ; inline
: 10% ( -- bool ) 10 random 8 > ;
: 20% ( -- bool ) 10 random 7 > ;
: 30% ( -- bool ) 10 random 6 > ;
: 40% ( -- bool ) 10 random 5 > ;
: 50% ( -- bool ) 10 random 4 > ;
: 60% ( -- bool ) 10 random 3 > ;
: 70% ( -- bool ) 10 random 2 > ;
: 80% ( -- bool ) 10 random 1 > ;
: 90% ( -- bool ) 10 random 0 > ;
! varying bit-length random number
: random-bits ( n -- int )
random 2 swap ^ random ;
@ -28,23 +18,20 @@ IN: random-tester
: random-string
[ max-length random [ max-value random , ] times ] "" make ;
SYMBOL: special-integers
: special-integers ( -- seq ) \ special-integers get ;
[ { -1 0 1 } % most-negative-fixnum , most-positive-fixnum , first-bignum , ]
{ } make \ special-integers set-global
: special-integers ( -- seq ) \ special-integers get ;
SYMBOL: special-floats
: special-floats ( -- seq ) \ special-floats get ;
[ { 0.0 -0.0 } % e , pi , 1./0. , -1./0. , 0./0. , epsilon , epsilon neg , ]
{ } make \ special-floats set-global
: special-floats ( -- seq ) \ special-floats get ;
SYMBOL: special-complexes
: special-complexes ( -- seq ) \ special-complexes get ;
[
{ -1 0 1 i -i } %
{ -1 0 1 } % -1 sqrt dup , neg ,
e , e neg , pi , pi neg ,
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-global
: special-complexes ( -- seq ) \ special-complexes get ;
: random-fixnum ( -- fixnum )
most-positive-fixnum random 1+ coin-flip [ neg 1- ] when >fixnum ;

67
extra/random-tester/utils/utils.factor
View File

@ -1,7 +1,6 @@
USING: arrays assocs combinators.lib continuations kernel
math math.functions namespaces quotations random sequences
sequences.private shuffle ;
IN: random-tester.utils
: %chance ( n -- ? )
@ -17,7 +16,7 @@ IN: random-tester.utils
: 80% ( -- ? ) 80 %chance ;
: 90% ( -- ? ) 90 %chance ;
: call-if ( quot ? -- ) [ call ] [ drop ] if ; inline
: call-if ( quot ? -- ) swap when ; inline
: with-10% ( quot -- ) 10% call-if ; inline
: with-20% ( quot -- ) 20% call-if ; inline
@ -29,67 +28,7 @@ IN: random-tester.utils
: with-80% ( quot -- ) 80% call-if ; inline
: with-90% ( quot -- ) 90% call-if ; inline
: random-hash-key keys random ;
: random-hash-value [ random-hash-key ] keep at ;
: random-key keys random ;
: random-value [ random-key ] keep at ;
: do-one ( seq -- ) random call ; inline
TUPLE: p-list seq max count count-vec ;
: reset-array ( seq -- )
[ drop 0 ] over map-into ;
C: <p-list> p-list
: make-p-list ( seq n -- tuple )
>r dup length [ 1- ] keep r>
[ ^ 0 swap 2array ] keep
0 <array> <p-list> ;
: inc-seq ( seq max -- )
2dup [ < ] curry find-last over [
nipd 1+ 2over swap set-nth
1+ over length rot <slice> reset-array
] [
3drop reset-array
] if ;
: inc-count ( tuple -- )
[ p-list-count first2 >r 1+ r> 2array ] keep
set-p-list-count ;
: (get-permutation) ( seq index-seq -- newseq )
[ swap nth ] map-with ;
: get-permutation ( tuple -- seq )
[ p-list-seq ] keep p-list-count-vec (get-permutation) ;
: p-list-next ( tuple -- seq/f )
dup p-list-count first2 < [
[
[ get-permutation ] keep
[ p-list-count-vec ] keep p-list-max
inc-seq
] keep inc-count
] [
drop f
] if ;
: (permutations) ( tuple -- )
dup p-list-next [ , (permutations) ] [ drop ] if* ;
: permutations ( seq n -- seq )
make-p-list [ (permutations) ] { } make ;
: (each-permutation) ( tuple quot -- )
over p-list-next [
[ rot drop swap call ] 3keep
drop (each-permutation)
] [
2drop
] if* ; inline
: each-permutation ( seq n quot -- )
>r make-p-list r> (each-permutation) ;