Batch vertices for large shapes.

Fix for this bug: vydd#160

The draw buffer isn't large enough for shapes that consist of
more than about 6000 vertices, so we need to batch the draw
calls. Different batching behaviour is required for different
primitive types, e.g. for triangle strips, in each batch you
have to include the last 2 vertices from the previous batch so
that the strip is continuous. I've only covered the :triangles
and :triangle-strip primitive types.

src/drawing.lisp

@@ -81,16 +81,64 @@
                                 (vector (env-model-matrix *env*)))
   (gl:bind-texture :texture-2d texture)
   (symbol-macrolet ((position (env-buffer-position *env*)))
-    (when (> (* *bytes-per-vertex* (+ position (length vertices))) *buffer-size*)
+    (when (not (enough-space-for-vertices-p (length vertices)))
       (start-draw))
-    (let ((buffer-pointer (%gl:map-buffer-range :array-buffer
-                                                (* position *bytes-per-vertex*)
-                                                (* (length vertices) *bytes-per-vertex*)
-                                                +access-mode+)))
-      (fill-buffer buffer-pointer vertices color)
-      (%gl:unmap-buffer :array-buffer)
-      (%gl:draw-arrays primitive position (length vertices))
-      (setf position (+ position (length vertices))))))
+    ;; Important to calculate the bounding box before they've been batched so that
+    ;; there are no discontinuities in the texture.
+    (loop with bb = (bounding-box vertices)
+          for (batch-size batch last-batch-p) in (batch-vertices vertices primitive)
+          do (let* ((buffer-pointer
+                      (%gl:map-buffer-range :array-buffer
+                                            (* position *bytes-per-vertex*)
+                                            (* batch-size *bytes-per-vertex*)
+                                            +access-mode+)))
+               (fill-buffer buffer-pointer
+                            batch
+                            color
+                            :num-vertices batch-size
+                            :bounding-box bb)
+               (%gl:unmap-buffer :array-buffer)
+               (%gl:draw-arrays primitive position batch-size)
+               (incf position batch-size)
+               (when (not last-batch-p)
+                 (start-draw))))))
+
+(defun enough-space-for-vertices-p (num-vertices)
+  (<= (* *bytes-per-vertex*
+        (+ (env-buffer-position *env*)
+           num-vertices))
+     *buffer-size*))
+
+(defun batch-vertices (vertices primitive)
+  (let ((num-vertices (length vertices)))
+    (cond
+      ((enough-space-for-vertices-p num-vertices)
+       (list (list num-vertices vertices t)))
+      ((eq primitive :triangles)
+       ;; Assuming that the draw buffer is empty whenever we resort to batching.
+       (loop with max-per-batch = (let ((buff-capacity (floor *buffer-size* *bytes-per-vertex*)))
+                                    ;; This is needed to ensure that the vertices
+                                    ;; for each triangle are in the same batch.
+                                    (- buff-capacity (mod buff-capacity 3)))
+             while (> num-vertices 2)
+             for n = (min max-per-batch num-vertices)
+             collect (list n vertices (zerop (- num-vertices n)))
+             ;; Keep the last 2 vertices for the next batch so
+             ;; that there isn't a gap in the triangle strip.
+             do (setf vertices (nthcdr n vertices))
+             do (decf num-vertices n)))
+      ((eq primitive :triangle-strip)
+       (loop with max-per-batch = (floor *buffer-size* *bytes-per-vertex*)
+             while (> num-vertices 2)
+             for n = (min max-per-batch num-vertices)
+             collect (list n vertices (zerop (- num-vertices n)))
+             ;; Keep the last 2 vertices for the next batch so
+             ;; that there isn't a gap in the triangle strip.
+             do (setf vertices (nthcdr (- n 2) vertices))
+             do (decf num-vertices (- n 2))))
+      ;; Better to fail early rather than crashing with an obscure
+      ;; OpenGL error.
+      (t (error "Draw buffer not large enough for this shape.")))))
 
 (defmethod push-vertices (vertices color texture primitive (draw-mode (eql :figure)))
   (let* ((vertices (mapcar (lambda (v) (transform-vertex v (env-model-matrix *env*)))
@@ -109,24 +157,32 @@
   ;; TODO: Drawing in event handlers could be useful with COPY-PIXELS set to to T.
   (warn "Can't draw from current context (e.g. an event handler)."))
 
-(defun fit-uv-to-rect (uv)
-  (if *uv-rect*
-      (destructuring-bind (u-in v-in) uv
+(defun normalize-and-fit-uv-to-rect (box x y)
+  (multiple-value-bind (u-in v-in)
+      (normalize-to-bounding-box box x y)
+    (if *uv-rect*
         (destructuring-bind (u1 v1 u-range v-range) *uv-rect*
-          (list (+ u1 (* u-range u-in))
-                (+ v1 (* v-range v-in)))))
-      uv))
+          (values (+ u1 (* u-range u-in))
+                  (+ v1 (* v-range v-in))))
+        (values u-in v-in))))
 
-(defun fill-buffer (buffer-pointer vertices color)
+(defun fill-buffer (buffer-pointer vertices color &key num-vertices bounding-box)
   (loop
+    with bb = (or bounding-box
+                  (bounding-box (if (null num-vertices)
+                                    vertices
+                                    (subseq vertices 0 num-vertices))))
+    for j from 0
+    while (or (null num-vertices) (< j num-vertices))
     for idx from 0 by *vertex-attributes*
     for (x y) in vertices
-    for (tx ty) in (mapcar #'fit-uv-to-rect (normalize-to-bounding-box vertices))
-    do (setf (cffi:mem-aref buffer-pointer :float idx) (coerce-float x)
-             (cffi:mem-aref buffer-pointer :float (+ idx 1)) (coerce-float y)
-             (cffi:mem-aref buffer-pointer :float (+ idx 2)) (coerce-float tx)
-             (cffi:mem-aref buffer-pointer :float (+ idx 3)) (coerce-float (* ty (env-y-axis-sgn *env*)))
-             (cffi:mem-aref buffer-pointer :uint8 (* 4 (+ idx 4))) (aref color 0)
-             (cffi:mem-aref buffer-pointer :uint8 (+ (* 4 (+ idx 4)) 1)) (aref color 1)
-             (cffi:mem-aref buffer-pointer :uint8 (+ (* 4 (+ idx 4)) 2)) (aref color 2)
-             (cffi:mem-aref buffer-pointer :uint8 (+ (* 4 (+ idx 4)) 3)) (aref color 3))))
+    do (multiple-value-bind (tx ty)
+           (normalize-and-fit-uv-to-rect bb x y)
+         (setf (cffi:mem-aref buffer-pointer :float idx) (coerce-float x)
+               (cffi:mem-aref buffer-pointer :float (+ idx 1)) (coerce-float y)
+               (cffi:mem-aref buffer-pointer :float (+ idx 2)) (coerce-float tx)
+               (cffi:mem-aref buffer-pointer :float (+ idx 3)) (coerce-float (* ty (env-y-axis-sgn *env*)))
+               (cffi:mem-aref buffer-pointer :uint8 (* 4 (+ idx 4))) (aref color 0)
+               (cffi:mem-aref buffer-pointer :uint8 (+ (* 4 (+ idx 4)) 1)) (aref color 1)
+               (cffi:mem-aref buffer-pointer :uint8 (+ (* 4 (+ idx 4)) 2)) (aref color 2)
+               (cffi:mem-aref buffer-pointer :uint8 (+ (* 4 (+ idx 4)) 3)) (aref color 3)))))

src/geometry.lisp

@@ -83,13 +83,10 @@
         maximize y into max-y
         finally (return (list (list min-x min-y) (list max-x max-y)))))
 
-(defun normalize-to-bounding-box (vertices)
-  (let ((box (bounding-box vertices)))
-    (with-lines (box)
-      (mapcar (lambda (vertex)
-                (list (normalize (first vertex) x1 x2)
-                      (normalize (second vertex) y1 y2)))
-              vertices))))
+(defun normalize-to-bounding-box (box x y)
+  (with-lines (box)
+    (values (normalize x x1 x2)
+            (normalize y y1 y2))))
 
 (defun angle-between-lines (l1 l2)
   "Calculate angle between 2 lines in positive radians. Doesn't handle