diff options
Diffstat (limited to 'wheelwork.lisp')
| -rw-r--r-- | wheelwork.lisp | 284 |
1 files changed, 256 insertions, 28 deletions
diff --git a/wheelwork.lisp b/wheelwork.lisp index 23b328a..799f28c 100644 --- a/wheelwork.lisp +++ b/wheelwork.lisp @@ -5,7 +5,42 @@ (defvar *application* nil "current application") -(defclass/std application () +(defclass/std unit () + ((cached-model :a) + (container :with :a) + (width height :with :std 1.0) + (rotation x y :with :std 0.0) + (opacity :std 1.0 :doc "0.0 indicates it will not be rendred."))) + +(defmethod (setf closer-mop:slot-value-using-class) :after + (newval class (unit unit) slot) + (when (member (closer-mop:slot-definition-name slot) + '(scale-y scale-x rotation tx ty)) + (setf (cached-model unit) nil))) + +(defclass/std container () + ((units :with :a)) + (:documentation "Just a list of units. Made into a class so that transformation affine transformations methods can be specialzied on whole groups of units")) + +(defun add-unit (container unit) + "Adds a unit to the end of a container (thus affecting render +order). Makes sure to remove the unit from its current container if necessary." + (when (unit-container unit) + (remove-unit unit)) + (setf (container-units container) + (nconc (container-units container) + (list unit))) + unit) + +(defun remove-unit (unit) + "Removes a unit from its container. Returns T if the unit actually was removed." + (when (unit-container unit) + (setf + (container-units (unit-container unit)) (delete unit (container-units (unit-container units))) + (unit-container unit) nil) + t)) + +(defclass/std application (container) ((title :with :std "Wheelwork App") (asset-root :ri :std #P"./" :doc "Directory under which assets are stored.") (asset-classifiers @@ -17,7 +52,6 @@ (width height :with :std 800) (projection :with :a :doc "The projection matrix for the scene. Orthographic by default.") (window :with :a) - (display-root :doc "A list of objects to display, the root of a tree") (refocus-on-mousedown-p :std t) (focus last-motion-target :with :a) (frame-wait :std (/ 1000 30) :doc "Frames Per Second" :a))) @@ -42,7 +76,6 @@ '(scale width height)) (set-projection app))) - (defgeneric boot (app) (:documentation "Specialized for each subclass of APPLICATION. Responsble for setting the app up once the system @@ -70,11 +103,229 @@ (eventloop app) (cleanup app)))))) +(defvar *frame-time* nil + "Bound and available once per frame. The result of GET-UNIVERSAL-TIME.") + +(defgeneric render (thing)) +(defmethod render ((app application)) + (gl:clear-color 0.0 0.0 0.0 1.0) + (gl:clear :depth-buffer-bit :color-buffer-bit) + (dolist (thing (display-root app)) + (render thing)) + (sdl2:gl-swap-window (application-window app))) + (defun eventloop (app) - (sdl2:with-event-loop (:method :poll) - (:quit () t))) + (let ((next-frame-time + (get-universal-time)) + (*frame-time* + (get-universal-time))) + (sdl2:with-event-loop (:method :poll) + (:idle () + (when (<= next-frame-time (setf *frame-time* (get-universal-time))) + (setf next-frame-time (+ *frame-time* (frame-wait app))) + (render app))) + (:quit () t)))) + +(defgeneric translate-by (thing dx dy)) +(defgeneric rotate-by (thing radians)) +(defgeneric scale-by (thing sx sy)) +(defgeneric pixel-width (thing)) +(defgeneric (setf pixel-width) (newval thing)) +(defgeneric pixel-height (thing)) +(defgeneric (setf pixel-height) (newval thing)) + +(defgeneric visible-pixel-at-p (object x y) + (:documentation "returns T if the visible pixel at screen + coordintaes x and y belogns to object. Used for event handling.")) + +(defgeneric model-matrix (thing) + (:documentation "Returns the model matrix")) + + +(defmethod model-matrix ((u unit)) + (or (cached-model u) + (setf (cached-model u) + (let ((m (mat:meye 4))) + (mat:nmtranslate m (vec:vec (unit-x u) (unit-y u) 0.0)) + + (mat:nmtranslate m (vec:v* 0.5 (vec:vec (unit-width u) (unit-height u) 0.0))) + (mat:nmrotate m vec:+vz+ (unit-rotation u)) + (mat:nmtranslate m (vec:v* -0.5 (vec:vec (unit-width u) (unit-height u) 0.0))) + + (mat:nmscale m (vec:vec (unit-width u) (unit-height u) 1.0)) + m)))) + +(defgeneric ensure-loaded (asset) + (:documentation "Ensures that the asset is loaded into memory and ready for use. Returns the asset.")) + +(defmethod ensure-loaded :around ((thing asset)) + (unless (asset-loadedp thing) + (call-next-method) + (setf (asset-loadedp thing) t) + thing)) +(defclass/std asset () + ((path :with :ri :std (error "An asset requires a path")) + (loadedp :with :a))) +(defclass/std texture (asset) + ((width height id mipmap :with :r) + (internal-format image-format :ri :with :std :rgba) + (wrap-s wrap-t :ri :with :std :repeat) + (min-filter mag-filter :ri :with :std :nearest))) + +(defmethod ensure-loaded ((texture texture)) + (with-slots (width height id) texture + (pngload:with-png-in-static-vector (png (asset-path texture) :flip-y t) + (setf width (pngload:width png) + height (pngload:height png) + id (gl:gen-texture)) + (gl:bind-texture :texture-2d (texture-id texture)) + (gl:tex-parameter :texture-2d :texture-wrap-s (texture-wrap-s texture)) + (gl:tex-parameter :texture-2d :texture-wrap-t (texture-wrap-t texture)) + (gl:tex-parameter :texture-2d :texture-min-filter (texture-min-filter texture)) + (gl:tex-parameter :texture-2d :texture-min-filter (texture-mag-filter texture)) + (gl:tex-image-2d :texture-2d + 0 + (texture-internal-format texture) + (texture-width texture) + (texture-height texture) + 0 + (texture-image-format texture) + :unsigned-byte + (pngload:data png))))) + +(defclass/std bitmap (unit) + ((texture :ri :std (error "A bitmap requires a texture.")) + (vao shader :with :r :static))) + +(defun shader-by-type (type) + (case type + (:vertex :vertex-shader) + (:geometry :geometry-shader) + (:fragment :fragment-shader))) + +(defun gl-shader (type stage) + (let ((shader (gl:create-shader type))) + (gl:shader-source shader (varjo:glsl-code stage)) + (gl:compile-shader shader) + (unless (gl:get-shader shader :compile-status) + (error "failed to compile ~a shader:~%~a~%" + type (gl:get-shader-info-log shader))) + shader)) + +(defun create-shader (&rest sources) + (let* ((stages + (varjo:rolling-translate + (mapcar (lambda (source) + (destructuring-bind (type inputs uniforms code) source + (varjo:make-stage type inputs uniforms '(:330) code))) + sources))) + (shaders + (loop + :for stage :in stages + :for source :in sources + :collect (gl-shader (shader-by-type (car source)) + stage))) + + (program (gl:create-program))) + (dolist (shader shaders) (gl:attach-shader program shader)) + (gl:link-program program) + (unless (gl:get-program program :link-status) + (error "failed to link program: ~%~a~%" + (gl:get-program-info-log program))) + (dolist (shader shaders) + (gl:detach-shader program shader) + (gl:delete-shader shader)) + program)) + + +(defun gl-array (type &rest contents) + (let ((array (gl:alloc-gl-array type (length contents)))) + (dotimes (i (length contents) array) + (setf (gl:glaref array i) (elt contents i))))) + +(defmacro with-gl-array ((var type &rest contents) &body body) + `(let ((,var (gl-array ,type ,@contents))) + (unwind-protect (progn ,@body) + (gl:free-gl-array ,var)))) + + +(define-symbol-macro +float-size+ + (cffi:foreign-type-size :float)) + +(defmethod initialize-instance :after ((bitmap bitmap) &key) + (with-slots (vao shader width height texture) bitmap + (setf texture (ensure-loaded texture) + height (texture-height texture) + width (texture-width texture)) + (unless shader + (setf shader + (create-shader + '(:vertex + ((vert :vec2)) + ((transform :mat4)) + ((values + (* transform (vari:vec4 vert 0.0 1.0)) + vert))) ;color + '(:fragment + ((tc :vec2)) + ((tex :sampler-2d)) + ((vari:texture tex tc))))) + (gl:program-uniformi + shader + (gl:get-uniform-location shader "TEX") + 0)) + (unless vao + (setf vao (gl:gen-vertex-array)) + (gl:bind-vertex-array vao) + (let ((vbo (gl:gen-buffer))) + (with-gl-array (verts :float + 0.0 1.0 + 1.0 0.0 + 0.0 0.0 + + 0.0 1.0 + 1.0 1.0 + 1.0 0.0) + (gl:bind-buffer :array-buffer vbo) + (gl:buffer-data :array-buffer :static-draw verts))) + (gl:enable-vertex-attrib-array 0) + (gl:vertex-attrib-pointer 0 2 :float 0 (* +float-size+ 2) 0) + (gl:bind-buffer :array-buffer 0) + (gl:bind-vertex-array 0)))) + +(defmethod render ((bitmap bitmap)) + (with-slots (texture vao shader) bitmap + (gl:active-texture 0) + (gl:bind-texture :texture-2d (texture-id texture)) + (gl:use-program shader) + (gl:program-uniform-matrix-4fv + shader + (gl:get-uniform-location shader "TRANSFORM") + (mat:marr (model-matrix bitmap))) + (gl:bind-vertex-array vao) + (gl:draw-arrays :triangles 0 6) + (gl:bind-vertex-array 0))) + + +(defun asset-class-for (asset-id &optional (app *application*)) + "Given an asset-id (see GET-ASSET), retrieve the symbol name of a +the class that will be used to instantiate the asset object. That +class should be a subclass of ASSET. Additional clases can be added +to the application's ASSET-CLASSIFIERS association list." + (second (assoc (pathname-type asset-id) (asset-classifiers app) :test #'string-equal))) + +(defun get-asset (asset-id &optional (app *application*)) + "ASSET-ID is a pathname namestring relative to the application's +ASSET-ROOT. GET-ASSET retrieves an already-available asset from the +application's ASSETS table, or, if not available, loads the asset from +disk." + (or (gethash asset-id (application-assets app)) + (setf (gethash asset-id (application-assets app)) + (ensure-loaded + (make-instance (asset-class-for asset-id) + :path (uiop:merge-pathnames* asset-id (asset-root app))))))) ;; (defun get-focus (&optional (app *application*)) ;; (or (application-focus app) @@ -93,23 +344,6 @@ ;; (declare (ignore w)) ;; h)) -;; (defun asset-class-for (asset-id &optional (app *application*)) -;; "Given an asset-id (see GET-ASSET), retrieve the symbol name of a -;; the class that will be used to instantiate the asset object. That -;; class should be a subclass of ASSET. Additional clases can be added -;; to the application's ASSET-CLASSIFIERS association list." -;; (second (assoc (pathname-type asset-id) (asset-classifiers app) :test #'string-equal))) - -;; (defun get-asset (asset-id &optional (app *application*)) -;; "ASSET-ID is a pathname namestring relative to the application's -;; ASSET-ROOT. GET-ASSET retrieves an already-available asset from the -;; application's ASSETS table, or, if not available, loads the asset from -;; disk." -;; (or (gethash asset-id (application-assets app)) -;; (setf (gethash asset-id (application-assets app)) -;; (initialize -;; (make-instance (asset-class-for asset-id) -;; :path (uiop:merge-pathnames* asset-id (asset-root app))))))) ;; (defclass/std event-handler () ;; ((event-type handler-function :ri))) @@ -132,9 +366,3 @@ ;; (:documentation "Event handlers per object. The static hash tables ;; are keyed by UNIT and hold Event-Handler instances.")) -;; (defclass/std display-unit () -;; ((x y width height rotation :a :with :std 0.0 :type float :doc "Geometric properties") -;; (cached-model cached-real-model container listener :a :doc "Internal use.") -;; (focusablep :doc "T indicates it cannot be made the object of focus.") -;; (opacity :std 1.0 :doc "0.0 indicates it will not be rendred."))) - |