-! Copyright (C) 2008 Daniel Ehrenberg.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors arrays assocs binary-search grouping kernel\r
-locals make math math.order sequences sequences.private sorting ;\r
-IN: interval-maps\r
-\r
-TUPLE: interval-map { array array read-only } ;\r
-\r
-<PRIVATE\r
-\r
-ALIAS: start first-unsafe\r
-ALIAS: end second-unsafe\r
-ALIAS: value third-unsafe\r
-\r
-: find-interval ( key interval-map -- interval-node )\r
- array>> [ start <=> ] with search nip ; inline\r
-\r
-: interval-contains? ( key interval-node -- ? )\r
- first2-unsafe between? ; inline\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 group ;\r
-\r
-ERROR: not-an-interval-map obj ;\r
-\r
-: check-interval-map ( map -- map )\r
- dup interval-map? [ not-an-interval-map ] unless ; inline\r
-\r
-PRIVATE>\r
-\r
-: interval-at* ( key map -- value ? )\r
- check-interval-map\r
- [ drop ] [ find-interval ] 2bi\r
- [ nip ] [ interval-contains? ] 2bi\r
- [ value t ] [ drop f f ] if ; inline\r
-\r
-: interval-at ( key map -- value ) interval-at* drop ; inline\r
-\r
-: interval-key? ( key map -- ? ) interval-at* nip ; inline\r
-\r
-: interval-values ( map -- values )\r
- check-interval-map array>> [ value ] map ;\r
-\r
-: <interval-map> ( specification -- map )\r
- all-intervals [ first-unsafe second-unsafe ] 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 [ first2 dupd ] 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 grouping kernel
+locals make math math.order sequences sequences.private sorting ;
+IN: interval-maps
+
+TUPLE: interval-map { array array read-only } ;
+
+<PRIVATE
+
+ALIAS: start first-unsafe
+ALIAS: end second-unsafe
+ALIAS: value third-unsafe
+
+: find-interval ( key interval-map -- interval-node )
+ array>> [ start <=> ] 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 -- ? )
+ [ end ] [ start ] bi* < ;
+
+: ensure-disjoint ( intervals -- intervals )
+ dup [ disjoint? ] monotonic?
+ [ "Intervals are not disjoint" throw ] unless ;
+
+: >intervals ( specification -- intervals )
+ [ suffix ] { } assoc>map concat 3 group ;
+
+ERROR: not-an-interval-map obj ;
+
+: check-interval-map ( map -- map )
+ dup interval-map? [ not-an-interval-map ] unless ; inline
+
+PRIVATE>
+
+: interval-at* ( key map -- value ? )
+ check-interval-map
+ [ drop ] [ find-interval ] 2bi
+ [ nip ] [ interval-contains? ] 2bi
+ [ value 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 )
+ check-interval-map array>> [ value ] 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 ;