Merge git://spitspat.com/git/factor
Doug Coleman
commit
c078621369
|
|
@ -58,3 +58,5 @@ IN: temporary
|
|||
[ dup array? ] [ dup vector? ] [ dup float? ]
|
||||
} || nip
|
||||
] unit-test
|
||||
|
||||
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test
|
||||
|
|
|
|||
|
|
@ -67,6 +67,12 @@ MACRO: napply ( n -- )
|
|||
|
||||
: map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
|
||||
|
||||
MACRO: nfirst ( n -- )
|
||||
[ [ swap nth ] curry [ keep ] curry ] map concat [ drop ] compose ;
|
||||
|
||||
: seq>stack ( seq -- )
|
||||
dup length nfirst ; inline
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: sigma ( seq quot -- n ) [ rot slip + ] curry 0 swap reduce ;
|
||||
|
|
|
|||
|
|
@ -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
unmaintained/random-tester/random.factor → extra/random-tester/random/random.factor
Normal file → Executable file
0
unmaintained/random-tester/random.factor → extra/random-tester/random/random.factor
Normal file → Executable file
|
|
@ -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) ;
|
||||
|
||||
|
||||
|
|
@ -250,7 +250,7 @@ update() {
|
|||
}
|
||||
|
||||
install_libraries() {
|
||||
sudo apt-get install libc6-dev libfreetype6-dev wget git-core git-doc libx11-dev glutg3-dev
|
||||
sudo apt-get install libc6-dev libfreetype6-dev wget git-core git-doc libx11-dev glutg3-dev rlwrap
|
||||
}
|
||||
|
||||
case "$1" in
|
||||
|
|
|
|||
|
|
@ -1,9 +0,0 @@
|
|||
REQUIRES: libs/lazy-lists libs/null-stream libs/shuffle ;
|
||||
PROVIDE: apps/random-tester
|
||||
{ +files+ {
|
||||
"utils.factor"
|
||||
"random.factor"
|
||||
"random-tester.factor"
|
||||
"random-tester2.factor"
|
||||
"type.factor"
|
||||
} } ;
|
||||
|
|
@ -1,301 +0,0 @@
|
|||
USING: kernel math math-internals memory sequences namespaces errors
|
||||
assocs words arrays parser compiler syntax io
|
||||
quotations tools prettyprint optimizer inference ;
|
||||
IN: random-tester
|
||||
|
||||
! n-foo>bar -- list of words of type 'foo' that take n parameters
|
||||
! and output a 'bar'
|
||||
|
||||
|
||||
! Math vocabulary words
|
||||
: 1-x>y
|
||||
{
|
||||
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 numerator real sec ! next-power-of-2
|
||||
sech sgn sin sinh sq sqrt tan tanh truncate
|
||||
} ;
|
||||
|
||||
: 1-x>y-throws
|
||||
{
|
||||
recip log2
|
||||
asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh
|
||||
} ;
|
||||
|
||||
: 2-x>y ( -- seq ) { * + - /f max min polar> bitand bitor bitxor align } ;
|
||||
: 2-x>y-throws ( -- seq ) { / /i mod rem } ;
|
||||
|
||||
: 1-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 exp floor imaginary
|
||||
log neg next-power-of-2 numerator real sec
|
||||
sech sgn sin sinh sq sqrt tan tanh truncate
|
||||
} ;
|
||||
|
||||
: 1-ratio>x
|
||||
{
|
||||
1+ 1- >bignum >digit >fixnum abs absq arg ceiling
|
||||
cis conjugate cos cosec cosech
|
||||
cosh cot coth exp floor imaginary
|
||||
log neg next-power-of-2 real sec
|
||||
sech sgn sin sinh sq sqrt tan tanh truncate
|
||||
} ;
|
||||
|
||||
: 1-float>x ( -- seq )
|
||||
{
|
||||
1+ 1- >bignum >digit >fixnum abs absq arg
|
||||
ceiling cis conjugate cos cosec cosech
|
||||
cosh cot coth double>bits exp float>bits floor imaginary
|
||||
log neg real sec ! next-power-of-2
|
||||
sech sgn sin sinh sq sqrt tan tanh truncate
|
||||
} ;
|
||||
|
||||
: 1-complex>x
|
||||
{
|
||||
1+ 1- abs absq arg conjugate cos cosec cosech
|
||||
cosh cot coth exp imaginary log neg real
|
||||
sec sech sin sinh sq sqrt tan tanh
|
||||
} ;
|
||||
|
||||
: 1-integer>x-throws
|
||||
{
|
||||
recip log2
|
||||
asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh
|
||||
} ;
|
||||
|
||||
: 1-ratio>x-throws
|
||||
{
|
||||
recip
|
||||
asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh
|
||||
} ;
|
||||
|
||||
: 1-integer>integer
|
||||
{
|
||||
1+ 1- >bignum >digit >fixnum abs absq bitnot ceiling conjugate
|
||||
denominator floor imaginary
|
||||
neg next-power-of-2 numerator real sgn sq truncate
|
||||
} ;
|
||||
|
||||
: 1-ratio>ratio
|
||||
{ 1+ 1- >digit abs absq conjugate neg real sq } ;
|
||||
|
||||
: 1-float>float
|
||||
{
|
||||
1+ 1- >digit abs absq arg ceiling
|
||||
conjugate exp floor neg real sq truncate
|
||||
} ;
|
||||
|
||||
: 1-complex>complex
|
||||
{
|
||||
1+ 1- abs absq arg conjugate cosec cosech cosh cot coth exp log
|
||||
neg sech sin sinh sq sqrt tanh
|
||||
} ;
|
||||
|
||||
: 2-integer>x { * + - /f max min polar> bitand bitor bitxor align } ;
|
||||
: 2-ratio>x { * + - /f max min polar> } ;
|
||||
: 2-float>x { float+ float- float* float/f + - * /f max min polar> } ;
|
||||
: 2-complex>x { * + - /f } ;
|
||||
|
||||
: 2-integer>integer { * + - max min bitand bitor bitxor align } ;
|
||||
: 2-ratio>ratio { * + - max min } ;
|
||||
: 2-float>float { float* float+ float- float/f max min /f + - } ;
|
||||
: 2-complex>complex { * + - /f } ;
|
||||
|
||||
|
||||
SYMBOL: last-quot
|
||||
SYMBOL: first-arg
|
||||
SYMBOL: second-arg
|
||||
: 0-runtime-check ( quot -- )
|
||||
#! Checks the runtime only, not the compiler
|
||||
#! Evaluates the quotation twice and makes sure the results agree
|
||||
[ last-quot set ] keep
|
||||
[ call ] keep
|
||||
call
|
||||
! 2dup swap unparse write " " write unparse print flush
|
||||
= [ last-quot get . "problem in runtime" throw ] unless ;
|
||||
|
||||
: 1-runtime-check ( quot -- )
|
||||
#! Checks the runtime only, not the compiler
|
||||
#! Evaluates the quotation twice and makes sure the results agree
|
||||
#! For quotations that are given one argument
|
||||
[ last-quot set first-arg set ] 2keep
|
||||
[ call ] 2keep
|
||||
call
|
||||
2dup swap unparse write " " write unparse print flush
|
||||
= [ "problem in runtime" throw ] unless ;
|
||||
|
||||
: 1-interpreted-vs-compiled-check ( x quot -- )
|
||||
#! Checks the runtime output vs the compiler output
|
||||
#! quot: ( x -- y )
|
||||
2dup swap unparse write " " write . flush
|
||||
[ last-quot set first-arg set ] 2keep
|
||||
[ call ] 2keep compile-1
|
||||
2dup swap unparse write " " write unparse print flush
|
||||
= [ "problem in math1" throw ] unless ;
|
||||
|
||||
: 2-interpreted-vs-compiled-check ( x y quot -- )
|
||||
#! Checks the runtime output vs the compiler output
|
||||
#! quot: ( x y -- z )
|
||||
.s flush
|
||||
[ last-quot set first-arg set second-arg set ] 3keep
|
||||
[ call ] 3keep compile-1
|
||||
2dup swap unparse write " " write unparse print flush
|
||||
= [ "problem in math2" throw ] unless ;
|
||||
|
||||
: 0-interpreted-vs-compiled-check-catch ( quot -- )
|
||||
#! Check the runtime output vs the compiler output for words that throw
|
||||
#!
|
||||
dup .
|
||||
[ last-quot set ] keep
|
||||
[ catch [ "caught: " write dup print-error ] when* ] keep
|
||||
[ compile-1 ] catch [ nip "caught: " write dup print-error ] when*
|
||||
= [ "problem in math3" throw ] unless ;
|
||||
|
||||
: 1-interpreted-vs-compiled-check-catch ( quot -- )
|
||||
#! Check the runtime output vs the compiler output for words that throw
|
||||
2dup swap unparse write " " write .
|
||||
! "." write
|
||||
[ last-quot set first-arg set ] 2keep
|
||||
[ catch [ nip "caught: " write dup print-error ] when* ] 2keep
|
||||
[ compile-1 ] catch [ 2nip "caught: " write dup print-error ] when*
|
||||
= [ "problem in math4" throw ] unless ;
|
||||
|
||||
: 2-interpreted-vs-compiled-check-catch ( quot -- )
|
||||
#! Check the runtime output vs the compiler output for words that throw
|
||||
! 3dup rot unparse write " " write swap unparse write " " write .
|
||||
"." write
|
||||
[ last-quot set first-arg set second-arg set ] 3keep
|
||||
[ catch [ 2nip "caught: " write dup print-error ] when* ] 3keep
|
||||
[ compile-1 ] catch [ 2nip nip "caught: " write dup print-error ] when*
|
||||
= [ "problem in math5" throw ] unless ;
|
||||
|
||||
|
||||
! RANDOM QUOTATIONS TO TEST
|
||||
: random-1-integer>x-quot ( -- quot ) 1-integer>x random 1quotation ;
|
||||
: random-1-ratio>x-quot ( -- quot ) 1-ratio>x random 1quotation ;
|
||||
: random-1-float>x-quot ( -- quot ) 1-float>x random 1quotation ;
|
||||
: random-1-complex>x-quot ( -- quot ) 1-complex>x random 1quotation ;
|
||||
|
||||
: test-1-integer>x ( -- )
|
||||
random-integer random-1-integer>x-quot 1-interpreted-vs-compiled-check ;
|
||||
: test-1-ratio>x ( -- )
|
||||
random-ratio random-1-ratio>x-quot 1-interpreted-vs-compiled-check ;
|
||||
: test-1-float>x ( -- )
|
||||
random-float random-1-float>x-quot 1-interpreted-vs-compiled-check ;
|
||||
: test-1-complex>x ( -- )
|
||||
random-complex random-1-complex>x-quot 1-interpreted-vs-compiled-check ;
|
||||
|
||||
|
||||
: random-1-float>float-quot ( -- obj ) 1-float>float random 1quotation ;
|
||||
: random-2-float>float-quot ( -- obj ) 2-float>float random 1quotation ;
|
||||
: nrandom-2-float>float-quot ( -- obj )
|
||||
[
|
||||
5
|
||||
[
|
||||
{
|
||||
[ 2-float>float random , random-float , ]
|
||||
[ 1-float>float random , ]
|
||||
} do-one
|
||||
] times
|
||||
2-float>float random ,
|
||||
] [ ] make ;
|
||||
|
||||
: test-1-float>float ( -- )
|
||||
random-float random-1-float>float-quot 1-interpreted-vs-compiled-check ;
|
||||
: test-2-float>float ( -- )
|
||||
random-float random-float random-2-float>float-quot
|
||||
2-interpreted-vs-compiled-check ;
|
||||
|
||||
: test-n-2-float>float ( -- )
|
||||
random-float random-float nrandom-2-float>float-quot
|
||||
2-interpreted-vs-compiled-check ;
|
||||
|
||||
: test-1-integer>x-runtime ( -- )
|
||||
random-integer random-1-integer>x-quot 1-runtime-check ;
|
||||
|
||||
: random-1-integer>x-throws-quot ( -- obj ) 1-integer>x-throws random 1quotation ;
|
||||
: random-1-ratio>x-throws-quot ( -- obj ) 1-ratio>x-throws random 1quotation ;
|
||||
: test-1-integer>x-throws ( -- obj )
|
||||
random-integer random-1-integer>x-throws-quot
|
||||
1-interpreted-vs-compiled-check-catch ;
|
||||
: test-1-ratio>x-throws ( -- obj )
|
||||
random-ratio random-1-ratio>x-throws-quot
|
||||
1-interpreted-vs-compiled-check-catch ;
|
||||
|
||||
|
||||
|
||||
: test-2-integer>x-throws ( -- )
|
||||
[
|
||||
random-integer , random-integer ,
|
||||
2-x>y-throws random ,
|
||||
] [ ] make 2-interpreted-vs-compiled-check-catch ;
|
||||
|
||||
! : test-^-ratio ( -- )
|
||||
! [
|
||||
! random-ratio , random-ratio , \ ^ ,
|
||||
! ] [ ] make interp-compile-check-catch ;
|
||||
|
||||
: test-0-float?-when
|
||||
[
|
||||
random-number , \ dup , \ float? , 1-float>x random 1quotation , \ when ,
|
||||
] [ ] make 0-runtime-check ;
|
||||
|
||||
: test-1-integer?-when
|
||||
random-integer [
|
||||
\ dup , \ integer? , 1-integer>x random 1quotation , \ when ,
|
||||
] [ ] make 1-interpreted-vs-compiled-check ;
|
||||
|
||||
: test-1-ratio?-when
|
||||
random-ratio [
|
||||
\ dup , \ ratio? , 1-ratio>x random 1quotation , \ when ,
|
||||
] [ ] make 1-interpreted-vs-compiled-check ;
|
||||
|
||||
: test-1-float?-when
|
||||
random-float [
|
||||
\ dup , \ float? , 1-float>x random 1quotation , \ when ,
|
||||
] [ ] make 1-interpreted-vs-compiled-check ;
|
||||
|
||||
: test-1-complex?-when
|
||||
random-complex [
|
||||
\ dup , \ complex? , 1-complex>x random 1quotation , \ when ,
|
||||
] [ ] make 1-interpreted-vs-compiled-check ;
|
||||
|
||||
|
||||
: many-word-test ( -- )
|
||||
#! defines words a1000 down to a0, which does a trivial addition
|
||||
"random-tester-scratchpad" vocabularies get delete-at
|
||||
"random-tester-scratchpad" set-in
|
||||
"a0" "random-tester-scratchpad" create [ 1 1 + ] define-compound
|
||||
100 [
|
||||
[ 1+ "a" swap unparse append "random-tester-scratchpad" create ] keep
|
||||
"a" swap unparse append [ parse ] catch [ :1 ] when define-compound
|
||||
] each ;
|
||||
|
||||
: compile-loop ( -- )
|
||||
10 [ many-word-test "a100" parse first compile ] times ;
|
||||
|
||||
: random-test
|
||||
"----" print
|
||||
{
|
||||
test-1-integer>x
|
||||
test-1-ratio>x
|
||||
test-1-float>x
|
||||
test-1-complex>x
|
||||
test-1-integer>x-throws
|
||||
test-1-ratio>x-throws
|
||||
test-1-float>float
|
||||
test-2-float>float
|
||||
! test-n-2-float>float
|
||||
test-1-integer>x-runtime
|
||||
! test-0-float?-when
|
||||
test-1-integer?-when
|
||||
test-1-ratio?-when
|
||||
test-1-float?-when
|
||||
test-1-complex?-when
|
||||
! full-gc
|
||||
! code-gc
|
||||
} random dup . execute nl ;
|
||||
|
||||
|
|
@ -1,186 +0,0 @@
|
|||
USING: compiler errors inference interpreter io kernel math
|
||||
memory namespaces prettyprint random-tester sequences tools
|
||||
quotations words arrays definitions generic graphs
|
||||
hashtables byte-arrays assocs network ;
|
||||
IN: random-tester2
|
||||
|
||||
: dangerous-words ( -- array )
|
||||
{
|
||||
die
|
||||
set-walker-hook exit
|
||||
>r r> ndrop
|
||||
|
||||
set-callstack set-word set-word-prop
|
||||
set-catchstack set-namestack set-retainstack
|
||||
set-continuation-retain continuation-catch
|
||||
set-continuation-name catchstack retainstack
|
||||
set-no-math-method-generic
|
||||
set-no-math-method-right
|
||||
set-check-method-class
|
||||
set-check-create-name
|
||||
set-pathname-string
|
||||
set-check-create-vocab
|
||||
set-check-method-generic
|
||||
<check-create> check-create?
|
||||
reset-generic forget-class
|
||||
create forget-word forget-vocab forget
|
||||
forget-methods forget-predicate
|
||||
remove-word-prop empty-method
|
||||
continue-with <continuation>
|
||||
|
||||
define-compound define make-generic
|
||||
define-method define-predicate-class
|
||||
define-tuple-class define-temp define-tuple-slots
|
||||
define-writer define-predicate define-generic
|
||||
(define-union-class)
|
||||
define-declared define-class
|
||||
define-union-class define-inline
|
||||
?make-generic define-reader define-slot define-slots
|
||||
define-typecheck define-slot-word define-union-class
|
||||
define-simple-generic with-methods define-constructor
|
||||
predicate-word condition-continuation define-symbol
|
||||
tuple-predicate (sort-classes)
|
||||
|
||||
stdio
|
||||
close readln read1 read read-until
|
||||
stream-read stream-readln stream-read1 lines
|
||||
contents stream-copy stream-flush
|
||||
lines-loop
|
||||
stream-format set-line-reader-cr
|
||||
<client-stream> <server> <client>
|
||||
<duplex-stream> <file-writer> <file-reader>
|
||||
<style-stream> style-stream default-constructor
|
||||
init-namespaces plain-writer
|
||||
|
||||
with-datastack <quotation> datastack-underflow.
|
||||
(delegates) simple-slot , # %
|
||||
<continuation> continue-with set-delegate
|
||||
callcc0 callcc1
|
||||
|
||||
:r :s :c
|
||||
|
||||
(next-power-of-2) (^) d>w/w w>h/h millis
|
||||
(random) ^n integer, first-bignum
|
||||
most-positive-fixnum ^ init-random next-power-of-2
|
||||
most-negative-fixnum
|
||||
|
||||
clear-assoc build-graph
|
||||
|
||||
set-word-def set-word-name
|
||||
set-word-props
|
||||
set set-axis set-delegate set-global set-restart-obj
|
||||
|
||||
|
||||
|
||||
gensym random
|
||||
|
||||
double>bits float>bits >bignum
|
||||
|
||||
class-predicates delete (delete) memq?
|
||||
prune join concat group at+
|
||||
normalize norm vneg vmax vmin v- v+ [v-]
|
||||
times repeat (repeat)
|
||||
supremum infimum at norm-sq
|
||||
product sum curry remove-all member? subseq?
|
||||
|
||||
! O(n) on bignums
|
||||
(add-vertex) (prune) (split) digits>integer
|
||||
substitute ?head ?tail add-vertex all? base> closure
|
||||
drop-prefix
|
||||
find-last-sep format-column head? index index*
|
||||
last-index mismatch push-new remove-vertex reset-props
|
||||
seq-quot-uses sequence= split split, split1 start
|
||||
start* string-lines string>integer tail? v.
|
||||
|
||||
stack-picture
|
||||
|
||||
! allot crashes
|
||||
at+ natural-sort
|
||||
|
||||
# % (delegates) +@ , . .s <continuation>
|
||||
<quotation> <word> be> bin> callstack changed-word
|
||||
changed-words continue-with counter dec
|
||||
global
|
||||
hex> inc le> namespace namestack nest oct> off
|
||||
on parent-dir path+
|
||||
simple-slot simple-slots string>number tabular-output
|
||||
unxref-word xref-word xref-words vocabularies
|
||||
with-datastack
|
||||
|
||||
bind if-graph ! 0 >n ! GCs
|
||||
|
||||
move-backward move-forward open-slice (open-slice) ! infinite loop
|
||||
(assoc-stack) ! infinite loop
|
||||
|
||||
case ! 100000000000 t case ! takes a long time
|
||||
} ;
|
||||
|
||||
: safe-words ( -- array )
|
||||
dangerous-words {
|
||||
"arrays" "assocs" "bit-arrays" "byte-arrays"
|
||||
"errors" "generic" "graphs" "hashtables" "io"
|
||||
"kernel" "math" "namespaces" "quotations" "sbufs"
|
||||
"queues" "strings" "sequences" "vectors" "words"
|
||||
} [ words ] map concat seq-diff natural-sort ;
|
||||
|
||||
safe-words \ safe-words set-global
|
||||
|
||||
: 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. }
|
||||
} ;
|
||||
|
||||
: setup-test ( #data #code -- data... quot )
|
||||
#! variable stack effect
|
||||
>r [ databank random ] times r>
|
||||
[ drop \ safe-words get random ] map >quotation ;
|
||||
|
||||
SYMBOL: before
|
||||
SYMBOL: after
|
||||
SYMBOL: quot
|
||||
SYMBOL: err
|
||||
err off
|
||||
|
||||
: test-compiler ( data... quot -- ... )
|
||||
err off
|
||||
dup quot set
|
||||
datastack clone dup pop* before set
|
||||
[ call ] catch drop datastack clone after set
|
||||
clear
|
||||
before get [ ] each
|
||||
quot get [ compile-1 ] [ err on ] recover ;
|
||||
|
||||
: do-test ( data... quot -- )
|
||||
.s flush test-compiler
|
||||
err get [
|
||||
datastack after get 2dup = [
|
||||
2drop
|
||||
] [
|
||||
[ . ] each
|
||||
"--" print [ . ] each quot get .
|
||||
"not =" throw
|
||||
] if
|
||||
] unless
|
||||
clear ;
|
||||
|
||||
: random-test* ( #data #code -- )
|
||||
setup-test do-test ;
|
||||
|
||||
: run-random-tester2
|
||||
100000000000000 [ 6 3 random-test* ] times ;
|
||||
|
||||
|
||||
! A worthwhile test that has not been run extensively
|
||||
|
||||
1000 [ drop gensym ] map "syms" set-global
|
||||
|
||||
: fooify-test
|
||||
"syms" get-global random
|
||||
2000 random >quotation
|
||||
over set-word-def
|
||||
100 random zero? [ code-gc ] when
|
||||
compile fooify-test ;
|
||||
|
||||
|
|
@ -1,218 +0,0 @@
|
|||
USING: arrays errors generic hashtables io kernel lazy-lists math
|
||||
memory modules namespaces null-stream prettyprint random-tester2
|
||||
quotations sequences strings
|
||||
tools vectors words ;
|
||||
IN: random-tester
|
||||
|
||||
: inert ;
|
||||
TUPLE: inert-object ;
|
||||
|
||||
: inputs ( -- seq )
|
||||
{
|
||||
0 -1 -1000000000000000000000000 2
|
||||
inert
|
||||
-29/2
|
||||
1000000000000000000000000000000/1111111111111111111111111111111111
|
||||
3/4
|
||||
-1000000000000000000000000/111111111111111111
|
||||
-3.14 1/0. 0.0 -1/0. 3.14 0/0.
|
||||
20102101010100110110
|
||||
C{ 1 -1 }
|
||||
W{ 55 }
|
||||
{ }
|
||||
f t
|
||||
""
|
||||
"asdf"
|
||||
[ ]
|
||||
! DLL" libm.dylib"
|
||||
! ALIEN: 1
|
||||
T{ inert-object f }
|
||||
}
|
||||
[
|
||||
H{ { 1 2 } { "asdf" "foo" } } clone ,
|
||||
H{ } clone ,
|
||||
V{ 1 0 65536 } clone ,
|
||||
V{ } clone ,
|
||||
SBUF" " clone ,
|
||||
B{ } clone ,
|
||||
?{ } clone ,
|
||||
] { } make append ;
|
||||
|
||||
TUPLE: success quot inputs outputs input-types output-types ;
|
||||
|
||||
SYMBOL: err
|
||||
SYMBOL: last-time
|
||||
SYMBOL: quot
|
||||
SYMBOL: output
|
||||
SYMBOL: input
|
||||
SYMBOL: silent
|
||||
t silent set-global
|
||||
|
||||
: test-quot ( input quot -- success/f )
|
||||
! 2dup swap . . flush
|
||||
! dup [ hash+ ] = [ 2dup . . flush ] when
|
||||
err off
|
||||
quot set input set
|
||||
silent get [
|
||||
quot get last-time get = [
|
||||
quot get
|
||||
dup . flush
|
||||
last-time set
|
||||
] unless
|
||||
] unless
|
||||
[
|
||||
clear
|
||||
input get >vector set-datastack quot get
|
||||
[ [ [ call ] { } make drop ] with-null-stream ]
|
||||
[ err on ] recover
|
||||
datastack clone output set
|
||||
] with-saved-datastack
|
||||
err get [
|
||||
f
|
||||
] [
|
||||
quot get input get output get
|
||||
2dup [ [ type ] map ] 2apply <success>
|
||||
] if ;
|
||||
|
||||
: test-inputs ( word -- seq )
|
||||
[
|
||||
[ word-input-count inputs swap ] keep
|
||||
1quotation [
|
||||
test-quot [ , ] when*
|
||||
] curry each-permutation
|
||||
] { } make ;
|
||||
|
||||
: >types ( quot -- seq )
|
||||
map concat prune natural-sort ;
|
||||
|
||||
: >output-types ( seq -- seq )
|
||||
#! input seq is the result of test-inputs
|
||||
[ success-output-types ] >types ;
|
||||
|
||||
: >input-types ( seq -- seq )
|
||||
#! input seq is the result of test-inputs
|
||||
[ success-input-types ] >types ;
|
||||
|
||||
TUPLE: typed quot inputs outputs ;
|
||||
|
||||
: successes>typed ( seq -- typed )
|
||||
dup empty? [
|
||||
drop f { } clone { } clone <typed>
|
||||
] [
|
||||
[ first success-quot ] keep
|
||||
[ >input-types ] keep >output-types <typed>
|
||||
] if ;
|
||||
|
||||
: word>type-check ( word -- tuple )
|
||||
[
|
||||
dup test-inputs
|
||||
successes>typed ,
|
||||
] curry [ with-saved-datastack ] { } make first ;
|
||||
|
||||
: type>name ( n -- string )
|
||||
dup integer? [
|
||||
{
|
||||
"fixnum"
|
||||
"bignum"
|
||||
"word"
|
||||
"obj"
|
||||
"ratio"
|
||||
"float"
|
||||
"complex"
|
||||
"wrapper"
|
||||
"array"
|
||||
"boolean"
|
||||
"hashtable"
|
||||
"vector"
|
||||
"string"
|
||||
"sbuf"
|
||||
"quotation"
|
||||
"dll"
|
||||
"alien"
|
||||
"tuple"
|
||||
} nth
|
||||
] when ;
|
||||
|
||||
: replace-subseqs ( seq new old -- seq )
|
||||
[
|
||||
swapd split1 [ append swap add ] [ nip ] if*
|
||||
] 2each ;
|
||||
|
||||
: type-array>name ( seq -- seq )
|
||||
{
|
||||
{ "object" { 0 1 2 4 5 6 7 8 9 10 11 12 13 14 15 16 17 } }
|
||||
{ "seq3" { 0 1 8 9 11 12 13 14 } }
|
||||
{ "seq2" { 0 8 9 11 12 13 14 } }
|
||||
{ "seq" { 8 9 11 12 13 14 } }
|
||||
{ "number" { 0 1 4 5 6 } }
|
||||
{ "real" { 0 1 4 5 } }
|
||||
{ "rational" { 0 1 4 } }
|
||||
{ "integer" { 0 1 } }
|
||||
{ "float/complex" { 5 6 } }
|
||||
{ "word/f" { 2 9 } }
|
||||
} flip first2 replace-subseqs [ type>name ] map ;
|
||||
|
||||
: buggy?
|
||||
[ word>type-check ] catch [
|
||||
drop f
|
||||
] [
|
||||
2array [ [ type-array>name ] map ] map
|
||||
[ [ length 1 = ] all? ] all? not
|
||||
] if ;
|
||||
|
||||
: variable-stack-effect?
|
||||
[ word>type-check ] catch nip ;
|
||||
|
||||
: find-words ( quot -- seq )
|
||||
\ safe-words get
|
||||
[
|
||||
word-input-count 3 <=
|
||||
] subset swap subset ;
|
||||
|
||||
: find-safe ( -- seq ) [ buggy? not ] find-words ;
|
||||
|
||||
: find-buggy ( -- seq ) [ buggy? ] find-words ;
|
||||
|
||||
: test-word ( output input word -- ? )
|
||||
1quotation test-quot dup [
|
||||
success-outputs sequence=
|
||||
] [
|
||||
nip
|
||||
] if ;
|
||||
|
||||
: word-finder ( inputs outputs -- seq )
|
||||
swap safe-words
|
||||
[ >r 2dup r> test-word ] subset 2nip ;
|
||||
|
||||
: (enumeration-test)
|
||||
[
|
||||
[ stack-effect effect-in length ] catch [ 4 < ] unless
|
||||
] subset [ [ test-inputs successes>typed , ] each ] { } make ;
|
||||
|
||||
! full-gc finds corrupted memory faster
|
||||
|
||||
: enumeration-test ( -- seq )
|
||||
[
|
||||
\ safe-words get
|
||||
f silent set
|
||||
(enumeration-test)
|
||||
] with-scope ;
|
||||
|
||||
: array>all-quots ( seq n -- seq )
|
||||
[
|
||||
[ 1+ [ >quotation , ] each-permutation ] each-with
|
||||
] { } make ;
|
||||
|
||||
: array>all ( seq n -- seq )
|
||||
dupd array>all-quots append ;
|
||||
|
||||
: quot-finder ( inputs outputs -- seq )
|
||||
swap safe-words 2 array>all
|
||||
[
|
||||
3 [ >quotation >r 2dup r> [ test-quot ] keep
|
||||
swap [ , ] [ drop ] if ] each-permutation
|
||||
] { } make ;
|
||||
|
||||
: word-frequency ( -- alist )
|
||||
all-words [ dup usage length 2array ] map sort-values ;
|
||||
|
||||
|
|
@ -1,77 +0,0 @@
|
|||
USING: generic kernel math sequences namespaces errors
|
||||
assocs words arrays parser compiler syntax io
|
||||
quotations optimizer inference shuffle tools prettyprint ;
|
||||
IN: random-tester
|
||||
|
||||
: word-input-count ( word -- n )
|
||||
[ stack-effect effect-in length ] [ 2drop 0 ] recover ;
|
||||
|
||||
: type-error? ( exception -- ? )
|
||||
[ swap execute or ] curry
|
||||
>r { no-method? no-math-method? } f r> reduce ;
|
||||
|
||||
! HASHTABLES
|
||||
: random-hash-entry ( hash -- key value )
|
||||
[ keys random dup ] keep at ;
|
||||
|
||||
: coin-flip ( -- bool ) 2 random zero? ;
|
||||
: do-one ( seq -- ) random call ; inline
|
||||
|
||||
: nzero-array ( seq -- )
|
||||
dup length >r 0 r> [ pick set-nth ] each-with drop ;
|
||||
|
||||
: zero-array ( n -- seq ) [ drop 0 ] map ;
|
||||
|
||||
TUPLE: p-list seq max count count-vec ;
|
||||
: make-p-list ( seq n -- tuple )
|
||||
>r dup length [ 1- ] keep r>
|
||||
[ ^ 0 swap 2array ] keep
|
||||
zero-array <p-list> ;
|
||||
|
||||
: inc-seq ( seq max -- )
|
||||
2dup [ < ] curry find-last over -1 = [
|
||||
3drop nzero-array
|
||||
] [
|
||||
nipd 1+ 2over swap set-nth
|
||||
1+ over length rot <slice> nzero-array
|
||||
] if ;
|
||||
|
||||
: inc-count ( tuple -- )
|
||||
[ p-list-count first2 >r 1+ r> 2array ] keep
|
||||
set-p-list-count ;
|
||||
|
||||
: get-permutation ( tuple -- seq )
|
||||
[ p-list-seq ] keep p-list-count-vec [ swap nth ] map-with ;
|
||||
|
||||
: 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) ;
|
||||
|
||||
SYMBOL: saved-datastack
|
||||
: with-saved-datastack
|
||||
>r datastack saved-datastack set r> call
|
||||
saved-datastack get set-datastack ; inline
|
||||
Loading…
Reference in New Issue