extra/ui/gadgets/charts/lines/lines.factor

   1 ! Copyright (C) 2016-2017 Alexander Ilin.
   2 ! See http://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
  10
  11 SPECIALIZED-ARRAY: c:float
  12
  13 ! Data must be a sequence of { x y } coordinates sorted by
  14 ! non-descending x vaues.
  15 TUPLE: line < gadget color data ;
  16
  17 <PRIVATE
  18
  19 : (line-vertices) ( seq -- vertices )
  20     concat [ 0.3 + ] float-array{ } map-as ;
  21
  22 ALIAS: x first
  23 ALIAS: y second
  24
  25 : search-first ( elt seq -- index elt )
  26     [ first <=> ] with search ;
  27
  28 : search-first? ( elt seq -- index elt exact-match? )
  29     dupd search-first rot [ dup first ] dip = ;
  30
  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* ;
  36
  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 short head-slice ] when* ;
  42
  43 ! : data-rect ( data -- rect )
  44 !    [ [ first x ] [ last x ] bi ] keep
  45 !    [ y ] map minmax swapd
  46 !    [ 2array ] bi@ <extent-rect> ;
  47
  48 : x-in-bounds? ( min,max pairs -- ? )
  49     {
  50         [ [ first ] dip last x > not ]
  51         [ [ second ] dip first x < not ]
  52     } 2&& ;
  53
  54 : y-in-bounds? ( min,max pairs -- ? )
  55     [ y ] map minmax 2array
  56     {
  57         [ [ first ] dip second > not ]
  58         [ [ second ] dip first < not ]
  59     } 2&& ;
  60
  61 ! : xy-in-bounds? ( bounds pairs -- ? )
  62 !    {
  63 !        [ [ first ] dip x-in-bounds? ]
  64 !        [ [ second ] dip y-in-bounds? ]
  65 !    } 2&& ;
  66
  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 ;
  72
  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 )
  77     2dup first x > [
  78         [ dupd first2 y-at 2array ] keep rest-slice swap prefix
  79     ] [
  80         nip
  81     ] if ;
  82
  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 )
  87     2dup last x < [
  88         [ dupd last2 y-at 2array ] keep but-last-slice swap suffix
  89     ] [
  90         nip
  91     ] if ;
  92
  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 ;
  97
  98 : clip-by-x ( min,max pairs -- pairs' )
  99     2dup x-in-bounds? [
 100         [ dup first ] dip [ search-first? not ] keep
 101         adjusted-tail-slice
 102         [ dup second ] dip [ search-first? not ] keep
 103         adjusted-head-slice
 104         dup length 1 > [ min-max-cut ] [ nip ] if
 105         dup slice? [ dup like ] when
 106     ] [
 107         2drop { }
 108     ] if ;
 109
 110 : between<=> ( value min max -- <=> )
 111     3dup between? [ 3drop +eq+ ] [ nip > +gt+ +lt+ ? ] if ;
 112
 113 : calc-point-y ( slope y point -- xy ) over [ calc-x ] dip 2array ;
 114
 115 : xyy>chunk ( x y1 y2 -- chunk )
 116     overd 2array [ 2array ] dip 2array ;
 117
 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
 123     ] [
 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
 128     ] if ;
 129
 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&& ]
 136     } 2|| [
 137         left
 138     ] [
 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
 142         ] [
 143             left-point right-point calc-line-slope
 144             y-coord left-point calc-point-y
 145         ] if
 146         left swap suffix
 147     ] if ;
 148
 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&& ]
 155     } 2|| [
 156         right
 157     ] [
 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
 161         ] [
 162             left-point right-point calc-line-slope
 163             y-coord left-point calc-point-y
 164         ] if
 165         right swap prefix
 166     ] if ;
 167
 168 : first-point ( chunks -- first-point ) first first ;
 169
 170 : last-point ( chunks -- last-point ) last last ;
 171
 172 :: (make-pair) ( prev next min max -- next' )
 173     prev next min max
 174     prev next [ first y min max between<=> ] bi@ 2array
 175     {
 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 ]
 183     } case ;
 184
 185 ! Drop chunks that are out of bounds, add extra points where needed.
 186 :: (drawable-chunks) ( chunks min max -- chunks' )
 187     chunks length {
 188         { 0 [ chunks ] }
 189         { 1 [
 190                 chunks first-point y min max between?
 191                 chunks { } ?
 192             ]
 193         }
 194         [
 195             drop [
 196                 chunks [ ] [ min max (make-pair) ] map-reduce
 197                 dup first y min max between? [ , ] [ drop ] if
 198             ] { } make
 199         ]
 200     } case ;
 201
 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 )
 206     first2 [
 207         '[ [ y _ _ between<=> ] bi@ = ]
 208         monotonic-split-slice
 209     ] 2keep (drawable-chunks) ;
 210
 211 : flip-y-axis ( chunks ymin,ymax -- chunks )
 212     first2 + '[ [ _ swap - ] assoc-map ] map ;
 213
 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
 217
 218 ! Sometimes no scaling is needed.
 219 ! : scale-mapper ( width min,max -- quot: ( value -- value' ) )
 220 !    first2 swap 3dup - = [
 221 !        3drop [ ]
 222 !    ] [
 223 !        '[ _ swap _ _ scale ]
 224 !    ] if ; inline
 225
 226 : scale-chunks ( chunks xwidth xmin,xmax yheight ymin,ymax -- chunks' )
 227     [ scale-mapper ] 2bi@ '[ [ _ _ bi* ] assoc-map ] map ;
 228
 229 PRIVATE>
 230
 231 : draw-line ( seq -- )
 232     dup [ but-last-slice ] over length odd? [ dip ] [ call ] if
 233     rest-slice append
 234     [ (line-vertices) gl-vertex-pointer GL_LINES 0 ] keep
 235     length glDrawArrays ;
 236
 237 ! bounds: { { xmin xmax } { ymin ymax } }
 238 : clip-data ( bounds data -- data' )
 239     dup empty? [ nip ] [
 240         dupd [ first ] dip clip-by-x
 241         dup empty? [ nip ] [
 242             [ second ] dip [ y-in-bounds? ] keep swap
 243             [ drop { } ] unless
 244         ] if
 245     ] if ;
 246
 247 M: line draw-gadget*
 248     dup parent>> dup chart? [| line chart |
 249         chart chart-axes
 250         COLOR: black line [ default-color ] [ data>> ] bi
 251         dupd clip-data swap second [ drawable-chunks ] keep
 252         flip-y-axis
 253         chart chart-dim first2 [ chart chart-axes first2 ] dip swap
 254         scale-chunks
 255         [ draw-line ] each
 256     ] [ 2drop ] if ;