From 529fa9259080ec99738a68853e9c44309d9d2731 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 3 Dec 2007 23:56:30 -0600 Subject: [PATCH] Port random-tester --- extra/random-tester/databank/databank.factor | 11 ++ extra/random-tester/random-tester.factor | 45 +++++++ extra/random-tester/random/random.factor | 87 +++++++++++++ .../safe-words/safe-words.factor | 117 ++++++++++++++++++ extra/random-tester/utils/utils.factor | 95 ++++++++++++++ 5 files changed, 355 insertions(+) create mode 100644 extra/random-tester/databank/databank.factor create mode 100644 extra/random-tester/random-tester.factor create mode 100755 extra/random-tester/random/random.factor create mode 100644 extra/random-tester/safe-words/safe-words.factor create mode 100644 extra/random-tester/utils/utils.factor diff --git a/extra/random-tester/databank/databank.factor b/extra/random-tester/databank/databank.factor new file mode 100644 index 0000000000..45ee779372 --- /dev/null +++ b/extra/random-tester/databank/databank.factor @@ -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. } + } ; + diff --git a/extra/random-tester/random-tester.factor b/extra/random-tester/random-tester.factor new file mode 100644 index 0000000000..f8aa0f29b5 --- /dev/null +++ b/extra/random-tester/random-tester.factor @@ -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 ; diff --git a/extra/random-tester/random/random.factor b/extra/random-tester/random/random.factor new file mode 100755 index 0000000000..da9a5c26d8 --- /dev/null +++ b/extra/random-tester/random/random.factor @@ -0,0 +1,87 @@ +USING: kernel math sequences namespaces errors hashtables words +arrays parser compiler syntax io tools prettyprint optimizer +inference ; +IN: random-tester + +! Tweak me +: max-length 15 ; inline +: max-value 1000000000 ; inline + +: 10% ( -- bool ) 10 random 8 > ; +: 20% ( -- bool ) 10 random 7 > ; +: 30% ( -- bool ) 10 random 6 > ; +: 40% ( -- bool ) 10 random 5 > ; +: 50% ( -- bool ) 10 random 4 > ; +: 60% ( -- bool ) 10 random 3 > ; +: 70% ( -- bool ) 10 random 2 > ; +: 80% ( -- bool ) 10 random 1 > ; +: 90% ( -- bool ) 10 random 0 > ; + +! varying bit-length random number +: random-bits ( n -- int ) + random 2 swap ^ random ; + +: random-seq ( -- seq ) + { [ ] { } V{ } "" } random + [ max-length random [ max-value random , ] times ] swap make ; + +: random-string + [ max-length random [ max-value random , ] times ] "" make ; + +SYMBOL: special-integers +[ { -1 0 1 } % most-negative-fixnum , most-positive-fixnum , first-bignum , ] +{ } make \ special-integers set-global +: special-integers ( -- seq ) \ special-integers get ; +SYMBOL: special-floats +[ { 0.0 -0.0 } % e , pi , 1./0. , -1./0. , 0./0. , epsilon , epsilon neg , ] +{ } make \ special-floats set-global +: special-floats ( -- seq ) \ special-floats get ; +SYMBOL: special-complexes +[ + { -1 0 1 i -i } % + e , e neg , pi , pi neg , + 0 pi rect> , 0 pi neg rect> , pi neg 0 rect> , pi pi rect> , + pi pi neg rect> , pi neg pi rect> , pi neg pi neg rect> , + e neg e neg rect> , e e rect> , +] { } make \ special-complexes set-global +: special-complexes ( -- seq ) \ special-complexes get ; + +: random-fixnum ( -- fixnum ) + most-positive-fixnum random 1+ coin-flip [ neg 1- ] when >fixnum ; + +: random-bignum ( -- bignum ) + 400 random-bits first-bignum + coin-flip [ neg ] when ; + +: random-integer ( -- n ) + coin-flip [ + random-fixnum + ] [ + coin-flip [ random-bignum ] [ special-integers random ] if + ] if ; + +: random-positive-integer ( -- int ) + random-integer dup 0 < [ + neg + ] [ + dup 0 = [ 1 + ] when + ] if ; + +: random-ratio ( -- ratio ) + 1000000000 dup [ random ] 2apply 1+ / coin-flip [ neg ] when dup [ drop random-ratio ] unless 10% [ drop 0 ] when ; + +: random-float ( -- float ) + coin-flip [ random-ratio ] [ special-floats random ] if + coin-flip + [ .0000000000000000001 /f ] [ coin-flip [ .00000000000000001 * ] when ] if + >float ; + +: random-number ( -- number ) + { + [ random-integer ] + [ random-ratio ] + [ random-float ] + } do-one ; + +: random-complex ( -- C ) + random-number random-number rect> ; + diff --git a/extra/random-tester/safe-words/safe-words.factor b/extra/random-tester/safe-words/safe-words.factor new file mode 100644 index 0000000000..9bc87a9c5a --- /dev/null +++ b/extra/random-tester/safe-words/safe-words.factor @@ -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 [ assoc? ] compile-1 + 2^ not + ! arrays + resize-array + ! assocs + (assoc-stack) + new-assoc + assoc-like + + 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 [ assoc? ] compile-1 +! -3 [ ] 2 [ byte-array>bignum denominator ] compile-1 + diff --git a/extra/random-tester/utils/utils.factor b/extra/random-tester/utils/utils.factor new file mode 100644 index 0000000000..ef3d66ad2d --- /dev/null +++ b/extra/random-tester/utils/utils.factor @@ -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 + +: make-p-list ( seq n -- tuple ) + >r dup length [ 1- ] keep r> + [ ^ 0 swap 2array ] keep + 0 ; + +: inc-seq ( seq max -- ) + 2dup [ < ] curry find-last over [ + nipd 1+ 2over swap set-nth + 1+ over length rot 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) ; + +