Merge event system into engine. Simplify event-related interfaces

borodust · May 5, 2017 · dc61242 · dc61242
1 parent 7b3965d
commit dc61242
Show file tree

Hide file tree

Showing 19 changed files with 190 additions and 270 deletions.
diff --git a/README.md b/README.md
@@ -11,12 +11,8 @@ Experimental **bod**acious **g**ame **e**ngine written in **C**ommon **L**isp.
 
 * ***Foundations***
 
-  Basic engine blocks for memory management, concurrency, math and systems. Everything else is
-  built on top. See `cl-bodge/engine`.
-
-* ***Events***
-
-  Base for event-driven systems. See `cl-bodge/events`.
+  Basic engine blocks for memory management, concurrency, math, events and systems. Everything
+  else is built on top. See `cl-bodge/engine`.
 
 * ***Host***
 
@@ -148,4 +144,4 @@ Examples and demos [repository](https://github.com/borodust/bodge-showcase).
   [Text editing](https://www.youtube.com/watch?v=T5nCKKGj1J0)
 
 ## Help and Support
-You can receive those in `#cl-bodge` or `#lispgames` IRC channels at `freenode.net`.
+You can receive those in `#cl-bodge` or `#lispgames` IRC channels at `freenode.net`.
diff --git a/cl-bodge.asd b/cl-bodge.asd
@@ -51,33 +51,23 @@
                (:module resources
                         :components ((:file "audio")
                                      (:file "graphics")))
+               (:module events
+                        :components ((:file "event")
+                                     (:file "emitter")
+                                     (:file "listener")))
                (:file "properties")
                (:file "engine")
                (:file "generic-system")
                (:file "thread-bound-system")))
 
 
-(defsystem cl-bodge/events
-  :description "Bodacious Game Engine event system"
-  :version "0.3.0"
-  :author "Pavel Korolev"
-  :mailto "dev@borodust.org"
-  :license "MIT"
-  :depends-on (cl-bodge/engine cl-bodge/utils log4cl)
-  :pathname "events/"
-  :serial t
-  :components ((:file "packages")
-               (:file "event")
-               (:file "system")))
-
-
 (defsystem cl-bodge/host
   :description "Bodacious Game Engine host system"
   :version "0.3.0"
   :author "Pavel Korolev"
   :mailto "dev@borodust.org"
   :license "MIT"
-  :depends-on (cl-bodge/engine cl-bodge/utils cl-bodge/events cl-glfw3 log4cl bordeaux-threads
+  :depends-on (cl-bodge/engine cl-bodge/utils cl-glfw3 log4cl bordeaux-threads
                                cl-muth trivial-main-thread)
   :pathname "host/"
   :serial t
@@ -284,7 +274,7 @@
   :mailto "dev@borodust.org"
   :license "MIT"
   :depends-on (cl-bodge/engine cl-bodge/utils cl-bodge/poiu cl-bodge/physics
-                               cl-bodge/host cl-bodge/events cl-bodge/scenegraph)
+                               cl-bodge/host cl-bodge/scenegraph)
   :pathname "interactions/"
   :serial t
   :components ((:file "packages")
@@ -364,7 +354,7 @@
   :author "Pavel Korolev"
   :mailto "dev@borodust.org"
   :license "MIT"
-  :depends-on (cl-bodge/engine cl-bodge/utils cl-bodge/events cl-bodge/host
+  :depends-on (cl-bodge/engine cl-bodge/utils cl-bodge/host
                                cl-bodge/graphics cl-bodge/audio cl-bodge/physics
                                cl-bodge/resources cl-bodge/scenegraph
                                cl-bodge/poiu cl-bodge/text cl-bodge/canvas

diff --git a/engine/engine.lisp b/engine/engine.lisp
@@ -73,13 +73,6 @@ file is stored."
   (:documentation "Base class for all engine systems"))
 
 
-(defgeneric notify-system (system notification &key &allow-other-keys)
-  (:method (system notification &key))
-  (:documentation "System's callback which is called by engine during various
-  events. `notification` can be one of those:
-:engine-started"))
-
-
 (defgeneric enable (system)
   (:method (system) nil)
   (:documentation "Enable engine's system synchronousy."))
@@ -188,9 +181,7 @@ directories used by the engine are relative to 'working-directory parameter."
         (when (null system-class-names)
           (error "(:engine :systems) property should be defined and cannot be nil"))
         (setf systems (alist-hash-table (instantiate-systems system-class-names))
-              disabling-order (enable-requested-systems systems)))
-      (loop for system being the hash-value of systems
-         do (notify-system system :engine-started)))))
+              disabling-order (enable-requested-systems systems))))))
 
 
 (defun shutdown ()

diff --git a/engine/events/emitter.lisp b/engine/events/emitter.lisp
@@ -0,0 +1,83 @@
+(in-package :cl-bodge.events)
+
+
+;;
+(defclass handler-registry (lockable)
+  ((handler-table :initform (make-hash-table))))
+
+
+(defun invoke-handlers (reg event)
+  (with-slots (handler-table) reg
+    (destructuring-bind (&optional handler-lock &rest handlers)
+        (with-instance-lock-held (reg)
+          (gethash (class-of event) handler-table))
+      (when handler-lock
+        (flet ((acquire-rest (list)
+                 (bt:with-recursive-lock-held (handler-lock)
+                   (rest list))))
+          (loop for handler in handlers by #'acquire-rest
+             do (etypecase handler
+                  (function (funcall handler event))
+                  (symbol (funcall (symbol-function handler) event)))))))))
+
+
+(defun register-handler (reg event-class handler)
+  (with-slots (handler-table) reg
+    (with-instance-lock-held (reg)
+      (push handler (cdr (gethash event-class
+                                  handler-table
+                                  (list (bt:make-recursive-lock "handler-list-lock"))))))))
+
+
+(defun remove-handler (reg event-class handler)
+  (with-slots (handler-table) reg
+    (with-instance-lock-held (reg)
+      (when-let ((handler-list (gethash event-class handler-table)))
+        (deletef (cdr handler-list) handler)))))
+
+
+
+;;
+(defclass event-emitter ()
+  ((handler-registry :initform (make-instance 'handler-registry))))
+
+
+(defun fire-event (event emitter)
+  (with-slots (handler-registry) emitter
+    (invoke-handlers handler-registry event)))
+
+
+(defgeneric subscribe-to (event-class-name emitter handler)
+  (:method (event-class-name (emitter event-emitter) handler)
+    (with-slots (handler-registry) emitter
+      (let ((event-class (find-class event-class-name)))
+        (register-handler handler-registry event-class handler)))
+    handler))
+
+
+(defgeneric unsubscribe-from (event-class-name emitter handler)
+  (:method (event-class-name (emitter event-emitter) handler)
+    (with-slots (handler-registry) emitter
+      (let ((event-class (find-class event-class-name)))
+        (remove-handler handler-registry event-class handler)))
+    handler))
+
+
+(defmacro %with-accessor-bindings ((accessor-bindings event-var) &body body)
+  (let ((bindings (loop for binding in accessor-bindings
+                     for (name accessor) = (if (and (listp binding) (second binding))
+                                               binding
+                                               (list binding (symbolicate binding '-from)))
+                     collect `(,name (,accessor ,event-var)))))
+    `(symbol-macrolet ,bindings
+       ,@body)))
+
+
+(defmacro subscribe-body-to ((event-class emitter (&rest accessor-bindings)
+                                          &optional (event-var (gensym)))
+                             &body body)
+  `(subscribe-to ',event-class ,emitter
+                 (lambda (,event-var)
+                   (declare (ignorable ,event-var))
+                   (%with-accessor-bindings (,accessor-bindings ,event-var)
+                     ,@body))))
diff --git a/engine/events/event.lisp b/engine/events/event.lisp
@@ -0,0 +1,21 @@
+(in-package :cl-bodge.events)
+
+;;;
+;;;
+;;;
+(defclass event () ())
+
+
+(defmacro defevent (name (&rest superclass-names) (&rest field-names) &rest class-options)
+  (let ((constructor-name (symbolicate 'make- name)))
+    `(progn
+       (defclass ,name (,@superclass-names)
+         (,@(loop for field-name in field-names collecting
+                 `(,field-name :initarg ,(make-keyword field-name)
+                               :initform (error "~a must be provided" ',field-name)
+                               :reader ,(symbolicate field-name '-from))))
+         ,@class-options)
+       (declaim (inline ,constructor-name))
+       (defun ,constructor-name (,@field-names)
+         (make-instance ',name ,@(loop for field-name in field-names appending
+                                      `(,(make-keyword field-name) ,field-name)))))))
diff --git a/engine/events/listener.lisp b/engine/events/listener.lisp
@@ -0,0 +1,22 @@
+(in-package :cl-bodge.events)
+
+
+(defclass event-listener ()
+  ((callbacks :initform (list))))
+
+
+(defun register-event-handler (event-listener event-class-name handler emitter)
+  (with-slots (callbacks) event-listener
+    (push (list event-class-name emitter handler) callbacks)))
+
+
+(defun subscribe-listener (event-listener)
+  (with-slots (callbacks) event-listener
+    (dolist (args callbacks)
+      (apply #'subscribe-to args))))
+
+
+(defun unsubscribe-listener (event-listener)
+  (with-slots (callbacks) event-listener
+    (dolist (args callbacks)
+      (apply #'unsubscribe-from args))))
diff --git a/engine/packages.lisp b/engine/packages.lisp
@@ -15,7 +15,7 @@
            foreign-pointer-of))
 
 
-(defpackage :cl-bodge.concurrency
+(ge.util:define-package :cl-bodge.concurrency
   (:nicknames :ge.mt)
   (:use :cl-bodge.utils :cl-bodge.memory
         :cl :bordeaux-threads :cl-muth :cl-flow)
@@ -43,7 +43,7 @@
            with-instance-lock-held))
 
 
-(defpackage :cl-bodge.math
+(ge.util:define-package :cl-bodge.math
   (:nicknames :ge.math)
   (:use :cl :cl-bodge.utils)
   (:export lerp
@@ -116,7 +116,7 @@
            rotate))
 
 
-(defpackage :cl-bodge.engine.resources
+(ge.util:define-package :cl-bodge.engine.resources
   (:nicknames :ge.ng.rsc)
   (:use :cl :cl-bodge.utils)
   (:export pixel-format
@@ -137,16 +137,28 @@
            audio-sampling-rate-of))
 
 
+(ge.util:define-package :cl-bodge.events
+  (:nicknames :ge.eve)
+  (:use :cl :cl-bodge.utils :cl-bodge.concurrency)
+  (:export event
+           defevent
+           fire-event
+           subscribe-to
+           unsubscribe-from
+           subscribe-body-to
+           event-emitter
+           event-listener))
+
+
 (ge.util:define-package :cl-bodge.engine
   (:nicknames :ge.ng)
   (:use :cl-bodge.utils :cl :bordeaux-threads :cl-muth)
   (:use-reexport :cl-bodge.concurrency :cl-bodge.memory :cl-bodge.math
-                 :cl-bodge.engine.resources)
+                 :cl-bodge.engine.resources :cl-bodge.events)
   (:export system
            enable
            disable
            enabledp
-           notify-system
            acquire-executor
            release-executor
            working-directory

diff --git a/events/event.lisp b/events/event.lisp
diff --git a/events/packages.lisp b/events/packages.lisp