steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

math.statistics: Make a safe version of kth-object. Bounds check k w/ regards to seq.

db4
Doug Coleman 2012-04-23 13:55:25 -07:00
parent b9bcfdab8e
commit 7cb094d521
2 changed files with 23 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
basis/math/statistics/statistics-tests.factor
View File

@ -1,4 +1,5 @@
USING: assocs kernel math math.functions math.statistics sequences tools.test ; USING: assocs kernel math math.functions math.statistics sequences
math.order tools.test ;
IN: math.statistics.tests IN: math.statistics.tests
[ 1 ] [ { 1 } mean ] unit-test [ 1 ] [ { 1 } mean ] unit-test
@ -19,6 +20,10 @@ IN: math.statistics.tests
{ 4 } [ { 1 2 3 4 } 0 kth-largest ] unit-test { 4 } [ { 1 2 3 4 } 0 kth-largest ] unit-test
{ 2 } [ { 1 2 3 4 } 2 kth-largest ] unit-test { 2 } [ { 1 2 3 4 } 2 kth-largest ] unit-test
[ { 1 2 3 4 } 30 kth-largest ] [ bounds-error? ] must-fail-with
[ { 1 2 3 4 } 2 [ [ ] compare ] kth-object ] [ bounds-error? ] must-fail-with
{ 3 } [ { 1 2 3 4 } 2 [ before? ] kth-object ] unit-test
[ 1 ] [ { 1 } mode ] unit-test [ 1 ] [ { 1 } mode ] unit-test
[ 3 ] [ { 1 2 3 3 3 4 5 6 76 7 2 21 1 3 3 3 } mode ] unit-test [ 3 ] [ { 1 2 3 3 3 4 5 6 76 7 2 21 1 3 3 3 } mode ] unit-test

23
basis/math/statistics/statistics.factor
View File

@ -14,9 +14,12 @@ IN: math.statistics
: harmonic-mean ( seq -- x ) : harmonic-mean ( seq -- x )
[ recip ] map-sum recip ; [ recip ] map-sum recip ;
:: kth-object ( seq k quot: ( x y -- ? ) -- elt ) <PRIVATE
:: (kth-object) ( seq k quot: ( x y -- ? ) nth-quot exchange-quot -- elt )
#! Wirth's method, Algorithm's + Data structues = Programs p. 84 #! Wirth's method, Algorithm's + Data structues = Programs p. 84
#! The algorithm modifiers seq, so we clone it #! The algorithm modifiers seq, so we clone it
k seq bounds-check 2drop
seq clone :> seq seq clone :> seq
0 :> i! 0 :> i!
0 :> j! 0 :> j!
@ -30,10 +33,10 @@ IN: math.statistics
m j! m j!
[ i j <= ] [ i j <= ]
[ [
[ i seq nth-unsafe x quot call ] [ i 1 + i! ] while [ i seq nth-quot call x quot call ] [ i 1 + i! ] while
[ x j seq nth-unsafe quot call ] [ j 1 - j! ] while [ x j seq nth-quot call quot call ] [ j 1 - j! ] while
i j <= [ i j <= [
i j seq exchange-unsafe i j seq exchange-quot call
i 1 + i! i 1 + i!
j 1 - j! j 1 - j!
] when ] when
@ -44,9 +47,17 @@ IN: math.statistics
] while ] while
k seq nth ; inline k seq nth ; inline
: kth-smallest ( seq k -- elt ) [ < ] kth-object ; : kth-object-unsafe ( seq k quot: ( x y -- ? ) -- elt )
[ nth-unsafe ] [ exchange-unsafe ] (kth-object) ; inline
PRIVATE>
: kth-object ( seq k quot: ( x y -- ? ) -- elt )
[ nth ] [ exchange ] (kth-object) ; inline
: kth-smallest ( seq k -- elt ) [ < ] kth-object-unsafe ;
: kth-largest ( seq k -- elt ) [ > ] kth-object ; : kth-largest ( seq k -- elt ) [ > ] kth-object-unsafe ;
: count-relative ( seq k -- lt eq gt ) : count-relative ( seq k -- lt eq gt )
[ 0 0 0 ] 2dip '[ [ 0 0 0 ] 2dip '[