Add stroked stippled lines.

Used to improve the weather chart example, and make stroked lines more
useful for charting. However, there are still some issues with the
stippling code, it needs to be better tested and reworked, especially
when path segments are very close together.

Author: bakpakin

examples/charts/weather-chart.janet

@@ -42,6 +42,7 @@
       "latitude=" (string/format "%.3f" (get location :latitude))
       "&longitude=" (string/format "%.3f" (get location :longitude))
       "&past_days=" past-days
+      "&timezone=Etc/UTC"
       "&hourly=" (string/join y-columns ",")
       "&temperature_unit=fahrenheit"))
   (print "Getting weather data from " url " ...")
@@ -56,6 +57,29 @@
   (def x-ticks (seq [[i x] :pairs timestamps :when (string/has-suffix? "T00:00" x)] i))
   (defn format-x [x] (slice (first (string/split "T" (get timestamps (math/round x) ""))) 5))
 
+  # Find the "now" location for a horizontal line
+  (def ts-parse (peg/compile ~{:n (/ ':d+ ,scan-number)
+                               :main (* :n "-" :n "-" :n "T" :n ":" :n)}))
+  (def {:year Y :month-day D :hours H :month M} (os/date))
+  (def now-index (find-index |(if-let [[y m d h s] (peg/match ts-parse $)] (and (= y Y) (= m (inc M))
+                                                                                (= d (inc D)) (= h H)))
+                             timestamps))
+
+  # Then split our forecase data into before and after now.
+  (each col y-columns
+    (def historic-data (array/slice (get data-frame col)))
+    (def forecast-data (array/slice (get data-frame col)))
+    (for i 0 (length historic-data)
+      (when (< i now-index) (set (forecast-data i) nil))
+      (when (> i now-index) (set (historic-data i) nil)))
+    (put data-frame col historic-data)
+    (put data-frame (keyword col "-forecast") forecast-data))
+  (def extended-y-columns [;y-columns ;(map |(keyword $ "-forecast") y-columns)])
+  (def styles (tabseq [c :in extended-y-columns]
+                      c (if (string/has-suffix? "-forecast" c)
+                          :stroke-stipple
+                          :stroke)))
+
   # So fetch (disable this for black-on-white instead of white-on-black, looks more professional, less cool)
   (charts/dark-mode)
 
@@ -68,16 +92,20 @@
     :height (* 2 540)
     :data data-frame
     :x-column :time
-    :y-column y-columns
+    :y-column extended-y-columns
     :color-map {:temperature_2m 0xFF0000dd
                 :wind_speed_10m 0xFFdd0000
-                :relative_humidity_2m 0xFF96AF00}
+                :relative_humidity_2m 0xFF96AF00
+                :temperature_2m-forecast 0xFF0000dd
+                :wind_speed_10m-forecast 0xFFdd0000
+                :relative_humidity_2m-forecast 0xFF96AF00}
     :y-label "°F / kmph / %"
     :legend-map {:temperature_2m "Temperature (°F)"
                  :wind_speed_10m "Wind Speed (km/h)"
                  :relative_humidity_2m "Humidity (%)"
                  :precipitation_probability "Precipitation Probability (%)"}
-    :line-style :stroke #{:temperature_2m :stroke}
+    :legend-labels y-columns
+    :line-style-per-column styles
     :x-ticks x-ticks
     :format-x format-x
     # :transpose true
@@ -89,13 +117,17 @@
     :padding 40 # default padding is 16, larger padding looks better for larger fonts and images.
     :super-sample 4 # Super-sampled anti-aliasing is a great way to get nice charts.
     # It is a bit slow to render, especially for large images (4x super-sampled is 16 times the pixels). Going beyond 4 is usually superfluous.
-    :stroke-thickness 2
+    :stroke-thickness 1
     :grid :solid # grid can be :none (nil), :solid, or :stipple
     #:grid :stipple
     :legend :top # legend can be :none (nil), :top, :top-left, :top-right, :bottom-left, :bottom-right
     #:legend :top-right
     #:x-minor-ticks 12
     #:y-minor-ticks 10
+    :annotate (fn [view to-pixel to-metric]
+                (def [x-now _] (to-pixel now-index 0))
+                (gfx2d/draw-simple-text view (+ 2 x-now) 2 "Now" gfx2d/white :olive 2 2)
+                (gfx2d/plot view x-now 0 x-now 10000 gfx2d/white))
     :save-as output)
 
   (print "Wrote chart to " output)

spork/charts.janet

@@ -376,7 +376,7 @@
     (errorf "unknown color map %v - expect function, array, tuple, table, struct, number, table, or keyword, got %v" cmap)))
 
 ###
-### Argument groups
+### Legends
 ###
 
 (defn draw-legend
@@ -973,7 +973,7 @@
 
     # Plot lines between points
     (def line-style2 (get line-style-per-column ycol line-style))
-    (enum line-style2 :plot :stipple :fine-stipple :stroke :bar :multi-bar :none :area)
+    (enum line-style2 :plot :stipple :fine-stipple :stroke :stroke-stipple :bar :multi-bar :none :area)
     (def multi-bar (= line-style2 :multi-bar)) # multi-bar and bar share most of the same code
     (case (if multi-bar :bar line-style2)
 
@@ -1002,6 +1002,10 @@
       (do
         (g/stroke-path canvas pts graph-color stroke-thickness))
 
+      :stroke-stipple
+      (do
+        (g/stroke-path canvas pts graph-color stroke-thickness false (* 8 stroke-thickness) (* 4 stroke-thickness)))
+
       :area
       (do
         (if transpose
@@ -1135,12 +1139,15 @@
   * :scatter - set to true to disable lines connecting points
   * :legend - set to true to add a legend to the top of the chart
   * :legend-map - a dictionary mapping column names to pretty text for the chart
+  * :legend-labels - optional list of y-column names to display in the legend
   * :legend-padding - extra padding around legend area
   * :point-radius - radius of points when drawing a scatter plot
   * :line-style - How to draw lines. Can be one of :stroke, :plot, :none, :bar, :area, or :stipple. Default is :plot.
   * :line-style-per-column - Optional dictionary to override line style by y-column name.
   * :super-sample - Super Sample anti-aliasing for chart lines. Is a bit slow, but makes smooth plots. Works best with :stroke and :bar
   * :stroke-thickness - thickness in pixels of the stroke of the graph when :line-type = :stroke
+  * :annotate - an optional function to add annotations to a rendered chart. This function should take 3 arguments:
+      (fn callback [view to-pixel to-metric] ...)
 
   Axis Boundaries
   * :x-min - minimum x coordinate on chart
@@ -1155,7 +1162,7 @@
    x-min x-max y-min y-max
    padding inner-padding inner-padding-x inner-padding-y title
    circle-points
-   scatter grid legend super-sample stroke-thickness
+   scatter grid legend legend-labels super-sample stroke-thickness
    format-x format-y
    save-as
    legend-map legend-padding
@@ -1168,6 +1175,7 @@
    x-grid-ticks y-grid-ticks
    x-labels-vertical
    grid-between-x grid-between-y
+   annotate
    transpose]
 
   # Check parameters and set defaults.
@@ -1203,7 +1211,7 @@
 
   # Check enums
   (enum grid :none :solid :stipple :fine-stipple)
-  (enum line-style :plot :stipple :fine-stipple :stroke :bar :multi-bar :none :area) # - allow for dictionary of styles
+  (enum line-style :plot :stipple :fine-stipple :stroke :stroke-stipple :bar :multi-bar :none :area) # - allow for dictionary of styles
   (enum legend :none :top :top-left :top-right :bottom-left :bottom-right)
 
   # Allow variadic shorthand
@@ -1224,14 +1232,15 @@
 
   # Add legend if legend = :top. This makes a horizontal legend just below the title with no extra framing
   (default legend-padding (max 4 (div padding 4)))
+  (default legend-labels y-columns)
   (when (= legend :top)
     (+= title-padding (div padding 2))
     (def view-width (- width padding padding))
-    (def [lw lh] (draw-legend nil :font font :padding legend-padding :labels y-columns :legend-map legend-map :view-width view-width))
+    (def [lw lh] (draw-legend nil :font font :padding legend-padding :labels legend-labels :legend-map legend-map :view-width view-width))
     (def legend-view (g/viewport canvas (math/floor (* (- width lw) 0.5)) title-padding lw lh true))
     (+= title-padding lh)
     (-= title-padding (math/floor (* 0.5 padding))) # just looks a bit better
-    (draw-legend legend-view :font font :padding legend-padding :labels y-columns :color-map color-map
+    (draw-legend legend-view :font font :padding legend-padding :labels legend-labels :color-map color-map
                  :legend-map legend-map :text-color text-color :view-width view-width))
 
   # Crop title section out of place where axis and charting will draw
@@ -1243,7 +1252,7 @@
                            (if transpose y-columns x-column)
                            (if transpose x-column y-columns)
                            x-min x-max y-min y-max))
-  (def [graph-view to-pixel-space _to-metric-space]
+  (def [graph-view to-pixel-space to-metric-space]
     (draw-axes
       :canvas view
       :padding padding :inner-padding inner-padding
@@ -1282,9 +1291,11 @@
     :bar-padding bar-padding
     :transpose transpose)
 
+  (when annotate (annotate graph-view to-pixel-space to-metric-space))
+
   # Draw internal legend if selected
   (when (index-of legend [:top-left :top-right :bottom-left :bottom-right])
-    (def [lw lh] (draw-legend nil :font font :padding legend-padding :labels y-columns :legend-map legend-map :frame false))
+    (def [lw lh] (draw-legend nil :font font :padding legend-padding :labels legend-labels :legend-map legend-map :frame false))
     (def {:width gw :height gh} (g/unpack graph-view))
     (def legend-view
       (case legend
@@ -1294,10 +1305,9 @@
         :bottom-right (g/viewport graph-view (- gw lw padding) (- gh lh padding) lw lh true)))
     (when (not= :none background-color)
       (g/fill-rect legend-view 0 0 lw lh background-color))
-    (draw-legend legend-view :font font :padding legend-padding :labels y-columns :view-width 0
+    (draw-legend legend-view :font font :padding legend-padding :labels legend-labels :view-width 0
                  :color-map color-map :legend-map legend-map :frame true))
 
-  # Save to file
   (when save-as
     (g/save save-as canvas))
 

spork/gfx2d-codegen.janet

@@ -254,7 +254,7 @@
 
 (function v/lerp :static :inline
   [a:V2 b:V2 t:double] -> V2
-  (return (v/+ (v/s* t a) (v/s* (- 1 t) b))))
+  (return (v/+ (v/s* (- 1 t) a) (v/s* t b))))
 
 (function v/rotate-cw-90 :static :inline
   [a:V2] -> V2
@@ -1554,27 +1554,54 @@
 
 (cfunction stroke-path
   "Stroke a line along a path"
-  [img:*Image points:indexed ,;shader-args &opt thickness:double=1 join-end:bool=0] -> *Image
+  [img:*Image points:indexed ,;shader-args &opt thickness:double=1 join-end:bool=0 stipple-cycle:int=0 stipple-on:int=0] -> *Image
   (var npoints:int 0)
   (var (vs 'V2))
   (if join-end
     (set vs (indexed-to-vs-join-end points &npoints))
     (set vs (indexed-to-vs points &npoints)))
-  (each-i 1 npoints
-    (def A:V2 (aref vs (- i 1)))
-    (def B:V2 (aref vs i))
-    (def AB:V2 (v/- B A))
-    (def leg:V2 (v/s* thickness (v/rotate-cw-90 (v/norm AB))))
-    (def p1:V2 (v/+ A leg))
-    (def p2:V2 (v/- A leg))
-    (def p3:V2 (v/- B leg))
-    (def p4:V2 (v/+ B leg))
-    (def (ps (array V2)) @[p1 p2 p3 p4 p1])
-    (fill-path-impl img ps 5 ,;shader-params))
-  (each-i 0 npoints
-    (def P:V2 (aref vs i))
-    (circle img P.x P.y (+ 0.25 thickness) ,;shader-params))
-  (janet-sfree vs:*V2) # self-test for mangling of type-grafted symbols
+  (if (or (>= 0 stipple-cycle) (>= stipple-on stipple-cycle))
+    (do # solid stroke
+      (each-i 1 npoints
+        (def A:V2 (aref vs (- i 1)))
+        (def B:V2 (aref vs i))
+        (def AB:V2 (v/- B A))
+        (def ABlen:float (v/len AB))
+        (if (= 0 ABlen) (continue))
+        (def leg:V2 (v/s* thickness (v/rotate-cw-90 (v/norm AB))))
+        (def p1:V2 (v/+ A leg))
+        (def p2:V2 (v/- A leg))
+        (def p3:V2 (v/- B leg))
+        (def p4:V2 (v/+ B leg))
+        (def (ps (array V2)) @[p1 p2 p3 p4 p1])
+        (fill-path-impl img ps 5 ,;shader-params))
+      (each-i 0 npoints
+        (def P:V2 (aref vs i))
+        (circle img P.x P.y (+ 0.25 thickness) ,;shader-params)))
+    (do # stippled stroke
+      (var pixel-lookback:float 0)
+      (each-i 1 npoints
+        (def A:V2 (aref vs (- i 1)))
+        (def B:V2 (aref vs i))
+        (def AB:V2 (v/- B A))
+        (def ABlen:float (v/len AB))
+        (if (= 0 ABlen) (continue))
+        (def leg:V2 (v/s* thickness (v/rotate-cw-90 (v/norm AB))))
+        (for [(def t:float (- (/ pixel-lookback ABlen))) (< t 1) (+= t (/ stipple-cycle ABlen))]
+          (def t-end:float (+ t (/ stipple-on ABlen)))
+          (def t1:double (- (clamp t 0 1) (/ 1 ABlen)))
+          (def t2:double (clamp t-end 0 1))
+          (when (and (not= t1 t2) (or (> t 0) (> t-end 0)))
+            (def C:V2 (v/lerp A B t1))
+            (def D:V2 (v/lerp A B t2))
+            (def p1:V2 (v/+ C leg))
+            (def p2:V2 (v/- C leg))
+            (def p3:V2 (v/- D leg))
+            (def p4:V2 (v/+ D leg))
+            (def (ps (array V2)) @[p1 p2 p3 p4 p1])
+            (fill-path-impl img ps 5 ,;shader-params))
+          (set pixel-lookback (* ABlen (- 1 t)))))))
+  (janet-sfree vs:*V2) # cjanet self-test for mangling of type-grafted symbols
   (return img))
 
 ###
@@ -1888,7 +1915,7 @@
     # Always do internal measurement non-rotated, and then rotate output during sampling.
     (def measure:TextMeasure (measure-text-impl font cursor scale 0))
     # Shift origin to match simple text - by default, text origin is upper most glyph. Instead, should be ascender line.
-    (def from-glyphtop:int (? (= 1 (band orientation 2r1100)) 1 0))
+    (def from-glyphtop:int (? (= 2r100 (band orientation 2r1100)) 1 0))
     (var fx:float (- measure.xmin))
     (var fy:float (? from-glyphtop (- measure.ymin) (* font->ascent scale font->scale font->glyph-space-to-pixel)))
     (while *cursor

test/gold/bezier-stipple-2.png

@@ -228,6 +228,38 @@
 
 (test-stroke-bezier)
 
+(defn test-stroke-bezier-stipple
+  []
+  (def width 256)
+  (def height 256)
+  (def canvas (blank width height 3))
+  (def control-points [10 10
+                       10 (- height 10)
+                       (- width 10) (- height 10)
+                       (- width 10) 10])
+  (def points (bezier-path control-points 0.04))
+  (stroke-path canvas [0 0 (/ width 2) (/ height 2) width height] red 4 false 20 10)
+  (stroke-path canvas points green 4 false 20 10)
+  (check-image canvas "bezier-stipple.png"))
+
+(test-stroke-bezier-stipple)
+
+(defn test-stroke-bezier-stipple-2
+  []
+  (def width 256)
+  (def height 256)
+  (def canvas (blank width height 3))
+  (def control-points [10 10
+                       10 (- height 10)
+                       (- width 10) (- height 10)
+                       (- width 10) 10])
+  (def points (bezier-path control-points 0.004))
+  (stroke-path canvas [0 0 (/ width 2) (/ height 2) width height] red 4 false 10 5)
+  (stroke-path canvas points green 4 false 10 5)
+  (check-image canvas "bezier-stipple-2.png"))
+
+(test-stroke-bezier-stipple-2)
+
 (defn test-fill-bezier
   []
   (def width 256)