1 ! Copyright (C) 2008 Daniel Ehrenberg.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs binary-search classes grouping
4 kernel make math math.order sequences sequences.private
8 ! Intervals are triples of { start end value }
9 TUPLE: interval-map { array array read-only } ;
13 : find-interval ( key interval-map -- interval-node )
14 array>> [ first-unsafe <=> ] with search nip ; inline
16 : interval-contains? ( key interval-node -- ? )
17 first2-unsafe between? ; inline
19 : all-intervals ( sequence -- intervals )
20 [ [ dup number? [ dup 2array ] when ] dip ] { } assoc-map-as ;
22 : disjoint? ( node1 node2 -- ? )
23 [ second-unsafe ] [ first-unsafe ] bi* < ;
25 : ensure-disjoint ( intervals -- intervals )
26 dup [ disjoint? ] monotonic?
27 [ "Intervals are not disjoint" throw ] unless ;
29 : >intervals ( specification -- intervals )
30 [ suffix ] { } assoc>map concat 3 group ;
34 : interval-at* ( key map -- value ? )
35 interval-map check-instance
36 [ drop ] [ find-interval ] 2bi
37 [ nip ] [ interval-contains? ] 2bi
38 [ third-unsafe t ] [ drop f f ] if ; inline
40 : interval-at ( key map -- value ) interval-at* drop ; inline
42 : interval-key? ( key map -- ? ) interval-at* nip ; inline
44 : interval-values ( map -- values )
45 interval-map check-instance array>> [ third-unsafe ] map ;
47 : <interval-map> ( specification -- map )
48 all-intervals [ first-unsafe second-unsafe ] sort-with
49 >intervals ensure-disjoint interval-map boa ;
51 : <interval-set> ( specification -- map )
52 dup zip <interval-map> ;
54 :: coalesce ( alist -- specification )
55 ! Only works with integer keys, because they're discrete
58 alist sort-keys unclip swap [ first2 dupd ] dip
59 [| oldkey oldval key val | ! Underneath is start
62 [ oldkey 2array oldval 2array , key ] unless
64 ] assoc-each [ 2array ] bi@ ,