README.md

@@ -8,6 +8,5 @@ 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

@@ -1,34 +0,0 @@
-;;;; 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

@@ -1,84 +0,0 @@
-;;; 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" "sdl2-image" "cl-opengl" "trivial-types" "objective-lisp" "3d-vectors" "3d-matrices" "superfluous-parentheses")
+  :depends-on ("sdl2" "cl-opengl" "trivial-types" "objective-lisp" "3d-vectors" "3d-matrices")
   :components
   ((:module "wh-engine"
     :components ((:file "package")
@@ -19,8 +19,7 @@
                  (:file "systems")
                  (:module "render"
                   :components ((:file "render-system")
-                               (:file "resources")
+                               (:file "shader")
-                               (:file "text")
                                (:file "drawable")
                                (:file "render-target")
                                (:file "view")))

wh-engine/actor.lisp

@@ -70,11 +70,7 @@
    (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)
@@ -82,160 +78,159 @@
 
 (defmethod scene ((this actor))
   "The scene containing this actor."
-  (deref-sus-pointer #[this :slot scene]))
+  (deref-sus-pointer (o! this :slot scene)))
 
 (defmethod parent ((this actor))
   "This actor's parent."
-  (deref-sus-pointer #[this :slot parent]))
+  (deref-sus-pointer (o! this :slot parent)))
 
 (defmethod tree-active-p ((this actor))
   "Whether or not this actor and all its parents are active."
-  (and #[this active-p] (not #[this :slot blocked-p])))
+  (and (o! this active-p) (not (o! 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 #[this children]
+  (loop for child in (o! this children)
         when (typep child 'actor)
-          do #[child (apply-to-tree fun)]))
+          do (o! child (apply-to-tree fun))))
 
 (defmethod print-object ((this actor) stream)
   (print-unreadable-object (this stream :type t :identity t)
     (format stream "~D ~S"
-            #[this :slot id] #[this :slot name])))
+            (o! this :slot id) (o! 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))
-           #[this components]))
+           (o! this components)))
 
 (defmethod add-component ((this actor) component)
   "Add a component to this object."
   (let ((component-class (class-of component)))
-    (when #[this (get-component component-class)]
+    (when (o! this (get-component component-class))
       (error "~S already has a component of class ~S" this component-class))
-    (push component #[this :slot components])
+    (push component (o! this :slot components))
-    #[component (attach this)])
+    (o! component (attach this)))
   component)
 
 (defmethod add-child ((this actor) child)
   "Add a child to this object."
-  (when #[child parent]
+  (when (o! child parent)
-    (error "~S is already a child of ~S" child #[child parent]))
+    (error "~S is already a child of ~S" child (o! child parent)))
   (unless (find-if (lambda (x) (etypecase x
                                  (actor (eq x child))
-                                 (id-ref (eql (id-ref-actor x) #[child id]))))
+                                 (id-ref (eql (id-ref-actor x) (o! child id)))))
-                   #[this :slot children])
+                   (o! this :slot children))
-    (push child #[this :slot children]))
+    (push child (o! this :slot children)))
-  (setf #[child :slot parent] (make-weak-pointer this))
+  (setf (o! child :slot parent) (make-weak-pointer this))
-  #[child (parent-changed)]
+  (o! child (parent-changed))
   child)
 
 (defmethod remove-child ((this actor) child)
   "Remove a child from this object."
-  (unless (eq #[child parent] this)
+  (unless (eq (o! child parent) this)
     (error "~S is not a child of ~S" child this))
-  (setf #[this :slot children]
+  (setf (o! this :slot children)
         (delete-if (lambda (x) (etypecase x
                                  (actor (eq x child))
-                                 (id-ref (eql (id-ref-actor x) #[child id]))))
+                                 (id-ref (eql (id-ref-actor x) (o! child id)))))
-                   #[this :slot children] :count 1))
+                   (o! this :slot children) :count 1))
-  (setf #[child :slot parent] nil)
+  (setf (o! child :slot parent) nil)
-  #[child (parent-changed)]
+  (o! child (parent-changed))
   child)
 
 (defmethod recompute-blocked-p ((this actor))
   "Determine if any ancestors of this actor are deactivated."
-  (setf #[this :slot blocked-p]
+  (setf (o! this :slot blocked-p)
-        (when #[this parent] (or (not #[this parent active-p]) #[this parent :slot blocked-p]))))
+        (when (o! this parent) (or (not (o! this parent active-p)) (o! this parent :slot blocked-p)))))
 
 (defmethod has-tag ((this actor) tag)
   "Check if this object has the specified tag."
-  (find tag #[this tags]))
+  (find tag (o! this tags)))
 
 (defmethod add-tag ((this actor) tag)
   "Add a tag to this object."
-  (pushnew tag #[this :slot tags]))
+  (pushnew tag (o! this :slot tags)))
 
 (defmethod remove-tag ((this actor) tag)
   "Remove a tag from this object."
-  (setf #[this :slot tags] (remove tag #[this :slot tags])))
+  (setf (o! this :slot tags) (remove tag (o! this :slot tags))))
 
 (defmethod parent-changed ((this actor))
   "Called when the actor's parent is changed."
-  #[this (recompute-blocked-p)]
+  (o! this (recompute-blocked-p))
-  #[this (recompute-matrix)]
+  (loop for component in (o! this components)
-  (loop for component in #[this components]
+        do (o! component (parent-changed))))
-        do #[component (parent-changed)]))
 
 (defmethod deactivate ((this actor) &key origin)
   "Deactivate this object."
-  #[this (recompute-blocked-p)]
+  (o! this (recompute-blocked-p))
   (unless origin
-    (setf #[this :slot active-p] nil))
+    (setf (o! this :slot active-p) nil))
-  (loop for component in #[this components]
+  (loop for component in (o! this components)
-        do #[component (deactivate :origin (or origin this))])
+        do (o! component (deactivate :origin (or origin this))))
-  (loop for child in #[this children]
+  (loop for child in (o! this children)
-        do #[child (deactivate :origin (or origin this))]))
+        do (o! child (deactivate :origin (or origin this)))))
 
 (defmethod activate ((this actor) &key origin)
   "Activate this object."
-  #[this (recompute-blocked-p)]
+  (o! this (recompute-blocked-p))
   (unless origin
-    (setf #[this :slot active-p] t))
+    (setf (o! this :slot active-p) t))
-  (when #[this tree-active-p]
+  (when (o! this tree-active-p)
-    (loop for child in #[this children]
+    (loop for child in (o! this children)
-          when #[child active-p]
+          when (o! child active-p)
-            do #[child (activate :origin (or origin this))])
+            do (o! child (activate :origin (or origin this))))
-    (loop for component in #[this components]
+    (loop for component in (o! this components)
-          when #[component active-p]
+          when (o! component active-p)
-            do #[component (activate :origin (or origin this))])
+            do (o! component (activate :origin (or origin this))))
     ))
 
 (defmethod resume ((this actor))
   "Initialize or restore this actor's state."
   ;; Restore self
-  (when (typep #[this :slot scene] 'id-ref)
+  (when (typep (o! this :slot scene) 'id-ref)
     ;; relink to scene
-    (let ((scene (get-scene (id-ref-scene #[this :slot scene]))))
+    (let ((scene (get-scene (id-ref-scene (o! this :slot scene)))))
-      (setf #[this :slot scene] nil)
+      (setf (o! this :slot scene) nil)
-      #[scene (add-actor this)]))
+      (o! scene (add-actor this))))
-  (when (typep #[this :slot parent] 'id-ref)
+  (when (typep (o! this :slot parent) 'id-ref)
     ;; relink to parent
-    (let ((parent #[this scene (get-actor (id-ref-actor #[this :slot parent]))]))
+    (let ((parent (o! this scene (get-actor (id-ref-actor (o! this :slot parent))))))
-      (setf #[this :slot parent] nil)
+      (setf (o! this :slot parent) nil)
-      #[parent (add-child this)]))
+      (o! parent (add-child this))))
-  (loop for entry on #[this :slot children]
+  (loop for entry on (o! this :slot children)
         when (typep (car entry) 'id-ref)
           do (rplaca entry (dereferize (car entry))))
   ;; Restore components
-  (loop for component in #[this components]
+  (loop for component in (o! this components)
-        do #[component (resume)])
+        do (o! component (resume)))
   ;; Restore children
-  (loop for child in #[this children]
+  (loop for child in (o! this children)
-        do #[child (resume)]))
+        do (o! child (resume))))
 
 (defmethod suspend ((this actor))
   "Prepare this actor for serialization."
   ;; Suspend children
-  (loop for child in #[this children]
+  (loop for child in (o! this children)
-        do #[child (suspend)])
+        do (o! child (suspend)))
   ;; Suspend components
-  (loop for component in #[this components]
+  (loop for component in (o! this components)
-        do #[component (suspend)])
+        do (o! component (suspend)))
   ;; Suspend self
-  (loop for child-cell on #[this :slot children]
+  (loop for child-cell on (o! this :slot children)
         when (typep (car child-cell) 'actor)
           do (rplaca child-cell (referize (car child-cell))))
-  (referize-setf #[this :slot scene])
+  (referize-setf (o! this :slot scene))
-  (referize-setf #[this :slot parent]))
+  (referize-setf (o! this :slot parent)))
 
 (defmethod update ((this actor))
   "Update this actor's components."
-  (loop for component in #[this components]
+  (loop for component in (o! this components)
-        do (when #[component active-p]
+        do (when (o! component active-p)
-                 (unless #[component started-p] #[component (start)])
+                 (unless (o! component started-p) (o! component (start)))
-                 #[component (update)])))
+                 (o! component (update)))))
 
 (defmethod destroy ((this actor))
   "Mark this object for unloading."
@@ -258,32 +253,24 @@
 ;; Transform
 
 (defmethod initialize-instance :after ((this actor) &key)
-  #[this (recompute-matrix)])
+  (o! this (recompute-matrix)))
 
 (defmethod recompute-matrix ((this actor))
-  "Recompute the local-to-parent-space matrix and local-to-world-space matrix."
+  "Recompute the local-to-parent-space matrix."
-  (let ((rs (sin #[this rotation]))
+  (let ((rs (sin (o! this rotation)))
-        (rc (cos #[this rotation]))
+        (rc (cos (o! this rotation)))
-        (sx (vx2 #[this scale]))
+        (sx (vx2 (o! this scale)))
-        (sy (vy2 #[this scale]))
+        (sy (vy2 (o! this scale)))
-        (tx (vx2 #[this location]))
+        (tx (vx2 (o! this location)))
-        (ty (vy2 #[this location])))
+        (ty (vy2 (o! this location))))
-    (with-fast-matref (m #[this :slot matrix] 3)
+    (with-fast-matref (m (o! 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 ()
   ())
 
-(defparameter *keyspec-parsing-table* nil)
+(defvar *keyspec-parsing-table* nil)
-(defparameter *keycode-translation-reverse-table* nil)
+(defvar *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))
-(defparameter *keycode-translation-table*
+(defvar *keycode-translation-table*
   (setup-keycode-translation-table #x08 :backspace
                                    #x09 :tab
                                    #x0d :return
@@ -225,7 +225,8 @@
   (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."
@@ -248,11 +249,13 @@
                           (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)
@@ -283,7 +286,8 @@
     (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,15 +79,17 @@
               (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 ")
+                               #|
-                               ;;         (/ (- (sdl2:get-performance-counter) prev-profiling-tick) profiling-scale))
+                               (format t ,(format nil "~S~A" (first system) "=~S ")
+                                       (/ (- (sdl2:get-performance-counter) prev-profiling-tick) profiling-scale))
+                               |#
                                ))
               (sdl2:gl-swap-window win))
              (:keydown

wh-engine/render/render-system.lisp

@@ -47,9 +47,9 @@
                   ,(m 2 0) ,(m 2 1) 0.0 ,(m 2 2))
                 )))
 
-(defvar *view-width* 512
+(defvar *view-width* 384
   "View-space width in pixels.")
-(defvar *view-height* 384
+(defvar *view-height* 256
   "View-space height in pixels.")
 (defvar *view-ppu* 64
   "Pixels in view-space per unit in world-space.")
@@ -64,9 +64,7 @@
 
 (defun sort-world-views ()
   "Re-sort the *world-views* list by render pass."
-  (sort *world-views* #'< :key (lambda (v) #[(deref-pointer v) render-pass])))
+  (sort *world-views* #'< :key (lambda (v) (o! (deref-pointer v) render-pass))))
-
-(declaim (special *projection*))
 
 (let (render-target win-width win-height)
   (defun render-system-init ()
@@ -74,10 +72,8 @@
           win-height (* *view-height* *pixel-scale*)
           render-target (make-instance 'render-target :width *view-width* :height *view-height*))
 
-    (sdl2-image:init '(:png :jpg :tif))
-
     ;; change render target mode
-    (gl:bind-texture :texture-2d #[render-target render-texture])
+    (gl:bind-texture :texture-2d (o! 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 +90,18 @@
 
   (defun render-system-update ()
     ;; draw to render texture
-    #[render-target (bind-for-rendering)]
+    (o! 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 #[view active-p] #[view actor tree-active-p])
+            when (and (o! view active-p) (o! view actor tree-active-p))
               do (progn
-                   (unless (eql #[view render-pass] render-pass)
+                   (unless (eql (o! view render-pass) render-pass)
-                     (setf render-pass #[view render-pass])
+                     (setf render-pass (o! view render-pass))
                      (gl:clear :depth-buffer))
-                   #[view (render-view *world-drawables*)])))
+                   (o! view (render-view *world-drawables*)))))
     (gl:flush)
 
     ;; now draw to window
@@ -114,7 +110,7 @@
     (gl:clear :color-buffer)
     (gl:disable :depth-test)
     (gl:enable :texture-2d)
-    (gl:bind-texture :texture-2d #[render-target render-texture])
+    (gl:bind-texture :texture-2d (o! render-target render-texture))
     (gl:matrix-mode :modelview)
     (gl:load-identity)
 

wh-engine/render/resources.lisp

@@ -1,97 +0,0 @@
-;;;; 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

@@ -0,0 +1,494 @@
+;;;; 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)))
+
+(defvar *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")))
+
+(defvar *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")))
+
+(defvar *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)))
+
+(defvar *types* '((:void . "void")
+                  (:bool . "bool")
+                  (:int . "int")
+                  (:uint . "uint")
+                  (:float . "float")
+                  (:double . "double")
+                  (:vec2 . "vec2")
+                  (:vec3 . "vec3")
+                  (:vec4 . "vec4")
+                  (:double-vec2 . "dvec2")
+                  (:double-vec3 . "dvec3")
+                  (:double-vec4 . "dvec4")
+                  (:bool-vec2 . "bvec2")
+                  (:bool-vec3 . "bvec3")
+                  (:bool-vec4 . "bvec4")
+                  (:int-vec2 . "ivec2")
+                  (:int-vec3 . "ivec3")
+                  (:int-vec4 . "ivec4")
+                  (:uint-vec2 . "uvec2")
+                  (:uint-vec3 . "uvec3")
+                  (:uint-vec4 . "uvec4")
+                  (: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")))
+
+(defvar *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))))
+     
+
+(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)))
+                           version)
+  "Define a GLSL shader with Lisp code."
+  `(defparameter ,name (transpile-shader ',name
+                                         :version ,version
+                                         :in ',vert-inputs
+                                         :inter ',inter-vars
+                                         :out ',frag-outputs
+                                         :uniform ',uniform-vars
+                                         :vert ',vert-body :frag ',frag-body)))

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

@@ -0,0 +1,12 @@
+#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-shader.lisp

@@ -0,0 +1,26 @@
+;;;; basic-shader.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)))
+  :version 330
+  :vert ((setf *position* (* proj view model (vec4 vert-pos 1.0))))
+  :frag ((setf *frag-colour* (* (sample-texture main-tex vert-uv) colour))))
+
+(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)))
+  :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))))

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

@@ -0,0 +1,15 @@
+#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

@@ -0,0 +1,14 @@
+#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

@@ -0,0 +1,10 @@
+#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;
+}