basis/combinators/random/random.factor

   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
   5 summary ;
   6 IN: combinators.random
   7
   8 : ifp ( p true false -- ) [ random-unit > ] 2dip if ; inline
   9
  10 : whenp ( p true -- ) [ ] ifp ; inline
  11
  12 : unlessp ( p false -- ) [ [ ] ] dip ifp ; inline
  13
  14 <PRIVATE
  15
  16 : with-drop ( quot -- quot' ) [ drop ] prepend ; inline
  17
  18 : prepare-pair ( pair -- pair' )
  19     first2 [ [ [ - ] [ < ] 2bi ] curry ] [ with-drop ] bi* 2array ;
  20
  21 ERROR: bad-probabilities assoc ;
  22
  23 M: bad-probabilities summary
  24     drop "The probabilities do not satisfy the rules stated in the docs." ;
  25
  26 : good-probabilities? ( assoc -- ? )
  27     dup last pair? [
  28         keys { [ sum 1 number= ] [ [ 0 1 between? ] all? ] } 1&&
  29     ] [
  30         but-last keys { [ sum 0 1 between? ] [ [ 0 1 between? ] all? ] } 1&&
  31     ] if ;
  32
  33 ! Useful for unit-tests (no random part)
  34 : (casep>quot) ( assoc -- quot )
  35     dup good-probabilities? [
  36         [ dup pair? [ prepare-pair ] [ with-drop ] if ] map
  37         cond>quot
  38     ] [ throw-bad-probabilities ] if ;
  39
  40 MACRO: (casep) ( assoc -- quot ) (casep>quot) ;
  41
  42 : casep>quot ( assoc -- quot )
  43     (casep>quot) [ random-unit ] prepend ;
  44
  45 : (conditional-probabilities) ( seq i -- p )
  46     [ dup 0 > [ head [ 1 swap - ] [ * ] map-reduce ] [ 2drop 1 ] if ]
  47     [ swap nth ] 2bi * ;
  48
  49 : conditional-probabilities ( seq -- seq' )
  50     dup length iota [ (conditional-probabilities) ] with map ;
  51
  52 : (direct>conditional) ( assoc -- assoc' )
  53     [ keys conditional-probabilities ] [ values ] bi zip ;
  54
  55 : direct>conditional ( assoc -- assoc' )
  56     dup last pair? [ (direct>conditional) ] [
  57         unclip-last [ (direct>conditional) ] [ suffix ] bi*
  58     ] if ;
  59
  60 : call-random>casep ( seq -- assoc )
  61     [ length recip ] keep [ 2array ] with map ;
  62
  63 PRIVATE>
  64
  65 MACRO: casep ( assoc -- quot ) casep>quot ;
  66
  67 MACRO: casep* ( assoc -- quot ) direct>conditional casep>quot ;
  68
  69 MACRO: call-random ( seq -- quot ) call-random>casep casep>quot ;
  70
  71 MACRO: execute-random ( seq -- quot )
  72     [ 1quotation ] map call-random>casep casep>quot ;