1 ! Copyright (C) 2005, 2010 Slava Pestov, Joe Groff.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors combinators fry kernel math math.order
4 sequences sequences.private ;
7 ERROR: groups-error seq n ;
11 GENERIC: group@ ( n groups -- from to seq )
13 TUPLE: chunking { seq read-only } { n read-only } ;
15 INSTANCE: chunking sequence
17 M: chunking nth group@ <slice> ; inline
19 M: chunking nth-unsafe group@ <slice-unsafe> ; inline
21 M: chunking set-nth group@ <slice> 0 swap copy ;
23 M: chunking like drop { } like ; inline
25 : check-groups ( seq n -- seq n )
26 dup 0 <= [ groups-error ] when ; inline
28 : new-groups ( seq n class -- groups )
29 [ check-groups ] dip boa ; inline
33 TUPLE: groups < chunking ;
36 [ seq>> length ] [ n>> ] bi [ + 1 - ] keep /i ; inline
39 [ n>> * ] [ seq>> ] bi set-length ; inline
42 [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ; inline
44 : <groups> ( seq n -- groups )
45 groups new-groups ; inline
47 TUPLE: clumps < chunking ;
50 dup seq>> length [ drop 0 ] [
51 swap [ 1 + ] [ n>> ] bi* [-]
55 [ n>> + 1 - ] [ seq>> ] bi set-length ; inline
58 [ n>> over + ] [ seq>> ] bi ; inline
60 : <clumps> ( seq n -- clumps )
61 clumps new-groups ; inline
65 : map-like ( seq n quot -- seq )
66 2keep drop '[ _ like ] map ; inline
70 : group ( seq n -- array ) [ <groups> ] map-like ; inline
72 : clump ( seq n -- array ) [ <clumps> ] map-like ; inline
74 : monotonic? ( seq quot: ( elt1 elt2 -- ? ) -- ? )
75 over length dup 2 < [ 3drop t ] [
77 [ first2-unsafe ] dip call
79 [ [ first-unsafe 1 ] [ (setup-each) ] bi ] dip
80 '[ @ _ keep swap ] (all-integers?) nip
84 : all-equal? ( seq -- ? ) [ = ] monotonic? ;
86 : all-eq? ( seq -- ? ) [ eq? ] monotonic? ;
89 { from integer read-only }
90 { to integer read-only }
93 INSTANCE: circular-slice virtual-sequence
95 M: circular-slice equal? over circular-slice? [ sequence= ] [ 2drop f ] if ;
97 M: circular-slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
99 M: circular-slice length [ to>> ] [ from>> ] bi - ; inline
101 M: circular-slice virtual-exemplar seq>> ; inline
103 M: circular-slice virtual@
104 [ from>> + ] [ seq>> ] bi [ length rem ] keep ; inline
106 C: <circular-slice> circular-slice
108 TUPLE: circular-clumps
112 INSTANCE: circular-clumps sequence
114 M: circular-clumps length
115 seq>> length ; inline
117 M: circular-clumps nth
118 [ n>> over + ] [ seq>> ] bi <circular-slice> ; inline
120 : <circular-clumps> ( seq n -- clumps )
121 circular-clumps new-groups ; inline
123 : circular-clump ( seq n -- array )
124 [ <circular-clumps> ] map-like ; inline