Merge git://spitspat.com/git/factor
Doug Coleman
commit
c078621369
|
|
@ -58,3 +58,5 @@ IN: temporary
|
||||||
[ dup array? ] [ dup vector? ] [ dup float? ]
|
[ dup array? ] [ dup vector? ] [ dup float? ]
|
||||||
} || nip
|
} || nip
|
||||||
] unit-test
|
] 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
|
: 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 ;
|
: 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() {
|
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
|
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