summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Thompson <dthompson2@worcester.edu>2020-08-28 07:16:51 -0400
committerDavid Thompson <dthompson2@worcester.edu>2020-10-20 08:28:03 -0400
commit48fce33ffa868c041ac397ee2f826133ffc643ab (patch)
tree354f41e9db52668cc033c5b97c3d0aff0d35a826
parent5e3a70ae58a4955ae57f36651e0966b807bda5a8 (diff)
render: Add vector path rendering module.wip-path-rendering
-rw-r--r--Makefile.am1
-rw-r--r--chickadee/graphics/path.scm1603
-rw-r--r--examples/path.scm121
3 files changed, 1725 insertions, 0 deletions
diff --git a/Makefile.am b/Makefile.am
index ffd4731..05e847c 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -81,6 +81,7 @@ SOURCES = \
chickadee/graphics/phong.scm \
chickadee/graphics/pbr.scm \
chickadee/graphics/model.scm \
+ chickadee/graphics/path.scm \
chickadee/scripting/agenda.scm \
chickadee/scripting/script.scm \
chickadee/scripting/channel.scm \
diff --git a/chickadee/graphics/path.scm b/chickadee/graphics/path.scm
new file mode 100644
index 0000000..b8bdd23
--- /dev/null
+++ b/chickadee/graphics/path.scm
@@ -0,0 +1,1603 @@
+;;; Chickadee Game Toolkit
+;;; Copyright © 2020 David Thompson <davet@gnu.org>
+;;;
+;;; Chickadee is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published
+;;; by the Free Software Foundation, either version 3 of the License,
+;;; or (at your option) any later version.
+;;;
+;;; Chickadee is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary
+;;
+;; Vector path rendering.
+;;
+;;; Code:
+
+(define-module (chickadee graphics path)
+ #:use-module (chickadee graphics)
+ #:use-module (chickadee graphics color)
+ #:use-module (chickadee graphics gl)
+ #:use-module (chickadee graphics shader)
+ #:use-module (chickadee graphics stencil)
+ #:use-module (chickadee graphics buffer)
+ #:use-module (chickadee math)
+ #:use-module (chickadee math bezier)
+ #:use-module (chickadee math matrix)
+ #:use-module (chickadee math rect)
+ #:use-module (chickadee math vector)
+ #:use-module (gl)
+ #:use-module (ice-9 match)
+ #:use-module ((rnrs base) #:select (mod))
+ #:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-4)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-43)
+ #:export (path
+ path?
+ move-to
+ line-to
+ bezier-to
+ close-path
+ arc
+ arc-to
+ line
+ polyline
+ rectangle
+ square
+ rounded-rectangle
+ regular-polygon
+ ellipse
+ circle
+ stroke
+ fill
+ fill-and-stroke
+ with-style
+ with-transform
+ translate
+ rotate
+ scale
+ superimpose
+ pad
+ beside
+ below
+ make-canvas
+ canvas?
+ draw-canvas))
+
+
+;;;
+;;; Paths
+;;;
+
+;; TODO: Support clockwise *and* counterclockwise winding.
+
+;; Meet the primitive commands: move-to, line-to, bezier-to, and
+;; close-path.
+(define (move-to point)
+ `(move-to ,point))
+
+(define (line-to point)
+ `(line-to ,point))
+
+(define (bezier-to control1 control2 point)
+ `(bezier-to ,control1 ,control2 ,point))
+
+(define (close-path)
+ '(close))
+
+;; Arcs are interesting in that they can be built from the primitives
+;; above *but* they need to know the previous point in the path first.
+;; Because of this context sensitivity, we must defer the process of
+;; creating the command list until we have a full path assembled.
+;;
+;; So in addition to our primitives, we need one more: expand. The
+;; expand command is likely a trivial macro expander. It accepts a
+;; proc with a single argument: The previous point in the path.
+(define (arc center rx ry angle-start angle-end)
+ ;; This algorithm is based on "Approximating Arcs Using Cubic Bézier
+ ;; Curves" by Joe Cridge:
+ ;; https://web.archive.org/web/20170829122313/https://www.joecridge.me/content/pdf/bezier-arcs.pdf
+ (define (adjust-angle angle)
+ ;; Clamp within [0, 2pi] range.
+ (let* ((clamped (mod angle 2pi))
+ (adjusted (atan (* (/ rx ry) (tan clamped)))))
+ ;; Adjust angles to counter linear scaling.
+ (cond
+ ((<= clamped pi/2)
+ adjusted)
+ ((and (> clamped pi/2)
+ (<= clamped (* pi 1.5)))
+ (+ adjusted pi))
+ (else
+ (+ adjusted 2pi)))))
+ (let* ((angle-start (adjust-angle angle-start))
+ (angle-end* (adjust-angle angle-end))
+ (angle-end (if (> angle-start angle-end*)
+ (+ angle-end* 2pi)
+ angle-end*))
+ ;; Don't bother making a curve for an angle smaller than
+ ;; this.
+ (min-angle .00001)
+ (cx (vec2-x center))
+ (cy (vec2-y center)))
+ (define (expand-arc prev-point)
+ ;; Break the arc into a series of bezier curves where each curve
+ ;; covers at most pi/2 radians of the total curve.
+ (let loop ((start angle-start)
+ ;; Carrying over some values from each iteration to
+ ;; reduce redundant sin/cos calls.
+ (cos-start #f)
+ (sin-start #f)
+ (x1 #f)
+ (y1 #f))
+ (let ((delta (- angle-end start)))
+ (if (> delta min-angle)
+ (if x1
+ ;; Iteration 2+: Create a bezier curve for up to pi/2
+ ;; radians of the arc. Limiting a curve to <= pi/2
+ ;; radians creates a very close approximation of the
+ ;; true curve.
+ (let* ((size (min delta pi/2)) ; max segment angle is pi/2
+ ;; This curve segment spans the range [start,
+ ;; end] radians.
+ (end (+ start size))
+ (cos-end (cos end))
+ (sin-end (sin end))
+ ;; The end point is on the true arc.
+ (x2 (+ cx (* cos-end rx)))
+ (y2 (+ cy (* sin-end ry)))
+ ;; Alpha is the segment angle split in half.
+ ;; Looking at this on the unit circle, it puts
+ ;; half of the arc segment above the x axis and
+ ;; the other half below. Alpha is <= pi/4.
+ (alpha (/ size 2.0))
+ (cos-alpha (cos alpha))
+ ;; The unscaled, unrotated x coordinate of the
+ ;; control points. This formula makes it so
+ ;; that the midpoint of the bezier curve is the
+ ;; midpoint of the true arc.
+ (control-x (/ (- 4.0 cos-alpha) 3.0))
+ ;; The unscaled, unrotated, positive y
+ ;; coordinate of the control points. This
+ ;; formula makes it so that the control points
+ ;; are tangents to the true arc.
+ (control-y (+ (sin alpha)
+ (* (- cos-alpha control-x)
+ (/ 1.0 (tan alpha)))))
+ ;; All the preceding calculations were done
+ ;; with an arc segment somewhere in the range
+ ;; [-pi/4, pi/4]. In order to create a curve
+ ;; for the range [start, end], we need to
+ ;; rotate.
+ (rotation (+ start alpha))
+ (cos-rotation (cos rotation))
+ (sin-rotation (sin rotation))
+ ;; Compute the actual control points by
+ ;; applying the necessary rotation and linear
+ ;; scaling to achieve the ellipitcal shape at
+ ;; the desired size and location.
+ ;;
+ ;; Control point 1:
+ (cx1 (+ cx (* (+ (* control-x cos-rotation)
+ (* control-y sin-rotation))
+ rx)))
+ (cy1 (+ cy (* (- (* control-x sin-rotation)
+ (* control-y cos-rotation))
+ ry)))
+ ;; Control point 2:
+ (cx2 (+ cx (* (- (* control-x cos-rotation)
+ (* control-y sin-rotation))
+ rx)))
+ (cy2 (+ cy (* (+ (* control-x sin-rotation)
+ (* control-y cos-rotation))
+ ry))))
+ (cons (bezier-to (vec2 cx1 cy1)
+ (vec2 cx2 cy2)
+ (vec2 x2 y2))
+ (loop end cos-end sin-end x2 y2)))
+ ;; First iteration: Compute the starting point and move
+ ;; the brush to that point.
+ (let* ((cos-start (cos start))
+ (sin-start (sin start))
+ (x1 (+ cx (* cos-start rx)))
+ (y1 (+ cy (* sin-start ry))))
+ (cons (if prev-point
+ (line-to (vec2 x1 y1))
+ (move-to (vec2 x1 y1)))
+ (loop start cos-start sin-start x1 y1))))
+ ;; The remaining arc segment to render is either 0 or so
+ ;; miniscule that it won't be visible, so we're done.
+ '()))))
+ `(expand ,expand-arc)))
+
+(define* (arc-to control point radius)
+ (define distance-tolerance 0.01)
+ (define (close? a b)
+ (let ((dx (- (vec2-x b) (vec2-x a)))
+ (dy (- (vec2-y b) (vec2-y a))))
+ (< (+ (* dx dx) (* dy dy))
+ (* distance-tolerance distance-tolerance))))
+ (define (expand-arc-to prev-point)
+ (unless prev-point
+ (error "path cannot start with arc-to"))
+ ;; If the points are really close together, just use a line
+ ;; segment instead of an arc.
+ (if (close? point prev-point)
+ `((line-to ,point))
+ (let* ((d0 (vec2-normalize (vec2- prev-point control)))
+ (d1 (vec2-normalize (vec2- point control)))
+ (a (acos (+ (* (vec2-x d0) (vec2-x d1))
+ (* (vec2-y d0) (vec2-y d1)))))
+ (d (/ radius (tan (/ a 2.0)))))
+ (cond
+ ((> d 10000.0)
+ `((line-to ,point)))
+ ((> (vec2-cross d0 d1) 0.0)
+ (pk 'clockwise)
+ (let ((cx (+ (vec2-x control)
+ (* (vec2-x d0) d)
+ (* (vec2-y d0) radius)))
+ (cy (+ (vec2-y control)
+ (* (vec2-y d0) d)
+ (* (- (vec2-x d0)) radius)))
+ (angle-start (atan (- (vec2-y d0)) (vec2-x d0)))
+ (angle-end (atan (vec2-y d1) (- (vec2-x d1)))))
+ ;;(list (arc (vec2 cx cy) radius radius angle-start angle-end))
+ `((line-to ,control)
+ (line-to ,point))))
+ (else
+ (pk 'counter-clockwise)
+ (let ((cx (+ (vec2-x control)
+ (* (vec2-x d0) d)
+ (* (- (vec2-y d0)) radius)))
+ (cy (+ (vec2-y control)
+ (* (vec2-y d0) d)
+ (* (vec2-x d0) radius)))
+ (angle-start (atan (vec2-y d0) (- (vec2-x d0))))
+ (angle-end (atan (- (vec2-y d1)) (vec2-x d1))))
+ (list (arc (vec2 cx cy) radius radius angle-start angle-end))
+ ;; `((line-to ,control)
+ ;; (line-to ,point))
+ ))))))
+ `(expand ,expand-arc-to))
+
+(define-record-type <path>
+ (make-path commands bounding-box)
+ path?
+ (commands path-commands)
+ (bounding-box path-bounding-box))
+
+(define (path . commands)
+ (make-path (list->vector
+ ;; Expand and flatten the command list.
+ (let loop ((commands commands)
+ (prev-point #f))
+ (match commands
+ (() '())
+ ((command . rest)
+ (match command
+ ((or ('move-to point)
+ ('line-to point)
+ ('bezier-to _ _ point))
+ (cons command (loop rest point)))
+ ;; Recursively expand nested command list.
+ (('expand proc)
+ (loop (append (proc prev-point) rest) prev-point))
+ ;; Flatten nested command list.
+ (((? pair? sub-commands) ...)
+ (loop (append sub-commands rest) prev-point))
+ (other
+ (cons other (loop rest prev-point))))))))
+ ;; Compute bounding box.
+ (let loop ((commands commands)
+ (xmin 4294967295.0)
+ (xmax 0.0)
+ (ymin 4294967295.0)
+ (ymax 0.0))
+ (match commands
+ (()
+ (make-rect xmin ymin (- xmax xmin) (- ymax ymin)))
+ ((((or 'move-to 'line-to) point) . rest)
+ (loop rest
+ (min xmin (vec2-x point))
+ (max xmax (vec2-x point))
+ (min ymin (vec2-y point))
+ (max ymax (vec2-y point))))
+ ((('bezier-to control1 control2 point) . rest)
+ (loop rest
+ (min xmin (vec2-x control1) (vec2-x control2) (vec2-x point))
+ (max xmax (vec2-x control1) (vec2-x control2) (vec2-x point))
+ (min ymin (vec2-y control1) (vec2-y control2) (vec2-y point))
+ (max ymax (vec2-y control1) (vec2-y control2) (vec2-y point))))
+ ((_ . rest)
+ (loop rest xmin xmax ymin ymax))))))
+
+
+;;;
+;;; Closed path constructors
+;;;
+
+(define (line start end)
+ (path (move-to start)
+ (line-to end)))
+
+(define (polyline p1 p2 . prest)
+ (apply path
+ (move-to p1)
+ (line-to p2)
+ (map line-to prest)))
+
+(define (rectangle bottom-left width height)
+ (let ((x (vec2-x bottom-left))
+ (y (vec2-y bottom-left)))
+ (path (move-to bottom-left) ; bottom left
+ (line-to (vec2 (+ x width) y)) ; bottom right
+ (line-to (vec2 (+ x width) (+ y height))) ; top right
+ (line-to (vec2 x (+ y height))) ; top left
+ (close-path)))) ; back to bottom left
+
+(define (square bottom-left size)
+ (rectangle bottom-left size size))
+
+;; Kappa is the constant used for calculating the locations of control
+;; points for cubic bezier curves in order to create 90 degree arcs.
+;;
+;; The derivation can be found here:
+;; http://www.whizkidtech.redprince.net/bezier/circle/kappa/
+(define kappa 0.5522847498307936)
+
+(define* (rounded-rectangle bottom-left width height #:key
+ (radius 4.0)
+ (radius-bottom-left radius)
+ (radius-bottom-right radius)
+ (radius-top-left radius)
+ (radius-top-right radius))
+ (let* ((hw (/ width 2.0))
+ (hh (/ height 2.0))
+ (x (vec2-x bottom-left))
+ (y (vec2-y bottom-left))
+ (rxbl (min radius-bottom-left hw))
+ (rybl (min radius-bottom-left hh))
+ (rxbr (min radius-bottom-right hw))
+ (rybr (min radius-bottom-right hh))
+ (rxtl (min radius-top-left hw))
+ (rytl (min radius-top-left hh))
+ (rxtr (min radius-top-right hw))
+ (rytr (min radius-top-right hh)))
+ (path (move-to (vec2 x (+ y rytl)))
+ (line-to (vec2 x (- (+ y height) rybl)))
+ (bezier-to (vec2 x
+ (- (+ y height) (* rybl (- 1.0 kappa))))
+ (vec2 (+ x (* rxbl (- 1.0 kappa)))
+ (+ y height))
+ (vec2 (+ x rxbl)
+ (+ y height)))
+ (line-to (vec2 (- (+ x width) rxbr)
+ (+ y height)))
+ (bezier-to (vec2 (- (+ x width) (* rxbr (- 1.0 kappa)))
+ (+ y height))
+ (vec2 (+ x width)
+ (- (+ y height) (* rybr (- 1.0 kappa))))
+ (vec2 (+ x width)
+ (- (+ y height) rybr)))
+ (line-to (vec2 (+ x width)
+ (+ y rytr)))
+ (bezier-to (vec2 (+ x width)
+ (+ y (* rytr (- 1.0 kappa))))
+ (vec2 (- (+ x width) (* rxtr (- 1.0 kappa)))
+ y)
+ (vec2 (- (+ x width) rxtr)
+ y))
+ (line-to (vec2 (+ x rxtl) y))
+ (bezier-to (vec2 (+ x (* rxtl (- 1.0 kappa)))
+ y)
+ (vec2 x
+ (+ y (* rytl (- 1.0 kappa))))
+ (vec2 x (+ y rytl)))
+ (close-path))))
+
+(define (regular-polygon center num-sides radius)
+ (let ((theta-step (/ 2pi num-sides)))
+ (apply path
+ (let loop ((i 0))
+ (cond
+ ;; Return to the starting point to close the polygon.
+ ((= i num-sides)
+ (list (close-path)))
+ ;; First point needs to move the brush to the initial
+ ;; position directly above the center point.
+ ((zero? i)
+ (cons (move-to (vec2/polar center radius pi/2))
+ (loop (+ i 1))))
+ ;; Draw a line to the next point. Lines are drawn in a
+ ;; counter clockwise order.
+ (else
+ (cons (line-to (vec2/polar center radius
+ (+ (* i theta-step) pi/2)))
+ (loop (+ i 1)))))))))
+
+(define (ellipse center rx ry)
+ (let ((cx (vec2-x center))
+ (cy (vec2-y center)))
+ ;; To begin, move brush to the left of the center point.
+ (path (move-to (vec2 (- cx rx) cy))
+ ;; Draw a curve 90 degrees clockwise. The brush is now
+ ;; above the center point. The first control point is
+ ;; directly above the start point. The second control point
+ ;; is directly to the left of the end point. The kappa
+ ;; constant is used to place the control points just right
+ ;; so as to form a 90 degree arc with the desired radii.
+ (bezier-to (vec2 (- cx rx) (+ cy (* ry kappa)))
+ (vec2 (- cx (* rx kappa)) (+ cy ry))
+ (vec2 cx (+ cy ry)))
+ ;; Draw the same type of curve again, moving the brush to
+ ;; the right of the center point.
+ (bezier-to (vec2 (+ cx (* rx kappa)) (+ cy ry))
+ (vec2 (+ cx rx) (+ cy (* ry kappa)))
+ (vec2 (+ cx rx) cy))
+ ;; Now the brush moves below the center point.
+ (bezier-to (vec2 (+ cx rx) (- cy (* ry kappa)))
+ (vec2 (+ cx (* rx kappa)) (- cy ry))
+ (vec2 cx (- cy ry)))
+ ;; And finally back to the starting point to the left of the
+ ;; center point.
+ (bezier-to (vec2 (- cx (* rx kappa)) (- cy ry))
+ (vec2 (- cx rx) (- cy (* ry kappa)))
+ (vec2 (- cx rx) cy)))))
+
+(define (circle center r)
+ (ellipse center r r))
+
+
+;;;
+;;; Path Tesselation
+;;;
+
+;; Tesselation is a 2 step process:
+;;
+;; Step 1: Compile path commands into a sequence of points that form
+;; line segments.
+;;
+;; Step 2: Use compiled points to fill vertex buffers with triangles
+;; for filling or stroking.
+(define-record-type <compiled-path>
+ (%make-compiled-path point-capacity point-count path-capacity path-count bounding-box)
+ compiled-path?
+ (point-count compiled-path-point-count set-compiled-path-point-count!)
+ (point-capacity compiled-path-point-capacity set-compiled-path-point-capacity!)
+ (path-count compiled-path-count set-compiled-path-count!)
+ (path-capacity compiled-path-capacity set-compiled-path-capacity!)
+ (points compiled-path-points set-compiled-path-points!)
+ (offsets compiled-path-offsets set-compiled-path-offsets!)
+ (counts compiled-path-counts set-compiled-path-counts!)
+ (bounding-box compiled-path-bounding-box))
+
+(define (resize-compiled-path-offsets-and-counts! compiled-path capacity)
+ (let ((new-offsets (make-u32vector capacity))
+ (new-counts (make-u32vector capacity)))
+ (unless (zero? (compiled-path-capacity compiled-path))
+ (let ((old-offsets (compiled-path-offsets compiled-path))
+ (old-counts (compiled-path-counts compiled-path)))
+ (bytevector-copy! old-offsets 0 new-offsets 0 (bytevector-length old-offsets))
+ (bytevector-copy! old-counts 0 new-counts 0 (bytevector-length old-counts))))
+ (set-compiled-path-offsets! compiled-path new-offsets)
+ (set-compiled-path-counts! compiled-path new-counts)
+ (set-compiled-path-capacity! compiled-path capacity)))
+
+(define (resize-compiled-path-points! compiled-path capacity)
+ (let ((new-points (make-f32vector (* capacity 2))))
+ (unless (zero? (compiled-path-point-capacity compiled-path))
+ (let ((old-points (compiled-path-points compiled-path)))
+ (bytevector-copy! old-points 0 new-points 0 (bytevector-length old-points))))
+ (set-compiled-path-points! compiled-path new-points)
+ (set-compiled-path-point-capacity! compiled-path capacity)))
+
+(define (make-compiled-path)
+ (let ((compiled-path (%make-compiled-path 0 0 0 0 (make-rect 0.0 0.0 0.0 0.0))))
+ (resize-compiled-path-offsets-and-counts! compiled-path 64)
+ (resize-compiled-path-points! compiled-path 256)
+ compiled-path))
+
+(define (clear-compiled-path compiled-path)
+ (set-compiled-path-count! compiled-path 0)
+ (set-compiled-path-point-count! compiled-path 0))
+
+(define %origin (vec2 0.0 0.0))
+
+(define (transform-bounding-box rect matrix)
+ (let* ((x1 (rect-x rect))
+ (y1 (rect-y rect))
+ (x2 (rect-right rect))
+ (y2 (rect-top rect))
+ (bottom-left (matrix3-transform matrix (vec2 x1 y1)))
+ (bottom-right (matrix3-transform matrix (vec2 x2 y1)))
+ (top-right (matrix3-transform matrix (vec2 x2 y2)))
+ (top-left (matrix3-transform matrix (vec2 x1 y2)))
+ (min-x (min (vec2-x bottom-left)
+ (vec2-x bottom-right)
+ (vec2-x top-right)
+ (vec2-x top-left)))
+ (min-y (min (vec2-y bottom-left)
+ (vec2-y bottom-right)
+ (vec2-y top-right)
+ (vec2-y top-left)))
+ (max-x (max (vec2-x bottom-left)
+ (vec2-x bottom-right)
+ (vec2-x top-right)
+ (vec2-x top-left)))
+ (max-y (max (vec2-y bottom-left)
+ (vec2-y bottom-right)
+ (vec2-y top-right)
+ (vec2-y top-left))))
+ (make-rect min-x min-y (- max-x min-x) (- max-y min-y))))
+
+(define (compile-path compiled-path path matrix)
+ ;; Command interpreter:
+ (define (add-point x y)
+ (let* ((n (compiled-path-point-count compiled-path))
+ (i (* n 2))
+ (c (compiled-path-point-capacity compiled-path)))
+ ;; Dynamically expand point buffer as needed.
+ (when (= n c)
+ (resize-compiled-path-points! compiled-path (* c 2)))
+ (let ((points (compiled-path-points compiled-path)))
+ (f32vector-set! points i x)
+ (f32vector-set! points (+ i 1) y)
+ (set-compiled-path-point-count! compiled-path (+ n 1)))))
+ (define (add-path offset)
+ (let* ((n (compiled-path-count compiled-path))
+ (c (compiled-path-capacity compiled-path)))
+ ;; Dynamically expand count/offset buffers, as needed.
+ (when (= n c)
+ (resize-compiled-path-offsets-and-counts! compiled-path (* c 2)))
+ (let ((offsets (compiled-path-offsets compiled-path))
+ (counts (compiled-path-counts compiled-path)))
+ (u32vector-set! offsets n offset)
+ (u32vector-set! counts n (- (compiled-path-point-count compiled-path) offset))
+ (set-compiled-path-count! compiled-path (+ n 1)))))
+ ;; Expand bounding box to cover the new path, taking into account
+ ;; the transformation matrix.
+ (rect-union! (compiled-path-bounding-box compiled-path)
+ (transform-bounding-box (path-bounding-box path) matrix))
+ ;; Evaluate all commands. This simple virtual machine uses a
+ ;; brush-on-paper metaphor and has a few variables that can be
+ ;; manipulated:
+ ;;
+ ;; - offset: the index to the first point of the current path in the
+ ;; compiled path's collection of points.
+ ;;
+ ;; - brush: the current location of the imaginary brush that is
+ ;; drawing the path. Some commands move the brush while its on the
+ ;; paper, thus creating a path, while others may pick the brush up
+ ;; and move it to a different location.
+ ;;
+ ;; - first: the starting point of the current brush stroke. This is
+ ;; used to handle the close command, where a straight line is drawn
+ ;; directly back to the beginning of the path.
+ (let loop ((commands (path-commands path))
+ (i 0)
+ (offset (compiled-path-point-count compiled-path))
+ (brush %origin)
+ (first #f))
+ (cond
+ ((< i (vector-length commands))
+ (match (vector-ref commands i)
+ ;; Move the brush without adding any new points. Reset first
+ ;; and prev since the brush isn't on the paper anymore.
+ (('move-to point)
+ (let ((point (matrix3-transform matrix point)))
+ (if first
+ ;; Moving the brush completes the current path and starts
+ ;; a new one.
+ (begin
+ (add-path offset)
+ (loop commands (+ i 1) (compiled-path-point-count compiled-path) point #f))
+ ;; Moving the brush before drawing anything is a noop.
+ (loop commands (+ i 1) offset point #f))))
+ ;; Draw a line from the current brush position to the given
+ ;; point.
+ (('line-to point)
+ (let ((point (matrix3-transform matrix point)))
+ (if first
+ (begin
+ (add-point (vec2-x point) (vec2-y point))
+ (loop commands (+ i 1) offset point first))
+ ;; This is the first time we're moving the brush while
+ ;; its on the paper, so we have to add the initial brush
+ ;; point in addition to the line endpoint.
+ (begin
+ (add-point (vec2-x brush) (vec2-y brush))
+ (add-point (vec2-x point) (vec2-y point))
+ (loop commands (+ i 1) offset point brush)))))
+ ;; Draw a cubic bezier curve from the current brush position
+ ;; to the given point.
+ (('bezier-to control1 control2 point)
+ (let ((control1 (matrix3-transform matrix control1))
+ (control2 (matrix3-transform matrix control2))
+ (point (matrix3-transform matrix point)))
+ (unless first
+ (add-point (vec2-x brush) (vec2-y brush)))
+ ;; Approximate a Bezier curve using De Casteljau's method
+ ;; of recursive subdivision.
+ ;;
+ ;; This implementation is based on the paper "Piecewise
+ ;; Linear Approximation of Bezier Curves" (2000) by Kaspar
+ ;; Fischer.
+ ;;
+ ;; https://pdfs.semanticscholar.org/fdf9/3b43da6de234a023d0a0d353f713ba8c5cb5.pdf
+ (let flatten ((x1 (vec2-x brush))
+ (y1 (vec2-y brush))
+ (cx1 (vec2-x control1))
+ (cy1 (vec2-y control1))
+ (cx2 (vec2-x control2))
+ (cy2 (vec2-y control2))
+ (x2 (vec2-x point))
+ (y2 (vec2-y point)))
+ ;; Calculate how flat the curve is. If the curve is
+ ;; sufficiently flat, we can approximate it with a
+ ;; straight line from its start point to its end point. I
+ ;; don't understand this part yet, tbh, but it works
+ ;; well.
+ (let* ((ux (max (- (* cx1 3.0) (* x1 2.0) x2)
+ (- (* cx2 3.0) (* x2 2.0) x1)))
+ (uy (max (- (* cy1 3.0) (* y1 2.0) y2)
+ (- (* cy2 3.0) (* y2 2.0) y1)))
+ ;; TODO: Figure out a tolerance value based on the
+ ;; screen we're rendering to so that our
+ ;; approximation doesn't look jaggy.
+ (tol 0.25)
+ (tolerance (* tol tol 16.0)))
+ ;; Are ya flat enough, son?
+ (if (<= (+ (* ux ux) (* uy uy)) tolerance)
+ ;; Curve is within the tolerance range for
+ ;; flatness. Add a point to the baked path and
+ ;; increment the point count.
+ (add-point x2 y2)
+ ;; Curve is not flat enough, so split the curve
+ ;; into 2 smaller curves (left and right) that
+ ;; together describe the same curve as the
+ ;; original. To figure out the start, end, and
+ ;; control points for these 2 smaller curves, we
+ ;; work from the start and end points of the
+ ;; original curve and move inward.
+ (let* (;; Left start point is the same as the
+ ;; original start point.
+ (lx1 x1)
+ (ly1 y1)
+ ;; Right end point is the same as the
+ ;; original end point.
+ (rx2 x2)
+ (ry2 y2)
+ ;; Left control point 1 is the midpoint of
+ ;; the line formed by the start point and
+ ;; the control point 1.
+ (lcx1 (/ (+ x1 cx1) 2.0))
+ (lcy1 (/ (+ y1 cy1) 2.0))
+ ;; Right control point 2 is the midpoint of
+ ;; the line formed by control point 2 and
+ ;; the end point.
+ (rcx2 (/ (+ cx2 x2) 2.0))
+ (rcy2 (/ (+ cy2 y2) 2.0))
+ ;; m is the midpoint of the line formed by
+ ;; control points 1 and 2.
+ (mx (/ (+ cx1 cx2) 2.0))
+ (my (/ (+ cy1 cy2) 2.0))
+ ;; Left control point 2 is the midpoint of
+ ;; the line formed by m and left control
+ ;; point 1.
+ (lcx2 (/ (+ lcx1 mx) 2.0))
+ (lcy2 (/ (+ lcy1 my) 2.0))
+ ;; Right control point 1 is the midpoint of
+ ;; the line formed by m and right control
+ ;; point 2.
+ (rcx1 (/ (+ mx rcx2) 2.0))
+ (rcy1 (/ (+ my rcy2) 2.0))
+ ;; The left end point and the right start
+ ;; point are the same. This point is the
+ ;; midpoint of the line formed by left
+ ;; control point 2 and right control point
+ ;; 1.
+ (lx2 (/ (+ lcx2 rcx1) 2.0))
+ (ly2 (/ (+ lcy2 rcy1) 2.0))
+ (rx1 lx2)
+ (ry1 ly2))
+ ;; Recursively subdivide the left side first,
+ ;; then the right.
+ (flatten lx1 ly1 lcx1 lcy1 lcx2 lcy2 lx2 ly2)
+ (flatten rx1 ry1 rcx1 rcy1 rcx2 rcy2 rx2 ry2)))))
+ (loop commands (+ i 1) offset point (or first brush))))
+ ;; Draw a line back to the first point.
+ (('close)
+ (if first
+ ;; Add a point that is the same as the first point in the
+ ;; path, then start a new path.
+ (begin
+ (unless (vec2= brush first)
+ (add-point (vec2-x first) (vec2-y first)))
+ (add-path offset)
+ (loop commands (+ i 1) (compiled-path-point-count compiled-path) brush #f))
+ ;; Closing a loop with no points is a noop.
+ (loop commands (+ i 1) offset brush #f)))
+ ;; Unknown command.
+ (((? symbol? name) . _)
+ (error "unrecognized path command" name))
+ ;; Straight up garbage.
+ (invalid-command
+ (error "invalid path command" invalid-command))))
+ ;; All commands processed. All that's left to do is check if
+ ;; an unclosed path has been left hanging and add it.
+ ((= offset (compiled-path-point-count compiled-path))
+ ;; The last path was closed, so there's nothing left to do.
+ #t)
+ (else
+ ;; The last path isn't closed, so we just need to register the
+ ;; open path.
+ (add-path offset)))))
+
+(define-record-type <stroked-path>
+ (%make-stroked-path color width feather cap
+ vertex-count index-count
+ vertex-capacity index-capacity
+ vertex-buffer index-buffer vertex-array)
+ stroked-path?
+ (color stroked-path-color)
+ (width stroked-path-width)
+ (feather stroked-path-feather)
+ (cap stroked-path-cap)
+ (vertex-count stroked-path-vertex-count set-stroked-path-vertex-count!)
+ (index-count stroked-path-index-count set-stroked-path-index-count!)
+ (vertex-capacity stroked-path-vertex-capacity set-stroked-path-vertex-capacity!)
+ (index-capacity stroked-path-index-capacity set-stroked-path-index-capacity!)
+ (vertex-buffer stroked-path-vertex-buffer)
+ (index-buffer stroked-path-index-buffer)
+ (vertex-array stroked-path-vertex-array))
+
+(define (resize-stroked-path-vertex-buffer! stroked-path capacity)
+ (resize-buffer! (stroked-path-vertex-buffer stroked-path)
+ (* capacity 20)) ; 20 bytes per vertex: x y u v length
+ (set-stroked-path-vertex-capacity! stroked-path capacity))
+
+(define (resize-stroked-path-index-buffer! stroked-path capacity)
+ (resize-buffer! (stroked-path-index-buffer stroked-path)
+ (* capacity 4)) ; 4 bytes per index
+ (set-stroked-path-index-capacity! stroked-path capacity))
+
+(define (make-stroked-path color width feather cap)
+ (let* ((vertex-buffer (make-buffer #f
+ #:name "stroke vertex buffer"
+ ;; Vertex layout:
+ ;; - x, y
+ ;; - u, v
+ ;; - length of current path
+ #:stride (* 5 4) ; 5 f32s
+ #:usage 'stream))
+ (index-buffer (make-buffer #f
+ #:name "stroke index buffer"
+ #:target 'index
+ #:usage 'stream))
+ (verts (make-buffer-view #:name "stroke vertices"
+ #:buffer vertex-buffer
+ #:type 'vec2
+ #:component-type 'float))
+ (tex (make-buffer-view #:name "stroke texcoords"
+ #:buffer vertex-buffer
+ #:type 'vec2
+ #:component-type 'float
+ #:offset 8))
+ (lengths (make-buffer-view #:name "stroke lengths"
+ #:buffer vertex-buffer
+ #:type 'scalar
+ #:component-type 'float
+ #:offset 16))
+ (index (make-buffer-view #:name "stroke index"
+ #:buffer index-buffer
+ #:type 'scalar
+ #:component-type 'unsigned-int))
+ (vertex-array (make-vertex-array #:indices index
+ #:attributes `((0 . ,verts)
+ (1 . ,tex)
+ (2 . ,lengths))))
+ (stroked-path (%make-stroked-path color width feather cap
+ 0 0 0 0
+ vertex-buffer
+ index-buffer
+ vertex-array)))
+ (resize-stroked-path-vertex-buffer! stroked-path 1024)
+ (resize-stroked-path-index-buffer! stroked-path 1024)
+ stroked-path))
+
+(define (clear-stroked-path stroked-path)
+ (set-stroked-path-vertex-count! stroked-path 0)
+ (set-stroked-path-index-count! stroked-path 0))
+
+;; Tesselation of stroked paths involves building rectangles composed
+;; of 2 triangles for each line segment in the path. This
+;; implementation is based upon the paper "Shader-Based, Antialiased,
+;; Dashed, Stroked Polylines" by Nicolas P. Rougier.
+;;
+;; See: https://pdfs.semanticscholar.org/5ec2/8762c868b410b8388181d63a17469c38b26c.pdf
+(define* (stroke-path compiled-path #:key color width feather cap)
+ (let ((stroked-path (make-stroked-path color width feather cap)))
+ (with-mapped-buffer (stroked-path-vertex-buffer stroked-path)
+ (with-mapped-buffer (stroked-path-index-buffer stroked-path)
+ (let ((points (compiled-path-points compiled-path))
+ (offsets (compiled-path-offsets compiled-path))
+ (counts (compiled-path-counts compiled-path))
+ (path-count (compiled-path-count compiled-path))
+ (padding (/ (ceiling (+ width (* feather 2.5))) 2.0)))
+ (define (add-points first? lx ly rx ry distance)
+ ;; Resize buffers, if necessary.
+ (let ((vert-count (stroked-path-vertex-count stroked-path))
+ (vert-capacity (stroked-path-vertex-capacity stroked-path))
+ (index-count (stroked-path-index-count stroked-path))
+ (index-capacity (stroked-path-index-capacity stroked-path)))
+ (when (> (+ vert-count 2) vert-capacity)
+ (resize-stroked-path-vertex-buffer! stroked-path
+ (* vert-capacity 2))
+ (map-buffer! (stroked-path-vertex-buffer stroked-path)))
+ (when (> (+ index-count 6) index-capacity)
+ (resize-stroked-path-index-buffer! stroked-path
+ (* index-capacity 2))
+ (map-buffer! (stroked-path-index-buffer stroked-path)))
+ (let ((verts (buffer-data
+ (stroked-path-vertex-buffer stroked-path)))
+ (voffset (* vert-count 5))) ; 5 floats per vertex
+ ;; Left
+ (f32vector-set! verts voffset lx)
+ (f32vector-set! verts (+ voffset 1) ly)
+ (f32vector-set! verts (+ voffset 2) distance)
+ (f32vector-set! verts (+ voffset 3) padding)
+ ;; Right
+ (f32vector-set! verts (+ voffset 5) rx)
+ (f32vector-set! verts (+ voffset 6) ry)
+ (f32vector-set! verts (+ voffset 7) distance)
+ (f32vector-set! verts (+ voffset 8) (- padding))
+ (set-stroked-path-vertex-count! stroked-path (+ vert-count 2))
+ ;; On the first iteration we only have 2 points which is
+ ;; not enough to create line segment geometry which
+ ;; requires looking at the newest 2 points + the 2
+ ;; previous points.
+ (unless first?
+ (let ((index (buffer-data
+ (stroked-path-index-buffer stroked-path))))
+ (u32vector-set! index index-count (- vert-count 1))
+ (u32vector-set! index (+ index-count 1) (- vert-count 2))
+ (u32vector-set! index (+ index-count 2) vert-count)
+ (u32vector-set! index (+ index-count 3) (- vert-count 1))
+ (u32vector-set! index (+ index-count 4) vert-count)
+ (u32vector-set! index (+ index-count 5) (+ vert-count 1))
+ (set-stroked-path-index-count! stroked-path (+ index-count 6)))))))
+ (define (set-length i length)
+ (let ((verts (buffer-data (stroked-path-vertex-buffer stroked-path)))
+ (voffset (* i 10)))
+ (f32vector-set! verts (+ voffset 4) length)
+ (f32vector-set! verts (+ voffset 9) length)))
+ (let path-loop ((i 0))
+ (when (< i path-count)
+ (let* ((count (u32vector-ref counts i))
+ (first (u32vector-ref offsets i))
+ (last (+ first count -1))
+ (open? (or (not (= (f32vector-ref points (* first 2))
+ (f32vector-ref points (* last 2))))
+ (not (= (f32vector-ref points (+ (* first 2) 1))
+ (f32vector-ref points (+ (* last 2) 1))))))
+ (last* (- last 1)))
+ (let point-loop ((j first)
+ ;; How far along the line segment we are.
+ (distance 0.0))
+ (when (<= j last)
+ (let ((x (f32vector-ref points (* j 2)))
+ (y (f32vector-ref points (+ (* j 2) 1))))
+ (cond
+ ;; End caps.
+ ((and open? (= j first))
+ (let* ((next-offset (* (+ j 1) 2))
+ (next-x (f32vector-ref points next-offset))
+ (next-y (f32vector-ref points (+ next-offset 1)))
+ (dx (- x next-x))
+ (dy (- y next-y))
+ (mag (sqrt (+ (* dx dx) (* dy dy))))
+ (norm-x (/ dx mag))
+ (norm-y (/ dy mag))
+ (pad-x (* norm-x padding))
+ (pad-y (* norm-y padding))
+ (lx (+ x pad-x pad-y))
+ (ly (- (+ y pad-y) pad-x))
+ (rx (- (+ x pad-x) pad-y))
+ (ry (+ y pad-y pad-x)))
+ (add-points #t lx ly rx ry (- distance padding))
+ (point-loop (+ j 1) (+ distance padding mag))))
+ ((and open? (= j last))
+ (let* ((prev-offset (* (- j 1) 2))
+ (prev-x (f32vector-ref points prev-offset))
+ (prev-y (f32vector-ref points (+ prev-offset 1)))
+ (dx (- x prev-x))
+ (dy (- y prev-y))
+ (mag (sqrt (+ (* dx dx) (* dy dy))))
+ (norm-x (/ dx mag))
+ (norm-y (/ dy mag))
+ (pad-x (* norm-x padding))
+ (pad-y (* norm-y padding))
+ (lx (- (+ x pad-x) pad-y))
+ (ly (+ y pad-y pad-x))
+ (rx (+ x pad-x pad-y))
+ (ry (- (+ y pad-y) pad-x)))
+ (add-points #f lx ly rx ry (+ distance padding))))
+ ;; Point is somewhere in the middle of the path
+ ;; (or the first/last point within a closed loop)
+ ;; and needs to be mitered.
+ ;;
+ ;; The vector math used to make a miter joint for
+ ;; a polyline is based on this informative forum
+ ;; thread:
+ ;;
+ ;; https://forum.libcinder.org/topic/smooth-thick-lines-using-geometry-shader
+ (else
+ ;; For the prev/next offsets, we need to account
+ ;; for closed loops. When j = last, we need the
+ ;; next index to be 1. Likewise, when j =
+ ;; first, we need the previous index to be
+ ;; offset + count - 1, in other words: the
+ ;; second to last point. This is because the
+ ;; first and last points of a closed loop are
+ ;; the same, so in order to know how to miter
+ ;; the first and last line segments we need to
+ ;; know about the second and second to last
+ ;; points in the compiled path buffer. The
+ ;; modulo operator is our best friend when it
+ ;; comes to wrapping values to a range.
+ (let* ((prev-offset (* (+ (modulo (- j first 1)
+ (- count 1))
+ first)
+ 2))
+ (prev-x (f32vector-ref points prev-offset))
+ (prev-y (f32vector-ref points (+ prev-offset 1)))
+ (next-offset (* (+ (modulo (- j first)
+ (- count 1))
+ first 1)
+ 2))
+ (next-x (f32vector-ref points next-offset))
+ (next-y (f32vector-ref points (+ next-offset 1)))
+ ;; Vector from (x, y) to (next-x next-y).
+ (ndx (- next-x x))
+ (ndy (- next-y y))
+ ;; Normalized form.
+ (nmag (sqrt (+ (* ndx ndx) (* ndy ndy))))
+ (nx (if (zero? nmag) 0.0 (/ ndx nmag)))
+ (ny (if (zero? nmag) 0.0 (/ ndy nmag)))
+ ;; Vector from (prev-x, prev-y) to (x, y).
+ (pdx (- x prev-x))
+ (pdy (- y prev-y))
+ ;; Normalized form.
+ (pmag (sqrt (+ (* pdx pdx) (* pdy pdy))))
+ (px (if (zero? pmag) 0.0 (/ pdx pmag)))
+ (py (if (zero? pmag) 0.0 (/ pdy pmag)))
+ ;; Tangent of the 2 vectors.
+ (tanx (+ nx px))
+ (tany (+ ny py))
+ ;; Normalized form.
+ (tanmag (sqrt (+ (* tanx tanx) (* tany tany))))
+ (ntanx (if (zero? tanmag) 0.0 (/ tanx tanmag)))
+ (ntany (if (zero? tanmag) 0.0 (/ tany tanmag)))
+ ;; In order to join 2 line segments
+ ;; together neatly, they must have
+ ;; mitered corners. The miter direction
+ ;; is perpendicular to the tangent of the
+ ;; 2 line segments.
+ (miterx (- ntany))
+ (mitery ntanx)
+ ;; In order to compute the proper length
+ ;; of the miter line, we need to project
+ ;; the miter vector (which is in
+ ;; normalized form) onto the normalized
+ ;; form of a vector for one of the line
+ ;; segments. It doesn't matter which
+ ;; vector is used, so I chose the vector
+ ;; from the current point to the
+ ;; previous.
+ (miter-dot (+ (* miterx (- py)) (* mitery px)))
+ (miter-length (abs (/ padding miter-dot)))
+ ;; Finally, we can compute the vector
+ ;; that will thicken the line, but
+ ;; there's a catch. If the two line
+ ;; segments were parallel, computing the
+ ;; miter length caused a division by
+ ;; zero, so we need to treat that
+ ;; special.
+ (padx (* miterx miter-length))
+ (pady (* mitery miter-length))
+ ;; Left side
+ (lx (+ x padx))
+ (ly (+ y pady))
+ ;; Right side
+ (rx (- x padx))
+ (ry (- y pady)))
+ (add-points (= j first) lx ly rx ry distance)
+ (point-loop (+ j 1) (+ distance nmag)))))))
+ (when (= j last)
+ ;; Go over the points one more time to set the total
+ ;; length in each vertex.
+ (let length-loop ((k first))
+ (when (<= k last)
+ (set-length k distance)
+ (length-loop (+ k 1)))))))
+ (path-loop (+ i 1)))))))
+ stroked-path))
+
+(define-record-type <filled-path>
+ (%make-filled-path color count stencil-vertex-count stencil-vertex-capacity
+ stencil-vertex-buffer stencil-vertex-array
+ quad-vertex-buffer quad-vertex-array)
+ filled-path?
+ (color filled-path-color)
+ (counts filled-path-counts set-filled-path-counts!)
+ (offsets filled-path-offsets set-filled-path-offsets!)
+ (count filled-path-count set-filled-path-count!)
+ (stencil-vertex-count filled-path-stencil-vertex-count
+ set-filled-path-stencil-vertex-count!)
+ (stencil-vertex-capacity filled-path-stencil-vertex-capacity
+ set-filled-path-stencil-vertex-capacity!)
+ (stencil-vertex-buffer filled-path-stencil-vertex-buffer)
+ (stencil-vertex-array filled-path-stencil-vertex-array)
+ (quad-vertex-buffer filled-path-quad-vertex-buffer)
+ (quad-vertex-array filled-path-quad-vertex-array))
+
+(define (resize-filled-path-stencil-vertex-buffer! filled-path capacity)
+ (resize-buffer! (filled-path-stencil-vertex-buffer filled-path)
+ (* capacity 8)) ; 2 f32s per vertex: x y
+ (set-filled-path-stencil-vertex-capacity! filled-path capacity))
+
+(define (make-filled-path color)
+ (let* ((quad-vertex-buffer (make-buffer #f
+ #:length (* 8 4) ; 8 f32s
+ #:name "fill quad vertices"
+ #:usage 'stream))
+ (quad-verts (make-buffer-view #:name "fill quad vertices"
+ #:buffer quad-vertex-buffer
+ #:type 'vec2
+ #:component-type 'float))
+ (quad-index (make-buffer-view #:name "fill quad index"
+ #:type 'scalar
+ #:component-type 'unsigned-int
+ #:buffer (make-buffer (u32vector 0 2 3 0 1 2)
+ #:name "fill quad index"
+ #:target 'index)))
+ (quad-vertex-array (make-vertex-array #:indices quad-index
+ #:attributes `((0 . ,quad-verts))))
+ (stencil-vertex-buffer (make-buffer #f
+ #:name "fill stencil vertices"
+ #:usage 'stream))
+ (stencil-verts (make-buffer-view #:name "fill stencil vertices"
+ #:buffer stencil-vertex-buffer
+ #:type 'vec2
+ #:component-type 'float))
+ (stencil-vertex-array (make-vertex-array #:attributes `((0 . ,stencil-verts))
+ #:mode 'triangle-fan))
+ (filled-path (%make-filled-path color 0 0 0
+ stencil-vertex-buffer
+ stencil-vertex-array
+ quad-vertex-buffer
+ quad-vertex-array)))
+ ;; TODO: Adjust this starting size to something better.
+ (resize-filled-path-stencil-vertex-buffer! filled-path 1024)
+ filled-path))
+
+(define (clear-filled-path filled-path)
+ (set-filled-path-count! filled-path 0)
+ (set-filled-path-stencil-vertex-count! filled-path 0))
+
+(define* (fill-path compiled-path #:key (color black))
+ (let* ((filled-path (make-filled-path color))
+ (points (compiled-path-points compiled-path))
+ (offsets (compiled-path-offsets compiled-path))
+ (counts (compiled-path-counts compiled-path))
+ (path-count (compiled-path-count compiled-path))
+ (bbox (compiled-path-bounding-box compiled-path))
+ ;; Every triangle fan that we create will contain this
+ ;; reference point as the initial point. Mathematically
+ ;; speaking, any point can be chosen and the fill algorithm
+ ;; will still behave correctly. Choosing a point within the
+ ;; path's bounding box should lead to less fragments on the
+ ;; GPU, though, and the center of the bounding box seems like
+ ;; a sensible location.
+ (ref-x (rect-center-x bbox))
+ (ref-y (rect-center-y bbox)))
+ ;; Setup counts and offsets.
+ (set-filled-path-count! filled-path path-count)
+ (let ((bv (make-u32vector path-count)))
+ (let loop ((i 0))
+ (when (< i path-count)
+ (u32vector-set! bv i (+ (u32vector-ref counts i) 1))
+ (loop (+ i 1))))
+ (set-filled-path-counts! filled-path bv))
+ (let ((bv (make-u32vector path-count)))
+ (let loop ((i 0))
+ (when (< i path-count)
+ (u32vector-set! bv i (+ (u32vector-ref offsets i) i))
+ (loop (+ i 1))))
+ (set-filled-path-offsets! filled-path bv))
+ ;; Create geometry for the stencil buffer.
+ (with-mapped-buffer (filled-path-stencil-vertex-buffer filled-path)
+ (let loop ((i 0))
+ (when (< i path-count)
+ (let* ((count (u32vector-ref counts i))
+ (first (u32vector-ref offsets i))
+ (last (+ first count -1))
+ (n (filled-path-stencil-vertex-count filled-path)))
+ ;; Resize buffer, if necessary.
+ (let ((capacity (filled-path-stencil-vertex-capacity filled-path)))
+ (when (>= (+ n count 1) capacity)
+ (let ((new-capacity (let cloop ((c (* capacity 2)))
+ (if (> c (+ n count 1))
+ c
+ (cloop (* c 2))))))
+ (resize-filled-path-stencil-vertex-buffer! filled-path
+ new-capacity)
+ (map-buffer! (filled-path-stencil-vertex-buffer filled-path)))))
+ (let ((verts (buffer-data (filled-path-stencil-vertex-buffer filled-path)))
+ (offset (* n 2)))
+ ;; Build the triangle fan for the path. This geometry
+ ;; will be used for a GPU-based implementation of the
+ ;; non-zero rule:
+ ;;
+ ;; See: https://en.wikipedia.org/wiki/Nonzero-rule
+ ;;
+ ;; Add reference point as the basis for each triangle in
+ ;; the fan.
+ (f32vector-set! verts offset ref-x)
+ (f32vector-set! verts (+ offset 1) ref-y)
+ ;; Now simply copy all the points in the path into the
+ ;; buffer. Each point is stored as 2 f32s, so 8 bytes per
+ ;; point.
+ (bytevector-copy! points (* first 8) verts (* (+ n 1) 8) (* count 8))
+ (set-filled-path-stencil-vertex-count! filled-path (+ n count 1))))
+ (loop (+ i 1)))))
+ ;; Create simple quad covering the bounding box to be used for the
+ ;; final render pass with stencil applied.
+ ;;
+ ;; TODO: A convex hull would result in less fragments to process.
+ (with-mapped-buffer (filled-path-quad-vertex-buffer filled-path)
+ (let ((verts (buffer-data (filled-path-quad-vertex-buffer filled-path)))
+ (x1 (rect-x bbox))
+ (y1 (rect-y bbox))
+ (x2 (rect-right bbox))
+ (y2 (rect-top bbox)))
+ (f32vector-set! verts 0 x1)
+ (f32vector-set! verts 1 y1)
+ (f32vector-set! verts 2 x2)
+ (f32vector-set! verts 3 y1)
+ (f32vector-set! verts 4 x2)
+ (f32vector-set! verts 5 y2)
+ (f32vector-set! verts 6 x1)
+ (f32vector-set! verts 7 y2)))
+ filled-path))
+
+
+;;;
+;;; Rendering
+;;;
+
+(define fill-shader
+ (delay
+ (strings->shader
+ "
+#ifdef GLSL330
+layout (location = 0) in vec2 position;
+layout (location = 1) in vec2 tex;
+layout (location = 2) in float strokeLength;
+#elif defined(GLSL130)
+in vec2 position;
+in vec2 tex;
+in float length;
+#elif defined(GLSL120)
+attribute vec2 position;
+attribute vec2 tex;
+attribute float length;
+#endif
+#ifdef GLSL120
+varying vec2 fragTex;
+#else
+out vec2 fragTex;
+out float fragStrokeLength;
+#endif
+uniform mat4 mvp;
+
+void main(void) {
+ fragTex = tex;
+ fragStrokeLength = strokeLength;
+ gl_Position = mvp * vec4(position.xy, 0.0, 1.0);
+}
+"
+ "
+#ifdef GLSL330
+out vec4 fragColor;
+#endif
+#ifdef GLSL120
+attribute vec2 fragTex;
+attribute float fragStrokeLength;
+#else
+in vec2 fragTex;
+in float fragStrokeLength;
+#endif
+uniform int mode;
+uniform vec4 color;
+uniform float feather;
+uniform float strokeWidth;
+uniform int strokeCap;
+float infinity = 1.0 / 0.0;
+
+void main(void) {
+ // fill mode
+ if(mode == 0) {
+#ifdef GLSL330
+ fragColor = color;
+#else
+ gl_FragColor = color;
+#endif
+ } else if(mode == 1) { // stroke mode
+ float hw = strokeWidth / 2.0;
+ float u = fragTex.x;
+ float v = fragTex.y;
+ float dx;
+ float dy;
+ float d;
+
+ if (u < 0 || u > fragStrokeLength) {
+ if (u < 0) {
+ dx = abs(u);
+ } else {
+ dx = u - fragStrokeLength;
+ }
+ dy = abs(v);
+
+ switch (strokeCap) {
+ // none
+ case 0:
+ d = infinity;
+ break;
+ // butt
+ case 1:
+ d = max(dx + hw - 2 * feather, dy);
+ break;
+ // square
+ case 2:
+ d = max(dx, dy);
+ break;
+ // round
+ case 3:
+ d = sqrt(dx * dx + dy * dy);
+ break;
+ // triangle out
+ case 4:
+ d = dx + dy;
+ break;
+ // triangle in
+ case 5:
+ d = max(dy, hw - feather + dx - dy);
+ break;
+ }
+ } else {
+ d = abs(v);
+ }
+
+ if(d <= hw) {
+#ifdef GLSL330
+ fragColor = color;
+#else
+ gl_FragColor = color;
+#endif
+ } else {
+ vec4 c = vec4(color.rgb, color.a * (1.0 - ((d - hw) / feather)));
+#ifdef GLSL330
+ fragColor = c;
+#else
+ gl_FragColor = c;
+#endif
+ }
+ }
+}
+")))
+
+(define stencil-flip
+ (make-stencil-test #:on-pass 'invert))
+
+(define stencil-cover-and-clear
+ (make-stencil-test #:on-fail 'zero #:on-depth-fail 'zero #:on-pass 'zero
+ #:function 'not-equal))
+
+;; TODO: gradients
+(define* (draw-filled-path filled-path #:key (debug? #f))
+ (let ((counts (filled-path-counts filled-path))
+ (offsets (filled-path-offsets filled-path))
+ (n (filled-path-count filled-path)))
+ (if debug?
+ ;; Wireframe debug mode.
+ (begin
+ (gl-polygon-mode (cull-face-mode front) (polygon-mode line))
+ (let loop ((i 0))
+ (when (< i n)
+ (gpu-apply* (force fill-shader)
+ (filled-path-stencil-vertex-array filled-path)
+ (u32vector-ref offsets i)
+ (u32vector-ref counts i)
+ #:mvp (current-projection)
+ #:mode 0)
+ (loop (+ i 1))))
+ (gl-polygon-mode (cull-face-mode front) (polygon-mode fill)))
+ ;; Anti-alias the edges of the fill.
+ (with-multisample #t
+ ;; Render fan to stencil buffer. Each time a triangle is
+ ;; rasterized, it flips the values in the stencil buffer for
+ ;; those fragments. So, the first time a triangle is
+ ;; rendered, it sets the stencil bits for all fragments to
+ ;; 1. Then, when an overlapping triangle is rendered, it
+ ;; sets all the stencil bits for the overlapped fragments
+ ;; back to 0. This neat hack implements the non-zero rule
+ ;; for determining whether or not a point is inside a closed
+ ;; path.
+ ;;
+ ;; For more information, see:
+ ;; http://developer.download.nvidia.com/devzone/devcenter/gamegraphics/files/opengl/gpupathrender.pdf
+ (with-color-mask null-color-mask
+ (with-stencil-test stencil-flip
+ (let loop ((i 0))
+ (when (< i n)
+ (gpu-apply* (force fill-shader)
+ (filled-path-stencil-vertex-array filled-path)
+ (u32vector-ref offsets i)
+ (u32vector-ref counts i)
+ #:mvp (current-projection)
+ #:mode 0)
+ (loop (+ i 1))))))
+ ;; Render a quad with the stencil applied. The quad is the
+ ;; size of the path's bounding box. The stencil test will
+ ;; make it so we only draw fragments that are part of the
+ ;; filled path.
+ (with-stencil-test stencil-cover-and-clear
+ ;; TODO: Allow custom blend mode.
+ (with-blend-mode 'alpha
+ (gpu-apply (force fill-shader)
+ (filled-path-quad-vertex-array filled-path)
+ #:mvp (current-projection)
+ #:mode 0
+ #:color (filled-path-color filled-path))))))))
+
+;; TODO: dashes
+(define* (draw-stroked-path stroked-path)
+ ;; TODO: Support custom blend mode.
+ (with-blend-mode 'alpha
+ (gpu-apply* (force fill-shader)
+ (stroked-path-vertex-array stroked-path)
+ 0
+ (stroked-path-index-count stroked-path)
+ #:mvp (current-projection)
+ #:color (stroked-path-color stroked-path)
+ #:mode 1
+ #:feather (stroked-path-feather stroked-path)
+ #:stroke-cap (match (stroked-path-cap stroked-path)
+ (#f 0) ; no cap
+ ('butt 1)
+ ('square 2)
+ ('round 3)
+ ('triangle-out 4)
+ ('triangle-in 5)
+ (x (error "unsupported line cap style" x)))
+ #:stroke-width (stroked-path-width stroked-path))))
+
+
+
+;;;
+;;; High-level canvas API
+;;;
+
+(define-record-type <painter>
+ (make-painter commands bounding-box)
+ painter?
+ (commands painter-commands)
+ (bounding-box painter-bounding-box))
+
+(define (eval-painter compiled-path painter matrix)
+ ;; Another mini VM for a simple picture language.
+ ;; TODO: Support 3x3 transformation matrices
+ (let loop ((commands (painter-commands painter))
+ (matrix matrix)
+ (fill-color white)
+ (stroke-color black)
+ (stroke-width 1.0)
+ (stroke-feather 1.0)
+ (stroke-cap 'round))
+ (match commands
+ ((command . rest)
+ (match command
+ ;; Compile paths into a series of line segments.
+ (('compile paths)
+ (clear-compiled-path compiled-path)
+ (for-each (lambda (path)
+ (compile-path compiled-path path matrix))
+ paths)
+ (loop rest matrix fill-color stroke-color stroke-width
+ stroke-feather stroke-cap))
+ ;; Tesselate filled path.
+ (('fill)
+ (cons (fill-path compiled-path #:color fill-color)
+ (loop rest matrix fill-color stroke-color stroke-width
+ stroke-feather stroke-cap)))
+ ;; Tesselate stroked path.
+ (('stroke)
+ ;; Apply the transformation matrix to the stroke width so if
+ ;; the picture is scaled up/down the stroke gets
+ ;; wider/narrower.
+ (let* ((a (matrix3-transform matrix (vec2 0.0 0.0)))
+ (b (matrix3-transform matrix (vec2 stroke-width 0.0)))
+ (stroke-width* (vec2-magnitude (vec2- b a))))
+ (cons (stroke-path compiled-path
+ #:cap stroke-cap
+ #:color stroke-color
+ #:feather stroke-feather
+ #:width stroke-width*)
+ (loop rest matrix fill-color stroke-color stroke-width
+ stroke-feather stroke-cap))))
+ ;; Apply transformation matrix.
+ (('transform transform)
+ (loop rest (matrix3* matrix transform) fill-color stroke-color
+ stroke-width stroke-feather stroke-cap))
+ ;; Set style properties. A little redundant but I don't
+ ;; feel like switching to a hash table just yet.
+ (('set-style 'fill-color fill-color)
+ (loop rest matrix fill-color stroke-color stroke-width
+ stroke-feather stroke-cap))
+ (('set-style 'stroke-color stroke-color)
+ (loop rest matrix fill-color stroke-color stroke-width
+ stroke-feather stroke-cap))
+ (('set-style 'stroke-width stroke-width)
+ (loop rest matrix fill-color stroke-color stroke-width
+ stroke-feather stroke-cap))
+ (('set-style 'stroke-feather stroke-feather)
+ (loop rest matrix fill-color stroke-color stroke-width
+ stroke-feather stroke-cap))
+ (('set-style 'stroke-cap stroke-cap)
+ (loop rest matrix fill-color stroke-color stroke-width
+ stroke-feather stroke-cap))
+ ;; Recursively tesselate another painter.
+ (('call subpainter)
+ (append (loop (painter-commands subpainter)
+ matrix fill-color stroke-color stroke-width
+ stroke-feather stroke-cap)
+ (loop rest matrix fill-color stroke-color stroke-width
+ stroke-feather stroke-cap)))))
+ (() '()))))
+
+(define (bounding-box-union rects)
+ (reduce rect-union (make-null-rect) rects))
+
+;; Primitive painters
+(define (stroke . paths)
+ (make-painter `((compile ,paths)
+ (stroke))
+ (bounding-box-union
+ (map path-bounding-box paths))))
+
+(define (fill . paths)
+ (make-painter `((compile ,paths)
+ (fill))
+ (bounding-box-union
+ (map path-bounding-box paths))))
+
+(define (fill-and-stroke . paths)
+ (make-painter `((compile ,paths)
+ (fill)
+ (stroke))
+ (bounding-box-union
+ (map path-bounding-box paths))))
+
+;; Painter combinators
+(define-syntax-rule (with-style ((key value) ...) painter)
+ (make-painter `((set-style key ,value) ...
+ (call ,painter))
+ (painter-bounding-box painter)))
+
+(define (transform matrix painter)
+ (make-painter `((transform ,matrix)
+ (call ,painter))
+ (transform-bounding-box (painter-bounding-box painter)
+ matrix)))
+
+(define (translate v painter)
+ (transform (matrix3-translate v) painter))
+
+(define (rotate angle painter)
+ (transform (matrix3-rotate angle) painter))
+
+(define (scale x painter)
+ (transform (matrix3-scale x) painter))
+
+(define (pad pad-x pad-y painter)
+ (make-painter (painter-commands painter)
+ (rect-inflate (painter-bounding-box painter) pad-x pad-y)))
+
+(define (superimpose . painters)
+ (make-painter (map (lambda (painter)
+ `(call ,painter))
+ painters)
+ (bounding-box-union
+ (map painter-bounding-box painters))))
+
+(define (beside . painters)
+ (make-painter (let loop ((painters painters)
+ (x 0.0))
+ (match painters
+ (() '())
+ ((painter . rest)
+ (let* ((r (painter-bounding-box painter))
+ (rx (rect-x r))
+ (ry (rect-y r))
+ (rw (rect-width r)))
+ (cons `(call ,(translate (vec2 (- x rx) (- ry)) painter))
+ (loop rest (+ x rw)))))))
+ (let loop ((painters painters)
+ (width 0.0)
+ (height 0.0))
+ (match painters
+ (()
+ (make-rect 0.0 0.0 width height))
+ ((painter . rest)
+ (let ((r (painter-bounding-box painter)))
+ (loop rest (+ width (rect-width r)) (max height (rect-height r)))))))))
+
+(define (below . painters)
+ (make-painter (let loop ((painters painters)
+ (y 0.0))
+ (match painters
+ (() '())
+ ((painter . rest)
+ (let* ((r (painter-bounding-box painter))
+ (rx (rect-x r))
+ (ry (rect-y r))
+ (rh (rect-width r)))
+ (cons `(call ,(translate (vec2 (- rx) (- y ry)) painter))
+ (loop rest (+ y rh)))))))
+ (let loop ((painters painters)
+ (width 0.0)
+ (height 0.0))
+ (match painters
+ (()
+ (make-rect 0.0 0.0 width height))
+ ((painter . rest)
+ (let ((r (painter-bounding-box painter)))
+ (loop rest (max width (rect-width r)) (+ height (rect-height r)))))))))
+
+(define-record-type <canvas>
+ (%make-canvas matrix compiled-path tesselated-paths)
+ canvas?
+ (painter canvas-painter set-canvas-painter!)
+ (matrix canvas-matrix set-canvas-matrix!)
+ (compiled-path canvas-compiled-path)
+ (tesselated-paths canvas-tesselated-paths set-canvas-tesselated-paths!))
+
+(define (canvas-tesselate! canvas painter)
+ (set-canvas-painter! canvas painter)
+ (let ((tesselations (eval-painter (canvas-compiled-path canvas)
+ painter
+ (canvas-matrix canvas))))
+ (set-canvas-tesselated-paths! canvas tesselations)))
+
+(define* (make-canvas painter #:key (matrix (make-identity-matrix3)))
+ (let ((canvas (%make-canvas matrix (make-compiled-path) '())))
+ (canvas-tesselate! canvas painter)
+ canvas))
+
+(define (draw-canvas canvas)
+ (for-each (lambda (tesselation)
+ (if (filled-path? tesselation)
+ (draw-filled-path tesselation)
+ (draw-stroked-path tesselation)))
+ (canvas-tesselated-paths canvas)))
diff --git a/examples/path.scm b/examples/path.scm
new file mode 100644
index 0000000..e759a08
--- /dev/null
+++ b/examples/path.scm
@@ -0,0 +1,121 @@
+(use-modules (chickadee)
+ (chickadee graphics color)
+ (chickadee graphics font)
+ (chickadee graphics path)
+ (chickadee math)
+ (chickadee math matrix)
+ (chickadee math vector)
+ (sdl2)
+ (srfi srfi-4))
+
+(set! *random-state* (random-state-from-platform))
+
+(define center (vec2 320.0 240.0))
+
+(define (stats-message)
+ (format #f "fps: ~1,2f"
+ (/ 1000.0 avg-frame-time)))
+(define start-time (sdl-ticks))
+(define avg-frame-time 16)
+(define stats-text (stats-message))
+(define stats-text-pos (vec2 4.0 464.0))
+(define last-update start-time)
+(define canvas #f)
+
+(define (load)
+ (set! canvas
+ (make-canvas
+ (superimpose
+ ;; (with-style ((fill-color tango-light-plum))
+ ;; (fill
+ ;; (circle center 20.0)
+ ;; (circle center 40.0)
+ ;; (circle center 60.0)
+ ;; (circle center 80.0)
+ ;; (circle center 100.0)
+ ;; (circle center 120.0)
+ ;; (circle center 140.0)
+ ;; (circle center 160.0)
+ ;; (circle center 180.0)
+ ;; (circle center 200.0)
+ ;; (circle center 220.0)
+ ;; (circle center 240.0)
+ ;; (circle center 260.0)
+ ;; (circle center 280.0)
+ ;; (circle center 300.0)
+ ;; (circle center 320.0)
+ ;; (circle center 340.0)
+ ;; (circle center 360.0)
+ ;; (circle center 380.0)
+ ;; (circle center 400.0)))
+ ;; (with-style ((fill-color (string->color "#37946e"))
+ ;; (stroke-color (string->color "#cbdbfc"))
+ ;; (stroke-width 5.0))
+ ;; (fill-and-stroke
+ ;; (path (move-to (vec2 50.0 50.0))
+ ;; (line-to (vec2 500.0 50.0))
+ ;; (line-to (vec2 400.0 200.0))
+ ;; (bezier-to (vec2 500.0 250.0) (vec2 380.0 300.0) (vec2 400.0 400.0))
+ ;; (line-to (vec2 300.0 400.0))
+ ;; (close-path))
+ ;; (path (move-to (vec2 90.0 70.0))
+ ;; (line-to (vec2 460.0 70.0))
+ ;; (line-to (vec2 380.0 190.0))
+ ;; (line-to (vec2 380.0 380.0))
+ ;; (line-to (vec2 310.0 380.0))
+ ;; (close-path))
+ ;; (rounded-rectangle (vec2 270.0 180.0) 40.0 40.0 #:radius 8.0)
+ ;; (rounded-rectangle (vec2 250.0 160.0) 80.0 80.0 #:radius 8.0)
+ ;; (rounded-rectangle (vec2 40.0 40.0) 400.0 400.0 #:radius 20.0)))
+ (stroke
+ (path
+ (move-to (vec2 100.0 100.0))
+ (line-to (vec2 200.0 200.0))
+ (arc-to (vec2 200.0 300.0) (vec2 300.0 300.0) 40.0)
+ (line-to (vec2 400.0 400.0))))
+ ;; (translate (vec2 -320.0 -240.0)
+ ;; (scale 0.9
+ ;; (rotate (/ pi 8.0)
+ ;; (translate center
+ ;; (superimpose
+ ;; (with-style ((fill-color tango-light-plum)
+ ;; (stroke-color white)
+ ;; (stroke-width 5.0))
+ ;; (fill-and-stroke
+ ;; (rounded-rectangle (vec2 40.0 40.0) 560.0 400.0 #:radius 20.0)))
+ ;; (with-style ((stroke-width 10.0)
+ ;; (stroke-color white)
+ ;; (stroke-cap 'triangle-out))
+ ;; (stroke
+ ;; (circle center 60.0)
+ ;; (path
+ ;; (move-to (vec2 100.0 240.0))
+ ;; (arc center 180.0 180.0 pi (+ 2pi (/ pi 4.0)))
+ ;; (line-to center))))
+ ;; (with-style ((stroke-color tango-plum)
+ ;; (stroke-width 6.0))
+ ;; (stroke
+ ;; (apply polyline (map (lambda (i)
+ ;; (vec2 (* (+ i 1) 30) (+ (random 240) 100)))
+ ;; (iota 20))))))))))
+ ;; (let ((rect (pad 4.0 4.0
+ ;; (fill-and-stroke
+ ;; (rounded-rectangle (vec2 0.0 0.0) 50.0 50.0 #:radius 4.0)))))
+ ;; (translate center
+ ;; (below rect rect rect)))
+ ))))
+
+(define (draw alpha)
+ (draw-canvas canvas)
+
+ (draw-text stats-text stats-text-pos)
+ (let ((current-time (sdl-ticks)))
+ (set! avg-frame-time
+ (+ (* (- current-time start-time) 0.1)
+ (* avg-frame-time 0.9)))
+ (set! start-time current-time)
+ (when (>= (- current-time last-update) 1000)
+ (set! stats-text (stats-message))
+ (set! last-update current-time))))
+
+(run-game #:load load #:draw draw)