extra/rosetta-code/probabilistic-choice/probabilistic-choice.factor

   1 ! Copyright (c) 2012 Anonymous
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs combinators.random formatting kernel
   4 math quotations sequences ;
   5 IN: rosettacode.probabilistic-choice
   6
   7 ! http://rosettacode.org/wiki/Probabilistic_choice
   8
   9 ! Given a mapping between items and their required probability
  10 ! of occurrence, generate a million items randomly subject to the
  11 ! given probabilities and compare the target probability of
  12 ! occurrence versus the generated values.
  13
  14 ! The total of all the probabilities should equal one. (Because
  15 ! floating point arithmetic is involved this is subject to
  16 ! rounding errors).
  17
  18 ! Use the following mapping to test your programs:
  19 ! aleph   1/5.0
  20 ! beth    1/6.0
  21 ! gimel   1/7.0
  22 ! daleth  1/8.0
  23 ! he      1/9.0
  24 ! waw     1/10.0
  25 ! zayin   1/11.0
  26 ! heth    1759/27720 # adjusted so that probabilities add to 1
  27
  28 CONSTANT: data
  29 {
  30     { "aleph"   1/5.0 }
  31     { "beth"    1/6.0 }
  32     { "gimel"   1/7.0 }
  33     { "daleth"  1/8.0 }
  34     { "he"      1/9.0 }
  35     { "waw"     1/10.0 }
  36     { "zayin"   1/11.0 }
  37     { "heth"    f }
  38 }
  39
  40 MACRO: case-probas ( data -- quot )
  41     [ first2 [ 1quotation ] dip [ swap 2array ] when* ] map 1quotation ;
  42
  43 : expected ( data name -- float )
  44     dupd of [ ] [ values sift sum 1 swap - ] ?if ;
  45
  46 : generate ( # case-probas -- seq )
  47     H{ } clone [
  48         '[ _ casep _ inc-at ] times
  49     ] keep ; inline
  50
  51 : normalize ( seq # -- seq )
  52     [ clone ] dip '[ _ /f ] assoc-map ;
  53
  54 : summarize1 ( name value data -- )
  55     pick expected "%6s: %10f %10f\n" printf ;
  56
  57 : summarize ( generated data -- )
  58     "Key" "Value" "expected" "%6s  %10s %10s\n" printf
  59     '[ _ summarize1 ] assoc-each ;
  60
  61 : generate-normalized ( # proba -- seq )
  62     [ generate ] [ drop normalize ] 2bi ; inline
  63
  64 : example ( # data -- )
  65     [ case-probas generate-normalized ]
  66     [ summarize ] bi ; inline