From 23b4103f4e6d9b1e75770d6c90581b9cfce7f173 Mon Sep 17 00:00:00 2001 From: Yukari Hafner Date: Wed, 27 Nov 2024 11:32:02 +0100 Subject: [PATCH] Improve describe output for primitives and rigid shapes --- package.lisp | 1 + physics/primitives.lisp | 27 ++++++++++++++++++++------- physics/rigidbody.lisp | 11 +++++++++++ toolkit.lisp | 17 +++++++++++++++++ 4 files changed, 49 insertions(+), 7 deletions(-) diff --git a/package.lisp b/package.lisp index 56dc6342..e7533d93 100644 --- a/package.lisp +++ b/package.lisp @@ -383,6 +383,7 @@ #:define-support-function #:finish-hit #:collision-system-mask + #:collision-mask-systems #:collision-mask-p #:primitive #:primitive-entity diff --git a/physics/primitives.lisp b/physics/primitives.lisp index 87d2abab..518ccde0 100644 --- a/physics/primitives.lisp +++ b/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))) diff --git a/physics/rigidbody.lisp b/physics/rigidbody.lisp index ba8ab0bd..d9aa88e4 100644 --- a/physics/rigidbody.lisp +++ b/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)))) diff --git a/toolkit.lisp b/toolkit.lisp index f603783c..7cd9ffc2 100644 --- a/toolkit.lisp +++ b/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))))))