Remove random-tester from unmaintained
Doug Coleman
parent
529fa92590
commit
5f900497d0
|
|
@ -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,87 +0,0 @@
|
|||
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> ;
|
||||
|
||||
|
|
@ -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