parent
ab434ea3c2
commit
abace393ff
GPG Key ID:
5BEBEEAB2C73D520
@ -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.")))))
|
||||
@ -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))
|
||||
@ -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))))
|
||||
@ -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])
|
||||