#13 Scene graph

#29 Separable shading programs and pipelines
borodust · Oct 20, 2016 · 69afd8f · 69afd8f
1 parent 2589595
commit 69afd8f
Show file tree

Hide file tree

Showing 10 changed files with 464 additions and 44 deletions.
diff --git a/cl-bodge.asd b/cl-bodge.asd
@@ -74,4 +74,7 @@
                (:module resources
                         :serial t
                         :components ((:file "shader-source")
-                                     (:file "image")))))
+                                     (:file "image")))
+               (:module scene
+                        :serial t
+                        :components ((:file "scene")))))
diff --git a/engine/thread-bound-system.lisp b/engine/thread-bound-system.lisp
@@ -35,17 +35,14 @@
 
 
 (defmethod execute ((this thread-bound-system) fn)
-  (with-system-lock-held (this)
-    (unless (enabledp this)
-      (error "Can't execute tasks. System ~a disabled" (class-name (class-of this))))
-    (with-promise (resolve reject)
-      (handler-case
-          (put-into (%job-queue-of this)
-                    (lambda ()
-                      (handler-case
-                          (resolve (funcall fn))
-                        (t (e) (log:error e) (reject e)))))
-        (interrupted ()))))) ; just continue execution
+  (with-promise (resolve reject)
+    (handler-case
+        (put-into (%job-queue-of this)
+                  (lambda ()
+                    (handler-case
+                        (resolve (funcall fn))
+                      (t (e) (log:error e) (reject e)))))
+      (interrupted ())))) ; just continue execution
 
 
 (defmethod enable ((this thread-bound-system))
@@ -60,7 +57,7 @@
              (unwind-protect
                   (progn
                     (with-system-lock-held (this)
-                      (setf (%job-queue-of this) (make-blocking-queue 512))
+                      (setf (%job-queue-of this) (make-blocking-queue 256))
                       (initialize-system this)
                       (setf thread (current-thread)))
                     (open-latch latch)

diff --git a/graphics/shading.lisp b/graphics/shading.lisp
@@ -1,7 +1,6 @@
 (in-package :cl-bodge.graphics)
 
-(defclass shading-program (gl-object)
-  ()
+(defclass shading-program (gl-object) ()
   (:default-initargs :id (gl:create-program)))
 
 
@@ -18,24 +17,34 @@
     shader))
 
 
-(defun make-program (program shader-sources)
-  (let* ((shaders (loop for src in shader-sources collect
-		       (compile-shader (shader-type-of src) (shader-text-of src)))))
+(defun make-program (this shader-sources)
+  (let ((program (id-of this))
+        (shaders (loop for src in shader-sources collect
+                      (compile-shader (shader-type-of src) (shader-text-of src)))))
     (loop for shader in shaders do (gl:attach-shader program shader))
     (gl:link-program program)
     (log:trace "Program log:~%~a" (gl:get-program-info-log program))
-    (loop for shader in shaders do (gl:delete-shader shader))))
+    (loop for shader in shaders do
+         (gl:detach-shader program shader)
+         (gl:delete-shader shader))))
 
 
-(defmethod initialize-instance :after ((this shading-program) &key shader-sources)
-  (make-program (id-of this) shader-sources))
+(defmethod initialize-instance :after ((this shading-program) &key shader-sources separable-p)
+  (gl:program-parameteri (id-of this) :program-separable separable-p)
+  (make-program this shader-sources))
 
 
 (declaim (inline make-shading-program))
 (defun make-shading-program (system &rest shader-sources)
   (make-instance 'shading-program :system system :shader-sources shader-sources))
 
 
+(declaim (inline make-separable-shading-program))
+(defun make-separable-shading-program (system &rest shader-sources)
+  (make-instance 'shading-program :system system :shader-sources shader-sources
+                 :separable-p t))
+
+
 (defun use-shading-program (program)
   (gl:use-program (id-of program)))
 
@@ -52,6 +61,37 @@
 (defun (setf program-uniform-variable) (value program variable-name)
   (when-let ((variable-idx (gl:get-uniform-location (id-of program) variable-name)))
     (etypecase value
-      (single-float (gl:uniformf variable-idx value))
-      (vec (gl:uniformfv variable-idx (vec->array value)))
-      (mat4 (gl:uniform-matrix variable-idx 4 (vector (mat->array value)) nil)))))
+      (single-float (gl:program-uniformf (id-of program) variable-idx value))
+      (vec (gl:program-uniformfv (id-of program) variable-idx (vec->array value)))
+      (mat4 (gl:program-uniform-matrix (id-of program) variable-idx 4
+                                       (vector (mat->array value)) nil)))))
+
+
+;;;
+;;; Shading program pipeline
+;;;
+(defclass shading-pipeline (gl-object) ()
+  (:default-initargs :id (gl:gen-program-pipeline)))
+
+
+(define-destructor shading-pipeline ((id id-of) (sys system-of))
+  (-> sys
+    (gl:delete-program-pipelines (list id))))
+
+
+(defun make-shading-pipeline (system)
+  (make-instance 'shading-pipeline :system system))
+
+(defmacro with-bound-shading-pipeline ((pipeline &optional previous) &body body)
+  (once-only (previous)
+    `(unwind-protect
+          (progn
+            (gl:bind-program-pipeline (id-of ,pipeline))
+            ,@body)
+       (if (null ,previous)
+           (gl:bind-program-pipeline 0)
+           (gl:bind-program-pipeline (id-of ,previous))))))
+
+
+(defun use-shading-program-stages (pipeline program &rest stages)
+  (apply #'gl:use-program-stages (id-of pipeline) (id-of program) stages))
diff --git a/graphics/textures.lisp b/graphics/textures.lisp
@@ -2,19 +2,19 @@
 
 
 (defenum texture-format
-  :gray :rgb :rgba)
+  :grey :rgb :rgba)
 
 
 (defun %pixel-format->external-format (value)
   (ecase value
-    (:gray :red)
+    (:grey :red)
     (:rgb :rgb)
     (:rgba :rgba)))
 
 
 (defun %texture-format->internal-format (value)
   (ecase value
-    (:gray :r8)
+    (:grey :r8)
     (:rgb :rgb8)
     (:rgba :rgba8)))
 

diff --git a/math/matrix.lisp b/math/matrix.lisp
@@ -30,6 +30,10 @@
   (sb-cga:rotate* x y z))
 
 
+(definline rotation-mat4 (vec)
+  (sb-cga:rotate vec))
+
+
 (definline translation-mat4* (x y z)
   (sb-cga:translate* x y z))
 

diff --git a/packages.lisp b/packages.lisp
@@ -15,7 +15,8 @@
            definline
            copy-memory
 
-           ensure-not-null))
+           ensure-not-null
+           if-unbound))
 
 
 (defpackage :cl-bodge.concurrency
@@ -190,11 +191,16 @@
            make-indexed-mesh
 
            make-shading-program
+           make-separable-shading-program
            use-shading-program
            program-uniform-variable
 
            with-bound-texture
-           make-2d-texture))
+           make-2d-texture
+
+           make-shading-pipeline
+           use-shading-program-stages
+           with-bound-shading-pipeline))
 
 
 (defpackage :cl-bodge.audio
@@ -258,6 +264,37 @@
            load-png-image))
 
 
+(defpackage :cl-bodge.scene
+  (:nicknames :ge.sg)
+  (:use :cl-bodge.utils :cl-bodge.engine :cl-bodge.graphics :cl-bodge.physics
+        :cl-bodge.math :cl-bodge.concurrency :cl-bodge.host
+        :cl :alexandria)
+  (:export scene
+           animate
+           adopt
+
+           *scene*
+           *projection-matrix*
+           *transform-matrix*
+
+           node
+           find-node
+           simulate
+           body-transform-node
+           shading-pipeline-node
+           texture-node
+           mesh-node
+           projection-node
+           update-projection
+           camera-node
+           translate-camera
+           rotate-camera
+           shading-program-node
+           shading-parameters-node
+           transform-node
+
+           scenegraph))
+
 
 (defpackage :cl-bodge
   (:use :cl)

diff --git a/physics/geometry.lisp b/physics/geometry.lisp
@@ -1,22 +1,29 @@
 (in-package :cl-bodge.physics)
 
 
-(defclass geom (ode-object) ())
-
+(defclass geom (ode-object)
+  ())
 
 
 (define-destructor geom ((id id-of) (sys system-of))
   (-> sys
     (ode:geom-destroy id)))
 
 
-(defun bind-geom (geom rigid-body)
-    (ode:geom-set-body (id-of geom) (id-of rigid-body)))
+;;;
+;;;
+;;;
+(defclass volume-geom (geom) ())
+
+
+(defgeneric bind-geom (geom rigid-body)
+  (:method ((this volume-geom) rigid-body)
+    (ode:geom-set-body (id-of this) (id-of rigid-body))))
 
 ;;;
 ;;;
 ;;;
-(defclass sphere-geom (geom) ())
+(defclass sphere-geom (volume-geom) ())
 
 
 (defun make-sphere-geom (system radius)
@@ -28,7 +35,7 @@
 ;;;
 ;;;
 ;;;
-(defclass box-geom (geom) ())
+(defclass box-geom (volume-geom) ())
 
 
 (defun make-box-geom (system x y z)
@@ -52,7 +59,7 @@
 ;;;
 ;;;
 ;;;
-(defclass capped-cylinder-geom (geom) ())
+(defclass capped-cylinder-geom (volume-geom) ())
 
 
 (defun make-capped-cylinder-geom (system radius length)

diff --git a/resources/image.lisp b/resources/image.lisp
@@ -14,7 +14,7 @@
 (defun load-png-image (path)
   (let* ((data (opticl:read-png-file path))
          (format (typecase data
-                   (opticl:8-bit-gray-image :gray)
+                   (opticl:8-bit-gray-image :grey)
                    (opticl:8-bit-rgb-image :rgb)
                    (opticl:8-bit-rgba-image :rgba))))
     (opticl:with-image-bounds (w h) data
@@ -33,7 +33,7 @@
   (loop with width = (width-of this)
      and height = (height-of this)
      and channels = (ecase (ge.gx.rsc:pixel-format-of this)
-                      (:gray 1)
+                      (:grey 1)
                       (:rgb 3)
                       (:rgba 4))
      and data = (pixels-of this)