+++ /dev/null
-Alexander Ilin
+++ /dev/null
-! Copyright (C) 2017 Alexander Ilin.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test charts ;
-IN: charts.tests
+++ /dev/null
-! Copyright (C) 2016-2017 Alexander Ilin.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel sequences ui.gadgets ;
-IN: charts
-
-TUPLE: chart < gadget axes ;
-
-M: chart pref-dim* drop { 300 300 } ;
-
-! Return the x and y ranges of the visible area.
-: chart-axes ( chart -- seq )
- [ dim>> ] [ axes>> ] bi [
- nip
- ] [
- [ 0 swap 2array ] map
- ] if* ;
-
-! Return the { width height } of the visible area, in pixels.
-: chart-dim ( chart -- seq ) dim>> ;
-
-! There are several things to do to present data on the screen.
-! Map the data coordinates to the screen coordinates.
-! Cut off data outside the presentation window. When cutting off vertically, split the line into segments and add new points if necessary. Return an array of line segments.
-! Remove redundant points from the drawing pass.
+++ /dev/null
-Alexander Ilin
+++ /dev/null
-! Copyright (C) 2017 Alexander Ilin.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays charts charts.lines colors.constants
-kernel literals locals math math.constants math.functions
-sequences ui ui.gadgets ;
-IN: charts.demos
-
-CONSTANT: -pi $[ pi neg ]
-
-: sine-wave ( steps -- seq )
- [ iota ] keep
- pi 2 * swap / [ * pi - dup sin 2array ] curry map
- ${ pi $[ pi sin ] } suffix ;
-
-: cosine-wave ( steps -- seq )
- [ iota ] keep
- pi 2 * swap / [ * pi - dup cos 2array ] curry map
- ${ pi $[ pi cos ] } suffix ;
-
-<PRIVATE
-
-:: (chart-demo) ( n -- )
- chart new ${ ${ -pi pi } { -1 1 } } >>axes
- line new COLOR: blue >>color n sine-wave >>data add-gadget
- line new COLOR: red >>color n cosine-wave >>data add-gadget
- "Chart" open-window ;
-
-PRIVATE>
-
-: chart-demo ( -- ) 40 (chart-demo) ;
-
-MAIN: chart-demo
-
-! chart new line new COLOR: blue >>color { { 0 100 } { 100 0 } { 100 50 } { 150 50 } { 200 100 } } >>data add-gadget "Chart" open-window
+++ /dev/null
-graphics
-demos
--- /dev/null
+Alexander Ilin
--- /dev/null
+! Copyright (C) 2017 Alexander Ilin.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test ui.gadgets.charts ;
+IN: ui.gadgets.charts.tests
--- /dev/null
+! Copyright (C) 2016-2017 Alexander Ilin.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel sequences ui.gadgets ;
+IN: ui.gadgets.charts
+
+TUPLE: chart < gadget axes ;
+
+M: chart pref-dim* drop { 300 300 } ;
+
+! Return the x and y ranges of the visible area.
+: chart-axes ( chart -- seq )
+ [ dim>> ] [ axes>> ] bi [
+ nip
+ ] [
+ [ 0 swap 2array ] map
+ ] if* ;
+
+! Return the { width height } of the visible area, in pixels.
+: chart-dim ( chart -- seq ) dim>> ;
+
+! There are several things to do to present data on the screen.
+! Map the data coordinates to the screen coordinates.
+! Cut off data outside the presentation window. When cutting off vertically, split the line into segments and add new points if necessary. Return an array of line segments.
+! Remove redundant points from the drawing pass.
--- /dev/null
+Alexander Ilin
--- /dev/null
+! Copyright (C) 2017 Alexander Ilin.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays colors.constants kernel literals locals
+math math.constants math.functions sequences ui ui.gadgets
+ui.gadgets.charts ui.gadgets.charts.lines ;
+IN: ui.gadgets.charts.demos
+
+CONSTANT: -pi $[ pi neg ]
+
+: sine-wave ( steps -- seq )
+ [ iota ] keep
+ pi 2 * swap / [ * pi - dup sin 2array ] curry map
+ ${ pi $[ pi sin ] } suffix ;
+
+: cosine-wave ( steps -- seq )
+ [ iota ] keep
+ pi 2 * swap / [ * pi - dup cos 2array ] curry map
+ ${ pi $[ pi cos ] } suffix ;
+
+<PRIVATE
+
+:: (chart-demo) ( n -- )
+ chart new ${ ${ -pi pi } { -1 1 } } >>axes
+ line new COLOR: blue >>color n sine-wave >>data add-gadget
+ line new COLOR: red >>color n cosine-wave >>data add-gadget
+ "Chart" open-window ;
+
+PRIVATE>
+
+: chart-demo ( -- ) 40 (chart-demo) ;
+
+MAIN: chart-demo
+
+! chart new line new COLOR: blue >>color { { 0 100 } { 100 0 } { 100 50 } { 150 50 } { 200 100 } } >>data add-gadget "Chart" open-window
--- /dev/null
+graphics
+demos
--- /dev/null
+Alexander Ilin
--- /dev/null
+! Copyright (C) 2017 Alexander Ilin.
+! See http://factorcode.org/license.txt for BSD license.
+USING: binary-search colors help.markup help.syntax kernel
+sequences splitting.monotonic ui.gadgets ui.gadgets.charts
+ui.gadgets.charts.lines.private ui.render ;
+IN: ui.gadgets.charts.lines
+
+ABOUT: { "ui.gadgets.charts.lines" "about" }
+
+ARTICLE: { "ui.gadgets.charts.lines" "about" } "Lines"
+" The " { $vocab-link "ui.gadgets.charts.lines" } " vocab implements the " { $link line } " gadget. See the " { $link { "charts.lines" "implementation" } } "." ;
+
+ARTICLE: { "charts.lines" "implementation" } "Implementation details"
+"The " { $slot "data" } " in a " { $link line } " gadget should be sorted by non-descending " { $snippet "x" } " coordinate. In a large data set this allows to quickly find the left and right intersection points with the viewport using binary " { $link search } " and remove the irrelevant data from further processing: " { $link clip-by-x } ". If the resulting sequence is empty (i.e. the entire data set is completely to the left or to the right of the viewport), nothing is drawn (" { $link x-in-bounds? } ")."
+$nl
+"If there are several points with the same " { $snippet "x" } " coordinate matching " { $snippet "xmin" } ", the leftmost of those is found and included in the resulting set (" { $link adjusted-head-slice } "). The same adjustment is done for the right point if it matches " { $snippet "xmax" } ", only this time the rightmost is searched for (" { $link adjusted-tail-slice } ")."
+$nl
+"If there are no points with either the " { $snippet "xmin" } " or the " { $snippet "xmax" } " coordinate, and the line spans beyond the viewport in either of those directions, the corresponding points are calculated and added to the data set (" { $link min-max-cut } ")."
+$nl
+"After we've got a subset of data that's completely within the " { $snippet "[xmin,xmax]" } " bounds, we check if the resulting data are completely above or completely below the viewport (" { $link y-in-bounds? } "), and if so, nothing is drawn. This involves finding the minimum and maximum " { $snippet "y" } " values by traversing the remaining data, which is why it's important to cut away the irrelevant data first and to make sure the " { $snippet "y" } " coordinates for the points at " { $snippet "xmin" } " and " { $snippet "xmax" } " are in the data set. All of the above is done by " { $link clip-data } "."
+$nl
+"At this point either the data set is empty, or there is at least some intersection between the data and the viewport. The task of the next step is to produce a sequence of lines that can be drawn on the viewport. The " { $link drawable-chunks } " word cuts away all the data outside the viewport, adding the intersection points where necessary. It does so by first grouping the data points into subsequences (chunks), in which all points are either above, below or within the " { $snippet "[ymin,ymax]" } " limits (" { $link monotonic-split-slice } " using " { $link between<=> } ")."
+$nl
+"Those chunks are then examined pairwise by " { $link (drawable-chunks) } " and edge points are calculated and added where necessary by " { $link (make-pair) } ". For example, if a chunk is within the viewport, and the next one is above the viewport, then a point should be added to the end of the first chunk, connecting its last point to the point of the viewport boundary intersection (" { $link fix-left-chunk } ", and " { $link fix-right-chunk } " for the opposite case). If a chunk is below the viewport, and the next one is above the viewport (or vice versa), then a new 2-point chunk should be created so that the intersecting line would be drawn within the viewport boundaries (" { $link 2-point-chunk } ")."
+$nl
+"The data are now filtered down to contain only the subset that is relevant to the currently chosen visible range, and is split into chunks that can each be drawn in a single contuguous stroke."
+$nl
+"Since the display uses inverted coordinate system, with " { $snippet "y" } " = 0 at the top of the screen, and growing downwards, we need to flip the data along the horizontal center line (" { $link flip-y-axis } ")."
+$nl
+"Finally, the data needs to be scaled so that its coordinates are mapped to the screen coordinates (" { $link scale-chunks } "). This last step could probably be combined with flipping the " { $snippet "y" } " coordinate for extra performance."
+$nl
+"The resulting chunks are displayed with a call to " { $link draw-line } " each."
+;
+
+HELP: clip-data
+{ $values
+ { "bounds" "{ { xmin xmax } { ymin ymax } }" }
+ { "data" { $link sequence } " of { x y } pairs sorted by non-descending x" }
+ { "data'" "possibly empty subsequence of " { $snippet "data" } }
+}
+{ $description "Filter the " { $snippet "data" } " by first removing all points outside the " { $snippet "[xmin,xmax]" } " range, and then making sure that the remaining " { $snippet "y" } " values are not entirely above or below the " { $snippet "[ymin,ymax]" } " range." } ;
+
+HELP: draw-line
+{ $values
+ { "seq" { $link sequence } " of { x y } pairs, in pixels" }
+}
+{ $description "Draw a sequence of straight line segments connecting all consecutive points with a single OpenGL call. Intended to be called by a " { $link draw-gadget* } " implementation." } ;
+
+HELP: line
+{ $class-description "This is a " { $link gadget } " which, when added as a child to the " { $link chart } ", will display its data as straight line segments. The implementation is oriented towards speed to allow large data sets to be displayed as quickly as possible."
+$nl
+"Slots:"
+{ $list
+ { { $slot "data" } " - a " { $link sequence } " of { x y } pairs sorted by non-descending x;" }
+ { { $slot "data" } " - a " { $link color } " to draw the line with." }
+} } ;
+
+HELP: y-at
+{ $description "Given two points on a straight line and an " { $snippet "x" } " coordinate, calculate the " { $snippet "y" } " coordinate at " { $snippet "x" } " on that line." }
+{ $examples
+ { $example
+ "USING: ui.gadgets.charts.lines.private prettyprint ;"
+ "0 { 1 1 } { 5 5 } y-at ."
+ "0"
+ }
+ { $example
+ "USING: ui.gadgets.charts.lines.private prettyprint ;"
+ "3 { 0 5 } { 5 5 } y-at ."
+ "5"
+ }
+ { $example
+ "USING: ui.gadgets.charts.lines.private prettyprint ;"
+ "12 { 12 50 } { 15 15 } y-at ."
+ "50"
+ }
+} ;
+
+HELP: calc-x
+{ $description "Given the " { $snippet "slope" } " of a line and a random " { $snippet "point" } " belonging to that line, calculate the " { $snippet "x" } " coordinate corresponding to the given " { $snippet "y" } "." }
+{ $examples
+ { $example
+ "USING: ui.gadgets.charts.lines.private prettyprint ;"
+ "1 5 { 1 1 } calc-x ."
+ "5"
+ }
+ { $example
+ "USING: ui.gadgets.charts.lines.private prettyprint ;"
+ "0.5 10 { 0 0 } calc-x ."
+ "20.0"
+ }
+} ;
+
+HELP: calc-y
+{ $description "Given the " { $snippet "slope" } " of a line and a random " { $snippet "point" } " belonging to that line, calculate the " { $snippet "y" } " coordinate corresponding to the given " { $snippet "x" } "." }
+{ $examples
+ { $example
+ "USING: ui.gadgets.charts.lines.private prettyprint ;"
+ "1 5 { 1 1 } calc-y ."
+ "5"
+ }
+ { $example
+ "USING: ui.gadgets.charts.lines.private prettyprint ;"
+ "0.5 20 { 0 0 } calc-y ."
+ "10.0"
+ }
+} ;
+
+HELP: calc-line-slope
+{ $description "Given the two points belonging to a straight line, calculate the " { $snippet "slope" } " of the line, assuming the line equation is " { $snippet "y(x) = slope * x + b" } "."
+$nl
+"The formula for the calculation is " { $snippet "slope = (y1-y2) / (x1-x2)" } ", therefore it'll throw a division by zero error if both points have the same " { $snippet "x" } " coordinate." }
+{ $examples
+ { $example
+ "USING: ui.gadgets.charts.lines.private prettyprint ;"
+ "{ 1 1 } { 10 10 } calc-line-slope ."
+ "1"
+ }
+ { $example
+ "USING: ui.gadgets.charts.lines.private prettyprint ;"
+ "{ 0 0 } { 10 20 } calc-line-slope ."
+ "2"
+ }
+} ;
+
+{ calc-line-slope y-at calc-x calc-y } related-words
--- /dev/null
+! Copyright (C) 2017 Alexander Ilin.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences tools.test
+ui.gadgets.charts.lines ui.gadgets.charts.lines.private ;
+IN: ui.gadgets.charts.lines.tests
+
+{ -2/3 } [ { 1 3 } { -2 5 } calc-line-slope ] unit-test
+{ 3 } [ -2/3 1 { 1 3 } calc-y ] unit-test
+{ 5 } [ -2/3 -2 { 1 3 } calc-y ] unit-test
+{ 3 } [ -2/3 1 { -2 5 } calc-y ] unit-test
+{ 5 } [ -2/3 -2 { -2 5 } calc-y ] unit-test
+{ 5 } [ -2 { 1 3 } { -2 5 } y-at ] unit-test
+{ 3 } [ 1 { 1 3 } { -2 5 } y-at ] unit-test
+{ 1 } [ 4 { -2 5 } { 1 3 } y-at ] unit-test
+{ 0.0 } [ 5.5 { -2 5 } { 1 3 } y-at ] unit-test
+{ 1 } [ -2/3 3 { 1 3 } calc-x ] unit-test
+{ -2 } [ -2/3 5 { 1 3 } calc-x ] unit-test
+{ 1 } [ -2/3 3 { -2 5 } calc-x ] unit-test
+{ -2 } [ -2/3 5 { -2 5 } calc-x ] unit-test
+
+{ 2 3 } [ { 1 2 3 } last2 ] unit-test
+{ 1 2 } [ { 1 2 } last2 ] unit-test
+[ { 1 } last2 ] must-fail
+[ { } last2 ] must-fail
+
+! 2-point-chunk upwards
+{
+ { { -3 -3 } { 3 3 } }
+} [
+ { { -6 0 } { -5 -5 } } { { 5 5 } { 6 0 } }
+ -3 3 2-point-chunk
+] unit-test
+
+! 2-point-chunk downwards
+{
+ { { -3 3 } { 3 -3 } }
+} [
+ { { -6 0 } { -5 5 } } { { 5 -5 } { 6 0 } }
+ -3 3 2-point-chunk
+] unit-test
+
+! 2-point-chunk: same x coord
+{
+ { { -5 -3 } { -5 3 } }
+} [
+ { { -6 0 } { -5 -5 } } { { -5 5 } { 6 0 } }
+ -3 3 2-point-chunk
+] unit-test
+
+! fix-left-chunk: y coord = top limit
+{
+ { { -6 0 } { -3 3 } }
+} [
+ { { -6 0 } { -3 3 } } { { 5 5 } { 6 6 } }
+ -3 3 fix-left-chunk
+] unit-test
+
+! fix-left-chunk: y coord = bottom limit
+{
+ { { -6 0 } { -3 -3 } }
+} [
+ { { -6 0 } { -3 -3 } } { { 5 -5 } { 6 -6 } }
+ -3 3 fix-left-chunk
+] unit-test
+
+! fix-left-chunk: going upwards
+{
+ { { -6 0 } { 2 2 } { 3 3 } }
+} [
+ { { -6 0 } { 2 2 } } { { 5 5 } { 6 6 } }
+ -3 3 fix-left-chunk
+] unit-test
+
+! fix-left-chunk: going downwards
+{
+ { { -6 0 } { -2 -2 } { -1 -3 } }
+} [
+ { { -6 0 } { -2 -2 } } { { 0 -4 } { 6 -6 } }
+ -3 3 fix-left-chunk
+] unit-test
+
+! TODO: add more tests for the recently discovered bugs in fix-left-chunk and fix-right-chunk
+
+! fix-right-chunk: y coord = top limit
+{
+ { { 5 3 } { 6 0 } }
+} [
+ { { -6 6 } { -3 4 } } { { 5 3 } { 6 0 } }
+ -3 3 fix-right-chunk
+] unit-test
+
+! fix-right-chunk: y coord = bottom limit
+{
+ { { 5 -3 } { 6 0 } }
+} [
+ { { -6 -6 } { -3 -4 } } { { 5 -3 } { 6 0 } }
+ -3 3 fix-right-chunk
+] unit-test
+
+! fix-right-chunk: going upwards
+{
+ { { -3 -3 } { -2 -2 } { 6 0 } }
+} [
+ { { -6 -6 } { -4 -4 } } { { -2 -2 } { 6 0 } }
+ -3 3 fix-right-chunk
+] unit-test
+
+! fix-right-chunk: going downwards
+{
+ { { -3 3 } { -2 2 } { 6 0 } }
+} [
+ { { -6 6 } { -4 4 } } { { -2 2 } { 6 0 } }
+ -3 3 fix-right-chunk
+] unit-test
+
+! tight bounds
+{
+ { { { 0 0 } { 0 1 } { 1 2 } { 1 3 } { 2 5 } } }
+} [
+ { { 0 0 } { 0 1 } { 1 2 } { 1 3 } { 2 5 } } { 0 5 }
+ drawable-chunks [ { } like ] map
+] unit-test
+
+! loose bounds
+{
+ { { { 0 0 } { 0 1 } { 1 2 } { 1 3 } { 2 5 } } }
+} [
+ { { 0 0 } { 0 1 } { 1 2 } { 1 3 } { 2 5 } } { -1 6 }
+ drawable-chunks [ { } like ] map
+] unit-test
+
+! only bottom element accepted
+{
+ { { { 0 0 } } }
+} [
+ { { 0 0 } { 0 1 } { 1 2 } { 1 3 } { 2 5 } } { -1 0 }
+ drawable-chunks [ { } like ] map
+] unit-test
+
+! only top element accepted
+{
+ { { { 2 5 } } }
+} [
+ { { 0 0 } { 0 1 } { 1 2 } { 1 3 } { 2 5 } } { 5 10 }
+ drawable-chunks [ { } like ] map
+] unit-test
+
+! top half of the elements accepted
+{
+ { { { 1 2 } { 1 3 } { 2 5 } } }
+} [
+ { { 0 0 } { 0 1 } { 1 2 } { 1 3 } { 2 5 } } { 2 10 }
+ drawable-chunks [ { } like ] map
+] unit-test
+
+! bottom half of the elements accepted
+{
+ { { { 0 0 } { 0 1 } { 1 2 } } }
+} [
+ { { 0 0 } { 0 1 } { 1 2 } { 1 3 } { 2 5 } } { -2 2 }
+ drawable-chunks [ { } like ] map
+] unit-test
+
+! middle section of the elements accepted
+{
+ { { { 0 1 } { 1 2 } { 1 3 } } }
+} [
+ { { 0 0 } { 0 1 } { 1 2 } { 1 3 } { 2 5 } } { 1 3 }
+ drawable-chunks [ { } like ] map
+] unit-test
+
+! two sections, including first but not last
+{
+ {
+ { { 0 0 } { 1 2 } { 2 3 } }
+ { { 5 3 } { 6 2 } { 7 0 } }
+ }
+} [
+ { { 0 0 } { 1 2 } { 2 3 } { 3 5 } { 4 5 } { 5 3 } { 6 2 } { 7 0 } { 8 -1 } { 9 -2 } } { 0 3 }
+ drawable-chunks [ { } like ] map
+] unit-test
+
+! two sections, including last but not first
+{
+ {
+ { { 2 0 } { 3 3 } { 4 3 } }
+ { { 7 3 } { 8 2 } { 9 0 } }
+ }
+} [
+ { { 0 -2 } { 1 -1 } { 2 0 } { 3 3 } { 4 3 } { 5 5 } { 6 9 } { 7 3 } { 8 2 } { 9 0 } } { 0 3 }
+ drawable-chunks [ { } like ] map
+] unit-test
+
+! single-element sequences, same x coord
+{
+ {
+ { { 0 0 } { 0 3 } }
+ { { 0 3 } { 0 0 } }
+ }
+} [
+ { { 0 -2 } { 0 0 } { 0 5 } { 0 3 } { 0 -1 } } { 0 3 }
+ drawable-chunks [ { } like ] map
+] unit-test
+
+! single point sticks out to within the limits from below
+{
+ {
+ { { 1 1 } { 2 2 } { 3 1 } }
+ }
+} [
+ { { 0 0 } { 2 2 } { 4 0 } } { 1 5 }
+ drawable-chunks [ { } like ] map
+] unit-test
+
+! single point sticks out to within the limits from above
+{
+ {
+ { { 1 3 } { 2 2 } { 3 3 } }
+ }
+} [
+ { { 0 4 } { 2 2 } { 4 4 } } { 1 3 }
+ drawable-chunks [ { } like ] map
+] unit-test
+
+{
+ { { { 0 300 } { 1 200 } { 2 150 } { 3 100 } { 4 0 } } }
+} [
+ { { { 0 0 } { 1 100 } { 2 150 } { 3 200 } { 4 300 } } }
+ { 0 300 } flip-y-axis
+] unit-test
+
+{
+ { 0 30 60 90 120 150 180 210 240 270 300 }
+} [
+ 11 iota [ 10 + ] map [ 300 swap 20 10 scale ] map
+] unit-test
+
+{ { } }
+[ { } { } clip-data ] unit-test
+
+{ { } }
+[ { { 0 1 } { 0 5 } } { } clip-data ] unit-test
+
+! Adjustment after search is required in both directions.
+{
+ {
+ { 1 3 } { 1 4 } { 1 5 }
+ { 2 6 } { 3 7 } { 4 8 }
+ { 5 9 } { 5 10 } { 5 11 } { 5 12 }
+ }
+} [
+ { { 1 5 } { 0 14 } }
+ {
+ { 0 1 } { 0 2 }
+ { 1 3 } { 1 4 } { 1 5 }
+ { 2 6 } { 3 7 } { 4 8 }
+ { 5 9 } { 5 10 } { 5 11 } { 5 12 }
+ { 6 13 } { 7 14 }
+ } clip-data
+] unit-test
+
+! no points within the viewport, complete calculation
+{
+ { { 1 1 } { 4 4 } }
+} [
+ { { 1 4 } { 1 4 } }
+ { { 0 0 } { 5 5 } } clip-data
+] unit-test
+
+! no points within the viewport, complete calculation
+{
+ { { 1 4 } { 4 1 } }
+} [
+ { { 1 4 } { 1 4 } }
+ { { 0 5 } { 5 0 } } clip-data
+] unit-test
+
+! no points within the viewport, complete calculation
+{
+ { { 1 3 } { 4 3 } }
+} [
+ { { 1 4 } { 1 4 } }
+ { { 0 3 } { 5 3 } } clip-data
+] unit-test
+
+! all data are to the left of viewport
+{
+ { }
+} [
+ { { 1 4 } { 1 4 } }
+ { { -1 0 } { 0 1 } { 0.5 1 } } clip-data
+] unit-test
+
+! all data are to the right of viewport
+{
+ { }
+} [
+ { { 1 4 } { 1 4 } }
+ { { 4.5 0 } { 5 1 } { 6 1 } } clip-data
+] unit-test
+
+! just a little off the top
+{ t } [
+ { 0 99 }
+ { { 0 100 } { 100 0 } { 100 50 } { 150 50 } { 200 100 } }
+ y-in-bounds?
+] unit-test
+
+! TODO: add tests where after search there is no adjustment necessary, so that extra adjustment would take bad elements.
--- /dev/null
+! Copyright (C) 2016-2017 Alexander Ilin.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs binary-search combinators
+combinators.short-circuit fry kernel locals make math math.order
+math.statistics math.vectors namespaces opengl opengl.gl
+sequences specialized-arrays.instances.alien.c-types.float
+splitting.monotonic ui.gadgets ui.gadgets.charts ui.render ;
+IN: ui.gadgets.charts.lines
+
+! Data must be a sequence of { x y } coordinates sorted by
+! non-descending x vaues.
+TUPLE: line < gadget color data ;
+
+<PRIVATE
+
+: (line-vertices) ( seq -- vertices )
+ concat [ 0.3 + ] float-array{ } map-as ;
+
+ALIAS: x first
+ALIAS: y second
+
+: search-first ( elt seq -- index elt )
+ [ first <=> ] with search ;
+
+: search-first? ( elt seq -- index elt exact-match? )
+ dupd search-first rot [ dup first ] dip = ;
+
+! Return a slice of the seq with all elements equal to elt to the
+! left of the index, plus one that's not equal, if requested.
+:: adjusted-tail-slice ( n elt plus-one? seq -- slice )
+ n seq elt x '[ x _ = not ] find-last-from drop seq swap
+ [ plus-one? [ 1 + ] unless tail-slice ] when* ;
+
+! Return a slice of the seq with all elements equal to elt to the
+! right of the index, plus one that's not equal, if requested.
+:: adjusted-head-slice ( n elt plus-one? seq -- slice )
+ n seq elt x '[ x _ = not ] find-from drop seq swap
+ [ plus-one? [ 1 + ] when short head-slice ] when* ;
+
+! : data-rect ( data -- rect )
+! [ [ first x ] [ last x ] bi ] keep
+! [ y ] map minmax swapd
+! [ 2array ] bi@ <extent-rect> ;
+
+: x-in-bounds? ( min,max pairs -- ? )
+ {
+ [ [ first ] dip last x > not ]
+ [ [ second ] dip first x < not ]
+ } 2&& ;
+
+: y-in-bounds? ( min,max pairs -- ? )
+ [ y ] map minmax 2array
+ {
+ [ [ first ] dip second > not ]
+ [ [ second ] dip first < not ]
+ } 2&& ;
+
+! : xy-in-bounds? ( bounds pairs -- ? )
+! {
+! [ [ first ] dip x-in-bounds? ]
+! [ [ second ] dip y-in-bounds? ]
+! } 2&& ;
+
+: calc-line-slope ( point1 point2 -- slope ) v- first2 swap / ;
+: calc-y ( slope x point -- y ) first2 [ - * ] dip + ;
+: calc-x ( slope y point -- x ) first2 swap [ - swap / ] dip + ;
+: y-at ( x point1 point2 -- y ) dupd calc-line-slope -rot calc-y ;
+: last2 ( seq -- penultimate ultimate ) 2 tail* first2 ;
+
+! Due to the way adjusted-tail-slice works, the first element of
+! pairs is <= xmin, and if the first is < xmin, then the second is
+! > xmin. Otherwise the first one would be = xmin.
+: left-cut-x ( xmin pairs -- seq )
+ 2dup first x > [
+ [ dupd first2 y-at 2array ] keep rest-slice swap prefix
+ ] [
+ nip
+ ] if ;
+
+! Due to the way adjusted-head-slice works, the last element of
+! pairs is >= xmax, and if the last is > xmax, then the second to
+! last is < xmax. Otherwise the last one would be = xmax.
+: right-cut-x ( xmax pairs -- seq )
+ 2dup last x < [
+ [ dupd last2 y-at 2array ] keep but-last-slice swap suffix
+ ] [
+ nip
+ ] if ;
+
+! If the line spans beyond min or max, make sure there are points
+! with x = min and x = max in seq.
+: min-max-cut ( min,max pairs -- seq )
+ [ first2 ] dip right-cut-x left-cut-x ;
+
+: clip-by-x ( min,max pairs -- pairs' )
+ 2dup x-in-bounds? [
+ [ dup first ] dip [ search-first? not ] keep
+ adjusted-tail-slice
+ [ dup second ] dip [ search-first? not ] keep
+ adjusted-head-slice
+ dup length 1 > [ min-max-cut ] [ nip ] if
+ dup slice? [ dup like ] when
+ ] [
+ 2drop { }
+ ] if ;
+
+: between<=> ( value min max -- <=> )
+ 3dup between? [ 3drop +eq+ ] [ nip > +gt+ +lt+ ? ] if ;
+
+: calc-point-y ( slope y point -- xy ) over [ calc-x ] dip 2array ;
+
+: xyy>chunk ( x y1 y2 -- chunk )
+ [ over ] dip 2array [ 2array ] dip 2array ;
+
+:: 2-point-chunk ( left right ymin ymax -- chunk )
+ left last :> left-point
+ right first :> right-point
+ left-point x right-point x = [
+ left-point x ymin ymax xyy>chunk
+ ] [
+ left-point right-point calc-line-slope :> slope
+ slope ymin left-point calc-point-y
+ slope ymax left-point calc-point-y
+ left-point y right-point y > [ swap ] when 2array
+ ] if ;
+
+:: fix-left-chunk ( left right ymin ymax -- left' )
+ left last :> left-point
+ right first :> right-point
+ left-point y right-point y {
+ [ { [ drop ymin = ] [ > ] } 2&& ]
+ [ { [ drop ymax = ] [ < ] } 2&& ]
+ } 2|| [
+ left
+ ] [
+ left-point y right-point y > ymin ymax ? :> y-coord
+ left-point x right-point x = [
+ left-point x y-coord 2array
+ ] [
+ left-point right-point calc-line-slope
+ y-coord left-point calc-point-y
+ ] if
+ left swap suffix
+ ] if ;
+
+:: fix-right-chunk ( left right ymin ymax -- right' )
+ left last :> left-point
+ right first :> right-point
+ left-point y right-point y {
+ [ { [ ymin = nip ] [ < ] } 2&& ]
+ [ { [ ymax = nip ] [ > ] } 2&& ]
+ } 2|| [
+ right
+ ] [
+ left-point y right-point y < ymin ymax ? :> y-coord
+ left-point x right-point x = [
+ right-point x y-coord 2array
+ ] [
+ left-point right-point calc-line-slope
+ y-coord left-point calc-point-y
+ ] if
+ right swap prefix
+ ] if ;
+
+: first-point ( chunks -- first-point ) first first ;
+
+: last-point ( chunks -- last-point ) last last ;
+
+:: (make-pair) ( prev next min max -- next' )
+ prev next min max
+ prev next [ first y min max between<=> ] bi@ 2array
+ {
+ { { +gt+ +eq+ } [ fix-right-chunk ] }
+ { { +lt+ +eq+ } [ fix-right-chunk ] }
+ { { +eq+ +gt+ } [ fix-left-chunk , next ] }
+ { { +eq+ +lt+ } [ fix-left-chunk , next ] }
+ { { +gt+ +lt+ } [ 2-point-chunk , next ] }
+ { { +lt+ +gt+ } [ 2-point-chunk , next ] }
+ [ drop "same values - can't happen" throw ]
+ } case ;
+
+! Drop chunks that are out of bounds, add extra points where needed.
+:: (drawable-chunks) ( chunks min max -- chunks' )
+ chunks length {
+ { 0 [ chunks ] }
+ { 1 [
+ chunks first-point y min max between?
+ chunks { } ?
+ ]
+ }
+ [
+ drop [
+ chunks [ ] [ min max (make-pair) ] map-reduce
+ dup first y min max between? [ , ] [ drop ] if
+ ] { } make
+ ]
+ } case ;
+
+! Split data into chunks to be drawn within the [ymin,ymax] limits.
+! Return the (empty?) sequence of chunks, possibly with some new
+! points at ymin and ymax at the gap bounds.
+: drawable-chunks ( data ymin,ymax -- chunks )
+ first2 [
+ '[ [ y _ _ between<=> ] bi@ = ]
+ monotonic-split-slice
+ ] 2keep (drawable-chunks) ;
+
+: flip-y-axis ( chunks ymin,ymax -- chunks )
+ first2 + '[ [ _ swap - ] assoc-map ] map ;
+
+! value' = (value - min) / (max - min) * width
+: scale ( width value max min -- value' ) neg [ + ] curry bi@ / * ;
+
+! Return quotation that can be used in map operation.
+: scale-mapper ( width min,max -- quot: ( value -- value' ) )
+ first2 swap '[ _ swap _ _ scale ] ; inline
+
+! Sometimes no scaling is needed.
+! : scale-mapper ( width min,max -- quot: ( value -- value' ) )
+! first2 swap 3dup - = [
+! 3drop [ ]
+! ] [
+! '[ _ swap _ _ scale ]
+! ] if ; inline
+
+: scale-chunks ( chunks xwidth xmin,xmax yheight ymin,ymax -- chunks' )
+ [ scale-mapper ] 2bi@ '[ [ _ _ bi* ] assoc-map ] map ;
+
+PRIVATE>
+
+: draw-line ( seq -- )
+ dup [ but-last-slice ] over length odd? [ dip ] [ call ] if
+ rest-slice append
+ [ (line-vertices) gl-vertex-pointer GL_LINES 0 ] keep
+ length glDrawArrays ;
+
+! bounds: { { xmin xmax } { ymin ymax } }
+: clip-data ( bounds data -- data' )
+ dup empty? [ nip ] [
+ dupd [ first ] dip clip-by-x
+ dup empty? [ nip ] [
+ [ second ] dip [ y-in-bounds? ] keep swap
+ [ drop { } ] unless
+ ] if
+ ] if ;
+
+M: line draw-gadget*
+ dup parent>> dup chart? [| line chart |
+ chart chart-axes
+ line [ color>> gl-color ] [ data>> ] bi
+ dupd clip-data swap second [ drawable-chunks ] keep
+ flip-y-axis
+ chart chart-dim first2 [ chart chart-axes first2 ] dip swap
+ scale-chunks
+ [ draw-line ] each
+ ] [ 2drop ] if ;
+++ /dev/null
-Alexander Ilin
+++ /dev/null
-! Copyright (C) 2017 Alexander Ilin.
-! See http://factorcode.org/license.txt for BSD license.
-USING: binary-search charts charts.lines.private colors
-help.markup help.syntax kernel sequences splitting.monotonic
-ui.gadgets ui.render ;
-IN: charts.lines
-
-ABOUT: { "charts.lines" "about" }
-
-ARTICLE: { "charts.lines" "about" } "Lines"
-" The " { $vocab-link "charts.lines" } " vocab implements the " { $link line } " gadget. See the " { $link { "charts.lines" "implementation" } } "." ;
-
-ARTICLE: { "charts.lines" "implementation" } "Implementation details"
-"The " { $slot "data" } " in a " { $link line } " gadget should be sorted by non-descending " { $snippet "x" } " coordinate. In a large data set this allows to quickly find the left and right intersection points with the viewport using binary " { $link search } " and remove the irrelevant data from further processing: " { $link clip-by-x } ". If the resulting sequence is empty (i.e. the entire data set is completely to the left or to the right of the viewport), nothing is drawn (" { $link x-in-bounds? } ")."
-$nl
-"If there are several points with the same " { $snippet "x" } " coordinate matching " { $snippet "xmin" } ", the leftmost of those is found and included in the resulting set (" { $link adjusted-head-slice } "). The same adjustment is done for the right point if it matches " { $snippet "xmax" } ", only this time the rightmost is searched for (" { $link adjusted-tail-slice } ")."
-$nl
-"If there are no points with either the " { $snippet "xmin" } " or the " { $snippet "xmax" } " coordinate, and the line spans beyond the viewport in either of those directions, the corresponding points are calculated and added to the data set (" { $link min-max-cut } ")."
-$nl
-"After we've got a subset of data that's completely within the " { $snippet "[xmin,xmax]" } " bounds, we check if the resulting data are completely above or completely below the viewport (" { $link y-in-bounds? } "), and if so, nothing is drawn. This involves finding the minimum and maximum " { $snippet "y" } " values by traversing the remaining data, which is why it's important to cut away the irrelevant data first and to make sure the " { $snippet "y" } " coordinates for the points at " { $snippet "xmin" } " and " { $snippet "xmax" } " are in the data set. All of the above is done by " { $link clip-data } "."
-$nl
-"At this point either the data set is empty, or there is at least some intersection between the data and the viewport. The task of the next step is to produce a sequence of lines that can be drawn on the viewport. The " { $link drawable-chunks } " word cuts away all the data outside the viewport, adding the intersection points where necessary. It does so by first grouping the data points into subsequences (chunks), in which all points are either above, below or within the " { $snippet "[ymin,ymax]" } " limits (" { $link monotonic-split-slice } " using " { $link between<=> } ")."
-$nl
-"Those chunks are then examined pairwise by " { $link (drawable-chunks) } " and edge points are calculated and added where necessary by " { $link (make-pair) } ". For example, if a chunk is within the viewport, and the next one is above the viewport, then a point should be added to the end of the first chunk, connecting its last point to the point of the viewport boundary intersection (" { $link fix-left-chunk } ", and " { $link fix-right-chunk } " for the opposite case). If a chunk is below the viewport, and the next one is above the viewport (or vice versa), then a new 2-point chunk should be created so that the intersecting line would be drawn within the viewport boundaries (" { $link 2-point-chunk } ")."
-$nl
-"The data are now filtered down to contain only the subset that is relevant to the currently chosen visible range, and is split into chunks that can each be drawn in a single contuguous stroke."
-$nl
-"Since the display uses inverted coordinate system, with " { $snippet "y" } " = 0 at the top of the screen, and growing downwards, we need to flip the data along the horizontal center line (" { $link flip-y-axis } ")."
-$nl
-"Finally, the data needs to be scaled so that its coordinates are mapped to the screen coordinates (" { $link scale-chunks } "). This last step could probably be combined with flipping the " { $snippet "y" } " coordinate for extra performance."
-$nl
-"The resulting chunks are displayed with a call to " { $link draw-line } " each."
-;
-
-HELP: clip-data
-{ $values
- { "bounds" "{ { xmin xmax } { ymin ymax } }" }
- { "data" { $link sequence } " of { x y } pairs sorted by non-descending x" }
- { "data'" "possibly empty subsequence of " { $snippet "data" } }
-}
-{ $description "Filter the " { $snippet "data" } " by first removing all points outside the " { $snippet "[xmin,xmax]" } " range, and then making sure that the remaining " { $snippet "y" } " values are not entirely above or below the " { $snippet "[ymin,ymax]" } " range." } ;
-
-HELP: draw-line
-{ $values
- { "seq" { $link sequence } " of { x y } pairs, in pixels" }
-}
-{ $description "Draw a sequence of straight line segments connecting all consecutive points with a single OpenGL call. Intended to be called by a " { $link draw-gadget* } " implementation." } ;
-
-HELP: line
-{ $class-description "This is a " { $link gadget } " which, when added as a child to the " { $link chart } ", will display its data as straight line segments. The implementation is oriented towards speed to allow large data sets to be displayed as quickly as possible."
-$nl
-"Slots:"
-{ $list
- { { $slot "data" } " - a " { $link sequence } " of { x y } pairs sorted by non-descending x;" }
- { { $slot "data" } " - a " { $link color } " to draw the line with." }
-} } ;
-
-HELP: y-at
-{ $description "Given two points on a straight line and an " { $snippet "x" } " coordinate, calculate the " { $snippet "y" } " coordinate at " { $snippet "x" } " on that line." }
-{ $examples
- { $example
- "USING: charts.lines.private prettyprint ;"
- "0 { 1 1 } { 5 5 } y-at ."
- "0"
- }
- { $example
- "USING: charts.lines.private prettyprint ;"
- "3 { 0 5 } { 5 5 } y-at ."
- "5"
- }
- { $example
- "USING: charts.lines.private prettyprint ;"
- "12 { 12 50 } { 15 15 } y-at ."
- "50"
- }
-} ;
-
-HELP: calc-x
-{ $description "Given the " { $snippet "slope" } " of a line and a random " { $snippet "point" } " belonging to that line, calculate the " { $snippet "x" } " coordinate corresponding to the given " { $snippet "y" } "." }
-{ $examples
- { $example
- "USING: charts.lines.private prettyprint ;"
- "1 5 { 1 1 } calc-x ."
- "5"
- }
- { $example
- "USING: charts.lines.private prettyprint ;"
- "0.5 10 { 0 0 } calc-x ."
- "20.0"
- }
-} ;
-
-HELP: calc-y
-{ $description "Given the " { $snippet "slope" } " of a line and a random " { $snippet "point" } " belonging to that line, calculate the " { $snippet "y" } " coordinate corresponding to the given " { $snippet "x" } "." }
-{ $examples
- { $example
- "USING: charts.lines.private prettyprint ;"
- "1 5 { 1 1 } calc-y ."
- "5"
- }
- { $example
- "USING: charts.lines.private prettyprint ;"
- "0.5 20 { 0 0 } calc-y ."
- "10.0"
- }
-} ;
-
-HELP: calc-line-slope
-{ $description "Given the two points belonging to a straight line, calculate the " { $snippet "slope" } " of the line, assuming the line equation is " { $snippet "y(x) = slope * x + b" } "."
-$nl
-"The formula for the calculation is " { $snippet "slope = (y1-y2) / (x1-x2)" } ", therefore it'll throw a division by zero error if both points have the same " { $snippet "x" } " coordinate." }
-{ $examples
- { $example
- "USING: charts.lines.private prettyprint ;"
- "{ 1 1 } { 10 10 } calc-line-slope ."
- "1"
- }
- { $example
- "USING: charts.lines.private prettyprint ;"
- "{ 0 0 } { 10 20 } calc-line-slope ."
- "2"
- }
-} ;
-
-{ calc-line-slope y-at calc-x calc-y } related-words
+++ /dev/null
-! Copyright (C) 2017 Alexander Ilin.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences tools.test charts.lines
-charts.lines.private ;
-IN: charts.lines.tests
-
-{ -2/3 } [ { 1 3 } { -2 5 } calc-line-slope ] unit-test
-{ 3 } [ -2/3 1 { 1 3 } calc-y ] unit-test
-{ 5 } [ -2/3 -2 { 1 3 } calc-y ] unit-test
-{ 3 } [ -2/3 1 { -2 5 } calc-y ] unit-test
-{ 5 } [ -2/3 -2 { -2 5 } calc-y ] unit-test
-{ 5 } [ -2 { 1 3 } { -2 5 } y-at ] unit-test
-{ 3 } [ 1 { 1 3 } { -2 5 } y-at ] unit-test
-{ 1 } [ 4 { -2 5 } { 1 3 } y-at ] unit-test
-{ 0.0 } [ 5.5 { -2 5 } { 1 3 } y-at ] unit-test
-{ 1 } [ -2/3 3 { 1 3 } calc-x ] unit-test
-{ -2 } [ -2/3 5 { 1 3 } calc-x ] unit-test
-{ 1 } [ -2/3 3 { -2 5 } calc-x ] unit-test
-{ -2 } [ -2/3 5 { -2 5 } calc-x ] unit-test
-
-{ 2 3 } [ { 1 2 3 } last2 ] unit-test
-{ 1 2 } [ { 1 2 } last2 ] unit-test
-[ { 1 } last2 ] must-fail
-[ { } last2 ] must-fail
-
-! 2-point-chunk upwards
-{
- { { -3 -3 } { 3 3 } }
-} [
- { { -6 0 } { -5 -5 } } { { 5 5 } { 6 0 } }
- -3 3 2-point-chunk
-] unit-test
-
-! 2-point-chunk downwards
-{
- { { -3 3 } { 3 -3 } }
-} [
- { { -6 0 } { -5 5 } } { { 5 -5 } { 6 0 } }
- -3 3 2-point-chunk
-] unit-test
-
-! 2-point-chunk: same x coord
-{
- { { -5 -3 } { -5 3 } }
-} [
- { { -6 0 } { -5 -5 } } { { -5 5 } { 6 0 } }
- -3 3 2-point-chunk
-] unit-test
-
-! fix-left-chunk: y coord = top limit
-{
- { { -6 0 } { -3 3 } }
-} [
- { { -6 0 } { -3 3 } } { { 5 5 } { 6 6 } }
- -3 3 fix-left-chunk
-] unit-test
-
-! fix-left-chunk: y coord = bottom limit
-{
- { { -6 0 } { -3 -3 } }
-} [
- { { -6 0 } { -3 -3 } } { { 5 -5 } { 6 -6 } }
- -3 3 fix-left-chunk
-] unit-test
-
-! fix-left-chunk: going upwards
-{
- { { -6 0 } { 2 2 } { 3 3 } }
-} [
- { { -6 0 } { 2 2 } } { { 5 5 } { 6 6 } }
- -3 3 fix-left-chunk
-] unit-test
-
-! fix-left-chunk: going downwards
-{
- { { -6 0 } { -2 -2 } { -1 -3 } }
-} [
- { { -6 0 } { -2 -2 } } { { 0 -4 } { 6 -6 } }
- -3 3 fix-left-chunk
-] unit-test
-
-! TODO: add more tests for the recently discovered bugs in fix-left-chunk and fix-right-chunk
-
-! fix-right-chunk: y coord = top limit
-{
- { { 5 3 } { 6 0 } }
-} [
- { { -6 6 } { -3 4 } } { { 5 3 } { 6 0 } }
- -3 3 fix-right-chunk
-] unit-test
-
-! fix-right-chunk: y coord = bottom limit
-{
- { { 5 -3 } { 6 0 } }
-} [
- { { -6 -6 } { -3 -4 } } { { 5 -3 } { 6 0 } }
- -3 3 fix-right-chunk
-] unit-test
-
-! fix-right-chunk: going upwards
-{
- { { -3 -3 } { -2 -2 } { 6 0 } }
-} [
- { { -6 -6 } { -4 -4 } } { { -2 -2 } { 6 0 } }
- -3 3 fix-right-chunk
-] unit-test
-
-! fix-right-chunk: going downwards
-{
- { { -3 3 } { -2 2 } { 6 0 } }
-} [
- { { -6 6 } { -4 4 } } { { -2 2 } { 6 0 } }
- -3 3 fix-right-chunk
-] unit-test
-
-! tight bounds
-{
- { { { 0 0 } { 0 1 } { 1 2 } { 1 3 } { 2 5 } } }
-} [
- { { 0 0 } { 0 1 } { 1 2 } { 1 3 } { 2 5 } } { 0 5 }
- drawable-chunks [ { } like ] map
-] unit-test
-
-! loose bounds
-{
- { { { 0 0 } { 0 1 } { 1 2 } { 1 3 } { 2 5 } } }
-} [
- { { 0 0 } { 0 1 } { 1 2 } { 1 3 } { 2 5 } } { -1 6 }
- drawable-chunks [ { } like ] map
-] unit-test
-
-! only bottom element accepted
-{
- { { { 0 0 } } }
-} [
- { { 0 0 } { 0 1 } { 1 2 } { 1 3 } { 2 5 } } { -1 0 }
- drawable-chunks [ { } like ] map
-] unit-test
-
-! only top element accepted
-{
- { { { 2 5 } } }
-} [
- { { 0 0 } { 0 1 } { 1 2 } { 1 3 } { 2 5 } } { 5 10 }
- drawable-chunks [ { } like ] map
-] unit-test
-
-! top half of the elements accepted
-{
- { { { 1 2 } { 1 3 } { 2 5 } } }
-} [
- { { 0 0 } { 0 1 } { 1 2 } { 1 3 } { 2 5 } } { 2 10 }
- drawable-chunks [ { } like ] map
-] unit-test
-
-! bottom half of the elements accepted
-{
- { { { 0 0 } { 0 1 } { 1 2 } } }
-} [
- { { 0 0 } { 0 1 } { 1 2 } { 1 3 } { 2 5 } } { -2 2 }
- drawable-chunks [ { } like ] map
-] unit-test
-
-! middle section of the elements accepted
-{
- { { { 0 1 } { 1 2 } { 1 3 } } }
-} [
- { { 0 0 } { 0 1 } { 1 2 } { 1 3 } { 2 5 } } { 1 3 }
- drawable-chunks [ { } like ] map
-] unit-test
-
-! two sections, including first but not last
-{
- {
- { { 0 0 } { 1 2 } { 2 3 } }
- { { 5 3 } { 6 2 } { 7 0 } }
- }
-} [
- { { 0 0 } { 1 2 } { 2 3 } { 3 5 } { 4 5 } { 5 3 } { 6 2 } { 7 0 } { 8 -1 } { 9 -2 } } { 0 3 }
- drawable-chunks [ { } like ] map
-] unit-test
-
-! two sections, including last but not first
-{
- {
- { { 2 0 } { 3 3 } { 4 3 } }
- { { 7 3 } { 8 2 } { 9 0 } }
- }
-} [
- { { 0 -2 } { 1 -1 } { 2 0 } { 3 3 } { 4 3 } { 5 5 } { 6 9 } { 7 3 } { 8 2 } { 9 0 } } { 0 3 }
- drawable-chunks [ { } like ] map
-] unit-test
-
-! single-element sequences, same x coord
-{
- {
- { { 0 0 } { 0 3 } }
- { { 0 3 } { 0 0 } }
- }
-} [
- { { 0 -2 } { 0 0 } { 0 5 } { 0 3 } { 0 -1 } } { 0 3 }
- drawable-chunks [ { } like ] map
-] unit-test
-
-! single point sticks out to within the limits from below
-{
- {
- { { 1 1 } { 2 2 } { 3 1 } }
- }
-} [
- { { 0 0 } { 2 2 } { 4 0 } } { 1 5 }
- drawable-chunks [ { } like ] map
-] unit-test
-
-! single point sticks out to within the limits from above
-{
- {
- { { 1 3 } { 2 2 } { 3 3 } }
- }
-} [
- { { 0 4 } { 2 2 } { 4 4 } } { 1 3 }
- drawable-chunks [ { } like ] map
-] unit-test
-
-{
- { { { 0 300 } { 1 200 } { 2 150 } { 3 100 } { 4 0 } } }
-} [
- { { { 0 0 } { 1 100 } { 2 150 } { 3 200 } { 4 300 } } }
- { 0 300 } flip-y-axis
-] unit-test
-
-{
- { 0 30 60 90 120 150 180 210 240 270 300 }
-} [
- 11 iota [ 10 + ] map [ 300 swap 20 10 scale ] map
-] unit-test
-
-{ { } }
-[ { } { } clip-data ] unit-test
-
-{ { } }
-[ { { 0 1 } { 0 5 } } { } clip-data ] unit-test
-
-! Adjustment after search is required in both directions.
-{
- {
- { 1 3 } { 1 4 } { 1 5 }
- { 2 6 } { 3 7 } { 4 8 }
- { 5 9 } { 5 10 } { 5 11 } { 5 12 }
- }
-} [
- { { 1 5 } { 0 14 } }
- {
- { 0 1 } { 0 2 }
- { 1 3 } { 1 4 } { 1 5 }
- { 2 6 } { 3 7 } { 4 8 }
- { 5 9 } { 5 10 } { 5 11 } { 5 12 }
- { 6 13 } { 7 14 }
- } clip-data
-] unit-test
-
-! no points within the viewport, complete calculation
-{
- { { 1 1 } { 4 4 } }
-} [
- { { 1 4 } { 1 4 } }
- { { 0 0 } { 5 5 } } clip-data
-] unit-test
-
-! no points within the viewport, complete calculation
-{
- { { 1 4 } { 4 1 } }
-} [
- { { 1 4 } { 1 4 } }
- { { 0 5 } { 5 0 } } clip-data
-] unit-test
-
-! no points within the viewport, complete calculation
-{
- { { 1 3 } { 4 3 } }
-} [
- { { 1 4 } { 1 4 } }
- { { 0 3 } { 5 3 } } clip-data
-] unit-test
-
-! all data are to the left of viewport
-{
- { }
-} [
- { { 1 4 } { 1 4 } }
- { { -1 0 } { 0 1 } { 0.5 1 } } clip-data
-] unit-test
-
-! all data are to the right of viewport
-{
- { }
-} [
- { { 1 4 } { 1 4 } }
- { { 4.5 0 } { 5 1 } { 6 1 } } clip-data
-] unit-test
-
-! just a little off the top
-{ t } [
- { 0 99 }
- { { 0 100 } { 100 0 } { 100 50 } { 150 50 } { 200 100 } }
- y-in-bounds?
-] unit-test
-
-! TODO: add tests where after search there is no adjustment necessary, so that extra adjustment would take bad elements.
+++ /dev/null
-! Copyright (C) 2016-2017 Alexander Ilin.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs binary-search charts combinators
-combinators.short-circuit fry kernel locals make math math.order
-math.statistics math.vectors namespaces opengl opengl.gl
-sequences specialized-arrays.instances.alien.c-types.float
-splitting.monotonic ui.gadgets ui.render ;
-IN: charts.lines
-
-! Data must be a sequence of { x y } coordinates sorted by
-! non-descending x vaues.
-TUPLE: line < gadget color data ;
-
-<PRIVATE
-
-: (line-vertices) ( seq -- vertices )
- concat [ 0.3 + ] float-array{ } map-as ;
-
-ALIAS: x first
-ALIAS: y second
-
-: search-first ( elt seq -- index elt )
- [ first <=> ] with search ;
-
-: search-first? ( elt seq -- index elt exact-match? )
- dupd search-first rot [ dup first ] dip = ;
-
-! Return a slice of the seq with all elements equal to elt to the
-! left of the index, plus one that's not equal, if requested.
-:: adjusted-tail-slice ( n elt plus-one? seq -- slice )
- n seq elt x '[ x _ = not ] find-last-from drop seq swap
- [ plus-one? [ 1 + ] unless tail-slice ] when* ;
-
-! Return a slice of the seq with all elements equal to elt to the
-! right of the index, plus one that's not equal, if requested.
-:: adjusted-head-slice ( n elt plus-one? seq -- slice )
- n seq elt x '[ x _ = not ] find-from drop seq swap
- [ plus-one? [ 1 + ] when short head-slice ] when* ;
-
-! : data-rect ( data -- rect )
-! [ [ first x ] [ last x ] bi ] keep
-! [ y ] map minmax swapd
-! [ 2array ] bi@ <extent-rect> ;
-
-: x-in-bounds? ( min,max pairs -- ? )
- {
- [ [ first ] dip last x > not ]
- [ [ second ] dip first x < not ]
- } 2&& ;
-
-: y-in-bounds? ( min,max pairs -- ? )
- [ y ] map minmax 2array
- {
- [ [ first ] dip second > not ]
- [ [ second ] dip first < not ]
- } 2&& ;
-
-! : xy-in-bounds? ( bounds pairs -- ? )
-! {
-! [ [ first ] dip x-in-bounds? ]
-! [ [ second ] dip y-in-bounds? ]
-! } 2&& ;
-
-: calc-line-slope ( point1 point2 -- slope ) v- first2 swap / ;
-: calc-y ( slope x point -- y ) first2 [ - * ] dip + ;
-: calc-x ( slope y point -- x ) first2 swap [ - swap / ] dip + ;
-: y-at ( x point1 point2 -- y ) dupd calc-line-slope -rot calc-y ;
-: last2 ( seq -- penultimate ultimate ) 2 tail* first2 ;
-
-! Due to the way adjusted-tail-slice works, the first element of
-! pairs is <= xmin, and if the first is < xmin, then the second is
-! > xmin. Otherwise the first one would be = xmin.
-: left-cut-x ( xmin pairs -- seq )
- 2dup first x > [
- [ dupd first2 y-at 2array ] keep rest-slice swap prefix
- ] [
- nip
- ] if ;
-
-! Due to the way adjusted-head-slice works, the last element of
-! pairs is >= xmax, and if the last is > xmax, then the second to
-! last is < xmax. Otherwise the last one would be = xmax.
-: right-cut-x ( xmax pairs -- seq )
- 2dup last x < [
- [ dupd last2 y-at 2array ] keep but-last-slice swap suffix
- ] [
- nip
- ] if ;
-
-! If the line spans beyond min or max, make sure there are points
-! with x = min and x = max in seq.
-: min-max-cut ( min,max pairs -- seq )
- [ first2 ] dip right-cut-x left-cut-x ;
-
-: clip-by-x ( min,max pairs -- pairs' )
- 2dup x-in-bounds? [
- [ dup first ] dip [ search-first? not ] keep
- adjusted-tail-slice
- [ dup second ] dip [ search-first? not ] keep
- adjusted-head-slice
- dup length 1 > [ min-max-cut ] [ nip ] if
- dup slice? [ dup like ] when
- ] [
- 2drop { }
- ] if ;
-
-: between<=> ( value min max -- <=> )
- 3dup between? [ 3drop +eq+ ] [ nip > +gt+ +lt+ ? ] if ;
-
-: calc-point-y ( slope y point -- xy ) over [ calc-x ] dip 2array ;
-
-: xyy>chunk ( x y1 y2 -- chunk )
- [ over ] dip 2array [ 2array ] dip 2array ;
-
-:: 2-point-chunk ( left right ymin ymax -- chunk )
- left last :> left-point
- right first :> right-point
- left-point x right-point x = [
- left-point x ymin ymax xyy>chunk
- ] [
- left-point right-point calc-line-slope :> slope
- slope ymin left-point calc-point-y
- slope ymax left-point calc-point-y
- left-point y right-point y > [ swap ] when 2array
- ] if ;
-
-:: fix-left-chunk ( left right ymin ymax -- left' )
- left last :> left-point
- right first :> right-point
- left-point y right-point y {
- [ { [ drop ymin = ] [ > ] } 2&& ]
- [ { [ drop ymax = ] [ < ] } 2&& ]
- } 2|| [
- left
- ] [
- left-point y right-point y > ymin ymax ? :> y-coord
- left-point x right-point x = [
- left-point x y-coord 2array
- ] [
- left-point right-point calc-line-slope
- y-coord left-point calc-point-y
- ] if
- left swap suffix
- ] if ;
-
-:: fix-right-chunk ( left right ymin ymax -- right' )
- left last :> left-point
- right first :> right-point
- left-point y right-point y {
- [ { [ ymin = nip ] [ < ] } 2&& ]
- [ { [ ymax = nip ] [ > ] } 2&& ]
- } 2|| [
- right
- ] [
- left-point y right-point y < ymin ymax ? :> y-coord
- left-point x right-point x = [
- right-point x y-coord 2array
- ] [
- left-point right-point calc-line-slope
- y-coord left-point calc-point-y
- ] if
- right swap prefix
- ] if ;
-
-: first-point ( chunks -- first-point ) first first ;
-
-: last-point ( chunks -- last-point ) last last ;
-
-:: (make-pair) ( prev next min max -- next' )
- prev next min max
- prev next [ first y min max between<=> ] bi@ 2array
- {
- { { +gt+ +eq+ } [ fix-right-chunk ] }
- { { +lt+ +eq+ } [ fix-right-chunk ] }
- { { +eq+ +gt+ } [ fix-left-chunk , next ] }
- { { +eq+ +lt+ } [ fix-left-chunk , next ] }
- { { +gt+ +lt+ } [ 2-point-chunk , next ] }
- { { +lt+ +gt+ } [ 2-point-chunk , next ] }
- [ drop "same values - can't happen" throw ]
- } case ;
-
-! Drop chunks that are out of bounds, add extra points where needed.
-:: (drawable-chunks) ( chunks min max -- chunks' )
- chunks length {
- { 0 [ chunks ] }
- { 1 [
- chunks first-point y min max between?
- chunks { } ?
- ]
- }
- [
- drop [
- chunks [ ] [ min max (make-pair) ] map-reduce
- dup first y min max between? [ , ] [ drop ] if
- ] { } make
- ]
- } case ;
-
-! Split data into chunks to be drawn within the [ymin,ymax] limits.
-! Return the (empty?) sequence of chunks, possibly with some new
-! points at ymin and ymax at the gap bounds.
-: drawable-chunks ( data ymin,ymax -- chunks )
- first2 [
- '[ [ y _ _ between<=> ] bi@ = ]
- monotonic-split-slice
- ] 2keep (drawable-chunks) ;
-
-: flip-y-axis ( chunks ymin,ymax -- chunks )
- first2 + '[ [ _ swap - ] assoc-map ] map ;
-
-! value' = (value - min) / (max - min) * width
-: scale ( width value max min -- value' ) neg [ + ] curry bi@ / * ;
-
-! Return quotation that can be used in map operation.
-: scale-mapper ( width min,max -- quot: ( value -- value' ) )
- first2 swap '[ _ swap _ _ scale ] ; inline
-
-! Sometimes no scaling is needed.
-! : scale-mapper ( width min,max -- quot: ( value -- value' ) )
-! first2 swap 3dup - = [
-! 3drop [ ]
-! ] [
-! '[ _ swap _ _ scale ]
-! ] if ; inline
-
-: scale-chunks ( chunks xwidth xmin,xmax yheight ymin,ymax -- chunks' )
- [ scale-mapper ] 2bi@ '[ [ _ _ bi* ] assoc-map ] map ;
-
-PRIVATE>
-
-: draw-line ( seq -- )
- dup [ but-last-slice ] over length odd? [ dip ] [ call ] if
- rest-slice append
- [ (line-vertices) gl-vertex-pointer GL_LINES 0 ] keep
- length glDrawArrays ;
-
-! bounds: { { xmin xmax } { ymin ymax } }
-: clip-data ( bounds data -- data' )
- dup empty? [ nip ] [
- dupd [ first ] dip clip-by-x
- dup empty? [ nip ] [
- [ second ] dip [ y-in-bounds? ] keep swap
- [ drop { } ] unless
- ] if
- ] if ;
-
-M: line draw-gadget*
- dup parent>> dup chart? [| line chart |
- chart chart-axes
- line [ color>> gl-color ] [ data>> ] bi
- dupd clip-data swap second [ drawable-chunks ] keep
- flip-y-axis
- chart chart-dim first2 [ chart chart-axes first2 ] dip swap
- scale-chunks
- [ draw-line ] each
- ] [ 2drop ] if ;
projects / factor.git / commitdiff