78 lines
2.0 KiB
Factor
78 lines
2.0 KiB
Factor
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
|