1 ! Copyright (C) 2008 Daniel Ehrenberg.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs binary-search grouping kernel
4 locals make math math.order sequences sequences.private sorting ;
7 TUPLE: interval-map { array array read-only } ;
11 ALIAS: start first-unsafe
12 ALIAS: end second-unsafe
13 ALIAS: value third-unsafe
15 : find-interval ( key interval-map -- interval-node )
16 array>> [ start <=> ] with search nip ; inline
18 : interval-contains? ( key interval-node -- ? )
19 first2-unsafe between? ; inline
21 : all-intervals ( sequence -- intervals )
22 [ [ dup number? [ dup 2array ] when ] dip ] { } assoc-map-as ;
24 : disjoint? ( node1 node2 -- ? )
25 [ end ] [ start ] bi* < ;
27 : ensure-disjoint ( intervals -- intervals )
28 dup [ disjoint? ] monotonic?
29 [ "Intervals are not disjoint" throw ] unless ;
31 : >intervals ( specification -- intervals )
32 [ suffix ] { } assoc>map concat 3 group ;
34 ERROR: not-an-interval-map obj ;
36 : check-interval-map ( map -- map )
37 dup interval-map? [ not-an-interval-map ] unless ; inline
41 : interval-at* ( key map -- value ? )
43 [ drop ] [ find-interval ] 2bi
44 [ nip ] [ interval-contains? ] 2bi
45 [ value t ] [ drop f f ] if ; inline
47 : interval-at ( key map -- value ) interval-at* drop ; inline
49 : interval-key? ( key map -- ? ) interval-at* nip ; inline
51 : interval-values ( map -- values )
52 check-interval-map array>> [ value ] map ;
54 : <interval-map> ( specification -- map )
55 all-intervals [ first-unsafe second-unsafe ] sort-with
56 >intervals ensure-disjoint interval-map boa ;
58 : <interval-set> ( specification -- map )
59 dup zip <interval-map> ;
61 :: coalesce ( alist -- specification )
62 ! Only works with integer keys, because they're discrete
65 alist sort-keys unclip swap [ first2 dupd ] dip
66 [| oldkey oldval key val | ! Underneath is start
69 [ oldkey 2array oldval 2array , key ] unless
71 ] assoc-each [ 2array ] bi@ ,