Engine base somewhat functional
This commit is contained in:
parent
0538c1cf16
commit
74d2cdc890
GPG Key ID:
5BEBEEAB2C73D520
|
|
@ -1,3 +1,7 @@
|
|||
|
||||
# KDE :')
|
||||
.directory
|
||||
|
||||
# ---> CommonLisp
|
||||
*.FASL
|
||||
*.fasl
|
||||
|
|
|
|||
|
|
@ -3,4 +3,9 @@
|
|||
A game engine written in Common Lisp.
|
||||
|
||||
## Dependencies
|
||||
- `cl-opengl`
|
||||
- cl-sdl2
|
||||
- cl-opengl
|
||||
- trivial-types
|
||||
- [objective-lisp](https://bytes.keithhacks.cyou/keith/objective-lisp)
|
||||
- 3d-vectors
|
||||
- 3d-matrices
|
||||
|
|
|
|||
|
|
@ -0,0 +1,7 @@
|
|||
;; run.lisp
|
||||
;; registers current dir and loads wh-engine
|
||||
|
||||
(push (truename "./") asdf:*central-registry*)
|
||||
(asdf:load-system 'wh-engine)
|
||||
|
||||
(format t "**** wh-engine READY! ****~%")
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
;;;; wh-engine system definition
|
||||
;;;; Copyleft (C) 2021 ~keith
|
||||
|
||||
(defsystem "wh-engine"
|
||||
:version "0.1.0"
|
||||
:description "A game engine written in Common Lisp."
|
||||
:author "~keith"
|
||||
:license "GNU AGPLv3"
|
||||
:depends-on ("sdl2" "cl-opengl" "trivial-types" "objective-lisp" "3d-vectors" "3d-matrices")
|
||||
:components
|
||||
((:module "wh-engine"
|
||||
:components ((:file "package")
|
||||
(:file "main")
|
||||
(:file "actor")
|
||||
(:file "component")
|
||||
(:file "scene")
|
||||
(:file "render/drawable")
|
||||
(:file "render/view"))
|
||||
)))
|
||||
|
|
@ -0,0 +1,317 @@
|
|||
;;;; wh-engine/actor.lisp
|
||||
(in-package wh-engine)
|
||||
|
||||
(defclass actor ()
|
||||
((id :documentation "This actor's unique ID."
|
||||
:reader id
|
||||
:type fixnum
|
||||
:initarg :id
|
||||
:initform (make-id))
|
||||
(name :documentation "This actor's human-readable name."
|
||||
:accessor name
|
||||
:type string
|
||||
:initarg :name
|
||||
:initform "")
|
||||
(scene :documentation "The scene containing this actor."
|
||||
:reader scene
|
||||
:type (or weak-pointer null)
|
||||
:initform nil)
|
||||
(tags :documentation "This actor's tags."
|
||||
:reader tags
|
||||
:type (proper-list symbol)
|
||||
:initarg :tags
|
||||
:initform '(:default))
|
||||
(active-p :documentation "Whether or not this actor should be processed."
|
||||
:reader active-p
|
||||
:type boolean
|
||||
:initform t)
|
||||
(blocked-p :documentation "Whether or not this actor has a deactivated ancestor."
|
||||
:type boolean
|
||||
:initform nil)
|
||||
(parent :documentation "This actor's parent."
|
||||
:reader parent
|
||||
:type (or weak-pointer null)
|
||||
:initarg :parent
|
||||
:initform nil)
|
||||
(children :documentation "The actors this actor is a parent of."
|
||||
:reader children
|
||||
:type (proper-list weak-pointer)
|
||||
:initform nil)
|
||||
(components :documentation "The components attached to this actor."
|
||||
:reader components
|
||||
:type (proper-list component)
|
||||
:initform nil)
|
||||
(destroyed-p :documentation "If true, this actor will be unloaded."
|
||||
:reader destroyed-p
|
||||
:type boolean
|
||||
:initform nil)
|
||||
;; Transform data
|
||||
(location :documentation "The actor's location relative to its parent."
|
||||
:reader location
|
||||
:type vec2
|
||||
:initarg :location
|
||||
:initform (vec2 0 0))
|
||||
(z-layer :documentation "The actor's Z layer."
|
||||
:accessor z-layer
|
||||
:type fixnum
|
||||
:initarg :z-layer
|
||||
:initform 0)
|
||||
(rotation :documentation "The actor's rotation relative to its parent."
|
||||
:reader rotation
|
||||
:type single-float
|
||||
:initarg :rotation
|
||||
:initform 0.0)
|
||||
(scale :documentation "The actor's scale relative to its parent."
|
||||
:reader scale
|
||||
:type vec2
|
||||
:initarg :scale
|
||||
:initform (vec2 1 1))
|
||||
(matrix :documentation "Local-to-parent-space transformation matrix."
|
||||
:reader matrix
|
||||
:type mat3
|
||||
:initform (meye 3)))
|
||||
(:documentation "Base class for entities in the game."))
|
||||
|
||||
(defmethod scene ((this actor))
|
||||
"The scene containing this actor."
|
||||
(deref-pointer [this :slot scene]))
|
||||
|
||||
(defmethod parent ((this actor))
|
||||
"This actor's parent."
|
||||
(deref-pointer [this :slot parent]))
|
||||
|
||||
(defmethod tree-active-p ((this actor))
|
||||
"Whether or not this actor and all its parents are active."
|
||||
(and [this active-p] (not [this :slot blocked-p])))
|
||||
|
||||
(defmethod print-object ((this actor) stream)
|
||||
(print-unreadable-object (this stream :type t :identity t)
|
||||
(prin1 [this :slot id] stream)
|
||||
(princ " ")
|
||||
(prin1 [this :slot name] stream)))
|
||||
|
||||
(defmethod get-component ((this actor) component-class)
|
||||
"Get a component of the specified class attached to this object."
|
||||
(find-if (lambda (component) (typep component component-class))
|
||||
[this components]))
|
||||
|
||||
(defmethod add-component ((this actor) component)
|
||||
"Add a component to this object."
|
||||
(let ((component-class (class-of component)))
|
||||
(when [this (get-component component-class)]
|
||||
(error "~S already has a component of class ~S" this component-class))
|
||||
(push component [this :slot components])
|
||||
[component (attach this)])
|
||||
component)
|
||||
|
||||
(defmethod add-child ((this actor) child)
|
||||
"Add a child to this object."
|
||||
(when [child parent]
|
||||
(error "~S is already a child of ~S" child [child parent]))
|
||||
(push (make-weak-pointer child) [this :slot children])
|
||||
(setf [child :slot parent] (make-weak-pointer this))
|
||||
[child (parent-changed)]
|
||||
child)
|
||||
|
||||
(defmethod remove-child ((this actor) child)
|
||||
"Remove a child from this object."
|
||||
(unless (eq [child parent] this)
|
||||
(error "~S is not a child of ~S" child this))
|
||||
(setf [this :slot children] (remove child [this :slot children] :key #'weak-pointer-value))
|
||||
(setf [child :slot parent] nil)
|
||||
[child (parent-changed)]
|
||||
child)
|
||||
|
||||
(defmethod recompute-blocked-p ((this actor))
|
||||
"Determine if any ancestors of this actor are deactivated."
|
||||
(setf [this :slot blocked-p]
|
||||
(when [this parent] (or (not [this parent active-p]) [this parent :slot blocked-p]))))
|
||||
|
||||
(defmethod has-tag ((this actor) tag)
|
||||
"Check if this object has the specified tag."
|
||||
(find tag [this tags]))
|
||||
|
||||
(defmethod add-tag ((this actor) tag)
|
||||
"Add a tag to this object."
|
||||
(pushnew tag [this :slot tags]))
|
||||
|
||||
(defmethod remove-tag ((this actor) tag)
|
||||
"Remove a tag from this object."
|
||||
(setf [this :slot tags] (remove tag [this :slot tags])))
|
||||
|
||||
(defmethod parent-deactivated ((this actor) parent)
|
||||
"Called when the actor's parent is deactivated."
|
||||
[this (recompute-blocked-p)]
|
||||
(loop for component in [this components]
|
||||
do [component (parent-deactivated parent)])
|
||||
(loop for child-ptr in [this children]
|
||||
for child = (weak-pointer-value child-ptr)
|
||||
do [child (parent-deactivated parent)]))
|
||||
|
||||
(defmethod parent-activated ((this actor) parent)
|
||||
"Called when the actor's parent is activated."
|
||||
[this (recompute-blocked-p)]
|
||||
(loop for child-ptr in [this children]
|
||||
for child = (weak-pointer-value child-ptr)
|
||||
do [child (parent-activated parent)])
|
||||
(loop for component in [this components]
|
||||
do [component (parent-activated parent)]))
|
||||
|
||||
(defmethod parent-changed ((this actor))
|
||||
"Called when the actor's parent is changed."
|
||||
[this (recompute-blocked-p)]
|
||||
(loop for component in [this components]
|
||||
do [component (parent-changed)]))
|
||||
|
||||
(defmethod deactivate ((this actor))
|
||||
"Deactivate this object."
|
||||
(setf [this :slot active-p] nil)
|
||||
(loop for component in [this components]
|
||||
do [component (parent-deactivated this)])
|
||||
(loop for child-ptr in [this children]
|
||||
for child = (weak-pointer-value child-ptr)
|
||||
do [child (parent-deactivated this)]))
|
||||
|
||||
(defmethod activate ((this actor))
|
||||
"Activate this object."
|
||||
(setf [this :slot active-p] t)
|
||||
(loop for child-ptr in [this children]
|
||||
for child = (weak-pointer-value child-ptr)
|
||||
do [child (parent-activated this)])
|
||||
(loop for component in [this components]
|
||||
do [component (parent-activated this)]))
|
||||
|
||||
(defmethod update ((this actor))
|
||||
"Update this actor's components."
|
||||
(loop for component in [this components]
|
||||
do (when [component active-p]
|
||||
(unless [component started-p] [component (start)])
|
||||
[component (update)]))
|
||||
; (loop for child in [this children]
|
||||
; do (when [child active-p]
|
||||
; [child (.update)]))
|
||||
)
|
||||
|
||||
(defmethod destroy ((this actor))
|
||||
"Mark this object for unloading."
|
||||
(unless [this destroyed-p]
|
||||
; Cleanup on aisle 5!
|
||||
(loop for component in [this components]
|
||||
when [component active-p]
|
||||
do [component (destroy)])
|
||||
; Remove from parent
|
||||
(when [this parent]
|
||||
[this parent (remove-child this)])
|
||||
(loop for child-ptr in [this children]
|
||||
for child = (weak-pointer-value child-ptr)
|
||||
do [child (destroy)])
|
||||
(when [this scene]
|
||||
[this scene (remove-actor this)]))
|
||||
(setf [this :slot destroyed-p] t))
|
||||
|
||||
;; Transform
|
||||
|
||||
(defmethod initialize-instance :after ((this actor) &key)
|
||||
[this (recompute-matrix)])
|
||||
|
||||
(defmethod recompute-matrix ((this actor))
|
||||
"Recompute the local-to-parent-space matrix."
|
||||
(let ((rs (sin [this rotation]))
|
||||
(rc (cos [this rotation]))
|
||||
(sx (vx2 [this scale]))
|
||||
(sy (vy2 [this scale]))
|
||||
(tx (vx2 [this location]))
|
||||
(ty (vy2 [this location])))
|
||||
(with-fast-matref (m [this :slot matrix] 3)
|
||||
(setf (m 0 0) (* sx rc)
|
||||
(m 0 1) (* sy (- rs))
|
||||
(m 0 2) tx
|
||||
(m 1 0) (* sx rs)
|
||||
(m 1 1) (* sy rc)
|
||||
(m 1 2) ty)
|
||||
)))
|
||||
|
||||
(defmethod (setf location) (new-val (this actor))
|
||||
"The actor's location relative to its parent."
|
||||
(declare (type vec2 new-val))
|
||||
|
||||
(setf (vx2 [this :slot location]) (vx2 new-val)
|
||||
(vy2 [this :slot location]) (vy2 new-val))
|
||||
[this (recompute-matrix)])
|
||||
|
||||
(defmethod (setf rotation) (new-val (this actor))
|
||||
"The actor's rotation relative to its parent."
|
||||
(declare (type single-float new-val))
|
||||
|
||||
(setf [this :slot rotation] new-val)
|
||||
[this (recompute-matrix)])
|
||||
|
||||
(defmethod (setf scale) (new-val (this actor))
|
||||
"The actor's scale relative to its parent."
|
||||
(declare (type vec2 new-val))
|
||||
|
||||
(setf (vx2 [this :slot scale]) (vx2 new-val)
|
||||
(vy2 [this :slot scale]) (vy2 new-val))
|
||||
[this (recompute-matrix)])
|
||||
|
||||
(defmethod world-matrix ((this actor))
|
||||
"The local-to-world-space transformation matrix for this actor."
|
||||
(if [this parent]
|
||||
(m* [this matrix] [this parent world-matrix])
|
||||
[this matrix]))
|
||||
|
||||
(defmethod local-matrix ((this actor))
|
||||
"The world-to-local-space transformation matrix for this actor."
|
||||
(minv [this world-matrix]))
|
||||
|
||||
(defmethod world-location ((this actor))
|
||||
"The world-space location of this actor."
|
||||
(vxy (m* [this world-matrix] (vec3 0 0 1))))
|
||||
|
||||
(defmethod transform-point ((this actor) point)
|
||||
"Transform point from local space to parent space."
|
||||
(declare (type vec2 point))
|
||||
|
||||
(vxy (m* [this matrix] (vxy1 point))))
|
||||
|
||||
(defmethod world-point ((this actor) point)
|
||||
"Transform point from local space to world space."
|
||||
(declare (type vec2 point))
|
||||
|
||||
(vxy (m* [this world-matrix] (vxy1 point))))
|
||||
|
||||
(defmethod local-point ((this actor) point)
|
||||
"Transform point from world space to local space."
|
||||
(declare (type vec2 point))
|
||||
|
||||
(vxy (m* [this local-matrix] (vxy1 point))))
|
||||
|
||||
(defmethod transform-svector ((this actor) vector)
|
||||
"Transform vector from local space to parent space."
|
||||
(declare (type vec2 vector))
|
||||
|
||||
(vxy (m* [this matrix] (vxy_ vector))))
|
||||
|
||||
(defmethod transform-vector ((this actor) vector)
|
||||
"Transform vector from local space to parent space, without changing its length."
|
||||
(declare (type vec2 vector))
|
||||
|
||||
(nvscale [this (transform-svector vector)] (vlength vector)))
|
||||
|
||||
(defmethod translate-by ((this actor) vector)
|
||||
"Translate this actor by the given vector in parent space."
|
||||
(declare (type vec2 vector))
|
||||
|
||||
(setf [this location] (v+ [this location] vector)))
|
||||
|
||||
(defmethod rotate-by ((this actor) angle)
|
||||
"Rotate this actor by the given angle."
|
||||
(declare (type single-float angle))
|
||||
|
||||
(setf [this rotation] (+ [this rotation] angle)))
|
||||
|
||||
(defmethod scale-by ((this actor) factor)
|
||||
"Scale this actor by the given factor (either a scalar or a vector)."
|
||||
(declare (type (or single-float vec2) factor))
|
||||
|
||||
(setf [this scale] (v* [this scale] factor)))
|
||||
|
|
@ -0,0 +1,67 @@
|
|||
;;;; wh-engine/component.lisp
|
||||
(in-package wh-engine)
|
||||
|
||||
(defclass component ()
|
||||
((actor :documentation "The actor this component belongs to."
|
||||
:reader actor
|
||||
:type (or weak-pointer null)
|
||||
:initform nil)
|
||||
(active-p :documentation "Whether or not this component is active."
|
||||
:reader active-p
|
||||
:type boolean
|
||||
:initarg :active-p
|
||||
:initform t)
|
||||
(started-p :documentation "Whether or not this component has been started yet."
|
||||
:reader started-p
|
||||
:type boolean
|
||||
:initform nil))
|
||||
(:documentation "Base class for components attached to game entities."))
|
||||
|
||||
(defmethod actor ((this component))
|
||||
"The actor this component belongs to."
|
||||
(deref-pointer [this :slot actor]))
|
||||
|
||||
(defmethod scene ((this component))
|
||||
"The scene this component belongs to."
|
||||
[this actor scene])
|
||||
|
||||
(defmethod destroyed-p ((this component))
|
||||
"If true, this component will be unloaded."
|
||||
[this actor destroyed-p])
|
||||
|
||||
(defmethod attach ((this component) actor)
|
||||
"Attach this component to an actor."
|
||||
(setf [this :slot actor] (make-weak-pointer (ensure-live actor)))
|
||||
[this (parent-changed)])
|
||||
|
||||
(defmethod parent-deactivated ((this component) parent)
|
||||
"Called when the component's actor is deactivated."
|
||||
nil)
|
||||
|
||||
(defmethod parent-activated ((this component) parent)
|
||||
"Called when the component's actor is activated."
|
||||
nil)
|
||||
|
||||
(defmethod parent-changed ((this component))
|
||||
"Called when the component's actor's parent is changed."
|
||||
nil)
|
||||
|
||||
(defmethod deactivate ((this component))
|
||||
"Deactivate this component."
|
||||
(setf [this :slot active-p] nil))
|
||||
|
||||
(defmethod activate ((this component))
|
||||
"Activate this component."
|
||||
(setf [this :slot active-p] t))
|
||||
|
||||
(defmethod start ((this component))
|
||||
"Called before on-update the first time this component is processed."
|
||||
(setf [this :slot started-p] t))
|
||||
|
||||
(defmethod update ((this component))
|
||||
"Called every game tick while this component and its actor are active."
|
||||
nil)
|
||||
|
||||
(defmethod destroy ((this component))
|
||||
"Called just before the component's actor is destroyed."
|
||||
nil)
|
||||
|
|
@ -0,0 +1,197 @@
|
|||
;;;; wh-engine/main.lisp
|
||||
(in-package wh-engine)
|
||||
|
||||
;; FIXME this should be a defconst
|
||||
(defvar +version+ (list 0 1 0)
|
||||
"Engine version.")
|
||||
|
||||
(defun ensure-version (expected-version)
|
||||
"Ensure this version of wh-engine is compatible with the expected version."
|
||||
(if (= (nth 0 +version+) 0)
|
||||
(unless (equal +version+ expected-version)
|
||||
(error "engine version ~S incompatible with expected-version ~S (pre-1.0 mismatch)"
|
||||
+version+ expected-version))
|
||||
(progn
|
||||
(unless (= (nth 0 +version+) (nth 0 expected-version))
|
||||
(error "engine version ~S incompatible with expected-version ~S (major-version mismatch)"
|
||||
+version+ expected-version))
|
||||
(unless (>= (nth 1 +version+) (nth 1 expected-version))
|
||||
(error "engine version ~S incompatible with expected-version ~S (minor-version too low)"
|
||||
+version+ expected-version))
|
||||
(unless (equal +version+ expected-version)
|
||||
(warn "engine version ~S differs from expected-version ~S, but is still compatible"
|
||||
+version+ expected-version)))))
|
||||
|
||||
(declaim (inline deref-pointer))
|
||||
(defun deref-pointer (ptr)
|
||||
"Dereference ptr if it's non-nil."
|
||||
(when ptr (weak-pointer-value ptr)))
|
||||
|
||||
(defun points-to (ptr obj)
|
||||
"Return true if ptr points to obj."
|
||||
(declare (type weak-pointer ptr))
|
||||
|
||||
(eq (weak-pointer-value ptr) obj))
|
||||
|
||||
(defun ensure-live (obj)
|
||||
"Ensure obj is live (non-destroyed)."
|
||||
(when [obj destroyed-p]
|
||||
(error "~S was used after it was destroyed" obj))
|
||||
obj)
|
||||
|
||||
(declaim (inline vxy1))
|
||||
(defun vxy1 (vector)
|
||||
"Convert vector to a vec3, with a Z component of 1."
|
||||
(declare (type vec2 vector))
|
||||
(vec3 (vx2 vector) (vy2 vector) 1))
|
||||
|
||||
(declaim (inline vxy-trunc))
|
||||
(defun vxy-trunc (vector)
|
||||
"Convert vector to a vec2 and truncate its X and Y components to the nearest integer."
|
||||
(declare (type vec3 vector))
|
||||
(vec2 (ftruncate (vx3 vector)) (ftruncate (vy3 vector))))
|
||||
|
||||
(defun opengl-matrix (matrix)
|
||||
(declare (type mat3 matrix))
|
||||
(with-fast-matref (m matrix 3)
|
||||
(make-array '(16) :initial-contents
|
||||
`(,(m 0 0) ,(m 0 1) 0.0 ,(m 0 2)
|
||||
,(m 1 0) ,(m 1 1) 0.0 ,(m 1 2)
|
||||
0.0 0.0 1.0 0.0
|
||||
,(m 2 0) ,(m 2 1) 0.0 ,(m 2 2))
|
||||
)))
|
||||
|
||||
(defvar *id-counter* 0
|
||||
"Counter for assigning unique IDs.")
|
||||
|
||||
(defun make-id ()
|
||||
"Return a unique ID."
|
||||
(setq *id-counter* (+ *id-counter* 1)))
|
||||
|
||||
(defun fixed-id (id)
|
||||
"Ensure the given ID won't be returned by make-id."
|
||||
(declare (type fixnum id))
|
||||
(when (>= id *id-counter*)
|
||||
(setq *id-counter* (+ id 1)))
|
||||
id)
|
||||
|
||||
(defvar *running-scenes* nil
|
||||
"List of running scenes.")
|
||||
|
||||
(defun add-scene (scene)
|
||||
"Add a scene to the list of running scenes."
|
||||
(declare (type scene scene))
|
||||
|
||||
(push scene *running-scenes*)
|
||||
scene)
|
||||
|
||||
(defun remove-scene (scene)
|
||||
"Remove a scene from the list of running scenes."
|
||||
(declare (type scene scene))
|
||||
|
||||
(setf *running-scenes* (remove scene *running-scenes*))
|
||||
scene)
|
||||
|
||||
(defun get-scene (scene-id)
|
||||
"Get a scene by its ID."
|
||||
(find-if (lambda (scene) (eq [scene id] scene-id)) *running-scenes*))
|
||||
|
||||
(defun update-all-scenes ()
|
||||
"Update all running scenes."
|
||||
(loop for scene in *running-scenes*
|
||||
do [scene (update)]))
|
||||
|
||||
(defvar *view-width* 384
|
||||
"View-space width in pixels.")
|
||||
(defvar *view-height* 256
|
||||
"View-space height in pixels.")
|
||||
(defvar *view-ppu* 64
|
||||
"Pixels in view-space per unit in world-space.")
|
||||
|
||||
(defvar *pixel-scale* 2
|
||||
"Scaling factor for rendered pixels.")
|
||||
|
||||
(defvar *world-drawables* nil
|
||||
"List of all known drawables.")
|
||||
(defvar *world-views* nil
|
||||
"List of all known views.")
|
||||
|
||||
(defun register-test-scene ()
|
||||
(let (test-scene test-actor test-drawable test-actor-2 camera-actor camera-view)
|
||||
(setf test-scene (make-instance 'scene
|
||||
:id -1
|
||||
:name "Test scene"))
|
||||
(add-scene test-scene)
|
||||
|
||||
(setf test-actor (make-instance 'actor
|
||||
:name "Actor"))
|
||||
[test-scene (add-actor test-actor)]
|
||||
|
||||
(setf test-drawable (make-instance 'drawable-test))
|
||||
[test-actor (add-component test-drawable)]
|
||||
|
||||
(setf test-actor-2 (make-instance 'actor
|
||||
:name "Actor 2"
|
||||
:location (vec2 0.5 0.5)
|
||||
:rotation (coerce (/ pi 4) 'single-float)
|
||||
:z-layer -1))
|
||||
[test-scene (add-actor test-actor-2)]
|
||||
|
||||
[test-actor-2 (add-component (make-instance 'drawable-test
|
||||
:colour (vec4 0.0 1.0 0.0 1.0)))
|
||||
]
|
||||
|
||||
(setf camera-actor (make-instance 'actor
|
||||
:name "Camera"
|
||||
:rotation (coerce (/ pi -4) 'single-float)))
|
||||
[test-scene (add-actor camera-actor)]
|
||||
|
||||
(setf camera-view (make-instance 'view))
|
||||
[camera-actor (add-component camera-view)]
|
||||
|
||||
test-scene))
|
||||
|
||||
(defun run ()
|
||||
"Run the main game loop."
|
||||
(sdl2:with-init (:everything)
|
||||
(format t "wh-engine: using SDL ~D.~D.~D~%"
|
||||
sdl2-ffi:+sdl-major-version+
|
||||
sdl2-ffi:+sdl-minor-version+
|
||||
sdl2-ffi:+sdl-patchlevel+)
|
||||
(finish-output)
|
||||
(sdl2:with-window (win :flags '(:shown :opengl)
|
||||
:w *view-width* :h *view-height*
|
||||
:title (format nil "wh-engine ~D.~D.~D (Affero GPL; NON-FREE USAGE PROHIBITED)"
|
||||
(nth 0 +version+) (nth 1 +version+) (nth 2 +version+)))
|
||||
(sdl2:with-gl-context (gl-context win)
|
||||
(sdl2:gl-make-current win gl-context)
|
||||
(gl:viewport 0 0 *view-width* *view-height*)
|
||||
(gl:matrix-mode :projection)
|
||||
(gl:ortho 0 *view-width*
|
||||
0 *view-height*
|
||||
-1024 1024)
|
||||
(gl:matrix-mode :modelview)
|
||||
(gl:load-identity)
|
||||
(gl:clear-color 0.0 0.0 0.0 1.0)
|
||||
(gl:clear :color-buffer)
|
||||
(gl:clear :depth-buffer)
|
||||
(gl:enable :depth-test)
|
||||
|
||||
(sdl2:with-event-loop (:method :poll)
|
||||
(:quit () t)
|
||||
(:idle ()
|
||||
(update-all-scenes)
|
||||
(gl:clear :color-buffer)
|
||||
(let ((render-pass nil))
|
||||
(loop for view-ptr in *world-views*
|
||||
for view = (ensure-live (weak-pointer-value view-ptr))
|
||||
when (and [view active-p] [view actor tree-active-p])
|
||||
do (progn
|
||||
(unless (eq [view render-pass] render-pass)
|
||||
(setf render-pass [view render-pass])
|
||||
(gl:clear :depth-buffer)
|
||||
)
|
||||
[view (render-view *world-drawables*)])))
|
||||
(gl:flush)
|
||||
(sdl2:gl-swap-window win)))
|
||||
))))
|
||||
|
|
@ -0,0 +1,82 @@
|
|||
;;;; wh-engine/package.lisp
|
||||
;;;; root package of wh-engine
|
||||
|
||||
(defpackage wh-engine
|
||||
(:nicknames whe)
|
||||
(:use common-lisp 3d-vectors 3d-matrices)
|
||||
(:import-from sb-ext
|
||||
weak-pointer weak-pointer-p make-weak-pointer weak-pointer-value)
|
||||
(:export
|
||||
;; main.lisp
|
||||
+version+ ensure-version
|
||||
deref-pointer points-to ensure-live
|
||||
vxy1 vxy-trunc
|
||||
make-id fixed-id
|
||||
*running-scenes*
|
||||
add-scene remove-scene get-scene update-all-scenes
|
||||
*view-width* *view-height* *view-ppu* *pixel-scale*
|
||||
register-test-scene
|
||||
run
|
||||
|
||||
;; actor.lisp
|
||||
actor
|
||||
; properties
|
||||
id name scene tags active-p parent children components destroyed-p
|
||||
location z-layer rotation scale matrix
|
||||
; virtual properties
|
||||
tree-active-p
|
||||
world-matrix local-matrix
|
||||
world-location
|
||||
; methods
|
||||
get-component add-component
|
||||
add-child remove-child
|
||||
has-tag add-tag remove-tag
|
||||
parent-deactivated parent-activated parent-changed
|
||||
deactivate activate
|
||||
update
|
||||
destroy
|
||||
transform-point world-point local-point
|
||||
transform-svector transform-vector
|
||||
translate-by rotate-by scale-by
|
||||
|
||||
;; component.lisp
|
||||
component
|
||||
; properties
|
||||
actor active-p started-p
|
||||
; virtual properties
|
||||
scene destroyed-p
|
||||
; methods
|
||||
attach
|
||||
parent-deactivated parent-activated parent-changed
|
||||
deactivate activate
|
||||
start update
|
||||
destroy
|
||||
|
||||
;; scene.lisp
|
||||
scene
|
||||
; properties
|
||||
id name actors destroyed-p
|
||||
; methods
|
||||
add-actor remove-actor
|
||||
get-actor get-tagged-actors
|
||||
update
|
||||
destroy
|
||||
|
||||
;; render/drawable.lisp
|
||||
drawable
|
||||
; virtual properties
|
||||
culling-box
|
||||
; methods
|
||||
draw
|
||||
|
||||
drawable-test
|
||||
|
||||
;; render/view.lisp
|
||||
view
|
||||
; properties
|
||||
render-pass render-mask cull-p
|
||||
; virtual properties
|
||||
view-matrix world-matrix
|
||||
; methods
|
||||
view-point render-view render-drawable
|
||||
))
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
;;;; wh-engine/render/drawable.lisp
|
||||
(in-package wh-engine)
|
||||
|
||||
(defclass drawable (component)
|
||||
()
|
||||
(:documentation "Base class for components that draw graphics."))
|
||||
|
||||
(defmethod start :after ((this drawable))
|
||||
; Register
|
||||
(pushnew (make-weak-pointer this) *world-drawables*))
|
||||
|
||||
(defmethod destroy :before ((this drawable))
|
||||
; Unregister
|
||||
(setf *world-drawables* (delete this *world-drawables* :key #'weak-pointer-value)))
|
||||
|
||||
(defmethod culling-box ((this drawable))
|
||||
"The local-space bounding box used for culling."
|
||||
(cons (vec2 0 0) (vec2 0 0)))
|
||||
|
||||
(defmethod draw ((this drawable) view)
|
||||
"Draw this object."
|
||||
nil)
|
||||
|
||||
(defclass drawable-test (drawable)
|
||||
((colour :documentation "Colour of the test quad."
|
||||
:accessor colour
|
||||
:type vec4
|
||||
:initarg :colour
|
||||
:initform (vec4 1.0 0.0 1.0 1.0)))
|
||||
(:documentation "Basic drawable test."))
|
||||
|
||||
(defmethod culling-box ((this drawable-test))
|
||||
(cons (vec2 -0.5 -0.5) (vec2 0.5 0.5)))
|
||||
|
||||
(defmethod draw ((this drawable-test) view)
|
||||
(gl:begin :quads)
|
||||
(gl:color (vx4 [this colour]) (vy4 [this colour]) (vz4 [this colour]) (vw4 [this colour]))
|
||||
(gl:vertex -0.5 -0.5 0.0 1.0)
|
||||
(gl:vertex 0.5 -0.5 0.0 1.0)
|
||||
(gl:vertex 0.5 0.5 0.0 1.0)
|
||||
(gl:vertex -0.5 0.5 0.0 1.0)
|
||||
(gl:end))
|
||||
|
|
@ -0,0 +1,96 @@
|
|||
;;;; wh-engine/render/view.lisp
|
||||
(in-package wh-engine)
|
||||
|
||||
(defun sort-world-views ()
|
||||
"Re-sort the *world-views* list by render pass."
|
||||
(sort *world-views* #'< :key (lambda (v) [(deref-pointer v) render-pass])))
|
||||
|
||||
(defclass view (component)
|
||||
((render-pass :documentation "The render pass this view should be drawn in."
|
||||
:reader render-pass
|
||||
:type fixnum
|
||||
:initarg :render-pass
|
||||
:initform 0)
|
||||
(render-mask :documentation "Only include actors with at least one of these tags."
|
||||
:accessor render-mask
|
||||
:type (proper-list symbol)
|
||||
:initarg :render-mask
|
||||
:initform '(:default))
|
||||
(cull-p :documentation "Whether or not to skip rendering out-of-frame objects."
|
||||
:accessor cull-p
|
||||
:type boolean
|
||||
:initarg :cull-p
|
||||
:initform t))
|
||||
(:documentation "Defines a view into the scene, and rendering settings for objects drawn by the view."))
|
||||
|
||||
(defmethod (setf render-pass) (new-val (this view))
|
||||
"The render pass this view should be drawn in."
|
||||
(setf [this :slot render-pass] new-val)
|
||||
(sort-world-views))
|
||||
|
||||
(defmethod start :after ((this view))
|
||||
; Register
|
||||
(pushnew (make-weak-pointer this) *world-views*)
|
||||
(sort-world-views))
|
||||
|
||||
(defmethod destroy :before ((this view))
|
||||
(unless [this destroyed-p]
|
||||
; Unregister
|
||||
(setf *world-views* (delete this *world-views* :key #'weak-pointer-value))))
|
||||
|
||||
(defmethod view-matrix ((this view))
|
||||
"The world-to-view-space transformation matrix for this object."
|
||||
;; view-space = local-space, scaled by ppu, then offset so [-width/2..width/2] -> [0..width]
|
||||
;; (Y+ is still up in view-space)
|
||||
(m* (mat *view-ppu* 0 (/ *view-width* 2)
|
||||
0 *view-ppu* (/ *view-height* 2)
|
||||
0 0 1)
|
||||
[this actor local-matrix]))
|
||||
|
||||
(defmethod world-matrix ((this view))
|
||||
"The view-to-world-space transformation matrix for this object."
|
||||
(minv [this view-matrix]))
|
||||
|
||||
(defmethod view-point ((this view) point)
|
||||
"Transform point from world space to view space."
|
||||
(declare (type vec2 point))
|
||||
|
||||
(vxy-trunc (m* [this view-matrix] (vxy1 point))))
|
||||
|
||||
(defmethod render-view ((this view) drawables)
|
||||
"Render everything in this view, given all drawables in the world."
|
||||
(let ((view-matrix [this view-matrix]))
|
||||
;; Apply view matrix
|
||||
(gl:matrix-mode :modelview)
|
||||
(gl:load-transpose-matrix (opengl-matrix view-matrix))
|
||||
(loop for drawable-ptr in drawables
|
||||
for drawable = (deref-pointer drawable-ptr)
|
||||
when (and drawable (ensure-live drawable))
|
||||
when (and [drawable active-p] [drawable actor tree-active-p]
|
||||
(some (lambda (x) [drawable actor (has-tag x)]) [this render-mask]))
|
||||
do [this (render-drawable drawable view-matrix)])
|
||||
))
|
||||
|
||||
(defun in-view-p (drawable drawable-matrix view-matrix view-box)
|
||||
"Determine if drawable is in the view defined by view-matrix and view-box."
|
||||
(let ((drawable-culling-box [drawable culling-box])
|
||||
box-a box-b)
|
||||
(setf box-a (vxy-trunc (m* view-matrix
|
||||
(m* drawable-matrix (vxy1 (car drawable-culling-box))))))
|
||||
(setf box-b (vxy-trunc (m* view-matrix
|
||||
(m* drawable-matrix (vxy1 (cdr drawable-culling-box))))))
|
||||
;; If it's in view at all, either its top-right corner is >= bottom-left of view,
|
||||
;; or its bottom-left is <= top-right of view
|
||||
(or (v>= (vmax box-a box-b) (car view-box))
|
||||
(v<= (vmin box-a box-b) (cdr view-box)))))
|
||||
|
||||
(defmethod render-drawable ((this view) drawable view-matrix)
|
||||
"Render drawable with the precomputed view-matrix."
|
||||
(let ((drawable-matrix [drawable actor world-matrix]))
|
||||
(when (or (not [this cull-p]) (in-view-p drawable drawable-matrix view-matrix
|
||||
(cons (vec2 0 0) (vec2 *view-width* *view-height*))))
|
||||
(gl:push-matrix)
|
||||
(gl:translate 0 0 [drawable actor z-layer])
|
||||
(gl:mult-transpose-matrix (opengl-matrix drawable-matrix))
|
||||
[drawable (draw this)]
|
||||
(gl:pop-matrix))))
|
||||
|
|
@ -0,0 +1,70 @@
|
|||
;;;; wh-engine/scene.lisp
|
||||
(in-package wh-engine)
|
||||
|
||||
(defclass scene ()
|
||||
((id :documentation "This scene's unique ID."
|
||||
:reader id
|
||||
:type fixnum
|
||||
:initarg :id
|
||||
:initform 0)
|
||||
(name :documentation "This scene's human-readable name."
|
||||
:accessor name
|
||||
:type string
|
||||
:initarg :name
|
||||
:initform "")
|
||||
(actors :documentation "A list containing all actors in the scene."
|
||||
:reader actors
|
||||
:type (proper-list actor)
|
||||
:initform nil)
|
||||
(destroyed-p :documentation "If true, this scene will be unloaded."
|
||||
:reader destroyed-p
|
||||
:type boolean
|
||||
:initform nil))
|
||||
(:documentation "A scene containing game entities."))
|
||||
|
||||
(defmethod print-object ((this scene) stream)
|
||||
(print-unreadable-object (this stream :type t :identity t)
|
||||
(prin1 [this :slot id] stream)
|
||||
(princ " ")
|
||||
(prin1 [this :slot name] stream)))
|
||||
|
||||
(defmethod add-actor ((this scene) actor)
|
||||
"Add an actor to this scene."
|
||||
(when [actor scene]
|
||||
(error "~S is already in scene ~S" actor [actor scene]))
|
||||
(push actor [this :slot actors])
|
||||
(setf [actor :slot scene] (make-weak-pointer this))
|
||||
actor)
|
||||
|
||||
(defmethod remove-actor ((this scene) actor)
|
||||
"Remove an actor from this scene."
|
||||
(unless (eq [actor scene] this)
|
||||
(error "~S is not in scene ~S" actor this))
|
||||
(setf [this :slot actors] (remove actor [this :slot actors] :key #'weak-pointer-value))
|
||||
(setf [actor :slot scene] nil)
|
||||
actor)
|
||||
|
||||
(defmethod get-actor ((this scene) actor-id)
|
||||
"Get the actor with the specified ID in this scene."
|
||||
(find-if (lambda (actor) (eq [actor id] actor-id)) [this actors]))
|
||||
|
||||
(defmethod get-tagged-actors ((this scene) tags)
|
||||
"Get all actors tagged with the given set of tags."
|
||||
(loop for actor in [this actors]
|
||||
if (subsetp tags [actor tags])
|
||||
collect actor))
|
||||
|
||||
(defmethod update ((this scene))
|
||||
"Update all actors in this scene."
|
||||
(loop for actor in [this actors]
|
||||
unless (or [actor destroyed-p] (not [actor tree-active-p]))
|
||||
do [actor (update)]))
|
||||
|
||||
(defmethod destroy ((this scene))
|
||||
"Mark this scene for unloading."
|
||||
(unless [this destroyed-p]
|
||||
; We're dead, clean up actors
|
||||
(loop for actor in [this actors]
|
||||
do [actor (destroy)])
|
||||
(remove-scene this))
|
||||
(setf [this :slot destroyed-p] t))
|
||||
Loading…
Reference in New Issue