1 ! Copyright (C) 2010 Jon Harper.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays assocs combinators combinators.short-circuit
4 kernel macros math math.order quotations random sequences
8 : ifp ( p true false -- ) [ random-unit > ] 2dip if ; inline
9 : whenp ( p true -- ) [ ] ifp ; inline
10 : unlessp ( p false -- ) [ [ ] ] dip ifp ; inline
14 : with-drop ( quot -- quot' ) [ drop ] prepend ; inline
16 : prepare-pair ( pair -- pair' )
17 first2 [ [ [ - ] [ < ] 2bi ] curry ] [ with-drop ] bi* 2array ;
19 ERROR: bad-probabilities assoc ;
21 M: bad-probabilities summary
22 drop "The probabilities do not satisfy the rules stated in the docs." ;
24 : good-probabilities? ( assoc -- ? )
26 keys { [ sum 1 number= ] [ [ 0 1 between? ] all? ] } 1&&
28 but-last keys { [ sum 0 1 between? ] [ [ 0 1 between? ] all? ] } 1&&
31 ! Useful for unit-tests (no random part)
32 : (casep>quot) ( assoc -- quot )
33 dup good-probabilities? [
34 [ dup pair? [ prepare-pair ] [ with-drop ] if ] map
36 ] [ bad-probabilities ] if ;
38 MACRO: (casep) ( assoc -- ) (casep>quot) ;
40 : casep>quot ( assoc -- quot )
41 (casep>quot) [ random-unit ] prepend ;
43 : (conditional-probabilities) ( seq i -- p )
44 [ dup 0 > [ head [ 1 swap - ] [ * ] map-reduce ] [ 2drop 1 ] if ] [ swap nth ] 2bi * ;
46 : conditional-probabilities ( seq -- seq' )
47 dup length iota [ (conditional-probabilities) ] with map ;
49 : (direct>conditional) ( assoc -- assoc' )
50 [ keys conditional-probabilities ] [ values ] bi zip ;
52 : direct>conditional ( assoc -- assoc' )
53 dup last pair? [ (direct>conditional) ] [
54 unclip-last [ (direct>conditional) ] [ suffix ] bi*
57 : call-random>casep ( seq -- assoc )
58 [ length recip ] keep [ 2array ] with map ;
62 MACRO: casep ( assoc -- ) casep>quot ;
64 MACRO: casep* ( assoc -- ) direct>conditional casep>quot ;
66 MACRO: call-random ( seq -- ) call-random>casep casep>quot ;
68 MACRO: execute-random ( seq -- )
69 [ 1quotation ] map call-random>casep casep>quot ;