;;; -*- Mode: LISP; Syntax: Zetalisp; Base: 10; Package: (Boids :use scl :colon-mode :internal) -*- ;;; ========================================================================================= ;;; ;;; defontified 27oct94 -lgm ;;; ;;; Historical note by Craig Reynolds (written on 1-25-95): ;;; ;;; Version 1 of Boids was created shortly before SIGGRAPH 86 and was used to make ;;; some preliminary motion tests that were shown at the Advanced 3D Animation course ;;; at SIGGRAPH 86. Version 2 was created in the fall of 1986 for the production of ;;; "Breaking the Ice", which premiered at SIGGRAPH 87. It was also used for "Behave" ;;; so was modified in early 1988. (The file below is unmodified from those days ;;; except to remove Symbolics-specific font information.) Subsequent work on Boids ;;; was done by Andy Kopra (of VIFX) and was used as a starting point for the bat ;;; swarms he created in the feature films "Batman Returns" and "Cliffhanger". For ;;; more information see the SIGGRAPH 87 paper: ;;; ;;; Reynolds, C. W. (1987) "Flocks, Herds, and Schools: A Distributed Behavioral ;;; Model", in Computer Graphics, 21(4), pages 25-34. ;;; ;;; And on the World Wide Web, see: ;;; ;;; http://reality.sgi.com/employees/craig/boids.html ;;; ;;; ;;; ========================================================================================= ;;; ;;; Boid Brains (version 2) ;;; ;;; ========================================================================================= ;;; ;;; To do: ;;; ;;; Obstacle avoidance should have first priority in "acceleration allocation", but its ;;; overthruster strength factor should be reduced to something reasonable. ;;; ;;; Should "flockmate avoidance" be renamed "separation maintenance"? ;;; ;;; We may want to define some sort of protocol for obstacles along the lines of "quick ;;; estimate of minimum distance to object". This could be used to order the obstacles for ;;; "prioritized acceleration allocation" for the avoidance vectors. ;;; ;;; Optional speed enhancement: assuming that things run too slow to be practical (which ;;; seems likely) I may need to implement the space lattice partitioning hack to hold down ;;; the n^2 growth of the basic navigation algorithm. ;;; ;;; Maybe average-3d-vector-values and sum-3d-vector-values should be macros, for speed. ;;; ;;; ----------------------------------------------------------------------------------------- ;;; ;;; Maybe these should go in a "defs" file: (defmacro VLET* (bindings &body body) (vlet-parser bindings body :vector)) (eval-when (compile load eval) (defun VLET-PARSER (bindings body mode) (if (null bindings) `(progn ,@body) (let* ((clause (first bindings)) (items (if (listp clause) (length clause) 0))) (cond ((eql clause :vector) (vlet-parser (rest bindings) body :vector)) ((eql clause :scaler) (vlet-parser (rest bindings) body :scaler)) ((eql mode :scaler) `(let (,clause) ,(vlet-parser (rest bindings) body :scaler))) (t `(with-3d-vector-on-stack ,`(,(first clause) ,@(when (= items 3) `(,(second clause)))) ,(if (= items 3) (third clause) (second clause)) ,(vlet-parser (rest bindings) body :vector) ))))))) #| ;;; For example: (vlet* ((a (calculate-a)) :scaler (q (+ 2 4 8)) :vector (b (bx by bz) (calculate-b))) (the-body) (the-body)) |# (defmacro WITH-3D-VECTOR-ON-STACK ((vector-name &optional list-of-xyz-component-names) form-which-returns-three-values &body body) (let ((x-name (or (nth 0 list-of-xyz-component-names) (gensym))) (y-name (or (nth 1 list-of-xyz-component-names) (gensym))) (z-name (or (nth 2 list-of-xyz-component-names) (gensym)))) `(multiple-value-bind (,x-name ,y-name ,z-name) ,form-which-returns-three-values (with-stack-list (,vector-name ,x-name ,y-name ,z-name) ,@body)))) (defmacro TIME-IT (form-to-be-timed &optional describe-consing) `(progn (without-interrupts (cl:time nil)) (without-interrupts (cl:time ,form-to-be-timed ,describe-consing)))) (defmacro NIY () '(cerror "Proceed without any special action" "Not implemented yet.")) (defmacro MVL (form-which-returns-a-multiple-value) `(multiple-value-list ,form-which-returns-a-multiple-value)) (defmacro WITH-MESSAGES-ON-3D-LISTENER (&body body) `(let* ((*debug-io* *terminal-io*) (*terminal-io* (or (when 3d:camera (send 3d:camera :typeout-stream)) *terminal-io*))) ,@body)) ;;; (defun PRINT-MAG-XYZ (name x y z &optional (stream t) (start-on-new-line-p t)) ;;; (when start-on-new-line-p (format stream "~&")) ;;; (format stream "~35<~a: ~$ (~$ ~$ ~$)~;~>" name (magnitude-xyz x y z) x y z)) ;;; ;;; (defun PRINT-MAG-VECTOR (name vector &optional (stream t) (start-on-new-line-p t)) ;;; (multiple-value-bind (x y z) (3d:parse-triplet-from-value vector) ;;; (print-mag-xyz name x y z stream start-on-new-line-p))) (defun PRINT-VECTOR (string vector &optional (stream t) (start-on-new-line-p t)) (multiple-value-bind (x y z) (values-list vector) (when start-on-new-line-p (format stream "~&")) (format stream "~a ~3$ (~$ ~$ ~$)" string (magnitude vector) x y z))) '(setq dyna:*forms-to-eval-at-frame-start* `((let ((w ,zl:standard-output)) (format w "~&~3df " dyna:*current-frame-number*) (time:print-current-time w)))) ;;; ----------------------------------------------------------------------------------------- ;;; ;;; This object re-seeded each time :initialize-flock is called, to provide a repeatable ;;; sequence of random numbers for the initial flock randomization. If all other relevant ;;; parameters are held constant then all randomization will be identical each run. (defparameter *RESTARTABLE-RANDOM-NUMBER-GENERATOR-STATE* nil) (defun RESET-RESTARTABLE-RANDOM-NUMBER-GENERATOR-STATE (&optional (random-state (or *restartable-random-number-generator-state* (setq *restartable-random-number-generator-state* (make-random-state)))) (random-seed 281973564)) ;; "Bozo's Number" (cli::seed-random-state random-state random-seed) random-state) (defun RANDOM2 (limit-a limit-b &optional (random-state (or *restartable-random-number-generator-state* (reset-restartable-random-number-generator-state)))) (if (= limit-a limit-b) limit-a (if (< limit-a limit-b) (+ limit-a (cl:random (- limit-b limit-a) random-state)) (+ limit-b (cl:random (- limit-a limit-b) random-state))))) (defun RANDOM-DEVIATION (&optional (central-value 0) (randomization-magnitude 2)) (+ central-value (random2 0.0 randomization-magnitude) (* -0.5 randomization-magnitude))) ;;; ----------------------------------------------------------------------------------------- (defsubst FORCE-INTO-RANGE (number lower-bound upper-bound) "Ensures that a number lies between a lower and upper bound." (min (max number lower-bound) upper-bound)) (defsubst EXPT-NON-NEG (base-number power-number) "A variation on EXPT that truncates its first arg to be  0 to avoid complex results" (expt (max 0 base-number) power-number)) ;;; ----------------------------------------------------------------------------------------- (defparameter *PRINT* nil) (defparameter *DEFAULT-FLOCK* nil) (defun DEFAULT-FLOCK () *default-flock*) (defun DEFAULT-BOID (&optional (flock (default-flock))) (when flock (first (send flock :members)))) (defparameter *ENVIRONMENTAL-OBSTACLES* nil) ;;; ----------------------------------------------------------------------------------------- (defun FLIGHT-TEST (flying-object &optional (local-acceleration '(0 0 .05)) (repeat :forever)) (loop initially (send flying-object :set-speed 0) (send flying-object :initialize-transformation) (format t "~&Type any character to exit loop ...") for r from 0 by 1 until (or (send *standard-output* :tyi-no-hang) (neq repeat :forever) (eql r repeat)) do (send 3d:camera :redraw t) (send flying-object :fly :local-acceleration local-acceleration) finally (format t " ~d incremental :fly operations." r) (return r))) (defun FLOCK-TEST (flock &key (repeat :forever) (display-per-boid nil) (print *print*)) (flet ((redraw () (send 3d:camera :redraw t))) (loop with *print* = print initially (format t "~&Type any character to exit loop ...") for r from 0 until (or (send *standard-output* :tyi-no-hang) (neq repeat :forever) (eql r repeat)) do (unless display-per-boid (redraw)) (loop for b in (send flock :members) for i from 0 do (with-character-style ('(nil :condensed nil)) (when print (format t "~&F=~d B=~d: " r i)) (when display-per-boid (redraw)) (send b :pilot))) finally (format t " ~d incremental :pilot operations." r) (redraw) (return r)))) ;;; ----------------------------------------------------------------------------------------- (defmethod (:ALIGN-Y-TO-LOCAL 3D:OBJECT) (local-vector) ;; ;; Move the object's local center to the global center. Align the object's local Z with the global Z. ;; The target direction is already transformed into this space because the local and global spaces are ;; now coincident. The object is :align-y-to'ed to the target. Then the object is re-aligned and ;; re-moved back to its original state. ;; (unless (negligible-vector? local-vector :threshold 1.0e-15) (vlet* ((center (send self :global-center)) (heading (send self :global-heading))) (3d:alter-3d-matrix 3d:base-matrix :unmove center :align heading :align-y-to local-vector :unalign heading :move center)))) ;;; while this seemed like the right thing it was broken still: '(defmethod (:ALIGN-Y-TO-LOCAL 3D:OBJECT) (local-vector) (unless (negligible-vector? local-vector :threshold 1.0e-15) (vlet* ((global-vector (globalize-direction local-vector self))) (send self :align-y-to global-vector)))) '(defun TEST-ALIGN-Y-TO-LOCAL (object local-vector) (loop initially (send object :initialize-transformation) (send object :translate '(10 10 10)) (send 3d:camera :redraw-opaque t) do (send object :align-y-to-local local-vector) (send 3d:camera :redraw-opaque t) until (send cl:*terminal-io* :tyi-no-hang ))) 3d: '(defmethod (:ALIGN-Y-TO-LOCAL 3D:OBJECT) (local-vector) ;; ;; Move the object's local center to the global center. Align the object's local Z with ;; the global Z. The target direction is already transformed into this space because the ;; local and global spaces are now coincident. The object is :align-y-to'ed to the ;; target. Then the object is re-aligned and re-moved back to its original state. ;; (unless (boids::negligible-vector? local-vector :threshold 1.0e-15) (boids::with-3d-vector-on-stack (center (cx cy cz)) (send self :global-center) (boids::with-3d-vector-on-stack (heading (hx hy hz)) (send self :global-heading) (alter-3d-matrix base-matrix :unmove center :align heading :align-y-to local-vector :unalign heading :move center))))) ;;; ----------------------------------------------------------------------------------------- (defflavor FLIGHT-MIXIN ;; ;; Should gravity be an instance variable, or a global parameter? Is there any reason to want ;; to have it be different for each (species of) bird? Having be an active function allows it ;; to be anisotropic, allowing not only uniform gravity fields but also, for example, the field ;; around a gravitating point, like a planet (aka "boids in orbit"). It makes perfect sense to ;; limit this all to vertically aligned fields for now. Put a warning in :set-gravity. ;; ;; It might make sense in the short term to have a "floor" constraint associated with a ;; gravitational field. The relevant metric would be called :altitude. ;; ;; Damn! I knew this would happen. This flavor is already too big. Lets split off a gravity or ;; gravitation mixin. ;; (gravity speed min-speed max-speed max-accel-relative (last-accel-x nil) (last-accel-y nil) (last-accel-z nil) acceleration-smoothing roll-damping roll-resistance bank-exaggeration) () (:initable-instance-variables gravity speed min-speed max-speed max-accel-relative acceleration-smoothing roll-damping roll-resistance bank-exaggeration) (:gettable-instance-variables gravity speed min-speed max-speed max-accel-relative acceleration-smoothing roll-damping roll-resistance bank-exaggeration) (:settable-instance-variables gravity speed min-speed max-speed max-accel-relative acceleration-smoothing roll-damping roll-resistance bank-exaggeration) (:default-init-plist :gravity :global-default :speed 0 :min-speed 0 :max-speed 0.5 :max-accel-relative 0.2 :acceleration-smoothing 0.6 :roll-damping 0.5 :roll-resistance 0 :bank-exaggeration 1.0)) (defmethod (:LAST-ACCELERATION FLIGHT-MIXIN) (&optional (default '(0 0 0))) (if (and last-accel-x last-accel-y last-accel-z) (values last-accel-x last-accel-y last-accel-z) (values-list default))) (defmethod (:SET-LAST-ACCELERATION FLIGHT-MIXIN) (acceleration-vector) (setf (list last-accel-x last-accel-y last-accel-z) acceleration-vector)) (defmethod (:FLY FLIGHT-MIXIN) (&optional (requested-acceleration '(0 0 0))) ;; ;; Performs one incremental step of geometical flight. The object moves relatively from its current ;; position. It moves along its velocity vector as modified by the specified acceleration vector. ;; (vlet* ((adjusted-acceleration (truncate-magnitude requested-acceleration (send self :max-acceleration))) (last-acceleration (send self :last-acceleration adjusted-acceleration)) (smoothed-acceleration (interpolate-vectors (send self :acceleration-smoothing) adjusted-acceleration last-acceleration)) (old-velocity (values 0 0 (send self :speed))) (requested-velocity (3d-vector-add old-velocity smoothed-acceleration)) :scaler (intended-speed (magnitude requested-velocity)) (adjusted-speed (send self :set-speed intended-speed)) :vector (new-velocity (3d-vector-scale (if (< adjusted-speed intended-speed) (// adjusted-speed intended-speed) 1) requested-velocity))) ;; ;; This is the "intended acceleration", rather than the actual acceleration. Which is more ;; appropriate? Comparing next time's requested acceleration with this time's actual acceleration is ;; a little apples-and-oranges. ;; (send self :set-last-acceleration smoothed-acceleration) ;; ;; Steer the object from the old heading to the new one. Pitch and yaw are adjusted so that the ;; object is pointed along the direction of the new velocity. (Which ignores for simplicity the ;; possibility of "side slip".) Roll is adjusted to acount for "banking". ;; (send self :steer old-velocity new-velocity) ;; ;; Move forward along the new orientation according to the new speed. ;; (send self :forward adjusted-speed) ;; ;; Finally, if despite avoidance attempts the object is violating a constraint, force it to obey. ;; (send self :enforce-constraints))) (defmethod (:STEER FLIGHT-MIXIN) (old-velocity new-velocity) ;; ;; I'm not sure if the modularity would be better if this "steer to slide alongside constraints" stuff ;; should be here, or in :fly, or in a separate module called from :fly. With it here the model is that ;; steering is a semi-automatic operation that takes into account maneuvering around obstacles. ;; (vlet* ((new-adjusted-velocity (send self :constrain-steering new-velocity)) (new-adj-acceleration (3d-vector-sub new-adjusted-velocity old-velocity)) (actual-steering-acceleration (truncate-magnitude new-adj-acceleration (send self :max-acceleration))) (actual-new-velocity (3d-vector-add old-velocity actual-steering-acceleration)) ) (when (plusp (magnitude-squared actual-new-velocity)) ;; ;; PITCH and YAW the object (local X and Y rotations) to align with the new local velocity. ;; ;; (An interesting way to do the zero gravity case would be to replace the ;; align/roll with a roll/pitch. There would be no yaw adjustment necessary ;; because the roll would align the local y axis with the new local velocity.) ;; (send self :align-to-local actual-new-velocity) ;; ;; Adjust the roll for a "coordinated turn". ;; (send self :bank actual-steering-acceleration)))) (defmethod (:CONSTRAIN-STEERING FLIGHT-MIXIN) (new-velocity) ;; ;; I wonder if this would work better if we extended the "curb feeler" (aka velocity vector) further ;; than just one frame? We could be asking "if I continue to glide in this direct for N frames, will I ;; impact a constraint?". It would tend to cause somewhat smaller turns which happen somewhat earlier. ;; ;; We may want to do both, there is the issue of overshoot in cases when the "curb feeler" passes ;; through a portion of an obstacle. this can cause apparent "tunneling". I have moved a modified ;; copy of this body into the avoidance method for planar obstacles. ;; (declare (special *environmental-obstacles*)) (let ((new-speed-squared (magnitude-squared new-velocity))) (if (or (null *environmental-obstacles*) (zerop new-speed-squared)) (values-list new-velocity) (vlet* ((global-velocity-point (vx vy vz) (globalize-position new-velocity self)) (new-global-velocity-adjusted (loop with speed = (3d:fast-sqrt new-speed-squared) with modifications = nil with max-iterations = 3 for i from 1 to max-iterations do (loop for o in *environmental-obstacles* do (vlet* ((current (values vx vy vz)) (modified (mx my mz) (send o :enforce-position-constraints current))) (when (or mx my mz) (setq modifications t) (vlet* ((local-constrained-velocity (localize-position modified self)) (normalized-velocity (normalize local-constrained-velocity :error-for-zero-length nil)) (newer-v (3d-vector-scale speed normalized-velocity)) (gvp (gvx gvy gvz) (globalize-position newer-v self))) (ignore gvp global-velocity-point) (setq vx gvx vy gvy vz gvz))))) while modifications finally (return (values vx vy vz))))) (localize-position new-global-velocity-adjusted self))))) (defmethod (:BANK FLIGHT-MIXIN) (steering-acceleration) ;; ;; The basic idea to treat the object as a long pendulum extending in the local "down" (-Y) direction, ;; whose pivot point is the center of the object's local space. The centripetal acceleration will pull ;; the pendulum away from the axis of the turn. In the presence of gravity, the bank angle will be a ;; compromise between the centripetal direction and the global "down" of the gravitational field, based ;; on the vector sum of the centripetal and gravitational accelerations. Finally the desired bank ;; direction is "blended" with the current local up/down axis to give some damping of roll angle. ;; (let ((damping (send self :roll-damping)) (keel-weight (+ 1 (send self :roll-resistance))) (exaggeration (send self :bank-exaggeration))) (vlet* ((banking (3d-vector-scale exaggeration steering-acceleration)) (local-gravity (send self :local-gravity)) (local-anti-gravity (3d-vector-scale (- keel-weight) local-gravity)) (previous-banking (values 0 damping 0)) (total-acceleration (3d-vector-add banking local-anti-gravity previous-banking)) (new-local-up (project-onto-xy-plane total-acceleration))) '(when (eql self (default-boid)) (format w " s=~3$ g=~3$ d=~3$" (magnitude steering-acceleration) (magnitude local-anti-gravity) (magnitude previous-banking))) (without-floating-underflow-traps (send self :align-y-to-local new-local-up)) (values-list new-local-up)))) (defmethod (:ENFORCE-CONSTRAINTS FLIGHT-MIXIN) () (declare (special *environmental-obstacles*)) (loop for obstacle in *environmental-obstacles* do (send obstacle :enforce-position-constraints self))) (defmethod (:MAX-ACCELERATION FLIGHT-MIXIN) () (* (send self :max-accel-relative) (send self :max-speed))) (defwhopper (:SET-SPEED FLIGHT-MIXIN) (new-value) ;; ;; Force the speed of the object to lie between the pre-established ;; max and min speed limits. Returns the adjusted speed value. ;; (continue-whopper (force-into-range new-value (send self :min-speed) (send self :max-speed)))) (defmethod (:RELATIVE-SPEED FLIGHT-MIXIN) () (let ((maximum (send self :max-speed)) (current (send self :speed))) (if (zerop maximum) 0 (// current maximum)))) (defmethod (:LOCAL-VELOCITY FLIGHT-MIXIN) () (values 0 0 (send self :speed))) (defmethod (:GLOBAL-VELOCITY FLIGHT-MIXIN) () (with-3d-vector-on-stack (lv) (send self :local-velocity) (globalize-direction lv self))) (defmethod (:ALTITUDE FLIGHT-MIXIN) () (niy)) (defparameter *DEFAULT-GRAVITY* ;; Gravitational acceleration "g" -- in feet per frame per frame (let* ((frames-per-second 30) (feet-per-meter 3.280840) (g-in-meters-per-second-squared -9.806650) (frames-squared-per-second-squared (expt frames-per-second 2)) (g-in-feet-per-second-squared (* g-in-meters-per-second-squared feet-per-meter))) (// g-in-feet-per-second-squared frames-squared-per-second-squared))) (defwhopper (:GRAVITY FLIGHT-MIXIN) () ;; ;; Return the gravitational acceleration direction vector as an xyz multiple-value. A number is taken ;; to mean a downward pulling field. NIL (or 0) means no gravity. :GLOBAL-DEFAULT uses the variable. ;; (let* ((g0 (continue-whopper)) (g1 (if (null g0) 0 g0)) (g (if (eql g1 :global-default) *default-gravity* g1))) (if (numberp g) (values 0 g 0) (3d:parse-triplet-from-value g)))) (defmethod (:LOCAL-GRAVITY FLIGHT-MIXIN) () (vlet* ((global-gravity (send self :gravity))) (localize-direction global-gravity self))) (defmethod (:UPNESS FLIGHT-MIXIN) () ;; ;; Measures the relationship of the boid's heading relative to the global "gravitational up" direction. ;; Returns a number between -1 meaning "down" and +1 meaning "up". ;; (vlet* ((global-heading (send self :global-heading)) (gravitional-up (send self :gravitional-up))) (dot-product global-heading gravitional-up))) (defmethod (:GRAVITIONAL-UP FLIGHT-MIXIN) () ;; ;; Returns a unit vector in the "up" direction as defined relative to gravity. ;; (vlet* ((gravitational-acceleration (send self :gravity)) (anti-gravity (3d-vector-scale -1 gravitational-acceleration)) (gravitational-up (normalize anti-gravity :error-for-zero-length nil))) (values-list gravitational-up))) (defmethod (:CURVATURE FLIGHT-MIXIN) () ;; ;; Approximates the mathematical curvature of the flight path. Its is based on the ;; "requested-acceleration" history rather than on the actual "difference of headiongs". ;; (vlet* ((acceleration (send self :last-acceleration)) (radial-component (project-onto-xy-plane acceleration))) (magnitude radial-component))) (defmethod (:CURVENESS FLIGHT-MIXIN) () ;; ;; Computes "relative curvature": 0 means straight flight, 1 means maximum turning acceleration. ;; (let ((max-acc (send self :max-acceleration))) (if (zerop max-acc) 0 (// (send self :curvature) max-acc)))) (defmethod (:UP-SIDE-DOWN-NESS FLIGHT-MIXIN) () ;; ;; Measures the (anti)alignment of the boid's local "up" relative to the global "gravitational up". ;; Returns a number between +1 meaning "up side down" and -1 meaning "right side up". ;; (vlet* ((globalized-up (globalize-direction '(0 1 0) self)) (gravitional-up (send self :gravitional-up))) (- (dot-product globalized-up gravitional-up)))) ;;; ----------------------------------------------------------------------------------------- (defflavor FLYING-OBJECT () (flight-mixin 3d:object)) ;;; ----------------------------------------------------------------------------------------- (defflavor BOID-BRAIN ;; ;; ;; ((flockmate-avoidance-threshold 4) ;; 3) ;; 2.5) ;; 5) ;; 1.8) (flockmate-avoidance-exponent 2) ;; 3) ;; 2) (flockmate-avoidance-strength 1) (velocity-matching-threshold 5) ;; 3)) ;; be careful when changing this, it is very sensitive: (velocity-matching-strength 0.23) ;;0.2)) (neighborhood-centering-threshold 5) ;; 3)) (neighborhood-centering-strength 0.3) ;; 0.4) (migratory-urge-strength 0.3) ;; 0.35) (migratory-radialness 1) (anti-climb-strength 0.1) (anti-dive-strength 0) (steering-weights '(1.5 0.5 1.0)) (course-leveling-weights '(6.0 1.0 0.1)) ;; ;; I put a reset for these in :initialize-members there needs to be a better mechanism. ;; (global-target-point nil) (global-direction nil) ) () :initable-instance-variables :gettable-instance-variables :settable-instance-variables) (defmethod (:PILOT BOID-BRAIN) () ;; ;; Navigate a new course and calculate a corresponding acceleration. The boid wants to fly forward ;; along the current velocity, as modified by that acceleration. The flight simulator in :FLY may ;; have to modify the requested acceleration to suit the constraints it is bound by. ;; (without-floating-underflow-traps (vlet* ((requested-acceleration (send self :navigate))) (send self :fly requested-acceleration)))) '((defparameter *BOID-TO-METER* nil) (when (eq self *boid-to-meter*) (print-vector "avoid-obstacles: " avoid-obstacles w) (print-vector "avoid-flockmates: " avoid-flockmates w) (print-vector "velocity-matching:" velocity-matching w) (print-vector "centering-urge: " centering-urge w) (print-vector "migratory-urge: " migratory-urge w) (print-vector "course-damping: " course-damping w) (vlet* ((just-added (3d-vector-add avoid-obstacles avoid-flockmates velocity-matching centering-urge migratory-urge course-damping))) (print-vector "sum of accels: " just-added w))) (when (eq self *boid-to-meter*) (print-vector "acceleration: " desired-acceleration w) (format w "~&speed: ~3d" (send self :speed)))) (defmethod (:NAVIGATE BOID-BRAIN) () (vlet* ((avoid-obstacles (send self :environmental-obstacle-avoidance)) (avoid-flockmates (send self :flockmate-avoidance)) (velocity-matching (send self :velocity-matching)) (centering-urge (send self :neighborhood-centering)) (migratory-urge (send self :migratory-urge)) (course-leveling (send self :course-leveling)) (course-damping (send self :course-damping))) ;; ;; Available-acceleration should probably be 1.0, but I've set it a little higher to ;; avoid have to readjust the weighting factors for all of the acceleration requests. ;; (vlet* ((composite-acceleration (prioritized-acceleration-allocation 1.3 ;; 1.0 avoid-obstacles avoid-flockmates velocity-matching centering-urge migratory-urge course-leveling course-damping)) (weights (values-list (send self :steering-weights))) (desired-acceleration (componentwise-product weights composite-acceleration))) '(when (eql self (default-boid)) (format w " n")) (values-list desired-acceleration)))) (defun PRIORITIZED-ACCELERATION-ALLOCATION (available-acceleration &rest vectors) (loop with allocated-acceleration = 0 with (tx ty tz) = '(0 0 0) for v in vectors for (vx vy vz) = (or v '(0 0 0)) for mag-v = (magnitude v) for scaler = (if (> (+ allocated-acceleration mag-v) available-acceleration) (// (- available-acceleration allocated-acceleration) mag-v) 1) do (incf tx (* vx scaler)) (incf ty (* vy scaler)) (incf tz (* vz scaler)) (incf allocated-acceleration mag-v) ;; (format tow "~& (~d ~D ~d), ~d, ~d" tx ty tz allocated-acceleration mag-v) until (> allocated-acceleration available-acceleration) finally ;; (format t "~& mag= ~d" (magnitude-xyz tx ty tz)) ;; (format w "~&~D" allocated-acceleration) (return (values tx ty tz)))) (defmethod (:ENVIRONMENTAL-OBSTACLE-AVOIDANCE BOID-BRAIN) (&optional (obstacles *environmental-obstacles*)) (if (null obstacles) (values 0 0 0) (flet ((avoidance (obstacle) (send obstacle :avoidance-vector-for-flying-object self))) (vlet* ((sum (sum-3d-vector-values obstacles #'avoidance))) (truncate-magnitude sum))))) (defmethod (:FLOCKMATE-AVOIDANCE BOID-BRAIN) (&optional (flockmates (send self :nearby-flockmates))) (flet ((avoidance (flockmate) (send self :avoidance-for-flockmate flockmate))) (vlet* ((sum (sum-3d-vector-values flockmates #'avoidance))) (truncate-magnitude sum)))) (defmethod (:AVOIDANCE-FOR-FLOCKMATE BOID-BRAIN) (flockmate) (if (eq flockmate self) (values 0 0 0) (vlet* ((its-center (send flockmate :global-center)) (my-center (send self :global-center)) (seperation (3d-vector-sub my-center its-center)) :scaler (threshold (send self :flockmate-avoidance-threshold)) (exponent (send self :flockmate-avoidance-exponent)) (distance-squared (magnitude-squared seperation))) (if (> distance-squared (* threshold threshold)) (values 0 0 0) (vlet* ((local-seperation (localize-direction seperation self)) :scaler (distance (3d:fast-sqrt distance-squared)) (relative-distance (// distance threshold)) (repulsion (expt-non-neg (- 1 relative-distance) exponent)) (strength (send self :flockmate-avoidance-strength)) (factor (* strength (// repulsion distance)))) (if (zerop distance) (values 0 0 0) (3d-vector-scale factor local-seperation))))))) (defmethod (:VELOCITY-MATCHING BOID-BRAIN) () (vlet* ((target-global (send self :nearby-velocity)) (target-local (localize-direction target-global self)) (current-local (send self :local-velocity)) (difference (3d-vector-sub target-local current-local)) (trimmed-goal (truncate-magnitude difference))) ;; ;; This might want to be done in :choose-course. A value of 1.0 was very unstable, the ;; boids would just flutter around erratically, while a value of 0.1 had very little effect. A ;; value between 0.2 and 0.3 seems to do the right thing. It is interesting that the performance ;; is so non-linear. ;; (let ((strength (send self :velocity-matching-strength))) (3d-vector-scale strength trimmed-goal)))) (defmethod (:NEARBY-VELOCITY BOID-BRAIN) (&optional (objects (send self :nearby-flockmates))) ;; ;; Note this this currently uses uniform weighting. It should be center/forward weighted. ;; (let ((threshold (send self :velocity-matching-threshold))) (flet ((velocity (object) (send object :global-velocity)) (nearby-p (object) (send self :nearby-p object threshold))) (average-3d-vector-values objects #'velocity #'nearby-p)))) (defmethod (:NEIGHBORHOOD-CENTERING BOID-BRAIN) () (vlet* ((global-centering (send self :nearby-center-of-mass)) (local-centering (localize-position global-centering self)) (trimmed-centering (truncate-magnitude local-centering))) (3d-vector-scale (send self :neighborhood-centering-strength) trimmed-centering))) ;;; --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ;;; This hack is used by Sc-4-0 and Sc-4-1 of Breaking the Ice. (defparameter *FLOCK-CENTERING-STRENGTH-MULTIPLIER-FUNCTION* nil) (defmethod (:NEARBY-CENTER-OF-MASS BOID-BRAIN) (&optional (objects (send self :nearby-flockmates))) ;; ;; Note this this currently uses uniform weighting. It should be center/forward weighted. ;; (let ((threshold (send self :neighborhood-centering-threshold)) (function *flock-centering-strength-multiplier-function*)) (flet ((nearby-p (object) (send self :nearby-p object threshold))) (if (not function) (flet ((center (object) (send object :global-center))) (average-3d-vector-values objects #'center #'nearby-p)) (vlet* ((my-center (send self :global-center))) (flet ((center (object) (if (not function) (send object :global-center) (vlet* ((its-center (send object :global-center)) (offset (3d-vector-sub its-center my-center)) (scaled (3d-vector-scale (funcall function self object) offset))) (3d-vector-add scaled my-center))))) (average-3d-vector-values objects #'center #'nearby-p))))))) (defparameter *MIGRATORY-GLOBAL-DIRECTION* nil) (defparameter *MIGRATORY-GLOBAL-TARGET-POINT* nil) ;;; This hack is used by Sc-4-0 and Sc-4-1 of Breaking the Ice. (defparameter *MIGRATORY-GLOBAL-ANTI-TARGET-POINT* nil) (defmethod (:MIGRATORY-URGE BOID-BRAIN) () (let ((strength (send self :migratory-urge-strength)) (radialness (send self :migratory-radialness)) (direction (or (send self :global-direction) *migratory-global-direction*)) (target-point (or (send self :global-target-point) *migratory-global-target-point*)) (anti-target *migratory-global-anti-target-point*)) (vlet* ((local-direction (if direction (localize-direction direction self) (values 0 0 0))) (local-target-point (if target-point (localize-position target-point self) (values 0 0 0))) (local-anti-target (if anti-target (localize-position anti-target self) (values 0 0 0))) (anti-anti (3d-vector-scale -1 local-anti-target)) (combination (3d-vector-add local-target-point local-direction anti-anti)) (not-backwards (clip-negative-z-component-of-vector combination)) (blended (interpolate-vectors radialness combination not-backwards)) (normalized (normalize blended :error-for-zero-length nil))) (3d-vector-scale strength normalized)))) (defmethod (:COURSE-LEVELING BOID-BRAIN) () (let* ((upness (send self :upness)) (strength (if (> upness 0) (* (+ upness) (send self :anti-climb-strength)) (* (- upness) (send self :anti-dive-strength))))) (vlet* ((heading (send self :global-heading)) (downward (send self :gravity)) (level-heading (perpendicular-component heading downward)) (difference (3d-vector-sub level-heading heading)) (local-dif (localize-direction difference self)) (weights (values-list (send self :course-leveling-weights))) (local-weighted (componentwise-product weights local-dif)) (global-weighted (globalize-direction local-weighted self)) (trimmed (truncate-magnitude global-weighted)) (correction (3d-vector-scale strength trimmed))) '(when (eql self (default-boid)) '(vlet* ((ld (localize-direction global-weighted self))) (print-vector " " ld w nil)) (format w " cl")) (localize-direction correction self)))) (defmethod (:COURSE-DAMPING BOID-BRAIN) () ;; ;; the old version was a function of speed, sort of like momentum. ;; But that means that it has no effect at zero speed. ;; ;; In case this code gets reactivated there is now a :relative-speed message ;; '(let ((damping-strength 0.2)) ;; proto instance variable (let* ((max (send self :max-speed)) (relative-speed (if (zerop max) 0 (// (send self :speed) max)))) (values 0 0 (* damping-strength relative-speed)))) ;; ;; This version is just a constant and so still has effect at 0 speed, ;; but not much (I was hacking with this trying to animate the ;; camera-boid in "scene c" of "birds and fish"). ;; (let ((damping-strength 0.1)) ;; proto instance variable (values 0 0 damping-strength))) (defmethod (:NEARBY-FLOCKMATES BOID-BRAIN) () ;; ;; Temporary! ;; (send self :all-flockmates)) ;;; This hack is used by Sc-4-0 and Sc-4-1 of Breaking the Ice. (defparameter *DEFAULT-FLOCKMATES* nil) (defmethod (:ALL-FLOCKMATES BOID-BRAIN) () ;; ;; even more Temporary! ;; (or *default-flockmates* (send (send self :superior) :members))) (defmethod (:NEARBY-P BOID-BRAIN) (object threshold-distance) (< (with-3d-vector-on-stack (my-center) (send self :global-center) (with-3d-vector-on-stack (its-center) (send object :global-center) (with-3d-vector-on-stack (difference) (3d-vector-sub its-center my-center) (magnitude-squared difference)))) (* threshold-distance threshold-distance))) (defun FLOCKMATE-P (boid-0 boid-1) (eq (send boid-0 :superior) (send boid-1 :superior))) ;;; ----------------------------------------------------------------------------------------- (defflavor BOID-RECORDING-MIXIN () ()) (defmethod (:BOID-STATE-ARRAY-LENGTH BOID-RECORDING-MIXIN) () 12) (defmethod (:RECORD-STATE BOID-RECORDING-MIXIN) (boid-state-array) (let* ((matrix (send self :base-matrix)) (a (aref matrix 3)) (b (aref matrix 7)) (c (aref matrix 11)) (d (aref matrix 15))) ;; ;; Check the "homogeneous column" for the purely 3-space case: ;; (when (or ( a 0.0) ( b 0.0) ( c 0.0) ( d 1.0)) (error "/"homogeneous column/" of the boid's matrix is not equal to [0 0 0 1]:~@ [~d ~d ~d ~d]" a b c d)) ;; ;; Maybe this could be rewritten more compactly with the REPLACE function? ;; (setf (aref boid-state-array 0) (aref matrix 0)) (setf (aref boid-state-array 1) (aref matrix 1)) (setf (aref boid-state-array 2) (aref matrix 2)) (setf (aref boid-state-array 3) (aref matrix 4)) (setf (aref boid-state-array 4) (aref matrix 5)) (setf (aref boid-state-array 5) (aref matrix 6)) (setf (aref boid-state-array 6) (aref matrix 8)) (setf (aref boid-state-array 7) (aref matrix 9)) (setf (aref boid-state-array 8) (aref matrix 10)) (setf (aref boid-state-array 9) (aref matrix 12)) (setf (aref boid-state-array 10) (aref matrix 13)) (setf (aref boid-state-array 11) (aref matrix 14)))) (defmethod (:RESTORE-STATE BOID-RECORDING-MIXIN) (state-array) (send self :plug-transformation (aref state-array 0) (aref state-array 1) (aref state-array 2) 0.0 (aref state-array 3) (aref state-array 4) (aref state-array 5) 0.0 (aref state-array 6) (aref state-array 7) (aref state-array 8) 0.0 (aref state-array 9) (aref state-array 10) (aref state-array 11) 1.0)) ;;; ----------------------------------------------------------------------------------------- ;;; ;;; Moved from W:>Production>sigfilm>code>Birds-and-Fish.Lisp to here for reference. ;;; ;;; Currently this mixin is not part of the basic Boid flavor, it may want to be. (defflavor LOCOMOTION-CYCLE-MIXIN ((locomotion-cycle-phase) (locomotion-cycle-amplitude)) () :initable-instance-variables :settable-instance-variables :gettable-instance-variables (:required-methods :compute-locomotion-cycle-phase :compute-locomotion-cycle-amplitude)) (defmethod (:PILOT LOCOMOTION-CYCLE-MIXIN :AFTER) (&rest ignore) (send self :set-locomotion-cycle-phase (send self :compute-locomotion-cycle-phase)) (send self :set-locomotion-cycle-amplitude (send self :compute-locomotion-cycle-amplitude))) (defwhopper (:BOID-STATE-ARRAY-LENGTH LOCOMOTION-CYCLE-MIXIN) () (+ 2 (continue-whopper))) (defmethod (:RECORD-STATE LOCOMOTION-CYCLE-MIXIN :AFTER) (boid-state-array) ;; ;; This needs a way to say plug these values into the NEXT two slots of the recording array. Maybe the ;; stack consed list is the right thing, since its length would replace :BOID-STATE-ARRAY-LENGTH. ;; (setf (aref boid-state-array 12) (send self :locomotion-cycle-phase)) (setf (aref boid-state-array 13) (send self :locomotion-cycle-amplitude))) (defmethod (:RESTORE-STATE LOCOMOTION-CYCLE-MIXIN :AFTER) (boid-state-array) (send self :set-locomotion-cycle-phase (aref boid-state-array 12)) (send self :set-locomotion-cycle-amplitude (aref boid-state-array 13))) (defparameter *LOCOMOTION-CYCLE-AMPLITUDE* 1.0) (defun LOCOMOTION-CYCLE-FRAME-ACTION (default &key (amplitude *locomotion-cycle-amplitude*) (value dyna:*current-sequence-value*) (operation dyna:*current-sequence-motion-type*) (object dyna:*current-sequence-anim-object*)) (send object operation (dyna:interpolate amplitude default value))) (defun SETUP-LOCOMOTION-CYCLE-PHASES (flock) (loop for boid in (send flock :members) for phase from 0.0 by (// 1.0 (send flock :population)) do (send boid :set-locomotion-cycle-phase phase))) ;;; ----------------------------------------------------------------------------------------- ;;; ;;; Moved from W:>Production>sigfilm>code>Birds-and-Fish.Lisp to here for reference. ;;; ;;; Currently this mixin is not part of the basic Boid flavor, it may want to be. (defflavor SCRIPTED-ANIMATION-CYCLE-MIXIN ((animation-cycle-script)) () :initable-instance-variables :settable-instance-variables :gettable-instance-variables) (defmethod (:ANIMATE-GEOMETRICAL-MODEL SCRIPTED-ANIMATION-CYCLE-MIXIN) () ;; ;; Animate the instance of the model associated with the locomotion cycle script: ;; ;; (And of course *only-referenced-objects-visible* should be an arg not a global flag.) ;; (let ((script (send self :animation-cycle-script))) (when (dyna:script-p script) (let* ((phase (send self :locomotion-cycle-phase)) (runtime (send script :runtime)) (time (* runtime (if (= 0 phase) 1 phase))) (dyna:*only-referenced-objects-visible* nil) (*locomotion-cycle-amplitude* (send self :locomotion-cycle-amplitude))) ;; These should probably be bundled together by Dyna: (send script :animate-frame-init time) (send script :animate-frame time) ;; ;; Copy the newly animated pose of the script's model instance into the ;; animated subobject of this boid ;; (let ((instance-animated-by-script (send script :anim-object)) (animated-sub-instance (first (send self :body)))) (send instance-animated-by-script :make-invisible) (copy-pose-from-similar-instance instance-animated-by-script animated-sub-instance)))))) (defmethod (:COMPUTE-LOCOMOTION-CYCLE-PHASE SCRIPTED-ANIMATION-CYCLE-MIXIN) () (let ((script (send self :animation-cycle-script))) (when (dyna:script-p script) (let* ((fps (send script :fps)) (runtime (send script :runtime)) (increment (// (float (* fps runtime)))) (old-phase (send self :locomotion-cycle-phase)) (new-phase (mod (+ old-phase increment) 1.0))) new-phase)))) (defun WRAP-ANIMATING-SUBOBJECT (subobject subobject-name-string) (make-instance '3d:object :name subobject-name-string :body (list subobject))) (defun OBJECT-WITH-ANIMATING-SUBOBJECT-FROM-SCRIPT (script object-name-string) (let* ((object-from-script (send script :anim-object)) (instance-of-object-from-script (send object-from-script :copy-self))) (wrap-animating-subobject instance-of-object-from-script object-name-string))) (defun ANIMATE-GEOMETRICAL-MODELS-OF-FLOCK (flock) (let ((population (send flock :population))) (tv:noting-progress ((format nil "Animate geometrical models for ~a of ~d ~a" (send flock :flock-word) population (send flock :flock-member-name))) (loop for boid in (send flock :members) for count from 1 do (send boid :animate-geometrical-model) (tv:note-progress count population))))) ;;; ----------------------------------------------------------------------------------------- (defun COPY-POSE-FROM-SIMILAR-INSTANCE (instance-to-copy instance-to-modify &optional (max-levels-to-copy nil)) ;; ;; Given two 3d objects (which are presumed to be instances of the same hierarchy) make one be a copy ;; of the other by setting all of its transformation matrices to copies of the other's matrices. ;; (unless (typep instance-to-copy '3d:object) (error "instance-to-copy is not a 3d:object")) (unless (typep instance-to-modify '3d:object) (error "instance-to-modify is not a 3d:object")) ;; ;; Do the recursion first so that the two objects will have been checked for corresponding subobject ;; structure before modification is done (at each level). ;; (let ((inferiors-a (send instance-to-copy :body)) (inferiors-b (send instance-to-modify :body))) (cond ((and (numberp max-levels-to-copy) (zerop max-levels-to-copy)) ()) ((and (null inferiors-a) (null inferiors-b)) ()) ((and (typep inferiors-a '3d:body-display-item) (typep inferiors-b '3d:body-display-item)) ()) ((and (listp inferiors-a) (listp inferiors-b) (= (length inferiors-a) (length inferiors-b))) (loop with n = (when (numberp max-levels-to-copy) (1- max-levels-to-copy)) for a in inferiors-a for b in inferiors-b do (copy-pose-from-similar-instance a b n))) (t (error "the two objects specified do not correspond in subobject structure.~@ subobjects of instance-to-copy: ~s~@ subobjects of instance-to-modify: ~s" inferiors-a inferiors-b)))) ;; ;; If the subobjects were all OK, modify the top level object. ;; (send instance-to-modify :copy-transformation (send instance-to-copy :base-matrix))) ;;; ----------------------------------------------------------------------------------------- ;;; ;;; Moved from W:>Production>sigfilm>code>Birds-and-Fish.Lisp to here for reference. (defflavor STOP-AND-START-MIXIN (fastest-max-speed slowest-max-speed stop-and-start-damping stop-and-start-phase stop-and-start-phase-increment slow-fraction-of-cycle) () :initable-instance-variables :settable-instance-variables :gettable-instance-variables (:default-init-plist :stop-and-start-phase (random2 0.0 1.0) :stop-and-start-damping 0.2)) (defmethod (:PILOT STOP-AND-START-MIXIN :BEFORE) (&rest ignore) (let ((new-phase (+ (send self :stop-and-start-phase) (send self :stop-and-start-phase-increment)))) (send self :set-stop-and-start-phase (mod (if ( new-phase 1) (send self :end-of-start-stop-cycle new-phase) new-phase) 1)) (send self :set-max-speed (dyna:interpolate (send self :stop-and-start-damping) (if (< (send self :stop-and-start-phase) (send self :slow-fraction-of-cycle)) (send self :slowest-max-speed) (send self :fastest-max-speed)) (send self :max-speed))))) (defmethod (:END-OF-START-STOP-CYCLE STOP-AND-START-MIXIN) (new-phase) ;; ;; this hook is to allow restarting with new cycle parameters, but the default is just to ;; keep cycling at teh same rate. ;; new-phase) ;;; ----------------------------------------------------------------------------------------- (defflavor BOID () (boid-brain boid-recording-mixin flying-object)) (compile-flavor-methods boid) ;;; ----------------------------------------------------------------------------------------- (defflavor FLOCK-MIXIN (;; ;; This represents the species of the flock ;; member-template ;; ;; ;; (flock-word) ;; ;; can be one of :playback, :record or :record-to-file ;; (flock-recording-mode :playback) (flock-recording-array)) () :initable-instance-variables :gettable-instance-variables :settable-instance-variables (:default-init-plist :member-template (default-boid-template))) (defwhopper (:FLOCK-WORD FLOCK-MIXIN) () (or (continue-whopper) (send self :set-flock-word (flock-word-from-species (send self :member-template))))) (defmethod (:POPULATION FLOCK-MIXIN) () (length (send self :members))) (defmethod (:SET-POPULATION FLOCK-MIXIN) (new-population) (assert ( new-population 0) (new-population) "population cannot be negative") (tv:noting-progress ((format nil "Set ~a population to ~d." (send self :flock-word) new-population)) (let ((current-population (send self :population))) (if ( new-population current-population) (send self :add-subobjects (loop repeat (- new-population current-population) for p from current-population with template = (send self :member-template) collecting (make-boid-instance :template template) do (tv:note-progress p new-population)))) (loop repeat (- current-population new-population) for p downfrom current-population do (send self :remove-subobject (first (send self :members))) (tv:note-progress p current-population)))) new-population) (defmethod (:INITIALIZE-MEMBERS FLOCK-MIXIN) ;; ;; (see note at corresponding macro below) ;; (&key (init t) ; Does it make sense to ever say :init nil ? (move '(0 0 0)) (randomize-radius-min 0) (randomize-radius-max 0) (randomize-radius-x-stretch 1) (randomize-radius-y-stretch 1) (randomize-radius-z-stretch 1) ;; what I really had in mind was more of a aim-at, perhaps this is outside the scope of ;; this function. (align-to '(0 0 1)) ; This default prevents using existing orientations. (randomize-yaw-min 0) (randomize-yaw-max 0) (randomize-pitch-min 0) (randomize-pitch-max 0) (randomize-roll-min 0) (randomize-roll-max 0) ;; (randomize-speed-min 0) (randomize-speed-max 0) (randomize-min-speed-min 0) (randomize-min-speed-max 0) (randomize-max-speed-min 0) (randomize-max-speed-max 0) ;; (last-acceleration nil) ;; (global-target-point nil) (global-direction nil) ;; (age-random-sequence 0) ) (reset-restartable-random-number-generator-state) (loop repeat age-random-sequence do (random2 0.0 1.0)) (let ((population (send self :population)) (name-string (send self :flock-member-name))) (tv:noting-progress ((format nil "Initialize flock of ~d ~a" population name-string)) (when init (send self :initialize-transformation)) (loop for boid in (send self :members) for count from 1 do (when init (send boid :initialize-transformation)) (send boid :set-last-acceleration last-acceleration) (if (and ( randomize-radius-max 0) (< (// randomize-radius-min randomize-radius-max) 0.5)) ;; ;; solid sphere case ;; (loop with (x y z) do (multiple-value-bind (a b c) (random-position-inside-radius-1-sphere) (setq x a y b z c)) for radius = (* (magnitude-xyz x y z) randomize-radius-max) until (< randomize-radius-min radius randomize-radius-max) finally (send boid :translate move) (send boid :move (* x randomize-radius-x-stretch randomize-radius-max) (* y randomize-radius-y-stretch randomize-radius-max) (* z randomize-radius-z-stretch randomize-radius-max))) ;; ;; hollow sphere case ;; (multiple-value-bind (x y z) (random-3d-unit-vector) (let ((random-radius (random2 randomize-radius-min randomize-radius-max))) (send boid :translate move) (send boid :move (* x randomize-radius-x-stretch random-radius) (* y randomize-radius-y-stretch random-radius) (* z randomize-radius-z-stretch random-radius))))) (flet ((send-random (set-msg min max) (send boid set-msg (random2 (float min) (float max))))) (progn (send boid :align-to align-to) (send-random :yaw randomize-yaw-min randomize-yaw-max) (send-random :pitch randomize-pitch-min randomize-pitch-max) (send-random :roll randomize-roll-min randomize-roll-max)) (progn (send-random :set-speed randomize-speed-min randomize-speed-max) (send-random :set-min-speed randomize-min-speed-min randomize-min-speed-max) (send-random :set-max-speed randomize-max-speed-min randomize-max-speed-max))) (progn (send boid :set-global-target-point global-target-point) (send boid :set-global-direction global-direction)) (tv:note-progress count population))))) ;;; This fake arglist is copied from the method above, be sure to update this if that changes. (defmacro INITIALIZE-FLOCK (flock &rest keyword-args-for-initialize-members &environment env) (declare (arglist flock &key (init t) (move '(0 0 0)) (randomize-radius-min 0) (randomize-radius-max 0) (randomize-radius-x-stretch 1) (randomize-radius-y-stretch 1) (randomize-radius-z-stretch 1) (align-to '(0 0 1)) (randomize-yaw-min 0) (randomize-yaw-max 0) (randomize-pitch-min 0) (randomize-pitch-max 0) (randomize-roll-min 0) (randomize-roll-max 0) ;; (randomize-speed-min 0) (randomize-speed-max 0) (randomize-min-speed-min 0) (randomize-min-speed-max 0) (randomize-max-speed-min 0) (randomize-max-speed-max 0) ;; (last-acceleration nil) ;; (global-target-point nil) (global-direction nil) ;; (age-random-sequence 0) )) (once-only (flock &environment env) `(unless (null ,flock) (send ,flock :initialize-members ,@keyword-args-for-initialize-members)))) (defun RERANDOMIZE-PORTION-OF-FLOCK (&key (init t) (flock *default-flock*) (portion-of-flock 0.1) (randomize-radius-max 0) (centerpoint-triplet '(0 0 0)) (randomize-radius-x-stretch 1) (randomize-radius-y-stretch 1) (randomize-radius-z-stretch 1)) (loop repeat (round (* portion-of-flock (send flock :population))) for boid in (send flock :members) do (when init (send boid :initialize-transformation)) (loop with (x y z) do (multiple-value-bind (a b c) (random-position-inside-radius-1-sphere) (setq x a y b z c)) for radius = (* (magnitude-xyz x y z) randomize-radius-max) until (< radius randomize-radius-max) finally (send boid :translate centerpoint-triplet) (send boid :move (* x randomize-radius-x-stretch randomize-radius-max) (* y randomize-radius-y-stretch randomize-radius-max) (* z randomize-radius-z-stretch randomize-radius-max))))) (defmethod (:CENTER FLOCK-MIXIN) () (flet ((global-center (boid) (send boid :global-center))) (average-3d-vector-values (send self :members) #'global-center))) (defmethod (:AVERAGE-VELOCITY FLOCK-MIXIN) () (flet ((velocity (boid) (send boid :global-velocity))) (average-3d-vector-values (send self :members) #'velocity))) (defmethod (:AVERAGE-RADIUS FLOCK-MIXIN) () (vlet* ((flock-center (send self :center))) (loop for boid in (send self :members) for count from 1.0 for radius = (vlet* ((boid-center (send boid :global-center))) (distance boid-center flock-center)) summing radius into total finally (return (// total count))))) (defmethod (:MEMBERS FLOCK-MIXIN) () (send self :body)) (defmethod (:FLOCK-MEMBER-NAME FLOCK-MIXIN) (&optional (flock-or-member-template (send self :member-template)) (population (send self :population))) (flock-member-name flock-or-member-template population)) ;;; I'm not real fond of these two message names: (defmethod (:PILOT-MEMBERS FLOCK-MIXIN) () (let ((population (send self :population)) (frames (ignore-errors (send (send dyna:*current-sequence* :script) :runtime-in-frames)))) (tv:noting-progress ((format nil "Animate ~a of ~d ~a (frame ~d of ~d (~d%))." (send self :flock-word) population (send self :flock-member-name) dyna:*current-frame-number* frames (round (* 100.0 (// dyna:*current-frame-number* frames))))) (loop for count from 1 for boid-index from 0 for boid in (send self :members) with frame-index = (1- dyna:*current-frame-number*) do (send self :pilot-member boid boid-index frame-index) (tv:note-progress count population) finally (when (eq :record-to-file (send self :flock-recording-mode)) (send self :save-one-frame-of-flock-recording frame-index)))))) (defmethod (:PILOT-MEMBER FLOCK-MIXIN) (boid boid-index frame-number) (select (send self :flock-recording-mode) ((:record :record-to-file) (send boid :pilot) (send self :record-boid-state boid boid-index frame-number)) (:playback (send self :restore-boid-state boid boid-index frame-number)) (t (error "bogus flock-recording-mode of ~s" (send self :flock-recording-mode))))) (defun PILOT-FLOCK (&optional (flock (default-flock))) ;; ;; For use from S-Dynamics scripts: ;; (when flock (send flock :pilot-members) (send flock :make-visible))) (defparameter *DEFAULT-FLOCK-RECORDING-LENGTH* 300) (defmethod (:SETUP-FOR-RECORDING FLOCK-MIXIN) () (let* ((associated-script (ignore-errors (send dyna:*current-sequence* :script))) (frame-count (ignore-errors (send associated-script :runtime-in-frames)))) (if (null (send self :flock-recording-array)) (if (eq :playback (send self :flock-recording-mode)) (send self :restore-flock-recording) (send self :set-flock-recording-array (make-array (or frame-count *default-flock-recording-length*)))) (when (and frame-count (> frame-count (length (send self :flock-recording-array)))) (format (if 3d:camera (send 3d:camera :typeout-stream) t) "~&Growing frame-per-flock array from ~d to ~d." (length (send self :flock-recording-array)) frame-count) (send self :set-flock-recording-array (adjust-array (send self :flock-recording-array) frame-count)))) (send self :flock-recording-array))) (defmethod (:SETUP-FOR-RECORDING-ONE-FRAME FLOCK-MIXIN) (frame-number) (let* ((frame-per-flock-array (send self :setup-for-recording)) (boid-per-frame-array (aref frame-per-flock-array frame-number)) (population (send self :population))) (if (null boid-per-frame-array) (setf (aref frame-per-flock-array frame-number) (make-array population)) (when (> population (length boid-per-frame-array)) (format (if 3d:camera (send 3d:camera :typeout-stream) t) "~&Growing boids-per-frame array from ~d to ~d." (length boid-per-frame-array) population) (setf (aref frame-per-flock-array frame-number) (adjust-array (aref frame-per-flock-array frame-number) population)))) (aref frame-per-flock-array frame-number))) (defmethod (:SETUP-FOR-RECORDING-ONE-BOID-STATE FLOCK-MIXIN) (boid boid-index frame-number) (let* ((boid-per-frame-array (send self :setup-for-recording-one-frame frame-number)) (boid-state-array (aref boid-per-frame-array boid-index))) (when (null boid-state-array) (setf (aref boid-per-frame-array boid-index) (make-array (send boid :boid-state-array-length)))) (aref boid-per-frame-array boid-index))) (defmethod (:RECORD-BOID-STATE FLOCK-MIXIN) (boid boid-index frame-number) (let ((boid-state-array (send self :setup-for-recording-one-boid-state boid boid-index frame-number))) (send boid :record-state boid-state-array))) (defmethod (:RESTORE-BOID-STATE FLOCK-MIXIN) (boid boid-index frame-number) (let* ((frame-per-flock-array (send self :setup-for-recording)) (boid-per-frame-array (aref frame-per-flock-array frame-number))) (when (null boid-per-frame-array) ;; ;; If it gets here this is really an error in the New Way -- either the whole recording should be ;; there or none at all. ;; (send self :restore-one-frame-of-flock-recording frame-number)) (let* ((boid-per-frame-array (aref frame-per-flock-array frame-number)) (state-array (aref boid-per-frame-array boid-index))) (send boid :restore-state state-array)))) ;;; this is about to become obsolete (cwr 3-23-87) ;;; (defparameter *RESTORED-FLOCK-FRAME-RECORDING* nil) ;;; this is about to become obsolete (cwr 3-23-87) ;;; (defmethod (:SAVE-ONE-FRAME-OF-FLOCK-RECORDING FLOCK-MIXIN) (frame-number) ;; ;; First check to see if the data to be dumped really exists. ;; (let ((population (send self :population)) (frame-per-flock-array (send self :setup-for-recording))) (when (null frame-per-flock-array) (error "flock has no recording to save.")) (let ((boid-per-frame-array (aref frame-per-flock-array frame-number))) (when (null boid-per-frame-array) (error "flock has no recording of frame ~d to save." frame-number)) (let ((first-missing (loop for i from 0 below population do (when (null (aref boid-per-frame-array i)) (return i))))) (when first-missing (error "flock has no recording of boid ~d at frame ~d to save." first-missing frame-number))) ;; ;; Now check for the existance of the >script-name-Flock-Data> subdirectory. ;; ;; this is all duplicated in :save- and :restore-, make it a subroutine ;; (let ((script (ignore-errors (send dyna:*current-sequence* :script)))) (when (null script) (error "can't find an associated script from which to default pathname.")) (let* ((script-name (send script :name)) (subdir-name (format nil "~a-Flock-Data" script-name)) (script-pathname (send script :pathname)) (script-dir-list (send script-pathname :raw-directory)) (subdir-pathname (send script-pathname :new-raw-directory (append script-dir-list (list subdir-name)))) (versioned-pathname (send subdir-pathname :new-version :newest)) (typed-pathname (send versioned-pathname :new-canonical-type :bin)) (species-name (string-capitalize-words (flock-member-name self population))) (name (format nil "~a-~3,vd" species-name "0" (1+ frame-number))) (pathname (send typed-pathname :new-raw-name name))) ;; ;; do it ;; (sys:dump-forms-to-file pathname `((setq *restored-flock-frame-recording* ,boid-per-frame-array)))))))) ;;; this is about to become obsolete (cwr 3-23-87) ;;; (defmethod (:RESTORE-ONE-FRAME-OF-FLOCK-RECORDING FLOCK-MIXIN) (frame-number) (let* ((frame-per-flock-array (send self :setup-for-recording))) (when (not (null (aref frame-per-flock-array frame-number))) (cerror "proceed by overwriting the existing recording" "a recording already exists for this flock at frame ~d" frame-number)) ;; ;; Now check for the existance of the >script-name-Flock-Data> subdirectory. ;; ;; this is all duplicated in :save- and :restore-, make it a subroutine ;; (let ((script (ignore-errors (send dyna:*current-sequence* :script)))) (when (null script) (error "can't find an associated script from which to default pathname.")) (let* ((script-name (send script :name)) (subdir-name (format nil "~a-Flock-Data" script-name)) (script-pathname (send script :pathname)) (script-dir-list (send script-pathname :raw-directory)) (subdir-pathname (send script-pathname :new-raw-directory (append script-dir-list (list subdir-name)))) (versioned-pathname (send subdir-pathname :new-version :newest)) (typed-pathname (send versioned-pathname :new-canonical-type :bin)) (species-name (string-capitalize-words (flock-member-name self 2))) (name (format nil "~a-~3,vd" species-name "0" (1+ frame-number))) (pathname (send typed-pathname :new-raw-name name))) ;; ;; do it ;; ;; The with-open-file doing a ":probe :error :if-does-not-exist" is to work around ;; the fact that (load pathname :if-does-not-exist :error) does not work in 7.0, this ;; was reported to BUG-LISPM. ;; (let ((*restored-flock-frame-recording*)) (with-open-file (stream pathname :direction :probe :if-does-not-exist :error)) (format (if (not (null 3d:camera)) (send 3d:camera :typeout-stream) t) "~&Reading ~a flock data for frame ~d." species-name (1+ frame-number)) (load pathname :verbose nil) (setf (aref frame-per-flock-array frame-number) *restored-flock-frame-recording*)))))) (defun SAVE-FLOCK-RECORDINGS (&optional list-o-flocks (script (send (dyna:find-script-editor) :script)) (query-p t)) (when (not (null list-o-flocks)) (format t "~2&Saving flock data for script: ~a" (send script :name)) (loop for flock in list-o-flocks do (format t "~& ~a" (send flock :name)) finally (format t "~2%")) (loop for flock in (loop for flock in list-o-flocks when (or (null query-p) (y-or-n-p "~&Save /"~a/" recording~& to ~a? " (send flock :name) (send flock :flock-data-pathname script))) collect flock finally (format t "~%")) for pathname = (send flock :flock-data-pathname script) do (format t "~&Saving /"~a/" recording~& to ~a..." (send flock :name) pathname) (send flock :save-flock-recording pathname) (format t " done.")))) (defparameter *RESTORED-FLOCK-RECORDING* nil) (defmethod (:SAVE-FLOCK-RECORDING FLOCK-MIXIN) (&optional (pathname (send self :flock-data-pathname))) ;; ;; First check to see if the data to be dumped really exists. ;; (let ((frame-per-flock-array (send self :setup-for-recording))) (when (null frame-per-flock-array) (error "flock has no recording to save.")) ;; ;; Dump a form which, when loaded, sets *restored-flock-recording* to a recreation of the flock ;; recording array. ;; (sys:dump-forms-to-file pathname `((setq *restored-flock-recording* ,frame-per-flock-array))))) (defmethod (:RESTORE-FLOCK-RECORDING FLOCK-MIXIN) (&optional (pathname (send self :flock-data-pathname))) ;; ;; The with-open-file doing a ":probe :error :if-does-not-exist" is to work around ;; the fact that (load pathname :if-does-not-exist :error) does not work in 7.0, this ;; was reported to BUG-LISPM. ;; (with-messages-on-3d-listener (let ((*restored-flock-recording*)) (with-open-file (stream pathname :direction :probe :if-does-not-exist :error)) (format t "~&Reading ~a ~d data." (string-capitalize (flock-member-name self)) (string-capitalize (send self :flock-word))) (load pathname :verbose nil) (send self :set-flock-recording-array *restored-flock-recording*)))) (defmethod (:FLOCK-DATA-PATHNAME FLOCK-MIXIN) (&optional (script (ignore-errors (send dyna:*current-sequence* :script)))) '(assert (dyna:script-p script) (script) "can't find an associated script from which to default pathname.") (when (null script) (error "can't find an associated script from which to default pathname.")) (let* ((script-name (send script :name)) (script-pathname (send script :pathname)) (species-name (string-capitalize (flock-member-name self))) (flock-name (string-capitalize (send self :flock-word))) (name (format nil "~a-~a-~a-Data" script-name species-name flock-name)) (renamed-pathname (send script-pathname :new-raw-name name)) (typed-pathname (send renamed-pathname :new-canonical-type :bin)) (pathname (send typed-pathname :new-version :newest))) pathname)) ;;; ----------------------------------------------------------------------------------------- (defflavor FLOCK () (flock-mixin 3d:object)) (compile-flavor-methods flock) ;;; ----------------------------------------------------------------------------------------- ;;; ;;; Boid and flock creation utilities (defun READIN-INVISIBLE-OBJECT (object-pathname) (let ((object (3d:readin-object object-pathname))) (send object :make-invisible) object)) (defparameter *DEFAULT-BOID-TEMPLATE* nil) (defun DEFAULT-BOID-TEMPLATE () (or *default-boid-template* (setq *default-boid-template* (change-instance-flavor (send (readin-invisible-object "W:>cwr>Boids>Very-low-res-boid") :copy-self) 'boid)))) (defun MAKE-BOID-INSTANCE (&key (template (default-boid-template))) (send template :copy-self)) (defparameter *DEFAULT-FLOCK-POPULATION* 44) (defun FLOCK-MEMBER-NAME (flock-or-member-template &optional (population 1)) ;; ;; This DWIM is a little sloppy, if we happened to have a multi-level structure of flocks, where each ;; memeber of the main flock was itself a flock of sub-things, this OR would probably not do what we ;; want. Whatever that is. ;; (let* ((species-template (or (send-if-handles flock-or-member-template :member-template) flock-or-member-template)) (species-name-string (format nil "~(~a~)" (type-of species-template)))) (if (= 1 population) species-name-string (string-pluralize species-name-string)))) (defun FLOCK-WORD-FROM-SPECIES (species-name-string-or-template) (loop with species-name-string = (if (stringp species-name-string-or-template) species-name-string-or-template (flock-member-name species-name-string-or-template)) for (individual-name group-name) in '(("bee" "swarm") ("toad" "knot") ("bird" "flock") ("lion" "pride") ("angel" "host") ("fish" "school") ("geese" "gaggle") ("locust" "plague") ("owl" "parliament") ("lark" "exaltation")) when (string-equal individual-name species-name-string) do (return group-name) finally (return "flock"))) (defun MAKE-FLOCK (&key (menu t) (population *default-flock-population*) (name :create-descriptive-name) (template (default-boid-template)) (flock-word (flock-word-from-species template)) (flock-recording-mode :playback) (add-object-to-view t) (make-visible nil)) (with-messages-on-3d-listener (let ((name-specified (neq name :create-descriptive-name))) (flet ((default-name () (format nil "~a-of-~d-~a" flock-word population (flock-member-name template population)))) (flet ((after-choice (window variable old-value new-value) (ignore window variable old-value new-value) (select variable (((locf population)) (unless name-specified (setq name (default-name))) (send window :refresh) t) (((locf name)) (setq name-specified t) nil)))) (when (eq name :create-descriptive-name) (setq name (default-name))) (catch 'abort-edit (when menu (tv:choose-variable-values `((,(locf population) " population" :number) (,(locf name) " name" :string-or-nil) (,(locf template) " template" :eval-form) (,(locf flock-recording-mode) " flock recording mode" :assoc ((" Playback " . :playback) (" Record " . :record) (" Record to file " . :record-to-file) )) (,(locf add-object-to-view) " (3D:Add-Object-To-View...)?" :boolean)) :label `(:string ,(format nil "choose values for new ~a of ~a:" flock-word (flock-member-name template population)) :font fonts:cptfontcb) :margin-choices `(,(format nil "make ~a" flock-word) ("abort" (throw 'abort-edit nil))) :function #'after-choice)) (format t "~&Creating /"~a/"." name) (reset-restartable-random-number-generator-state) (let ((flock (make-instance 'flock :name name :flock-word flock-word :member-template template :flock-recording-mode flock-recording-mode))) (send flock :set-population population) (if make-visible (send flock :make-visible) (send flock :make-invisible)) (when add-object-to-view (3d:add-object-to-view flock)) flock))))))) (defun NO-MENU-WARNING (menu-p) (unless menu-p (with-character-style ('(nil :bold nil)) (format t "~&*** menus are turned off ***")))) (defun FIND-FLOCK (&key (menu t) (ok-to-reuse-flocks t) (population *default-flock-population*) (flock *default-flock*) (template (default-boid-template)) (flock-word (flock-word-from-species template))) (with-messages-on-3d-listener (unless menu (with-character-style ('(nil :bold nil)) (format t "~&*** menus are turned off ***"))) (let* ((other-flocks (when ok-to-reuse-flocks (loop for f in (list-of-known-flocks) when (neq f flock) when (flock-of-same-species-p f template) collect (cons (send f :name) f)))) (previous (when ok-to-reuse-flocks (when (not (null flock)) (when (flock-of-same-species-p flock template) (when (3d:viewable-p flock) flock))))) (label `(:font fonts:cptfontcb :string ,(format nil " select ~a of ~a " flock-word (flock-member-name template 2)))) (default-item) (items `(("" :no-select "") (,(format nil " create new ~a " flock-word) :eval (make-flock :population ,population :template ,template :menu ,menu :flock-word ,flock-word) :documentation " Create a new flock, hence preserving the previous one. ") ,@(when previous `(("" :no-select "") ("previous:" :no-select "") ,(setq default-item (cons (send flock :name) flock)))) ,@(when other-flocks `(("" :no-select "") ("others:" :no-select ""))) ,@other-flocks ("" :no-select ""))) (new-flock (if menu (tv:menu-choose items label '(:mouse) default-item) (or (when ok-to-reuse-flocks (loop for f in (cons flock (list-of-known-flocks)) when (flock-of-same-species-p f template) when (= population (send f :population)) do (return f))) (make-flock :population population :template template :menu menu :flock-word flock-word))))) (when new-flock (setq *default-flock* new-flock))))) (defun FLOCK-RECORDING-MODE-MENU (&optional (flocks (list-of-known-flocks))) (let* ((modes (loop for flock in flocks collect (send flock :flock-recording-mode))) (name-length (loop for flock in flocks maximize (string-length (send flock :name)))) (menu-list (loop for m on modes for flock in flocks collect (list (locf (car m)) (format nil " ~v<~v~a~~>" name-length (if (eql flock (default-flock)) '(:fix :bold :normal) '(:fix :roman :normal)) (send flock :name)) :assoc '((" Playback " . :playback) (" Record " . :record) (" Record to file " . :record-to-file)))))) (catch 'abort-edit (tv:choose-variable-values menu-list :label "Choose flock recording mode:" :margin-choices `("set modes" ("abort" (throw 'abort-edit nil)))) (loop for mode in modes for flock in flocks do (setf (send flock :flock-recording-mode) mode))))) (defun LIST-OF-KNOWN-FLOCKS () (loop for o in 3d:*global-object-list* when (typep o 'flock) collect o)) (defun FLOCK-OF-SAME-SPECIES-P (flock template) (when flock (typep (send flock :member-template) (type-of template)))) (defun REPLACE-ALL-BOIDS (&optional (flocks (list-of-known-flocks))) ;; ;; It would be better if this used a copy protocol, rather than replacing them with new default boids. ;; (loop for f in flocks for p = (send f :population) do (format t "~&~a ..." (send f :name)) (send f :set-population 0) (send f :set-population p) (format t " ~d boids replaced.~&" p))) ;;; ----------------------------------------------------------------------------------------- ;;; ;;; Boid hackers macros. These came from Breaking the Ice (and Behave) (defmacro LOOP-FOR-BOIDS-IN-FLOCK ((boid-iteration-variable flock) &body body) `(loop for ,boid-iteration-variable in (send ,flock :members) do ,@body)) (defmacro WITH-TEMPORARY-MIGRATORY-URGE-STRENGTH-MULTIPLIER ((temporary-multiplier flock) &body body &environment env) (let ((boid (make-symbol "BOID"))) (once-only (temporary-multiplier flock &environment env) `(let ((.old-migratory-urge-strength. (send (default-boid ,flock) :migratory-urge-strength))) (unwind-protect (progn (loop-for-boids-in-flock (,boid ,flock) (send ,boid :set-migratory-urge-strength (* .old-migratory-urge-strength. ,temporary-multiplier))) ,@body) (loop-for-boids-in-flock (,boid ,flock) (send ,boid :set-migratory-urge-strength .old-migratory-urge-strength.))))))) (defmacro WITH-TEMPORARY-MAX-ACCEL-RELATIVE-MULTIPLIER ((temporary-multiplier flock) &body body &environment env) (let ((boid (make-symbol "BOID"))) (once-only (temporary-multiplier flock &environment env) `(let ((.old-max-accel-relative. (send (default-boid ,flock) :max-accel-relative))) (unwind-protect (progn (loop-for-boids-in-flock (,boid ,flock) (send ,boid :set-max-accel-relative (* .old-max-accel-relative. ,temporary-multiplier))) ,@body) (loop-for-boids-in-flock (,boid ,flock) (send ,boid :set-max-accel-relative .old-max-accel-relative.))))))) (defmacro WITH-TEMPORARY-MAX-SPEED-MULTIPLIER ((temporary-multiplier flock) &body body &environment env) (let ((boid (make-symbol "BOID"))) (once-only (temporary-multiplier flock &environment env) `(let ((.old-max-speed. (send (default-boid ,flock) :max-speed))) (unwind-protect (progn (loop-for-boids-in-flock (,boid ,flock) (send ,boid :set-max-speed (* .old-max-speed. ,temporary-multiplier))) ,@body) (loop-for-boids-in-flock (,boid ,flock) (send ,boid :set-max-speed .old-max-speed.))))))) ;;; ----------------------------------------------------------------------------------------- ;;; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- (defmacro WITH-TEMPORARY-FLOCKMATE-AVOIDANCE-STRENGTH ((new-avoidance flock) &body body &environment env) (let ((boid (make-symbol "BOID"))) (once-only (new-avoidance flock &environment env) `(let ((.old-flockmate-avoidance-strength. (send (default-boid ,flock) :flockmate-avoidance-strength))) (unwind-protect (progn (loop-for-boids-in-flock (,boid ,flock) (send ,boid :set-flockmate-avoidance-strength ,new-avoidance)) ,@body) (loop-for-boids-in-flock (,boid ,flock) (send ,boid :set-flockmate-avoidance-strength .old-flockmate-avoidance-strength.))))))) (defmacro WITH-TEMPORARY-VELOCITY-MATCHING-STRENGTH ((new-matching flock) &body body &environment env) (let ((boid (make-symbol "BOID"))) (once-only (new-matching flock &environment env) `(let ((.old-velocity-matching-strength. (send (default-boid ,flock) :velocity-matching-strength))) (unwind-protect (progn (loop-for-boids-in-flock (,boid ,flock) (send ,boid :set-velocity-matching-strength ,new-matching)) ,@body) (loop-for-boids-in-flock (,boid ,flock) (send ,boid :set-velocity-matching-strength .old-velocity-matching-strength.))))))) (defmacro WITH-TEMPORARY-FAST-SLOW-SPEED ((new-slowest new-fastest flock) &body body &environment env) (let ((boid (make-symbol "BOID"))) (once-only (new-slowest new-fastest flock &environment env) `(let ((.old-slow-speed. (send (default-boid ,flock) :slowest-max-speed)) (.old-fast-speed. (send (default-boid ,flock) :fastest-max-speed))) (unwind-protect (progn (loop-for-boids-in-flock (,boid ,flock) (send ,boid :set-slowest-max-speed ,new-slowest) (send ,boid :set-fastest-max-speed ,new-fastest)) ,@body) (loop-for-boids-in-flock (,boid ,flock) (send ,boid :set-slowest-max-speed .old-slow-speed.) (send ,boid :set-fastest-max-speed .old-fast-speed.))))))) (defmacro WITH-TEMPORARY-MIGRATORY-URGE-STRENGTH ((new-migratory-urge flock) &body body &environment env) (let ((boid (make-symbol "BOID"))) (once-only (new-migratory-urge flock &environment env) `(let ((.old-migratory-urge-strength. (send (default-boid ,flock) :migratory-urge-strength))) (unwind-protect (progn (loop-for-boids-in-flock (,boid ,flock) (send ,boid :set-migratory-urge-strength ,new-migratory-urge)) ,@body) (loop-for-boids-in-flock (,boid ,flock) (send ,boid :set-migratory-urge-strength .old-migratory-urge-strength.))))))) ;;; ----------------------------------------------------------------------------------------- ;;; ;;; Obstacle Objects ;;; ;;; Probably they want to be known on a per-boid basis, but for now, lets assume we have a ;;; global list: *environmental-obstacles*. ;;; ;;; This flavorization is just a first pass. It may want to be remodularized later. (defflavor OBSTACLE ((inside-p nil)) () (:initable-instance-variables inside-p) (:gettable-instance-variables inside-p) (:settable-instance-variables inside-p)) ;;; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- (defflavor SPHERICAL-OBSTACLE ((center '(0 0 0)) (radius 1)) (obstacle) (:initable-instance-variables center radius) (:gettable-instance-variables center radius) (:settable-instance-variables center radius)) (defmethod (:ENFORCE-POSITION-CONSTRAINTS SPHERICAL-OBSTACLE) (vector-or-object) ;; ;; Find the sphere-center to object-center vector. ;; Compare its manitude-squared to the radius-squared. ;; If inside/outside constraint is violated: truncate vector and set position. ;; (let* ((c (send self :center)) (r (send self :radius)) (r 2 (* r r))) (with-3d-vector-on-stack (position) (if (typep vector-or-object '3d:object) (send vector-or-object :global-center) (values-list vector-or-object)) (with-3d-vector-on-stack (displacement) (3d-vector-sub position c) (let* ((d 2 (magnitude-squared displacement))) (when (or (and (> d 2 r 2) (send self :inside-p)) (and (> r 2 d 2) (not (send self :inside-p)))) (with-3d-vector-on-stack (constrained-displacement) (3d-vector-scale (// r (3d:fast-sqrt d 2)) displacement) (with-3d-vector-on-stack (constrained-position) (3d-vector-add c constrained-displacement) (when (typep vector-or-object '3d:object) (send vector-or-object :translate-to constrained-position)) (values-list constrained-position))))))))) (defmethod (:AVOIDANCE-VECTOR-FOR-FLYING-OBJECT SPHERICAL-OBSTACLE) (flying-object) ;; ;; Avoids contact with the inside surface of the specified sphere by a lateral acceleration on the side ;; which faces the center of the sphere. Currently this assumes that the boid is already inside and ;; that we intend to do inside avoidance. The math for the outside case is almost identical. ;; (unless (send self :inside-p) (error "only inside-sphere case is supported now.")) (multiple-value-bind (cx cy cz) (localize-position (send self :center) flying-object) (let* ((r (localize-scaler-distance (send self :radius) flying-object)) (s-squared (- (* r r) (* cx cx) (* cy cy)))) ;; ;; The path of the boid (its local z axis) intersects the sphere in at most two places. If it ;; does not intersect at all, the boid must be outside, and in no danger of collision, this is ;; indicated by a negative "s-squared" (hence imaginary roots). If "s-squared" is positive there ;; will be two intersections at "A" (0,0,cz+s) and "B" (0,0,cz-s) in local space. Those two ;; points will be coincident if the intersection is exactly on the terminator of the sphere ;; (corresponding to s=0). ;; (if (minusp s-squared) (values 0 0 0) (let* ((s (3d:fast-sqrt s-squared)) (az (+ cz s)) (bz (- cz s))) ;; ;; If Az and Bz are both positive the boid is outside the sphere and on a collision course. ;; If Az and Bz are both negative the boid is outside but the sphere is behind. If Az is ;; positive and Bz is negative then the boid is inside and hence on a collision course. ;; (if (and (minusp az) (minusp bz)) (values 0 0 0) (if (and (plusp az) (plusp bz)) (values 0 0 0) ;; outside-ahead case, fill in later (let* ((threshold (min r (* 15 (send flying-object :speed)))) (relative-distance (if (zerop threshold) 1 (force-into-range (// az threshold) 0 1))) (weighting (* 3.5 (expt-non-neg (- 1 relative-distance) 2.5)))) (with-3d-vector-on-stack (radial) (values cx cy 0) (with-3d-vector-on-stack (unit-radial) (if (negligible-vector? radial) (values 1 0 0) (normalize radial)) (3d-vector-scale weighting unit-radial))))))))))) (compile-flavor-methods spherical-obstacle) ;;; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- (defflavor CYLINDRICAL-OBSTACLE ;; ;; If this were based on 3d:object, we could assume (for example) that the cylinder is centered ;; at (0,0,0) and is aligned with the local Y axis. Then the defining parameters would be simply ;; RADIUS and HEIGHT. Since the obstacle is free to move, the global endpoint positions should ;; probably be computed dynamically (based on RADIUS, HEIGHT and the local coordinate system). ;; ((endpoint-0 '(0 -2 0)) (endpoint-1 '(0 +2 0)) (radius 1)) (obstacle) (:initable-instance-variables endpoint-0 endpoint-1 radius) (:gettable-instance-variables endpoint-0 endpoint-1 radius) (:settable-instance-variables endpoint-0 endpoint-1 radius)) (defmethod (:ENFORCE-POSITION-CONSTRAINTS CYLINDRICAL-OBSTACLE) (vector-or-object) ;; ;; This has been designed to be able to quickly reject points that are well away from the cylinder. ;; (when (send self :inside-p) (error "inside-cylinder case not implemented yet")) (vlet* ((object-center (if (typep vector-or-object '3d:object) (send vector-or-object :global-center) (values-list vector-or-object))) :scaler (axis-coordinate (send self :project-point-onto-parametric-axis object-center))) (when (< 0 axis-coordinate 1) (vlet* ((axis-point (send self :point-on-axis-from-parameter axis-coordinate)) (axis-to-object-offset (3d-vector-sub object-center axis-point)) :scaler (distance-squared-to-axis (magnitude-squared axis-to-object-offset)) (radius-squared (* radius radius))) (when (< distance-squared-to-axis radius-squared) (let ((distance-squared-to-ep0 (distance-squared endpoint-0 object-center)) (distance-squared-to-ep1 (distance-squared endpoint-1 object-center))) (vlet* ((new-position (cond ((< distance-squared-to-ep0 radius-squared) (3d-vector-add endpoint-0 axis-to-object-offset)) ((< distance-squared-to-ep1 radius-squared) (3d-vector-add endpoint-1 axis-to-object-offset)) (t (let ((distance-to-axis (3d:fast-sqrt distance-squared-to-axis))) (if (zerop distance-to-axis) (values-list endpoint-0) (vlet* ((constrained-offset (3d-vector-scale (// radius distance-to-axis) axis-to-object-offset))) (3d-vector-add axis-point constrained-offset)))))))) (when (typep vector-or-object '3d:object) (send vector-or-object :translate-to new-position)) (values-list new-position)))))))) (defmethod (:AVOIDANCE-VECTOR-FOR-FLYING-OBJECT CYLINDRICAL-OBSTACLE) (flying-object) (when (send self :inside-p) (error "inside-cylinder case not implemented yet")) (catch 'end-on-case (vlet* ((local-ep0 (x0 y0 z0) (localize-position endpoint-0 flying-object)) (local-ep1 (x1 y1 z1) (localize-position endpoint-1 flying-object)) :scaler (local-radius (localize-scaler-distance radius flying-object)) (local-radius 2 (* local-radius local-radius)) ;; ;; Project the axis line of the cylinder onto the local XY plane. The equation of the projected ;; line is Ax+By+C=0 and the "radial perpendicular" which passes through the local origin and is ;; perpendicular to the projected axis has the equation Bx-Ay=0. The intersection of these two ;; lines is the projection of the point on the cylindrical axis closest to the local Z axis. The z ;; coordinate of this axis point is obtained by ratios (similar triangles). ;; (A (- y1 y0)) (B (- x0 x1)) (C (- (* x1 y0) (* x0 y1))) x y z (ignore (cond ((and (zerop A) (zerop B)) (throw 'end-on-case (values 0 0 0))) ((zerop A) (setq x 0 y (- (// C B)) z (dyna:remap-interval y y0 y1 z0 z1))) ((zerop B) (setq x (- (// C A)) y 0 z (dyna:remap-interval x x0 x1 z0 z1))) (t (setq y (// (- C) (+ (// (* A A) B) B)) x (* y (// A B)) z (dyna:remap-interval x x0 x1 z0 z1))))) :vector (radial-direction (values x y 0)) :scaler (radial-distance (magnitude radial-direction)) (cylinder-length (distance local-ep0 local-ep1)) (radius-on-axis (// local-radius cylinder-length)) (axis-coordinate (with-3d-vector-on-stack (approximate-axis-point) (values x y (- z local-radius)) (send self :project-point-onto-parametric-axis approximate-axis-point local-ep0 local-ep1))) (cylinder-ahead (and (or ( z0 0) ( z1 0)) (> local-radius radial-distance) (< 0 axis-coordinate 1))) (ep0-ahead (and ( z0 0) (< (magnitude-squared-xyz x0 y0 0) local-radius 2))) (ep1-ahead (and ( z1 0) (< (magnitude-squared-xyz x1 y1 0) local-radius 2)))) ;; (format w "~&~3A ~3A ~3A" cylinder-ahead ep0-ahead ep1-ahead) (flet ((paramaxis-point (param) (send self :point-on-axis-from-parameter param local-ep0 local-ep1))) (if (not (or cylinder-ahead ep0-ahead ep1-ahead)) (values 0 0 0) (vlet* ((endpoint-direction (cond (ep0-ahead (paramaxis-point (- radius-on-axis))) (ep1-ahead (paramaxis-point (+ 1 radius-on-axis))) (t (values 0 0 0)))) (steering-direction (3d-vector-sub endpoint-direction radial-direction)) (radial-steering-direction (project-onto-xy-plane steering-direction)) (trimmed-steering-direction (truncate-magnitude radial-steering-direction)) :scaler ;; proto instance variables below: ;; (avoidance-strength 5) ;; cwr 2-19-87 (avoidance-strength 10.0) (dead-aheadness (expt-non-neg (- 1 (// radial-distance local-radius)) .7)) (fastness (* 5 (send flying-object :speed))) (closeness (// (expt-non-neg (// (magnitude-xyz x y z) local-radius) 3.5))) (scaler (* avoidance-strength dead-aheadness fastness closeness))) (when nil ;; t ;; (eq flying-object (default-boid)) (format w "~&~3d ~f~20t~f~35t~f" dyna:*current-frame-number* dead-aheadness closeness (* scaler (magnitude trimmed-steering-direction)))) (3d-vector-scale scaler trimmed-steering-direction))))))) (defmethod (:PROJECT-POINT-ONTO-PARAMETRIC-AXIS CYLINDRICAL-OBSTACLE) (point &optional (ep0 (send self :endpoint-0)) (ep1 (send self :endpoint-1))) (with-3d-vector-on-stack (point-offset-from-ep0) (3d-vector-sub point ep0) (with-3d-vector-on-stack (axis-basis) (3d-vector-sub ep1 ep0) ;; ;; This should probabaly be a call to "project-onto-parametric-axis": ;; (let ((unitizer (// (float (magnitude-squared axis-basis))))) (with-3d-vector-on-stack (unit-axis-basis) (3d-vector-scale unitizer axis-basis) (dot-product point-offset-from-ep0 unit-axis-basis)))))) (defmethod (:POINT-ON-AXIS-FROM-PARAMETER CYLINDRICAL-OBSTACLE) (parameter &optional (ep0 (send self :endpoint-0)) (ep1 (send self :endpoint-1))) (with-3d-vector-on-stack (axis-basis) (3d-vector-sub ep1 ep0) (with-3d-vector-on-stack (scaled-axis-basis) (3d-vector-scale parameter axis-basis) (3d-vector-add ep0 scaled-axis-basis)))) (compile-flavor-methods cylindrical-obstacle) ;;; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- (defflavor BOX-OBSTACLE ((width 1) (height 1) (depth 1)) (obstacle 3d:object) (:initable-instance-variables width height depth) (:gettable-instance-variables width height depth) (:settable-instance-variables width height depth)) (defmethod (:ENFORCE-POSITION-CONSTRAINTS BOX-OBSTACLE) (vector-or-object &key (radial-boost 1.0)) (vlet* ((global-position (if (typep vector-or-object '3d:object) (send vector-or-object :global-center) (values-list vector-or-object))) (local-position (lx ly lz) (localize-position global-position self)) :scaler (hx (* width 0.5)) (hy (* height 0.5)) (hz (* depth 0.5))) (ignore local-position) (when (and (< (- hx) lx hx) (< (- hy) ly hy) (< (- hz) lz hz)) (let* ((nx (* hx (if (minusp lx) -1 1))) ;; (not using SIGNUM because zero is no good) (ny (* hy (if (minusp ly) -1 1))) (nz (* hz (if (minusp lz) -1 1))) (dx (abs (- lx nx))) (dy (abs (- ly ny))) (dz (abs (- lz nz)))) (vlet* ((constrained-local-position (if (< dx dy) (if (< dx dz) (values nx ly lz) (values lx ly nz)) (if (< dy dz) (values lx ny lz) (values lx ly nz)))) (boosted-local-position (3d-vector-scale radial-boost constrained-local-position)) (constrained-global-position (globalize-position boosted-local-position self))) (when (typep vector-or-object '3d:object) (send vector-or-object :translate-to constrained-global-position)) (values-list constrained-global-position)))))) (defmethod (:MAXIMUM-RADIUS BOX-OBSTACLE) () (* 0.5 (magnitude-xyz width height depth))) (defmethod (:OBJECT-WITHIN-COLLISION-RANGE-P BOX-OBSTACLE) (flying-object distance-threshold) ;; ;; This predicate checks to see if the flying object is close enough to this obstacle to make more ;; exacting collision avoidance computations: to do a "quick reject" test. The obstacle is modeled as a ;; sphere around the obstacle's center. If it is close enough to a certain cylindrical volume around the ;; object and its forward pointing collision probe, this functions returns T. (Maybe this method should ;; be on flying-object, if the :maximum-radius protocol could be standardized for all obstacle types.) ;; "Local space" here refers to the boid's local space. ;; (vlet* ((global-obstacle-center (send self :global-center)) (local-obstacle-center (localize-position global-obstacle-center flying-object)) (local-radial-offset (componentwise-product '(1 1 0) local-obstacle-center))) (let ((radial-distance (magnitude local-radial-offset)) (forward-distance (dot-product '(0 0 1) local-obstacle-center)) (obstacle-radius (send self :maximum-radius))) (and (< radial-distance obstacle-radius) ;; close enough to local Z axis (> forward-distance (- obstacle-radius)) ;; not too far back (< forward-distance (+ obstacle-radius ;; not too far forward distance-threshold)))))) (defparameter *CURB-FEELER-DEFLECTED* nil) (defmethod (:AVOIDANCE-VECTOR-FOR-FLYING-OBJECT BOX-OBSTACLE) (flying-object) ;; ;; This is based on the "giant forward-pointing curb-feeler" obstacle avoidance algorithm. To deal with ;; the problem of probe overshoot (and hence possibly "tunneling" through the obstacle) it uses an ;; incremental extension of the probe to find an approximation the closest point on the obstacle along ;; the "forward" axis of the FLYING-OBJECT. ;; ;; This value for STRENGTH is quite high, and occasionally produces accelereations with magnitudes up to ;; 1 or 2 feet/frame/frame, although the seem to average around 0.2 to 0.4 which is reasonable. The ;; hefty STRENGTH and long FUTURE-TIME (3 seconds) give a pretty good avoidance behavior, with the ;; flock steering away from the obstacle at a prudent distance. But the strength also causes bad jitter ;; and oscillation as the obstacle came in and out of the boids path. I installed acceleration damping ;; in the :fly method to try to damp this out. The combination seems to be working pretty well for ;; simple, isolated situations. ;; (when (send self :inside-p) (error "inside-box case not implemented yet")) (let* ((*curb-feeler-deflected* nil) (strength 280.0) ;; [4x] 70.0) (future-time 90.0) ;; 60.0) ;; 40.0) (speed (send flying-object :speed)) (future-distance (* speed future-time)) (weighting (// (* strength speed) future-time)) (too-small (// speed 50.0)) (default-avoidance '(0.70710677 0.70710677 0.0)) ;;(multiple-value-list (normalize '(1 1 0))) ) (if (not (send self :object-within-collision-range-p flying-object future-distance)) (values 0 0 0) (vlet* ((future-point (values 0 0 future-distance)) (adjusted-future-point (deflect-subdividing-curb-feeler-from-obstacle future-point future-distance flying-object self)) (adjustment (3d-vector-sub adjusted-future-point future-point)) (scaled-adjustment (3d-vector-scale weighting adjustment)) (adjustment (if (and *curb-feeler-deflected* (< (magnitude-squared scaled-adjustment) (* too-small too-small))) (3d-vector-scale speed default-avoidance) (values-list scaled-adjustment)))) (values-list adjustment))))) (compile-flavor-methods box-obstacle) ;;; (when (eq flying-object (default-boid)) ;;; (with-character-style ('(nil :italic :small) w) ;;; (when ( 0 (magnitude-squared adjustment)) ;;; '(print-vector " adjustment" adjustment w nil) ;;; (format w " ~3$" (magnitude-squared adjustment)) ;;; ) ;;; (when (and *curb-feeler-deflected* ;;; (< (magnitude-squared scaled-adjustment) ;;; (* too-small too-small))) ;;; (format w " *")))) (defparameter *BOX-AVOIDANCE-TEST-OBSTACLE* nil) (defun BOX-AVOIDANCE-TEST-PILOT-FLOCK () (when (null *Box-Avoidance-Test-obstacle*) (flet ((setup-box (pathname w h d) (setq *Box-Avoidance-Test-obstacle* (change-instance-flavor (readin-invisible-object pathname) 'box-obstacle)) (send *Box-Avoidance-Test-obstacle* :set-width (1+ w)) (send *Box-Avoidance-Test-obstacle* :set-height (1+ h)) (send *Box-Avoidance-Test-obstacle* :set-depth (1+ d)))) ;(setup-box "W:>cwr>Boids>Box-Avoidance-Box.Obj" 20 10 5) ;(setup-box "W:>cwr>Boids>Box-Avoidance-Thin-Box.Obj" 20 10 1) (setup-box "GRAPHICS:PRODUCTION;SIGFILM;FLAT-SLAB-PANEL-GROUP-OF-4.OBJ" 2.8 5.14 0.242) )) (when (or (eql 1 dyna:*current-frame-number*) (null *default-flock*)) (let* ((flock (find-flock :population 20)) ;;; (radius (max 3 (radius-for-spherical-flock flock))) (radius (radius-for-spherical-flock flock)) ;;; (near-corner-z -12) ;;; (near-corner-z -7) ;;; for "flat on" test case (near-corner-z -16) ;;; for "flat on" test case, long approach ;;; (near-corner-z -20) ;;; for "flat on" test case, long approach ;;; (near-corner-z -30) ;;; for "flat on" test case, very long approach (z-stretch 2.5) (speed 0.25) ;; .2) ) (initialize-flock flock :move (list 0 0 (- near-corner-z (* radius z-stretch) -3)) :randomize-radius-max radius :randomize-radius-x-stretch 0.8 :randomize-radius-y-stretch 0.7 :randomize-radius-z-stretch z-stretch :randomize-max-speed-min speed :randomize-max-speed-max speed :randomize-speed-min speed :randomize-speed-max speed)) ) (let ((*environmental-obstacles* (list *Box-Avoidance-Test-obstacle*)) (*migratory-global-direction* '(0 0 1))) (pilot-flock))) ;;; ----------------------------------------------------------------------------------------- (defflavor PLANAR-OBSTACLE ;; ;; This obstacle is based on 3D:OBJECT, and uses the object's local cordinate system to describe ;; the position and orientation of the plane of the obstacle. Basically it is the local XY ;; plane which represents the "infinite wall", hence the plane's normal is the local +Z axis and ;; the local origin is a point on the plane. ;; () (obstacle 3d:object)) (defmethod (:ENFORCE-POSITION-CONSTRAINTS PLANAR-OBSTACLE) (vector-or-object &key (radial-boost 1.0)) (ignore radial-boost) (vlet* ((old-global-position (if (typep vector-or-object '3d:object) (send vector-or-object :global-center) (values-list vector-or-object))) (old-local-position (lx ly lz) (localize-position old-global-position self))) (when (if (send self :inside-p) (plusp lz) (minusp lz)) (vlet* ((new-local-position (componentwise-product old-local-position '(1 1 0))) (new-global-position (globalize-position new-local-position self))) (when (typep vector-or-object '3d:object) (send vector-or-object :translate-to new-global-position)) (values-list new-global-position))))) (defmethod (:AVOIDANCE-VECTOR-FOR-FLYING-OBJECT PLANAR-OBSTACLE) (flying-object) ;; ;; Maybe this should start with a check to see if the object was already violating the constraint, but ;; if things are that far gone it is too late to be fixed by collision avoidance planning. (This body ;; is largely copied from :constrain-steering, which see.) STRENGTH and FUTURE-TIME should probably ;; become instance variables of someone. These values (18 and 30) seem to produce radial accelerations ;; of up to about 0.4 or 0.5. Those sound like swell values, except they would be totally swamped if ;; put up against some of the other obstacles which have huge strengths left over from the old "simple ;; average of accelerations" technique. ;; ;; I did some more tests (using Plane-Avoidance-Test.Script) and settled on STRENGTH of 15 and ;; FUTURE-TIME of 40 (1.33 seconds). These produced radial accelerations of magnitudes around 0.3, and ;; seemed to minimize the feedback jitter effect. ;; ;; (let* ((strength 15.0) ;; 17) ;; 16) ;; 25.0) ;; 18.0) ;; 20.0) ;; 1.0) (future-time 40.0) ;; 30.0) ;; 10) (speed (send flying-object :speed)) (future-distance (* speed future-time))) (vlet* ((future-point (values 0 0 future-distance)) (adjusted-future-point (deflect-curb-feeler-from-obstacle future-point future-distance flying-object self)) (adjustment (3d-vector-sub adjusted-future-point future-point)) (scaled-adjustment (3d-vector-scale (// strength future-time) adjustment))) '(when (eq flying-object (third (send (default-flock) :members))) (print-vector "adjustment" scaled-adjustment w)) (values-list scaled-adjustment)))) (compile-flavor-methods planar-obstacle) (defparameter *PLANE-OBSTACLE* nil) (defun PLANE-AVOIDANCE-FRAME-ACTION () (declare (special w)) (when (null *plane-obstacle*) (setq *plane-obstacle* (change-instance-flavor (readin-invisible-object "W:>cwr>Boids>Planar-obstacle.obj.newest") 'planar-obstacle))) (let ((*environmental-obstacles* (list *plane-obstacle*)) (*migratory-global-direction* '(0 0 -.5))) (when (or (eql 1 dyna:*current-frame-number*) (null *default-flock*)) (let* ((flock (find-flock :population 40)) (radius (* 1.1 (radius-for-spherical-flock flock))) (speed 0.15) (pre-age 30)) (initialize-flock flock :move `(0 0 ,(+ 3 (max radius 5) (* pre-age speed))) :randomize-radius-max radius :randomize-yaw-min 180 :randomize-yaw-max 180 :randomize-speed-min speed :randomize-speed-max speed :randomize-max-speed-min speed :randomize-max-speed-max speed) (loop for i from 1 to pre-age do (pilot-flock) (format (or w t) " ~d" i)))) (pilot-flock))) ;;; ----------------------------------------------------------------------------------------- (defun DEFLECT-SUBDIVIDING-CURB-FEELER-FROM-OBSTACLE (curb-feeler-local-offset curb-feeler-length object obstacle ;;; &optional (subdivision-max 20) ; @ speed=.25 ;;; &optional (subdivision-max (round (* 80 (send object :speed)))) ;;; &optional (subdivision-max (round (+ 10 (* 40 (send object :speed))))) &optional (subdivision-max (round (+ 5 (* 60 (send object :speed))))) ) ;;;(with-character-style ('(nil nil :small) w ) ;;; (when (eq object (default-boid)) (format w " (")) (loop for level from 1 to subdivision-max ;;; for factor first 1 then (* factor subdivision-factor) ;;; for length first curb-feeler-length then (* length subdivision-factor) ;;; for retracter from 0.0 by (// 1.0 subdivision-max) ;;; with step = (// 1.0 subdivision-max) with multiplier = 1.075 ;; 1.05 ;; 1.1 with total = (loop repeat subdivision-max for i first 1.0 then (* i multiplier) summing i) ;;; for factor first (// total) then (* factor multiplier) for m first (// total) then (* m multiplier) summing m into factor for length = (* curb-feeler-length factor) with (x y z) = curb-feeler-local-offset ;;; do (format t "~&:: ~s ~30t~s ~60t~s" total factor length) ;;; do (when (eq object (default-boid)) ;;; (format w "~a" (substring "abcdefghijklmnopqrstuvwxyza" (mod (1- level) 26) (1+ (mod (1- level) 26))))) until (vlet* ((previous (values x y z)) (subdivided (3d-vector-scale factor previous)) (deflected (deflect-curb-feeler-from-obstacle subdivided length object obstacle)) (restored (3d-vector-scale (// factor) deflected)) (deflection (3d-vector-sub restored previous))) (unless (negligible-vector? deflection) ;;; (when (eq object (default-boid)) ;;; (when (numberp (third *foo*)) ;;; (when (plusp (third *foo*)) ;;; (format w "[~$]" (third *foo*))))) (setf (list x y z) restored) t)) finally ;;; (when (eq object (default-boid)) (format w ")")) (return (values x y z)))) (defun DEFLECT-CURB-FEELER-FROM-OBSTACLE (curb-feeler-local-offset curb-feeler-length object obstacle) (loop with max-iterations = 5 ; 4 ; 3 with (x y z) = curb-feeler-local-offset for i from 1 to max-iterations for modifications = nil do (vlet* ((current-local (values x y z)) (current (globalize-position current-local object)) ;; ;; (foo (print-vector " probe" current w)) ;; (modified (send obstacle :enforce-position-constraints current :radial-boost 1.03 ;; 1.05 ;; 1.1 ;; 1.15 ;; 2.0 ))) ;; ;; (setq *foo* (copy-list modified)) ;; ;; (print-vector "modified" modified w) ;; ;; this check is "has it changed?", it might want to be asking "has it changed, ;; and if so, has it gotten shorter?" because the other possibility is that it ;; has been pushed though the object to the other side. ;; (when (numberp (first modified)) (setq modifications t *curb-feeler-deflected* t) (vlet* ((constrained-offset (localize-position modified object)) (normalized-offset (normalize constrained-offset :error-for-zero-length nil)) (new-offset (3d-vector-scale curb-feeler-length normalized-offset))) (setf (list x y z) new-offset)))) while modifications finally (return (values x y z)))) ;;; ----------------------------------------------------------------------------------------- (defun FIND-FLOCK-FOR-SCRIPT (&key (population *default-flock-population*) (flock *default-flock*)) ;; ;; Hack upon hack! This should not refer to dyna:se. The initialization step must be formalized. ;; (progn (send (send dyna:se :current-script) :set-anim-object (find-flock :population population :flock flock)) (send *default-flock* :initialize-members :randomize-radius-min 1 :randomize-radius-max 6 :randomize-radius-x-stretch 1.3 :randomize-yaw-min -5 :randomize-yaw-max 5 :randomize-pitch-min -5 :randomize-pitch-max 5 :randomize-max-speed-min 0.4 :randomize-max-speed-max 0.4 :randomize-speed-min 0.4 :randomize-speed-max 0.4 ; :move '(13 0 0) ; :randomize-radius-min 1 :randomize-radius-max 6 ; :randomize-yaw-min -10 :randomize-yaw-max 10 ; :randomize-pitch-min -10 :randomize-pitch-max 10 ; :randomize-max-speed-min 0.35 :randomize-max-speed-max 0.5 ; :randomize-speed-min 0.3 :randomize-speed-max 0.4 ;;; :randomize-radius-min 3 :randomize-radius-max 19 ;;; :randomize-yaw-max 360 ;;; :randomize-pitch-min -10 :randomize-pitch-max 10 ;;; :randomize-max-speed-min 0.4 :randomize-max-speed-max 0.6 ;;; :randomize-speed-min 0.3 :randomize-speed-max 0.4 ;;; :randomize-max-speed-min 1 :randomize-max-speed-max 1 ;;; :randomize-speed-min 1 :randomize-speed-max 1 ) ;;; (send (default-boid) :move-to 0 0 -5) ;;; (send (default-boid) :set-max-speed 0.4) )) (defun SET-MIGRATORY-GLOBAL-TARGET-POINT (target-point) (setq *migratory-global-target-point* target-point)) ;;; (defun x (y) (// (- y 1.0))) ;;; (loop for i first 1.0d0 then (// (+ i 1)) do (print i)) ;;; (defparameter *golden-mean* 1.6180339887498948) (defun RADIUS-FOR-SPHERICAL-FLOCK (&optional (flock-or-population *default-flock*)) (* 1.33 (expt (float (if (numberp flock-or-population) flock-or-population (send flock-or-population :population))) 1\3))) (defun ZIG-ZAG-SETUP () (find-flock) (unless (null *default-flock*) (send *default-flock* :initialize-members :move '(-50 0 -50) :randomize-radius-min 2 :randomize-radius-max (radius-for-spherical-flock *default-flock*) :randomize-max-speed-min .666 :randomize-max-speed-max .666 :randomize-speed-max 0.333) ;; ;; For camera-on-boid version: drop back the camera-boid so he can see the rest of the gang, and ;; set his speed to zero so he'll start out acelerating from a standing start. ;; (send (default-boid) :move 0 0 -7) (send (default-boid) :set-speed 0))) (defun FLY-ALONG-SIDE-SETUP () (find-flock) (unless (null *default-flock*) (send *default-flock* :initialize-members :move '(0 0 -75) :randomize-radius-min 2 :randomize-radius-max (radius-for-spherical-flock *default-flock*) :randomize-max-speed-min 0.5 :randomize-max-speed-max 0.5 :randomize-speed-min 0.5 :randomize-speed-max 0.5))) (defparameter *WANDER-INSIDE-SPHERE-OBSTACLE* (list (make-instance 'spherical-obstacle :inside-p t :radius 19))) (defparameter *WANDER-INSIDE-SPHERE-OBSTACLE-9* (list (make-instance 'spherical-obstacle :inside-p t :radius 9))) (defun WANDER-INSIDE-SPHERE-SETUP () (find-flock) (unless (null *default-flock*) (let* ((outer-radius (* 2.2 (radius-for-spherical-flock *default-flock*))) (inner-radius (* 0.8 outer-radius)) (center-y (- outer-radius (send (first *wander-inside-sphere-obstacle*) :radius)))) (send *default-flock* :initialize-members :move (list 0 center-y 0) :randomize-radius-min inner-radius :randomize-radius-max outer-radius #| :randomize-max-speed-min 1 :randomize-max-speed-max 1 :randomize-speed-min 1 :randomize-speed-max 1 |# :randomize-yaw-max 360 :randomize-pitch-min -10 :randomize-pitch-max 10 :randomize-max-speed-min 0.47 :randomize-max-speed-max 0.53 :randomize-speed-min 0 :randomize-speed-max 0.6 )))) (defparameter *CYLINDER-AVOIDANCE-TEST-OBSTACLE* (list (make-instance 'cylindrical-obstacle :radius (+ 5 0.5) ;; add half a body length for clearance ; :endpoint-0 '(0 -15 0) ; :endpoint-1 '(0 +15 0) ;; tilted version: :endpoint-0 '(0 -27.24 -12.7) :endpoint-1 '(0 0.05 -.04) ))) (defparameter *CYLINDER-AVOIDANCE-TEST-DISTANCE* 12) (defun CYLINDER-AVOIDANCE-TEST-SETUP () (find-flock) (unless (null *default-flock*) (let* () (send *default-flock* :initialize-members :move (list 0 0 (+ *Cylinder-Avoidance-Test-distance*)) :randomize-radius-min 2 :randomize-radius-max (* 2 (radius-for-spherical-flock *default-flock*)) :randomize-radius-z-stretch 0.4 :randomize-yaw-min 180 :randomize-yaw-max 180 :randomize-max-speed-min 0.47 :randomize-max-speed-max 0.53 :randomize-speed-min 0.5 :randomize-speed-max 0.5)))) (defun CYLINDER-AVOIDANCE-TEST-PILOT-FLOCK () (let ((*environmental-obstacles* *Cylinder-Avoidance-Test-obstacle*) (*migratory-global-target-point* `(0 0 ,(* -2 *Cylinder-Avoidance-Test-distance*)))) (pilot-flock))) '(defun BACK-AND-FORTH-PILOT-FLOCK (back-or-forth) (let* ((target-1 '(0 0 -7)) (target-2 '(0 0 +7)) (species :fish) (speed (select species (:boids 0.3) (:birds *max-bird-speed*) (:fish *fish-max-speed*)))) (when (eql 1 dyna:*current-frame-number*) (select species (:boids (find-flock)) (:birds (setup-birds)) (:fish (setup-fish))) (unless (null *default-flock*) (initialize-flock *default-flock* :move target-2 :align-to target-1 :randomize-radius-max (* 1.2 (radius-for-spherical-flock)) :randomize-max-speed-min speed :randomize-max-speed-max speed :randomize-speed-min speed :randomize-speed-max speed))) (vlet* ((*migratory-global-target-point* (3d-vector-scale 4 (if back-or-forth target-1 target-2)))) (select species (:boids (pilot-flock)) (:birds (pilot-birds)) (:fish (pilot-fish)))))) ;;; ----------------------------------------------------------------------------------------- ;;; ;;; Boid 3d geometry library. ;;; ;;; Generally, vector valued functions return xyz as three multiple values. Functions with ;;; "-xyz" in their names take their vector arguments as separate components. Otherwise ;;; vector arguments are passed as lists "(x y z)". Maybe this should be using defstructs. (defun 3D-VECTOR-ADD (&rest 3d-vectors) (loop for (x y z) in 3d-vectors summing x into tx summing y into ty summing z into tz finally (return (values tx ty tz)))) (defun 3D-VECTOR-SUB (&rest 3d-vectors) (loop with (tx ty tz) = (first 3d-vectors) for (x y z) in (rest 3d-vectors) do (decf tx x) (decf ty y) (decf tz z) finally (return (values tx ty tz)))) (defun 3D-VECTOR-SCALE (scale-factor vector) (multiple-value-bind (x y z) (3d:parse-triplet-from-value vector) (scale-xyz scale-factor x y z))) (defun SCALE-XYZ (scaler x y z) (values (* x scaler) (* y scaler) (* z scaler))) (defun MAGNITUDE (vector) (multiple-value-bind (x y z) (3d:parse-triplet-from-value vector) (magnitude-xyz x y z))) (defun MAGNITUDE-XYZ (x y z) (without-floating-underflow-traps (3d:fast-sqrt (+ (* x x) (* y y) (* z z))))) (defun MAGNITUDE-SQUARED (vector) (multiple-value-bind (x y z) (3d:parse-triplet-from-value vector) (without-floating-underflow-traps (+ (* x x) (* y y) (* z z))))) (defun MAGNITUDE-SQUARED-XYZ (x y z) (without-floating-underflow-traps (+ (* x x) (* y y) (* z z)))) (defun DISTANCE-XYZ (ax ay az bx by bz) (flet ((sq (a) (* a a))) (3d:fast-sqrt (+ (sq (- ax bx)) (sq (- ay by)) (sq (- az bz)))))) (defun DISTANCE (vector-a vector-b) (3d:fast-sqrt (distance-squared vector-a vector-b))) (defun DISTANCE-SQUARED (vector-a vector-b) (flet ((sq (a) (* a a))) (multiple-value-bind (ax ay az) (3d:parse-triplet-from-value vector-a) (multiple-value-bind (bx by bz) (3d:parse-triplet-from-value vector-b) (+ (sq (- ax bx)) (sq (- ay by)) (sq (- az bz))))))) (defsubst NORMALIZE-XYZ-INTERNAL (x y z error-for-zero-length) (declare (values nx ny nz magnitude-of-xyz)) ;; ;; I determined by testing that it is not worth checking for either the zero or unit magnitude cases. ;; The check slows the typical case down too much relative to the chance thatr they will occur. ;; (let ((m (magnitude-xyz x y z))) (if (and (zerop m) (not error-for-zero-length)) (values 0 0 0 0) (values (// x m) (// y m) (// z m) m)))) (defun NORMALIZE (vector &key (error-for-zero-length t)) (declare (values nx ny nz magnitude-of-xyz)) (destructuring-bind (x y z) vector (normalize-xyz-internal x y z error-for-zero-length))) (defun NORMALIZE-XYZ (x y z &key (error-for-zero-length t)) (declare (values nx ny nz magnitude-of-xyz)) (normalize-xyz-internal x y z error-for-zero-length)) (defun COMPONENTWISE-PRODUCT (vector-a vector-b) (multiple-value-bind (ax ay az) (3d:parse-triplet-from-value vector-a) (multiple-value-bind (bx by bz) (3d:parse-triplet-from-value vector-b) (values (* ax bx) (* ay by) (* az bz))))) (defun DOT-PRODUCT (vector-a vector-b) (multiple-value-bind (ax ay az) (3d:parse-triplet-from-value vector-a) (multiple-value-bind (bx by bz) (3d:parse-triplet-from-value vector-b) (+ (* ax bx) (* ay by) (* az bz))))) (defun PERPENDICULAR-COMPONENT (arbitrary-vector basis-vector) ;; ;; Returns component of ARBITRARY-VECTOR which is perpendicular to BASIS-VECTOR ;; (vlet* ((unit-basis-vector (normalize basis-vector :error-for-zero-length nil))) (let ((projection-onto-basis (dot-product arbitrary-vector unit-basis-vector))) (vlet* ((parallel-component (3d-vector-scale projection-onto-basis unit-basis-vector))) (3d-vector-sub arbitrary-vector parallel-component))))) (defun INTERPOLATE-VECTORS (interpolation-factor vector-a vector-b) (vlet* ((weighted-a (3d-vector-scale (- 1 interpolation-factor) vector-a)) (weighted-b (3d-vector-scale interpolation-factor vector-b))) (3d-vector-add weighted-a weighted-b))) (defun SET-VECTOR-MAGNITUDE (magnitude direction-vector) (vlet* ((unit-vector (normalize direction-vector))) (3d-vector-scale magnitude unit-vector))) (defun TRUNCATE-MAGNITUDE (vector &optional (maximum-magnitude 1)) (multiple-value-bind (x y z) (3d:parse-triplet-from-value vector) (truncate-magnitude-xyz x y z maximum-magnitude))) (defun TRUNCATE-MAGNITUDE-XYZ (x y z &optional (maximum-magnitude 1)) (let ((magnitude-squared (magnitude-squared-xyz x y z))) (if (zerop magnitude-squared) (values 0 0 0) (if (< magnitude-squared (* maximum-magnitude maximum-magnitude)) (values x y z) (let* ((magnitude (3d:fast-sqrt magnitude-squared)) (scaler (* maximum-magnitude (// 1.0 magnitude)))) (scale-xyz scaler x y z)))))) (defun MAGNITUDE-BELOW-THRESHOLD?-XYZ (x y z &key (threshold 0.0001)) (without-floating-underflow-traps (flet ((sq (a) (* a a))) (> (sq threshold) (+ (sq x) (sq y) (sq z)))))) (defun NEGLIGIBLE-XYZ? (x y z &key (threshold 0.0001)) (magnitude-below-threshold?-xyz x y z :threshold threshold)) (defun NEGLIGIBLE-VECTOR? (v &key (threshold 0.0001)) (if (null v) t (multiple-value-bind (x y z) (3d:parse-triplet-from-value v) (negligible-xyz? x y z :threshold threshold)))) (defun AVERAGE-3D-VECTOR-VALUES (list-of-objects &optional (function-to-extract-3d-value-from-object #'3d:parse-triplet-from-value) (function-to-test-if-object-should-be-averaged #'identity)) (declare (values average-x average-y average-z)) (multiple-value-bind (total-x total-y total-z count) (sum-3d-vector-values list-of-objects function-to-extract-3d-value-from-object function-to-test-if-object-should-be-averaged) (values (// total-x count) (// total-y count) (// total-z count)))) (defun SUM-3D-VECTOR-VALUES (list-of-objects &optional (function-to-extract-3d-value-from-object #'3d:parse-triplet-from-value) (function-to-test-if-object-should-be-added-to-sum #'identity)) (declare (values total-x total-y total-z count)) (loop with (total-x total-y total-z) = '(0 0 0) with counter = 0.0 for o in list-of-objects when (funcall function-to-test-if-object-should-be-added-to-sum o) do (multiple-value-bind (vx vy vz) (funcall function-to-extract-3d-value-from-object o) (incf total-x vx) (incf total-y vy) (incf total-z vz) (incf counter 1)) finally (return (values total-x total-y total-z counter)))) (defun RANDOM-3D-UNIT-VECTOR () ;; ;; Loop, selecting random points uniformly distributed inside the unit cube, until a selected point is ;; also inside the unit sphere (its distance from the origin is  1). Project this vector onto the ;; surface of the unit sphere by normalizing its length, and return its XYZ components. ;; (loop for x = (random2 -1.0 1.0) for y = (random2 -1.0 1.0) for z = (random2 -1.0 1.0) until ( (magnitude-squared-xyz x y z) 1) finally (return (normalize-xyz x y z)))) (defun RANDOM-POSITION-INSIDE-RADIUS-1-SPHERE () ;; ;; Loop, selecting random points uniformly distributed inside the unit cube, until a selected point is ;; also inside the unit sphere (its distance from the origin is  1) and return its XYZ components. ;; (loop for x = (random2 -1.0 1.0) for y = (random2 -1.0 1.0) for z = (random2 -1.0 1.0) until ( (magnitude-squared-xyz x y z) 1) finally (return (values x y z)))) (defun PROJECT-ONTO-XY-PLANE (vector) (multiple-value-bind (x y ignore) (3d:parse-triplet-from-value vector) (values x y 0))) (defun CLIP-NEGATIVE-Z-COMPONENT-OF-VECTOR (vector) (multiple-value-bind (vx vy vz) (values-list vector) (values vx vy (max vz 0)))) (defun LOCALIZE-SCALER-DISTANCE (distance object) ;; ;; this code works fine, but it is only necessary if the local space is scaled or stretched, and since ;; it isn't in any of the boids stuff so far, I made this a cheap no-op rather than an expensive no-op. ;; #|(with-3d-vector-on-stack (unit-diagonal) (normalize-xyz 1 1 1) (with-3d-vector-on-stack (distance-vector) (3d-vector-scale distance unit-diagonal) (with-3d-vector-on-stack (local-distance) (localize-direction distance-vector object) (magnitude local-distance)))) |# (ignore object) distance) ;;; ----------------------------------------------------------------------------------------- (defmacro WITH-CURRENT-TRANSFORM-MATRIX ((matrix-variable-name object-camera-or-matrix) &body body) `(progn (check-type ,object-camera-or-matrix (or 3d:object 3d:viewer array) "a 3d:object, a 3d:viewer or a transformation matrix") (using-resource (,matrix-variable-name 3d:temp-transform-matrix) (cond ((typep ,object-camera-or-matrix '3d:object) (3d:current-matrix ,object-camera-or-matrix ,matrix-variable-name)) ((typep ,object-camera-or-matrix '3d:viewer) (send ,object-camera-or-matrix :fill-object-transform ,matrix-variable-name)) ((arrayp ,object-camera-or-matrix) (3d:copy-matrix-and-code ,object-camera-or-matrix ,matrix-variable-name))) ,@body))) '(defmacro WITH-CURRENT-TRANSFORM-MATRIX ((matrix-variable-name object-with-matrix) &body body) `(using-resource (,matrix-variable-name 3d:temp-transform-matrix) (3d:current-matrix ,object-with-matrix ,matrix-variable-name) ,@body)) (defun GLOBALIZE-POSITION (vector object) (multiple-value-bind (x y z) (3d:parse-triplet-from-value vector) (globalize-position-xyz x y z object))) (defun GLOBALIZE-POSITION-XYZ (x y z object) (with-current-transform-matrix (matrix object) (3d:transform-coordinates x y z matrix))) (defun GLOBALIZE-DIRECTION (vector object) (multiple-value-bind (x y z) (3d:parse-triplet-from-value vector) (globalize-direction-xyz x y z object))) (defun GLOBALIZE-DIRECTION-XYZ (x y z object) (with-current-transform-matrix (matrix object) (multiple-value-bind (ox oy oz) (3d:transform-coordinates 0 0 0 matrix) (multiple-value-bind (gx gy gz) (3d:transform-coordinates x y z matrix) (values (- gx ox) (- gy oy) (- gz oz)))))) ;;; Command: (3d:show-matrix '#) ;;; 22 ( x-y-rotate trans) ;;; .4879 .0000 .8729 .0000 ;;; -.7805 .4478 .4362 .0000 ;;; -.3909 -.8942 .2184 .0000 ;;; .00 .00 .00 1.0000 ;;; NIL ;;; Command: (DESCRIBE '#) ;;; ;;; (loop for i from 0 below 16 do (print (aref '# i))) ;;; 0.4878597 ;;; 0.0 ;;; 0.87292206 ;;; 0.0 ;;; -0.780527 ;;; 0.4477591 ;;; 0.43622184 ;;; 0.0 ;;; -0.3908588 ;;; -0.8941543 ;;; 0.21844362 ;;; 0.0 ;;; 0.0 ;;; 0.0 ;;; 0.0 ;;; 1.0 ;;; NIL ;;; ;;; (defun LOCALIZE-POSITION (vector object) ;;; (multiple-value-bind (x y z) (3d:parse-triplet-from-value vector) ;;; (localize-position-xyz x y z object))) ;;; ;;; from ASAS: ;;; ;;; (defun LOCALIZE-PIJK ;;; (p i j k vector) ;;; (let ((local-offset (vsub vector p))) ;;; (vector2 (localize-axis i) ;;; (localize-axis j) ;;; (localize-axis k)))) ;;; ;;; (defmacro LOCALIZE-AXIS ;;; (axis) ;;; `(quo (vdot local-offset ,axis) ;;; (vmag-squared ,axis))) ;;; ;;; Command: (time-it (localize-speedup-test :old 100 '(1 2 3) box)) ;;; Evaluation of NIL took 0.000379 seconds of elapsed time ;;; including 0.000 seconds waiting for the disk for 0 faults. ;;; Evaluation of (LOCALIZE-SPEEDUP-TEST :OLD 100 '# BOX) took 0.559232 seconds of elapsed ;;; time including 0.000 seconds waiting for the disk for 0 faults. ;;; NIL ;;; Command: (time-it (localize-speedup-test :new 100 '(1 2 3) box)) ;;; Evaluation of NIL took 0.000380 seconds of elapsed time ;;; including 0.000 seconds waiting for the disk for 0 faults. ;;; Evaluation of (LOCALIZE-SPEEDUP-TEST :NEW 100 '# BOX) took 0.145406 seconds of elapsed ;;; time including 0.000 seconds waiting for the disk for 0 faults. ;;; NIL ;;; ;;; (defun LOCALIZE-SPEEDUP-TEST (old-new count vector object) ;;; (cond ((eql old-new :old) (loop repeat count do (localize-position vector object))) ;;; ((eql old-new :new) (loop repeat count do (localize-position-new vector object))))) (defun LOCALIZE-POSITION (vector object) ;; ;; Transform a global position vector into a position vector in the OBJECT's local space. ;; (with-current-transform-matrix (m object) (vlet* ((local-x-axis (values (aref m 0) (aref m 1) (aref m 2))) (local-y-axis (values (aref m 4) (aref m 5) (aref m 6))) (local-z-axis (values (aref m 8) (aref m 9) (aref m 10))) (local-center (values (aref m 12) (aref m 13) (aref m 14))) (local-offset (3d-vector-sub vector local-center)) ) (values (project-onto-parametric-axis local-offset local-x-axis) (project-onto-parametric-axis local-offset local-y-axis) (project-onto-parametric-axis local-offset local-z-axis))))) (defun PROJECT-ONTO-PARAMETRIC-AXIS (vector axis) (// (dot-product vector axis) (magnitude-squared axis))) (defun LOCALIZE-POSITION-XYZ (x y z object) (vlet* ((vector (values x y z))) (localize-position vector object))) (defun LOCALIZE-DIRECTION (vector object) ;; ;; Transform a global direction vector into a direction vector in the OBJECT's local space. ;; (with-current-transform-matrix (m object) (vlet* ((local-x-axis (values (aref m 0) (aref m 1) (aref m 2))) (local-y-axis (values (aref m 4) (aref m 5) (aref m 6))) (local-z-axis (values (aref m 8) (aref m 9) (aref m 10))) (local-center (values (aref m 12) (aref m 13) (aref m 14))) (local-offset-v (3d-vector-sub vector local-center)) (local-offset-o (3d-vector-sub '(0 0 0) local-center)) ;;; 15% slower to use "project-onto-parametric-axis" and so to do the mag-sq computation twice. ;; :scaler ;; (x-magnitude-squared (magnitude-squared local-x-axis)) ;; (y-magnitude-squared (magnitude-squared local-y-axis)) ;; (z-magnitude-squared (magnitude-squared local-z-axis)) ) '(values (- (// (dot-product local-offset-v local-x-axis) x-magnitude-squared) (// (dot-product local-offset-o local-x-axis) x-magnitude-squared)) (- (// (dot-product local-offset-v local-y-axis) y-magnitude-squared) (// (dot-product local-offset-o local-y-axis) y-magnitude-squared)) (- (// (dot-product local-offset-v local-z-axis) z-magnitude-squared) (// (dot-product local-offset-o local-z-axis) z-magnitude-squared))) (values (- (project-onto-parametric-axis local-offset-v local-x-axis) (project-onto-parametric-axis local-offset-o local-x-axis)) (- (project-onto-parametric-axis local-offset-v local-y-axis) (project-onto-parametric-axis local-offset-o local-y-axis)) (- (project-onto-parametric-axis local-offset-v local-z-axis) (project-onto-parametric-axis local-offset-o local-z-axis)))))) ;;; Command: (time-it (localize-dir-speedup-test :old 100 '(1 2 3) box)) ;;; Evaluation of NIL took 0.000380 seconds of elapsed time ;;; including 0.000 seconds waiting for the disk for 0 faults. ;;; Evaluation of (LOCALIZE-DIR-SPEEDUP-TEST :OLD 100 '# BOX) took 0.589144 seconds of elapsed ;;; time including 0.000 seconds waiting for the disk for 0 faults. ;;; NIL ;;; Command: (time-it (localize-dir-speedup-test :new 100 '(1 2 3) box)) ;;; Evaluation of NIL took 0.000382 seconds of elapsed time ;;; including 0.000 seconds waiting for the disk for 0 faults. ;;; Evaluation of (LOCALIZE-DIR-SPEEDUP-TEST :NEW 100 '# BOX) took 0.192146 seconds of elapsed ;;; time including 0.000 seconds waiting for the disk for 0 faults. ;;; NIL ;;; ;;; (defun LOCALIZE-DIR-SPEEDUP-TEST (old-new count vector object) ;;; (cond ((eql old-new :old) ;;; (loop repeat count do (localize-direction vector object))) ;;; ((eql old-new :new) ;;; (loop repeat count do (localize-direction-new vector object))))) (defun LOCALIZE-DIRECTION-XYZ (x y z object) ;; ;; Transform a global direction vector into a direction vector in the OBJECT's local space. ;; (vlet* ((vector (values x y z))) (localize-direction vector object))) ;;; -- eof ----------------------------------------------------------------------------------