unmaintained: New home for misfit Factor vocabularies.

[factor-unmaintained.git] / random-weighted / random-weighted.factor

diff --git a/random-weighted/random-weighted.factor b/random-weighted/random-weighted.factor
new file mode 100644 (file)
index 0000000..47c85a6
--- /dev/null
+++ b/random-weighted/random-weighted.factor
@@ -0,0 +1,20 @@
+
+USING: kernel namespaces arrays quotations sequences assocs combinators
+       mirrors math math.vectors random macros fry ;
+
+IN: random-weighted
+
+: probabilities ( weights -- probabilities ) dup sum v/n ;
+
+: layers ( probabilities -- layers )
+dup length 1+ [ head ] with map rest [ sum ] map ;
+
+: random-weighted ( weights -- elt )
+probabilities layers [ 1000 * ] map 1000 random [ > ] curry find drop ;
+
+: random-weighted* ( seq -- elt )
+dup [ second ] map swap [ first ] map random-weighted swap nth ;
+
+MACRO: call-random-weighted ( exp -- )
+  [ keys ] [ values <enum> >alist ] bi
+  '[ _ random-weighted _ case ] ;