diff options
author | David Thompson <dthompson2@worcester.edu> | 2020-08-28 07:16:51 -0400 |
---|---|---|
committer | David Thompson <dthompson2@worcester.edu> | 2020-11-18 15:05:25 -0500 |
commit | 9a5ef19d5971488de18539eaf68e35bf590a4c5e (patch) | |
tree | 564512b78a8acca80c9840e6057e5a8e75feb123 /chickadee | |
parent | 6de9470ff9a9ac87b391c7b51fa9986faf566d2d (diff) |
render: Add vector path rendering module.
Diffstat (limited to 'chickadee')
-rw-r--r-- | chickadee/graphics/path.scm | 1554 |
1 files changed, 1554 insertions, 0 deletions
diff --git a/chickadee/graphics/path.scm b/chickadee/graphics/path.scm new file mode 100644 index 0000000..5412c30 --- /dev/null +++ b/chickadee/graphics/path.scm @@ -0,0 +1,1554 @@ +;;; 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 array-list) + #:use-module (chickadee config) + #: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-empty-canvas + make-canvas + canvas? + set-canvas-painter! + set-canvas-matrix! + 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 like 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))) + +;; TODO: Make this work correctly. +;; (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 (or (close? prev-point control) +;; (close? control point) +;; (< radius distance-tolerance)) +;; `((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)))) +;; (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)))))))) +;; `(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) + (let ((commands* + ;; 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))))))))) + (make-path (list->vector commands*) + ;; Compute bounding box. + (let loop ((commands commands*) + (xmin +inf.0) + (xmax -inf.0) + (ymin +inf.0) + (ymax -inf.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)) + (path-bounding-box path) (compiled-path-bounding-box compiled-path) + ;; 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 + ;; DPI of the screen we're rendering to so that + ;; our approximation will always appear smooth. + (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))))) + + +;;; +;;; Stroked path +;;; + +;; TODO: Allow for multiple path styles to be rendered in a single +;; draw call. This will probably involve abusing textures to store +;; the per-path style info. We can cross that bridge if we ever need +;; the extra performance. +(define-record-type <stroked-path> + (%make-stroked-path vertex-count index-count + vertex-capacity index-capacity + vertex-buffer index-buffer vertex-array) + stroked-path? + (blend-mode stroked-path-blend-mode set-stroked-path-blend-mode!) + (color stroked-path-color set-stroked-path-color!) + (width stroked-path-width set-stroked-path-width!) + (feather stroked-path-feather set-stroked-path-feather!) + (cap stroked-path-cap set-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 (* 5 4))) ; 5 floats per vertex + (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) + (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 0 0 0 0 + vertex-buffer + index-buffer + vertex-array))) + (resize-stroked-path-vertex-buffer! stroked-path 128) + (resize-stroked-path-index-buffer! stroked-path 128) + stroked-path)) + +;; 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 stroked-path compiled-path #:key blend-mode color width feather cap) + ;; Setup stroke style. + (set-stroked-path-blend-mode! stroked-path blend-mode) + (set-stroked-path-color! stroked-path color) + (set-stroked-path-width! stroked-path width) + (set-stroked-path-feather! stroked-path feather) + (set-stroked-path-cap! stroked-path cap) + ;; Initialize counts. + (set-stroked-path-vertex-count! stroked-path 0) + (set-stroked-path-index-count! stroked-path 0) + ;; Tesselate. + (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: + ;; Position + (f32vector-set! verts voffset lx) + (f32vector-set! verts (+ voffset 1) ly) + ;; Distance from starting point + (f32vector-set! verts (+ voffset 2) distance) + ;; Distance from true line segment (used for antialising) + (f32vector-set! verts (+ voffset 3) padding) + ;; Right: + ;; Position + (f32vector-set! verts (+ voffset 5) rx) + (f32vector-set! verts (+ voffset 6) ry) + ;; Distance from starting point + (f32vector-set! verts (+ voffset 7) distance) + ;; Distance from true line segment + (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 5 2))) + (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 + ;; Beginning cap. + ((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 (- padding)) + (point-loop (+ j 1) mag))) + ;; End cap. + ((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))) + ;; The vector that will thicken the line. + (padx (* miterx miter-length)) + (pady (* mitery miter-length)) + ;; Figure out the extra distance +/- that + ;; the mitering has caused so the + ;; vertices distance attribute can be + ;; adjusted accordingly. + (padmag (sqrt (+ (* padx padx) (* pady pady)))) + ;; (npadx (if (zero? padmag) 0.0 (/ padx padmag))) + ;; (npady (if (zero? padmag) 0.0 (/ pady padmag))) + (miter-distance (sqrt (- (* padmag padmag) (* padding padding)))) + ;; 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)))))))) + + +;;; +;;; Filled path +;;; + +(define-record-type <filled-path> + (%make-filled-path count stencil-vertex-count stencil-vertex-capacity + stencil-vertex-buffer stencil-vertex-array + quad-vertex-buffer quad-vertex-array) + filled-path? + (blend-mode filled-path-blend-mode set-filled-path-blend-mode!) + (color filled-path-color set-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) + (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 0 0 0 + stencil-vertex-buffer + stencil-vertex-array + quad-vertex-buffer + quad-vertex-array))) + (resize-filled-path-stencil-vertex-buffer! filled-path 128) + filled-path)) + +(define* (fill-path filled-path compiled-path #:key blend-mode color) + (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)) + (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 style. + (set-filled-path-color! filled-path color) + ;; Setup counts and offsets. + (set-filled-path-count! filled-path 0) + (set-filled-path-stencil-vertex-count! filled-path 0) + (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))))) + + +;;; +;;; Rendering +;;; + +(define path-shader + (delay + (load-shader (scope-datadir "shaders/path-vert.glsl") + (scope-datadir "shaders/path-frag.glsl")))) + +(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)) + +(define *debug?* #f) + +;; TODO: gradients +(define* (draw-filled-path filled-path) + (let ((counts (filled-path-counts filled-path)) + (offsets (filled-path-offsets filled-path)) + (n (filled-path-count filled-path))) + ;; Wireframe debug mode. + (when *debug?* + (begin + (gl-polygon-mode (cull-face-mode front) (polygon-mode line)) + (let loop ((i 0)) + (when (< i n) + (gpu-apply* (force path-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 path-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 + (with-blend-mode (filled-path-blend-mode filled-path) + (gpu-apply (force path-shader) + (filled-path-quad-vertex-array filled-path) + #:mvp (current-projection) + #:mode 0 + #:color (filled-path-color filled-path))))))) + +;; TODO: dashed stroke +;; TODO: miter styles and miter limit +(define* (draw-stroked-path stroked-path) + (with-blend-mode (stroked-path-blend-mode stroked-path) + (gpu-apply* (force path-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 result compiled-path filled-paths stroked-paths painter matrix) + ;; Another mini VM for a simple picture language. + (let loop ((commands (painter-commands painter)) + (matrix matrix) + (blend-mode 'alpha) + (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 blend-mode fill-color stroke-color stroke-width + stroke-feather stroke-cap)) + ;; Tesselate filled path. + (('fill) + (let ((filled-path (if (array-list-empty? filled-paths) + (make-filled-path) + (array-list-pop! filled-paths)))) + (fill-path filled-path compiled-path + #:blend-mode blend-mode + #:color fill-color) + (array-list-push! result filled-path) + (loop rest matrix blend-mode 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. There's surely a more accurate way to do + ;; this, but the result looks okay to me for now. + (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))) + (stroked-path (if (array-list-empty? stroked-paths) + (make-stroked-path) + (array-list-pop! stroked-paths)))) + (stroke-path stroked-path + compiled-path + #:blend-mode blend-mode + #:cap stroke-cap + #:color stroke-color + #:feather stroke-feather + #:width stroke-width*) + (array-list-push! result stroked-path) + (loop rest matrix blend-mode fill-color stroke-color stroke-width + stroke-feather stroke-cap))) + ;; Apply transformation matrix. + (('transform transform) + (loop rest (matrix3* matrix transform) blend-mode fill-color + stroke-color stroke-width stroke-feather stroke-cap)) + ;; Set style properties. + ((or ('set-style 'blend-mode blend-mode) + ('set-style 'fill-color fill-color) + ('set-style 'stroke-color stroke-color) + ('set-style 'stroke-width stroke-width) + ('set-style 'stroke-feather stroke-feather) + ('set-style 'stroke-cap stroke-cap)) + (loop rest matrix blend-mode fill-color stroke-color stroke-width + stroke-feather stroke-cap)) + ;; Recursively tesselate another painter. + (('call subpainter) + (loop (painter-commands subpainter) + matrix blend-mode fill-color stroke-color stroke-width + stroke-feather stroke-cap) + (loop rest matrix blend-mode fill-color stroke-color + stroke-width stroke-feather stroke-cap)))) + (() #t)))) + +(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) + (let ((p painter)) ; avoid evaling painter twice + (make-painter `((set-style key ,value) ... + (call ,p)) + (painter-bounding-box p)))) + +(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 filled-path-pool stroked-path-pool + tesselated-paths) + canvas? + (painter canvas-painter %set-canvas-painter!) + (matrix canvas-matrix %set-canvas-matrix!) + (compiled-path canvas-compiled-path) + (filled-path-pool canvas-filled-path-pool) + (stroked-path-pool canvas-stroked-path-pool) + (tesselated-paths canvas-tesselated-paths)) + +(define (repaint-canvas canvas) + (let ((painter (canvas-painter canvas)) + (fill-pool (canvas-filled-path-pool canvas)) + (stroke-pool (canvas-stroked-path-pool canvas)) + (tesselations (canvas-tesselated-paths canvas))) + ;; Return tesselations back to pools. Reusing existing GPU + ;; buffers for canvases that are constantly redrawn is a very good + ;; thing. + (array-list-for-each (lambda (i tesselation) + (if (filled-path? tesselation) + (array-list-push! fill-pool tesselation) + (array-list-push! stroke-pool tesselation))) + tesselations) + (array-list-clear! tesselations) + ;; Rebuild tesselations with new painter. + (when painter + (eval-painter tesselations + (canvas-compiled-path canvas) + fill-pool + stroke-pool + painter + (canvas-matrix canvas))))) + +(define (set-canvas-painter! canvas painter) + (%set-canvas-painter! canvas painter) + (repaint-canvas canvas)) + +(define (set-canvas-matrix! canvas matrix) + (%set-canvas-matrix! canvas matrix) + (repaint-canvas canvas)) + +(define* (make-empty-canvas #:key (matrix (make-identity-matrix3))) + (%make-canvas matrix + (make-compiled-path) + (make-array-list) + (make-array-list) + (make-array-list))) + +(define* (make-canvas painter #:key (matrix (make-identity-matrix3))) + (let ((canvas (make-empty-canvas #:matrix matrix))) + (set-canvas-painter! canvas painter) + canvas)) + +(define (draw-canvas canvas) + (array-list-for-each (lambda (i tesselation) + (if (filled-path? tesselation) + (draw-filled-path tesselation) + (draw-stroked-path tesselation))) + (canvas-tesselated-paths canvas))) |