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