1 ! Copyright (C) 2016-2017 Alexander Ilin.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs binary-search colors
4 combinators combinators.short-circuit kernel make
5 math math.order math.statistics math.vectors opengl opengl.gl
6 sequences specialized-arrays splitting.monotonic ui.gadgets
7 ui.gadgets.charts ui.gadgets.charts.utils ui.render ;
8 QUALIFIED-WITH: alien.c-types c
9 IN: ui.gadgets.charts.lines
11 SPECIALIZED-ARRAY: c:float
13 ! Data must be a sequence of { x y } coordinates sorted by
14 ! non-descending x vaues.
15 TUPLE: line < gadget color data ;
19 : (line-vertices) ( seq -- vertices )
20 concat [ 0.3 + ] float-array{ } map-as ;
25 : search-first ( elt seq -- index elt )
26 [ first <=> ] with search ;
28 : search-first? ( elt seq -- index elt exact-match? )
29 dupd search-first rot [ dup first ] dip = ;
31 ! Return a slice of the seq with all elements equal to elt to the
32 ! left of the index, plus one that's not equal, if requested.
33 :: adjusted-tail-slice ( n elt plus-one? seq -- slice )
34 n seq elt x '[ x _ = not ] find-last-from drop seq swap
35 [ plus-one? [ 1 + ] unless tail-slice ] when* ;
37 ! Return a slice of the seq with all elements equal to elt to the
38 ! right of the index, plus one that's not equal, if requested.
39 :: adjusted-head-slice ( n elt plus-one? seq -- slice )
40 n seq elt x '[ x _ = not ] find-from drop seq swap
41 [ plus-one? [ 1 + ] when index-or-length head-slice ] when* ;
43 ! : data-rect ( data -- rect )
44 ! [ [ first x ] [ last x ] bi ] keep
45 ! [ y ] map minmax swapd
46 ! [ 2array ] bi@ <extent-rect> ;
48 : x-in-bounds? ( min,max pairs -- ? )
50 [ [ first ] dip last x > not ]
51 [ [ second ] dip first x < not ]
54 : y-in-bounds? ( min,max pairs -- ? )
55 [ y ] map minmax 2array
57 [ [ first ] dip second > not ]
58 [ [ second ] dip first < not ]
61 ! : xy-in-bounds? ( bounds pairs -- ? )
63 ! [ [ first ] dip x-in-bounds? ]
64 ! [ [ second ] dip y-in-bounds? ]
67 : calc-line-slope ( point1 point2 -- slope ) v- first2 swap / ;
68 : calc-y ( slope x point -- y ) first2 [ - * ] dip + ;
69 : calc-x ( slope y point -- x ) first2 swap [ - swap / ] dip + ;
70 : y-at ( x point1 point2 -- y ) dupd calc-line-slope -rot calc-y ;
71 : last2 ( seq -- penultimate ultimate ) 2 tail* first2 ;
73 ! Due to the way adjusted-tail-slice works, the first element of
74 ! pairs is <= xmin, and if the first is < xmin, then the second is
75 ! > xmin. Otherwise the first one would be = xmin.
76 : left-cut-x ( xmin pairs -- seq )
78 [ dupd first2 y-at 2array ] keep rest-slice swap prefix
83 ! Due to the way adjusted-head-slice works, the last element of
84 ! pairs is >= xmax, and if the last is > xmax, then the second to
85 ! last is < xmax. Otherwise the last one would be = xmax.
86 : right-cut-x ( xmax pairs -- seq )
88 [ dupd last2 y-at 2array ] keep but-last-slice swap suffix
93 ! If the line spans beyond min or max, make sure there are points
94 ! with x = min and x = max in seq.
95 : min-max-cut ( min,max pairs -- seq )
96 [ first2 ] dip right-cut-x left-cut-x ;
98 : clip-by-x ( min,max pairs -- pairs' )
100 [ dup first ] dip [ search-first? not ] keep
102 [ dup second ] dip [ search-first? not ] keep
104 dup length 1 > [ min-max-cut ] [ nip ] if
105 dup slice? [ dup like ] when
110 : between<=> ( value min max -- <=> )
111 3dup between? [ 3drop +eq+ ] [ nip > +gt+ +lt+ ? ] if ;
113 : calc-point-y ( slope y point -- xy ) over [ calc-x ] dip 2array ;
115 : xyy>chunk ( x y1 y2 -- chunk )
116 overd 2array [ 2array ] dip 2array ;
118 :: 2-point-chunk ( left right ymin ymax -- chunk )
119 left last :> left-point
120 right first :> right-point
121 left-point x right-point x = [
122 left-point x ymin ymax xyy>chunk
124 left-point right-point calc-line-slope :> slope
125 slope ymin left-point calc-point-y
126 slope ymax left-point calc-point-y
127 left-point y right-point y > [ swap ] when 2array
130 :: fix-left-chunk ( left right ymin ymax -- left' )
131 left last :> left-point
132 right first :> right-point
133 left-point y right-point y {
134 [ { [ drop ymin = ] [ > ] } 2&& ]
135 [ { [ drop ymax = ] [ < ] } 2&& ]
139 left-point y right-point y > ymin ymax ? :> y-coord
140 left-point x right-point x = [
141 left-point x y-coord 2array
143 left-point right-point calc-line-slope
144 y-coord left-point calc-point-y
149 :: fix-right-chunk ( left right ymin ymax -- right' )
150 left last :> left-point
151 right first :> right-point
152 left-point y right-point y {
153 [ { [ ymin = nip ] [ < ] } 2&& ]
154 [ { [ ymax = nip ] [ > ] } 2&& ]
158 left-point y right-point y < ymin ymax ? :> y-coord
159 left-point x right-point x = [
160 right-point x y-coord 2array
162 left-point right-point calc-line-slope
163 y-coord left-point calc-point-y
168 : first-point ( chunks -- first-point ) first first ;
170 : last-point ( chunks -- last-point ) last last ;
172 :: (make-pair) ( prev next min max -- next' )
174 prev next [ first y min max between<=> ] bi@ 2array
176 { { +gt+ +eq+ } [ fix-right-chunk ] }
177 { { +lt+ +eq+ } [ fix-right-chunk ] }
178 { { +eq+ +gt+ } [ fix-left-chunk , next ] }
179 { { +eq+ +lt+ } [ fix-left-chunk , next ] }
180 { { +gt+ +lt+ } [ 2-point-chunk , next ] }
181 { { +lt+ +gt+ } [ 2-point-chunk , next ] }
182 [ drop "same values - can't happen" throw ]
185 ! Drop chunks that are out of bounds, add extra points where needed.
186 :: (drawable-chunks) ( chunks min max -- chunks' )
190 chunks first-point y min max between?
196 chunks [ ] [ min max (make-pair) ] map-reduce
197 dup first y min max between? [ , ] [ drop ] if
202 ! Split data into chunks to be drawn within the [ymin,ymax] limits.
203 ! Return the (empty?) sequence of chunks, possibly with some new
204 ! points at ymin and ymax at the gap bounds.
205 : drawable-chunks ( data ymin,ymax -- chunks )
207 '[ [ y _ _ between<=> ] bi@ = ]
208 monotonic-split-slice
209 ] 2keep (drawable-chunks) ;
211 : flip-y-axis ( chunks ymin,ymax -- chunks )
212 first2 + '[ [ _ swap - ] assoc-map ] map ;
214 ! Return quotation that can be used in map operation.
215 : scale-mapper ( width min,max -- quot: ( value -- value' ) )
216 first2 swap '[ _ swap _ _ scale ] ; inline
218 ! Sometimes no scaling is needed.
219 ! : scale-mapper ( width min,max -- quot: ( value -- value' ) )
220 ! first2 swap 3dup - = [
223 ! '[ _ swap _ _ scale ]
226 : scale-chunks ( chunks xwidth xmin,xmax yheight ymin,ymax -- chunks' )
227 [ scale-mapper ] 2bi@ '[ [ _ _ bi* ] assoc-map ] map ;
231 : draw-line ( seq -- )
232 dup [ but-last-slice ] over length odd? [ dip ] [ call ] if
234 [ (line-vertices) gl-vertex-pointer GL_LINES 0 ] keep
235 length glDrawArrays ;
237 ! bounds: { { xmin xmax } { ymin ymax } }
238 : clip-data ( bounds data -- data' )
240 dupd [ first ] dip clip-by-x
242 [ second ] dip [ y-in-bounds? ] keep swap
248 dup parent>> dup chart? [| line chart |
250 COLOR: black line [ default-color ] [ data>> ] bi
251 dupd clip-data swap second [ drawable-chunks ] keep
253 chart chart-dim first2 [ chart chart-axes first2 ] dip swap