new! object instantiation macro (resolves #10)

wh-engine.asd

@@ -10,11 +10,13 @@
   :components
   ((:module "wh-engine"
     :components ((:file "package")
-                 (:file "main")
+                 (:file "global")
                  (:file "serialization")
                  (:file "actor")
                  (:file "component")
+                 (:file "actor-macros")
                  (:file "scene")
                  (:file "render/drawable")
-                 (:file "render/view"))
+                 (:file "render/view")
+                 (:file "main"))
     )))

wh-engine/actor-macros.lisp

@@ -0,0 +1,66 @@
+ ;;;; wh-engine/actor-macros.lisp
+(in-package wh-engine)
+
+(defvar *new!-impl-alist* ()
+  "Alist of special implementations for new!")
+
+(defmacro define-new!-impl (class (class-var it-var params-var) &body body)
+  "Define a special implementation for new!, which returns (values other-forms make-params)."
+  `(push (cons (find-class ',class)
+               (lambda (,class-var ,it-var ,params-var) ,@body))
+         *new!-impl-alist*))
+
+(defmacro new! (class &rest params &key &allow-other-keys)
+  "Create a new instance of class, as specified by params."
+  (let ((impl (cdr (assoc-if (lambda (x) (subtypep x class)) *new!-impl-alist*)))
+        (it (gensym)))
+    (if impl
+        (multiple-value-bind (other-forms make-params)
+            (funcall impl class it params)
+          `(let ((,it (make-instance ',class ,@make-params))) ,@other-forms ,it))
+        `(make-instance ',class ,@params))
+    ))
+
+(define-new!-impl actor (class it params)
+  (declare (ignore class))
+  (loop for (key value) on params by #'cddr
+        if (eq key :component)
+          collect `(o! ,it (add-component ,value)) into other-forms
+        else
+          if (eq key :child)
+            collect `(o! ,it (add-child ,value)) into other-forms
+        else
+          if (eq key :parent)
+            collect `(o! ,value (add-child ,it)) into other-forms
+        else
+          nconc `(,key ,value) into make-params
+        finally (return (values other-forms make-params))))
+
+#|
+(define-new!-impl component (class it params)
+  (loop for (key value) on params by #'cddr
+        if (eq key :actor)
+          collect `(o! ,value (add-component ,it)) into other-forms
+        else
+          nconc `(,key ,value) into make-params
+        finally (return (values other-forms make-params))))
+|#
+
+#|
+(defmacro actor! (class &rest params &key &allow-other-keys)
+  (let* ((cons-form `(make-instance ',class))
+         (it (gensym))
+         (other-forms
+           (loop for (key value) on params by #'cddr
+                 if (eq key :component)
+                   collect `(o! ,it (add-component ,value))
+                 else
+                   if (eq key :child)
+                     collect `(o! ,it (add-child ,value))
+                 else
+                   do (nconc cons-form `(,key ,value)))))
+    `(let ((,it ,cons-form)) ,@other-forms ,it)))
+
+(defmacro component! (class &rest params &key &allow-other-keys)
+  `(make-instance ',class ,@params))
+|#

wh-engine/global.lisp

@@ -0,0 +1,157 @@
+;;;; wh-engine/global.lisp
+;;;; global variables and utility functions
+(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."
+  (setf *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*)
+    (setf *id-counter* (+ id 1)))
+  id)
+
+(defstruct id-ref
+  (scene 0 :type fixnum)
+  (actor nil :type (or fixnum null))
+  (component nil :type (or symbol null)))
+
+(deftype pointer () '(or id-ref weak-pointer null))
+
+(declaim (inline deref-sus-pointer))
+(defun deref-sus-pointer (val)
+  "Dereference val, and warn if it's suspended."
+  (declare (type pointer val))
+  (etypecase val
+    (weak-pointer (weak-pointer-value val))
+    (id-ref (warn "dereferencing sus pointer ~S" val)
+     (weak-pointer-value (pointerize val)))
+    (null nil)))
+
+(defun referize (ptr)
+  "Convert ptr into an id-ref."
+
+  (let ((target (etypecase ptr
+                  (weak-pointer (weak-pointer-value ptr))
+                  ((or scene actor component) ptr))))
+    (etypecase target
+      (scene
+       (make-id-ref :scene (o! target id)))
+      (actor
+       (make-id-ref :scene (etypecase (o! target :slot scene)
+                                      (weak-pointer (o! target scene id))
+                                      (id-ref (id-ref-scene (o! target :slot scene))))
+                    :actor (o! target id)))
+      (component
+       (make-id-ref :scene (etypecase (o! target :slot actor)
+                                      (weak-pointer (o! target scene id))
+                                      (id-ref (id-ref-scene (o! target :slot actor))))
+                    :actor (etypecase (o! target :slot actor)
+                                      (weak-pointer (o! target actor id))
+                                      (id-ref (id-ref-actor (o! target :slot actor))))
+                    :component (class-name (class-of target))))
+      )))
+
+(defun dereferize (ref)
+  "Return the object specified by id-ref ref."
+  (declare (type id-ref ref))
+
+  (let ((scene (get-scene (id-ref-scene ref))) actor component)
+    (unless scene
+      (error "can't dereferize ~S (scene not found)" ref))
+    (if (id-ref-actor ref)
+        (if (setf actor (o! scene (get-actor (id-ref-actor ref))))
+            (if (id-ref-component ref)
+                (if (setf component (o! actor (get-component (find-class (id-ref-component ref)))))
+                    component
+                    (error "can't dereferize ~S (component not found)" ref))
+                actor)
+            (error "can't dereferize ~S (actor not found)" ref))
+        scene)))
+
+(defun pointerize (ref)
+  "Convert id-ref ref into a weak-pointer."
+  (declare (type id-ref ref))
+
+  (make-weak-pointer (dereferize ref)))
+
+(defmacro referize-setf (place)
+  `(when (typep ,place 'weak-pointer)
+     (setf ,place (referize ,place))))
+(defmacro pointerize-setf (place)
+  `(when (typep ,place 'id-ref)
+     (setf ,place (pointerize ,place))))
+
+(defvar *world-scenes* ()
+  "List of all running scenes.")
+
+(defun get-scene (scene-id)
+  "Get a scene by its ID."
+  (find-if (lambda (scene) (eq (o! scene id) scene-id)) *world-scenes*))

wh-engine/main.lisp

@@ -1,85 +1,6 @@
 ;;;; 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."
-  (setf *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*)
-    (setf *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))
@@ -94,10 +15,6 @@
   (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 initialize-actors-in (scene &rest actors)
   "Properly attach actors and their descendents to scene, and initialize them."
   (loop for actor in actors
@@ -127,62 +44,36 @@
 (defvar *world-views* nil
   "List of all known views.")
 
+(defvar *delta-time* 0.0
+  "Time in seconds since the last game tick.")
+
 (defun register-test-scene ()
-  (let (test-scene test-actor test-drawable test-actor-2 camera-actor camera-view child-actor grandchild-actor)
+  (let ((test-scene (new! scene :id -1 :name "Test scene")))
-    (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))
-
-    ;;(sb-ext:gc)
     (initialize-actors-in test-scene
-                          test-actor test-actor-2 camera-actor)
+                          (new! actor
-
+                                :name "Actor"
+                                :component (new! drawable-test))
+                          (new! actor
+                                :name "Actor 2"
+                                :location (vec2 0.5 0.5)
+                                :rotation (coerce (/ pi 4) 'single-float)
+                                :z-layer -1
+                                :component (new! drawable-test :colour (vec4 0 1 0 1))
+                                :child (new! actor
+                                             :name "Child Actor"
+                                             :location (vec2 0 0.5)
+                                             :z-layer -2
+                                             :component (new! drawable-test :colour (vec4 0 1 1 1))
+                                             :child (new! actor
+                                                          :name "Grandchild Actor"
+                                                          :location (vec2 0 1)
+                                                          :scale (vec2 0.25 0.25)
+                                                          :z-layer 1
+                                                          :component (new! drawable-test :colour (vec4 1 1 0 1)))))
+                          (new! actor
+                                :name "Camera"
+                                :component (new! view)))
     test-scene))
 
 (defun run ()
@@ -203,7 +94,11 @@
               (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))))
+              (win-height (nth-value 1 (sdl2:get-window-size win)))
+              (prev-tick (sdl2:get-ticks))
+              (this-tick (sdl2:get-ticks))
+              (prev-profiling-tick (sdl2:get-performance-counter))
+              (profiling-scale (/ (sdl2:get-performance-frequency) 1000.0)))
           ;; set up framebuffer
           (gl:bind-framebuffer :framebuffer framebuf)
 
@@ -244,9 +139,16 @@
           (sdl2:with-event-loop (:method :poll)
             (:quit () t)
             (:idle ()
+                   (setf prev-profiling-tick (sdl2:get-performance-counter))
+                   ;; calculate delta-time
+                   (setf this-tick (sdl2:get-ticks))
+                   (setf *delta-time* (* (- this-tick prev-tick) 0.001))
+                   (setf prev-tick this-tick)
+                   (format t "Δt = ~S (~S FPS)~%" *delta-time* (/ 1.0 *delta-time*))
                    ;; update
                    (loop for scene in *world-scenes*
                          do (o! scene (update)))
+                   (format t "game=~S " (/ (- (sdl2:get-performance-counter) prev-profiling-tick) profiling-scale))
                    ;; draw to render texture
                    (gl:bind-framebuffer :framebuffer framebuf)
                    (gl:viewport 0 0 *view-width* *view-height*)
@@ -261,6 +163,8 @@
                                     (setf render-pass (o! view render-pass))
                                     (gl:clear :depth-buffer))
                                   (o! view (render-view *world-drawables*)))))
+                   (gl:flush)
+                   (format t "draw=~S " (/ (- (sdl2:get-performance-counter) prev-profiling-tick) profiling-scale))
 
                    ;; now draw to window
                    (gl:bind-framebuffer :framebuffer 0)
@@ -272,7 +176,7 @@
                    (gl:matrix-mode :modelview)
                    (gl:load-identity)
 
-                   (gl:with-primitive :quads
+                   (gl:with-primitives :quads
                      (gl:color 1.0 1.0 1.0 1.0)
                      (gl:tex-coord 0.0 0.0)
                      (gl:vertex 0.0 0.0)
@@ -286,5 +190,6 @@
                    (gl:disable :texture-2d)
 
                    (gl:flush)
+                   (format t "blit=~S~%" (/ (- (sdl2:get-performance-counter) prev-profiling-tick) profiling-scale))
                    (sdl2:gl-swap-window win)))
           )))))

wh-engine/package.lisp

@@ -19,6 +19,7 @@
    *view-width* *view-height* *view-ppu* *pixel-scale*
    register-test-scene
    run
+   *delta-time*
 
    ;; serialization.lisp
    id-ref make-id-ref
@@ -68,6 +69,10 @@
    start update
    destroy
 
+   ;; actor-macros.lisp
+   new!
+   define-new!-impl
+
    ;; scene.lisp
    scene
    ; properties

wh-engine/serialization.lisp

@@ -1,77 +1,6 @@
  ;;;; wh-engine/serialization.lisp
 (in-package wh-engine)
 
-(defstruct id-ref
-  (scene 0 :type fixnum)
-  (actor nil :type (or fixnum null))
-  (component nil :type (or symbol null)))
-
-(deftype pointer () '(or id-ref weak-pointer null))
-
-(declaim (inline deref-sus-pointer))
-(defun deref-sus-pointer (val)
-  "Dereference val, and warn if it's suspended."
-  (declare (type pointer val))
-  (etypecase val
-    (weak-pointer (weak-pointer-value val))
-    (id-ref (warn "dereferencing sus pointer ~S" val)
-     (weak-pointer-value (pointerize val)))
-    (null nil)))
-
-(defun referize (ptr)
-  "Convert ptr into an id-ref."
-
-  (let ((target (etypecase ptr
-                  (weak-pointer (weak-pointer-value ptr))
-                  ((or scene actor component) ptr))))
-    (etypecase target
-      (scene
-       (make-id-ref :scene (o! target id)))
-      (actor
-       (make-id-ref :scene (etypecase (o! target :slot scene)
-                                      (weak-pointer (o! target scene id))
-                                      (id-ref (id-ref-scene (o! target :slot scene))))
-                    :actor (o! target id)))
-      (component
-       (make-id-ref :scene (etypecase (o! target :slot actor)
-                                      (weak-pointer (o! target scene id))
-                                      (id-ref (id-ref-scene (o! target :slot actor))))
-                    :actor (etypecase (o! target :slot actor)
-                                      (weak-pointer (o! target actor id))
-                                      (id-ref (id-ref-actor (o! target :slot actor))))
-                    :component (class-name (class-of target))))
-      )))
-
-(defun dereferize (ref)
-  "Return the object specified by id-ref ref."
-  (declare (type id-ref ref))
-
-  (let ((scene (get-scene (id-ref-scene ref))) actor component)
-    (unless scene
-      (error "can't dereferize ~S (scene not found)" ref))
-    (if (id-ref-actor ref)
-        (if (setf actor (o! scene (get-actor (id-ref-actor ref))))
-            (if (id-ref-component ref)
-                (if (setf component (o! actor (get-component (find-class (id-ref-component ref)))))
-                    component
-                    (error "can't dereferize ~S (component not found)" ref))
-                actor)
-            (error "can't dereferize ~S (actor not found)" ref))
-        scene)))
-
-(defun pointerize (ref)
-  "Convert id-ref ref into a weak-pointer."
-  (declare (type id-ref ref))
-
-  (make-weak-pointer (dereferize ref)))
-
-(defmacro referize-setf (place)
-  `(when (typep ,place 'weak-pointer)
-     (setf ,place (referize ,place))))
-(defmacro pointerize-setf (place)
-  `(when (typep ,place 'id-ref)
-     (setf ,place (pointerize ,place))))
-
 (defun replace-in-tree (tree atom-fun)
   (if (consp (car tree))
       (replace-in-tree (car tree) atom-fun)