mirror of
https://github.com/open-goal/jak-project
synced 2026-08-06 18:03:30 -04:00
water111
1215 lines
62 KiB
Common Lisp
1215 lines
62 KiB
Common Lisp
;;-*-Lisp-*-
|
|
(in-package goal)
|
|
(bundles "ENGINE.CGO" "GAME.CGO")
|
|
(require "engine/entity/actor-link-h.gc")
|
|
(require "engine/entity/ambient.gc")
|
|
(require "engine/level/level.gc")
|
|
(require "engine/draw/drawable-actor-h.gc")
|
|
(require "engine/common-obs/process-drawable.gc")
|
|
(require "engine/entity/entity-table.gc")
|
|
|
|
;; DECOMP BEGINS
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; global entity settings
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define *spawn-actors* #t)
|
|
|
|
(define *compact-actors* #t)
|
|
|
|
(define *vis-actors* #t)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; entity basic methods
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defmethod mem-usage ((this drawable-actor) (usage memory-usage-block) (flags mem-usage-flags))
|
|
"Account for this drawable wrapper and delegate to its entity actor in the entity category."
|
|
(mem-usage-add! usage entity 1 (asize-of this))
|
|
;; Attribute the actor's resource lump and referenced data to the entity category.
|
|
(mem-usage (-> this actor) usage (logior flags (mem-usage-flags resource-entity)))
|
|
(the-as drawable-actor 0))
|
|
|
|
(defmethod mem-usage ((this drawable-inline-array-actor) (usage memory-usage-block) (flags mem-usage-flags))
|
|
"Account for the drawable-group header and every active inline actor wrapper."
|
|
(mem-usage-add-symbol! usage drawable-group 1 32)
|
|
(dotimes (i (-> this length))
|
|
(mem-usage (-> this data i) usage flags))
|
|
(the-as drawable-inline-array-actor 0))
|
|
|
|
(defmethod print ((this entity-links))
|
|
(format #t "#<entity-links :process ~A @ #x~X>" (-> this process) this)
|
|
this)
|
|
|
|
(defmethod print ((this entity-perm))
|
|
(format #t
|
|
"#<entity-perm :aid ~D :task ~D :status #x~X :data #x~X @ #x~X>"
|
|
(-> this aid)
|
|
(-> this task)
|
|
(-> this status)
|
|
(-> this user-uint64)
|
|
this)
|
|
this)
|
|
|
|
(defmethod birth! ((this entity))
|
|
"Default entity birth hook; subclasses create their live representation."
|
|
(format #t "birth ~A~%" this)
|
|
this)
|
|
|
|
(defmethod kill! ((this entity))
|
|
"Default entity kill hook; subclasses remove their live representation."
|
|
(format #t "kill ~A~%" this)
|
|
this)
|
|
|
|
(defmethod print ((this entity))
|
|
"print an entity, with its name from the res."
|
|
(format #t "#<~A :name ~S @ #x~X>" (-> this type) (res-lump-struct this 'name structure) this)
|
|
this)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; entity finding
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defmethod get-level ((this entity))
|
|
"Return the active level heap containing this entity, or level-default when none contains it."
|
|
(dotimes (i (-> *level* length))
|
|
(let ((lev (-> *level* level i)))
|
|
(when (= (-> lev status) 'active)
|
|
(if (and (>= (the-as int this) (the-as int (-> lev heap base))) (< (the-as int this) (the-as int (-> lev heap top-base))))
|
|
(return lev)))))
|
|
(-> *level* level-default))
|
|
|
|
(defun entity-by-name ((name string))
|
|
"Return the first actor, ambient, or camera with name across active levels, or false."
|
|
(local-vars (i int))
|
|
(dotimes (level-index (-> *level* length))
|
|
(let ((lev (-> *level* level level-index)))
|
|
(when (= (-> lev status) 'active)
|
|
(let ((actors (-> lev bsp actors)))
|
|
(when (nonzero? actors)
|
|
(set! i 0)
|
|
(while (< i (-> actors length))
|
|
(let ((actor (-> actors data i actor))) (if (name= (res-lump-struct actor 'name basic) name) (return actor)))
|
|
(+! i 1))))
|
|
(let ((ambients (-> lev bsp ambients)))
|
|
(when (nonzero? ambients)
|
|
(set! i 0)
|
|
(while (< i (-> ambients length))
|
|
(let ((ambient (-> ambients data i ambient))) (if (name= (res-lump-struct ambient 'name basic) name) (return ambient)))
|
|
(+! i 1))))
|
|
(let ((cameras (-> lev bsp cameras)))
|
|
(when (nonzero? cameras)
|
|
(set! i 0)
|
|
(while (< i (-> cameras length))
|
|
(let ((camera (-> cameras i))) (if (name= (res-lump-struct camera 'name basic) name) (return camera)))
|
|
(+! i 1)))))))
|
|
(the-as entity #f))
|
|
|
|
(defun entity-by-type ((entity-type type))
|
|
"Return the first active-level entity actor whose declared process type is exactly entity-type,
|
|
or false."
|
|
(dotimes (level-index (-> *level* length))
|
|
(let ((lev (-> *level* level level-index)))
|
|
(when (= (-> lev status) 'active)
|
|
(let ((actors (-> lev bsp actors)))
|
|
(when (nonzero? actors)
|
|
(dotimes (i (-> actors length))
|
|
(let ((actor (-> actors data i actor)))
|
|
(if (and (type-type? (-> actor type) entity-actor) (= (-> actor etype) entity-type)) (return actor)))))))))
|
|
(the-as entity-actor #f))
|
|
|
|
(defun entity-by-aid ((aid uint))
|
|
"Binary-search active levels' actor-ID-sorted entity-link arrays and return the matching entity,
|
|
or false."
|
|
(dotimes (level-index (-> *level* length))
|
|
(let ((lev (-> *level* level level-index)))
|
|
(when (= (-> lev status) 'active)
|
|
(let ((links (-> lev entity)))
|
|
(when (nonzero? links)
|
|
(let ((lo 0)
|
|
(hi (+ (-> links length) -1)))
|
|
0
|
|
(while (>= hi lo)
|
|
(let* ((mid (+ lo (/ (- hi lo) 2)))
|
|
(link (-> links data mid))
|
|
(mid-aid (-> link perm aid)))
|
|
(cond
|
|
((= mid-aid aid) (return (-> link entity)))
|
|
((< (the-as uint mid-aid) aid) (set! lo (+ mid 1)))
|
|
(else (set! hi (+ mid -1))))))))))))
|
|
(the-as entity #f))
|
|
|
|
(defun entity-by-meters ((x float) (y float) (z float))
|
|
"Return the first active-level actor whose fixed-point translation equals x, y, and z in meters,
|
|
or false."
|
|
(dotimes (level-index (-> *level* length))
|
|
(let ((lev (-> *level* level level-index)))
|
|
(when (= (-> lev status) 'active)
|
|
(let ((actors (-> lev bsp actors)))
|
|
(when (nonzero? actors)
|
|
(dotimes (i (-> actors length))
|
|
(let* ((actor (-> actors data i actor))
|
|
(translation (-> actor extra trans)))
|
|
(if (and (= (the float (the int (-> translation x))) x)
|
|
(= (the float (the int (-> translation y))) y)
|
|
(= (the float (the int (-> translation z))) z))
|
|
(return actor)))))))))
|
|
(the-as entity-actor #f))
|
|
|
|
(defun process-by-ename ((name string))
|
|
"Return the live process connected to the named entity, or false."
|
|
(let ((ent (entity-by-name name))) (if ent (-> ent extra process))))
|
|
|
|
(defun entity-process-count ((mode symbol))
|
|
"Count active-level entity links with live processes, or visible links when mode is vis."
|
|
(let ((count 0))
|
|
(dotimes (level-index (-> *level* length))
|
|
(let ((lev (-> *level* level level-index)))
|
|
(when (= (-> lev status) 'active)
|
|
(let ((links (-> lev bsp level entity)))
|
|
(dotimes (i (-> links length))
|
|
(let ((ent (-> links data i entity)))
|
|
(case mode
|
|
(('vis) (if (is-object-visible? lev (-> ent extra vis-id)) (+! count 1)))
|
|
(else (if (-> ent extra process) (+! count 1))))))))))
|
|
count))
|
|
|
|
(defun entity-count ()
|
|
"Return the total number of entity links across active levels."
|
|
(let ((count 0))
|
|
(dotimes (level-index (-> *level* length))
|
|
(let ((lev (-> *level* level level-index)))
|
|
(when (= (-> lev status) 'active)
|
|
(let ((links (-> lev bsp level entity)))
|
|
(dotimes (i (-> links length))
|
|
(-> links data i entity) ;; value is unused.
|
|
(+! count 1))))))
|
|
count))
|
|
|
|
(defun entity-remap-names ((remaps pair))
|
|
"For each position/name record in remaps, locate the actor at the eighth-unit coordinates and
|
|
replace its name resource tag."
|
|
(let ((remap (car remaps)))
|
|
(while (not (null? remaps))
|
|
;; look up by the given position.
|
|
(let ((ent (entity-by-meters (the float (/ (the-as int (car (cdr remap))) 8))
|
|
(the float (/ (the-as int (car (cdr (cdr remap)))) 8))
|
|
(the float (/ (the-as int (car (cdr (cdr (cdr remap))))) 8)))))
|
|
(if ent
|
|
;; if we found an entity, modify its res.
|
|
(add-data! ent
|
|
(new 'static 'res-tag :name 'name :key-frame -1000000000.0 :elt-count #x1 :elt-type string)
|
|
(the-as pointer (car remap)))))
|
|
(set! remaps (cdr remaps))
|
|
(set! remap (car remaps))))
|
|
0
|
|
(none))
|
|
|
|
(defun-debug process-status-bits ((proc process) (stream symbol))
|
|
"Print three compact process-status characters to stream: logic-running, drawing, and current
|
|
draw LOD. Unsupported or inactive fields print spaces."
|
|
(let* ((status-proc proc)
|
|
(drawable-proc (the-as process-drawable
|
|
(if (and (nonzero? status-proc) (type-type? (-> status-proc type) process-drawable)) (the-as process-drawable status-proc)))))
|
|
(if (and (the-as process drawable-proc) (zero? (-> drawable-proc draw))) (set! drawable-proc (the-as process-drawable #f)))
|
|
;; first char is r or ' '. r for run.
|
|
;; second char is d or ' '. I think d is draw.
|
|
;; third char is a number 0-4 or a ' '. This is the lod.
|
|
(format stream
|
|
"~C~C~C"
|
|
(if (and proc (zero? (logand (-> *kernel-context* prevent-from-run) (-> proc mask))) (run-logic? proc))
|
|
#\r
|
|
#\\s ;; space
|
|
)
|
|
(if (and drawable-proc (logtest? (-> drawable-proc draw status) (draw-status was-drawn))) #\d #\\s)
|
|
(cond
|
|
((and drawable-proc (logtest? (-> drawable-proc draw status) (draw-status was-drawn)))
|
|
(case (-> drawable-proc draw cur-lod)
|
|
((0) #\0)
|
|
((1) #\1)
|
|
((2) #\2)
|
|
((3) #\3)
|
|
((4) #\4)))
|
|
(else #\\s))))
|
|
0
|
|
(none))
|
|
|
|
(defmethod print ((this process))
|
|
"Fancier print for process that can also print status of process drawables."
|
|
(format #t
|
|
"#<~A ~S ~A :state ~S :flags "
|
|
(-> this type)
|
|
(-> this name)
|
|
(-> this status)
|
|
(if (-> this state) (-> this state name)))
|
|
(process-status-bits this #t)
|
|
(format #t
|
|
" :stack ~D/~D :heap ~D/~D @ #x~X>"
|
|
(&- (-> this top-thread stack-top) (the-as uint (-> this top-thread sp)))
|
|
(-> this main-thread stack-size)
|
|
(- (-> this allocated-length) (&- (-> this heap-top) (the-as uint (-> this heap-cur))))
|
|
(-> this allocated-length)
|
|
this)
|
|
this)
|
|
|
|
(defmethod debug-print ((this entity-actor) (mode symbol) (expected-type type))
|
|
"Print one row of the entity debug table when this actor matches expected-type. mode controls
|
|
meter positions and the optional permanent-state detail row."
|
|
(let ((entity-type (-> this etype)))
|
|
(when (or (not expected-type) (and entity-type (valid? entity-type type #f #f 0) (type-type? entity-type expected-type)))
|
|
(format #t "~5D #x~8X ~-21S" (-> this extra vis-id) this (res-lump-struct this 'name structure))
|
|
(let ((level-name (-> this extra level nickname)))
|
|
(set! level-name
|
|
(cond
|
|
(level-name level-name)
|
|
(else (-> this extra level name))))
|
|
(format #t
|
|
"~8D ~3D ~-4S #x~4X"
|
|
(-> this extra perm aid)
|
|
(-> this extra perm task)
|
|
level-name
|
|
(-> this extra perm status)))
|
|
;; location
|
|
(if (= mode 'entity-meters)
|
|
(format #t " :trans ~14m ~14m ~14m " (-> this extra trans x) (-> this extra trans y) (-> this extra trans z))
|
|
(format #t " :trans ~14f ~14f ~14f " (-> this extra trans x) (-> this extra trans y) (-> this extra trans z)))
|
|
;; if we have an associated process, print info.
|
|
(let* ((proc (-> this extra process))
|
|
(drawable-proc (if (and (nonzero? proc) (type-type? (-> proc type) process-drawable)) proc)))
|
|
(format #t
|
|
":pr #x~8X ~-12S ~-21S ~-5S/~-5S "
|
|
(if (-> this extra process) (-> this extra process) 0)
|
|
(if (-> this extra process) (-> this extra process name) "")
|
|
(if (and (-> this extra process) (-> this extra process state)) (-> this extra process state name) "")
|
|
(if (-> this extra process)
|
|
(* (- (-> this extra process allocated-length)
|
|
(&- (-> this extra process heap-top) (the-as uint (-> this extra process heap-cur))))
|
|
8)
|
|
"")
|
|
(if (-> this extra process) (* (-> this extra process allocated-length) 8) ""))
|
|
(process-status-bits drawable-proc #t))
|
|
(format #t "~%")
|
|
(if (= mode 'entity-perm) (format #t " ~`entity-perm`P~%" (-> this extra perm)))))
|
|
(none))
|
|
|
|
(defmethod debug-print-entities ((this level-group) (mode symbol) (expected-type type))
|
|
"Print a table of active-level entities, optionally restricted to expected-type. mode selects
|
|
the ordinary table, meter-formatted positions, permanent-state details, or art-group names."
|
|
;; This table is wider than the debug screen.
|
|
(format #t
|
|
" id address name aid tsk lev status x y z address name state heap flags~%"
|
|
0
|
|
0
|
|
0)
|
|
(dotimes (level-index (-> this length))
|
|
(let ((lev (-> this level level-index)))
|
|
(when (= (-> lev status) 'active)
|
|
(case mode
|
|
(('art-group)
|
|
(format #t "level ~A~%" (-> lev name))
|
|
(dotimes (i (-> lev art-group art-group-array length))
|
|
(format #t "~T~2D ~S~%" i (-> lev art-group art-group-array i name))))
|
|
(else
|
|
(let ((links (-> lev bsp level entity)))
|
|
(dotimes (i (-> links length))
|
|
(debug-print (the-as entity-actor (-> links data i entity)) mode expected-type))))))))
|
|
0
|
|
(none))
|
|
|
|
;;;;;;;;;;;;;;;;;;
|
|
;; entity setup
|
|
;;;;;;;;;;;;;;;;;;
|
|
|
|
(defmethod add-to-level! ((this entity) (lev-group level-group) (lev level) (aid actor-id))
|
|
"Append this entity to level's entity-link array, splice the link into the level group's
|
|
circular list, copy its transform, and initialize actor ID, task, level, and visibility data."
|
|
;; grab the first free link
|
|
(let ((level-link (-> lev entity data (-> lev entity length))))
|
|
(+! (-> lev entity length) 1)
|
|
;; attach the entity to the link
|
|
(set! (-> level-link process) #f)
|
|
(set! (-> level-link entity) this)
|
|
(set! (-> this extra) level-link)
|
|
(cond
|
|
((-> lev-group entity-link)
|
|
;; add to linked list of existing
|
|
(let* ((other-prev (-> lev-group entity-link))
|
|
(other-front (-> other-prev next-link)))
|
|
(set! (-> other-prev next-link) level-link)
|
|
(set! (-> level-link prev-link) other-prev)
|
|
(set! (-> level-link next-link) other-front)
|
|
(set! (-> other-front prev-link) level-link)))
|
|
(else
|
|
;; we're the first in the level.
|
|
(set! (-> level-link prev-link) level-link)
|
|
(set! (-> level-link next-link) level-link)))
|
|
;; remember the start of the list
|
|
(set! (-> lev-group entity-link) level-link)
|
|
;; update the trans.
|
|
(set! (-> level-link trans quad) (-> this trans quad)))
|
|
;; set us up
|
|
(set! (-> this extra perm aid) aid)
|
|
(set! (-> this extra level) lev)
|
|
(cond
|
|
((= (-> this type) entity-actor)
|
|
(set! (-> (the-as entity-actor this) extra perm task) (-> (the-as entity-actor this) task))
|
|
(set! (-> (the-as entity-actor this) extra vis-id) (-> (the-as entity-actor this) vis-id-signed)))
|
|
(else (set! (-> this extra perm task) (game-task none)) (set! (-> this extra vis-id) 0) 0))
|
|
(none))
|
|
|
|
(defmethod remove-from-level! ((this entity) (group level-group))
|
|
"Unlink this entity from the level group's circular entity list and return the entity."
|
|
(let ((link (-> this extra)))
|
|
(cond
|
|
((= (-> link next-link) link) (set! (-> group entity-link) #f))
|
|
(else
|
|
(set! (-> link next-link prev-link) (-> link prev-link))
|
|
(set! (-> link prev-link next-link) (-> link next-link))
|
|
(if (= (-> group entity-link) link) (set! (-> group entity-link) (-> link prev-link))))))
|
|
this)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; visibility update
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; the visibility system is pretty simple and there is a single axis-aligned bounding box.
|
|
;; these methods are debug tools for updating these.
|
|
|
|
(defun update-actor-vis-box ((proc process-drawable) (min-pt vector) (max-pt vector))
|
|
"Expand min-point and max-point around proc's world-space draw-bounds sphere when it has draw
|
|
control."
|
|
(when (and proc (nonzero? (-> proc draw)))
|
|
;; add the draw origin offset.
|
|
(let ((world-bounds-origin (vector+! (new 'stack-no-clear 'vector) (-> proc draw origin) (-> proc draw bounds)))
|
|
(radius (-> proc draw bounds w)))
|
|
(set! (-> min-pt x) (fmin (-> min-pt x) (- (-> world-bounds-origin x) radius)))
|
|
(set! (-> min-pt y) (fmin (-> min-pt y) (- (-> world-bounds-origin y) radius)))
|
|
(set! (-> min-pt z) (fmin (-> min-pt z) (- (-> world-bounds-origin z) radius)))
|
|
(set! (-> max-pt x) (fmax (-> max-pt x) (+ (-> world-bounds-origin x) radius)))
|
|
(set! (-> max-pt y) (fmax (-> max-pt y) (+ (-> world-bounds-origin y) radius)))
|
|
(set! (-> max-pt z) (fmax (-> max-pt z) (+ (-> world-bounds-origin z) radius)))))
|
|
0
|
|
(none))
|
|
|
|
(defmethod update-vis-volumes ((this level-group))
|
|
"Expand each active entity's editable visibility box around the draw bounds of its live
|
|
process and drawable child processes. This development-only function contains a compiler
|
|
spill anomaly immediately before assigning the intended process."
|
|
(local-vars (spill-result symbol) (drawable-proc process))
|
|
(format 0 "call to update-vis-volumes, which may have a compiler bug.~%")
|
|
(dotimes (level-index (-> this length))
|
|
(let ((lev (-> this level level-index)))
|
|
(when (= (-> lev status) 'active)
|
|
(let ((links (-> lev bsp level entity)))
|
|
(dotimes (i (-> links length))
|
|
(let* ((ent (-> links data i entity))
|
|
(vis-volume (res-lump-data ent 'visvol (inline-array vector)))
|
|
(min-point (-> vis-volume 0))
|
|
(max-point (-> vis-volume 1)))
|
|
(let ((proc (-> ent extra process)))
|
|
;; I am pretty sure there is a GOAL compiler bug here.
|
|
;; the output makes zero sense, but I don't think it matters:
|
|
;; this function doesn't seem like it should ever be run outside of development
|
|
;; and the compiler bug has no effect?
|
|
(set! spill-result
|
|
(when (and (nonzero? proc) (type-type? (-> proc type) process-drawable))
|
|
;; i think it spills the wrong variable here
|
|
(set! drawable-proc (the-as process spill-result))
|
|
;; then immediate spills the right one.
|
|
(set! drawable-proc proc)
|
|
spill-result)))
|
|
(when drawable-proc
|
|
(update-actor-vis-box (the-as process-drawable drawable-proc) min-point max-point)
|
|
(let ((child-link (-> drawable-proc child)))
|
|
(while child-link
|
|
(let ((update-box update-actor-vis-box)
|
|
(child-proc (-> child-link 0)))
|
|
(update-box (the-as process-drawable (if (and (nonzero? child-proc) (type-type? (-> child-proc type) process-drawable)) child-proc))
|
|
min-point
|
|
max-point))
|
|
(set! child-link (-> child-link 0 brother)))))))))))
|
|
0
|
|
(none))
|
|
|
|
(defmethod update-vis-volumes-from-nav-mesh ((this level-group))
|
|
"Rebuild each active actor's editable visibility box from its navigation mesh, using a linked
|
|
nav-mesh actor when supplied and a six-meter box around the entity when no mesh is available."
|
|
;; loop over levels
|
|
(dotimes (level-index (-> this length))
|
|
(let ((lev (-> this level level-index)))
|
|
(when (= (-> lev status) 'active) ;; only active levels
|
|
;; loop over entities
|
|
(let ((links (-> lev bsp level entity)))
|
|
(dotimes (i (-> links length))
|
|
;; look up the bounding box.
|
|
(let* ((ent (-> links data i entity))
|
|
(vis-volume (res-lump-data ent 'visvol (inline-array vector)))
|
|
(min-point (-> vis-volume 0))
|
|
(max-point (-> vis-volume 1)))
|
|
(let ((translation (-> ent extra trans))
|
|
(nav-ent ent))
|
|
;; sometimes the nav-mesh may be in a different actor, I guess.
|
|
;; so try to look that up.
|
|
(let ((linked-nav-ent (entity-actor-lookup ent 'nav-mesh-actor 0)))
|
|
(when linked-nav-ent
|
|
(set! nav-ent linked-nav-ent)
|
|
(the-as entity-actor (the-as entity-actor nav-ent))))
|
|
(cond
|
|
((and (type-type? (-> nav-ent type) entity-actor) (nonzero? (-> (the-as entity-actor nav-ent) nav-mesh)))
|
|
;; we got a nav-mesh! compute the bounding box
|
|
(compute-bounding-box (-> (the-as entity-actor nav-ent) nav-mesh) min-point max-point))
|
|
(else
|
|
;; no nav-mesh found, just use the default position
|
|
(set! (-> min-point quad) (-> translation quad))
|
|
(set! (-> max-point quad) (-> translation quad)))))
|
|
;; add some padding to make a 6x6 meter box.
|
|
(let ((min-padding -12288.0)
|
|
(max-padding 12288.0))
|
|
(+! (-> min-point x) min-padding)
|
|
(+! (-> min-point y) min-padding)
|
|
(+! (-> min-point z) min-padding)
|
|
(+! (-> max-point x) max-padding)
|
|
(+! (-> max-point y) max-padding)
|
|
(+! (-> max-point z) max-padding))))))))
|
|
0
|
|
(none))
|
|
|
|
(define-extern money type)
|
|
|
|
(define-extern crate type)
|
|
|
|
(define-extern springbox type)
|
|
|
|
(define-extern fuel-cell type)
|
|
|
|
(defmethod print-volume-sizes ((this level-group))
|
|
"Print each ordinary active actor's visibility distance and box extents relative to its
|
|
origin, excluding money, crates, fuel cells, and springboxes."
|
|
(local-vars (entity-type type))
|
|
(dotimes (level-index (-> this length))
|
|
(let ((lev (-> this level level-index)))
|
|
(when (= (-> lev status) 'active)
|
|
(let ((links (-> lev bsp level entity)))
|
|
(dotimes (i (-> links length))
|
|
;; lookup volume and dist.
|
|
(let* ((ent (-> links data i entity))
|
|
(vis-volume (the-as object (res-lump-data ent 'visvol pointer)))
|
|
(vis-distance (res-lump-float ent 'vis-dist :default 409600.0))
|
|
(translation (-> ent extra trans)))
|
|
(set! entity-type
|
|
(cond
|
|
((type-type? (-> ent type) entity-actor) (set! entity-type (-> (the-as entity-actor ent) etype)) entity-type)
|
|
(else (the-as type #f))))
|
|
(let ((min-point (-> (the-as (inline-array vector) vis-volume) 0))
|
|
(max-point (-> (the-as (inline-array vector) vis-volume) 1)))
|
|
(when (not (or (name= entity-type money)
|
|
(or (name= entity-type crate) (name= entity-type fuel-cell) (name= entity-type springbox))))
|
|
(format #t "actor-vis ~S ~6,,1M " (res-lump-struct ent 'name basic) vis-distance)
|
|
(format #t
|
|
"~6,,1M ~6,,1M ~6,,1M ~6,,1M ~6,,1M ~6,,1M~%"
|
|
(- (-> min-point x) (-> translation x))
|
|
(- (-> min-point y) (-> translation y))
|
|
(- (-> min-point z) (-> translation z))
|
|
(- (-> max-point x) (-> translation x))
|
|
(- (-> max-point y) (-> translation y))
|
|
(- (-> max-point z) (-> translation z)))))))))))
|
|
0
|
|
(none))
|
|
|
|
(defun expand-vis-box-with-point ((ent entity) (point vector))
|
|
"Expand entity's editable visibility box to contain point when the entity has visvol data."
|
|
(let ((vis-volume (res-lump-data ent 'visvol (inline-array vector))))
|
|
(when vis-volume
|
|
(let ((min-point (-> vis-volume 0))
|
|
(max-point (-> vis-volume 1)))
|
|
(set! (-> min-point x) (fmin (-> min-point x) (-> point x)))
|
|
(set! (-> min-point y) (fmin (-> min-point y) (-> point y)))
|
|
(set! (-> min-point z) (fmin (-> min-point z) (-> point z)))
|
|
(set! (-> max-point x) (fmax (-> max-point x) (-> point x)))
|
|
(set! (-> max-point y) (fmax (-> max-point y) (-> point y)))
|
|
(set! (-> max-point z) (fmax (-> max-point z) (-> point z))))))
|
|
0
|
|
(none))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; The Debug Draw Method
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defmethod debug-draw-actors ((this level-group) (mode symbol))
|
|
"Draw the enabled entity, process, visibility-volume, animation, navigation, path, and volume
|
|
diagnostics for active levels. mode selects process-only markers, all entities, or the
|
|
ordinary live-entity display."
|
|
(when (and mode (not (or (= *master-mode* 'menu) (= *master-mode* 'progress))))
|
|
(dotimes (level-index (-> this length))
|
|
(let ((lev (-> this level level-index)))
|
|
(when (= (-> lev status) 'active)
|
|
(let ((links (-> lev bsp level entity)))
|
|
(dotimes (i (-> links length))
|
|
(let* ((ent (-> links data i entity))
|
|
(translation (-> ent extra trans)))
|
|
(cond
|
|
((and (= mode 'process) (-> ent extra process) (type-type? (-> ent extra process type) process-drawable))
|
|
(let ((drawable-proc (the-as process-drawable (-> ent extra process))))
|
|
(add-debug-x #t
|
|
(bucket-id debug-no-zbuf)
|
|
(-> drawable-proc root trans)
|
|
(new 'static 'rgba :r #x80 :g #xff :b #x80 :a #x80))
|
|
(add-debug-text-3d #t
|
|
(bucket-id debug-no-zbuf)
|
|
(res-lump-struct ent 'name string)
|
|
(-> drawable-proc root trans)
|
|
(font-color white)
|
|
(new 'static 'vector2h :y 8))
|
|
(add-debug-text-3d #t
|
|
(bucket-id debug-no-zbuf)
|
|
(symbol->string (-> drawable-proc state name))
|
|
(-> drawable-proc root trans)
|
|
(font-color white)
|
|
(new 'static 'vector2h :y 16))
|
|
(let ((eco-info (res-lump-data (-> drawable-proc entity) 'eco-info (pointer int32) :time 0.0)))
|
|
(when eco-info
|
|
(let ((draw-text add-debug-text-3d)
|
|
(enabled #t)
|
|
(debug-bucket 68))
|
|
(format (clear *temp-string*) "~S ~D~%" (pickup-type->string (the-as pickup-type (-> eco-info 0))) (-> eco-info 1))
|
|
(draw-text enabled
|
|
(the-as bucket-id debug-bucket)
|
|
*temp-string*
|
|
(-> drawable-proc root trans)
|
|
(font-color white)
|
|
(new 'static 'vector2h :y 24)))))
|
|
(let ((art-name (res-lump-struct (-> drawable-proc entity) 'art-name symbol)))
|
|
(if (and (the-as structure art-name) (= (-> art-name type) symbol))
|
|
(add-debug-text-3d #t
|
|
(bucket-id debug-no-zbuf)
|
|
(symbol->string art-name)
|
|
(-> drawable-proc root trans)
|
|
(font-color white)
|
|
(new 'static 'vector2h :y 24))))))
|
|
((or (= mode 'full) (-> ent extra process))
|
|
(add-debug-x #t
|
|
(bucket-id debug-no-zbuf)
|
|
translation
|
|
(if (-> ent extra process) (new 'static 'rgba :r #x80 :g #xff :b #x80 :a #x80) (new 'static 'rgba :r #xff :a #x80)))
|
|
(let ((draw-text add-debug-text-3d)
|
|
(enabled #t)
|
|
(debug-bucket 68))
|
|
(draw-text enabled
|
|
(the-as bucket-id debug-bucket)
|
|
(res-lump-struct ent 'name string)
|
|
translation
|
|
(if (logtest? (-> ent extra perm status) (entity-perm-status birth-blocked error)) (font-color white) (font-color yellow))
|
|
(new 'static 'vector2h :y 8))))))))))))
|
|
(when (and *display-actor-vis* (not (or *display-actor-anim* *display-process-anim*)))
|
|
(let ((vis-mode *display-actor-vis*))
|
|
(dotimes (level-index (-> this length))
|
|
(let ((lev (-> this level level-index)))
|
|
(when (= (-> lev status) 'active)
|
|
(let ((links (-> lev bsp level entity)))
|
|
(dotimes (i (-> links length))
|
|
(let ((ent (-> links data i entity)))
|
|
(let ((vis-volume (res-lump-data ent 'visvol pointer))
|
|
(vis-id (-> ent extra vis-id)))
|
|
(when (and vis-volume (or (= vis-mode #t) (= vis-mode 'box)))
|
|
(let ((draw-box add-debug-box)
|
|
(enabled #t)
|
|
(debug-bucket 68)
|
|
(min-point (&+ vis-volume 0))
|
|
(max-point (&+ vis-volume 16)))
|
|
(draw-box enabled
|
|
(the-as bucket-id debug-bucket)
|
|
(the-as vector min-point)
|
|
(the-as vector max-point)
|
|
(if (is-object-visible? lev vis-id) (new 'static 'rgba :g #x80 :b #x80 :a #x80) (new 'static 'rgba :r #x80 :b #x80 :a #x80))))))
|
|
(when (or (= vis-mode #t) (= vis-mode 'sphere))
|
|
(let ((proc (-> ent extra process)))
|
|
(when proc
|
|
(when (and (type-type? (-> proc type) process-drawable) (nonzero? (-> (the-as process-drawable proc) draw)))
|
|
(add-debug-x #t
|
|
(bucket-id debug-no-zbuf)
|
|
(-> (the-as process-drawable proc) root trans)
|
|
(new 'static 'rgba :r #xff :g #xff :b #xff :a #x80))
|
|
(add-debug-sphere #t
|
|
(bucket-id debug)
|
|
(vector+! (new 'stack-no-clear 'vector)
|
|
(-> (the-as process-drawable proc) draw origin)
|
|
(-> (the-as process-drawable proc) draw bounds))
|
|
(-> (the-as process-drawable proc) draw bounds w)
|
|
(new 'static 'rgba :r #x80 :a #x80))))))))))))))
|
|
(if *generate-actor-vis* (update-vis-volumes this))
|
|
(when (or *display-actor-anim* *display-process-anim*)
|
|
(let ((selected-proc (ppointer->process *display-process-anim*)))
|
|
(if (not selected-proc) (set! selected-proc (process-by-name *display-actor-anim* *active-pool*)))
|
|
(when (and selected-proc (type-type? (-> selected-proc type) process-drawable))
|
|
(let ((selected-ent (-> (the-as process-drawable selected-proc) entity))
|
|
(translation (-> (the-as process-drawable selected-proc) root trans)))
|
|
(when selected-ent
|
|
(add-debug-x #t
|
|
(bucket-id debug-no-zbuf)
|
|
translation
|
|
(if (-> selected-ent extra process) (new 'static 'rgba :r #x80 :g #xff :b #x80 :a #x80) (new 'static 'rgba :r #xff :a #x80)))
|
|
(add-debug-text-3d #t
|
|
(bucket-id debug-no-zbuf)
|
|
(res-lump-struct selected-ent 'name string)
|
|
translation
|
|
(if (logtest? (-> selected-ent extra perm status) (entity-perm-status birth-blocked error))
|
|
(font-color white)
|
|
(font-color white))
|
|
(new 'static 'vector2h :y 8))
|
|
(add-debug-text-3d #t
|
|
(bucket-id debug-no-zbuf)
|
|
(symbol->string (-> (the-as process-drawable selected-proc) state name))
|
|
translation
|
|
(font-color white)
|
|
(new 'static 'vector2h :y 16))))
|
|
(if (nonzero? (-> (the-as process-drawable selected-proc) skel))
|
|
(debug-print-channels (-> (the-as process-drawable selected-proc) skel) (the-as symbol *stdcon*)))
|
|
(if (nonzero? (-> (the-as process-drawable selected-proc) nav))
|
|
(debug-draw (-> (the-as process-drawable selected-proc) nav)))
|
|
(if (nonzero? (-> (the-as process-drawable selected-proc) path))
|
|
(debug-draw (-> (the-as process-drawable selected-proc) path)))
|
|
(if (nonzero? (-> (the-as process-drawable selected-proc) vol)) (init! (-> (the-as process-drawable selected-proc) vol))))
|
|
(if (and (the-as process-drawable selected-proc)
|
|
(type-type? (-> (the-as process-drawable selected-proc) type) process-drawable)
|
|
(nonzero? (-> (the-as process-drawable selected-proc) draw))
|
|
*display-actor-vis*)
|
|
(add-debug-sphere #t
|
|
(bucket-id debug)
|
|
(vector+! (new 'stack-no-clear 'vector)
|
|
(-> (the-as process-drawable selected-proc) draw origin)
|
|
(-> (the-as process-drawable selected-proc) draw bounds))
|
|
(-> (the-as process-drawable selected-proc) draw bounds w)
|
|
(new 'static 'rgba :r #x80 :a #x80))))
|
|
(when (and *display-actor-vis* *display-actor-anim*)
|
|
(let ((selected-ent (entity-by-name *display-actor-anim*)))
|
|
(when selected-ent
|
|
(let ((vis-volume (res-lump-data selected-ent 'visvol pointer))
|
|
(vis-id (-> selected-ent extra vis-id)))
|
|
(if vis-volume
|
|
(add-debug-box #t
|
|
(bucket-id debug-no-zbuf)
|
|
(the-as vector (&+ vis-volume 0))
|
|
(the-as vector (&+ vis-volume 16))
|
|
(if (is-object-visible? (-> selected-ent extra level) vis-id)
|
|
(new 'static 'rgba :g #x80 :b #x80 :a #x80)
|
|
(new 'static 'rgba :r #x80 :b #x80 :a #x80)))))))))
|
|
(if (and (or *display-nav-marks* *display-path-marks* *display-vol-marks*)
|
|
(not (or *display-actor-anim* *display-process-anim*)))
|
|
(iterate-process-tree *active-pool*
|
|
(lambda ((proc process-drawable))
|
|
(when (type-type? (-> proc type) process-drawable)
|
|
(if (nonzero? (-> proc nav)) (debug-draw (-> proc nav)))
|
|
(if (nonzero? (-> proc path)) (debug-draw (-> proc path)))
|
|
(if (nonzero? (-> proc vol)) (init! (-> proc vol))))
|
|
(none))
|
|
*null-kernel-context*))
|
|
#|
|
|
This is where the "actor graph" is drawn, but the plot functions don't do anything.
|
|
(when (and *display-actor-graph* (not (or (= *master-mode* 'menu) (= *master-mode* 'progress))))
|
|
(if (not (paused?))
|
|
(float-save-timeplot (if (< (the int (the float (mod (-> *display* base-frame-counter) 600))) 300)
|
|
1.0
|
|
0.0
|
|
)
|
|
)
|
|
)
|
|
(camera-plot-float-func 0.0 399.0 -81920.0 81920.0 float-lookup-redline (new 'static 'vector4w :x #xff :w #x80))
|
|
(camera-plot-float-func 0.0 399.0 -81920.0 81920.0 float-lookup-blueline (new 'static 'vector4w :z #xff :w #x80))
|
|
(camera-plot-float-func 0.0 399.0 -81920.0 81920.0 float-lookup-greenline (new 'static 'vector4w :y #xff :w #x80))
|
|
(camera-plot-float-func 0.0 399.0 0.0 409600.0 float-lookup-yellowline (new 'static 'vector4w :x #xff :y #xff :w #x80))
|
|
(camera-plot-float-func 0.0 399.0 0.0 1.0 float-lookup-timeplot (new 'static 'vector4w :x #x80 :y #x80 :z #x80 :w #x80))
|
|
)
|
|
|#
|
|
(when *display-split-boxes*
|
|
(dotimes (level-index (-> this length))
|
|
(let ((lev (-> this level level-index)))
|
|
(when (= (-> lev status) 'active)
|
|
(when (nonzero? (-> lev bsp boxes))
|
|
(let ((boxes (-> lev bsp boxes)))
|
|
(countdown (i (-> boxes length))
|
|
(add-debug-box #t
|
|
(bucket-id debug)
|
|
(-> boxes data i min)
|
|
(the-as vector (+ (the-as uint (-> boxes data 0 max)) (* i 32)))
|
|
(if (zero? (-> lev index)) (new 'static 'rgba :g #x80 :b #x80 :a #x80) (new 'static 'rgba :r #xff :g #x80 :b #x80 :a #x80))))))))))
|
|
(when (or *display-ambient-hint-marks*
|
|
*display-ambient-sound-marks*
|
|
*display-ambient-poi-marks*
|
|
*display-ambient-light-marks*
|
|
*display-ambient-dark-marks*
|
|
*display-ambient-weather-off-marks*
|
|
*display-ambient-ocean-off-marks*
|
|
*display-ambient-ocean-near-off-marks*
|
|
*display-ambient-music-marks*)
|
|
(dotimes (level-index (-> this length))
|
|
(let ((lev (-> this level level-index)))
|
|
(when (= (-> lev status) 'active)
|
|
(let ((ambients (-> lev bsp ambients)))
|
|
(when (nonzero? ambients)
|
|
(dotimes (i (-> ambients length))
|
|
(draw-debug (-> ambients data i ambient)))))))))
|
|
0
|
|
(none))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Camera Birthing
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defmethod birth! ((this entity-camera))
|
|
"Connect this camera entity to the camera engine."
|
|
(add-connection *camera-engine* *camera* nothing this #f #f)
|
|
this)
|
|
|
|
(defmethod kill! ((this entity-camera))
|
|
"Remove this camera entity's connection from the camera engine."
|
|
(remove-by-param1 *camera-engine* this)
|
|
this)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Actor Birthing
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defmacro birth-log (str &rest args)
|
|
"Debug print to stdout of runtime for debugging actor inits."
|
|
`(format 0 ,(string-append "[BIRTH] " str) ,@args)
|
|
;;`(empty)
|
|
)
|
|
|
|
(defun init-entity ((proc process) (ent entity-actor) (entity-type type))
|
|
"Activate proc in the entity pool, connect it to actor, and run its init-from-entity! method
|
|
immediately before the process enters ordinary scheduling. Callers pass proc's installed type as
|
|
entity-type, although this implementation does not read it."
|
|
;;(birth-log "(init-entity ~A)~%" ent)
|
|
;; activate the process. It goes in the entity-pool, which is a child of the main active-pool.
|
|
(activate proc *entity-pool* (res-lump-struct ent 'name basic) (the-as pointer #x70004000))
|
|
;; link the entity and the process
|
|
(set! (-> proc entity) ent)
|
|
(set! (-> ent extra process) proc)
|
|
;;(birth-log "activated: ~A ~A, now doing init ~A~%" proc ent (method-of-object proc init-from-entity!))
|
|
;; run the initializer
|
|
(run-now-in-process proc (method-of-object proc init-from-entity!) proc ent)
|
|
(none))
|
|
|
|
;; Fallback for displaying art whose declared process type is unavailable.
|
|
(define-extern birth-viewer
|
|
"Use the viewer fallback for an entity whose declared process type is unavailable. Retype proc as
|
|
viewer, initialize it through the ordinary entity path, and return true."
|
|
(function process entity-actor symbol))
|
|
|
|
(defmacro this-etype? (&rest types)
|
|
`(or ,@(apply (lambda (x) `(begin (define-extern ,x type) (type-type? (-> this etype) ,x))) types)))
|
|
|
|
(defmethod birth! ((this entity-actor))
|
|
"Obtain a process of this actor's declared type and initialize it from the entity. Mark birth
|
|
blocked when neither the normal initializer nor the viewer fallback accepts the process."
|
|
;; temp
|
|
;; (when (or (not (this-etype? process))
|
|
;; ;disallowed types
|
|
;; ;(this-etype?)
|
|
;; (zero? (-> this etype)))
|
|
;; (when (nonzero? (-> this etype))
|
|
;; (birth-log "rejecting etype ~A birth~%" (-> this etype))
|
|
;; )
|
|
;; (logior! (-> this extra perm status) (entity-perm-status birth-blocked))
|
|
;; (return this)
|
|
;; )
|
|
;;(birth-log "call to birth! on ~A~%" this)
|
|
(let* ((entity-type (-> this etype))
|
|
(info (entity-info-lookup entity-type))
|
|
(entity-process (get-process *default-dead-pool* entity-type (if info (-> info heap-size) #x4000))))
|
|
(cond
|
|
((not entity-process) (birth-log "could not birth because there is no process.~%"))
|
|
((begin
|
|
(set! (-> entity-process type) entity-type)
|
|
(and entity-type
|
|
(valid? entity-type type #f #f 0)
|
|
(valid? (method-of-object entity-process init-from-entity!) function #f #f 0)))
|
|
(init-entity entity-process this entity-type))
|
|
(else
|
|
(when (not (birth-viewer entity-process this))
|
|
(format 0 "ERROR: no proper process type named ~A exists in the code, could not start ~A~%" entity-type this)
|
|
(logior! (-> this extra perm status) (entity-perm-status birth-blocked))))))
|
|
this)
|
|
|
|
(defun entity-deactivate-handler ((proc process) (actor entity-actor))
|
|
"When proc is still actor's live process, clear its error and no-kill status and disconnect it
|
|
from the entity."
|
|
(when (= proc (-> actor extra process))
|
|
(logclear! (-> actor extra perm status) (entity-perm-status error no-kill))
|
|
(set! (-> actor extra process) #f))
|
|
(none))
|
|
|
|
(defmethod kill! ((this entity-actor))
|
|
"Deactivate this actor's live process, or clear its stale entity link when no process exists."
|
|
(let ((proc (-> this extra process))) (if proc (deactivate proc) (entity-deactivate-handler proc this)))
|
|
this)
|
|
|
|
(defmethod birth ((this bsp-header))
|
|
"Allocate or validate the level's entity and ambient tables, add actors in birth-order,
|
|
initialize ambient payloads, and connect every camera. Actor process creation is deferred
|
|
across later frames."
|
|
(local-vars (birth-start-cycles int) (birth-end-cycles int))
|
|
(#unless PC_PORT
|
|
(m birth-start-cycles Count))
|
|
;; how many actors do we need?
|
|
(let ((actor-count (if (nonzero? (-> this actors)) (-> this actors length) 0)))
|
|
(cond
|
|
((not (-> this level entity))
|
|
;; we don't have an array of entity-links. allocate one.
|
|
(set! (-> this level entity) (new 'loading-level 'entity-links-array actor-count)))
|
|
((< (-> this level entity allocated-length) actor-count)
|
|
;; we do, but it's not big enough. Complain.
|
|
(format 0
|
|
"ERROR: Attempting to rebirth level ~A with incorrect entity table size ~D/~D~%"
|
|
(-> this level)
|
|
actor-count
|
|
(-> this level entity allocated-length)))))
|
|
;; reset our entity links array to 0.
|
|
(set! (-> this level entity length) 0)
|
|
;; NOTE: we don't actually birth the actors. It is too slow.
|
|
;; so it gets spread over multiple frames later.
|
|
(when (nonzero? (-> this actors))
|
|
(dotimes (birth-idx (-> this actors length))
|
|
(let* ((idx-to-birth (-> this actor-birth-order birth-idx))
|
|
(actor-to-birth (-> this actors data (logand idx-to-birth #xffff) actor)))
|
|
(add-to-level! actor-to-birth *level* (-> this level) (the-as actor-id (-> actor-to-birth aid))))))
|
|
(let ((existing-amb-count (if (nonzero? (-> this ambients)) (-> this ambients length) 0)))
|
|
(cond
|
|
((not (-> this level ambient))
|
|
(set! (-> this level ambient) (new 'loading-level 'entity-ambient-data-array existing-amb-count)))
|
|
((< (-> this level ambient allocated-length) existing-amb-count)
|
|
(format 0
|
|
"ERROR: Attempting to rebirth level ~A with incorrect ambient table size ~D/~D~%"
|
|
(-> this level)
|
|
existing-amb-count
|
|
(-> this level ambient allocated-length)))))
|
|
(set! (-> this level ambient length) 0)
|
|
0
|
|
(let ((amb-array (-> this level ambient))
|
|
(bsp-ambs (-> this ambients)))
|
|
(when (nonzero? bsp-ambs)
|
|
(dotimes (i (-> bsp-ambs length))
|
|
(let ((amb-to-birth (-> bsp-ambs data i ambient)))
|
|
(set! (-> amb-to-birth ambient-data) (-> amb-array data (-> amb-array length)))
|
|
(birth-ambient! amb-to-birth))
|
|
(+! (-> amb-array length) 1))))
|
|
(let ((cams (-> this cameras))) (when (nonzero? cams) (dotimes (i (-> cams length)) (birth! (-> cams i)))))
|
|
(#unless PC_PORT
|
|
(m birth-end-cycles Count)
|
|
(format 0 "Done ~S in ~D~%" "birth" (- birth-end-cycles birth-start-cycles)))
|
|
(none))
|
|
|
|
(defmethod deactivate-entities ((this bsp-header))
|
|
"Kill and unlink this BSP's actors and cameras, then deactivate any remaining entity,
|
|
particle, or drawable process that still references the level heap being released."
|
|
(let ((actors (-> this actors)))
|
|
(when (nonzero? actors)
|
|
(dotimes (i (-> actors length))
|
|
(let ((actor (-> actors data i actor))) (kill! actor) (remove-from-level! actor *level*)))))
|
|
(let ((cameras (-> this cameras))) (when (nonzero? cameras) (dotimes (i (-> cameras length)) (kill! (-> cameras i)))))
|
|
(let ((child-link (-> *entity-pool* child))
|
|
(heap-base (-> this level heap base))
|
|
(heap-end (-> this level heap top-base)))
|
|
(while child-link
|
|
(let ((proc (ppointer->process child-link)))
|
|
(set! child-link (-> child-link 0 brother))
|
|
(cond
|
|
((-> (the-as process proc) entity)
|
|
(when (= (-> (the-as process proc) entity extra level) (-> this level))
|
|
(format #t "NOTICE: rogue level entity ~A~% still alive~%" proc)
|
|
(deactivate proc)))
|
|
((= (-> proc type) part-tracker)
|
|
(let ((tracker (the-as part-tracker proc)))
|
|
(if (and (nonzero? (-> tracker part))
|
|
(>= (the-as int (-> tracker part group)) (the-as int heap-base))
|
|
(< (the-as int (-> tracker part group)) (the-as int heap-end)))
|
|
(deactivate proc))))
|
|
(else
|
|
(let* ((candidate proc)
|
|
(drawable-proc (if (and (nonzero? candidate) (type-type? (-> candidate type) process-drawable)) candidate)))
|
|
(when drawable-proc
|
|
(cond
|
|
((and (nonzero? (-> (the-as process-drawable drawable-proc) part))
|
|
(>= (the-as int (-> (the-as process-drawable drawable-proc) part group)) (the-as int heap-base))
|
|
(< (the-as int (-> (the-as process-drawable drawable-proc) part group)) (the-as int heap-end)))
|
|
(format #t
|
|
"NOTICE: rogue null level entity (using part ~A) ~A~% still alive~%"
|
|
(-> (the-as process-drawable (-> (the-as process-drawable drawable-proc) part)) brother)
|
|
proc)
|
|
(deactivate proc))
|
|
((and (nonzero? (-> (the-as process-drawable drawable-proc) draw))
|
|
(>= (the-as int (-> (the-as process-drawable drawable-proc) draw art-group)) (the-as int heap-base))
|
|
(< (the-as int (-> (the-as process-drawable drawable-proc) draw art-group)) (the-as int heap-end)))
|
|
(format #t
|
|
"NOTICE: rogue null level entity (using art ~A) ~A~% still alive~%"
|
|
(-> (the-as process-drawable (-> (the-as process-drawable drawable-proc) draw)) mask)
|
|
proc)
|
|
(deactivate proc))))))))))
|
|
(none))
|
|
|
|
(defun process-drawable-from-entity! ((proc process-drawable) (actor entity-actor))
|
|
"Mark proc as actor-pausable and initialize its root translation, rotation, and unit scale from
|
|
actor."
|
|
(logior! (-> proc mask) (process-mask actor-pause))
|
|
(vector-copy! (-> proc root trans) (-> actor extra trans))
|
|
(quaternion-copy! (-> proc root quat) (-> actor quat))
|
|
(vector-identity! (-> proc root scale))
|
|
(none))
|
|
|
|
(defmethod update-perm! ((this entity-perm) (mode symbol) (clear-mask entity-perm-status))
|
|
"Clear permanent status for reset mode. game clears clear-mask. Other task records always
|
|
clear birth-blocked, error, and suppress-birth; non-task records clear clear-mask. A record
|
|
with respawn-on-reload also clears dead, no-kill, and suppress-birth. Clear user data unless
|
|
it was explicitly supplied by a cstage."
|
|
(cond
|
|
((= mode 'game) (logclear! (-> this status) clear-mask))
|
|
((nonzero? (-> this task))
|
|
(logclear! (-> this status) (logior (if (logtest? (-> this status) (entity-perm-status respawn-on-reload)) 524 0) 515)))
|
|
(else
|
|
(logclear! (-> this status)
|
|
(logior clear-mask (if (logtest? (-> this status) (entity-perm-status respawn-on-reload)) 524 0)))))
|
|
(when (not (logtest? (-> this status) (entity-perm-status user-set-from-cstage)))
|
|
(set! (-> this user-uint64) (the-as uint 0))
|
|
0)
|
|
this)
|
|
|
|
(defun reset-actors ((mode symbol))
|
|
"Kill active actors, clear reset-specific permanent status and user data in level and game-state
|
|
permission tables, deactivate remaining entity-pool processes, and restore the actor birth
|
|
budget. game also resets task control."
|
|
(local-vars (i int))
|
|
(set! *display-process-anim* (the-as (pointer process) #f))
|
|
(let* ((reset-mode mode)
|
|
(clear-mask (cond
|
|
((or (= reset-mode 'life) (= reset-mode 'debug)) 623)
|
|
((= reset-mode 'try) 623)
|
|
((= reset-mode 'game) 1919)
|
|
(else 1663)))
|
|
(game-state *game-info*))
|
|
(dotimes (level-index (-> *level* length))
|
|
(let ((lev (-> *level* level level-index)))
|
|
(when (= (-> lev status) 'active)
|
|
(let ((links (-> lev bsp level entity)))
|
|
(set! i 0)
|
|
(while (< i (-> links length))
|
|
(let ((ent (-> links data i entity)))
|
|
(kill! ent)
|
|
(update-perm! (-> ent extra perm) mode (the-as entity-perm-status clear-mask)))
|
|
(+! i 1))))))
|
|
(let ((task-perms (-> game-state task-perm-list)))
|
|
(set! i 0)
|
|
(while (< i (-> task-perms length))
|
|
(update-perm! (-> task-perms data i) mode (the-as entity-perm-status clear-mask))
|
|
(+! i 1))
|
|
(logior! (-> task-perms data 1 status) (entity-perm-status real-complete)))
|
|
(let ((perms (-> game-state perm-list)))
|
|
(set! i 0)
|
|
(while (< i (-> perms length))
|
|
(update-perm! (-> perms data i) mode (the-as entity-perm-status clear-mask))
|
|
(+! i 1))))
|
|
(iterate-process-tree *entity-pool* (lambda ((proc process-drawable)) (deactivate proc) (none)) *null-kernel-context*)
|
|
(if (= mode 'game) (task-control-reset mode))
|
|
(set! (-> *ACTOR-bank* birth-max) 1000)
|
|
0
|
|
(none))
|
|
|
|
(defun reset-cameras ()
|
|
"Remove every camera-engine connection, then reconnect all cameras from active levels."
|
|
(remove-all *camera-engine*)
|
|
(dotimes (level-index (-> *level* length))
|
|
(let ((lev (-> *level* level level-index)))
|
|
(when (= (-> lev status) 'active)
|
|
(let ((cameras (-> lev bsp cameras)))
|
|
(when (nonzero? cameras)
|
|
(dotimes (i (-> cameras length))
|
|
(birth! (-> cameras i))))))))
|
|
0
|
|
(none))
|
|
|
|
(defmethod run-logic? ((this process-drawable))
|
|
"Return whether this actor should run logic despite actor-pause: it is close enough to the
|
|
camera, changing skeleton channels, or explicitly requesting draw updates without skeleton
|
|
updates."
|
|
(or (not (logtest? (-> this mask) (process-mask actor-pause)))
|
|
(or (>= (+ (-> *ACTOR-bank* pause-dist) (-> this root pause-adjust-distance))
|
|
(vector-vector-distance (-> this root trans) (math-camera-pos)))
|
|
(and (nonzero? (-> this skel)) (!= (-> this skel root-channel 0) (-> this skel channel)))
|
|
(and (nonzero? (-> this draw)) (logtest? (-> this draw status) (draw-status no-skeleton-update))))))
|
|
|
|
(defmethod birth? ((this entity-links) (camera-position vector))
|
|
"Return true when this entity is not birth-blocked or dead and lies within the actor birth
|
|
distance of camera-position."
|
|
(and (not (logtest? (-> this perm status) (entity-perm-status birth-blocked dead)))
|
|
(< (vector-vector-distance (-> this trans) camera-position) (-> *ACTOR-bank* birth-dist))))
|
|
|
|
(defmethod actors-update ((this level-group))
|
|
"Compact actor process pools, adapt the pause distance and per-frame birth budget to frame
|
|
time, then birth or kill active-level actors according to each level's display mode,
|
|
visibility, distance, permanent status, and available actor memory."
|
|
(when *compact-actors*
|
|
(if (and (= *compact-actors* 'debug) (= (-> *nk-dead-pool* alive-list prev) (-> *nk-dead-pool* first-gap)))
|
|
(churn *nk-dead-pool* 1))
|
|
(if (nonzero? *debug-dead-pool*) (compact *debug-dead-pool* 10))
|
|
(compact *nk-dead-pool*
|
|
(the int (lerp-scale 8.0 1.0 (the float (-> *display* frames (-> *display* last-screen) frame run-time)) 2000.0 8000.0))))
|
|
(when (not (paused?))
|
|
(let ((frame-time (-> *display* frames (-> *display* last-screen) frame run-time)))
|
|
(let ((target-pause-distance (fmax 327680.0 (fmin (+ 327680.0 (* 204.8 (the float (- 7000 frame-time)))) (-> *ACTOR-bank* birth-dist)))))
|
|
(seek! (-> *ACTOR-bank* pause-dist) target-pause-distance (* 81920.0 (seconds-per-frame))))
|
|
(seekl! (-> *ACTOR-bank* birth-max) (the int (lerp-scale 25.0 1.0 (the float frame-time) 2000.0 7000.0)) 10))
|
|
(if (movie?) (set! (-> *ACTOR-bank* birth-max) 1000)))
|
|
(when *spawn-actors*
|
|
(let ((camera-position (camera-pos))
|
|
(actor-changes 0))
|
|
(dotimes (level-index (-> this length))
|
|
(let ((lev (-> this level level-index)))
|
|
(when (= (-> lev status) 'active)
|
|
(cond
|
|
((= (-> lev display?) 'special)
|
|
(let* ((links (-> lev entity))
|
|
(link-count (-> links length)))
|
|
(dotimes (i link-count)
|
|
(let ((link (-> links data i)))
|
|
(cond
|
|
((logtest? (-> link perm status) (entity-perm-status force-birth))
|
|
(when (not (or (-> link process) (logtest? (-> link perm status) (entity-perm-status birth-blocked dead))))
|
|
(birth! (-> link entity))
|
|
(+! actor-changes 1)
|
|
(if (>= actor-changes (-> *ACTOR-bank* birth-max)) (return (the-as object #f)))))
|
|
(else
|
|
(if (and (-> link process) (not (logtest? (-> link perm status) (entity-perm-status no-kill)))) (kill! (-> link entity)))))))))
|
|
((= (-> lev display?) 'special-vis)
|
|
(let* ((links (-> lev entity))
|
|
(link-count (-> links length)))
|
|
(dotimes (i link-count)
|
|
(let ((link (-> links data i)))
|
|
(cond
|
|
((and (logtest? (-> link perm status) (entity-perm-status force-birth)) (is-object-visible? lev (-> link vis-id)))
|
|
(when (not (or (-> link process) (logtest? (-> link perm status) (entity-perm-status birth-blocked dead))))
|
|
(birth! (-> link entity))
|
|
(+! actor-changes 1)))
|
|
(else
|
|
(when (and (-> link process) (not (logtest? (-> link perm status) (entity-perm-status no-kill))))
|
|
(kill! (-> link entity))
|
|
(+! actor-changes 1)))))
|
|
(if (>= actor-changes (-> *ACTOR-bank* birth-max)) (return (the-as object #f))))))
|
|
((= (-> lev display?) 'actor)
|
|
(let* ((links (-> lev entity))
|
|
(link-count (-> links length)))
|
|
(dotimes (i link-count)
|
|
(let ((link (-> links data i)))
|
|
(cond
|
|
(#t
|
|
(when (not (or (-> link process) (logtest? (-> link perm status) (entity-perm-status birth-blocked dead))))
|
|
(birth! (-> link entity))
|
|
(+! actor-changes 1)
|
|
(if (>= actor-changes (-> *ACTOR-bank* birth-max)) (return (the-as object #f)))))
|
|
(else
|
|
(if (and (-> link process) (not (logtest? (-> link perm status) (entity-perm-status no-kill)))) (kill! (-> link entity)))))))))
|
|
((not *vis-actors*)
|
|
(let* ((links (-> lev entity))
|
|
(link-count (-> links length)))
|
|
(dotimes (i link-count)
|
|
(let ((link (-> links data i)))
|
|
(cond
|
|
((and (< (vector-vector-distance (-> link trans) camera-position) (-> *ACTOR-bank* birth-dist))
|
|
(not (logtest? (-> link perm status) (entity-perm-status suppress-birth suppress-birth-2))))
|
|
(when (not (or (-> link process) (logtest? (-> link perm status) (entity-perm-status birth-blocked dead))))
|
|
(birth! (-> link entity))
|
|
(+! actor-changes 1)
|
|
(if (>= actor-changes (-> *ACTOR-bank* birth-max)) (return (the-as object #f)))))
|
|
(else
|
|
(if (and (-> link process) (not (logtest? (-> link perm status) (entity-perm-status no-kill)))) (kill! (-> link entity)))))))))
|
|
(*vis-actors*
|
|
(when (not (and (-> lev vis-info 0) (-> lev all-visible?)))
|
|
(let* ((links (-> lev entity))
|
|
(link-count (-> links length))
|
|
(low-memory? #f))
|
|
(dotimes (i link-count)
|
|
(let ((link (-> links data i)))
|
|
(cond
|
|
;; og:preserve-this check for actor culling setting
|
|
((and (#if PC_PORT
|
|
(or (with-pc (not (-> *pc-settings* ps2-actor-vis?))) (is-object-visible? lev (-> link vis-id)))
|
|
(is-object-visible? lev (-> link vis-id)))
|
|
(not (logtest? (-> link perm status) (entity-perm-status suppress-birth suppress-birth-2))))
|
|
(when (not (or (-> link process) (logtest? (-> link perm status) (entity-perm-status birth-blocked dead)) low-memory?))
|
|
(birth! (-> link entity))
|
|
(+! actor-changes 1)
|
|
(when (< (/ (the float (memory-free *nk-dead-pool*)) (the float (memory-total *nk-dead-pool*))) 0.1)
|
|
(format 0
|
|
"WARNING: low actor memory, no birth triggered!!! ~D/~D~%"
|
|
(memory-free *nk-dead-pool*)
|
|
(memory-total *nk-dead-pool*))
|
|
(set! low-memory? #t))))
|
|
(else
|
|
(when (and (-> link process) (not (logtest? (-> link perm status) (entity-perm-status no-kill))))
|
|
(kill! (-> link entity))
|
|
(+! actor-changes 1)))))
|
|
(if (>= actor-changes (-> *ACTOR-bank* birth-max)) (return (the-as object #f)))))))))))))
|
|
0)
|
|
|
|
(defun entity-birth-no-kill ((ent entity))
|
|
"Set no-kill on entity, birth it unless blocked, dead, or already live, and leave the resulting
|
|
process connected."
|
|
(let ((link (-> ent extra)))
|
|
(logior! (-> link perm status) (entity-perm-status no-kill))
|
|
(if (not (or (-> link process) (logtest? (-> link perm status) (entity-perm-status birth-blocked dead))))
|
|
(birth! (-> link entity)))
|
|
(-> link process))
|
|
(none))
|
|
|
|
(defun entity-task-complete-on ((ent entity))
|
|
"Set real-complete in entity's task-permission record when the entity has a nonzero task."
|
|
(let ((link (-> ent extra)))
|
|
(if (nonzero? (-> link perm task))
|
|
(logior! (-> *game-info* task-perm-list data (-> link perm task) status) (entity-perm-status real-complete))))
|
|
0
|
|
(none))
|
|
|
|
(defun entity-task-complete-off ((ent entity))
|
|
"Clear real-complete in entity's task-permission record unless the task is the complete sentinel."
|
|
(let ((link (-> ent extra)))
|
|
(if (!= (-> link perm task) (game-task complete))
|
|
(logclear! (-> *game-info* task-perm-list data (-> link perm task) status) (entity-perm-status real-complete))))
|
|
0
|
|
(none))
|
|
|
|
(defmethod set-or-clear-status! ((this entity-actor) (status-mask entity-perm-status) (enabled? symbol))
|
|
"Set or clear status-mask in this actor's permanent status. enabled? selects the operation."
|
|
(let ((link (-> this extra)))
|
|
(if enabled? (logior! (-> link perm status) status-mask) (logclear! (-> link perm status) status-mask))
|
|
(-> link perm status))
|
|
(none))
|
|
|
|
(defun process-entity-status! ((proc process) (status-mask entity-perm-status) (enabled? symbol))
|
|
"Set or clear status-mask on proc's permanent entity link when proc is still that entity's live
|
|
process. Return the resulting status, or zero when the connection is stale."
|
|
(cond
|
|
((and (-> proc entity) (= proc (-> proc entity extra process)))
|
|
(let ((link (-> proc entity extra)))
|
|
(if enabled? (logior! (-> link perm status) status-mask) (logclear! (-> link perm status) status-mask))
|
|
(the-as int (-> link perm status))))
|
|
(else 0)))
|
|
|
|
(#unless PC_PORT
|
|
(defun-debug entity-speed-test ((entity-name string))
|
|
"Disable actor spawning, reset actors, time the named entity's birth with the EE Count register
|
|
while interrupts are disabled, print the result and process, then kill it."
|
|
(local-vars (birth-cycles int))
|
|
(let ((ent (entity-by-name entity-name)))
|
|
(when ent
|
|
(set! *spawn-actors* #f)
|
|
(reset-actors 'debug)
|
|
0
|
|
(disable-irq)
|
|
(m Count 0)
|
|
(sync.p)
|
|
(birth! ent)
|
|
(m birth-cycles Count)
|
|
(enable-irq)
|
|
(format #t "~D spawn ~A ~A ~%" birth-cycles entity-name (-> ent extra process))
|
|
(kill! ent)))
|
|
(none)))
|