Port random-tester
Doug Coleman
parent
61aaa4f0de
commit
529fa92590
|
|
@ -0,0 +1,11 @@
|
|||
USING: kernel math.constants ;
|
||||
IN: random-tester.databank
|
||||
|
||||
: databank ( -- array )
|
||||
{
|
||||
! V{ } H{ } V{ 3 } { 3 } { } "" "asdf"
|
||||
pi 1/0. -1/0. 0/0. [ ]
|
||||
f t "" 0 0.0 3.14 2 -3 -7 20 3/4 -3/4 1.2/3 3.5
|
||||
C{ 2 2 } C{ 1/0. 1/0. }
|
||||
} ;
|
||||
|
||||
|
|
@ -0,0 +1,45 @@
|
|||
USING: compiler continuations io kernel math namespaces
|
||||
prettyprint quotations random sequences vectors ;
|
||||
USING: random-tester.databank random-tester.safe-words ;
|
||||
IN: random-tester
|
||||
|
||||
SYMBOL: errored
|
||||
SYMBOL: before
|
||||
SYMBOL: after
|
||||
SYMBOL: quot
|
||||
TUPLE: random-tester-error ;
|
||||
|
||||
: setup-test ( #data #code -- data... quot )
|
||||
#! Variable stack effect
|
||||
>r [ databank random ] times r>
|
||||
[ drop \ safe-words get random ] map >quotation ;
|
||||
|
||||
: test-compiler ! ( data... quot -- ... )
|
||||
errored off
|
||||
dup quot set
|
||||
datastack clone >vector dup pop* before set
|
||||
[ call ] catch drop
|
||||
datastack clone after set
|
||||
clear
|
||||
before get [ ] each
|
||||
quot get [ compile-1 ] [ errored on ] recover ;
|
||||
|
||||
: do-test ! ( data... quot -- )
|
||||
.s flush test-compiler
|
||||
errored get [
|
||||
datastack after get 2dup = [
|
||||
2drop
|
||||
] [
|
||||
[ . ] each
|
||||
"--" print
|
||||
[ . ] each
|
||||
quot get .
|
||||
random-tester-error construct-empty throw
|
||||
] if
|
||||
] unless clear ;
|
||||
|
||||
: random-test1 ( #data #code -- )
|
||||
setup-test do-test ;
|
||||
|
||||
: random-test2 ( -- )
|
||||
3 2 setup-test do-test ;
|
||||
|
|
@ -0,0 +1,87 @@
|
|||
USING: kernel math sequences namespaces errors hashtables words
|
||||
arrays parser compiler syntax io tools prettyprint optimizer
|
||||
inference ;
|
||||
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 ;
|
||||
|
||||
: random-seq ( -- seq )
|
||||
{ [ ] { } V{ } "" } random
|
||||
[ max-length random [ max-value random , ] times ] swap make ;
|
||||
|
||||
: random-string
|
||||
[ max-length random [ max-value random , ] times ] "" make ;
|
||||
|
||||
SYMBOL: special-integers
|
||||
[ { -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
|
||||
[ { 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
|
||||
[
|
||||
{ -1 0 1 i -i } %
|
||||
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 ;
|
||||
|
||||
: random-bignum ( -- bignum )
|
||||
400 random-bits first-bignum + coin-flip [ neg ] when ;
|
||||
|
||||
: random-integer ( -- n )
|
||||
coin-flip [
|
||||
random-fixnum
|
||||
] [
|
||||
coin-flip [ random-bignum ] [ special-integers random ] if
|
||||
] if ;
|
||||
|
||||
: random-positive-integer ( -- int )
|
||||
random-integer dup 0 < [
|
||||
neg
|
||||
] [
|
||||
dup 0 = [ 1 + ] when
|
||||
] if ;
|
||||
|
||||
: random-ratio ( -- ratio )
|
||||
1000000000 dup [ random ] 2apply 1+ / coin-flip [ neg ] when dup [ drop random-ratio ] unless 10% [ drop 0 ] when ;
|
||||
|
||||
: random-float ( -- float )
|
||||
coin-flip [ random-ratio ] [ special-floats random ] 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> ;
|
||||
|
||||
|
|
@ -0,0 +1,117 @@
|
|||
USING: kernel namespaces sequences sorting vocabs ;
|
||||
USING: arrays assocs generic hashtables math math.intervals math.parser math.functions refs shuffle vectors words ;
|
||||
IN: random-tester.safe-words
|
||||
|
||||
: ?-words
|
||||
{
|
||||
delegate
|
||||
|
||||
/f
|
||||
|
||||
bits>float bits>double
|
||||
float>bits double>bits
|
||||
|
||||
>bignum >boolean >fixnum >float
|
||||
|
||||
array? integer? complex? value-ref? ref? key-ref?
|
||||
interval? number?
|
||||
wrapper? tuple?
|
||||
[-1,1]? between? bignum? both? either? eq? equal? even? fixnum? float? fp-nan? hashtable? interval-contains? interval-subset? interval? key-ref? key? number? odd? pair? power-of-2? ratio? rational? real? subassoc? valid-digits? zero? assoc? curry? vector? callstack? ! clear 3.14 [ <vector> assoc? ] compile-1
|
||||
2^ not
|
||||
! arrays
|
||||
resize-array <array>
|
||||
! assocs
|
||||
(assoc-stack)
|
||||
new-assoc
|
||||
assoc-like
|
||||
<hashtable>
|
||||
all-integers? (all-integers?) ! hangs?
|
||||
assoc-push-if
|
||||
|
||||
(clone) assoc-clone-like ! SYMBOL: foo foo dup (clone) =
|
||||
} ;
|
||||
|
||||
: bignum-words
|
||||
{
|
||||
next-power-of-2 (next-power-of-2)
|
||||
times
|
||||
hashcode hashcode*
|
||||
} ;
|
||||
|
||||
: initialization-words
|
||||
{
|
||||
init-namespaces
|
||||
} ;
|
||||
|
||||
: stack-words
|
||||
{
|
||||
dup
|
||||
drop 2drop 3drop
|
||||
roll -roll 2swap
|
||||
|
||||
>r r>
|
||||
} ;
|
||||
|
||||
: method-words
|
||||
{
|
||||
method-def
|
||||
forget-word
|
||||
} ;
|
||||
|
||||
: stateful-words
|
||||
{
|
||||
counter
|
||||
gensym
|
||||
} ;
|
||||
|
||||
: foo-words
|
||||
{
|
||||
set-retainstack
|
||||
retainstack callstack
|
||||
datastack
|
||||
callstack>array
|
||||
} ;
|
||||
|
||||
: exit-words
|
||||
{
|
||||
call-clear die
|
||||
} ;
|
||||
|
||||
: bad-words ( -- array )
|
||||
[
|
||||
?-words %
|
||||
bignum-words %
|
||||
initialization-words %
|
||||
stack-words %
|
||||
method-words %
|
||||
stateful-words %
|
||||
exit-words %
|
||||
foo-words %
|
||||
] { } make ;
|
||||
|
||||
: safe-words ( -- array )
|
||||
bad-words {
|
||||
"alists" "arrays" "assocs" ! "bit-arrays" "byte-arrays"
|
||||
! "classes" "combinators" "compiler" "continuations"
|
||||
! "core-foundation" "definitions" "documents"
|
||||
! "float-arrays" "generic" "graphs" "growable"
|
||||
"hashtables" ! io.*
|
||||
"kernel" "math"
|
||||
"math.bitfields" "math.complex" "math.constants" "math.floats"
|
||||
"math.functions" "math.integers" "math.intervals" "math.libm"
|
||||
"math.parser" "math.ratios" "math.vectors"
|
||||
! "namespaces" "quotations" "sbufs"
|
||||
! "queues" "strings" "sequences"
|
||||
"vectors"
|
||||
! "words"
|
||||
} [ words ] map concat seq-diff natural-sort ;
|
||||
|
||||
safe-words \ safe-words set-global
|
||||
|
||||
! foo dup (clone) = .
|
||||
! foo dup clone = .
|
||||
! f [ byte-array>bignum assoc-clone-like ] compile-1
|
||||
! 2 3.14 [ construct-empty number= ] compile-1
|
||||
! 3.14 [ <vector> assoc? ] compile-1
|
||||
! -3 [ ] 2 [ byte-array>bignum denominator ] compile-1
|
||||
|
||||
|
|
@ -0,0 +1,95 @@
|
|||
USING: arrays assocs combinators.lib continuations kernel
|
||||
math math.functions namespaces quotations random sequences
|
||||
sequences.private shuffle ;
|
||||
|
||||
IN: random-tester.utils
|
||||
|
||||
: %chance ( n -- ? )
|
||||
100 random > ;
|
||||
|
||||
: 10% ( -- ? ) 10 %chance ;
|
||||
: 20% ( -- ? ) 20 %chance ;
|
||||
: 30% ( -- ? ) 30 %chance ;
|
||||
: 40% ( -- ? ) 40 %chance ;
|
||||
: 50% ( -- ? ) 50 %chance ;
|
||||
: 60% ( -- ? ) 60 %chance ;
|
||||
: 70% ( -- ? ) 70 %chance ;
|
||||
: 80% ( -- ? ) 80 %chance ;
|
||||
: 90% ( -- ? ) 90 %chance ;
|
||||
|
||||
: call-if ( quot ? -- ) [ call ] [ drop ] if ; inline
|
||||
|
||||
: with-10% ( quot -- ) 10% call-if ; inline
|
||||
: with-20% ( quot -- ) 20% call-if ; inline
|
||||
: with-30% ( quot -- ) 30% call-if ; inline
|
||||
: with-40% ( quot -- ) 40% call-if ; inline
|
||||
: with-50% ( quot -- ) 50% call-if ; inline
|
||||
: with-60% ( quot -- ) 60% call-if ; inline
|
||||
: with-70% ( quot -- ) 70% call-if ; inline
|
||||
: 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 ;
|
||||
|
||||
: 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) ;
|
||||
|
||||
|
||||
Loading…
Reference in New Issue