;;-*-Lisp-*-
(in-package goal)
(bundles "ENGINE.CGO" "GAME.CGO")
(require "engine/gfx/hw/display.gc")
(require "engine/draw/drawable-group-h.gc")
(require "engine/gfx/math-camera.gc")
(require "engine/debug/debug-sphere.gc")
(require "engine/camera/cam-debug-h.gc")
(require "engine/geometry/geometry.gc")
(require "engine/gfx/lights-h.gc")
(require "engine/math/vector.gc")

;; This file contains functions for debug drawing.
;; In general, the 3D functions draw using the camera and the 2D functions draw in screen coordinates.
;; Most functions take a boolean as their first argument. If the boolean is set to #f, it will skip drawing the point.

;; DECOMP BEGINS

(defun transform-float-point ((in vector) (out vector4w))
  "Transform in with the cached camera registers, perform perspective division and GS offset and
   depth clamping, convert to 28.4 fixed point, store the result in out, and return out. The input
   precedes the output, unlike most destructive vector functions."
  (with-vf0
    (with-vf (vf4 vf1 vf2 vf3 vf9 vf8 vf6)
      (rlet ((acc :class vf)
             (Q :class vf)
             (vf5 :class vf))
        (.lvf vf5 (&-> in quad))
        (.mul.w.vf acc vf4 vf5)
        (.add.mul.x.vf acc vf1 vf5 acc)
        (.add.mul.y.vf acc vf2 vf5 acc)
        (.add.mul.z.vf vf5 vf3 vf5 acc)
        (.div.vf Q vf9 vf5 :fsf #b0 :ftf #b11)
        (.wait.vf)
        (.mul.vf.xyz vf5 vf5 Q)
        (.add.vf vf5 vf5 vf8)
        (.max.x.vf.w vf5 vf5 vf0)
        (.min.x.vf.w vf5 vf5 vf6)
        (vftoi4.xyzw vf5 vf5)
        (.svf (&-> out quad) vf5)
        out))))

;;;;;;;;;;;;;;;;;;
;; Debug Draw
;;;;;;;;;;;;;;;;;;

;; All of these functions are super slow and probably very old.
;; They do a DMA packet per thing drawn.

(defun-debug add-debug-point ((enable-draw symbol) (bucket bucket-id) (pt vector))
  "Draw a projected point as a large four-vertex red, green, and blue gradient diamond."
  (if (not enable-draw) (return #f))
  (let ((point-data (new 'stack 'vector4w-2)))
    ;; transform the input point and convert to fixed point
    (set! (-> pt w) 1.0)
    (when (transform-point-qword! (-> point-data vector 0) pt)
      (with-dma-buffer-add-bucket ((dma-buff (-> (current-frame) debug-buf)) bucket)
        (with-cnt-vif-block (dma-buff)
          (dma-buffer-add-gif-tag dma-buff
                                  (new 'static 'gif-tag64 :nloop 1 :eop 1 :pre 1 :nreg 8 :prim (gif-prim tri-strip))
                                  (gs-reg-list rgbaq xyzf2 rgbaq xyzf2 rgbaq xyzf2 rgbaq xyzf2))
          ;; upper point is red
          (set! (-> point-data vector 1 x) 255) ;; r
          (set! (-> point-data vector 1 y) 128)
          (set! (-> point-data vector 1 z) 128)
          (set! (-> point-data vector 1 w) 128)
          (+! (-> point-data vector 0 y) 160)
          (dma-buffer-add-uint128 dma-buff (-> point-data quad 1) (-> point-data quad 0))
          ;; left point is green
          (+! (-> point-data vector 0 x) -256)
          (+! (-> point-data vector 0 y) -160)
          (set! (-> point-data vector 1 x) 128)
          (set! (-> point-data vector 1 y) 255) ;; g
          (dma-buffer-add-uint128 dma-buff (-> point-data quad 1) (-> point-data quad 0))
          ;; right point is blue
          (+! (-> point-data vector 0 x) 512)
          (set! (-> point-data vector 1 y) 128)
          (set! (-> point-data vector 1 z) 255)
          (dma-buffer-add-uint128 dma-buff (-> point-data quad 1) (-> point-data quad 0))
          ;; bottom point is red again
          (+! (-> point-data vector 0 x) -256)
          (+! (-> point-data vector 0 y) -160)
          (set! (-> point-data vector 1 x) 255)
          (set! (-> point-data vector 1 y) 128)
          (dma-buffer-add-uint128 dma-buff (-> point-data quad 1) (-> point-data quad 0))))))
  #f)

(defun-debug internal-draw-debug-line ((bucket bucket-id) (p0 vector) (p1 vector) (first-color rgba) (mode symbol) (second-color rgba))
  "Project and draw a 3D line immediately. A false mode uses the supplied colors, fade halves the
   second endpoint RGB, and fade-depth scales both endpoint colors by projected depth. A second
   color of -1 or opaque white reuses the first color."
  (let ((dma-buff (-> (current-frame) debug-buf)))
    (if (< (the-as uint (shr (+ (&- (-> dma-buff end) (the-as uint (-> dma-buff base))) 15) 4)) (the-as uint #x8000))
      (return (the-as pointer #f))))
  (if (or (zero? (+ second-color (the-as uint 1))) (= second-color (static-rgba #xff #xff #xff #xff)))
    (set! second-color first-color))
  (case mode
    (('fade)
     (set! second-color
           (new 'static
                'rgba
                :r
                (shr (-> second-color r) 1)
                :g
                (shr (-> second-color g) 1)
                :b
                (shr (-> second-color b) 1)
                :a (-> second-color a)))))
  (let ((projected-points (new 'stack 'vector4w-2))
        (colors (new 'stack 'vector4w-2)))
    (set! (-> p0 w) 1.0)
    (set! (-> p1 w) 1.0)
    (when (and (transform-point-qword! (-> projected-points vector 0) p0)
               (transform-point-qword! (-> projected-points vector 1) p1))
      (with-dma-buffer-add-bucket ((line-dma-buff (-> (current-frame) debug-buf)) bucket)
        (with-cnt-vif-block (line-dma-buff)
          (dma-buffer-add-gif-tag line-dma-buff
                                  (new 'static 'gif-tag64 :nloop 1 :eop 1 :pre 1 :nreg 4 :prim (gif-prim line))
                                  (gs-reg-list rgbaq xyzf2 rgbaq xyzf2))
          (case mode
            (('fade-depth)
             (let ((depth-scale (fminmax (* (1/ #xffffff) (the float (-> projected-points vector 0 z))) 0.2 1.0)))
               (set! (-> colors vector 0 x) (the int (* (the float (-> first-color r)) depth-scale)))
               (set! (-> colors vector 0 y) (the int (* (the float (-> first-color g)) depth-scale)))
               (set! (-> colors vector 0 z) (the int (* (the float (-> first-color b)) depth-scale))))
             (set! (-> colors vector 0 w) (the-as int (-> first-color a))))
            (else
             (set! (-> colors vector 0 x) (the-as int (-> first-color r)))
             (set! (-> colors vector 0 y) (the-as int (-> first-color g)))
             (set! (-> colors vector 0 z) (the-as int (-> first-color b)))
             (set! (-> colors vector 0 w) (the-as int (-> first-color a)))))
          (cond
            ((= mode 'fade-depth)
             (let ((depth-scale (fminmax (* (1/ #xffffff) (the float (-> projected-points vector 1 z))) 0.2 1.0)))
               (set! (-> colors vector 1 x) (the int (* (the float (-> second-color r)) depth-scale)))
               (set! (-> colors vector 1 y) (the int (* (the float (-> second-color g)) depth-scale)))
               (set! (-> colors vector 1 z) (the int (* (the float (-> second-color b)) depth-scale))))
             (set! (-> colors vector 1 w) (the-as int (-> second-color a))))
            (else
             (set! (-> colors vector 1 x) (the-as int (-> second-color r)))
             (set! (-> colors vector 1 y) (the-as int (-> second-color g)))
             (set! (-> colors vector 1 z) (the-as int (-> second-color b)))
             (set! (-> colors vector 1 w) (the-as int (-> second-color a)))))
          (+! (-> projected-points vector 0 z) -8192)
          (+! (-> projected-points vector 1 z) -8192)
          (dma-buffer-add-uint128 line-dma-buff
                                  (-> colors quad 0)
                                  (-> projected-points quad 0)
                                  (-> colors quad 1)
                                  (-> projected-points quad 1)))))))

(defun-debug internal-draw-debug-text-3d ((bucket bucket-id) (str string) (location vector) (font-color-id font-color) (offset vector2h))
  "Project location, apply the 2D offset, and append text with font-color-id to bucket immediately."
  (let ((projected (new 'stack-no-clear 'vector4w)))
    (set! (-> projected quad) (the-as uint128 0))
    (when (transform-point-qword! (the-as vector4w projected) location)
      (with-dma-buffer-add-bucket ((dma-buff (-> (current-frame) debug-buf)) bucket)
        (let ((font-ctx (new 'stack
                             'font-context
                             *font-default-matrix*
                             (+ (+ (-> offset x) -1792) (/ (-> projected x) 16))
                             (- (+ (+ (-> offset y) -8) (/ (-> projected y) 16)) (-> *video-parms* screen-miny))
                             0.0
                             font-color-id
                             (font-flags shadow kerning))))
          (set! (-> font-ctx origin z) (the float (/ (-> projected z) 16)))
          (draw-string str dma-buff font-ctx))))))

(defun-debug add-debug-outline-triangle ((enable-draw symbol) (bucket bucket-id) (p0 vector) (p1 vector) (p2 vector) (color rgba))
  "Draw outline of a triangle using lines."
  (when enable-draw
    (add-debug-line #t bucket p0 p1 color #f (the-as rgba -1))
    (add-debug-line #t bucket p1 p2 color #f (the-as rgba -1))
    (add-debug-line #t bucket p2 p0 color #f (the-as rgba -1)))
  #f)

(defun-debug add-debug-triangle-normal ((enable-draw symbol) (bucket bucket-id) (p0 vector) (p1 vector) (p2 vector) (color rgba))
  "Draw a one-meter normal from the centroid of the triangle."
  (when enable-draw
    (let ((center (new 'stack-no-clear 'vector))
          (normal-end (vector-3pt-cross! (new 'stack-no-clear 'vector) p0 p1 p2)))
      (vector-float/! normal-end normal-end (* (1/ METER_LENGTH) (vector-length normal-end)))
      (vector+! center p0 p1)
      (vector+! center center p2)
      (vector-float/! center center 3.0)
      (vector+! normal-end normal-end center)
      (add-debug-line #t bucket center normal-end color #f (the-as rgba -1))))
  #f)

(defun-debug add-debug-flat-triangle ((enable-draw symbol) (bucket bucket-id) (p0 vector) (p1 vector) (p2 vector) (color rgba))
  "Project and draw one flat-shaded triangle."
  (if (not enable-draw) (return #f))
  (let ((projected-points (new 'stack 'vector4w-3))
        (colors (new 'stack 'vector4w-3)))
    (set! (-> p0 w) 1.0)
    (set! (-> p1 w) 1.0)
    (set! (-> p2 w) 1.0)
    (when (and (transform-point-qword! (-> projected-points vector 0) p0)
               (transform-point-qword! (-> projected-points vector 1) p1)
               (transform-point-qword! (-> projected-points vector 2) p2))
      (with-dma-buffer-add-bucket ((dma-buff (-> (current-frame) debug-buf)) bucket)
        (with-cnt-vif-block (dma-buff)
          (dma-buffer-add-gif-tag dma-buff
                                  (new 'static 'gif-tag64 :nloop 1 :eop 1 :pre 1 :nreg 6 :prim (gif-prim tri))
                                  (gs-reg-list rgbaq xyzf2 rgbaq xyzf2 rgbaq xyzf2))
          (set! (-> colors vector 0 x) (the-as int (-> color r)))
          (set! (-> colors vector 0 y) (the-as int (-> color g)))
          (set! (-> colors vector 0 z) (the-as int (-> color b)))
          (set! (-> colors vector 0 w) (the-as int (-> color a)))
          (set! (-> projected-points vector 0 z) (+ (-> projected-points vector 0 z) -8192))
          (set! (-> projected-points vector 1 z) (+ (-> projected-points vector 1 z) -8192))
          (set! (-> projected-points vector 2 z) (+ (-> projected-points vector 2 z) -8192))
          (dma-buffer-add-uint128 dma-buff
                                  (-> colors quad 0)
                                  (-> projected-points quad 0) ;; xyz 1
                                  (-> colors quad 0)
                                  (-> projected-points quad 1) ;; xyz 2
                                  (-> colors quad 0)
                                  (-> projected-points quad 2) ;; xyz 3
                                  )))))
  #f)

;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Buffered debug draw
;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Some of the debug draw stuff just adds a line to a list of lines to draw.
;; This is used when pausing - the actual calls to debug-draw-line won't happen, but
;; we won't clear the debug draw buffer so they will still be drawn.

(when *debug-segment*
  (deftype debug-line (structure)
    ((flags  int32)
     (bucket bucket-id)
     (v1     vector :inline)
     (v2     vector :inline)
     (color  rgba)
     (mode   symbol)
     (color2 rgba)))
  (deftype debug-text-3d (structure)
    ((flags  int32)
     (bucket bucket-id)
     (pos    vector :inline)
     (color  font-color)
     (offset vector2h :inline)
     (str    string)))
  (deftype debug-tracking-thang (basic)
    ((length           int32)
     (allocated-length int32)))
  ;; allocate debug draw buffers
  (define *debug-lines* (the (inline-array debug-line) (malloc 'debug #x100000)))
  (define *debug-lines-trk* (new 'debug 'debug-tracking-thang))
  (set! (-> *debug-lines-trk* allocated-length) 16384)
  (define *debug-text-3ds* (the (inline-array debug-text-3d) (malloc 'debug #x6000)))
  (define *debug-text-3d-trk* (new 'debug 'debug-tracking-thang))
  (set! (-> *debug-text-3d-trk* allocated-length) 512)
  (dotimes (i (-> *debug-text-3d-trk* allocated-length))
    (set! (-> *debug-text-3ds* i str) (new 'debug 'string 80 (the string #f)))))

(defun-debug get-debug-line ()
  "Allocate a debug-line from the list."
  (cond
    ((< (-> *debug-lines-trk* length) (-> *debug-lines-trk* allocated-length))
     (+! (-> *debug-lines-trk* length) 1)
     (-> *debug-lines* (+ (-> *debug-lines-trk* length) -1)))
    (else (the-as debug-line #f))))

(defun-debug get-debug-text-3d ()
  "Allocate a debug text 3d from the list."
  (cond
    ((< (-> *debug-text-3d-trk* length) (-> *debug-text-3d-trk* allocated-length))
     (+! (-> *debug-text-3d-trk* length) 1)
     (-> *debug-text-3ds* (+ (-> *debug-text-3d-trk* length) -1)))
    (else (the-as debug-text-3d #f))))

(defun-debug debug-reset-buffers ()
  "Clear the persistent line and 3D-text counts and leave pauseable drawing disabled."
  (set! (-> *debug-lines-trk* length) 0)
  (set! (-> *debug-text-3d-trk* length) 0)
  (set! *debug-draw-pauseable* #f)
  #f)

(defun-debug debug-draw-buffers ()
  "Draw every persistent debug line and 3D text entry."
  (dotimes (i (-> *debug-lines-trk* length))
    (let ((line (-> *debug-lines* i)))
      (internal-draw-debug-line (-> line bucket) (-> line v1) (-> line v2) (-> line color) (-> line mode) (-> line color2))))
  (dotimes (i (-> *debug-text-3d-trk* length))
    (let ((text (-> *debug-text-3ds* i)))
      (internal-draw-debug-text-3d (-> text bucket) (-> text str) (-> text pos) (-> text color) (-> text offset))))
  #f)

(defun-debug add-debug-line ((enable-draw symbol) (bucket bucket-id) (p0 vector) (p1 vector) (color rgba) (mode symbol) (color2 rgba))
  "Draw a debug line between p0 and p1, in 3D."
  (when enable-draw
    (cond
      (*debug-draw-pauseable*
       (let ((line (get-debug-line)))
         (when line
           (set! (-> line bucket) bucket)
           (vector-copy! (-> line v1) p0)
           (vector-copy! (-> line v2) p1)
           (set! (-> line color) color)
           (set! (-> line color2) color2)
           (set! (-> line mode) mode))))
      (else (internal-draw-debug-line bucket p0 p1 color mode color2))))
  #f)

(defun-debug add-debug-line2d ((enable-draw symbol) (bucket bucket-id) (p0 vector) (p1 vector) (color vector))
  "Convert two screen-coordinate points to GS coordinates and draw a line with the supplied packed
   color vector."
  (if (not enable-draw) (return #f))
  (with-dma-buffer-add-bucket ((dma-buff (-> (current-frame) debug-buf)) bucket)
    (let ((projected-p0 (new 'stack 'vector4w))
          (projected-p1 (new 'stack 'vector4w)))
      (set! (-> projected-p0 quad) (-> p0 quad))
      (set! (-> projected-p1 quad) (-> p1 quad))
      (set! (-> projected-p0 x) (* (+ (-> projected-p0 x) 2048) 16))
      (set! (-> projected-p0 y) (* -16 (- 2048 (-> projected-p0 y))))
      (set! (-> projected-p0 z) #x7fffff)
      (set! (-> projected-p1 x) (* (+ (-> projected-p1 x) 2048) 16))
      (set! (-> projected-p1 y) (* -16 (- 2048 (-> projected-p1 y))))
      (set! (-> projected-p1 z) #x7fffff)
      (with-cnt-vif-block (dma-buff)
        (dma-buffer-add-gif-tag dma-buff
                                (new 'static 'gif-tag64 :nloop 1 :eop 1 :pre 1 :nreg 4 :prim (gif-prim line))
                                (gs-reg-list rgbaq xyzf2 rgbaq xyzf2))
        (dma-buffer-add-uint128 dma-buff (-> color quad) (-> projected-p0 quad))
        (dma-buffer-add-uint128 dma-buff (-> color quad) (-> projected-p1 quad)))))
  #f)

(defun-debug add-debug-box ((enable-draw symbol) (bucket bucket-id) (min-point vector) (max-point vector) (color rgba))
  "Draw all twelve edges of the axis-aligned box bounded by min-point and max-point."
  (let ((start (new-stack-vector0)))
    (set! (-> start quad) (-> min-point quad))
    (let ((end (new-stack-vector0)))
      (set! (-> end quad) (-> min-point quad))
      (when enable-draw
        (set! (-> end x) (-> max-point x))
        (add-debug-line #t bucket start end color #f (the-as rgba -1))
        (set! (-> end x) (-> min-point x))
        (set! (-> end y) (-> max-point y))
        (add-debug-line #t bucket start end color #f (the-as rgba -1))
        (set! (-> end y) (-> min-point y))
        (set! (-> end z) (-> max-point z))
        (add-debug-line #t bucket start end color #f (the-as rgba -1))
        (set! (-> start y) (-> max-point y))
        (set! (-> end y) (-> max-point y))
        (add-debug-line #t bucket start end color #f (the-as rgba -1))
        (set! (-> end z) (-> min-point z))
        (set! (-> end x) (-> max-point x))
        (add-debug-line #t bucket start end color #f (the-as rgba -1))
        (set! (-> end y) (-> min-point y))
        (set! (-> start x) (-> max-point x))
        (add-debug-line #t bucket start end color #f (the-as rgba -1))
        (set! (-> start quad) (-> max-point quad))
        (set! (-> end quad) (-> max-point quad))
        (set! (-> end x) (-> min-point x))
        (add-debug-line #t bucket start end color #f (the-as rgba -1))
        (set! (-> end x) (-> max-point x))
        (set! (-> end y) (-> min-point y))
        (add-debug-line #t bucket start end color #f (the-as rgba -1))
        (set! (-> end y) (-> max-point y))
        (set! (-> end z) (-> min-point z))
        (add-debug-line #t bucket start end color #f (the-as rgba -1))
        (set! (-> start y) (-> min-point y))
        (set! (-> end y) (-> min-point y))
        (add-debug-line #t bucket start end color #f (the-as rgba -1))
        (set! (-> end z) (-> max-point z))
        (set! (-> end x) (-> min-point x))
        (add-debug-line #t bucket start end color #f (the-as rgba -1))
        (set! (-> end y) (-> max-point y))
        (set! (-> start x) (-> min-point x))
        (add-debug-line #t bucket start end color #f (the-as rgba -1)))))
  #f)

(defun-debug add-debug-x ((enable-draw symbol) (bucket bucket-id) (center vector) (color rgba))
  "Draw two short perpendicular lines centered at center in the xz plane."
  (if (not enable-draw) (return #f))
  (let ((start (new-stack-vector0))
        (end (new-stack-vector0)))
    (vector+! start center (new 'static 'vector :x -1228.8))
    (vector+! end center (new 'static 'vector :x 1228.8))
    (add-debug-line #t bucket start end color #f (the-as rgba -1))
    (vector+! start center (new 'static 'vector :z -1228.8))
    (vector+! end center (new 'static 'vector :z 1228.8))
    (add-debug-line #t bucket start end color #f (the-as rgba -1)))
  #f)

(defun-debug add-debug-text-3d ((enable-draw symbol) (bucket bucket-id) (text string) (location vector) (font-color-id font-color) (offset vector2h))
  "Draw text at location with font-color-id and an optional 2D offset. During pauseable drawing,
   copy at most 79 characters into the persistent text buffer. The PC may filter distant strings."
  (when enable-draw
    (#when PC_PORT
      ;; Check to see if the string should be filtered or not
      (when (pc-filter-debug-string? text (vector-vector-distance location (target-pos 0)))
        ;;(format #t "got: ~S~%" text)
        ;; no-op the function!
        (return #f)))
    (cond
      (*debug-draw-pauseable*
       (let ((buffered-text (get-debug-text-3d)))
         (when buffered-text
           (set! (-> buffered-text flags) 0)
           (set! (-> buffered-text bucket) bucket)
           (vector-copy! (-> buffered-text pos) location)
           (cond
             (offset (set! (-> buffered-text offset x) (-> offset x)) (set! (-> buffered-text offset y) (-> offset y)))
             (else (set! (-> buffered-text offset x) 0) (set! (-> buffered-text offset y) 0) 0))
           (set! (-> buffered-text color) font-color-id)
           (let ((length 0)
                 (src (-> text data))
                 (dst (-> buffered-text str data)))
             (while (and (nonzero? (-> src 0)) (< length 79))
               (set! (-> dst 0) (-> src 0))
               (set! src (&-> src 1))
               (set! dst (&-> dst 1))
               (+! length 1))
             (set! (-> dst 0) (the-as uint 0)))
           0)))
      (else (internal-draw-debug-text-3d bucket text location font-color-id (if offset offset (new 'static 'vector2h))))))
  #f)

(defun-debug add-debug-sphere-with-transform ((enable-draw symbol) (bucket bucket-id) (point vector) (radius meters) (xform matrix) (color rgba))
  "Transform point by xform and draw a sphere of radius at the result. The sphere itself remains
   axis-aligned; xform changes only its center."
  (rlet ((acc :class vf)
         (vf0 :class vf)
         (vf1 :class vf)
         (vf2 :class vf)
         (vf3 :class vf)
         (vf4 :class vf)
         (vf5 :class vf))
    (init-vf0-vector)
    (when enable-draw
      (.lvf vf5 (&-> point quad))
      (.lvf vf1 (&-> xform vector 0 quad))
      (.lvf vf2 (&-> xform vector 1 quad))
      (.lvf vf3 (&-> xform vector 2 quad))
      (.lvf vf4 (&-> xform vector 3 quad))
      (.mul.w.vf acc vf4 vf0)
      (.add.mul.x.vf acc vf1 vf5 acc)
      (.add.mul.y.vf acc vf2 vf5 acc)
      (.add.mul.z.vf vf5 vf3 vf5 acc)
      (let ((world-point (new 'stack-no-clear 'vector)))
        (.svf (&-> world-point quad) vf5)
        (add-debug-sphere enable-draw bucket world-point radius color)))
    #f))

(defun-debug add-debug-sphere ((enable-draw symbol) (bucket bucket-id) (center vector) (radius meters) (color rgba))
  "Draw a wireframe sphere of radius at center."
  (if enable-draw (add-debug-sphere-from-table bucket center radius color))
  #f)

(defun-debug add-debug-text-sphere ((enable-draw symbol) (bucket bucket-id) (center vector) (radius meters) (text string) (color rgba))
  "Draw a wireframe sphere of radius at center and place text there. Color affects the sphere; the
   text uses the default font color."
  (add-debug-sphere enable-draw bucket center radius color)
  (add-debug-text-3d enable-draw bucket text center (font-color default) (the-as vector2h #f))
  #f)

(defun-debug add-debug-spheres ((enable-draw symbol) (bucket bucket-id) (centers (inline-array vector)) (count int) (color rgba))
  "Draw count spheres from centers, taking each sphere's radius from the center vector's w lane."
  (when enable-draw
    (let ((center (-> centers 0)))
      (countdown (remaining count)
        (add-debug-sphere #t bucket center (-> center w) color)
        (&+! center 16))))
  #f)

(defun-debug add-debug-circle ((enable-draw symbol) (bucket bucket-id) (center vector) (radius float) (color rgba) (orientation matrix))
  "Draw a twelve-segment circle of radius around center. An optional orientation rotates its local
   xz plane before translation."
  (if (not enable-draw) (return #f))
  (let ((angle 0.0)
        (start-point (new-stack-vector0))
        (end-point (new-stack-vector0))
        (i 0))
    (while (< i 12)
      (set! (-> start-point x) (* radius (cos angle)))
      (set! (-> start-point y) 0.0)
      (set! (-> start-point z) (* radius (sin angle)))
      (set! (-> start-point w) 1.0)
      (set! angle (+ 5461.3335 angle))
      (set! (-> end-point x) (* radius (cos angle)))
      (set! (-> end-point y) 0.0)
      (set! (-> end-point z) (* radius (sin angle)))
      (set! (-> end-point w) 1.0)
      (when orientation
        (vector-matrix*! start-point start-point orientation)
        (vector-matrix*! end-point end-point orientation))
      (vector+! start-point start-point center)
      (vector+! end-point end-point center)
      (add-debug-line #t bucket start-point end-point color #f (the-as rgba -1))
      (+! i 1)))
  #f)

(defun-debug add-debug-vector ((enable-draw symbol) (bucket bucket-id) (origin vector) (direction vector) (length meters) (color rgba))
  "Draw a line from origin to origin plus direction times length."
  (if (not enable-draw) (return #f))
  (let ((end (new-stack-vector0)))
    (set! (-> end x) (+ (-> origin x) (* (-> direction x) length)))
    (set! (-> end y) (+ (-> origin y) (* (-> direction y) length)))
    (set! (-> end z) (+ (-> origin z) (* (-> direction z) length)))
    (add-debug-line #t bucket origin end color #f (the-as rgba -1)))
  #f)

(defun-debug add-debug-matrix ((enable-draw symbol) (bucket bucket-id) (xform matrix))
  "Draw the three two-meter basis axes of xform at its translation, using red for x, green for y,
   and blue for z. Return xform."
  (add-debug-vector enable-draw
                    bucket
                    (-> xform vector 3)
                    (-> xform vector 0)
                    (meters 2)
                    (new 'static 'rgba :r #xff :a #x80))
  (add-debug-vector enable-draw
                    bucket
                    (-> xform vector 3)
                    (-> xform vector 1)
                    (meters 2)
                    (new 'static 'rgba :g #xff :a #x80))
  (add-debug-vector enable-draw
                    bucket
                    (-> xform vector 3)
                    (-> xform vector 2)
                    (meters 2)
                    (new 'static 'rgba :b #xff :a #x80))
  xform)

(defun-debug add-debug-rot-matrix ((enable-draw symbol) (bucket bucket-id) (rotation matrix) (origin vector))
  "Draw the three two-meter basis axes of rotation at origin, using red for x, green for y, and blue
   for z. Return rotation."
  (add-debug-vector enable-draw bucket origin (-> rotation vector 0) (meters 2) (new 'static 'rgba :r #xff :a #x80))
  (add-debug-vector enable-draw bucket origin (-> rotation vector 1) (meters 2) (new 'static 'rgba :g #xff :a #x80))
  (add-debug-vector enable-draw bucket origin (-> rotation vector 2) (meters 2) (new 'static 'rgba :b #xff :a #x80))
  rotation)

;; WARN: Stack slot load at 32 mismatch: defined as size 4, got size 16
(defun-debug add-debug-yrot-vector ((enable-draw symbol) (bucket bucket-id) (origin vector) (yrot float) (length float) (color rgba))
  "Draw a line of length from origin in the horizontal direction selected by yrot."
  (let ((angle yrot)
        (draw-length length)
        (draw-color color))
    (if (not enable-draw) (return #f))
    (let ((end (new-stack-vector0)))
      (set-vector! end
                   (+ (-> origin x) (* (sin angle) draw-length))
                   (-> origin y)
                   (+ (-> origin z) (* (cos angle) draw-length))
                   1.0)
      (add-debug-line enable-draw bucket end origin draw-color #f (the-as rgba -1))))
  #f)

(defun-debug add-debug-arc ((enable-draw symbol)
              (bucket bucket-id)
              (center vector)
              (start-angle float)
              (end-angle float)
              (radius float)
              (color rgba)
              (orientation matrix))
  "Draw a twelve-segment arc from start-angle through end-angle at radius around center, plus radial
   lines at both ends. An optional orientation rotates the local xz plane before translation."
  (if (not enable-draw) (return #f))
  (let ((angle start-angle)
        (start-point (new 'stack-no-clear 'vector)))
    (set! (-> start-point quad) (the-as uint128 0))
    (let ((end-point (new 'stack-no-clear 'vector)))
      (set! (-> end-point quad) (the-as uint128 0))
      (let ((i 0))
        (while (< i 12)
          (set! (-> start-point x) (* radius (sin angle)))
          (set! (-> start-point y) 0.0)
          (set! (-> start-point z) (* radius (cos angle)))
          (set! (-> start-point w) 1.0)
          (+! angle (the float (/ (the int (- end-angle start-angle)) 12)))
          (set! (-> end-point x) (* radius (sin angle)))
          (set! (-> end-point y) 0.0)
          (set! (-> end-point z) (* radius (cos angle)))
          (set! (-> end-point w) 1.0)
          (when orientation
            (vector-matrix*! start-point start-point orientation)
            (vector-matrix*! end-point end-point orientation))
          (vector+! start-point start-point center)
          (vector+! end-point end-point center)
          (add-debug-line #t bucket start-point end-point color #f (the-as rgba -1))
          (cond
            ((zero? i) (add-debug-line #t bucket start-point center color #f (the-as rgba -1)))
            ((= i 11) (add-debug-line #t bucket end-point center color #f (the-as rgba -1))))
          (+! i 1)))))
  #f)

(defun-debug add-debug-curve ((enable-draw symbol)
              (bucket bucket-id)
              (cverts (inline-array vector))
              (num-cverts int)
              (knots (pointer float))
              (num-knots int)
              (color rgba))
  "Draw a curve from its control vertices and knots by evaluating four line segments per control
   vertex over normalized progress from zero through one."
  (if (not enable-draw) (return #f))
  (let ((previous (new-stack-vector0))
        (current (new 'stack-no-clear 'vector)))
    (set! (-> current quad) (the-as uint128 0))
    (let ((segment-count (* num-cverts 4)))
      (curve-evaluate! current (-> knots 0) cverts num-cverts knots num-knots)
      (let ((i 0))
        (while (< i segment-count)
          (set! (-> previous quad) (-> current quad))
          (curve-evaluate! current (/ (the float (+ i 1)) (the float segment-count)) cverts num-cverts knots num-knots)
          (add-debug-line #t bucket previous current color #f (the-as rgba -1))
          (+! i 1)))))
  #f)

(defun-debug add-debug-curve2 ((enable-draw symbol) (bucket bucket-id) (curve-data curve) (color rgba) (unused-option symbol))
  "Draw curve-data with add-debug-curve. unused-option is retained for the legacy interface."
  (if enable-draw
    (add-debug-curve #t
                     bucket
                     (-> curve-data cverts)
                     (-> curve-data num-cverts)
                     (-> curve-data knots)
                     (-> curve-data num-knots)
                     color))
  #f)

(defun-debug add-debug-points ((enable-draw symbol)
              (bucket bucket-id)
              (points (inline-array vector))
              (count int)
              (color rgba)
              (fixed-y float)
              (highlight-index int))
  "Label and mark count points. A nonzero fixed-y overrides every point's y coordinate, and
   highlight-index is drawn white while the remaining points use color."
  (when enable-draw
    (dotimes (i count)
      (let ((point (new 'stack-no-clear 'vector)))
        (set! (-> point quad) (the-as uint128 0))
        (set! (-> point quad) (-> points i quad))
        (if (!= fixed-y 0.0) (set! (-> point y) fixed-y))
        (let ((draw-text add-debug-text-3d)
              (draw-enabled #t)
              (draw-bucket bucket))
          (format (clear *temp-string*) "~d" i)
          (draw-text draw-enabled draw-bucket *temp-string* point (font-color white) (the-as vector2h #f)))
        (add-debug-x #t bucket point (if (= i highlight-index) (new 'static 'rgba :r #xff :g #xff :b #xff :a #x80) color)))))
  #f)

(defun-debug debug-percent-bar ((enable-draw symbol) (bucket bucket-id) (x int) (y int) (fraction float) (color rgba))
  "Draw a 255-pixel background bar and a ten-pixel-high colored fill at screen position x,y. The
   fill width is 255 times fraction."
  (if (not enable-draw) (return #f))
  (with-dma-buffer-add-bucket ((dma-buff (-> *display* frames (-> *display* on-screen) frame debug-buf)) bucket) :bucket-group (-> *display* frames (-> *display* on-screen) frame bucket-group) (draw-sprite2d-xy dma-buff x y 255 14 (new 'static 'rgba :a #x40)) (draw-sprite2d-xy dma-buff x (+ y 2) (the int (* 255.0 fraction)) 10 color))
  #f)

(defun-debug debug-pad-display ((pad cpad-info))
  "Shift a 32-sample stick history, append the current left-stick direction and speed, and draw the
   samples as fading 2D squares."
  (let ((history
          ;; og:preserve-this
          (new 'static
               'inline-array
               vector
               32 ;; was originally 8, which is too small and would cause memory corruption
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector)
               ;; added
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector)
               (new 'static 'vector))))
    (let ((i 31)) (while (nonzero? i) (+! i -1) (set! (-> history (+ i 1) quad) (-> history i quad))))
    (set! (-> history 0 x) (* (sin (-> pad stick0-dir)) (-> pad stick0-speed)))
    (set! (-> history 0 y) (* (cos (-> pad stick0-dir)) (-> pad stick0-speed)))
    (dotimes (i 32)
      (with-dma-buffer-add-bucket ((dma-buff (-> (current-frame) debug-buf)) (bucket-id debug))
        (draw-sprite2d-xy dma-buff
                          (the int (* 120.0 (-> history i x)))
                          (the int (* 144.0 (-> history i y)))
                          10
                          10
                          (new 'static 'rgba :a #x80 :r (- 255 (* 7 i)))))))
  #f)

(defun-debug add-debug-light ((enable-draw symbol) (bucket bucket-id) (light-data light) (origin vector) (label string))
  "When the light has a nonzero level, draw its direction from origin and place a labeled sphere at
   the level-scaled endpoint. The sphere color is derived from the light color."
  (if (not enable-draw) (return #f))
  (when (!= (-> light-data levels x) 0.0)
    (add-debug-vector enable-draw
                      bucket
                      origin
                      (-> light-data direction)
                      (meters 3)
                      (new 'static 'rgba :r #xff :g #xff :b #xff :a #x80))
    (let ((position (vector+*! (new-stack-vector0) origin (-> light-data direction) (* 12288.0 (-> light-data levels x))))
          (packed-color (logior (logior (logior (shr (shl (the int (* 128.0 (-> light-data color w))) 56) 32)
                                                (shr (shl (the int (* 128.0 (-> light-data color z))) 56) 40))
                                        (shr (shl (the int (* 128.0 (-> light-data color y))) 56) 48))
                                (shr (shl (the int (* 128.0 (-> light-data color x))) 56) 56))))
      (format (clear *temp-string*) "~S ~,,2f" label (-> light-data levels x))
      (let ((text *temp-string*))
        (add-debug-text-sphere enable-draw bucket position (* 2048.0 (-> light-data levels x)) text (the-as rgba packed-color)))))
  #f)

(defun-debug add-debug-lights ((enable-draw symbol) (bucket bucket-id) (lights (inline-array light)) (origin vector))
  "Draw the three directional lights and ambient light in lights from origin."
  (if (not enable-draw) (return #f))
  (add-debug-light enable-draw bucket (-> lights 0) origin "dir0")
  (add-debug-light enable-draw bucket (-> lights 1) origin "dir1")
  (add-debug-light enable-draw bucket (-> lights 2) origin "dir2")
  (add-debug-light enable-draw bucket (-> lights 3) origin "ambi")
  #f)

(defun-debug-recursive drawable-frag-count int ((drawable-data drawable))
  "Recursively count leaf drawables below drawable-data. False contributes zero, a drawable-group
   contributes the sum of its children, and any other drawable contributes one."
  (let ((count 0))
    (cond
      ((not drawable-data))
      ((type-type? (-> drawable-data type) drawable-group)
       (dotimes (i (-> (the-as drawable-group drawable-data) length))
         (+! count (drawable-frag-count (-> (the-as drawable-group drawable-data) data i)))))
      (else (+! count 1)))
    count))

(defmethod inspect ((obj debug-vertex-stats))
  (format #t "[~8x] ~A~%" obj (-> obj type))
  (format #t "~Tlength: ~D~%" (-> obj length))
  (format #t "~Tpos-count: ~D~%" (-> obj pos-count))
  (format #t "~Tdata[~D]: @ #x~X~%" (-> obj length) (-> obj vertex))
  (dotimes (i (-> obj length))
    (let ((vertex (-> obj vertex i)))
      (format #t
              "  ~D : trans: ~D ~D ~D ~D"
              i
              (-> vertex trans x)
              (-> vertex trans y)
              (-> vertex trans z)
              (-> vertex trans w))
      (format #t "   st: ~D ~D~%" (-> vertex st x) (-> vertex st y))
      (format #t
              "       col: ~X   norm: ~D ~D ~D~%"
              (-> vertex color)
              (-> vertex normal x)
              (-> vertex normal y)
              (-> vertex normal z))))
  obj)

(defun-debug history-init ((history pos-history) (num-points int))
  "Set history's capacity to num-points and clear its lazily allocated point buffer."
  (set! (-> history num-points) num-points)
  (set! (-> history points) (the-as (inline-array vector) #f))
  history)

(defun-debug history-draw-and-update ((history pos-history) (draw-enabled int) (position vector))
  "Allocate history storage on the debug heap when drawing first becomes enabled, append position
   to the circular cursor, and when enabled draw adjacent stored samples without closing the ring."
  (if (and draw-enabled (not (-> history points)))
    (set! (-> history points) (the-as (inline-array vector) (malloc 'debug (* (-> history num-points) 16)))))
  (when (-> history points)
    (vector-copy! (-> history points (-> history h-first)) position)
    (+! (-> history h-first) 1)
    (when (>= (-> history h-first) (-> history num-points))
      (set! (-> history h-first) 0)
      0))
  (when draw-enabled
    (dotimes (i (1- (-> history num-points)))
      (if (!= (+ i 1) (-> history h-first))
        (add-debug-line #t
                        (bucket-id debug-no-zbuf)
                        (-> history points i)
                        (-> history points (1+ i))
                        (static-rgba #x80 #xc0 #x80 #x80)
                        #f
                        (the-as rgba -1)))))
  #f)

(defun-debug dma-timeout-cam ()
  "Set the debug camera to the fixed position and rotation used to investigate DMA timeouts."
  (let ((position (new-stack-vector0))
        (rotation (new-stack-matrix0)))
    (set! (-> position x) -666764.4)
    (set! (-> position y) 21102.984)
    (set! (-> position z) 51613.348)
    (set! (-> position w) 1.0)
    (set! (-> rotation vector 0 x) -0.911)
    (set! (-> rotation vector 0 y) 0.0)
    (set! (-> rotation vector 0 z) 0.4122)
    (set! (-> rotation vector 0 w) 0.0)
    (set! (-> rotation vector 1 x) -0.0984)
    (set! (-> rotation vector 1 y) 0.971)
    (set! (-> rotation vector 1 z) -0.2174)
    (set! (-> rotation vector 1 w) 0.0)
    (set! (-> rotation vector 2 x) -0.4003)
    (set! (-> rotation vector 2 y) -0.2387)
    (set! (-> rotation vector 2 z) -0.8847)
    (set! (-> rotation vector 2 w) 0.0)
    (set! (-> rotation vector 3 x) 0.0)
    (set! (-> rotation vector 3 y) 0.0)
    (set! (-> rotation vector 3 z) 0.0)
    (set! (-> rotation vector 3 w) 1.0)
    (debug-set-camera-pos-rot! position rotation)))

(defun-debug display-file-info ()
  "When enabled outside menus, print file versions, source asset names, and tool diagnostics for
   every active level."
  (when (and *display-file-info* (!= *master-mode* 'menu))
    (dotimes (i (-> *level* length))
      (let ((level-data (-> *level* level i)))
        (when (= (-> level-data status) 'active)
          (let ((bsp-data (-> level-data bsp)))
            (format *stdcon* "file name: ~S~%" (-> bsp-data info file-name))
            (format *stdcon* "version: ~D.~D~%" (-> bsp-data info major-version) (-> bsp-data info minor-version))
            (format *stdcon* "maya file: ~S~%" (-> bsp-data info maya-file-name))
            (format *stdcon* "mdb file: ~S~%" (-> bsp-data info mdb-file-name))
            (format *stdcon* "~S" (-> bsp-data info tool-debug)))))))
  0)