From 5f4bf4513bad8bf6d6b71fa97bfaf29aae3a014d Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Fri, 5 Oct 2012 14:48:05 -0700 Subject: [PATCH] math.extras: implement "search-sorted" and "weighted-random". --- extra/math/extras/extras-tests.factor | 6 +++++- extra/math/extras/extras.factor | 14 ++++++++++---- 2 files changed, 15 insertions(+), 5 deletions(-) diff --git a/extra/math/extras/extras-tests.factor b/extra/math/extras/extras-tests.factor index d5232cb4de..d55c1494c1 100644 --- a/extra/math/extras/extras-tests.factor +++ b/extra/math/extras/extras-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2012 John Benediktsson ! See http://factorcode.org/license.txt for BSD license -USING: math math.extras math.ranges tools.test ; +USING: math math.extras math.ranges sequences tools.test ; IN: math.extras.test @@ -68,3 +68,7 @@ IN: math.extras.test { 57/200 } [ { 80 60 10 20 30 } herfindahl ] unit-test { 17/160 } [ { 80 60 10 20 30 } normalized-herfindahl ] unit-test + +{ { 0 5 1 2 2 } } [ + { -10 10 2 2.5 3 } [ { 1 2 3 4 5 } search-sorted ] map +] unit-test diff --git a/extra/math/extras/extras.factor b/extra/math/extras/extras.factor index 343ef90222..22c22bbcac 100644 --- a/extra/math/extras/extras.factor +++ b/extra/math/extras/extras.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2012 John Benediktsson ! See http://factorcode.org/license.txt for BSD license -USING: combinators.short-circuit grouping kernel locals math -math.combinatorics math.constants math.functions math.order -math.primes math.ranges math.statistics math.vectors memoize -sequences sequences.extras sorting assocs fry ; +USING: assocs combinators.short-circuit fry grouping kernel +locals math math.combinatorics math.constants math.functions +math.order math.primes math.ranges math.statistics math.vectors +memoize random sequences sequences.extras sorting ; IN: math.extras @@ -188,3 +188,9 @@ PRIVATE> : exponential-index ( seq -- x ) dup sum '[ _ / dup ^ ] map-product ; + +: search-sorted ( obj seq -- i ) + swap '[ [ _ >= ] find drop dup ] [ length ] bi ? ; + +: weighted-random ( histogram -- obj ) + unzip cum-sum [ last random ] [ search-sorted ] bi swap nth ;