291 lines
11 KiB
Common Lisp
291 lines
11 KiB
Common Lisp
;;;; 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."
|
|
(declare (type (or weak-pointer null) ptr))
|
|
(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 (o! 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 *world-scenes* ()
|
|
"List of all running scenes.")
|
|
|
|
(defun add-scene (scene)
|
|
"Add a scene to the list of running scenes."
|
|
(declare (type scene scene))
|
|
|
|
(push scene *world-scenes*)
|
|
scene)
|
|
|
|
(defun remove-scene (scene)
|
|
"Remove a scene from the list of running scenes."
|
|
(declare (type scene scene))
|
|
|
|
(setf *world-scenes* (remove scene *world-scenes*))
|
|
scene)
|
|
|
|
(defun get-scene (scene-id)
|
|
"Get a scene by its ID."
|
|
(find-if (lambda (scene) (eq (o! scene id) scene-id)) *world-scenes*))
|
|
|
|
(defun attach-actor-to-world (actor scene)
|
|
"Properly attach actor and its descendents to scene, and initialize them."
|
|
;; attach actors to scene
|
|
(apply-to-tree actor (lambda (a)
|
|
(setf (o! a :slot scene) nil)
|
|
(o! scene (add-actor a))))
|
|
;; (resume) -> automatically resumes children
|
|
(o! actor (resume))
|
|
;; FIXME make (activate) call itself recursively on children
|
|
(apply-to-tree actor (lambda (a)
|
|
(when (o! a tree-active-p)
|
|
(o! a (activate)))))
|
|
)
|
|
|
|
(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 child-actor grandchild-actor)
|
|
(setf test-scene (make-instance 'scene
|
|
:id -1
|
|
:name "Test scene"))
|
|
(add-scene test-scene)
|
|
|
|
(setf test-actor (make-instance 'actor
|
|
:name "Actor"))
|
|
;; (o! test-scene (add-actor test-actor))
|
|
|
|
(setf test-drawable (make-instance 'drawable-test))
|
|
(o! 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))
|
|
;; (o! test-scene (add-actor test-actor-2))
|
|
|
|
(o! test-actor-2 (add-component (make-instance 'drawable-test
|
|
:colour (vec4 0.0 1.0 0.0 1.0))))
|
|
|
|
(setf child-actor (make-instance 'actor
|
|
:name "Child Actor"
|
|
:location (vec2 0 0.5)
|
|
:z-layer -2))
|
|
;; (o! test-scene (add-actor child-actor))
|
|
(o! test-actor-2 (add-child child-actor))
|
|
|
|
(o! child-actor (add-component (make-instance 'drawable-test
|
|
:colour (vec4 0.0 1.0 1.0 1.0))))
|
|
|
|
(setf grandchild-actor (make-instance 'actor
|
|
:name "Grandchild Actor"
|
|
:location (vec2 0 1)
|
|
:scale (vec2 0.25 0.25)
|
|
:z-layer 1))
|
|
;; (o! test-scene (add-actor grandchild-actor))
|
|
(o! child-actor (add-child grandchild-actor))
|
|
|
|
(o! grandchild-actor (add-component (make-instance 'drawable-test
|
|
:colour (vec4 1.0 1.0 0.0 0.0))))
|
|
|
|
(setf camera-actor (make-instance 'actor
|
|
:name "Camera"))
|
|
;; (o! test-scene (add-actor camera-actor))
|
|
|
|
(setf camera-view (make-instance 'view))
|
|
(o! camera-actor (add-component camera-view))
|
|
|
|
(attach-actor-to-world test-actor test-scene)
|
|
(attach-actor-to-world test-actor-2 test-scene)
|
|
(attach-actor-to-world camera-actor test-scene)
|
|
|
|
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* *pixel-scale*) :h (* *view-height* *pixel-scale*)
|
|
:title (format nil "wh-engine ~1{~D.~D.~D~} (Affero GPL; NON-FREE USAGE PROHIBITED)"
|
|
+version+))
|
|
(sdl2:with-gl-context (gl-context win)
|
|
(sdl2:gl-make-current win gl-context)
|
|
(let ((framebuf (gl:gen-framebuffer))
|
|
(renderbuf (gl:gen-renderbuffer))
|
|
(render-texture (gl:gen-texture))
|
|
(win-width (nth-value 0 (sdl2:get-window-size win)))
|
|
(win-height (nth-value 1 (sdl2:get-window-size win))))
|
|
;; set up framebuffer
|
|
(gl:bind-framebuffer :framebuffer framebuf)
|
|
|
|
(gl:bind-texture :texture-2d render-texture)
|
|
(gl:tex-image-2d :texture-2d 0 :rgba *view-width* *view-height* 0 :rgba :unsigned-byte (cffi:null-pointer))
|
|
(gl:tex-parameter :texture-2d :texture-wrap-s :clamp-to-edge)
|
|
(gl:tex-parameter :texture-2d :texture-wrap-t :clamp-to-edge)
|
|
(gl:tex-parameter :texture-2d :texture-min-filter :nearest)
|
|
(gl:tex-parameter :texture-2d :texture-mag-filter :nearest)
|
|
(gl:bind-texture :texture-2d 0)
|
|
|
|
(gl:framebuffer-texture-2d :framebuffer :color-attachment0 :texture-2d render-texture 0)
|
|
|
|
(gl:bind-renderbuffer :renderbuffer renderbuf)
|
|
(gl:renderbuffer-storage :renderbuffer :depth24-stencil8 *view-width* *view-height*)
|
|
(gl:bind-renderbuffer :renderbuffer 0)
|
|
|
|
(gl:framebuffer-renderbuffer :framebuffer :depth-stencil-attachment :renderbuffer renderbuf)
|
|
|
|
;; make sure it's valid
|
|
(let ((result (gl:check-framebuffer-status :framebuffer)))
|
|
(unless (gl::enum= result :framebuffer-complete)
|
|
(error "Failed to create framebuffer: ~S" result)))
|
|
|
|
(format t "texture-resident-p: ~S~%" (gl:texture-resident-p render-texture))
|
|
|
|
;; set up gl
|
|
(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)
|
|
|
|
(sdl2:with-event-loop (:method :poll)
|
|
(:quit () t)
|
|
(:idle ()
|
|
;; update
|
|
(loop for scene in *world-scenes*
|
|
do (o! scene (update)))
|
|
;; draw to render texture
|
|
(gl:bind-framebuffer :framebuffer framebuf)
|
|
(gl:viewport 0 0 *view-width* *view-height*)
|
|
(gl:clear :color-buffer)
|
|
(gl:enable :depth-test)
|
|
(let ((render-pass nil))
|
|
(loop for view-ptr in *world-views*
|
|
for view = (ensure-live (weak-pointer-value view-ptr))
|
|
when (and (o! view active-p) (o! view actor tree-active-p))
|
|
do (progn
|
|
(unless (eq (o! view render-pass) render-pass)
|
|
(setf render-pass (o! view render-pass))
|
|
(gl:clear :depth-buffer))
|
|
(o! view (render-view *world-drawables*)))))
|
|
|
|
;; now draw to window
|
|
(gl:bind-framebuffer :framebuffer 0)
|
|
(gl:viewport 0 0 win-width win-height)
|
|
(gl:clear :color-buffer)
|
|
(gl:disable :depth-test)
|
|
(gl:enable :texture-2d)
|
|
(gl:bind-texture :texture-2d render-texture)
|
|
(gl:matrix-mode :modelview)
|
|
(gl:load-identity)
|
|
|
|
(gl:with-primitive :quads
|
|
(gl:color 1.0 1.0 1.0 1.0)
|
|
(gl:tex-coord 0.0 0.0)
|
|
(gl:vertex 0.0 0.0)
|
|
(gl:tex-coord 1.0 0.0)
|
|
(gl:vertex *view-width* 0.0)
|
|
(gl:tex-coord 1.0 1.0)
|
|
(gl:vertex *view-width* *view-height*)
|
|
(gl:tex-coord 0.0 1.0)
|
|
(gl:vertex 0.0 *view-height*))
|
|
|
|
(gl:disable :texture-2d)
|
|
|
|
(gl:flush)
|
|
(sdl2:gl-swap-window win)))
|
|
)))))
|