67 lines
1.8 KiB
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
|