assembly-flow

borodust · Mar 11, 2017 · 96c54d5 · 96c54d5
1 parent 2091a95
commit 96c54d5
Show file tree

Hide file tree

Showing 10 changed files with 128 additions and 43 deletions.
diff --git a/README.md b/README.md
@@ -134,6 +134,8 @@ dependencies are made available to Quicklisp you should be able to load engine w
 
 ## Demonstrations
 
+Examples and demos [repository](https://github.com/borodust/bodge-showcase).
+
 * Chicken mesh loading, rendering and animation:
   [Chicken](https://www.youtube.com/watch?v=ypZP4SNQOv8)
 

diff --git a/engine/engine.lisp b/engine/engine.lisp
@@ -139,6 +139,7 @@ dependencies will be initialized in the correct order according to a dependency
   (when *engine*
     (error "Engine already running"))
   (setf *engine* (make-instance 'bodge-engine))
+  (log:config :sane2)
   (in-new-thread-waiting "startup-worker"
     (with-slots (systems properties disabling-order shared-pool shared-executors
                          working-directory engine-lock)
@@ -149,10 +150,8 @@ dependencies will be initialized in the correct order according to a dependency
             engine-lock (bt:make-recursive-lock "engine-lock")
             working-directory (uiop:pathname-directory-pathname properties-pathspec)
             shared-executors (list (make-single-threaded-executor)))
-
       (log:config (property :log-level :info))
       (reload-foreign-libraries)
-
       (let ((system-class-names
              (property :systems (lambda ()
                                   (error ":systems property should be defined")))))
@@ -180,7 +179,7 @@ initialized."
 
 (defun acquire-executor (&rest args &key (single-threaded-p nil) (exclusive-p nil)
                                       (special-variables nil))
-  "Acquire executor from the engine which corresponds to provided options:
+  "Acquire executor from the engine, properties of which correspond to provided options:
 :single-threaded-p - if t, executor will be single-threaded, otherwise it can be pooled one
 :exclusive-p - if t, this executor cannot be acquired by other requester and :special-variables
                can be specified for it, otherwise this executor could be shared among different
@@ -249,6 +248,22 @@ task is dispatched to the object provided under this key."
   (value-flow nil))
 
 
+(defgeneric initialization-flow (object &key &allow-other-keys)
+  (:documentation "Return flow that initializes an object.
+Flow variant of #'initialize-instance, although no guarantees
+about object returned from the flow are provided.")
+  (:method (object &key &allow-other-keys)))
+
+
+(defgeneric assembly-flow (class &key &allow-other-keys)
+  (:documentation "Return flow that constructs an object and returns it.
+Flow variant of #'make-instance.")
+  (:method (class &rest initargs &key &allow-other-keys)
+    (let ((instance (apply #'make-instance class initargs)))
+      (>> (apply #'initialization-flow instance initargs)
+          (value-flow instance)))))
+
+
 (defun run (fn)
   "Dispatch flow using engine as a dispatcher."
   (cl-flow:run-flow (engine) fn))

diff --git a/engine/math/vector.lisp b/engine/math/vector.lisp
@@ -25,6 +25,21 @@
   (%raw-> vec3 (v3:make (vref vec 0) (vref vec 1) (vref vec 2))))
 
 
+(defgeneric vector-length (vec))
+
+
+(defmethod vector-length ((this vec2))
+  (v2:length (value-of this)))
+
+
+(defmethod vector-length ((this vec3))
+  (v3:length (value-of this)))
+
+
+(defmethod vector-length ((this vec4))
+  (v4:length (value-of this)))
+
+
 (defgeneric make-vec3 (val &key))
 
 

diff --git a/engine/packages.lisp b/engine/packages.lisp
@@ -69,6 +69,7 @@
            y
            z
            w
+           vector-length
 
            mat
            square-mat
@@ -125,6 +126,8 @@
            concurrently
            value-flow
            null-flow
+           assembly-flow
+           initialization-flow
 
            system-object
            system-of

diff --git a/scene/model.lisp b/scene/model.lisp
@@ -4,8 +4,10 @@
 (defclass model (scene-node) ())
 
 
-(defgeneric make-model-graph (model))
+(defgeneric model-graph-assembly-flow (model))
 
 
-(defmethod initialize-instance :after ((this model) &key)
-  (adopt this (make-model-graph this)))
+(defmethod initialization-flow ((this model) &key)
+  (>> (model-graph-assembly-flow this)
+      (instantly (subgraph)
+        (adopt this subgraph))))
diff --git a/scene/packages.lisp b/scene/packages.lisp
@@ -18,10 +18,10 @@
            node-enabled-p
            initialize-node
            discard-node
+           node-initialization-flow
            tree-initialization-flow
            discard-tree
 
-
            *scene*
            *projection-matrix*
            *view-matrix*
@@ -51,7 +51,7 @@
            shading-parameters-node
 
            model
-           make-model-graph
+           model-graph-assembly-flow
 
            simulation-pass
            make-simulation-pass
@@ -66,4 +66,7 @@
            bone-node
            root-bone-of
 
+           *banner-texture*
+           banner-node
+
            scenegraph))
diff --git a/scene/rendering/banner.lisp b/scene/rendering/banner.lisp
@@ -0,0 +1,46 @@
+(in-package :cl-bodge.scene)
+
+
+(declaim (special *banner-texture*))
+
+
+(defclass banner-node (scene-node)
+  ((program :initarg :program)
+   ;; FIXME: share mesh too
+   (mesh :initform nil)))
+
+
+(defmethod discard-node banner :before ((this banner-node))
+  (with-slots (mesh) this
+    (dispose mesh)))
+
+
+(defmethod assemble-node ((class (eql 'banner-node)) &key)
+  (>> (call-next-method)
+      (-> ((graphics)) (this)
+        (with-slots (mesh) this
+          (setf mesh (make-mesh 4 :triangle-strip))
+          (with-disposable ((vbuf (make-array-buffer (make-array '(4 2)
+                                                                 :element-type 'single-float
+                                                                 :initial-contents
+                                                                 '((1.0 0.0)
+                                                                   (1.0 1.0)
+                                                                   (0.0 0.0)
+                                                                   (0.0 1.0)))))
+                            (tbuf (make-array-buffer #2a((1.0 0.0)
+                                                         (1.0 1.0)
+                                                         (0.0 0.0)
+                                                         (0.0 1.0)))))
+            (attach-array-buffer vbuf mesh 0)
+            (attach-array-buffer tbuf mesh 1)))
+        this)))
+
+
+(defmethod scene-pass ((this banner-node) (pass rendering-pass) input)
+  (with-slots (texture program mesh) this
+    (with-active-shading-program (program)
+      (setf (program-uniform-variable program "MVP") (model-view-projection-matrix)
+            (program-uniform-variable program "banner") 0)
+      (with-bound-texture (*banner-texture*)
+        (render mesh))))
+  (call-next-method))
diff --git a/scene/rendering/mesh.lisp b/scene/rendering/mesh.lisp
@@ -7,12 +7,13 @@
   ((mesh :initform nil)))
 
 
-(defgeneric make-node-mesh (node graphics-system))
+(defgeneric make-node-mesh (node))
 
 
-(defmethod initialize-node :after ((this mesh-node) (sys graphics-system))
-  (with-slots (mesh) this
-    (setf mesh (make-node-mesh this sys))))
+(defmethod initialization-flow ((this mesh-node) &key)
+  (-> ((graphics)) ()
+    (with-slots (mesh) this
+      (setf mesh (make-node-mesh this)))))
 
 
 (defmethod node-enabled-p ((this mesh-node))

diff --git a/scene/rendering/shading.lisp b/scene/rendering/shading.lisp
@@ -77,10 +77,10 @@
     (not (null pipeline))))
 
 
-(defmethod initialize-node :after ((this shading-pipeline-node)
-                                   (sys graphics-system))
-  (with-slots (pipeline) this
-    (setf pipeline (make-shading-pipeline))))
+(defmethod initialization-flow ((this shading-pipeline-node) &key)
+  (-> ((graphics)) ()
+    (with-slots (pipeline) this
+      (setf pipeline (make-shading-pipeline)))))
 
 
 (defmethod discard-node :before ((this shading-pipeline-node))
@@ -112,11 +112,11 @@
     (not (null program))))
 
 
-(defmethod initialize-node :after ((this shading-program-node)
-                                   (sys graphics-system))
-  (with-slots (program sources parameters) this
-    (setf program (build-shading-program sources)
-          parameters (mapcar #'uniform-name (uniforms-of program)))))
+(defmethod initialization-flow ((this shading-program-node) &key)
+  (-> ((graphics)) ()
+    (with-slots (program sources parameters) this
+      (setf program (build-shading-program sources)
+            parameters (mapcar #'uniform-name (uniforms-of program))))))
 
 
 (defmethod discard-node :before ((this shading-program-node))

diff --git a/scene/scene.lisp b/scene/scene.lisp
@@ -24,22 +24,10 @@
   (:method (node) t))
 
 
-(defgeneric initialize-node (node system)
-  (:method (node system)))
-
-
 (defgeneric discard-node (node)
   (:method (node)))
 
 
-(defun tree-initialization-flow (root &rest systems)
-  (flet ((initializer (system)
-           (-> (system :priority :high :important-p t) ()
-             (dotree (node root)
-               (initialize-node node system)))))
-    (~> (mapcar #'initializer systems))))
-
-
 (defun discard-tree (root)
   (dotree (node root :post)
     (discard-node node)))
@@ -140,15 +128,25 @@
 ;;;
 ;;;
 ;;;
-(defmacro %parse-node (node-def)
-  (destructuring-bind (ctor-def &rest children) node-def
-    (destructuring-bind (class &rest plist) (if (listp ctor-def)
-                                                ctor-def
-                                                (list ctor-def))
-      `(let ((node (make-instance ',class ,@plist)))
-         ,@(loop for child-def in children collecting
-                `(adopt node (%parse-node ,child-def)))
-         node))))
+(defun %children-adoption-flow ()
+  (instantly (&rest nodes)
+    (let ((parent (caar nodes)))
+      (dolist (child (cdr nodes))
+        (adopt parent (car child)))
+      parent)))
+
+
+(defun %parse-tree (node-def)
+  (destructuring-bind (ctor-def &rest children) (ensure-list node-def)
+    (destructuring-bind (class &rest plist) (ensure-list ctor-def)
+      (if children
+          `(>> (~> (assembly-flow ',class ,@plist)
+                   ,@(loop for child-def in children collecting
+                          (%parse-tree child-def)))
+               (%children-adoption-flow))
+          `(assembly-flow ',class ,@plist)))))
+
 
 (defmacro scenegraph (root)
-  `(%parse-node ,root))
+  "Returns flow for constructing a scenegraph"
+  (%parse-tree root))