-! Copyright (C) 2008 Daniel Ehrenberg.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel sequences arrays accessors grouping math.order\r
-sorting binary-search math assocs locals namespaces make ;\r
-IN: interval-maps\r
-\r
-TUPLE: interval-map array ;\r
-\r
-<PRIVATE\r
-\r
-ALIAS: start first\r
-ALIAS: end second\r
-ALIAS: value third\r
-\r
-: find-interval ( key interval-map -- interval-node )\r
- array>> [ start <=> ] with search nip ;\r
-\r
-: interval-contains? ( key interval-node -- ? )\r
- [ start ] [ end ] bi between? ;\r
-\r
-: all-intervals ( sequence -- intervals )\r
- [ [ dup number? [ dup 2array ] when ] dip ] { } assoc-map-as ;\r
-\r
-: disjoint? ( node1 node2 -- ? )\r
- [ end ] [ start ] bi* < ;\r
-\r
-: ensure-disjoint ( intervals -- intervals )\r
- dup [ disjoint? ] monotonic?\r
- [ "Intervals are not disjoint" throw ] unless ;\r
-\r
-: >intervals ( specification -- intervals )\r
- [ suffix ] { } assoc>map concat 3 <groups> ;\r
-\r
-PRIVATE>\r
-\r
-: interval-at* ( key map -- value ? )\r
- [ drop ] [ find-interval ] 2bi\r
- [ nip ] [ interval-contains? ] 2bi\r
- [ value t ] [ drop f f ] if ;\r
-\r
-: interval-at ( key map -- value ) interval-at* drop ;\r
-\r
-: interval-key? ( key map -- ? ) interval-at* nip ;\r
-\r
-: interval-values ( map -- values )\r
- array>> [ value ] map ;\r
-\r
-: <interval-map> ( specification -- map )\r
- all-intervals [ first second ] sort-with\r
- >intervals ensure-disjoint interval-map boa ;\r
-\r
-: <interval-set> ( specification -- map )\r
- dup zip <interval-map> ;\r
-\r
-:: coalesce ( alist -- specification )\r
- ! Only works with integer keys, because they're discrete\r
- ! Makes 2array keys\r
- [\r
- alist sort-keys unclip swap [ [ first dup ] [ second ] bi ] dip\r
- [| oldkey oldval key val | ! Underneath is start\r
- oldkey 1 + key =\r
- oldval val = and\r
- [ oldkey 2array oldval 2array , key ] unless\r
- key val\r
- ] assoc-each [ 2array ] bi@ ,\r
- ] { } make ;\r
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs binary-search classes grouping
+kernel make math math.order sequences sequences.private
+sorting ;
+IN: interval-maps
+
+! Intervals are triples of { start end value }
+TUPLE: interval-map { array array read-only } ;
+
+<PRIVATE
+
+: find-interval ( key interval-map -- interval-node )
+ array>> [ first-unsafe <=> ] with search nip ; inline
+
+: interval-contains? ( key interval-node -- ? )
+ first2-unsafe between? ; inline
+
+: all-intervals ( sequence -- intervals )
+ [ [ dup number? [ dup 2array ] when ] dip ] { } assoc-map-as ;
+
+: disjoint? ( node1 node2 -- ? )
+ [ second-unsafe ] [ first-unsafe ] bi* < ;
+
+: ensure-disjoint ( intervals -- intervals )
+ dup [ disjoint? ] monotonic?
+ [ "Intervals are not disjoint" throw ] unless ;
+
+: >intervals ( specification -- intervals )
+ [ suffix ] { } assoc>map concat 3 group ;
+
+PRIVATE>
+
+: interval-at* ( key map -- value ? )
+ interval-map check-instance
+ [ drop ] [ find-interval ] 2bi
+ [ nip ] [ interval-contains? ] 2bi
+ [ third-unsafe t ] [ drop f f ] if ; inline
+
+: interval-at ( key map -- value ) interval-at* drop ; inline
+
+: interval-key? ( key map -- ? ) interval-at* nip ; inline
+
+: interval-values ( map -- values )
+ interval-map check-instance array>> [ third-unsafe ] map ;
+
+: <interval-map> ( specification -- map )
+ all-intervals [ first-unsafe second-unsafe ] sort-with
+ >intervals ensure-disjoint interval-map boa ;
+
+: <interval-set> ( specification -- map )
+ dup zip <interval-map> ;
+
+:: coalesce ( alist -- specification )
+ ! Only works with integer keys, because they're discrete
+ ! Makes 2array keys
+ [
+ alist sort-keys unclip swap [ first2 dupd ] dip
+ [| 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 ;