Improve describe output for primitives and rigid shapes

package.lisp

@@ -383,6 +383,7 @@
    #:define-support-function
    #:finish-hit
    #:collision-system-mask
+   #:collision-mask-systems
    #:collision-mask-p
    #:primitive
    #:primitive-entity

physics/primitives.lisp

@@ -115,7 +115,7 @@
                        do (reverse-hit hit))
                  nstart)))))))
 
-(defparameter *collision-system-indices*
+(define-global +collision-system-indices+
   (let ((arr (make-array 32 :initial-element ())))
     (dotimes (i 16 arr)
       (setf (aref arr i) (list (format NIL "system-~d" i))))))
@@ -137,12 +137,12 @@
     ((or string symbol)
      (let* ((name (normalize-collision-system-name system-ish))
             (pos (position-if (lambda (names) (find name names :test #'string=))
-                              *collision-system-indices*)))
+                              +collision-system-indices+)))
        (unless pos
-         (setf pos (or (position NIL *collision-system-indices*)
+         (setf pos (or (position NIL +collision-system-indices+)
                        (error "No more free system indices to allocate ~s!~%  ~s"
-                              name *collision-system-indices*)))
-         (push name (aref *collision-system-indices* pos)))
+                              name +collision-system-indices+)))
+         (push name (aref +collision-system-indices+ pos)))
        (ash 1 pos)))
     (sequence
      (let ((mask 0))
@@ -166,16 +166,21 @@
     ((or string symbol)
      (let* ((name (normalize-collision-system-name system-ish))
             (pos (position-if (lambda (names) (find name names :test #'string=))
-                              *collision-system-indices*)))
+                              +collision-system-indices+)))
        (if pos
            (unless (logbitp pos mask)
              (error "The collision system ~s is already assigned to mask~%  ~32,'0b!" system-ish (ash 1 pos)))
-           (push name (aref *collision-system-indices* (floor (log mask 2)))))
+           (push name (aref +collision-system-indices+ (floor (log mask 2)))))
        mask))
     (sequence
      (sequences:dosequence (system system-ish system-ish)
        (setf (collision-system-mask system) mask)))))
 
+(defun collision-mask-systems (mask)
+  (loop for i from 0 below (length +collision-system-indices+)
+        for systems = (aref +collision-system-indices+ i)
+        when (logbitp i mask) append systems))
+
 (declaim (inline collision-mask-p))
 (defun collision-mask-p (mask entity)
   (< 0 (logand (collision-system-mask mask) (collision-mask entity))))
@@ -192,6 +197,14 @@
 (defmethod print-object ((primitive primitive) stream)
   (print-unreadable-object (primitive stream :type T :identity T)))
 
+(defmethod describe-object :after ((primitive primitive) stream)
+  (format stream "~&~%Collision Systems:~{~%  ~a~}"
+          (collision-mask-systems (primitive-collision-mask primitive)))
+  (format stream "~&~%Local Transform:~%")
+  (write-transform (primitive-local-transform primitive) stream)
+  (format stream "~&~%Global Transform:~%")
+  (write-transform (primitive-transform primitive) stream))
+
 (define-transfer primitive primitive-material primitive-local-transform primitive-collision-mask
   (:eval (let ((target (primitive-global-bounds-cache target))
                (source (primitive-global-bounds-cache source)))

physics/rigidbody.lisp

@@ -9,6 +9,17 @@
 (defmethod shared-initialize :after ((body rigid-shape) slots &key physics-primitives)
   (when physics-primitives (setf (physics-primitives body) physics-primitives)))
 
+(defmethod describe-object :after ((shape rigid-shape) stream)
+  (format stream "~&~%Collision Systems:~{~%  ~a~}"
+          (collision-mask-systems (collision-mask shape)))
+  (format stream "~&~%Local Transform:~%")
+  (write-transform (tf shape) stream)
+  (format stream "~&~%Global Transform:~%")
+  (write-transform (global-transform-matrix shape) stream)
+  (format stream "~&~%Physics Primitives:")
+  (loop for primitive across (physics-primitives shape)
+        do (format stream "~%  ~a~{ ~a~}" primitive (collision-mask-systems (collision-mask primitive)))))
+
 (define-transfer rigid-shape
   (physics-primitives physics-primitives (lambda (p) (map-into (make-array (length p)) #'clone p))))
 

toolkit.lisp

@@ -1493,3 +1493,20 @@
       (if background
           (uiop:launch-program (list* program args) :input input :error-output *error-output*)
           (uiop:run-program (list* program args) :input input :output :string :error-output *error-output*)))))
+
+(defun write-transform (transform stream)
+  (etypecase transform
+    (*transform
+     (format stream "~
+Location: ~7,2@f, ~7,2@f, ~7,2@f
+Scaling:  ~7,2@f, ~7,2@f, ~7,2@f
+Rotation: ~7,2@f, ~7,2@f, ~7,2@f, ~7,2@f"
+             (vx (tlocation transform)) (vy (tlocation transform)) (vz (tlocation transform))
+             (vx (tscaling transform)) (vy (tscaling transform)) (vz (tscaling transform))
+             (qx (trotation transform)) (qy (trotation transform)) (qz (trotation transform)) (qw (trotation transform))))
+    (*mat4
+     (handler-case
+         (let ((tf (tfrom-mat transform)))
+           (write-transform tf stream))
+       (error ()
+         (write-matrix transform stream))))))