1 ! Copyright (C) 2009 Daniel Ehrenberg.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien.c-types arrays assocs binary-search
4 classes combinators grouping kernel locals make math
5 math.order sequences sequences.private sorting
7 SPECIALIZED-ARRAY: uint
9 ! Sets of positive integers
11 ! Intervals are a pair of { start end }
12 TUPLE: interval-set { array uint-array read-only } ;
14 : interval-in? ( key set -- ? )
15 interval-set check-instance array>>
16 dupd [ <=> ] with search swap [
17 even? [ >= ] [ 1 - <= ] if
22 : spec>pairs ( sequence -- intervals )
23 [ dup number? [ dup 2array ] when ] map ;
25 : disjoint? ( node1 node2 -- ? )
26 [ second-unsafe ] [ first-unsafe ] bi* < ;
28 : (delete-redundancies) ( seq -- )
40 : delete-redundancies ( seq -- seq' )
41 ! If the next element is >= current one, leave out both
42 [ (delete-redundancies) ] uint-array{ } make ;
44 : make-intervals ( seq -- interval-set )
49 : >intervals ( seq -- seq' )
50 [ 1 + ] assoc-map concat ;
54 : <interval-set> ( specification -- interval-set )
56 >intervals make-intervals ;
60 :: or-step ( set1 set2 -- set1' set2' )
62 set1 second set2 first <=
63 [ set1 0 ] [ set2 2 ] if
64 [ second , ] [ set2 swap tail-slice ] bi*
67 : combine-or ( set1 set2 -- )
69 { [ over empty? ] [ % drop ] }
70 { [ dup empty? ] [ drop % ] }
80 : <interval-or> ( set1 set2 -- set )
82 [ combine-or ] uint-array{ } make
87 : prefix-0 ( seq -- 0seq )
88 0 over ?nth zero? [ rest ] [ 0 prefix ] if ;
90 : interval-max ( interval-set1 interval-set2 -- n )
91 [ array>> [ 0 ] [ last ] if-empty ] bi@ max ;
95 : <interval-not> ( set maximum -- set' )
96 [ array>> prefix-0 ] dip suffix make-intervals ;
98 : <interval-and> ( set1 set2 -- set )
100 [ '[ _ <interval-not> ] bi@ <interval-or> ] keep