i have no idea, these changes have just been sitting on my disk for a year

README.md

@@ -8,5 +8,6 @@ A game engine written in Common Lisp.
 - [cl-opengl](https://github.com/3b/cl-opengl)
 - [trivial-types](https://github.com/m2ym/trivial-types)
 - [objective-lisp](https://bytes.keithhacks.cyou/keith/objective-lisp)
+- [superfluous-parentheses](https://bytes.keithhacks.cyou/keith/superfluous-parentheses)
 - [3d-vectors](https://github.com/Shinmera/3d-vectors)
 - [3d-matrices](https://github.com/Shinmera/3d-matrices)

behaviour-scripts.lisp

@@ -0,0 +1,34 @@
+;;;; behaviour-scripts
+;;;; a proof-of-concept for scripting dialogue and other behaviours
+
+(ql:quickload :generators)
+(use-package :generators)
+
+(defun dialogue-running (handle)
+  (cdr handle))
+
+(defun example-conversation ()
+  (make-generator ()
+    (yield :dialogue "Hello! This is an example conversation. I will now ask you a test question.")
+    (case (yield :ask-question "Nice of the princess to invite us over for a picnic, eh Luigi?")
+      (:spaghetti
+       (yield :dialogue "This is the correct response.")
+       (let ((dialogue-handle
+               (yield :async-dialogue "Blah blah blah tutorial stuff. I'll listen for signals while I'm talking.")))
+         (loop do (case (yield :await-signal)
+                    (:tutorial-failure
+                     (yield :dialogue "No, no, no! The electron frobnicator goes IN the other thingy!!!"))
+                    (:tutorial-success
+                     (if (dialogue-running dialogue-handle)
+                         (progn
+                           (yield :dialogue "Wow, you won't even listen to my help? I see how it is.")
+                           (yield :set-emotion :offended))
+                         (yield :dialogue "Good! That concludes the tutorial."))
+                     (loop-finish))
+                    (:earthquake
+                     (yield :dialogue "The FUCK was that???")))))
+       (yield :walk-to-exit))
+      (:penis
+       (yield :dialogue "This is an incorrect response, but it was received correctly."))
+      (t
+       (yield :error "The yield statement returned an unexpected result.")))))

pixelart-scaling.lisp

@@ -0,0 +1,84 @@
+;;; Implementation of smooth pixelart scaling.
+;;; This is basically the equivalent of CSS `image-rendering: pixelated`
+
+;; native render resolution
+(defvar *render-width* 384)
+(defvar *render-height* 256)
+
+;; window resolution
+(defvar *window-width* 1200)
+(defvar *window-height* 800)
+
+(defvar *render-tex* (gl:gen-texture))
+(defvar *render-fb* (gl:gen-framebuffer))
+
+(defvar *upscale-tex* (gl:gen-texture))
+(defvar *upscale-fb* (gl:gen-framebuffer))
+(defvar *upscale-width*)
+(defvar *upscale-height*)
+
+(defmacro with-bind-texture ((target texture) &body body)
+  `(progn
+      (gl:bind-texture ,target ,texture)
+      ,@body
+      (gl:bind-texture ,target 0)))
+(defmacro with-bind-framebuffer ((target framebuffer) &body body)
+  `(progn
+      (gl:bind-framebuffer ,target ,framebuffer)
+      ,@body
+      (gl:bind-framebuffer ,target 0)))
+
+(defun init-textures ()
+  "Initialize textures. Call this whenever the window or render resolution changes."
+  ;; generate the render texture
+  (with-bind-texture (:texture-2d *render-tex*)
+    (gl:tex-image-2d
+      :texture-2d 0 :rgba
+      *render-width* *render-height*
+      0 :rgba :unsigned-byte (cffi:null-pointer))
+    (gl:tex-parameter :texture-2d :texture-wrap-s :clamp-to-edge)
+    (gl:tex-parameter :texture-2d :texture-wrap-t :clamp-to-edge)
+    (gl:tex-parameter :texture-2d :texture-min-filter :nearest)
+    (gl:tex-parameter :texture-2d :texture-mag-filter :nearest))
+  (with-bind-framebuffer (:framebuffer *render-fb*)
+    (gl:framebuffer-texture-2d :framebuffer :color-attachment0 :texture-2d *render-tex* 0))
+  
+  ;; generate the upscale texture, which is scaled to an integer multiple of the render size
+  (setf
+    *upscale-width* (* (ceiling *window-width* *render-width*) *render-width*)
+    *upscale-height* (* (ceiling *window-height* *render-height*) *render-height*))
+  (with-bind-texture (:texture-2d *upscale-tex*)
+    (gl:tex-image-2d
+      :texture-2d 0 :rgba
+      *upscale-width* *upscale-height*
+      0 :rgba :unsigned-byte (cffi:null-pointer))
+    (gl:tex-parameter :texture-2d :texture-wrap-s :clamp-to-edge)
+    (gl:tex-parameter :texture-2d :texture-wrap-t :clamp-to-edge)
+    (gl:tex-parameter :texture-2d :texture-min-filter :linear)
+    (gl:tex-parameter :texture-2d :texture-mag-filter :linear))
+  (with-bind-framebuffer (:framebuffer *upscale-fb*)
+    (gl:framebuffer-texture-2d :framebuffer :color-attachment0 :texture-2d *upscale-tex* 0)))
+
+(defun before-render ()
+  (gl:bind-framebuffer :framebuffer *render-fb*)
+  (gl:viewport 0 0 *render-width* *render-height*))
+
+(defun after-render ()
+  ;; upscale with nearest-neighbour
+  (gl:bind-framebuffer :framebuffer *upscale-fb*)
+  (gl:viewport 0 0 *upscale-width* *upscale-height*)
+  (gl:disable :depth-test)
+  (gl:enable :texture-2d)
+  (gl:bind-texture :texture-2d *render-tex*)
+  (draw-full-screen-quad)
+  
+  ;; downscale with linear, render to window
+  (gl:bind-framebuffer :framebuffer 0)
+  (gl:viewport 0 0 *window-width* *window-height*)
+  (gl:bind-texture :texture-2d *upscale-tex*)
+  (draw-full-screen-quad)
+  (gl:bind-texture :texture-2d 0))
+
+(defun draw-full-screen-quad ()
+  "Draw a quad from (-1,-1) to (1,1). Essentially draw a texture stretched across the entire viewport."
+  (not-implemented))

wh-engine.asd

@@ -6,7 +6,7 @@
   :description "A game engine written in Common Lisp."
   :author "~keith"
   :license "GNU AGPLv3"
-  :depends-on ("sdl2" "cl-opengl" "trivial-types" "objective-lisp" "3d-vectors" "3d-matrices")
+  :depends-on ("sdl2" "sdl2-image" "cl-opengl" "trivial-types" "objective-lisp" "3d-vectors" "3d-matrices" "superfluous-parentheses")
   :components
   ((:module "wh-engine"
     :components ((:file "package")
@@ -19,7 +19,8 @@
                  (:file "systems")
                  (:module "render"
                   :components ((:file "render-system")
-                               (:file "shader")
+                               (:file "resources")
+                               (:file "text")
                                (:file "drawable")
                                (:file "render-target")
                                (:file "view")))

wh-engine/actor.lisp

@@ -70,7 +70,11 @@
    (matrix :documentation "Local-to-parent-space transformation matrix."
            :reader matrix
            :type mat3
-           :initform (meye 3)))
+           :initform (meye 3))
+   (world-matrix :documentation "Local-to-world-space transformation matrix."
+                 :reader world-matrix
+                 :type mat3
+                 :initform (meye 3)))
   (:documentation "Base class for entities in the game."))
 
 (defmethod make-load-form ((this actor) &optional environment)
@@ -78,159 +82,160 @@
 
 (defmethod scene ((this actor))
   "The scene containing this actor."
-  (deref-sus-pointer (o! this :slot scene)))
+  (deref-sus-pointer #[this :slot scene]))
 
 (defmethod parent ((this actor))
   "This actor's parent."
-  (deref-sus-pointer (o! this :slot parent)))
+  (deref-sus-pointer #[this :slot parent]))
 
 (defmethod tree-active-p ((this actor))
   "Whether or not this actor and all its parents are active."
-  (and (o! this active-p) (not (o! this :slot blocked-p))))
+  (and #[this active-p] (not #[this :slot blocked-p])))
 
 (defmethod apply-to-tree ((this actor) fun)
   "Apply fun to this actor and all its children recursively."
   (funcall fun this)
-  (loop for child in (o! this children)
+  (loop for child in #[this children]
         when (typep child 'actor)
-          do (o! child (apply-to-tree fun))))
+          do #[child (apply-to-tree fun)]))
 
 (defmethod print-object ((this actor) stream)
   (print-unreadable-object (this stream :type t :identity t)
     (format stream "~D ~S"
-            (o! this :slot id) (o! this :slot name))))
+            #[this :slot id] #[this :slot name])))
 
 (defmethod get-component ((this actor) component-class)
   "Get a component of the specified class attached to this object."
   (find-if (lambda (component) (typep component component-class))
-           (o! this components)))
+           #[this components]))
 
 (defmethod add-component ((this actor) component)
   "Add a component to this object."
   (let ((component-class (class-of component)))
-    (when (o! this (get-component component-class))
+    (when #[this (get-component component-class)]
       (error "~S already has a component of class ~S" this component-class))
-    (push component (o! this :slot components))
+    (push component #[this :slot components])
-    (o! component (attach this)))
+    #[component (attach this)])
   component)
 
 (defmethod add-child ((this actor) child)
   "Add a child to this object."
-  (when (o! child parent)
+  (when #[child parent]
-    (error "~S is already a child of ~S" child (o! child parent)))
+    (error "~S is already a child of ~S" child #[child parent]))
   (unless (find-if (lambda (x) (etypecase x
                                  (actor (eq x child))
-                                 (id-ref (eql (id-ref-actor x) (o! child id)))))
+                                 (id-ref (eql (id-ref-actor x) #[child id]))))
-                   (o! this :slot children))
+                   #[this :slot children])
-    (push child (o! this :slot children)))
+    (push child #[this :slot children]))
-  (setf (o! child :slot parent) (make-weak-pointer this))
+  (setf #[child :slot parent] (make-weak-pointer this))
-  (o! child (parent-changed))
+  #[child (parent-changed)]
   child)
 
 (defmethod remove-child ((this actor) child)
   "Remove a child from this object."
-  (unless (eq (o! child parent) this)
+  (unless (eq #[child parent] this)
     (error "~S is not a child of ~S" child this))
-  (setf (o! this :slot children)
+  (setf #[this :slot children]
         (delete-if (lambda (x) (etypecase x
                                  (actor (eq x child))
-                                 (id-ref (eql (id-ref-actor x) (o! child id)))))
+                                 (id-ref (eql (id-ref-actor x) #[child id]))))
-                   (o! this :slot children) :count 1))
+                   #[this :slot children] :count 1))
-  (setf (o! child :slot parent) nil)
+  (setf #[child :slot parent] nil)
-  (o! child (parent-changed))
+  #[child (parent-changed)]
   child)
 
 (defmethod recompute-blocked-p ((this actor))
   "Determine if any ancestors of this actor are deactivated."
-  (setf (o! this :slot blocked-p)
+  (setf #[this :slot blocked-p]
-        (when (o! this parent) (or (not (o! this parent active-p)) (o! this parent :slot blocked-p)))))
+        (when #[this parent] (or (not #[this parent active-p]) #[this parent :slot blocked-p]))))
 
 (defmethod has-tag ((this actor) tag)
   "Check if this object has the specified tag."
-  (find tag (o! this tags)))
+  (find tag #[this tags]))
 
 (defmethod add-tag ((this actor) tag)
   "Add a tag to this object."
-  (pushnew tag (o! this :slot tags)))
+  (pushnew tag #[this :slot tags]))
 
 (defmethod remove-tag ((this actor) tag)
   "Remove a tag from this object."
-  (setf (o! this :slot tags) (remove tag (o! this :slot tags))))
+  (setf #[this :slot tags] (remove tag #[this :slot tags])))
 
 (defmethod parent-changed ((this actor))
   "Called when the actor's parent is changed."
-  (o! this (recompute-blocked-p))
+  #[this (recompute-blocked-p)]
-  (loop for component in (o! this components)
+  #[this (recompute-matrix)]
-        do (o! component (parent-changed))))
+  (loop for component in #[this components]
+        do #[component (parent-changed)]))
 
 (defmethod deactivate ((this actor) &key origin)
   "Deactivate this object."
-  (o! this (recompute-blocked-p))
+  #[this (recompute-blocked-p)]
   (unless origin
-    (setf (o! this :slot active-p) nil))
+    (setf #[this :slot active-p] nil))
-  (loop for component in (o! this components)
+  (loop for component in #[this components]
-        do (o! component (deactivate :origin (or origin this))))
+        do #[component (deactivate :origin (or origin this))])
-  (loop for child in (o! this children)
+  (loop for child in #[this children]
-        do (o! child (deactivate :origin (or origin this)))))
+        do #[child (deactivate :origin (or origin this))]))
 
 (defmethod activate ((this actor) &key origin)
   "Activate this object."
-  (o! this (recompute-blocked-p))
+  #[this (recompute-blocked-p)]
   (unless origin
-    (setf (o! this :slot active-p) t))
+    (setf #[this :slot active-p] t))
-  (when (o! this tree-active-p)
+  (when #[this tree-active-p]
-    (loop for child in (o! this children)
+    (loop for child in #[this children]
-          when (o! child active-p)
+          when #[child active-p]
-            do (o! child (activate :origin (or origin this))))
+            do #[child (activate :origin (or origin this))])
-    (loop for component in (o! this components)
+    (loop for component in #[this components]
-          when (o! component active-p)
+          when #[component active-p]
-            do (o! component (activate :origin (or origin this))))
+            do #[component (activate :origin (or origin this))])
     ))
 
 (defmethod resume ((this actor))
   "Initialize or restore this actor's state."
   ;; Restore self
-  (when (typep (o! this :slot scene) 'id-ref)
+  (when (typep #[this :slot scene] 'id-ref)
     ;; relink to scene
-    (let ((scene (get-scene (id-ref-scene (o! this :slot scene)))))
+    (let ((scene (get-scene (id-ref-scene #[this :slot scene]))))
-      (setf (o! this :slot scene) nil)
+      (setf #[this :slot scene] nil)
-      (o! scene (add-actor this))))
+      #[scene (add-actor this)]))
-  (when (typep (o! this :slot parent) 'id-ref)
+  (when (typep #[this :slot parent] 'id-ref)
     ;; relink to parent
-    (let ((parent (o! this scene (get-actor (id-ref-actor (o! this :slot parent))))))
+    (let ((parent #[this scene (get-actor (id-ref-actor #[this :slot parent]))]))
-      (setf (o! this :slot parent) nil)
+      (setf #[this :slot parent] nil)
-      (o! parent (add-child this))))
+      #[parent (add-child this)]))
-  (loop for entry on (o! this :slot children)
+  (loop for entry on #[this :slot children]
         when (typep (car entry) 'id-ref)
           do (rplaca entry (dereferize (car entry))))
   ;; Restore components
-  (loop for component in (o! this components)
+  (loop for component in #[this components]
-        do (o! component (resume)))
+        do #[component (resume)])
   ;; Restore children
-  (loop for child in (o! this children)
+  (loop for child in #[this children]
-        do (o! child (resume))))
+        do #[child (resume)]))
 
 (defmethod suspend ((this actor))
   "Prepare this actor for serialization."
   ;; Suspend children
-  (loop for child in (o! this children)
+  (loop for child in #[this children]
-        do (o! child (suspend)))
+        do #[child (suspend)])
   ;; Suspend components
-  (loop for component in (o! this components)
+  (loop for component in #[this components]
-        do (o! component (suspend)))
+        do #[component (suspend)])
   ;; Suspend self
-  (loop for child-cell on (o! this :slot children)
+  (loop for child-cell on #[this :slot children]
         when (typep (car child-cell) 'actor)
           do (rplaca child-cell (referize (car child-cell))))
-  (referize-setf (o! this :slot scene))
+  (referize-setf #[this :slot scene])
-  (referize-setf (o! this :slot parent)))
+  (referize-setf #[this :slot parent]))
 
 (defmethod update ((this actor))
   "Update this actor's components."
-  (loop for component in (o! this components)
+  (loop for component in #[this components]
-        do (when (o! component active-p)
+        do (when #[component active-p]
-                 (unless (o! component started-p) (o! component (start)))
+                 (unless #[component started-p] #[component (start)])
-                 (o! component (update)))))
+                 #[component (update)])))
 
 (defmethod destroy ((this actor))
   "Mark this object for unloading."
@@ -253,24 +258,32 @@
 ;; Transform
 
 (defmethod initialize-instance :after ((this actor) &key)
-  (o! this (recompute-matrix)))
+  #[this (recompute-matrix)])
 
 (defmethod recompute-matrix ((this actor))
-  "Recompute the local-to-parent-space matrix."
+  "Recompute the local-to-parent-space matrix and local-to-world-space matrix."
-  (let ((rs (sin (o! this rotation)))
+  (let ((rs (sin #[this rotation]))
-        (rc (cos (o! this rotation)))
+        (rc (cos #[this rotation]))
-        (sx (vx2 (o! this scale)))
+        (sx (vx2 #[this scale]))
-        (sy (vy2 (o! this scale)))
+        (sy (vy2 #[this scale]))
-        (tx (vx2 (o! this location)))
+        (tx (vx2 #[this location]))
-        (ty (vy2 (o! this location))))
+        (ty (vy2 #[this location])))
-    (with-fast-matref (m (o! this :slot matrix) 3)
+    (with-fast-matref (m #[this :slot matrix] 3)
       (setf (m 0 0) (* sx rc)
             (m 0 1) (* sy (- rs))
             (m 0 2) tx
             (m 1 0) (* sx rs)
             (m 1 1) (* sy rc)
             (m 1 2) ty)
-      )))
+      ))
+  ;; world matrix
+  (setf #[this :slot world-matrix]
+        (if #[this parent]
+            (m* #[this parent world-matrix] #[this matrix])
+            (mcopy3 #[this matrix])))
+  ;; make children update world matrix too
+  (loop for child in #[this children]
+        do #[child (recompute-matrix)]))
 
 (defmethod (setf location) (new-val (this actor))
   "The actor's location relative to its parent."

wh-engine/input/input-system.lisp

@@ -18,8 +18,8 @@
 (defun input-system-update ()
   ())
 
-(defvar *keyspec-parsing-table* nil)
+(defparameter *keyspec-parsing-table* nil)
-(defvar *keycode-translation-reverse-table* nil)
+(defparameter *keycode-translation-reverse-table* nil)
 (defun setup-keycode-translation-table (&rest rest)
   (let ((table (make-hash-table :size (+ (truncate (length rest) 2) 64)))
         (reverse (make-hash-table))
@@ -45,7 +45,7 @@
     (setf *keycode-translation-reverse-table* reverse)
     (setf *keyspec-parsing-table* parsing)
     table))
-(defvar *keycode-translation-table*
+(defparameter *keycode-translation-table*
   (setup-keycode-translation-table #x08 :backspace
                                    #x09 :tab
                                    #x0d :return
@@ -225,8 +225,7 @@
   (key nil :type (or symbol character cons string null))
   (controlp nil :type boolean)
   (metap nil :type boolean)
-  (shiftp nil :type boolean)
+  (shiftp nil :type boolean))
-  (superp nil :type boolean))
 
 (defmacro keyspec (keyspec expr)
   "Compare EXPR to an Emacs-style KEYSPEC."
@@ -249,13 +248,11 @@
                           (case (schar ks 0)
                             (#\C `(not (keypress-controlp ,var)))
                             (#\M `(not (keypress-metap ,var)))
-                            (#\S `(not (keypress-shiftp ,var)))
+                            (#\S `(not (keypress-shiftp ,var))))
-                            (#\X `(not (keypress-superp ,var))))
                           (case (schar ks 0)
                             (#\C `(keypress-controlp ,var))
                             (#\M `(keypress-metap ,var))
-                            (#\S `(keypress-shiftp ,var))
+                            (#\S `(keypress-shiftp ,var))))
-                            (#\X `(keypress-superp ,var))))
                      collect it
                      and do (setf ks (subseq ks 2))
                             (setf invertp nil)
@@ -286,8 +283,7 @@
     (make-keypress :key (gethash (sdl2:sym-value key-sym) *keycode-translation-table*)
                    :controlp (/= (logand sdl-mod #x00C0) 0)
                    :metap (/= (logand sdl-mod #x0300) 0)
-                   :shiftp (/= (logand sdl-mod #x0003) 0)
+                   :shiftp (/= (logand sdl-mod #x0003) 0))))
-                   :superp (/= (logand sdl-mod #x0C00) 0))))
 
 (defun on-key-down (key-sym)
   (let ((keypress (translate-sdl-key-sym key-sym)))

wh-engine/main.lisp

@@ -79,17 +79,15 @@
               (setf this-tick (sdl2:get-ticks))
               (setf *delta-time* (* (- this-tick prev-tick) 0.001))
               (setf prev-tick this-tick)
-              ;(format t "~%Δt = ~S (~S FPS)~%" *delta-time* (/ 1.0 *delta-time*))
+              ;; (format t "~%Δt = ~S (~S FPS)~%" *delta-time* (/ 1.0 *delta-time*))
               ;; update
               (loop for scene in *world*
                     do (o! scene (update)))
-              ;(format t "game=~S " (/ (- (sdl2:get-performance-counter) prev-profiling-tick) profiling-scale))
+              ;; (format t "game=~S " (/ (- (sdl2:get-performance-counter) prev-profiling-tick) profiling-scale))
               ,@(loop for system in *world-systems*
                       append `((,(third system))
-                               #|
+                               ;; (format t ,(format nil "~S~A" (first system) "=~S ")
-                               (format t ,(format nil "~S~A" (first system) "=~S ")
+                               ;;         (/ (- (sdl2:get-performance-counter) prev-profiling-tick) profiling-scale))
-                                       (/ (- (sdl2:get-performance-counter) prev-profiling-tick) profiling-scale))
-                               |#
                                ))
               (sdl2:gl-swap-window win))
              (:keydown

wh-engine/render/render-system.lisp

@@ -64,7 +64,7 @@
 
 (defun sort-world-views ()
   "Re-sort the *world-views* list by render pass."
-  (sort *world-views* #'< :key (lambda (v) (o! (deref-pointer v) render-pass))))
+  (sort *world-views* #'< :key (lambda (v) #[(deref-pointer v) render-pass])))
 
 (declaim (special *projection*))
 
@@ -74,10 +74,10 @@
           win-height (* *view-height* *pixel-scale*)
           render-target (make-instance 'render-target :width *view-width* :height *view-height*))
 
-    (load #p"wh-engine/render/shaders/basic-shaders.lisp")
+    (sdl2-image:init '(:png :jpg :tif))
 
     ;; change render target mode
-    (gl:bind-texture :texture-2d (o! render-target render-texture))
+    (gl:bind-texture :texture-2d #[render-target render-texture])
     (gl:tex-parameter :texture-2d :texture-min-filter :nearest)
     (gl:tex-parameter :texture-2d :texture-mag-filter :nearest)
     (gl:bind-texture :texture-2d 0)
@@ -94,18 +94,18 @@
 
   (defun render-system-update ()
     ;; draw to render texture
-    (o! render-target (bind-for-rendering))
+    #[render-target (bind-for-rendering)]
     (gl:clear :color-buffer)
     (gl:enable :depth-test)
     (let ((render-pass nil))
       (loop for view-ptr in *world-views*
             for view = (ensure-live (weak-pointer-value view-ptr))
-            when (and (o! view active-p) (o! view actor tree-active-p))
+            when (and #[view active-p] #[view actor tree-active-p])
               do (progn
-                   (unless (eql (o! view render-pass) render-pass)
+                   (unless (eql #[view render-pass] render-pass)
-                     (setf render-pass (o! view render-pass))
+                     (setf render-pass #[view render-pass])
                      (gl:clear :depth-buffer))
-                   (o! view (render-view *world-drawables*)))))
+                   #[view (render-view *world-drawables*)])))
     (gl:flush)
 
     ;; now draw to window
@@ -114,7 +114,7 @@
     (gl:clear :color-buffer)
     (gl:disable :depth-test)
     (gl:enable :texture-2d)
-    (gl:bind-texture :texture-2d (o! render-target render-texture))
+    (gl:bind-texture :texture-2d #[render-target render-texture])
     (gl:matrix-mode :modelview)
     (gl:load-identity)
 

wh-engine/render/resources.lisp

@@ -0,0 +1,97 @@
+;;;; wh-engine/render/resources.lisp
+;;;; shader & texture resource management
+(in-package wh-engine/render)
+
+(defclass texture ()
+  ((texture :documentation "The OpenGL texture ID."
+            :type fixnum
+            :initarg :texture
+            :reader texture)
+   (path :documentation "The path to the file this texture was loaded from."
+         :type (or string null)
+         :initarg :path
+         :reader path)
+   (alphap :documentation "Whether or not this texture has an alpha channel."
+           :type boolean
+           :initarg :alphap
+           :reader alphap)
+   (wrap-mode :documentation "The wrap mode for this texture."
+              :type keyword
+              :initarg :wrap-mode
+              :accessor wrap-mode)
+   (filterp :documentation "Whether or not this texture has filtering enabled."
+            :type boolean
+            :initarg :filterp
+            :accessor filterp))
+  (:documentation "A class representing a texture."))
+
+(defmethod make-load-form ((this texture) &optional environment)
+  `(fetch-texture ,#[this path] :alphap ,#[this alphap] :wrap-mode ,#[this wrap-mode] :filterp ,#[this filterp]))
+
+(defmethod (setf wrap-mode) (new-val (texture texture))
+  (setf #[texture :slot wrap-mode] new-val)
+  (let ((old (gl:get-integer :texture-binding-2d)))
+    (unwind-protect
+         (progn (gl:bind-texture :texture-2d #[texture texture])
+                (gl:tex-parameter :texture-2d :texture-wrap-s new-val)
+                (gl:tex-parameter :texture-2d :texture-wrap-t new-val))
+      (gl:bind-texture :texture-2d old))))
+
+(defmethod (setf filterp) (new-val (texture texture))
+  (setf #[texture :slot filterp] new-val)
+  (let ((old (gl:get-integer :texture-binding-2d)))
+    (unwind-protect
+         (progn (gl:bind-texture :texture-2d #[texture texture])
+                (gl:tex-parameter :texture-2d :texture-min-filter (if new-val :linear :nearest))
+                (gl:tex-parameter :texture-2d :texture-mag-filter (if new-val :linear :nearest)))
+      (gl:bind-texture :texture-2d old))))
+
+(defvar *fallback-texdata* nil)
+(defun load-image-gracefully (path)
+  "Return an SDL surface for the given image file, or a fallback magenta-and-black checkerboard."
+  (declare (type (or string pathname) path))
+  (unless *fallback-texdata*
+    (setf *fallback-texdata* (cffi:foreign-alloc :uint32 :count 4))
+    (setf (cffi:mem-aref *fallback-texdata* :uint32 0) #xFF00FFFF
+          (cffi:mem-aref *fallback-texdata* :uint32 1) #x000000FF
+          (cffi:mem-aref *fallback-texdata* :uint32 2) #x000000FF
+          (cffi:mem-aref *fallback-texdata* :uint32 3) #xFF00FFFF))
+  (handler-case (sdl2-image:load-image path)
+    (sdl2-image:sdl-image-error (c)
+      (warn "Failed to load image: ~S~%" path)
+      (sdl2:create-rgb-surface-with-format-from *fallback-texdata* 2 2 32 8 :format sdl2:+pixelformat-rgba8888+))))
+
+(defun make-texture (path &key (alphap t) (wrap-mode :repeat) (filterp nil))
+  "Create a texture instance from a file."
+  (declare (type (or string pathname) path)
+           (type boolean alphap filterp)
+           (type keyword wrap-mode))
+  (let* ((raw-surf (load-image-gracefully path))
+         (surf (sdl2:convert-surface-format raw-surf (if alphap :abgr8888 :bgr888)))
+         (texture (gl:gen-texture)))
+    (sdl2:free-surface raw-surf)
+    (gl:bind-texture :texture-2d texture)
+    (gl:tex-image-2d :texture-2d 0 (if alphap :rgba8 :rgb8)
+                     (sdl2:surface-width surf) (sdl2:surface-height surf)
+                     0 (if alphap :rgba :rgb) :unsigned-byte
+                     (sdl2:surface-pixels surf))
+    (gl:tex-parameter :texture-2d :texture-wrap-s wrap-mode)
+    (gl:tex-parameter :texture-2d :texture-wrap-t wrap-mode)
+    (gl:tex-parameter :texture-2d :texture-min-filter (if filterp :linear :nearest))
+    (gl:tex-parameter :texture-2d :texture-mag-filter (if filterp :linear :nearest))
+    (gl:bind-texture :texture-2d 0)
+    (sdl2:free-surface surf)
+    (make-instance 'texture
+                   :texture texture
+                   :path path
+                   :alphap alphap
+                   :wrap-mode wrap-mode
+                   :filterp filterp)))
+
+(defvar *texture-registry* (make-hash-table :test #'equal))
+(defun fetch-texture (path &rest make-args)
+  "Try to fetch the texture for PATH from the registry, or create it using MAKE-ARGS if it doesn't exist."
+  (declare (type (or string pathname) path))
+  (or (gethash path *texture-registry*)
+      (setf (gethash path *texture-registry*)
+            (apply #'make-texture path make-args))))

wh-engine/render/shader.lisp

@@ -1,696 +0,0 @@
-;;;; wh-engine/render/shader.lisp
-;;;; Lisp class for holding & handling shaders.
-(in-package wh-engine/render)
-
-(defun replace-xref-vars (forms vars replace-fun)
-  (loop for elt on forms
-        for form = (car elt)
-        if (symbolp form)
-          do (let ((var-entry (find form vars :key #'car)))
-               (when var-entry
-                 (rplaca elt (funcall replace-fun var-entry))))
-        else if (consp form)
-               do (replace-xref-vars (cdr form) vars replace-fun)))
-
-(defparameter *vert-builtins* '((*vertex-id* . "gl_VertexID")
-                                (*instance-id* . "gl_InstanceID")
-                                (*draw-id* . "gl_DrawID")
-                                (*base-vertex* . "gl_BaseVertex")
-                                (*base-instance* . "gl_BaseInstance")
-                                ;; out
-                                (*position* . "gl_Position")
-                                (*point-size* . "gl_PointSize")
-                                (*clip-distance* . "gl_ClipDistance")))
-
-(defparameter *frag-builtins* '((*frag-coord* . "gl_FragCoord")
-                                (*front-facing* . "gl_FrontFacing")
-                                (*point-coord* . "gl_PointCoord")
-                                (*sample-id* . "gl_SampleID")
-                                (*sample-position* . "gl_SamplePosition")
-                                (*sample-mask-in* . "gl_SampleMaskIn")
-                                (*clip-distance* . "gl_ClipDistance")
-                                (*primitive-id* . "gl_PrimitiveID")
-                                (*layer* . "gl_Layer")
-                                (*viewport-index* . "gl_ViewportIndex")
-                                ;; out
-                                (*frag-depth* . "gl_FragDepth")
-                                (*sample-mask* . "gl_SampleMask")))
-
-(defparameter *infix-ops* '((+ "+" t)
-                            (- "-" T)
-                            (* "*" t)
-                            (/ "/" t)
-                            (mod "%" t)
-                            (= "==" t)
-                            (eq "==" nil)
-                            (eql "==" nil)
-                            (equal "==" nil)
-                            (/= "!=" nil)
-                            (< "<" t)
-                            (> ">" t)
-                            (<= "<=" t)
-                            (>= ">=" t)
-                            (<< "<<" nil)
-                            (>> ">>" nil)
-                            (ash "<<" nil)
-                            (logand "&" t)
-                            (logior "|" t)
-                            (logxor "^" t)
-                            (and "&&" t)
-                            (or "||" t)))
-
-(defparameter *types* '((:void . "void")
-                        (:bool . "bool")
-                        (:int . "int")
-                        (:uint . "uint")
-                        (:float . "float")
-                        (:vec2 . "vec2")
-                        (:vec3 . "vec3")
-                        (:vec4 . "vec4")
-                        (:mat2 . "mat2")
-                        (:mat3 . "mat3")
-                        (:mat4 . "mat4")
-                        (:sampler-1d . "sampler1D")
-                        (:depth-sampler-1d . "sampler1DShadow")
-                        (:array-sampler-1d . "sampler1DArray")
-                        (:depth-array-sampler-1d . "sampler1DArrayShadow")
-                        (:sampler-2d . "sampler2D")
-                        (:depth-sampler-2d . "sampler2DShadow")
-                        (:array-sampler-2d . "sampler2DArray")
-                        (:depth-array-sampler-2d . "sampler2DArrayShadow")
-                        (:multisampler-2d . "sampler2DMS")
-                        (:array-multisampler-2d . "sampler2DMSArray")
-                        (:rect-sampler-2d . "sampler2DRect")
-                        (:depth-rect-sampler-2d . "sampler2DRectShadow")
-                        (:sampler-3d . "sampler3D")
-                        (:cube-sampler . "samplerCube")
-                        (:depth-cube-sampler . "samplerCubeShadow")
-                        (:array-cube-sampler . "samplerCubeArray")
-                        (:depth-array-cube-sampler . "samplerCubeArrayShadow")
-                        (:buffer-sampler . "samplerBuffer")))
-
-(defparameter *shader-funs* '((bool . "bool")
-                              (int . "int")
-                              (uint . "uint")
-                              (float . "float")
-                              (double . "double")
-                              (vec2 . "vec2")
-                              (vec3 . "vec3")
-                              (vec4 . "vec4")
-                              (radians . "radians")
-                              (degrees . "degrees")
-                              (sin . "sin")
-                              (cos . "cos")
-                              (tan . "tan")
-                              (asin . "asin")
-                              (acos . "acos")
-                              (atan . "atan")
-                              (sinh . "sinh")
-                              (cosh . "cosh")
-                              (tanh . "tanh")
-                              (asinh . "asinh")
-                              (acosh . "acosh")
-                              (atanh . "atanh")
-                              (expt . "pow")
-                              (exp . "exp")
-                              (log . "log")
-                              (sqrt . "sqrt")
-                              (abs . "abs")
-                              (signum . "sign")
-                              (floor . "floor")
-                              (ffloor . "floor")
-                              (truncate . "trunc")
-                              (ftruncate . "trunc")
-                              (round . "round")
-                              (fround . "round")
-                              (ceiling . "ceil")
-                              (fceiling . "ceil")
-                              (mod . "mod")
-                              (min . "min")
-                              (max . "max")
-                              (linear-blend . "mix")
-                              (step . "step")
-                              (smooth-step . "smoothstep")
-                              (float-nan-p . "isnan")
-                              (float-infinity-p . "isinf")
-                              (vlength . "length")
-                              (vdistance . "distance")
-                              (v. . "dot")
-                              (vc . "cross")
-                              (v2norm . "normalize")
-                              (vforward . "faceforward")
-                              (vreflect . "reflect")
-                              (vrefract . "refract")
-                              (mtranspose . "transpose")
-                              (mdet . "determinant")
-                              (minv . "inverse")
-                              (v< . "lessThan")
-                              (v<= . "lessThanEqual")
-                              (v> . "greaterThan")
-                              (v>= . "greaterThanEqual")
-                              (v= . "equal")
-                              (v/= . "notEqual")
-                              (texture-size . "textureSize")
-                              (texture-lod . "textureQueryLod")
-                              (texture-levels . "textureQueryLevels")
-                              (texture-samples . "textureSamples")
-                              (sample-texture . "texture")
-                              (sample-texture-raw . "texelFetch")))
-
-(defun swizzlep (sym)
-  (let ((sym-str (string-downcase (symbol-name sym))))
-    (and (char= (char sym-str 0) #\v)
-         (loop for c across (subseq sym-str 1)
-               always (member c '(#\x #\y #\z #\w) :test #'char=))
-         (subseq sym-str 1))))
-
-(defun conv-shader-type (type)
-  (or (cdr (assoc type *types*))
-      (error "Invalid type specifier: ~S" type)))
-
-(defvar *shader-var-suffix* 0)
-(defun conv-shader-var (sym &optional gen-suffix)
-  (concatenate 'string
-               (substitute-if-not #\_ (lambda (c) (or (alpha-char-p c) (digit-char-p c)))
-                                  (remove #\- (string-downcase (string-capitalize (symbol-name sym)) :end 1)))
-               (if gen-suffix
-                   (write-to-string (incf *shader-var-suffix*))
-                   "")))
-
-(defun conv-shader-form (form vars funs)
-  (flet ((conv-form (x) (conv-shader-form x vars funs)))
-    (etypecase form
-      (cons
-       (let* ((sym (car form))
-              (args (cdr form))
-              (infix-op (assoc sym *infix-ops*))
-              (swizzle (swizzlep sym)))
-         (cond
-           (infix-op
-            ;; special case for -, which is also a unary op
-            (if (and (eq sym '-) (= (length args) 1))
-                (format nil "(-~A)"
-                        (conv-form (first args)))
-                (progn
-                  (unless (or (= (length args) 2) (and (nth 2 infix-op) (> (length args) 2)))
-                    (error "Invalid # of args for shader infix-op: ~S" infix-op))
-                  ;; don't wanna repeat this a bajillion times, so just splice the
-                  ;; GLSL version of the operator into the format control string
-                  (format nil (concatenate 'string "(~{~A~^ " (nth 1 infix-op) " ~})")
-                          (loop for x in args collect (conv-form x))))))
-           ;; the unary operators ! and ~
-           ((member sym '(not lognot))
-            (unless (= (length args) 1)
-              (error "Invalid # of args for shader unary-op: ~S" sym))
-            (format nil (if (eq sym 'not) "(!~A)" "(~~~A)")
-                    (conv-form (first args))))
-           ;; hijack the (exprA, exprB, ...) to allow multi-setf
-           ((eq sym 'setf)
-            (unless (= (mod (length args) 2) 0)
-              (error "Invalid # of args for shader setf"))
-            (format nil "(~{~A = ~A~^, ~})"
-                    (loop for x in args collect (conv-form x))))
-           ((eq sym 'nth)
-            (unless (= (length args) 2)
-              (error "Invalid # of args for shader nth"))
-            (format nil "~A[~A]"
-                    (conv-form (second args))
-                    (conv-form (first args))))
-           ((eq sym 'aref)
-            (unless (>= (length args) 2)
-              (error "Invalid # of args for shader aref"))
-            (format nil "~A~{[~A]~}"
-                    (conv-form (first args))
-                    (loop for x in (rest args) collect (conv-form x))))
-           ;; non-statement (if) is the ternary operator
-           ((eq sym 'if)
-            (unless (= (length args) 3)
-              (error "Invalid # of args for shader if"))
-            (format nil "(~A ? ~A : ~A)"
-                    (conv-form (first args))
-                    (conv-form (second args))
-                    (conv-form (third args))))
-           ;; WHY IS THIS A FUNCTION HISS
-           ((eq sym 'length)
-            (unless (= (length args) 1)
-              (error "Invalid # of args for shader length"))
-            (format nil "~A.length()"
-                    (conv-form (first args))))
-           ;; apparently you can do this, (exprA, exprB) is non-statement progn
-           ;; thanks C
-           ((eq sym 'progn)
-            (unless (>= (length args) 1)
-              (error "Invalid # of args for shader progn"))
-            (format nil "(~{~A~^, ~})"
-                    (loop for x in args collect (conv-form x))))
-           (swizzle
-            (unless (= (length args) 1)
-              (error "Invalid # of args for shader swizzle"))
-            (format nil "~A.~A"
-                    (conv-form (first args))
-                    swizzle))
-           (t
-            (format nil "~A(~{~A~^, ~})"
-                    (or (cdr (assoc sym funs)) (error "Invalid shader fun: ~S" sym))
-                    (loop for x in args collect (conv-form x)))))))
-      (boolean (if form "true" "false"))
-      (symbol (or (cdr (assoc form vars)) (error "Invalid shader var: ~S" form)))
-      (integer (format nil "~D" form))
-      (float (format nil "~F" form)))))
-
-(defun conv-shader-stmt (stmt vars funs returnp)
-  (labels ((conv-form (x) (conv-shader-form x vars funs))
-           (conv-stmt (x r) (conv-shader-stmt x vars funs r))
-           (loop-conv-stmts (list r)
-             (loop for x on list
-                   collect (conv-stmt (car x) (and r (not (cdr x)))))))
-    (let* ((sym (when (consp stmt) (car stmt)))
-           (args (when (consp stmt) (cdr stmt))))
-      (case sym
-        ((progn)
-         (format nil "{~%~{~A~}}~%"
-                 (loop-conv-stmts args returnp)))
-        ((if)
-         (unless (<= 2 (length args) 3)
-           (error "Invalid # of args for shader if"))
-         (format nil "if (~A) ~{~%~A~^else~}"
-                 (conv-form (first args))
-                 (loop-conv-stmts (rest args) returnp)))
-        ;; handle both forms in one case clause
-        ((when unless)
-         (unless (>= (length args) 2)
-           (error "Invalid # of args for shader when/unless"))
-         (format nil "if (~:[~;!(~]~A~2:*~:[~;)~]~1*) {~%~{~A~}}~%"
-                 (eq sym 'unless)
-                 (conv-form (first args))
-                 (loop-conv-stmts (rest args) returnp)))
-        ((cond)
-         (unless (>= (length args) 1)
-           (error "Invalid # of args for shader cond"))
-         (format nil "~{~:[if (~A) ~;~1*~]{~%~{~A~}}~^ else ~}~%"
-                 (loop for clause in args
-                       nconc (list (eq (first clause) t)
-                                   (conv-form (first clause))
-                                   (loop-conv-stmts (rest clause) returnp)))))
-        ((case)
-         (unless (>= (length args) 2)
-           (error "Invalid # of args for shader case"))
-         (format nil "switch (~A) {~%~{~:[~{case ~A:~%~}~;default:~%~1*~]~{~A~}break;~%~}}~%"
-                 (conv-form (first args))
-                 (loop for clause in (rest args)
-                       nconc (list (eq (car clause) t)
-                                   (if (listp (car clause))
-                                       (loop for x in (car clause) collect (conv-form x))
-                                       (list (conv-form (car clause))))
-                                   (loop-conv-stmts (cdr clause) returnp)))))
-        ((return)
-         (unless (<= 0 (length args) 1)
-           (error "Invalid # of args for shader return"))
-         (format nil "return~:[~; ~A~];~%"
-                 args
-                 (and args (conv-form (first args)))))
-        ((break continue discard)
-         (when args
-           (error "Invalid # of args for shader break"))
-         (format nil "~(~A~);~%" sym))
-        ((while)
-         (unless (>= (length args) 1)
-           (error "Invalid # of args for shader while"))
-         (format nil "while (~A) {~%~{~A~}}~%"
-                 (conv-form (first args))
-                 (loop-conv-stmts (rest args) returnp)))
-        ((dotimes)
-         (unless (and (>= (length args) 1) (= (length (first args)) 2))
-           (error "Invalid # of args for shader dotimes"))
-         (let ((new-vars (cons (cons (caar args) (conv-shader-var (caar args) t)) vars)))
-           (format nil "for (int ~A = 0; ~1:*~A < ~A; ~2:*~A++~1*) {~%~{~A~}}~%"
-                   (conv-shader-form (caar args) new-vars funs)
-                   (conv-shader-form (cadar args) new-vars funs)
-                   (loop for x on (cdr args)
-                         collect (conv-shader-stmt (car x) new-vars funs
-                                                   (and returnp (not (cdr x))))))))
-        ((for)
-         (unless (and (>= (length args) 1) (= (length (first args)) 3))
-           (error "Invalid # of args for shader for"))
-         (format nil "for (~A;~A;~A) {~%~{~A~}}~%"
-                 (conv-form (caar args))
-                 (conv-form (cadar args))
-                 (conv-form (caddar args))
-                 (loop-conv-stmts (cdr args) returnp)))
-        ((let let*)
-         (unless (>= (length args) 1)
-           (error "Invalid # of args for shader let"))
-         (let ((new-vars (nconc (loop for decl in (first args)
-                                      if (consp (car decl))
-                                        collect (cons (caar decl) (conv-shader-var (caar decl) t))
-                                      else
-                                        collect (cons (car decl) (conv-shader-var (car decl) t)))
-                                vars)))
-           (format nil "{~%~{~A ~A~:[~; = ~A~];~%~}~{~A~}}~%"
-                   (loop for decl in (first args)
-                         if (consp (car decl))
-                           nconc (list
-                                  (conv-shader-type (cadar decl))
-                                  (conv-shader-form (caar decl) new-vars funs)
-                                  t (conv-shader-form (cadr decl) new-vars funs))
-                         else
-                           nconc (list
-                                  (conv-shader-type (cadr decl))
-                                  (conv-shader-form (car decl) new-vars funs)
-                                  nil))
-                   (loop for x on (rest args)
-                         collect (conv-shader-stmt (car x) new-vars funs
-                                                   (and returnp (not (cdr x))))))))
-        ((setf)
-         (unless (= (mod (length args) 2) 0)
-           (error "Invalid # of args for shader setf"))
-         (format nil "~{~A = ~A;~%~}"
-                 (loop for x in args collect (conv-form x))))
-        (t
-         (format nil "~:[~;return ~]~A;~%" returnp (conv-form stmt)))))))
-
-(defun conv-shader-fun (name return-type params body vars funs)
-  (let ((new-vars (nconc (loop for decl in params
-                               collect (cons (car decl) (conv-shader-var (car decl))))
-                         vars)))
-    (format nil "~A ~A(~{~A ~A~^, ~}) {~%~{~A~}}"
-            (conv-shader-type return-type) name
-            (loop for decl in params
-                  nconc (list (conv-shader-type (cadr decl))
-                              (conv-shader-form (car decl) new-vars funs)))
-            (loop for x on body
-                  collect (conv-shader-stmt (car x) new-vars funs
-                                            (not (or (cdr x) (eq return-type :void))))))))
-
-(defun conv-shader-io
-    (mode name &key type
-                 (location nil)
-                 (component nil)
-                 (binding nil)
-                 (top-left-origin-p nil)
-                 (pixel-coords-p nil)
-     &allow-other-keys)
-  (format nil "~:[~;~1:*layout(~{~A~^, ~}) ~]~(~A~) ~A ~A;~%"
-          (loop for val in (list location component binding top-left-origin-p pixel-coords-p)
-                for key in (list "location" "component" "binding" "origin_upper_left" "pixel_center_integer")
-                if (eq val t)
-                  collect key
-                else if val
-                   collect (format nil "~A=~D" key val))
-          mode (conv-shader-type type) (conv-shader-var name)))
-
-(defun conv-shader-part (name part version in-vars out-vars uniform-vars funs)
-  (apply #'concatenate 'string
-         (format nil "#version ~D core~%// GLSL-ified Lisp shader: ~S~S~%" version name part)
-         (nconc
-          (loop for var in in-vars
-                collect (apply #'conv-shader-io :in var))
-          (loop for var in out-vars
-                collect (apply #'conv-shader-io :out var))
-          (loop for var in uniform-vars
-                collect (apply #'conv-shader-io :uniform var))
-          funs)))
-
-(defun transpile-shader
-    (name &key
-            version
-            ((:in vert-inputs))
-            ((:inter inter-vars))
-            ((:out frag-outputs))
-            ((:uniform uniform-vars))
-            ((:vert vert-body))
-            ((:frag frag-body)))
-  "Translate Lisp shader code to GLSL."
-  ;; create implicit inter vars
-  (replace-xref-vars frag-body vert-inputs
-                     (lambda (var-entry)
-                       (let* ((orig-var (car var-entry))
-                              (inter-var-entry (find orig-var inter-vars
-                                                     :key (lambda (e) (getf (cdr e) :orig-var)))))
-                         (if inter-var-entry
-                             (car inter-var-entry)
-                             (let ((new-var (gensym (symbol-name orig-var))))
-                               (push `(,new-var :orig-var ,orig-var :type ,(getf (cdr var-entry) :type))
-                                     inter-vars)
-                               (push `(setf ,new-var ,orig-var) vert-body)
-                               new-var)))))
-  (let* ((vert-vars (nconc (loop for var-entry in (append inter-vars vert-inputs uniform-vars)
-                                 collect (cons (car var-entry) (conv-shader-var (car var-entry))))
-                           *vert-builtins*))
-         (frag-vars (nconc (loop for var-entry in (append frag-outputs inter-vars uniform-vars)
-                                 collect (cons (car var-entry) (conv-shader-var (car var-entry))))
-                           *frag-builtins*))
-         (vert-uniforms ()) (frag-uniforms ())
-         vert-glsl frag-glsl)
-    (replace-xref-vars vert-body uniform-vars
-                       (lambda (var-entry)
-                         (pushnew var-entry vert-uniforms)
-                         (car var-entry)))
-    (replace-xref-vars frag-body uniform-vars
-                       (lambda (var-entry)
-                         (pushnew var-entry frag-uniforms)
-                         (car var-entry)))
-    (setf vert-glsl
-          (conv-shader-part name :vert version
-                            vert-inputs inter-vars vert-uniforms
-                            (list (conv-shader-fun "main" :void () vert-body vert-vars *shader-funs*)))
-          frag-glsl
-          (conv-shader-part name :frag version
-                            inter-vars frag-outputs frag-uniforms
-                            (list (conv-shader-fun "main" :void () frag-body frag-vars *shader-funs*))))
-    `(:vert ,vert-glsl :frag ,frag-glsl
-                 (:in ,vert-inputs :inter ,inter-vars :out ,frag-outputs :uniform ,uniform-vars
-                  :version ,version :vert ,vert-body :frag ,frag-body))))
-
-;; Shader class
-(defclass shader ()
-  ((name :documentation "The symbol naming this shader."
-         :type symbol
-         :initarg :name)
-   (program :documentation "The GL program associated with this shader."
-            :type fixnum
-            :initarg :program)
-   (vertex-array :documentation "The GL vertex array associated with this shader."
-                 :type fixnum
-                 :initarg :vertex-array)
-   (vertex-buffers :documentation "List of GL vertex buffers associated with this shader.
-(handle gl-array stride current-idx)"
-                   :type list
-                   :initarg :vertex-buffers
-                   :initform nil)
-   (vertex-props :documentation "Alist of vertex property metadata.
-(name handle type buffer-idx offset)"
-                 :type list
-                 :initarg :vertex-props)
-   (uniform-props :documentation "Alist of uniform property metadata.
-(name handle type)"
-                  :type list
-                  :initarg :uniform-props)
-   (num-vertices :documentation "Number of vertices waiting to be drawn."
-                 :type fixnum
-                 :initform 0)
-   (max-vertices :documentation "Maximum number of vertices that can be drawn at a time."
-                 :type fixnum
-                 :initarg :max-vertices
-                 :initform 64)
-   (options :documentation "Shader options."
-            :type list
-            :initarg :options)
-   (mode :documentation "Shader mode. One of (:LINES :TRIANGLES :QUADS)"
-         :type (or symbol null)
-         :initform nil)
-   (transpilation :documentation "Raw transpilation data for shaders which have not been initialized yet."
-                  :type (or list null)
-                  :initarg :transpilation
-                  :initform nil)))
-
-(defun make-glsl-program (code-plist)
-  (let ((program (gl:create-program)))
-    (loop for (stage code) on code-plist by #'cddr
-          do (let ((s (gl:create-shader (ecase stage
-                                          (:vert :vertex-shader)
-                                          (:frag :fragment-shader)))))
-               (gl:shader-source s code)
-               (gl:compile-shader s)
-               (unless (gl:get-shader s :compile-status)
-                 (error (gl:get-shader-info-log s)))
-               (gl:attach-shader program s)))
-    (gl:link-program program)
-    (unless (gl:get-program program :link-status)
-      (error (gl:get-program-info-log program)))
-    program))
-
-(defun setup-vbo (type stride max-vertices props vbo-idx)
-  "Create and configure a GL vertex buffer.
-Returns: (VBO ARR)"
-  (let* ((vbo (gl:gen-buffer))
-         (arr (gl:alloc-gl-array type (* stride max-vertices)))
-         (elt-size (gl::foreign-type-size (gl::gl-array-type arr))))
-    (gl:bind-buffer :array-buffer vbo)
-    (gl:buffer-data :array-buffer :dynamic-draw arr)
-    (loop for p in props
-          ;; (name handle type vbo-idx offset)
-          when (eq (fourth p) type)
-            do (setf (fourth p) vbo-idx)
-               (gl:enable-vertex-attrib-array (second p))
-               (gl:vertex-attrib-pointer (second p)
-                                         (case (third p)
-                                           (:vec2 2)
-                                           (:vec3 3)
-                                           (:vec4 4)
-                                           (t 1))
-                                         type nil
-                                         (* elt-size stride) (* elt-size (fifth p))))
-    (gl:bind-buffer :array-buffer 0)
-    (values vbo arr)))
-
-(defmethod ensure-initialized ((shader shader))
-  (when #[shader :slot transpilation]
-    (let ((code (butlast #[shader :slot transpilation]))
-          (vars (car (last #[shader :slot transpilation]))))
-      (setf #[shader :slot transpilation] nil)
-      (setf #[shader :slot program] (make-glsl-program code))
-      ;; create VAO
-      (setf #[shader :slot vertex-array] (gl:gen-vertex-array))
-      (gl:bind-vertex-array #[shader :slot vertex-array])
-      ;; create VBOs for vertex properties
-      (loop for (prop-name . prop-plist) in (getf vars :in)
-            for prop-type = (getf prop-plist :type)
-            for prop-loc = (or (getf prop-plist :location)
-                               (gl:get-attrib-location #[shader :slot program] (conv-shader-var prop-name)))
-            with float-idx = 0 and int-idx = 0 and uint-idx = 0
-
-            if (member prop-type '(:float :vec2 :vec3 :vec4))
-              collect (list prop-name prop-loc prop-type :float float-idx) into props
-              and do (incf float-idx (1+ (position prop-type '(:float :vec2 :vec3 :vec4))))
-            else if (member prop-type '(:int :bool))
-                   collect (list prop-name prop-loc prop-type :int int-idx) into props
-                   and do (incf int-idx)
-            else
-              collect (list prop-name prop-loc prop-type :unsigned-int uint-idx) into props
-              and do (incf uint-idx)
-
-            finally
-               (setf #[shader :slot vertex-props] props)
-               (let ((vbo-idx 0))
-                 (when (> float-idx 0)
-                   (multiple-value-bind (vbo arr)
-                       (setup-vbo :float float-idx #[shader :slot max-vertices] #[shader :slot vertex-props] vbo-idx)
-                     (setf #[shader :slot vertex-buffers]
-                           (nconc #[shader :slot vertex-buffers]
-                                  `((,vbo ,arr ,float-idx 0))))
-                     (incf vbo-idx)))
-                 (when (> int-idx 0)
-                   (multiple-value-bind (vbo arr)
-                       (setup-vbo :int int-idx #[shader :slot max-vertices] #[shader :slot vertex-props] vbo-idx)
-                     (setf #[shader :slot vertex-buffers]
-                           (nconc #[shader :slot vertex-buffers]
-                                  `((,vbo ,arr ,int-idx 0))))
-                     (incf vbo-idx)))
-                 (when (> uint-idx 0)
-                   (multiple-value-bind (vbo arr)
-                       (setup-vbo :unsigned-int uint-idx #[shader :slot max-vertices] #[shader :slot vertex-props] vbo-idx)
-                     (setf #[shader :slot vertex-buffers]
-                           (nconc #[shader :slot vertex-buffers]
-                                  `((,vbo ,arr ,uint-idx 0))))))))
-      (gl:bind-vertex-array 0)
-      ;; uniform properties
-      (setf #[shader :slot uniform-props]
-            (loop for (prop-name . prop-plist) in (getf vars :uniform)
-                  for prop-type = (getf prop-plist :type)
-                  for prop-loc = (or (getf prop-plist :location)
-                                     (gl:get-attrib-location #[shader :slot program] (conv-shader-var prop-name)))
-                  collect (list prop-name prop-loc prop-type)))
-      )))
-
-(defmethod begin-draw ((shader shader) mode)
-  (setf #[shader :slot mode] mode))
-
-(defmethod end-draw ((shader shader))
-  (when (> #[shader :slot num-vertices] 0)
-    #[shader (flush-vertices)])
-  (setf #[shader :slot mode] nil))
-
-(defmethod uniform ((shader shader) name value)
-  (let ((prop (assoc name #[shader :slot uniform-props])))
-    (case (third prop)
-      (:float (gl:uniformfv (second prop) value))
-      ((:int :uint :bool) (gl:uniformiv (second prop) value))
-      (:vec2 (gl:uniformf (second prop) (vx2 value) (vy2 value)))
-      (:vec3 (gl:uniformf (second prop) (vx3 value) (vy3 value) (vz3 value)))
-      (:vec4 (gl:uniformf (second prop) (vx4 value) (vy4 value) (vz4 value) (vw4 value)))
-      (:mat2 (gl:uniform-matrix-2fv (second prop) (vector (marr2 value))))
-      (:mat3 (gl:uniform-matrix-3fv (second prop) (vector (marr3 value))))
-      (:mat4 (gl:uniform-matrix-4fv (second prop) (vector (marr4 value)))))))
-
-(defmethod vertex ((shader shader) &rest rest)
-  (declare (optimize (speed 3)))
-  ;; apply values
-  (loop for (name value) on rest by #'cddr
-        for prop = (assoc name #[shader :slot vertex-props])
-        for type = (third prop)
-        for buf = (nth (fourth prop) #[shader :slot vertex-buffers])
-        for array = (second buf)
-        for idx = (+ (fourth buf) (fifth prop))
-
-        if (eq type :vec2)
-          do (setf (gl:glaref array idx) (vx2 value)
-                   (gl:glaref array (+ idx 1)) (vy2 value))
-        else if (eq type :vec3)
-               do (setf (gl:glaref array idx) (vx3 value)
-                        (gl:glaref array (+ idx 1)) (vy3 value)
-                        (gl:glaref array (+ idx 2)) (vz3 value))
-        else if (eq type :vec4)
-               do (setf (gl:glaref array idx) (vx4 value)
-                        (gl:glaref array (+ idx 1)) (vy4 value)
-                        (gl:glaref array (+ idx 2)) (vz4 value)
-                        (gl:glaref array (+ idx 3)) (vw4 value))
-        else if (eq type :bool)
-               do (setf (gl:glaref array idx) (if value 1 0))
-        else
-          do (setf (gl:glaref array idx) value))
-  ;; increment counters
-  (loop for buf in #[shader :slot vertex-buffers]
-        do (incf (fourth buf) (third buf)))
-  (incf #[shader :slot num-vertices])
-  ;; flush
-  (when (>= #[shader :slot num-vertices] #[shader :slot max-vertices])
-    #[shader (flush-vertices)]))
-
-(defmethod flush-vertices ((shader shader))
-  (declare (optimize (speed 3)))
-  (gl:use-program #[shader :slot program])
-  (gl:bind-vertex-array #[shader :slot vertex-array])
-  (gl:draw-arrays #[shader :slot mode] 0 #[shader :slot num-vertices])
-  ;; reset counters
-  (setf #[shader :slot num-vertices] 0)
-  (loop for buf in #[shader :slot vertex-buffers]
-        do (setf (fourth buf) 0)))
-
-(defmacro define-shader
-    (name (&key
-             ((:in (&rest vert-inputs)) ())
-             ((:inter (&rest inter-vars)) ())
-             ((:out (&rest frag-outputs)) ())
-             ((:uniform (&rest uniform-vars)) ()))
-     &key
-       ((:vert (&body vert-body)))
-       ((:frag (&body frag-body)))
-       documentation
-       version
-       options)
-  "Define a GLSL shader with Lisp code."
-  `(defparameter ,name
-     (make-instance 'shader
-                    :name ',name
-                    :options ',options
-                    :transpilation
-                    (transpile-shader ',name
-                                      :version ,version
-                                      :in ',vert-inputs
-                                      :inter ',inter-vars
-                                      :out ',frag-outputs
-                                      :uniform ',uniform-vars
-                                      :vert ',vert-body
-                                      :frag ',frag-body))
-     ,documentation))

wh-engine/render/shaders/basic-frag.glsl

@@ -1,12 +0,0 @@
-#version 330 core
-
-in vec2 uv;
-
-out vec4 FragColour;
-
-uniform sampler2D mainTex;
-uniform vec4 colour;
-
-void main() {
-	FragColour = texture(mainTex, uv) * colour;
-}

wh-engine/render/shaders/basic-shaders.lisp

@@ -1,66 +0,0 @@
-;;;; basic-shaders.lisp (Lisp shader code)
-(in-package wh-engine/render)
-
-(define-shader basic-shader
-    (:in ((vert-pos :type :vec3 :location 0)
-          (vert-uv :type :vec2 :location 1))
-     :out ((*frag-colour* :type :vec4))
-     :uniform ((model :type :mat4)
-               (view :type :mat4)
-               (proj :type :mat4)
-               (main-tex :type :sampler-2d)
-               (colour :type :vec4)))
-  :documentation "Simple shader for 2D sprites."
-  :version 330
-  :vert ((setf *position* (* proj view model (vec4 vert-pos 1.0))))
-  :frag ((setf *frag-colour* (* (sample-texture main-tex vert-uv) colour)))
-  :options (:depth-test t
-            :depth-write t
-            :blend t))
-
-(define-shader render-target-blit-shader
-    (:in ((vert-pos :type :vec2 :location 0))
-     :out ((*frag-colour* :type :vec4)
-           (*frag-depth* :type :float))
-     :uniform ((main-tex :type :sampler-2d)
-               (depth-tex :type :depth-sampler-2d)))
-  :documentation "Shader for compositing render targets together."
-  :version 330
-  :vert ((setf *position* (vec4 vert-pos 0.0 1.0)))
-  :frag ((setf *frag-colour* (sample-texture main-tex vert-pos)
-               *frag-depth* (sample-texture depth-tex vert-pos)))
-  :options (:depth-test t
-            :depth-write t
-            :blend nil))
-
-(define-shader ui-basic-shader
-    (:in ((vert-pos :type :vec2 :location 0)
-          (vert-uv :type :vec2 :location 1))
-     :out ((*frag-colour* :type :vec4))
-     :uniform ((model :type :mat4)
-               (proj :type :mat4)
-               (main-tex :type :sampler-2d)
-               (colour :type :vec4)))
-  :documentation "Simple shader for overlay UI."
-  :version 330
-  :vert ((setf *position* (* proj model (vec4 vert-pos 1.0 1.0))))
-  :frag ((setf *frag-colour* (* (sample-texture main-tex vert-uv) colour)))
-  :options (:depth-test nil
-            :depth-write nil
-            :blend t))
-
-(define-shader ui-glyph-shader
-    (:in ((vert-pos :type :vec2 :location 0)
-          (vert-uv :type :vec2 :location 1))
-     :out ((*frag-colour* :type :vec4))
-     :uniform ((model :type :mat4)
-               (proj :type :mat4)
-               (main-tex :type :sampler-2d)
-               (colour :type :vec3)))
-  :documentation "Shader for text and other glyphs within overlay UI."
-  :version 330
-  :vert ((setf *position* (* proj model (vec4 vert-pos 1.0 1.0))))
-  :frag ((setf *frag-colour* (vec4 colour (vx (sample-texture main-tex vert-uv)))))
-  :options (:depth-test nil
-            :depth-write nil
-            :blend t))

wh-engine/render/shaders/basic-vert.glsl

@@ -1,15 +0,0 @@
-#version 330 core
-
-layout (location = 0) in vec3 vert_pos;
-layout (location = 1) in vec2 vert_uv;
-
-out vec2 uv;
-
-uniform mat4 model;
-uniform mat4 view;
-uniform mat4 proj;
-
-void main() {
-	gl_Position = proj * view * model * vec4(vert_pos, 1.0);
-	uv = vert_uv;
-}

wh-engine/render/shaders/render-target-blit-frag.glsl

@@ -1,14 +0,0 @@
-#version 330 core
-
-in vec2 uv;
-
-out vec4 FragColour;
-out float gl_FragDepth;
-
-uniform sampler2D mainTex;
-uniform sampler2DShadow depthTex;
-
-void main() {
-	FragColour = texture(mainTex, uv);
-	gl_FragDepth = texture(depthTex, uv);
-}

wh-engine/render/shaders/render-target-blit-vert.glsl

@@ -1,10 +0,0 @@
-#version 330 core
-
-layout (location = 0) in vec2 vert_pos;
-
-out vec2 uv;
-
-void main() {
-	gl_Position = vec4(vert_pos, 0.0, 1.0);
-	uv = vert_pos;
-}