keith/wh-engine
1
0
Fork 0
Code Issues 6 Pull requests Projects Releases Wiki Activity

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

Browse source
This commit is contained in:
~keith 2023-01-18 13:46:46 +00:00
parent ab434ea3c2
commit abace393ff
Signed by: keith
GPG key ID: 5BEBEEAB2C73D520
15 changed files with 333 additions and 922 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
README.md
View file

@ -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)

34
behaviour-scripts.lisp Normal file
View file

@ -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.")))))

84
pixelart-scaling.lisp Normal file
View file

@ -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))

5
wh-engine.asd
View file

@ -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")))

175
wh-engine/actor.lisp
View file

@ -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))
(o! component (attach this)))
(push component #[this :slot components])
#[component (attach this)])
component)
(defmethod add-child ((this actor) child)
"Add a child to this object."
(when (o! child parent)
(error "~S is already a child of ~S" child (o! child parent)))
(when #[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)))))
(o! this :slot children))
(push child (o! this :slot children)))
(setf (o! child :slot parent) (make-weak-pointer this))
(o! child (parent-changed))
(id-ref (eql (id-ref-actor x) #[child id]))))
#[this :slot children])
(push child #[this :slot children]))
(setf #[child :slot parent] (make-weak-pointer this))
#[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)))))
(o! this :slot children) :count 1))
(setf (o! child :slot parent) nil)
(o! child (parent-changed))
(id-ref (eql (id-ref-actor x) #[child id]))))
#[this :slot children] :count 1))
(setf #[child :slot parent] nil)
#[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)
(when (o! this parent) (or (not (o! this parent active-p)) (o! this parent :slot blocked-p)))))
(setf #[this :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))
(loop for component in (o! this components)
do (o! component (parent-changed))))
#[this (recompute-blocked-p)]
#[this (recompute-matrix)]
(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))
(loop for component in (o! this components)
do (o! component (deactivate :origin (or origin this))))
(loop for child in (o! this children)
do (o! child (deactivate :origin (or origin this)))))
(setf #[this :slot active-p] nil))
(loop for component in #[this components]
do #[component (deactivate :origin (or origin this))])
(loop for child in #[this children]
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))
(when (o! this tree-active-p)
(loop for child in (o! this children)
when (o! child active-p)
do (o! child (activate :origin (or origin this))))
(loop for component in (o! this components)
when (o! component active-p)
do (o! component (activate :origin (or origin this))))
(setf #[this :slot active-p] t))
(when #[this tree-active-p]
(loop for child in #[this children]
when #[child active-p]
do #[child (activate :origin (or origin this))])
(loop for component in #[this components]
when #[component active-p]
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)))))
(setf (o! this :slot scene) nil)
(o! scene (add-actor this))))
(when (typep (o! this :slot parent) 'id-ref)
(let ((scene (get-scene (id-ref-scene #[this :slot scene]))))
(setf #[this :slot scene] nil)
#[scene (add-actor this)]))
(when (typep #[this :slot parent] 'id-ref)
;; relink to parent
(let ((parent (o! this scene (get-actor (id-ref-actor (o! this :slot parent))))))
(setf (o! this :slot parent) nil)
(o! parent (add-child this))))
(loop for entry on (o! this :slot children)
(let ((parent #[this scene (get-actor (id-ref-actor #[this :slot parent]))]))
(setf #[this :slot parent] nil)
#[parent (add-child this)]))
(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)
do (o! component (resume)))
(loop for component in #[this components]
do #[component (resume)])
;; Restore children
(loop for child in (o! this children)
do (o! child (resume))))
(loop for child in #[this children]
do #[child (resume)]))
(defmethod suspend ((this actor))
"Prepare this actor for serialization."
;; Suspend children
(loop for child in (o! this children)
do (o! child (suspend)))
(loop for child in #[this children]
do #[child (suspend)])
;; Suspend components
(loop for component in (o! this components)
do (o! component (suspend)))
(loop for component in #[this components]
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 (o! this :slot parent)))
(referize-setf #[this :slot scene])
(referize-setf #[this :slot parent]))
(defmethod update ((this actor))
"Update this actor's components."
(loop for component in (o! this components)
do (when (o! component active-p)
(unless (o! component started-p) (o! component (start)))
(o! component (update)))))
(loop for component in #[this components]
do (when #[component active-p]
(unless #[component started-p] #[component (start)])
#[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."
(let ((rs (sin (o! this rotation)))
(rc (cos (o! this rotation)))
(sx (vx2 (o! this scale)))
(sy (vy2 (o! this scale)))
(tx (vx2 (o! this location)))
(ty (vy2 (o! this location))))
(with-fast-matref (m (o! this :slot matrix) 3)
"Recompute the local-to-parent-space matrix and local-to-world-space matrix."
(let ((rs (sin #[this rotation]))
(rc (cos #[this rotation]))
(sx (vx2 #[this scale]))
(sy (vy2 #[this scale]))
(tx (vx2 #[this location]))
(ty (vy2 #[this location])))
(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."

18
wh-engine/input/input-system.lisp
View file

@ -18,8 +18,8 @@
(defun input-system-update ()
())
(defvar *keyspec-parsing-table* nil)
(defvar *keycode-translation-reverse-table* nil)
(defparameter *keyspec-parsing-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)
(superp nil :type boolean))
(shiftp 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)))
(#\X `(not (keypress-superp ,var))))
(#\S `(not (keypress-shiftp ,var))))
(case (schar ks 0)
(#\C `(keypress-controlp ,var))
(#\M `(keypress-metap ,var))
(#\S `(keypress-shiftp ,var))
(#\X `(keypress-superp ,var))))
(#\S `(keypress-shiftp ,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)
:superp (/= (logand sdl-mod #x0C00) 0))))
:shiftp (/= (logand sdl-mod #x0003) 0))))
(defun on-key-down (key-sym)
(let ((keypress (translate-sdl-key-sym key-sym)))

10
wh-engine/main.lisp
View file

@ -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 ")
(/ (- (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

18
wh-engine/render/render-system.lisp
View file

@ -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)
(setf render-pass (o! view render-pass))
(unless (eql #[view render-pass] 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)

97
wh-engine/render/resources.lisp Normal file
View file

@ -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))))

696
wh-engine/render/shader.lisp
View file

@ -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))

12
wh-engine/render/shaders/basic-frag.glsl
View file

@ -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;
}

66
wh-engine/render/shaders/basic-shaders.lisp
View file

@ -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))

15
wh-engine/render/shaders/basic-vert.glsl
View file

@ -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;
}

14
wh-engine/render/shaders/render-target-blit-frag.glsl
View file

@ -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);
}

10
wh-engine/render/shaders/render-target-blit-vert.glsl
View file

@ -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;
}