Permalink
Browse files

Lots of fixes and changes and stuff and things all over the dang plac…

…e man!

Anyway just more things about the asset system rewrite, too many
detailed changes to really be useful to elaborate about in here.
The important point is that it's still broken at this point.
  • Loading branch information...
Shinmera committed Feb 18, 2018
1 parent 2a5d551 commit 2b4cdc05328258e1a7973a44d11a48bee0be207a
Showing with 189 additions and 193 deletions.
  1. +0 −4 asset-pool.lisp
  2. +16 −12 asset.lisp
  3. +17 −26 assets/font.lisp
  4. +47 −55 assets/mesh.lisp
  5. +1 −6 context.lisp
  6. +6 −9 controller.lisp
  7. +6 −6 fullscreenable.lisp
  8. +9 −9 geometry-clipmap.lisp
  9. +0 −4 geometry-shapes.lisp
  10. +2 −2 helpers.lisp
  11. +4 −4 loader.lisp
  12. +8 −5 pipeline.lisp
  13. +7 −1 resource.lisp
  14. +3 −3 resources/texture.lisp
  15. +24 −22 resources/vertex-buffer.lisp
  16. +0 −1 scene.lisp
  17. +19 −17 shader-pass.lisp
  18. +2 −2 skybox.lisp
  19. +2 −1 subject.lisp
  20. +5 −0 toolkit.lisp
  21. +11 −4 trial.asd
@@ -77,10 +77,6 @@
(defmethod pool-path ((name symbol) 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))
@@ -11,22 +11,22 @@
(name :initform NIL :accessor name)
(input :initarg :input :accessor input)))
(defmethod initialize-instance :after ((asset asset) &key pool name input)
(defmethod initialize-instance :after ((asset asset) &key pool name)
(check-type name symbol)
(setf (name asset) name)
(setf (pool asset) (etypecase pool
(symbol (pool pool T))
(symbol (find-pool pool T))
(pool pool)))
(setf (asset pool name) asset))
(defmethod reinitialize-instance :after ((asset asset) &key)
(when (loaded-p asset)
(when (allocated-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)
(cond ((allocated-p current)
(deallocate current)
(call-next-method)
(load current))
(T
@@ -38,23 +38,27 @@
(defgeneric load (asset))
(defgeneric reload (asset))
(defgeneric offload (asset))
(defgeneric loaded-p (asset))
(defmethod reload ((asset asset))
(offload asset)
(deallocate asset)
(load asset))
(defmethod load :around ((asset asset))
(unless (loaded-p asset)
(unless (allocated-p asset)
(v:trace :trial.asset "Loading ~a/~a" (name (pool asset)) (name asset))
(call-next-method)))
(defmethod offload :around ((asset asset))
(when (loaded-p asset)
(v:trace :trial.asset "Offloading ~a/~a" (name (pool asset)) (name asset))
(defmethod deallocate :around ((asset asset))
(when (allocated-p asset)
(v:trace :trial.asset "Deallocating ~a/~a" (name (pool asset)) (name asset))
(call-next-method)))
(defmethod coerce-asset-input ((asset asset) (input (eql T)))
(coerce-asset-input asset (input asset)))
(defmethod coerce-asset-input ((asset asset) thing)
thing)
(defmethod coerce-asset-input ((asset asset) (path pathname))
(pool-path (pool asset) path))
@@ -22,26 +22,19 @@
:charset *default-charset*
:size 24))
(defmethod coerce-input ((asset font) (file pathname))
file)
(defmethod coerce-input ((asset font) (file string))
(pathname file))
(defmethod finalize-resource ((type (eql 'font)) resource)
(cl-fond:free resource))
(defmethod load progn ((asset font))
(setf (resource asset)
(cl-fond:make-font (first (coerced-inputs asset))
(charset asset)
:size (size asset)
:oversample 2))
(v:debug :trial.asset "Loaded font ~a" (first (coerced-inputs asset))))
(defmethod load ((font font))
(setf (gl-name font)
(cl-fond:make-font (input font)
(charset font)
:size (size font)
:oversample 2)))
(defmethod text-extent ((font font) text)
(if (resource font)
(cl-fond:compute-extent (resource font) text)
(if (allocated-p font)
(cl-fond:compute-extent (gl-name font) text)
'(:l 0 :r 0 :t 0 :b 0 :gap 0)))
(define-shader-entity text (asset located-entity)
@@ -57,26 +50,24 @@
(defmethod initialize-instance :after ((text text) &key)
(let* ((vbo (make-instance 'vertex-buffer :buffer-type :array-buffer
:data-usage :dynamic-draw
:inputs (list (cffi:null-pointer))
:size 0))
(ebo (make-instance 'vertex-buffer :buffer-type :element-array-buffer
:data-usage :dynamic-draw
:inputs (list (cffi:null-pointer))
:size 0))
(vao (make-instance 'vertex-array :inputs `((,vbo :size 2 :stride 16 :offset 0)
(,vbo :size 2 :stride 16 :offset 8)
,ebo))))
(vao (make-instance 'vertex-array :buffers `((,vbo :size 2 :stride 16 :offset 0)
(,vbo :size 2 :stride 16 :offset 8)
,ebo))))
(setf (slot-value text 'vbo) vbo)
(setf (slot-value text 'ebo) ebo)
(setf (slot-value text 'vao) vao)))
(defmethod load progn ((text text))
(defmethod load ((text text))
(setf (text text) (text text)))
(defmethod paint ((text text) (pass shader-pass))
(let ((program (shader-program-for-pass pass text))
(vao (slot-value text 'vao))
(tex (cl-fond:texture (resource (font text))))
(tex (cl-fond:texture (gl-name (font text))))
(r (/ (size text) (size (font text)))))
(gl:active-texture :texture0)
(gl:bind-texture :texture-2d tex)
@@ -86,7 +77,7 @@
(setf (uniform program "view_matrix") (view-matrix))
(setf (uniform program "projection_matrix") (projection-matrix))
(setf (uniform program "text_color") (color text))
(gl:bind-vertex-array (resource vao))
(gl:bind-vertex-array (gl-name vao))
(%gl:draw-elements :triangles (size vao) :unsigned-int 0)
(gl:bind-vertex-array 0))
(gl:bind-texture :texture-2d 0)))
@@ -118,16 +109,16 @@ void main(){
}")
(defmethod (setf font) :after (font (entity text))
(when (resource font)
(when (allocated-p font)
(setf (text entity) (text entity))))
(defmethod (setf text) :before (text (entity text))
(let ((vao (slot-value entity 'vao))
(vbo (slot-value entity 'vbo))
(ebo (slot-value entity 'ebo))
(font (resource (font entity))))
(font (gl-name (font entity))))
(when font
(setf (size vao) (cl-fond:update-text font text (resource vbo) (resource ebo))))))
(setf (size vao) (cl-fond:update-text font text (gl-name vbo) (gl-name ebo))))))
(defmethod extent ((entity text))
(text-extent entity (text entity)))
@@ -7,61 +7,53 @@
(in-package #:org.shirakumo.fraf.trial)
(defclass mesh (asset vertex-array)
((mesh :initarg :mesh :accessor mesh)
(size :initform 0 :accessor size))
(:default-initargs :mesh NIL))
((geometry-name :initarg :geometry-name :accessor geometry-name)
(attributes :initarg :attributes :accessor attributes)
(data-usage :initarg :data-usage :accessor data-usage))
(:default-initargs
:geometry-name NIL
:data-usage :static-draw
:attributes T))
(defmethod load ((mesh mesh))
(let* ((geometry (first (coerced-inputs mesh)))
(mesh (etypecase geometry
(geometry (or (gethash (mesh mesh) (meshes geometry))
(error "~a does not contain a mesh named ~a."
geometry (mesh mesh))))
(T geometry))))
(etypecase mesh
(vertex-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 mesh) (resource new))
(setf (size mesh) (size new))))
(vertex-array
(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)
(let* ((input (coerce-asset-input mesh T))
(mesh (etypecase input
(pathname (gethash (geometry-name mesh) (meshes (read-geometry input T))))
(geometry (gethash (geometry-name mesh) (meshes input)))
(vertex-mesh input))))
(let* ((vertices (vertices mesh))
(primer (aref vertices 0))
(attributes (etypecase (attributes mesh)
((eql T) (vertex-attributes primer))
(list (attributes mesh))))
(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)))
;; Copy the contents of the mesh into the data buffer, packed.
(loop with buffer-offset = 0
for vertex across vertices
do (dolist (attribute attributes)
(setf buffer-offset (fill-vertex-attribute vertex attribute buffer buffer-offset))))
;; Construct the buffers and specs
(let* ((vbo (make-instance 'vertex-buffer :buffer-data buffer :buffer-type :array-buffer
:data-usage data-usage :element-type :float))
(ebo (make-instance 'vertex-buffer :buffer-data (faces mesh) :buffer-type :element-array-buffer
:data-usage data-usage :element-type :uint))
(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 (buffers mesh) (list* ebo specs))
(setf (size mesh) (length vertices))
(allocate mesh)
;; Clean up
(offload vbo)
(offload ebo)
(setf (inputs vbo) NIL)
(setf (inputs ebo) NIL)
(setf (inputs vao) NIL)
(static-vectors:free-static-vector buffer))
vao)))
(deallocate vbo)
(deallocate ebo)
(setf (buffer-data vbo) NIL)
(setf (buffer-data ebo) NIL)
(setf (buffers mesh) NIL)
(static-vectors:free-static-vector buffer)))))
@@ -93,9 +93,8 @@
(with-context (context)
(v:info :trial.context "Destroying context.")
(hide context)
(clear-asset-cache)
(loop for asset being the hash-values of (assets context)
do (offload asset))
do (deallocate asset))
(call-next-method))))
(defmethod create-context :around ((context context))
@@ -157,10 +156,6 @@
(defmethod describe-object :after ((context context) stream)
(context-info context stream))
(defun gl-property (name)
(handler-case (gl:get* name)
(error (err) :unavailable)))
(defun context-info (context stream)
(format stream "~&~%Running GL~a.~a ~a~%~
Sample buffers: ~a (~a sample~:p)~%~
@@ -14,9 +14,6 @@
(define-action load-game (system-action)
(key-press (eql key :f3)))
(define-action reload-assets (system-action)
(key-press (eql key :f5)))
(define-action reload-scene (system-action)
(key-press (eql key :f6)))
@@ -60,7 +57,7 @@
(vector-push (if (= 0 (frame-time (handler *context*))) 1 (/ (frame-time (handler *context*)))) fps-buffer)
(setf (vy (location text))
(- (getf (cl-fond:compute-extent (resource (font text)) "a") :t)))
(- (getf (cl-fond:compute-extent (gl-name (font text)) "a") :t)))
(setf (vx (location text)) 5)
(setf (text text) (format NIL "TIME [s]: ~8,2f~%~
FPS [Hz]: ~8,2f~%~
@@ -93,10 +90,6 @@
(map-event ev *loop*)
(retain-event ev))
;; (define-handler (controller reload-assets reload-assets 99) (ev)
;; (loop for asset being the hash-keys of (assets *context*)
;; do (load (offload asset))))
(define-handler (controller reload-scene reload-scene 99) (ev)
(let* ((display (display controller))
(old (scene display)))
@@ -111,9 +104,13 @@
:report "Give up reloading the scene and continue with the old."
(start old)))))
(defclass load-request (event)
((asset :initarg :asset)
(action :initarg :action :initform 'reload)))
(define-handler (controller load-request) (ev asset action)
(ecase action
(offload (offload asset))
(offload (deallocate asset))
(load (load asset))
(reload (reload asset))))
@@ -32,12 +32,12 @@
(list
(resize (context fullscreenable)
(first resolution)
(second resolution))
(cl-monitors:mode
(resize (context fullscreenable)
(cl-monitors:width resolution)
(cl-monitors:height resolution))
(cl-monitors:make-current resolution)))))
(second resolution)))
(cl-monitors:mode
(resize (context fullscreenable)
(cl-monitors:width resolution)
(cl-monitors:height resolution))
(cl-monitors:make-current resolution))))
(defmethod (setf fullscreen) :before (fullscreen (fullscreenable fullscreenable))
(show (context fullscreenable) :fullscreen fullscreen))
Oops, something went wrong.

0 comments on commit 2b4cdc0

Please sign in to comment.