Change loader system around to be based on resources instead. Introdu…

…ce a dependency mechanism to allow proper loading order of resources.

assets/font.lisp

@@ -58,7 +58,10 @@
     (setf (slot-value text 'ebo) ebo)
     (setf (slot-value text 'vao) vao)))
 
-(defmethod load ((text text))
+(defmethod dependencies ((text text))
+  (list (font text)))
+
+(defmethod allocate ((text text))
   (setf (text text) (text text)))
 
 (defmethod paint ((text text) (pass shader-pass))

controller.lisp

@@ -38,8 +38,8 @@
   (:default-initargs
    :name :controller))
 
-(defmethod compute-assets ((controller controller) cache)
-  (compute-assets (text controller) cache))
+(defmethod compute-resources ((controller controller) cache)
+  (compute-resources (text controller) cache))
 
 (defmethod register-object-for-pass :after (pass (controller controller))
   (register-object-for-pass pass (text controller)))

loader.lisp

@@ -6,48 +6,57 @@
 
 (in-package #:org.shirakumo.fraf.trial)
 
-(defgeneric compute-assets (object traversal-cache))
+(defgeneric compute-resources (object traversal-cache))
 (defgeneric bake (bakable))
 (defgeneric baked-p (bakable))
 (defgeneric transition (from to))
+(defgeneric dependencies (resource))
 
-(defmethod compute-assets :around (object (cache null))
-  (compute-assets object (make-hash-table :test 'eq)))
+(defmethod dependencies ((resource resource))
+  ())
 
-(defmethod compute-assets :around (object (cache hash-table))
+;; FIXME: Consider using a vector to compute the resources instead.
+;;        A large vector could easily become more efficient than a
+;;        list, especially considering we are mostly APPENDing things.
+(defmethod compute-resources :around (object (cache null))
+  (compute-resources object (make-hash-table :test 'eq)))
+
+(defmethod compute-resources :around (object (cache hash-table))
   (unless (gethash object cache)
     (setf (gethash object cache) T)
     (call-next-method)))
 
-(defmethod compute-assets ((anything T) cache)
+(defmethod compute-resources ((anything T) cache)
   NIL)
 
-(defmethod compute-assets ((cons cons) cache)
-  (nconc (compute-assets (car cons) cache)
-         (compute-assets (cdr cons) cache)))
+(defmethod compute-resources ((cons cons) cache)
+  (nconc (compute-resources (car cons) cache)
+         (compute-resources (cdr cons) cache)))
 
-(defmethod compute-assets ((vector vector) cache)
+(defmethod compute-resources ((vector vector) cache)
   (unless (typep vector 'string)
     (loop for object across vector
-          nconc (compute-assets object cache))))
+          nconc (compute-resources object cache))))
 
-(defmethod compute-assets ((table hash-table) cache)
+(defmethod compute-resources ((table hash-table) cache)
   (loop for value being the hash-values of table
-        nconc (compute-assets value cache)))
+        nconc (compute-resources value cache)))
 
-(defmethod compute-assets ((object entity) cache)
+(defmethod compute-resources ((object entity) cache)
   (loop for slot in (c2mop:class-slots (class-of object))
         for name = (c2mop:slot-definition-name slot)
         when (slot-boundp object name)
-        nconc (compute-assets (slot-value object name) cache)))
+        nconc (compute-resources (slot-value object name) cache)))
 
-(defmethod compute-assets ((asset asset) cache)
-  (nconc (call-next-method) (list asset)))
+(defmethod compute-resources ((resource resource) cache)
+  (nconc (call-next-method)
+         (dependencies resource)
+         (list resource)))
 
 (defclass bakable ()
   ((baked-p :initform NIL :accessor baked-p)))
 
-(defmethod compute-assets :before ((bakable bakable) cache)
+(defmethod compute-resources :before ((bakable bakable) cache)
   (bake bakable))
 
 (defmethod bake :around ((bakable bakable))
@@ -57,15 +66,15 @@
 
 (defmethod transition ((from null) (to scene))
   (v:info :trial.loader "Transitioning to ~a" to)
-  (let ((to-load (compute-assets to NIL)))
+  (let ((to-load (topological-sort-by-dependencies (compute-resources to NIL))))
     (v:info :trial.loader "Loading ~a assets." (length to-load))
     (v:debug :trial.loader "Loading:~%~a" to-load)
     (mapc #'load to-load)
     to))
 
 (defmethod transition ((from scene) (to null))
   (v:info :trial.loader "Transitioning from ~a" from)
-  (let ((to-deallocate (compute-assets to NIL)))
+  (let ((to-deallocate (compute-resources to NIL)))
     (v:info :trial.loader "Deallocating ~a assets." (length to-deallocate))
     (v:debug :trial.loader "Deallocating:~%~a" to-deallocate)
     (mapc #'deallocate to-deallocate)
@@ -76,16 +85,35 @@
     (dolist (item b) (setf (gethash item table) T))
     (remove-if (lambda (item) (gethash item table)) a)))
 
+(defun topological-sort-by-dependencies (resources)
+  (let ((status (make-hash-table :test 'eq))
+        (sorted ()))
+    (labels ((visit (resource)
+               (case (gethash resource status :unvisited)
+                 (:temporary
+                  (warn "Dependency loop detected on ~a." resource))
+                 (:unvisited
+                  (setf (gethash resource status) :temporary)
+                  (dolist (dependency (dependencies resource))
+                    ;; Avoid injecting dependencies that are not part of the
+                    ;; resource loading list to avoid duplicate loading.
+                    (when (find dependency resources)
+                      (visit dependency)))
+                  (setf (gethash resource status) :done)
+                  (push resource sorted)))))
+      (mapc #'visit resources))
+    (nreverse sorted)))
+
 (defmethod transition ((from scene) (to scene))
   (v:info :trial.loader "Transitioning from ~a to ~a" from to)
-  (let* ((from (compute-assets from NIL))
-         (to (compute-assets to NIL))
-         (to-load (stable-set-difference-eq to from))
-         (to-offload (stable-set-difference-eq from to)))
-    (v:info :trial.loader "Loading ~a assets." (length to-load))
+  (let* ((from (compute-resources from NIL))
+         (to (compute-resources to NIL))
+         (to-load (topological-sort-by-dependencies (stable-set-difference-eq to from)))
+         (to-deallocate (stable-set-difference-eq from to)))
+    (v:info :trial.loader "Loading ~a asset~:p." (length to-load))
     (v:debug :trial.loader "Loading:~%~a" to-load)
     (mapc #'load to-load)
-    (v:info :trial.loader "Offloading ~a assets." (length to-offload))
-    (v:debug :trial.loader "Offloading:~%~a" to-offload)
-    (mapc #'offload to-offload)
+    (v:info :trial.loader "Deallocating ~a asset~:p." (length to-deallocate))
+    (v:debug :trial.loader "Deallocating:~%~a" to-deallocate)
+    (mapc #'deallocate to-deallocate)
     to))

resources/framebuffer.lisp

@@ -11,10 +11,17 @@
   (:default-initargs
    :attachments (error "ATTACHMENTS required.")))
 
+(defmethod print-object ((framebuffer framebuffer) stream)
+  (print-unreadable-object (framebuffer stream :type T :identity T)
+    (format stream "~:{~a ~}" (attachments framebuffer))))
+
 (defmethod destructor ((framebuffer framebuffer))
   (let ((fbo (gl-name framebuffer)))
     (lambda () (gl:delete-framebuffers (list fbo)))))
 
+(defmethod dependencies ((framebuffer framebuffer))
+  (mapcar #'second (attachments framebuffer)))
+
 (defmethod allocate ((framebuffer framebuffer))
   (let ((fbo (gl:gen-framebuffer)))
     (with-cleanup-on-failure (gl:delete-framebuffers (list fbo))

resources/shader-program.lisp

@@ -25,6 +25,9 @@
   (let ((prog (gl-name program)))
     (lambda () (gl:delete-program prog))))
 
+(defmethod dependencies ((program shader-program))
+  (copy-list (shaders program)))
+
 (defmethod allocate ((program shader-program))
   (let ((shaders (shaders program)))
     (check-shader-compatibility shaders)

resources/shader.lisp

@@ -13,9 +13,13 @@
    :type (error "TYPE required.")
    :source (error "SOURCE required.")))
 
-(defmethod initialize-instance :before ((asset shader) &key type)
+(defmethod initialize-instance :before ((shader shader) &key type)
   (check-shader-type type))
 
+(defmethod print-object ((shader shader) stream)
+  (print-unreadable-object (shader stream :type T :identity T)
+    (format stream "~a" (shader-type shader))))
+
 (defmethod destructor ((shader shader))
   (let ((shdr (gl-name shader)))
     (lambda () (gl:delete-shader shdr))))

resources/vertex-array.lisp

@@ -16,6 +16,9 @@
   (let ((vao (gl-name array)))
     (lambda () (gl:delete-vertex-arrays (list vao)))))
 
+(defmethod dependencies ((array vertex-array))
+  (mapcar #'unlist (buffers array)))
+
 (defmethod allocate ((array vertex-array))
   (let ((vao (gl:gen-vertex-array)))
     (with-cleanup-on-failure (gl:delete-vertex-arrays (list vao))

resources/vertex-buffer.lisp

@@ -18,11 +18,15 @@
    :element-type :float
    :data-usage :static-draw))
 
-(defmethod initialize-instance :before ((asset vertex-buffer) &key buffer-type element-type data-usage)
+(defmethod initialize-instance :before ((buffer vertex-buffer) &key buffer-type element-type data-usage)
   (check-vertex-buffer-type buffer-type)
   (check-vertex-buffer-element-type element-type)
   (check-vertex-buffer-data-usage data-usage))
 
+(defmethod print-object ((buffer vertex-buffer) stream)
+  (print-unreadable-object (buffer stream :type T :identity T)
+    (format stream "~a ~a ~a" (data-usage buffer) (buffer-type buffer) (element-type buffer))))
+
 (defmethod destructor ((buffer vertex-buffer))
   (let ((vbo (gl-name buffer)))
     (lambda () (gl:delete-buffers (list vbo)))))