path: root/chickadee/graphics/path.scm

;;; Chickadee Game Toolkit
;;; Copyright © 2020, 2021 David Thompson <dthompson2@worcester.edu>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary
;;
;; Vector path rendering.
;;
;;; Code:

(define-module (chickadee graphics path)
  #:use-module (chickadee config)
  #:use-module (chickadee data array-list)
  #:use-module (chickadee graphics blend)
  #:use-module (chickadee graphics buffer)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics engine)
  #:use-module (chickadee graphics framebuffer)
  #:use-module (chickadee graphics gl)
  #:use-module (chickadee graphics multisample)
  #:use-module (chickadee graphics polygon)
  #:use-module (chickadee graphics shader)
  #:use-module (chickadee graphics stencil)
  #:use-module (chickadee graphics texture)
  #:use-module (chickadee image)
  #: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 (chickadee utils)
  #: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
            bezier-path
            rectangle
            square
            rounded-rectangle
            regular-polygon
            ellipse
            circle
            gradient?
            gradient-type
            gradient-matrix
            gradient-start-color
            gradient-end-color
            gradient-range
            gradient-radial-ratio
            linear-gradient
            radial-gradient
            stroke
            fill
            fill-and-stroke
            with-style
            transform
            translate
            rotate
            scale
            horizontal-flip
            vertical-flip
            superimpose
            pad
            beside
            below
            right-split
            up-split
            corner-split
            square-limit
            painter?
            painter-bounding-box
            make-empty-canvas
            make-canvas
            canvas?
            set-canvas-painter!
            set-canvas-matrix!
            draw-canvas*
            draw-canvas
            canvas->pixbuf
            write-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 #:optional (counter-clockwise? #t))
  ;; 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, tau] range.
    (let* ((clamped (mod angle tau))
           (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 tau)))))
  (let* ((angle-start (adjust-angle angle-start))
         (angle-end** (adjust-angle angle-end))
         (angle-end* (if (> angle-start angle-end**)
                         (+ angle-end** tau)
                         angle-end**))
         (angle-end (if counter-clockwise?
                        angle-end*
                        (- angle-end* tau)))
         ;; 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 (> (abs 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 (if counter-clockwise? ; max segment angle is pi/2
                                   (min delta pi/2)
                                   (max delta (- 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 c1 c2 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 (intersection d0 d1 x0 y0 x1 y1)
    ;; Calculate the coefficients for lines in standard form:
    ;;
    ;; Ax + By = C
    ;;
    ;; We use a point on each line and a direction vector to define
    ;; the line.  Then, we calculate the determinant and follow a
    ;; formula to get the intersection point.  We technically need two
    ;; points on the line in order to find the intersection, but we
    ;; get away with only calculating one point because we have the
    ;; direction vector which can be used to represent the difference
    ;; between the point (either (x0, y0) or (x1, y1)) and another
    ;; point that is d0 or d1 away.
    ;;
    ;; See:
    ;; https://en.wikipedia.org/wiki/Line%E2%80%93line_intersection#Given_two_points_on_each_line
    (let* ((a0 (vec2-y d0))
           (b0 (- (vec2-x d0)))
           (c0 (+ (* a0 x0) (* b0 y0)))
           (a1 (vec2-y d1))
           (b1 (- (vec2-x d1)))
           (c1 (+ (* a1 x1) (* b1 y1)))
           (det (- (* a0 b1) (* a1 b0))))
      (vec2 (/ (- (* b1 c0) (* b0 c1)) det)
            (/ (- (* a0 c1) (* a1 c0)) det))))
  (define (expand-arc-to c0)
    (unless c0
      (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? c0 c1)
            (close? c1 c2)
            (< radius distance-tolerance))
        `((line-to ,c2))
        ;; Calculate direction vectors from the middle control point,
        ;; c1, to the starting point, c0, and the target control
        ;; point, c2.
        (let* ((d0 (vec2-normalize (vec2- c0 c1)))
               (d1 (vec2-normalize (vec2- c2 c1)))
               ;; The cross product tells us if the arc moves
               ;; counter-clockwise (< 0), clockwise (> 0), or if
               ;; there is no arc because the lines are parallel (0).
               (cross (vec2-cross d0 d1)))
          (cond
           ;; Just draw a straight line if the lines are parallel.
           ;; The line intersection calculations would generate bogus
           ;; values in this case.
           ((= cross 0.0)
            `((line-to ,c2)))
           ((< cross 0.0)
            ;; Find the center of the circle that touches the lines
            ;; defined by the three control points. First, calculate
            ;; vectors that are perpendicular to d0 and d1.  For any
            ;; vector, there are *two* perpendicular vectors: (-y, x)
            ;; and (y, -x).  Which we use depends on if the arc is
            ;; going clockwise or counterclockwise.
            (let* ((x0 (+ (vec2-x c0)
                          (* (vec2-y d0) radius)))
                   (y0 (- (vec2-y c0)
                          (* (vec2-x d0) radius)))
                   (x1 (- (vec2-x c2) (* (vec2-y d1) radius)))
                   (y1 (+ (vec2-y c2) (* (vec2-x d1) radius)))
                   (center (intersection d0 d1 x0 y0 x1 y1))
                   (a0 (atan (vec2-x d0) (- (vec2-y d0))))
                   (a1 (atan (- (vec2-x d1)) (vec2-y d1))))
              (list (arc center radius radius a0 a1))))
           (else
            (let* ((x0 (- (vec2-x c0)
                          (* (vec2-y d0) radius)))
                   (y0 (+ (vec2-y c0)
                          (* (vec2-x d0) radius)))
                   (x1 (+ (vec2-x c2) (* (vec2-y d1) radius)))
                   (y1 (- (vec2-y c2) (* (vec2-x d1) radius)))
                   (center (intersection d0 d1 x0 y0 x1 y1))
                   (a0 (atan (- (vec2-x d0)) (vec2-y d0)))
                   (a1 (atan (vec2-x d1) (- (vec2-y d1)))))
              (list (arc center radius radius a0 a1 #f))))))))
  `(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 (bezier-path p1 c1 c2 p2 . points)
  (apply path
         (move-to p1)
         (bezier-to c1 c2 p2)
         (let loop ((points points))
           (match points
             (() '())
             ((c1 c2 p . rest)
              (cons (bezier-to c1 c2 p)
                    (loop rest)))))))

(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 (/ tau 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))


;;;
;;; Gradients
;;;

(define-record-type <gradient>
  (make-gradient type matrix start-color end-color range radial-ratio)
  gradient?
  (type gradient-type)
  (matrix gradient-matrix)
  (start-color gradient-start-color)
  (end-color gradient-end-color)
  (range gradient-range)
  ;; This x:y ratio is used to squash/stretch radial gradients to give
  ;; an elliptical appearance.
  (radial-ratio gradient-radial-ratio))

(define (angle->vec2 theta)
  (vec2 (cos theta) (sin theta)))

(define (make-range offset length)
  (vec2 offset (+ offset length)))

(define (make-gradient-matrix origin rotation)
  (matrix3* (matrix3-translate (vec2* origin -1.0))
            (matrix3-rotate rotation)))

(define (transform-gradient gradient matrix)
  (make-gradient (gradient-type gradient)
                 ;; The matrix needs to be inverted in order to
                 ;; convert world space coordinates back into local
                 ;; coordinates within the fragment shader.  We need
                 ;; the local coordinates for the gradient math to
                 ;; produce the correct result.
                 (matrix3* (matrix3-inverse matrix) (gradient-matrix gradient))
                 (gradient-start-color gradient)
                 (gradient-end-color gradient)
                 (gradient-range gradient)
                 (gradient-radial-ratio gradient)))

(define* (linear-gradient #:key (origin %origin) (start-color white)
                          (end-color black) (rotation 0.0) (offset 0.0)
                          (length 100.0))
  (make-gradient 'linear
                 (make-gradient-matrix origin rotation)
                 start-color
                 end-color
                 (make-range offset length)
                 0.0))

(define* (radial-gradient #:key (origin %origin) (start-color white)
                          (end-color black) (radius 50.0)
                          (radius-x radius) (radius-y radius)
                          (rotation 0.0) (offset 0.0))
  (make-gradient 'radial
                 (make-gradient-matrix origin rotation)
                 start-color
                 end-color
                 (make-range offset (- radius-x offset))
                 (/ radius-x radius-y)))


;;;
;;; 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)
  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 set-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)))
    (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)
  (set-compiled-path-bounding-box! compiled-path (make-rect 0.0 0.0 0.0 0.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 (matrix3-transform matrix %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
;;;

(define-geometry-type <stroke-vertex>
  stroke-vertex-ref
  stroke-vertex-set!
  stroke-vertex-append!
  (position vec2)
  (texture vec2)
  (length float))

;; 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 geometry)
  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!)
  (geometry stroked-path-geometry))

(define (make-stroked-path)
  (%make-stroked-path (make-geometry <stroke-vertex> 32)))

;; 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)
  ;; Tesselate.
  (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))
        (geometry (stroked-path-geometry stroked-path)))
    (define (add-points first? lx ly rx ry distance)
      (let ((vert-count (geometry-vertex-count geometry <stroke-vertex>)))
        ;; Each vertex has the following data:
        ;; - x
        ;; - y
        ;; - distance from starting point
        ;; - distance from true line segment (used for antialising)
        ;;
        ;; First vertex is the left hand side, second is the right.
        (stroke-vertex-append! geometry
                               (lx ly distance padding 0.0)
                               (rx ry distance (- padding) 0.0))
        ;; 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?
          (geometry-index-append! geometry
                                  (- vert-count 1)
                                  (- vert-count 2)
                                  vert-count
                                  (- vert-count 1)
                                  vert-count
                                  (+ vert-count 1)))))
    (define (set-length i length)
      (stroke-vertex-set! geometry length (* i 2) length)
      (stroke-vertex-set! geometry length (+ (* i 2) 1) length))
    (with-geometry geometry
      (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-geometry-type <fill-vertex>
  fill-vertex-ref
  fill-vertex-set!
  fill-vertex-append!
  (position vec2))

(define-record-type <filled-path>
  (%make-filled-path count quad-geometry stencil-geometry)
  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-geometry filled-path-stencil-geometry)
  (quad-geometry filled-path-quad-geometry))

(define (make-filled-path)
  (let* ((quad-geometry (make-geometry <fill-vertex> 4
                                       #:index-capacity 6))
         (stencil-geometry (make-geometry <fill-vertex> 32
                                          #:index? #f
                                          #:mode 'triangle-fan)))
    (%make-filled-path 0 quad-geometry stencil-geometry)))

(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))
         (quad-geometry (filled-path-quad-geometry filled-path))
         (stencil-geometry (filled-path-stencil-geometry filled-path)))
    ;; Setup style.
    (set-filled-path-color! filled-path color)
    (set-filled-path-blend-mode! filled-path blend-mode)
    ;; Setup counts and offsets.
    (set-filled-path-count! filled-path 0)
    (set-filled-path-count! filled-path path-count)
    ;; TODO: Don't allocate each time.
    (let ((bv (make-u32vector path-count)))
      (for-range ((i path-count))
        (u32vector-set! bv i (+ (u32vector-ref counts i) 1)))
      (set-filled-path-counts! filled-path bv))
    (let ((bv (make-u32vector path-count)))
      (for-range ((i path-count))
        (u32vector-set! bv i (+ (u32vector-ref offsets i) i)))
      (set-filled-path-offsets! filled-path bv))
    ;; Create geometry for the stencil buffer.
    (geometry-begin! stencil-geometry)
    (for-range ((i path-count))
      (let* ((count (u32vector-ref counts i))
             (first (u32vector-ref offsets i)))
        ;; 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.
        (fill-vertex-append! stencil-geometry (ref-x ref-y))
        ;; Now simply copy all the points in the path into the
        ;; buffer.
        (for-range ((j (+ first count) first))
          (fill-vertex-append! stencil-geometry
                               ((f32vector-ref points (* j 2))
                                (f32vector-ref points (+ (* j 2) 1)))))))
    (geometry-end! stencil-geometry)
    ;; 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.
    (geometry-begin! quad-geometry)
    (let ((x1 (rect-x bbox))
          (y1 (rect-y bbox))
          (x2 (rect-right bbox))
          (y2 (rect-top bbox)))
      (fill-vertex-append! quad-geometry (x1 y1) (x2 y1) (x2 y2) (x1 y2))
      (geometry-index-append! quad-geometry 0 2 3 0 1 2))
    (geometry-end! quad-geometry)))


;;;
;;; Rendering
;;;

(define-graphics-variable stroke-shader
  (load-shader (scope-datadir "shaders/path-stroke-vert.glsl")
               (scope-datadir "shaders/path-stroke-frag.glsl")))

(define-graphics-variable fill-shader
  (load-shader (scope-datadir "shaders/path-fill-vert.glsl")
               (scope-datadir "shaders/path-fill-frag.glsl")))

(define-graphics-variable mvp-matrix (make-null-matrix4))

(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)

(define* (draw-filled-path filled-path matrix)
  (let ((shader (graphics-variable-ref fill-shader))
        (mvp (graphics-variable-ref mvp-matrix))
        (counts (filled-path-counts filled-path))
        (offsets (filled-path-offsets filled-path))
        (n (filled-path-count filled-path))
        (quad-geometry (filled-path-quad-geometry filled-path))
        (stencil-geometry (filled-path-stencil-geometry filled-path)))
    (matrix4-mult! mvp matrix (current-projection))
    ;; Wireframe debug mode.
    (when *debug?*
      (with-graphics-state ((g:polygon-mode line-polygon-mode))
        (for-range ((i n))
          (shader-apply* shader
                         (geometry-vertex-array stencil-geometry)
                         (u32vector-ref offsets i)
                         (u32vector-ref counts i)
                         #:mvp (current-projection)))))
    ;; Anti-alias the edges of the fill.
    (with-graphics-state ((g: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-graphics-state ((g:color-mask null-color-mask)
                            (g:stencil-test stencil-flip))
        (for-range ((i n))
          (shader-apply* shader
                         (geometry-vertex-array stencil-geometry)
                         (u32vector-ref offsets i)
                         (u32vector-ref counts i)
                         #:mvp mvp)))
      ;; 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-graphics-state ((g:stencil-test stencil-cover-and-clear)
                            (g:blend-mode (filled-path-blend-mode filled-path)))
        (let ((color (filled-path-color filled-path)))
          (if (gradient? color)
              ;; Linear/radial gradient fill.
              (shader-apply shader
                            (geometry-vertex-array quad-geometry)
                            #:mvp mvp
                            #:color (gradient-start-color color)
                            #:end-color (gradient-end-color color)
                            #:gradient-matrix (gradient-matrix color)
                            #:gradient-range (gradient-range color)
                            #:radial-gradient-ratio (gradient-radial-ratio color)
                            #:mode (case (gradient-type color)
                                     ((linear) 1)
                                     ((radial) 2)))
              ;; Solid fill.
              (shader-apply shader
                            (geometry-vertex-array quad-geometry)
                            #:mvp mvp
                            #:color (filled-path-color filled-path)
                            #:mode 0)))))))

;; TODO: dashed stroke
;; TODO: miter styles and miter limit
(define* (draw-stroked-path stroked-path matrix)
  (let ((shader (graphics-variable-ref stroke-shader))
        (mvp (graphics-variable-ref mvp-matrix)))
    (matrix4-mult! mvp matrix (current-projection))
    (with-graphics-state ((g:blend-mode (stroked-path-blend-mode stroked-path)))
      (let ((geometry (stroked-path-geometry stroked-path)))
        (shader-apply* shader
                       (geometry-vertex-array geometry)
                       0
                       (geometry-index-count geometry)
                       #:mvp mvp
                       #:color (stroked-path-color stroked-path)
                       #:feather (stroked-path-feather stroked-path)
                       #:stroke-cap (case (stroked-path-cap stroked-path)
                                      ((#f) 0) ; no cap
                                      ((butt) 1)
                                      ((square) 2)
                                      ((round) 3)
                                      ((triangle-out) 4)
                                      ((triangle-in) 5)
                                      (else
                                       (error "unsupported line cap style"
                                              (stroked-path-cap stroked-path))))
                       #: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 blend: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 (if (gradient? fill-color)
                                   (transform-gradient fill-color matrix)
                                   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* transform matrix)
                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 (horizontal-flip painter)
  (scale (vec2 -1.0 1.0) painter))

(define (vertical-flip painter)
  (scale (vec2 1.0 -1.0) 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-height 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)))))))))

;; Adapted from Structure and Interpretation of Computer Programs,
;; section 2.2.4.
(define (right-split painter n)
  (if (<= n 0)
      painter
      (let ((smaller (right-split (scale 0.5 painter) (- n 1))))
        (beside (scale (vec2 0.5 1.0) painter)
                (below smaller smaller)))))

(define (up-split painter n)
  (if (<= n 0)
      painter
      (let ((smaller (up-split (scale 0.5 painter) (- n 1))))
        (below (scale (vec2 1.0 0.5) painter)
               (beside smaller smaller)))))

(define (corner-split painter n)
  (if (<= n 0)
      painter
      (let* ((smaller (scale (vec2 0.5 0.5) painter))
             (up (up-split smaller (- n 1)))
             (right (right-split smaller (- n 1)))
             (up-small (scale (vec2 0.5 1.0) up))
             (right-small (scale (vec2 1.0 0.5) right)))
        (beside (below smaller
                       (beside up-small up-small))
                (below (below right-small right-small)
                       (corner-split smaller (- n 1)))))))

(define (square-limit painter n)
  (if (<= n 0)
      painter
      (let* ((smaller (scale 0.5 painter))
             (split (corner-split smaller n))
             (flipped (vertical-flip split)))
        (below (beside (rotate pi split)
                       (horizontal-flip (rotate pi split)))
               (beside (horizontal-flip split)
                       split)))))

(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 matrix)
  (array-list-for-each (lambda (i tesselation)
                         (if (filled-path? tesselation)
                             (draw-filled-path tesselation matrix)
                             (draw-stroked-path tesselation matrix)))
                       (canvas-tesselated-paths canvas)))

(define %identity-matrix (make-identity-matrix4))

(define (draw-canvas canvas)
  (draw-canvas* canvas %identity-matrix))

(define (canvas->pixbuf canvas)
  "Return a new pixbuf containing the rasterized CANVAS."
  (let* ((bb (painter-bounding-box (canvas-painter canvas)))
         (width (inexact->exact (ceiling (rect-width bb))))
         (height (inexact->exact (ceiling (rect-height bb))))
         (framebuffer (make-framebuffer width height)))
    (with-framebuffer framebuffer
      (draw-canvas* canvas (make-identity-matrix4)))
    (texture->pixbuf (framebuffer-texture framebuffer))))

(define* (write-canvas canvas
                       #:optional (file-name (temp-image-file-name 'png))
                       #:key (format 'png))
  "Write CANVAS to FILE-NAME using FORMAT ('png' by default.)"
  (write-image (canvas->pixbuf canvas) file-name #:format format))