Browse files

Tons of changes for the new asset system. Still not done, still defin…

…itely broken.
  • Loading branch information...
Shinmera committed Feb 16, 2018
1 parent 526f88d commit 2a5d5515dde1c7eb669f3acbd2ecd8587c0f7738
@@ -14,11 +14,11 @@
(defvar *pools* (make-hash-table :test 'eql))
(defun pool (name &optional errorp)
(defun find-pool (name &optional errorp)
(or (gethash name *pools*)
(when errorp (error "No pool with name ~s." name))))
(defun (setf pool) (pool name)
(defun (setf find-pool) (pool name)
(setf (gethash name *pools*) pool))
(defun remove-pool (name)
@@ -42,25 +42,25 @@
(defmacro define-pool (name &body initargs)
(check-type name symbol)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(cond ((pool ',name)
(reinitialize-instance (pool ',name) ,@initargs))
(cond ((find-pool ',name)
(reinitialize-instance (find-pool ',name) ,@initargs))
(setf (pool ',name) (make-instance 'pool :name ',name ,@initargs))))
(setf (find-pool ',name) (make-instance 'pool :name ',name ,@initargs))))
(defmethod asset ((pool pool) name &optional (errorp T))
(or (gethash name (assets pool))
(when errorp (error "No asset with name ~s on pool ~a." name pool))))
(defmethod asset ((pool symbol) name &optional (errorp T))
(let ((pool (pool pool errorp)))
(let ((pool (find-pool pool errorp)))
(when pool (asset pool name errorp))))
(defmethod (setf asset) ((asset asset) (pool pool) name)
(setf (gethash name (assets pool)) asset))
(defmethod (setf asset) ((asset asset) (pool symbol) name)
(setf (asset (pool pool T) name) asset))
(setf (asset (find-pool pool T) name) asset))
(defmethod list-assets ((pool pool))
(alexandria:hash-table-values (assets pool)))
@@ -75,12 +75,12 @@
(merge-pathnames pathname (coerce-base (base pool))))
(defmethod pool-path ((name symbol) pathname)
(pool-path (pool name T) pathname))
(pool-path (find-pool name T) pathname))
(defclass load-request (event)
((asset :initarg :asset)
(action :initarg :action :initform 'reload)))
(eval-when (:load-toplevel :execute)
(define-pool trial
:base :trial))
;; (eval-when (:load-toplevel :execute)
;; (define-pool trial
;; :base :trial))
@@ -19,6 +19,19 @@
(pool pool)))
(setf (asset pool name) asset))
(defmethod reinitialize-instance :after ((asset asset) &key)
(when (loaded-p asset)
(reload asset)))
(defmethod update-instance-for-different-class :around ((previous asset) (current asset) &key)
;; FIXME: Error recovery?
(cond ((loaded-p current)
(offload current)
(load current))
(defmethod print-object ((asset asset) stream)
(print-unreadable-object (asset stream :type T)
(format stream "~a/~a" (name (pool asset)) (name asset))))
@@ -29,8 +42,7 @@
(defgeneric loaded-p (asset))
(defmethod reload ((asset asset))
(when (loaded-p asset)
(offload asset))
(offload asset)
(load asset))
(defmethod load :around ((asset asset))
@@ -42,3 +54,24 @@
(when (loaded-p asset)
(v:trace :trial.asset "Offloading ~a/~a" (name (pool asset)) (name asset))
(defmethod coerce-asset-input ((asset asset) (path pathname))
(pool-path (pool asset) path))
(defmethod coerce-asset-input ((asset asset) (list list))
(loop for item in list collect (coerce-asset-input asset item)))
(defmacro define-asset ((pool name) type input &rest options)
(check-type pool symbol)
(check-type name symbol)
(check-type type symbol)
`(let ((,name (asset ',pool ',name NIL)))
(cond ((and ,name (eql (type-of ,name) ',type))
(reinitialize-instance ,name :input ,input ,@options))
(change-class ,name ',type :input ,input ,@options))
(setf (asset ',pool ',name)
(make-instance ',type :input ,input ,@options))))))
(trivial-indent:define-indentation define-asset (4 6 4 &rest))

This file was deleted.

Oops, something went wrong.
@@ -0,0 +1,33 @@
This file is a part of trial
(c) 2017 Shirakumo (
Author: Nicolas Hafner <>
(in-package #:org.shirakumo.fraf.trial)
(defclass image (asset texture)
(defmethod load ((image image))
(let ((input (coerce-asset-input (input image))))
(multiple-value-bind (bits width height)
(cl-soil:load-image (unlist input))
(setf (pixel-data image) bits)
(setf (width image) width)
(setf (height image) height))
(when (listp input)
(setf (pixel-data image) (list (pixel-data image)))
(dolist (input (rest input))
(multiple-value-bind (bits width height)
(cl-soil:load-image input)
(push bits (pixel-data image))
(assert (= width (width image)))
(assert (= height (height image)))))
(setf (pixel-data image) (nreverse (pixel-data image))))
(allocate image))
(mapcar #'cffi:foreign-free (enlist (pixel-data image)))))
(defmethod resize ((image image) width height)
(error "Resizing is not implemented for images."))
@@ -6,44 +6,62 @@
(in-package #:org.shirakumo.fraf.trial)
(defclass mesh (asset)
(defclass mesh (asset vertex-array)
((mesh :initarg :mesh :accessor mesh)
(size :initform 0 :accessor size))
(:default-initargs :mesh NIL))
(defmethod coerce-input ((asset mesh) (input pathname))
(read-geometry input T))
(defmethod coerce-input ((asset mesh) (input string))
(read-geometry (pathname input) T))
(defmethod coerce-input ((asset mesh) (input geometry))
(defmethod coerce-input ((asset mesh) (input vertex-mesh))
(defmethod coerce-input ((asset mesh) (input vertex-array))
(defmethod finalize-resource ((type (eql 'mesh)) resource)
(finalize-resource 'vertex-array resource))
(defmethod load progn ((asset mesh))
(let* ((geometry (first (coerced-inputs asset)))
(defmethod load ((mesh mesh))
(let* ((geometry (first (coerced-inputs mesh)))
(mesh (etypecase geometry
(geometry (or (gethash (mesh asset) (meshes geometry))
(geometry (or (gethash (mesh mesh) (meshes geometry))
(error "~a does not contain a mesh named ~a."
geometry (mesh asset))))
geometry (mesh mesh))))
(T geometry))))
(etypecase mesh
(let ((new (make-instance 'vertex-mesh :face-length (face-length mesh))))
(setf (faces new) (faces mesh))
(setf (vertices new) (vertices mesh))
(change-class new 'vertex-array :load T)
(setf (resource asset) (resource new))
(setf (size asset) (size new))))
(setf (resource mesh) (resource new))
(setf (size mesh) (size new))))
(setf (resource asset) (resource (load mesh)))
(setf (size asset) (size mesh))))))
(setf (resource mesh) (resource (load mesh)))
(setf (size mesh) (size mesh))))))
(defmethod update-instance-for-different-class :after ((mesh vertex-mesh) (vao vertex-array) &key pack load (data-usage :static-draw) attributes)
(when pack (pack mesh))
(let* ((vertices (vertices mesh))
(primer (aref vertices 0))
(attributes (or attributes (vertex-attributes primer)))
(sizes (loop for attr in attributes collect (vertex-attribute-size primer attr)))
(total-size (* (length vertices) (reduce #'+ sizes)))
(buffer (make-static-vector total-size :element-type 'single-float)))
(loop with offset = 0
for vertex across vertices
do (dolist (attribute attributes)
(setf offset (fill-vertex-attribute vertex attribute buffer offset))))
(let* ((vbo (make-asset 'vertex-buffer buffer
:data-usage data-usage :element-type :float :buffer-type :array-buffer))
(ebo (make-asset 'vertex-buffer (faces mesh)
:data-usage data-usage :element-type :uint :buffer-type :element-array-buffer))
(specs (loop with stride = (reduce #'+ sizes)
for offset = 0 then (+ offset size)
for size in sizes
for index from 0
collect (list vbo :stride (* stride (cffi:foreign-type-size :float))
:offset (* offset (cffi:foreign-type-size :float))
:size size
:index index))))
(setf (inputs vao) (list* ebo specs))
(when load
(load vao)
;; Clean up
(offload vbo)
(offload ebo)
(setf (inputs vbo) NIL)
(setf (inputs ebo) NIL)
(setf (inputs vao) NIL)
(static-vectors:free-static-vector buffer))

This file was deleted.

Oops, something went wrong.
Oops, something went wrong.

0 comments on commit 2a5d551

Please sign in to comment.