jak-project/goal_src/jak1/engine/common-obs/process-drawable.gc

;;-*-Lisp-*-
(in-package goal)
(bundles "ENGINE.CGO" "GAME.CGO")
(require "engine/engine/engines.gc")
(require "engine/gfx/merc/merc-blend-shape.gc")
(require "engine/game/game-info.gc")
(require "engine/gfx/foreground/eye-h.gc")
(require "engine/gfx/shadow/shadow-cpu-h.gc")
(require "engine/collide/collide-shape-rider.gc")
(require "engine/load/loader.gc")

;; Construct and inspect drawable skeletons, maintain joint-animation channel stacks, and build the
;; cspace matrices consumed by the foreground renderer.

(define-extern *debug-vertex-stats* debug-vertex-stats)

(define-extern drawable-frag-count (function drawable int))

(define-extern drawable-tri-count (function drawable int))

(define-extern drawable-vertex-ratio (function drawable debug-vertex-stats int))

(define-extern cspace-inspect-tree (function process-drawable cspace int int object process-drawable))

;; DECOMP BEGINS

(defun cspace-by-name ((owner-drawable process-drawable) (name string))
  "Return the first cspace node whose joint has name, or #f when the drawable has no matching
   joint."
  (let* ((node-count (-> owner-drawable node-list length))
         (i 0)
         (node (-> owner-drawable node-list data i)))
    (while (< i node-count)
      (if (and (-> node joint) (name= (-> node joint name) name)) (return node))
      (+! i 1)
      (set! node (-> owner-drawable node-list data i))))
  (the-as cspace #f))

(defun cspace-index-by-name ((owner-drawable process-drawable) (name string))
  "Return the node-list index of the first joint with name, or -1 when it is absent."
  (let* ((joint-index 0)
         (node-count (-> owner-drawable node-list length))
         (i 0)
         (node (-> owner-drawable node-list data i)))
    (while (< i node-count)
      (if (and (-> node joint) (name= (-> node joint name) name)) (return joint-index))
      (+! joint-index 1)
      (+! i 1)
      (set! node (-> owner-drawable node-list data i))))
  -1)

(defun vector<-cspace! ((destination vector) (cspace-node cspace))
  "Extract a cspace bone's homogeneous translation into destination. The stored xyz components are
   divided by w and the result is returned as a position vector."
  (rlet ((Q :class vf)
         (vf0 :class vf)
         (vf2 :class vf))
    (init-vf0-vector)
    (.lvf vf2 (&-> (-> cspace-node bone) transform vector 3 quad))
    (.div.vf Q vf0 vf2 :fsf #b11 :ftf #b11)
    ;; og:preserve-this ADDED
    ;; there's a bug in swamp-blimp where they vector<-cspace!
    ;; on some default-initialized-to-zero bones
    ;; we have to return 0s for this to avoid NaNs getting everywhere.
    (let ((temp (new-stack-vector0)))
      (.svf (&-> temp quad) vf2)
      (when (= (-> temp w) 0.0)
        (set-vector! destination 0. 0. 0. 1.)
        (return destination)))
    (.wait.vf)
    (.mul.vf.xyz vf2 vf2 Q)
    (.nop.vf)
    (.nop.vf)
    (.mov.vf.w vf2 vf0)
    (.svf (&-> destination quad) vf2)
    destination))

(defun vector<-cspace+vector! ((destination vector) (cspace-node cspace) (local-position vector))
  "Transform local-position by the cspace bone matrix and write the result to destination."
  (vector-matrix*! destination local-position (-> cspace-node bone transform)))

(defun-debug cspace-children ((owner-drawable process-drawable) (parent-index int))
  "Return a list of every cspace node whose parent is parent-index."
  (let ((children '()))
    (countdown (i (-> owner-drawable node-list length))
      (if (= (-> owner-drawable node-list data i parent) parent-index)
        (set! children (cons (-> owner-drawable node-list data i) children))))
    children))

(defun-debug cspace-inspect-tree ((owner-drawable process-drawable) (node cspace) (depth int) (branch-mask int) (display-mode object))
  "Print the cspace hierarchy below node. depth and branch-mask control the tree guides; display-mode
   may add joint-animation matrix details or mesh fragment, triangle, and vertex statistics."
  (local-vars (inspect-result object))
  (if (and (= display-mode 'mesh) (zero? *debug-vertex-stats*)) (set! *debug-vertex-stats* (new 'debug 'debug-vertex-stats)))
  (if (not node) (set! node (the-as cspace (-> owner-drawable node-list data))))
  (print-tree-bitmask branch-mask depth)
  (cond
    ((-> node joint)
     (format #t "~S~S ~D" (if (zero? depth) "" "+---") (-> node joint name) (-> node joint number))
     (let ((mode display-mode))
       (set! inspect-result
             (cond
               ((= mode 'matrix)
                (let ((saved-print-column *print-column*))
                  (set! *print-column* (the-as binteger (* (* depth 4) 8)))
                  (set! inspect-result
                        (joint-anim-inspect-elt (-> owner-drawable skel frame-group0 data (-> node joint number))
                                                (-> owner-drawable skel frame-num0)))
                  (set! *print-column* saved-print-column))
                inspect-result)
               ((= mode 'mesh)
                (format #t
                        " ~D/~D/~F"
                        (drawable-frag-count (the-as drawable (-> node geo)))
                        (drawable-tri-count (the-as drawable (-> node geo)))
                        (drawable-vertex-ratio (the-as drawable (-> node geo)) *debug-vertex-stats*))))))
     (format #t "~%"))
    (else (format #t "~S~S~%" (if (zero? depth) "" "+---") node)))
  (let* ((children (cspace-children owner-drawable (the-as int node)))
         (children-object children)
         (children-left ((method-of-type (rtype-of children-object) length) children-object))
         (child (-> children car)))
    (while (not (null? (the-as object children)))
      (+! children-left -1)
      (cspace-inspect-tree owner-drawable
                           (the-as cspace child)
                           (+ depth 1)
                           (if (zero? children-left) branch-mask (logior branch-mask (ash 1 (+ depth 1))))
                           display-mode)
      (set! children (the-as pair (-> children cdr)))
      (set! child (-> children car))))
  owner-drawable)

(defmethod new draw-control ((allocation symbol) (type-to-make type) (owner-process process) (joint-geometry art-joint-geo))
  "Allocate draw control for owner-process and retain the joint geometry used to construct its
   skeleton."
  (let ((control (object-new allocation type-to-make (the-as int (-> type-to-make size)))))
    (set! (-> control jgeo) joint-geometry)
    (set! (-> control process) owner-process)
    control))

(defmethod lod-set! ((this draw-control) (requested-lod int))
  "Clamp desired-lod to the available range and switch the current merc geometry when the
   selected level changes."
  (let ((selected-lod (max 0 (min requested-lod (-> this lod-set max-lod)))))
    (set! (-> this desired-lod) selected-lod)
    (when (!= (-> this cur-lod) selected-lod)
      (set! (-> this mgeo) (-> this lod-set lod selected-lod geo))
      (set! (-> this cur-lod) selected-lod)))
  0
  (none))

(defmethod lods-assign! ((this draw-control) (new-lods lod-set))
  "Copy a complete LOD set into this draw control, then reselect the nearest valid current LOD
   so its geometry pointer agrees with the new table."
  (mem-copy! (the-as pointer (-> this lod-set)) (the-as pointer new-lods) 33)
  (let ((selected-lod (min (-> this cur-lod) (-> this lod-set max-lod))))
    (set! (-> this cur-lod) -1)
    (lod-set! this selected-lod))
  0
  (none))

(defmethod setup-lods! ((this lod-set) (skeleton-group-data skeleton-group) (art-group-data art-group) (owner-entity entity))
  "Resolve the skeleton group's mesh indices into the art group's merc geometry, copy each LOD
   distance, and apply entity or joint-geometry distance overrides. Return #f if any mesh index or
   type is invalid."
  (local-vars (distance-tag res-tag))
  (let ((skeleton-spec skeleton-group-data)
        (art-resources art-group-data))
    (let ((art-element-count (-> art-resources length))
          (max-lod (-> skeleton-spec max-lod)))
      (set! (-> this max-lod) max-lod)
      (dotimes (i (+ max-lod 1))
        (when (or (>= (-> skeleton-spec mgeo i) art-element-count)
                  (begin
                    (set! skeleton-group-data (the-as skeleton-group (-> art-resources data (-> skeleton-spec mgeo i))))
                    (!= (-> (the-as art-element skeleton-group-data) type) merc-ctrl)))
          (set! this (the-as lod-set #f))
          (goto cfg-16))
        (set! (-> this lod i geo) (the-as merc-ctrl skeleton-group-data))
        (set! (-> this lod i dist) (-> skeleton-spec lod-dist i)))
      (if (= (-> this lod max-lod dist) 4095996000.0)
        (set! (-> this lod max-lod dist) (res-lump-float owner-entity 'vis-dist :default 4095996000.0))))
    (let ((joint-geometry (-> art-resources data (-> skeleton-spec jgeo))))
      (set! distance-tag (new 'static 'res-tag))
      (let ((distance-overrides (res-lump-data (-> joint-geometry extra) 'lod-dist pointer :tag-ptr (& distance-tag))))
        (when distance-overrides
          (dotimes (i (the-as int (-> distance-tag elt-count)))
            (set! (-> this lod i dist) (-> (the-as (pointer float) (&+ distance-overrides (* i 4))))))))))
  (label cfg-16)
  this)

(define *default-skel-template* '((align root #f) (prejoint root cspace<-parented-matrix-joint!)))

(defbehavior make-nodes-from-jg process-drawable ((joint-geometry art-joint-geo) (skeleton-template pair) (allocation symbol))
  "Allocate the drawable's cspace and bone arrays from joint-geometry and skeleton-template,
   connect each joint to its parent and transform function, then register the drawable with the
   foreground renderer."
  (let ((nodes ((method-of-type cspace-array new) allocation cspace-array (+ (-> joint-geometry length) 1))))
    (let ((allocated-bones ((method-of-type skeleton new) allocation skeleton (+ (-> joint-geometry length) 1))))
      (set! (-> self draw skeleton) allocated-bones)
      (let ((bones allocated-bones))
        (when (or (zero? nodes) (zero? bones))
          (go process-drawable-art-error "memory")
          (set! nodes (the-as cspace-array #f))
          (goto cfg-16))
        (let ((root-node ((method-of-type cspace reset-and-assign-geo!) (-> nodes data 0) #f)))
          (set! (-> root-node bone) (the-as bone (-> bones bones)))
          (let ((node-data (-> nodes data)))
            (set! (-> node-data 0 param0) cspace<-transformq!)
            (set! (-> node-data 0 param1) (the-as basic (-> self root trans))))
          (set! (-> root-node bone cache bone-matrix) (the-as uint 0)))
        0
        (let ((matrix-node (reset-and-assign-geo! (-> nodes data 1) #f)))
          (set! (-> matrix-node joint) (-> joint-geometry data 0))
          (set! (-> matrix-node bone) (-> bones bones 1))
          (set! (-> matrix-node parent) (the-as cspace (-> nodes data)))
          (set! (-> matrix-node bone cache bone-matrix) (the-as uint 128)))
        (let ((first-joint-node (reset-and-assign-geo! (-> nodes data 2) #f)))
          (set! (-> first-joint-node joint) (-> joint-geometry data 1))
          (set! (-> first-joint-node bone) (-> bones bones 2))
          (set! (-> first-joint-node parent) (the-as cspace (-> nodes data)))
          (let ((joint-node first-joint-node))
            (set! (-> joint-node param0) cspace<-parented-matrix-joint!)
            (set! (-> joint-node param1) self))
          (set! (-> first-joint-node bone cache bone-matrix) (the-as uint 256)))
        (let ((node-index 3))
          (while (< node-index (-> nodes length))
            (let* ((joint-data (-> joint-geometry data (+ node-index -1)))
                   (parent-index (if (-> joint-data parent) (+ (-> joint-data parent number) 1) 0))
                   (node (reset-and-assign-geo! (-> nodes data node-index) #f)))
              (set! (-> node joint) joint-data)
              (set! (-> node bone) (-> bones bones node-index))
              (set! (-> node parent) (-> nodes data parent-index))
              (set! (-> node bone cache bone-matrix) (the-as uint (* node-index 128)))
              (set! (-> node bone cache parent-matrix) (the-as uint (* parent-index 128))))
            (+! node-index 1)))))
    (add-connection (-> (if (-> self entity) (-> self entity extra level) (-> *level* level-default))
                        foreground-draw-engine
                        (-> self draw sink-group merc-sink foreground-texture-page))
                    self
                    add-process-drawable
                    self
                    (-> self draw)
                    #f)
    (label cfg-16)
    nodes))

(defun fill-skeleton-cache ((owner-drawable process-drawable))
  "Initialize each bone cache's matrix offsets, parent-matrix offset, and frame marker, then write
   back the cache lines so the animation hardware sees the updated records."
  (let ((nodes (-> owner-drawable node-list))
        (bone-array (-> owner-drawable draw skeleton)))
    (dotimes (i (-> nodes length))
      (let ((node (-> nodes data i))
            (cache-record (the-as bone-cache (+ (the-as uint (the-as bone-cache (-> bone-array bones 0 cache))) (* 96 i)))))
        (set! (-> cache-record bone-matrix) (the-as uint (* i 128)))
        (set! (-> cache-record frame) (the-as uint 0))
        (let ((parent-joint-number 0))
          (if (and (-> node parent) (-> node parent joint)) (set! parent-joint-number (-> node parent joint number)))
          (set! (-> cache-record parent-matrix) (the-as uint (* (+ parent-joint-number 1) 128))))
        ;; The animation DMA reads these records without using the EE cache. Write back both cache
        ;; ways after changing a record so memory contains the offsets just calculated.
        (#unless PC_PORT
          (sync.l)
          (cache dxwbin cache-record 0)
          (sync.l)
          (cache dxwbin cache-record 1)))
      (#unless PC_PORT
        (sync.l))
      0))
  0)

(defun execute-math-engine ()
  "Evaluate joint matrices for every valid process queued in the matrix engine, then empty the
   queue."
  (#when PC_PORT
    (with-dma-buffer-add-bucket ((debug-buf (-> (current-frame) global-buf)) (bucket-id debug-no-zbuf))
      (when *display-actor-counts*
        (draw-string-xy (string-format "M: ~D/~D A: ~D" (-> *matrix-engine* length) MATRIX_ENGINE_AMOUNT (process-count *active-pool*))
                        debug-buf
                        8
                        (- 224 18)
                        (font-color default)
                        (font-flags shadow kerning)))))
  (let ((matrix-engine *matrix-engine*))
    (countdown (i (-> matrix-engine length))
      (let ((queued-drawable (handle->process (-> matrix-engine i))))
        (if queued-drawable (do-joint-math! (the-as process-drawable queued-drawable)))))
    (set! (-> matrix-engine length) 0))
  0
  0)

(define-extern draw-joint-spheres (function process-drawable symbol))

(#when PC_PORT
  (define *display-bones* #f)
  (define *display-joint-names* #f)
  (defun-debug draw-bone-lines ((obj process-drawable))
    "Added in PC port to debug bones"
    (dotimes (i (-> obj node-list length))
      (let ((parent (-> obj node-list data i parent)))
        (when (and parent (nonzero? parent) (-> parent joint) (-> parent parent))
          (let ((child (vector<-cspace! (new-stack-vector0) (-> obj node-list data i))))
            (add-debug-line #t
                            (bucket-id debug)
                            child
                            (vector<-cspace! (new-stack-vector0) parent)
                            (new 'static 'rgba :g #xff :a #x40)
                            #f
                            (the rgba -1))))))))

(defmethod do-joint-math! ((this process-drawable))
  "Generate the current animation frame, run skeleton prebind and postbind hooks, build every
   cspace transform, and update the draw origin. Hidden objects with no-animation set are skipped."
  (cond
    ((logtest? (-> this draw status) (draw-status hidden no-anim)))
    ((zero? (-> this skel))
     (matrix<-transformq+trans! (the-as matrix (-> this draw skeleton bones 3))
                                (the-as transformq (-> this root trans))
                                (-> this draw skeleton bones 0 transform vector 3))
     (set! (-> this draw origin quad) (-> this draw skeleton bones 3 transform vector 3 quad)))
    (else
     (let ((joint-count (-> this draw mgeo num-joints)))
       (let ((frame-node-count (+ joint-count 2)))
         (+ frame-node-count 1)
         ((-> this skel generate-frame-function)
          (the-as (inline-array vector) (+ 2416 (the-as int (the-as terrain-context (scratchpad-object int)))))
          frame-node-count
          this)
         (if (-> this skel prebind-function)
           ((-> this skel prebind-function) (the-as pointer (+ 2416 (scratchpad-object int))) frame-node-count this)))
       (dotimes (i 1)
         (let* ((special-node (-> this node-list data i))
                (transform-function (-> special-node param0)))
           (if transform-function
             ((the-as (function cspace basic basic int) transform-function)
              special-node
              (-> special-node param1)
              (-> special-node param2)))))
       (dotimes (i 2)
         (let* ((matrix-node (-> this node-list data (+ i 1)))
                (matrix-data (+ (* i 64) 2416 (scratchpad-object int)))
                (transform-function (-> matrix-node param0)))
           (if transform-function
             ((the-as (function cspace pointer none) transform-function) matrix-node (the-as pointer matrix-data)))))
       (let ((joint-node-base 3))
         (dotimes (i joint-count)
           (let ((joint-node (-> this node-list data (+ i joint-node-base)))
                 (joint-transform (+ (* 48 i) 2544 (scratchpad-object int))))
             (if (-> joint-node param0)
               ((the-as (function cspace matrix none) (-> joint-node param0)) joint-node (the-as matrix joint-transform))
               (cspace<-parented-transformq-joint! joint-node (the-as transformq joint-transform)))))))
     (if (-> this skel postbind-function) ((-> this skel postbind-function) this))
     (let ((origin-joint-index (-> this draw origin-joint-index)))
       (if (zero? origin-joint-index)
         (set! (-> this draw origin quad)
               (-> (the-as (pointer uint128)
                           (+ (the-as uint (-> this draw skeleton bones 0 transform vector 3)) (* (the-as uint 96) origin-joint-index)))))
         (vector<-cspace! (-> this draw origin) (-> this node-list data origin-joint-index))))))
  (#when PC_PORT
    (when *debug-segment*
      (if *display-bones* (draw-bone-lines this))
      (if *display-joint-names* (draw-joint-spheres this))))
  0
  (none))

(defmethod cleanup-for-death ((this process-drawable))
  "Remove collision links, disable joint channels, and mark the drawable's entity permanently
   dead before process teardown."
  (if (type-type? (-> this root type) collide-shape) (clear-collide-with-as (the-as collide-shape (-> this root))))
  (if (nonzero? (-> this skel)) (ja-channel-set! 0))
  (process-entity-status! this (entity-perm-status dead) #t)
  (none))

(defun draw-joint-spheres ((owner-drawable process-drawable))
  "Draw a small debug sphere at every cspace node; the PC debug build also labels named joints."
  (dotimes (i (-> owner-drawable node-list length))
    (let ((position (vector<-cspace! (new-stack-vector0) (-> owner-drawable node-list data i))))
      (add-debug-sphere #t (bucket-id debug) position (meters 0.1) (static-rgba 0 #xff 0 #x40))
      (#when PC_PORT
        (add-debug-text-sphere (!= (-> owner-drawable node-list data i joint) #f)
                               (bucket-id debug)
                               position
                               (meters 0.1)
                               (-> owner-drawable node-list data i joint name)
                               (static-rgba 0 #xff 0 #x40)))))
  #f)

(defmethod deactivate ((this process-drawable))
  "Stop particles and ambient sound owned by this drawable, then perform the ordinary process
   deactivation."
  (if (nonzero? (-> this part)) (kill-and-free-particles (-> this part)))
  (if (nonzero? (-> this sound)) (stop! (-> this sound)))
  ((method-of-type process deactivate) this)
  (none))

(defstate process-drawable-art-error (process-drawable)
  :code
    (behavior ((resource-kind string))
      (logior! (-> self entity extra perm status) (entity-perm-status error))
      (loop
        (when *display-entity-errors*
          (let ((draw-text add-debug-text-3d)
                (debug-enabled? #t)
                (debug-bucket 68))
            (format (clear *temp-string*) "~2j~s art error for ~s" resource-kind (-> self name))
            (draw-text debug-enabled?
                       (the-as bucket-id debug-bucket)
                       *temp-string*
                       (-> self root trans)
                       (font-color red)
                       (the-as vector2h #f))))
        (suspend))
      (none)))

(define-extern ja-post (function none :behavior process-drawable))

(define-extern anim-loop (function none :behavior process-drawable))

(defstate process-drawable-idle (process-drawable)
  :code anim-loop
  :post ja-post)

(defmethod initialize-skeleton ((this process-drawable) (skeleton-group-data skeleton-group) (skeleton-template pair))
  "Load the skeleton group's art group, construct draw and cspace data from skeleton-template,
   select its meshes and render resources, and initialize joint animation. Art lookup or type errors
   enter process-drawable-art-error."
  (local-vars (control draw-control))
  (let ((resource-level (cond
                          ((= (-> skeleton-group-data texture-level) 2) (-> *level* level-default))
                          ((-> this entity) (-> this entity extra level))
                          (else (-> *level* level-default)))))
    (let ((art-group-data (load-to-heap-by-name (-> resource-level art-group)
                                                (-> skeleton-group-data art-group-name)
                                                #f
                                                global
                                                (-> skeleton-group-data version))))
      (when (or (zero? art-group-data) (or (not art-group-data) (!= (-> art-group-data type) art-group)))
        (go process-drawable-art-error "art-group")
        (set! control (the-as draw-control #f))
        (goto cfg-59))
      (let ((joint-geometry (-> art-group-data data (-> skeleton-group-data jgeo)))
            (art-element-count (-> art-group-data length)))
        (when (or (>= (-> skeleton-group-data jgeo) art-element-count) (!= (-> joint-geometry type) art-joint-geo))
          (go process-drawable-art-error "joint-geo")
          (set! control (the-as draw-control #f))
          (goto cfg-59))
        (let ((new-control (new 'process 'draw-control this (the-as art-joint-geo joint-geometry))))
          (set! (-> this draw) new-control)
          (set! control new-control))
        (let ((control-data control))
          (set! (-> control-data status) (draw-status no-skeleton-update))
          (set! (-> control-data art-group) art-group-data)
          (set! (-> control-data jgeo) (the-as art-joint-geo joint-geometry))
          (set! (-> control-data force-lod) -1)
          (set! (-> control-data cur-lod) -1)
          (set! (-> control-data shadow) #f)
          (set! (-> control-data shadow-ctrl) #f)
          (set! (-> control-data data-format) (the-as uint 1))
          (vector-copy! (-> control-data color-mult) (new 'static 'vector :x 1.0 :y 1.0 :z 1.0 :w 1.0))
          (vector-copy! (-> control-data color-emissive) (new 'static 'vector))
          (set! (-> control-data level-index)
                (the-as uint (-> (if (-> this entity) (-> this entity extra level) (-> *level* level-default)) index)))
          (set! (-> control-data longest-edge) (-> skeleton-group-data longest-edge))
          (set! (-> control-data ripple) #f))
        (vector-copy! (-> control bounds) (-> skeleton-group-data bounds))
        (let ((shadow-index (-> skeleton-group-data shadow)))
          (when (and (> shadow-index 0) (< shadow-index art-element-count))
            (let ((shadow-geometry (-> art-group-data data shadow-index))
                  (entity-options (res-lump-value (-> this entity) 'options uint128)))
              (if (and (not (logtest? #x20000 entity-options)) (= (-> shadow-geometry type) shadow-geo))
                (set! (-> control shadow) (the-as shadow-geo shadow-geometry))))))
        (if (not (setup-lods! (-> control lod-set) skeleton-group-data art-group-data (-> this entity)))
          (go process-drawable-art-error "mesh"))
        (let ((texture-bucket (res-lump-value (-> joint-geometry extra) 'texture-bucket int :default (the-as uint128 1))))
          (let ((resource-level-index (if (= (-> skeleton-group-data texture-level) 2) 2 (-> resource-level index))))
            (if (= (the-as uint texture-bucket) 4) (set! texture-bucket 2))
            (if (= resource-level-index 2) (set! texture-bucket (-> skeleton-group-data sort))))
          (set! (-> control sink-group) (-> resource-level foreground-sink-group texture-bucket)))
        (set! (-> control dma-add-func) (the-as (function process-drawable draw-control symbol object none) nothing))
        (set! (-> this node-list) (make-nodes-from-jg (the-as art-joint-geo joint-geometry) skeleton-template 'process))
        (set! (-> control dma-add-func) dma-add-process-drawable)
        (set! (-> control shadow-mask) (res-lump-value (-> this entity) 'shadow-mask uint))
        (set! (-> control light-index) (res-lump-value (-> this entity) 'light-index uint))
        (lod-set! control 0)
        (let ((channel-count (res-lump-value (-> joint-geometry extra) 'joint-channel int :default (the-as uint128 6))))
          (cond
            ((> channel-count 0)
             (logior! (-> control status) (draw-status has-joint-channels))
             (let ((new-controller (new 'process 'joint-control channel-count)))
               (set! (-> this skel) new-controller)
               (let ((joint-controller new-controller))
                 (cond
                   ((>= (-> skeleton-group-data janim) 0)
                    (when (or (>= (-> skeleton-group-data janim) art-element-count)
                              (!= (-> art-group-data data (-> skeleton-group-data janim) type) art-joint-anim))
                      (go process-drawable-art-error "initial joint-anim")
                      (set! control (the-as draw-control #f))
                      (goto cfg-59))
                    (ja-channel-set! 1)
                    (let ((root-channel (-> this skel root-channel 0)))
                      (joint-control-channel-group-eval! root-channel
                                                         (the-as art-joint-anim (-> art-group-data data (-> skeleton-group-data janim)))
                                                         num-func-identity)
                      (set! (-> root-channel frame-num) 0.0)))
                   (else (ja-channel-set! 0)))
                 (set! (-> joint-controller effect) (new 'process 'effect-control this)))))
            (else
             (set! (-> control skeleton bones 0 transform vector 3 quad)
                   (-> (the-as vector
                               (get-property-struct (-> joint-geometry extra)
                                                    'trans-offset
                                                    'interp
                                                    -1000000000.0
                                                    *null-vector*
                                                    (the-as (pointer res-tag) #f)
                                                    *res-static-buf*))
                       quad))))))))
  (let ((collision-root (the-as collide-shape (-> (the-as collide-shape this) dir-targ x))))
    (if (and collision-root (nonzero? collision-root) (type-type? (-> collision-root type) collide-shape))
      (find-collision-meshes collision-root)))
  (label cfg-59)
  (none))

(defmethod initialize-skeleton-by-name ((this process-drawable) (name string) (skeleton-template object))
  "Resolve *<name>-sg* to a valid skeleton-group and initialize it with skeleton-template.
   Enter process-drawable-art-error when the named group is absent or invalid."
  (let ((symbol-converter string->symbol))
    (format (clear *temp-string*) "*~S-sg*" name)
    (let ((skeleton-group-data (-> (symbol-converter *temp-string*) value)))
      (if (and (nonzero? skeleton-group-data) (valid? skeleton-group-data skeleton-group #f #f 0))
        (initialize-skeleton this (the-as skeleton-group skeleton-group-data) (the-as pair skeleton-template))
        (go process-drawable-art-error name))))
  this)

(defmethod apply-alignment ((this process-drawable) (options align-opts) (animation-root transformq) (motion-scale vector))
  "Apply the requested animation-root alignment to this drawable. Selected local velocity
   components are rebuilt from animation translation, per-axis scale, frame rate, and gravity; the
   rotation option postmultiplies and normalizes the root quaternion."
  (when (logtest? options (align-opts adjust-x-vel adjust-y-vel adjust-xz-vel))
    (let* ((body-T-world (quaternion->matrix (new 'stack-no-clear 'matrix) (-> this root quat)))
           (world-T-body (matrix-transpose! (new 'stack-no-clear 'matrix) body-T-world))
           (grav-rt-body (vector-matrix*! (new 'stack-no-clear 'vector) (-> *standard-dynamics* gravity) world-T-body))
           (vel-rt-body (vector-matrix*! (new 'stack-no-clear 'vector) (-> this root transv) world-T-body)))
      (if (logtest? options (align-opts no-gravity)) (set-vector! grav-rt-body 0.0 0.0 0.0 1.0))
      (when (logtest? options (align-opts adjust-x-vel))
        (set! (-> vel-rt-body x)
              (+ (* (-> animation-root trans x) (-> motion-scale x) (-> *display* frames-per-second))
                 (* (-> grav-rt-body x) (seconds-per-frame))))
        (if (not (logtest? options (align-opts adjust-xz-vel keep-other-velocities))) (set! (-> vel-rt-body z) 0.0)))
      (if (and (logtest? options (align-opts adjust-y-vel))
               (not (and (logtest? options (align-opts ignore-y-if-zero)) (= (-> animation-root trans y) 0.0))))
        (set! (-> vel-rt-body y)
              (+ (* (-> animation-root trans y) (-> motion-scale y) (-> *display* frames-per-second))
                 (* (-> grav-rt-body y) (seconds-per-frame)))))
      (when (logtest? options (align-opts adjust-xz-vel))
        (set! (-> vel-rt-body z)
              (+ (* (-> animation-root trans z) (-> motion-scale z) (-> *display* frames-per-second))
                 (* (-> grav-rt-body z) (seconds-per-frame))))
        (if (not (logtest? options (align-opts adjust-x-vel keep-other-velocities))) (set! (-> vel-rt-body x) 0.0)))
      (vector-matrix*! (-> this root transv) vel-rt-body body-T-world)))
  (if (logtest? options (align-opts adjust-quat))
    (quaternion-normalize! (quaternion*! (-> this root quat) (-> this root quat) (-> animation-root quat))))
  (the-as collide-shape (-> this root)))

(defbehavior ja-done? process-drawable ((channel-index int))
  "Return whether channel-index's seek has reached its requested frame; an empty controller is
   already done."
  (let ((channel (-> self skel root-channel channel-index)))
    (cond
      ((zero? (-> self skel active-channels)) #t)
      ((= (-> channel num-func) num-func-seek!) (= (-> channel frame-num) (-> channel param 0)))
      (else #t))))

(defbehavior ja-min? process-drawable ((channel-index int))
  "Return whether channel-index is at internal frame zero."
  (= (-> self skel root-channel channel-index frame-num) 0.0))

(defbehavior ja-max? process-drawable ((channel-index int))
  "Return whether channel-index has reached the final frame in its animation."
  (let ((channel (-> self skel root-channel channel-index)))
    (>= (-> channel frame-num) (the float (+ (-> channel frame-group data 0 length) -1)))))

(defbehavior ja-num-frames process-drawable ((channel-index int))
  "Return the highest valid internal frame number for channel-index."
  (+ (-> self skel root-channel channel-index frame-group data 0 length) -1))

(defbehavior ja-frame-num process-drawable ((channel-index int))
  "Return channel-index's current internal frame."
  (-> self skel root-channel channel-index frame-num))

(defbehavior ja-aframe-num process-drawable ((channel-index int))
  "Convert channel-index's current internal frame to the animation's artist-frame numbering."
  (let* ((channel (-> self skel root-channel channel-index))
         (animation (-> channel frame-group)))
    (+ (* (-> channel frame-num) (-> animation artist-step))
       (if (and animation (nonzero? animation)) (-> animation artist-base) 0.0))))

(defbehavior ja-aframe process-drawable ((artist-frame float) (channel-index int))
  "Convert artist-frame to the corresponding internal frame for channel-index."
  (let ((animation (-> self skel root-channel channel-index frame-group)))
    (/ (- artist-frame (if (and animation (nonzero? animation)) (-> animation artist-base) 0.0))
       (if animation (-> animation artist-step) 1.0))))

(defbehavior ja-speed process-drawable ((channel-index int))
  "Return channel-index's animation playback speed."
  (-> self skel root-channel channel-index frame-group speed))

(defbehavior ja-step process-drawable ((channel-index int))
  "Return the artist-frame step represented by one internal frame on channel-index."
  (-> self skel root-channel channel-index frame-group artist-step))

(defbehavior ja-channel-set! process-drawable ((channel-count int))
  "Replace the active joint-animation stack with channel-count initialized channels rooted at the
   start of the controller's channel array."
  (set! (-> self skel active-channels) channel-count)
  (set! (-> self skel root-channel) (-> self skel channel))
  (set! (-> self skel blend-index) -1)
  (set! (-> self skel root-channel 0 frame-group) #f)
  (dotimes (i channel-count)
    (set! (-> self skel root-channel i eval-time) (the-as uint (current-time)))
    (set! (-> self skel root-channel i group-sub-index) i)
    (set! (-> self skel root-channel i command) (if (zero? i) 'push 'blend))
    (set! (-> self skel root-channel i frame-interp) 0.0)
    (set! (-> self skel root-channel i frame-num) 0.0)
    (set! (-> self skel root-channel i frame-group) #f)
    (set! (-> self skel root-channel i num-func) num-func-none)
    (set! (-> self skel root-channel i group-size) channel-count))
  channel-count)

(defbehavior ja-channel-push! process-drawable ((channel-count int) (blend-time time-frame))
  "Push channel-count new root channels. When blend-time is nonzero, retain the current channels
   below them and append a blend-in channel; otherwise replace the active set."
  (cond
    ((or (zero? (-> self skel active-channels))
         (zero? blend-time)
         (when (>= (+ (-> self skel active-channels) channel-count) (-> self skel allocated-length))
           (format 0
                   "WARNING: ~A could not do (ja-channel-push ~D) because it has ~D/~D channels.~%"
                   self
                   channel-count
                   (-> self skel active-channels)
                   (-> self skel allocated-length))
           #t))
     (ja-channel-set! channel-count))
    (else
     (when (not (-> self skel root-channel 0 frame-group))
       (set! (-> self skel active-channels)
             (/ (&- (the-as pointer (-> self skel root-channel)) (the-as uint (the-as pointer (-> self skel channel)))) 48))
       (if (zero? (-> self skel active-channels)) (return (ja-channel-set! channel-count))))
     (set! (-> self skel root-channel)
           (the-as (inline-array joint-control-channel) (-> self skel channel (-> self skel active-channels))))
     (set! (-> self skel active-channels) (+ channel-count 1 (-> self skel active-channels)))
     (dotimes (i channel-count)
       (set! (-> self skel root-channel i eval-time) (the-as uint (current-time)))
       (set! (-> self skel root-channel i group-sub-index) i)
       (set! (-> self skel root-channel i command) (if (zero? i) 'push 'blend))
       (set! (-> self skel root-channel i frame-interp) 0.0)
       (set! (-> self skel root-channel i frame-num) 0.0)
       (set! (-> self skel root-channel i frame-group) #f)
       (set! (-> self skel root-channel i num-func) num-func-none)
       (set! (-> self skel root-channel i group-size) channel-count))
     (let ((blend-channel (-> self skel root-channel channel-count)))
       (set! (-> blend-channel eval-time) (the-as uint (current-time)))
       (set! (-> blend-channel group-sub-index) channel-count)
       (set! (-> self skel blend-index) (+ (-> self skel active-channels) -1))
       (set! (-> blend-channel frame-interp) 0.0)
       (set! (-> blend-channel frame-num) 0.0)
       (set! (-> blend-channel frame-group) #f)
       (set! (-> blend-channel group-size) channel-count)
       (set! (-> blend-channel param 0) (/ 5.0 (+ 5.0 (the float blend-time))))
       (set! (-> blend-channel num-func) num-func-blend-in!)
       (cond
         ((= channel-count 1) (set! (-> blend-channel command) 'stack1) (set! (-> self skel root-channel 0 command) 'push1))
         (else (set! (-> blend-channel command) 'stack))))
     channel-count)))

(defbehavior joint-control-reset! process-drawable ((controller joint-control) (channel joint-control-channel))
  "Remove the stack group containing channel from controller, repair push1 and root-channel state,
   compact both sides of the channel array, and reduce the active count."
  (let* ((group-start (the-as joint-control-channel (&- (the-as pointer channel) (the-as uint (* 48 (-> channel group-size))))))
         (group-start-index (/ (&- (the-as pointer group-start) (the-as uint (the-as pointer (-> controller channel)))) 48))
         (channel-sub-index (/ (&- (the-as pointer channel) (the-as uint group-start)) 48)))
    (when (> group-start-index 0)
      (if (= (-> group-start command) 'push1) (set! (-> group-start command) 'push))
      (if (= (-> controller root-channel) group-start)
        (set! (-> controller root-channel) (-> controller channel))
        (set! (-> controller root-channel)
              (the-as (inline-array joint-control-channel) (-> controller root-channel (- (+ group-start-index 1))))))
      (qmem-copy<-! (the-as pointer (-> controller channel))
                    (the-as pointer group-start)
                    (* 48 (- (-> controller active-channels) group-start-index)))
      (qmem-copy<-! (the-as pointer (-> controller channel channel-sub-index))
                    (the-as pointer (+ (the-as uint (-> controller channel 1)) (* 48 channel-sub-index)))
                    (* 48 (+ (- (- -1 group-start-index) channel-sub-index) (-> controller active-channels))))
      (set! (-> controller active-channels) (- (-> controller active-channels) (+ group-start-index 1)))))
  (none))

(defbehavior ja-group-size process-drawable ()
  "Return the number of channels in the current pushed root group, or zero when no pushed group is
   active."
  (if (< (the-as int (-> self skel root-channel)) (the-as int (-> self skel channel (-> self skel active-channels))))
    (-> self skel root-channel 0 group-size)
    0))

(defbehavior ja-eval process-drawable ()
  "Evaluate every active root channel that has not already been evaluated this frame, excluding
   stack commands."
  (let ((channel (-> self skel root-channel 0))
        (channel-end (-> self skel channel (-> self skel active-channels)))
        (evaluation-time (current-time)))
    (while (< (the-as int channel) (the-as int channel-end))
      (case (-> channel command)
        (('stack 'stack1))
        (else (if (!= (-> channel eval-time) evaluation-time) (joint-control-channel-eval channel))))
      (&+! channel 48)))
  0)

(defbehavior ja-blend-eval process-drawable ()
  "Evaluate channels below the current root group for blending, excluding stack commands and
   channels already evaluated this frame."
  (let ((root-channel (-> self skel root-channel))
        (channel (the-as joint-control-channel (-> self skel channel)))
        (evaluation-time (current-time)))
    (when (and (nonzero? (-> self skel active-channels)) (!= root-channel channel))
      (while (< (the-as int channel) (the-as int root-channel))
        (case (-> channel command)
          (('stack 'stack1))
          (else (if (!= (-> channel eval-time) evaluation-time) (joint-control-channel-eval channel))))
        (&+! channel 48))))
  0)

(defmethod evaluate-joint-control ((this process-drawable))
  "Evaluate active joint channels, restarting when evaluation changes the channel stack.
   Validate animation objects, clamp frame positions and blend weights, then update blend shapes,
   eyes, and effect control."
  (let ((joint-controller (-> this skel)))
    (label cfg-1)
    (let ((channel-count (-> joint-controller active-channels)))
      (b! (logtest? (-> this draw status) (draw-status hidden)) cfg-27 :delay (empty-form))
      (let ((i 0))
        (b! #t cfg-13 :delay (nop!))
        (label cfg-3)
        (let ((channel (-> joint-controller channel i)))
          (let ((command (-> channel command)))
            (b! (!= command 'stack) cfg-6 :delay (nop!))
            (joint-control-channel-eval channel)
            (b! (!= channel-count (-> joint-controller active-channels)) cfg-1 :delay (nop!))
            (b! #t cfg-12 :delay (nop!))
            (label cfg-6)
            (b! (!= command 'stack1) cfg-9 :delay (nop!)))
          (joint-control-channel-eval channel)
          (b! (!= channel-count (-> joint-controller active-channels)) cfg-1 :delay (nop!))
          (set! (-> joint-controller channel (+ i -1) frame-interp) (-> channel frame-interp))
          (b! #t cfg-12 :delay (nop!))
          (label cfg-9)
          (let ((animation (-> channel frame-group)))
            (let ((expected-animation-type art-joint-anim)) (b! (= (-> animation type) expected-animation-type) cfg-11))
            (go process-drawable-art-error "joint-anim")
            ;; enter-state returns normally on PC, so stop here rather than reading the invalid
            ;; animation. The EE abandons this temporary behavior thread through its return
            ;; trampoline, just as enter-state does for other temporary-thread transitions.
            (#when PC_PORT
              (format 0 "process-drawable::evaluate-joint-control bad for ~A~%" this)
              (break!)
              (nop!))
            (#unless PC_PORT
              (rlet ((return-target)) (m! return-target return-from-thread) (jr return-target :delay (nop!))))
            0
            (label cfg-11)
            (set! (-> channel frame-num) (fmax 0.0 (fmin (-> channel frame-num) (the float (+ (-> animation data 0 length) -1)))))))
        (label cfg-12)
        (+! i 1)
        (label cfg-13)
        (b! (< i channel-count) cfg-3))
      (dotimes (i channel-count)
        (set! (-> joint-controller channel i frame-interp) (fmax 0.0 (fmin 1.0 (-> joint-controller channel i frame-interp)))))
      (if (or (zero? channel-count) (not (-> joint-controller root-channel 0 frame-group)))
        (logior! (-> this draw status) (draw-status no-anim))))
    (if (logtest? (-> this skel status) (janim-status blerc blerc-done)) (merc-blend-shape this))
    (if (logtest? (-> this skel status) (janim-status eye-done eye)) (merc-eye-anim this))
    (label cfg-27)
    (let ((effects (-> joint-controller effect))) (if effects (update-effects effects))))
  0
  (none))

;; WARN: Function ja-post has a return type of none, but the expression builder found a return statement.
(defbehavior ja-post process-drawable ()
  "Finish this drawable's animation update. Evaluate joint control, build matrices immediately when
   required, otherwise queue the drawable for the matrix engine, and update collision transforms
   when a forced skeleton refresh completes."
  (when (nonzero? (-> self draw))
    (let ((force-update? (logtest? (-> self draw status) (draw-status no-skeleton-update))))
      (logclear! (-> self draw status) (draw-status no-anim no-skeleton-update))
      (when (nonzero? (-> self skel))
        (evaluate-joint-control self)
        (when (or (logtest? (-> self skel status) (janim-status inited)) force-update?)
          (do-joint-math! self)
          (if (and force-update? (type-type? (-> self root type) collide-shape))
            (update-transforms! (the-as collide-shape (-> self root))))
          (return #f))))
    ;; og:preserve-this added matrix-engine check for PC port
    (if (< (-> *matrix-engine* length) MATRIX_ENGINE_AMOUNT)
      (let ((matrix-engine *matrix-engine*))
        (set! (-> matrix-engine (-> matrix-engine length)) (process->handle self))
        (+! (-> matrix-engine length) 1))))
  0
  (none))

(defmethod current-cycle-distance ((this joint-control))
  "Fold the active root-channel push, blend, push1, and stack commands and return the resulting
   animation-cycle distance."
  (cond
    ((< (the-as int (-> this root-channel)) (the-as int (-> this channel (-> this active-channels))))
     (let ((channel-end (-> this root-channel (-> this root-channel 0 group-size)))
           (channel (the-as joint-control-channel (-> this root-channel)))
           (distance-stack (the-as (pointer float) (new 'stack-no-clear 'vector))))
       (while (< (the-as int channel) (the-as int channel-end))
         (case (-> channel command)
           (('push) (set! (-> distance-stack 0) (-> channel dist)) (set! distance-stack (&-> distance-stack 1)))
           (('blend 'push1) (set! (-> distance-stack -1) (lerp (-> distance-stack -1) (-> channel dist) (-> channel frame-interp))))
           (('stack)
            (set! (-> distance-stack -2) (lerp (-> distance-stack -2) (-> distance-stack -1) (-> channel frame-interp)))
            (set! distance-stack (&-> distance-stack -1))))
         (&+! channel 48))
       (-> distance-stack -1)))
    (else 0.0)))

(defbehavior anim-loop process-drawable ()
  "Put the drawable's behavior thread to sleep indefinitely while post processing continues."
  (logior! (-> self mask) (process-mask sleep-code))
  (loop
    (nop!)
    (suspend))
  (none))

(defbehavior transform-post process-drawable ()
  "Finish joint animation and update collision transforms."
  (ja-post)
  (update-transforms! (the-as collide-shape (-> self root)))
  0)

(defbehavior rider-trans process-drawable ()
  "Detect riders on this drawable's collision shape during the transition phase."
  (detect-riders! (the-as collide-shape (-> self root)))
  0)

(defbehavior rider-post process-drawable ()
  "Finish joint animation, update collision transforms, pull attached riders, and perform
   push-away resolution."
  (ja-post)
  (let ((root-shape (the-as collide-shape (-> self root))))
    (update-transforms! root-shape)
    (pull-riders! root-shape)
    (do-push-aways! root-shape))
  0)

(defbehavior pusher-post process-drawable ()
  "Finish joint animation, update collision transforms, and perform push-away resolution."
  (ja-post)
  (let ((root-shape (the-as collide-shape (-> self root)))) (update-transforms! root-shape) (do-push-aways! root-shape))
  0)

(defbehavior process-drawable-delay-player process-drawable ((delay time-frame))
  "Wait for safe player control, hold the target process through dialog and delay frames, then
   release it."
  (while (and *target*
              (logtest? (-> *target* control mod-surface flags) (surface-flags jump))
              (not (logtest? (-> *target* control status) (cshape-moving-flags onsurf))))
    (suspend))
  (set-time! (-> self state-time))
  (process-grab? *target*)
  (while (or (-> *setting-control* current talking)
             (-> *setting-control* current spooling)
             (-> *setting-control* current hint)
             (-> *setting-control* current ambient))
    (suspend))
  (while (not (time-elapsed? (-> self state-time) delay))
    (suspend))
  (process-release? *target*)
  (suspend)
  0)

(defbehavior process-drawable-fuel-cell-handler process-drawable ((sender process) (unused-param int) (event symbol) (message event-message-block))
  "Mark this drawable dead when a fuel-cell child sends a pickup notification."
  (case event
    (('notify)
     (case (-> message param 0)
       (('pickup) (if (type-type? (-> sender type) fuel-cell) (process-entity-status! self (entity-perm-status dead) #t)))))))

;; WARN: Found some very strange gotos. Check result carefully, this is not well tested.
(defbehavior process-drawable-birth-fuel-cell process-drawable ((source-entity entity) (position vector) (instant-collect? symbol))
  "Spawn the source entity's pending fuel-cell pickup at position, retrying until the child is
   created; instant-collect? selects immediate collection."
  (let ((spawn-entity source-entity)
        (spawn-position (new 'stack-no-clear 'vector)))
    (if (not spawn-entity) (set! spawn-entity (-> self entity)))
    (if position
      (vector-copy! spawn-position position)
      (vector-copy! spawn-position (-> spawn-entity extra trans)))
    (let ((task (-> spawn-entity extra perm task))
          (pickup-options (new 'static 'fact-info)))
      (set! (-> pickup-options options) (fact-options))
      (if instant-collect? (set! (-> pickup-options options) (fact-options instant-collect)))
      (when (and (nonzero? task) (not (task-complete? *game-info* task)))
        (label cfg-12)
        (birth-pickup-at-point spawn-position (pickup-type fuel-cell) (the float task) #f self pickup-options)
        (when (not (-> self child))
          (suspend)
          (goto cfg-12)))))
  0
  (none))

;; this part is debug only
(when *debug-segment*
  (define *valid-con* (new 'debug 'string #x4000 (the-as string #f))))

(defun-debug process-drawable-valid? ((owner-drawable process-drawable))
  "Validate drawable geometry and active joint channels, append diagnostics to *valid-con*, print
   the report on failure, and return whether every checked object is valid."
  (let ((all-valid? #t))
    (clear *valid-con*)
    (format *valid-con* "~%--- ~A -----------------------------~%" owner-drawable)
    (dotimes (i (-> owner-drawable node-list length))
      (let ((node (-> owner-drawable node-list data i)))
        (when (-> node geo)
          (cond
            ((valid? (-> node geo) drawable "cspace geo" #t *valid-con*))
            (else (format *valid-con* "ERROR: ~A has an invalid geo ~A~%" node (-> node geo)) (set! all-valid? #f))))))
    (let ((channel-count (-> owner-drawable skel active-channels)))
      (when (< (-> owner-drawable skel allocated-length) channel-count)
        (format *valid-con*
                "ERROR: ~~A has ~D joint channels, but only ~D are allowed~%"
                owner-drawable
                channel-count
                (-> owner-drawable skel allocated-length))
        (set! all-valid? #f))
      (dotimes (i channel-count)
        (let ((channel (-> owner-drawable skel channel i)))
          (case (-> channel command)
            (('stack 'stack1))
            (else
             (set! all-valid?
                   (cond
                     ((valid? (-> channel frame-group) art-joint-anim "joint-control frame-group" #t *valid-con*)
                      (when (not (and (>= (the int (-> channel frame-num)) 0)
                                      (< (the int (-> channel frame-num)) (-> channel frame-group data 0 length))))
                        (format *valid-con*
                                "ERROR: ~`joint-control-channel`P #~D has an invalid frame-num ~F/~D [0-~D]~%"
                                channel
                                i
                                (-> channel frame-num)
                                (the int (-> channel frame-num))
                                (+ (-> channel frame-group data 0 length) -1))
                        (set! all-valid? #f))
                      all-valid?)
                     (else
                      (format *valid-con*
                              "ERROR: ~`joint-control-channel`P #~D has an invalid frame-group ~A~%"
                              channel
                              i
                              (-> channel frame-group))
                      #f))))))))
    (when (not all-valid?)
      (format *valid-con* "--------------------------------~%~%")
      (format 0 "~S" *valid-con*))
    all-valid?))