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

67 lines
1.8 KiB
Factor

! Copyright (c) 2012 Anonymous
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs combinators.random formatting fry kernel
macros math quotations sequences ;
IN: rosettacode.probabilistic-choice
! http://rosettacode.org/wiki/Probabilistic_choice
! Given a mapping between items and their required probability
! of occurrence, generate a million items randomly subject to the
! given probabilities and compare the target probability of
! occurrence versus the generated values.
! The total of all the probabilities should equal one. (Because
! floating point arithmetic is involved this is subject to
! rounding errors).
! Use the following mapping to test your programs:
! aleph 1/5.0
! beth 1/6.0
! gimel 1/7.0
! daleth 1/8.0
! he 1/9.0
! waw 1/10.0
! zayin 1/11.0
! heth 1759/27720 # adjusted so that probabilities add to 1
CONSTANT: data
{
{ "aleph" 1/5.0 }
{ "beth" 1/6.0 }
{ "gimel" 1/7.0 }
{ "daleth" 1/8.0 }
{ "he" 1/9.0 }
{ "waw" 1/10.0 }
{ "zayin" 1/11.0 }
{ "heth" f }
}
MACRO: case-probas ( data -- quot )
[ first2 [ 1quotation ] dip [ swap 2array ] when* ] map 1quotation ;
: expected ( data name -- float )
dupd of [ ] [ values sift sum 1 swap - ] ?if ;
: generate ( # case-probas -- seq )
H{ } clone [
'[ _ casep _ inc-at ] times
] keep ; inline
: normalize ( seq # -- seq )
[ clone ] dip '[ _ /f ] assoc-map ;
: summarize1 ( name value data -- )
pick expected "%6s: %10f %10f\n" printf ;
: summarize ( generated data -- )
"Key" "Value" "expected" "%6s %10s %10s\n" printf
'[ _ summarize1 ] assoc-each ;
: generate-normalized ( # proba -- seq )
[ generate ] [ drop normalize ] 2bi ; inline
: example ( # data -- )
[ case-probas generate-normalized ]
[ summarize ] bi ; inline