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

Coalesce function for interval maps

db4
Daniel Ehrenberg 2008-05-05 19:52:56 -05:00
parent fdc9d554e4
commit e82fb3b6dc
2 changed files with 23 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
extra/interval-maps/interval-maps-tests.factor
View File

@ -11,3 +11,8 @@ SYMBOL: test
[ 2 ] [ 1 test get interval-at ] unit-test [ 2 ] [ 1 test get interval-at ] unit-test
[ f ] [ 2 test get interval-at ] unit-test [ f ] [ 2 test get interval-at ] unit-test
[ f ] [ 0 test get interval-at ] unit-test [ f ] [ 0 test get interval-at ] unit-test
[ { { { 1 4 } 3 } { { 4 8 } 6 } } <interval-map> ] must-fail
[ { { { 1 3 } 2 } { { 4 5 } 4 } { { 7 8 } 4 } } ]
[ { { 1 2 } { 2 2 } { 3 2 } { 4 4 } { 5 4 } { 7 4 } { 8 4 } } coalesce ] unit-test

21
extra/interval-maps/interval-maps.factor
View File

@ -1,5 +1,5 @@
USING: kernel sequences arrays math.intervals accessors USING: kernel sequences arrays math.intervals accessors
math.order sorting math assocs ; math.order sorting math assocs locals namespaces ;
IN: interval-maps IN: interval-maps
TUPLE: interval-map array ; TUPLE: interval-map array ;
@ -24,6 +24,8 @@ M: interval >interval ;
: ensure-disjoint ( intervals -- intervals ) : ensure-disjoint ( intervals -- intervals )
dup keys [ interval-intersect not ] monotonic? dup keys [ interval-intersect not ] monotonic?
[ "Intervals are not disjoint" throw ] unless ; [ "Intervals are not disjoint" throw ] unless ;
PRIVATE> PRIVATE>
: interval-at* ( key map -- value ? ) : interval-at* ( key map -- value ? )
@ -35,7 +37,20 @@ PRIVATE>
: interval-key? ( key map -- ? ) interval-at* nip ; : interval-key? ( key map -- ? ) interval-at* nip ;
: <interval-map> ( specification -- map ) : <interval-map> ( specification -- map )
all-intervals ensure-disjoint all-intervals { } assoc-like
[ [ first to>> ] compare ] sort [ [ first to>> ] compare ] sort ensure-disjoint
[ interval-node boa ] { } assoc>map [ interval-node boa ] { } assoc>map
interval-map boa ; interval-map boa ;
:: coalesce ( assoc -- specification )
! Only works with integer keys, because they're discrete
! Makes 2array keys
[
assoc sort-keys unclip first2 dupd roll
[| oldkey oldval key val | ! Underneath is start
oldkey 1+ key =
oldval val = and
[ oldkey 2array oldval 2array , key ] unless
key val
] assoc-each [ 2array ] bi@ ,
] { } make ;