57 lines
1.6 KiB
Factor
Executable File
57 lines
1.6 KiB
Factor
Executable File
USING: kernel sequences arrays math.intervals accessors
|
|
math.order sorting math assocs locals namespaces ;
|
|
IN: interval-maps
|
|
|
|
TUPLE: interval-map array ;
|
|
|
|
<PRIVATE
|
|
TUPLE: interval-node interval value ;
|
|
|
|
: fixup-value ( value ? -- value/f ? )
|
|
[ drop f f ] unless* ;
|
|
|
|
: find-interval ( key interval-map -- i )
|
|
[ interval>> from>> first <=> ] binsearch ;
|
|
|
|
GENERIC: >interval ( object -- interval )
|
|
M: number >interval [a,a] ;
|
|
M: sequence >interval first2 [a,b] ;
|
|
M: interval >interval ;
|
|
|
|
: all-intervals ( sequence -- intervals )
|
|
[ >r >interval r> ] assoc-map ;
|
|
|
|
: ensure-disjoint ( intervals -- intervals )
|
|
dup keys [ interval-intersect not ] monotonic?
|
|
[ "Intervals are not disjoint" throw ] unless ;
|
|
|
|
|
|
PRIVATE>
|
|
|
|
: interval-at* ( key map -- value ? )
|
|
array>> [ find-interval ] 2keep swapd nth
|
|
[ nip value>> ] [ interval>> interval-contains? ] 2bi
|
|
fixup-value ;
|
|
|
|
: interval-at ( key map -- value ) interval-at* drop ;
|
|
: interval-key? ( key map -- ? ) interval-at* nip ;
|
|
|
|
: <interval-map> ( specification -- map )
|
|
all-intervals { } assoc-like
|
|
[ [ first to>> ] compare ] sort ensure-disjoint
|
|
[ interval-node boa ] { } assoc>map
|
|
interval-map boa ;
|
|
|
|
:: coalesce ( alist -- specification )
|
|
! Only works with integer keys, because they're discrete
|
|
! Makes 2array keys
|
|
[
|
|
alist 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 ;
|