aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
authorColin Okay <colin@cicadas.surf>2022-06-21 10:29:13 -0500
committerColin Okay <colin@cicadas.surf>2022-06-21 10:29:13 -0500
commitb956a766d7fd0ffa6cabe18fa0eb2822f4a0ffc0 (patch)
tree983e957e1c2ea8c32c931ced4ef4a2a6002d7234
parent49ac2ad797e63957f0058ef4ad6e15dda482175d (diff)
[add] example; [add] basic stuff to run example
-rw-r--r--examples/01-bitmap-display.lisp20
-rwxr-xr-xexamples/Fezghoul.pngbin0 -> 3937 bytes
-rw-r--r--wheelwork.lisp284
3 files changed, 276 insertions, 28 deletions
diff --git a/examples/01-bitmap-display.lisp b/examples/01-bitmap-display.lisp
new file mode 100644
index 0000000..fa743fa
--- /dev/null
+++ b/examples/01-bitmap-display.lisp
@@ -0,0 +1,20 @@
+;;; 01-bitmap-display.lisp
+
+(defpackage #:ww.examples/1
+ (:use #:cl)
+ (:export #:start))
+
+(in-package :ww.examples/1)
+
+(defclass bitmap-display (ww::application ) ())
+
+(defmethod ww::boot ((app bitmap-display))
+ (ww::add-unit
+ app
+ (make-instance 'ww::bitmap
+ :texture (ww::get-asset "Fezghoul.png"))))
+
+
+(defun start ()
+ (ww::start (make-instance 'bitmap-display
+ :asset-root #P"~/projects/wheelwork/examples/")))
diff --git a/examples/Fezghoul.png b/examples/Fezghoul.png
new file mode 100755
index 0000000..c58a95b
--- /dev/null
+++ b/examples/Fezghoul.png
Binary files differ
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.")))
-