stuff
This commit is contained in:
parent
04c4a13c5b
commit
1fda9b4f42
GPG Key ID:
5BEBEEAB2C73D520
|
|
@ -18,7 +18,9 @@
|
|||
(:file "serialization")
|
||||
(:file "systems")
|
||||
(:file "render/render-system")
|
||||
(:file "render/shader")
|
||||
(:file "render/drawable")
|
||||
(:file "render/render-target")
|
||||
(:file "render/view")
|
||||
(:file "input/input-system")
|
||||
(:file "main"))
|
||||
|
|
|
|||
|
|
@ -37,6 +37,7 @@
|
|||
finally (return (values other-forms make-params))))
|
||||
|
||||
(define-new!-impl component (class it params)
|
||||
(declare (ignore class))
|
||||
(loop for (key value) on params by #'cddr
|
||||
if (eq key :actor)
|
||||
collect `(o! ,value (add-component ,it)) into other-forms
|
||||
|
|
|
|||
|
|
@ -298,8 +298,8 @@
|
|||
(defmethod world-matrix ((this actor))
|
||||
"The local-to-world-space transformation matrix for this actor."
|
||||
(if (o! this parent)
|
||||
(m* (o! this parent world-matrix) (o! this matrix))
|
||||
(o! this matrix)))
|
||||
(nm* (o! this parent world-matrix) (o! this matrix))
|
||||
(mcopy3 (o! this matrix))))
|
||||
|
||||
(defmethod local-matrix ((this actor))
|
||||
"The world-to-local-space transformation matrix for this actor."
|
||||
|
|
|
|||
|
|
@ -6,7 +6,8 @@
|
|||
(:import-from sb-ext
|
||||
weak-pointer weak-pointer-p make-weak-pointer weak-pointer-value)
|
||||
(:import-from objective-lisp O!)
|
||||
(:export))
|
||||
(:export keypress make-keypress keypress-key keypress-controlp keypress-metap keypress-shiftp keypress-superp
|
||||
keyspec))
|
||||
|
||||
(in-package wh-engine/input)
|
||||
|
||||
|
|
@ -16,22 +17,13 @@
|
|||
|
||||
(defun input-system-update ()
|
||||
())
|
||||
#|
|
||||
(defmacro setup-keycode-translation-table (&rest rest)
|
||||
(let ((table (gensym)))
|
||||
`(let ((,table (make-hash-table)))
|
||||
(setf ,@(loop for x from #x21 to #x40
|
||||
nconc `((gethash ,x ,table) ,(code-char x)))
|
||||
,@(loop for x from #x5b to #x7a
|
||||
nconc `((gethash ,x ,table) ,(code-char x)))
|
||||
,@(loop for (k v) on rest by #'cddr
|
||||
nconc `((gethash ,k ,table) ,v)))
|
||||
,table)))
|
||||
|#
|
||||
|
||||
(defvar *keyspec-parsing-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 :size (+ (truncate (length rest) 2) 64))))
|
||||
(reverse (make-hash-table))
|
||||
(parsing (make-hash-table :test #'equal)))
|
||||
(loop for x from #x21 to #x40
|
||||
do (setf (gethash x table) (code-char x)
|
||||
(gethash (code-char x) reverse) x))
|
||||
|
|
@ -40,9 +32,18 @@
|
|||
(gethash (code-char x) reverse) x))
|
||||
(loop for (k v) on rest by #'cddr
|
||||
do (setf (gethash k table) v)
|
||||
(cond ((and (consp v) (keywordp (cdr v)))
|
||||
(setf (gethash (format nil "K-<~A>" (cdr v)) parsing) (cdr v)))
|
||||
((and (consp v) (stringp (cdr v)))
|
||||
(setf (gethash (format nil "K-~A" (cdr v)) parsing) (cdr v)))
|
||||
((keywordp v)
|
||||
(setf (gethash (format nil "<~A>" v) parsing) v))
|
||||
((stringp v)
|
||||
(setf (gethash v parsing) v)))
|
||||
unless (gethash v reverse)
|
||||
do (setf (gethash v reverse) k))
|
||||
(setf *keycode-translation-reverse-table* reverse)
|
||||
(setf *keyspec-parsing-table* parsing)
|
||||
table))
|
||||
(defvar *keycode-translation-table*
|
||||
(setup-keycode-translation-table #x08 :backspace
|
||||
|
|
@ -77,25 +78,25 @@
|
|||
#x40000051 :down
|
||||
#x40000052 :up
|
||||
#x40000053 :num-lock
|
||||
#x40000054 '(:keypad #\/)
|
||||
#x40000055 '(:keypad #\*)
|
||||
#x40000056 '(:keypad #\-)
|
||||
#x40000057 '(:keypad #\+)
|
||||
#x40000058 '(:keypad :return)
|
||||
#x40000059 '(:keypad #\1)
|
||||
#x4000005A '(:keypad #\2)
|
||||
#x4000005B '(:keypad #\3)
|
||||
#x4000005C '(:keypad #\4)
|
||||
#x4000005D '(:keypad #\5)
|
||||
#x4000005E '(:keypad #\6)
|
||||
#x4000005F '(:keypad #\7)
|
||||
#x40000060 '(:keypad #\8)
|
||||
#x40000061 '(:keypad #\9)
|
||||
#x40000062 '(:keypad #\0)
|
||||
#x40000063 '(:keypad #\.)
|
||||
#x40000054 '(:keypad . #\/)
|
||||
#x40000055 '(:keypad . #\*)
|
||||
#x40000056 '(:keypad . #\-)
|
||||
#x40000057 '(:keypad . #\+)
|
||||
#x40000058 '(:keypad . :return)
|
||||
#x40000059 '(:keypad . #\1)
|
||||
#x4000005A '(:keypad . #\2)
|
||||
#x4000005B '(:keypad . #\3)
|
||||
#x4000005C '(:keypad . #\4)
|
||||
#x4000005D '(:keypad . #\5)
|
||||
#x4000005E '(:keypad . #\6)
|
||||
#x4000005F '(:keypad . #\7)
|
||||
#x40000060 '(:keypad . #\8)
|
||||
#x40000061 '(:keypad . #\9)
|
||||
#x40000062 '(:keypad . #\0)
|
||||
#x40000063 '(:keypad . #\.)
|
||||
#x40000065 :application
|
||||
#x40000066 :power
|
||||
#x40000067 '(:keypad #\=)
|
||||
#x40000067 '(:keypad . #\=)
|
||||
#x40000068 :f13
|
||||
#x40000069 :f14
|
||||
#x4000006A :f15
|
||||
|
|
@ -122,8 +123,8 @@
|
|||
#x4000007F :mute
|
||||
#x40000080 :volume+
|
||||
#x40000081 :volume-
|
||||
#x40000085 '(:keypad #\,)
|
||||
#x40000086 '(:keypad :as400=)
|
||||
#x40000085 '(:keypad . #\,)
|
||||
#x40000086 '(:keypad . :as400=)
|
||||
#x40000099 :alt-erase
|
||||
#x4000009A :sys-req
|
||||
#x4000009B :cancel
|
||||
|
|
@ -142,46 +143,46 @@
|
|||
#x400000B3 :decimal-separator
|
||||
#x400000B4 :currency-unit
|
||||
#x400000B5 :currency-sub-unit
|
||||
#x400000B6 '(:keypad #\()
|
||||
#x400000B7 '(:keypad #\))
|
||||
#x400000B8 '(:keypad #\{)
|
||||
#x400000B9 '(:keypad #\})
|
||||
#x400000BA '(:keypad :tab)
|
||||
#x400000BB '(:keypad :backspace)
|
||||
#x400000BC '(:keypad #\a)
|
||||
#x400000BD '(:keypad #\b)
|
||||
#x400000BE '(:keypad #\c)
|
||||
#x400000BF '(:keypad #\d)
|
||||
#x400000C0 '(:keypad #\e)
|
||||
#x400000C1 '(:keypad #\f)
|
||||
#x400000C2 '(:keypad :xor)
|
||||
#x400000C3 '(:keypad #\^)
|
||||
#x400000C4 '(:keypad #\%)
|
||||
#x400000C5 '(:keypad #\<)
|
||||
#x400000C6 '(:keypad #\>)
|
||||
#x400000C7 '(:keypad #\&)
|
||||
#x400000C8 '(:keypad "&&")
|
||||
#x400000C9 '(:keypad #\|)
|
||||
#x400000CA '(:keypad "||")
|
||||
#x400000CB '(:keypad #\:)
|
||||
#x400000CC '(:keypad #\#)
|
||||
#x400000CD '(:keypad :space)
|
||||
#x400000CE '(:keypad #\@)
|
||||
#x400000CF '(:keypad #\!)
|
||||
#x400000D0 '(:keypad :mem-store)
|
||||
#x400000D1 '(:keypad :mem-recall)
|
||||
#x400000D2 '(:keypad :mem-clear)
|
||||
#x400000D3 '(:keypad :mem+)
|
||||
#x400000D4 '(:keypad :mem-)
|
||||
#x400000D5 '(:keypad :mem*)
|
||||
#x400000D6 '(:keypad :mem/)
|
||||
#x400000D7 '(:keypad #\±)
|
||||
#x400000D8 '(:keypad :clear)
|
||||
#x400000D9 '(:keypad :clear-entry)
|
||||
#x400000DA '(:keypad :binary)
|
||||
#x400000DB '(:keypad :octal)
|
||||
#x400000DC '(:keypad :decimal)
|
||||
#x400000DD '(:keypad :hexadecimal)
|
||||
#x400000B6 '(:keypad . #\()
|
||||
#x400000B7 '(:keypad . #\))
|
||||
#x400000B8 '(:keypad . #\{)
|
||||
#x400000B9 '(:keypad . #\})
|
||||
#x400000BA '(:keypad . :tab)
|
||||
#x400000BB '(:keypad . :backspace)
|
||||
#x400000BC '(:keypad . #\a)
|
||||
#x400000BD '(:keypad . #\b)
|
||||
#x400000BE '(:keypad . #\c)
|
||||
#x400000BF '(:keypad . #\d)
|
||||
#x400000C0 '(:keypad . #\e)
|
||||
#x400000C1 '(:keypad . #\f)
|
||||
#x400000C2 '(:keypad . :xor)
|
||||
#x400000C3 '(:keypad . #\^)
|
||||
#x400000C4 '(:keypad . #\%)
|
||||
#x400000C5 '(:keypad . #\<)
|
||||
#x400000C6 '(:keypad . #\>)
|
||||
#x400000C7 '(:keypad . #\&)
|
||||
#x400000C8 '(:keypad . "&&")
|
||||
#x400000C9 '(:keypad . #\|)
|
||||
#x400000CA '(:keypad . "||")
|
||||
#x400000CB '(:keypad . #\:)
|
||||
#x400000CC '(:keypad . #\#)
|
||||
#x400000CD '(:keypad . :space)
|
||||
#x400000CE '(:keypad . #\@)
|
||||
#x400000CF '(:keypad . #\!)
|
||||
#x400000D0 '(:keypad . :mem-store)
|
||||
#x400000D1 '(:keypad . :mem-recall)
|
||||
#x400000D2 '(:keypad . :mem-clear)
|
||||
#x400000D3 '(:keypad . :mem+)
|
||||
#x400000D4 '(:keypad . :mem-)
|
||||
#x400000D5 '(:keypad . :mem*)
|
||||
#x400000D6 '(:keypad . :mem/)
|
||||
#x400000D7 '(:keypad . #\±)
|
||||
#x400000D8 '(:keypad . :clear)
|
||||
#x400000D9 '(:keypad . :clear-entry)
|
||||
#x400000DA '(:keypad . :binary)
|
||||
#x400000DB '(:keypad . :octal)
|
||||
#x400000DC '(:keypad . :decimal)
|
||||
#x400000DD '(:keypad . :hexadecimal)
|
||||
;; modifiers
|
||||
#x400000E0 :left-control
|
||||
#x400000E1 :left-shift
|
||||
|
|
@ -220,55 +221,104 @@
|
|||
#x4000011A :sleep
|
||||
))
|
||||
|
||||
(defun parse-keyspec (keyspec)
|
||||
"Parse an Emacs-style key specification."
|
||||
(defstruct keypress
|
||||
(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))
|
||||
|
||||
(defmacro keyspec (keyspec expr)
|
||||
"Compare EXPR to an Emacs-style KEYSPEC."
|
||||
(declare (type simple-string keyspec))
|
||||
;; 'C-': control, 'M-': meta, 'S-': shift, 'X-': super, 'K-': keypad
|
||||
(let* ((keypad-p nil)
|
||||
(let* ((keypadp nil)
|
||||
(ks keyspec)
|
||||
(modifiers (loop while (and (> (length ks) 2) (char= (schar ks 1) #\-))
|
||||
if (char= (schar ks 0) #\K)
|
||||
do (setf keypad-p t)
|
||||
(setf ks (subseq ks 2))
|
||||
else
|
||||
if (case (schar ks 0)
|
||||
(#\C :control)
|
||||
(#\M :meta)
|
||||
(#\S :shift)
|
||||
(#\X :super))
|
||||
collect it
|
||||
and do (setf ks (subseq ks 2))
|
||||
else do (loop-finish)))
|
||||
(key (cond
|
||||
((= (length ks) 0)
|
||||
(error "Invalid keyspec ~S" keyspec))
|
||||
((= (length ks) 1)
|
||||
(if (upper-case-p (schar ks 0))
|
||||
(progn (setf modifiers (cons :shift modifiers))
|
||||
(char-downcase (schar ks 0)))
|
||||
(schar ks 0)))
|
||||
((string= ks "SPC") :space)
|
||||
((string= ks "RET") :return)
|
||||
((string= ks "ESC") :escape)
|
||||
((string= ks "DEL") :delete)
|
||||
((string= ks "BS") :backspace)
|
||||
(t (read-from-string ks)))
|
||||
))
|
||||
(values (if keypad-p `(:keypad ,key) key) modifiers)))
|
||||
(invertp nil)
|
||||
(var (gensym))
|
||||
(tests
|
||||
(loop while (and (> (length ks) 2) (or (char= (schar ks 1) #\-) (char= (schar ks 0) #\^)))
|
||||
if (char= (schar ks 0) #\K)
|
||||
do (setf keypadp t)
|
||||
(setf ks (subseq ks 2))
|
||||
else
|
||||
if (char= (schar ks 0) #\^)
|
||||
do (setf invertp t)
|
||||
(setf ks (subseq ks 1))
|
||||
else
|
||||
if (if invertp
|
||||
(case (schar ks 0)
|
||||
(#\C `(not (keypress-controlp ,var)))
|
||||
(#\M `(not (keypress-metap ,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))
|
||||
(#\X `(keypress-superp ,var))))
|
||||
collect it
|
||||
and do (setf ks (subseq ks 2))
|
||||
(setf invertp nil)
|
||||
else do (loop-finish)))
|
||||
(key
|
||||
(cond
|
||||
((= (length ks) 0)
|
||||
(error "Invalid keyspec ~S" keyspec))
|
||||
((= (length ks) 1)
|
||||
(if (upper-case-p (schar ks 0))
|
||||
(progn (push `(keypress-shiftp ,var) tests)
|
||||
(char-downcase (schar ks 0)))
|
||||
(schar ks 0)))
|
||||
((string= ks "SPC") :space)
|
||||
((string= ks "RET") :return)
|
||||
((string= ks "TAB") :tab)
|
||||
((string= ks "ESC") :escape)
|
||||
((string= ks "DEL") :delete)
|
||||
((string= ks "BS") :backspace)
|
||||
(t (gethash (if keypadp (concatenate 'string "K-" ks) ks) *keyspec-parsing-table*)))))
|
||||
`(let ((,var ,expr))
|
||||
(and ,@tests (equal (keypress-key ,var) ,(if keypadp `(cons :keypad ,key) key))))
|
||||
))
|
||||
|
||||
(defun translate-sdl-key-sym (key-sym)
|
||||
"Translate an SDL key-sym to a wh-engine keypress value."
|
||||
(let ((sdl-mod (sdl2:mod-value key-sym)))
|
||||
(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))))
|
||||
|
||||
(defun on-key-down (key-sym)
|
||||
(format t "key-down: ~S (mod ~S)~%"
|
||||
(gethash (sdl2:sym-value key-sym) *keycode-translation-table*)
|
||||
(sdl2:mod-keywords (sdl2:mod-value key-sym))))
|
||||
(let ((keypress (translate-sdl-key-sym key-sym)))
|
||||
(format t "keyDN: ~S~%" keypress)
|
||||
(when (keyspec "M-x" keypress)
|
||||
(format t "-- Meta-x Key Detected --~%"))
|
||||
))
|
||||
|
||||
(defun on-key-up (key-sym)
|
||||
())
|
||||
(let ((keypress (translate-sdl-key-sym key-sym)))
|
||||
(format t "keyUP: ~S~%" keypress)
|
||||
))
|
||||
|
||||
(defun on-mouse-move (mouse-location mouse-delta mouse-state)
|
||||
())
|
||||
|
||||
;; FIXME slow as FUCK
|
||||
(defun on-mouse-down (mouse-location mouse-button)
|
||||
())
|
||||
(let ((view (wh-engine:deref-pointer (first wh-engine/render::*world-views*))))
|
||||
(loop for drawable-ptr in wh-engine/render::*world-drawables*
|
||||
for drawable = (wh-engine:deref-pointer drawable-ptr)
|
||||
when (and (o! drawable wh-engine:active-p) (o! drawable wh-engine:actor wh-engine:tree-active-p))
|
||||
do (multiple-value-bind (box-min box-max)
|
||||
(wh-engine/render::transform-box (o! drawable wh-engine/render:culling-box)
|
||||
(o! drawable wh-engine:actor wh-engine:world-matrix)
|
||||
(o! view wh-engine/render:view-matrix))
|
||||
(if (and (v>= box-max mouse-location)
|
||||
(v<= box-min mouse-location))
|
||||
;; click has occured.
|
||||
(format t "Click on: ~S with btn: ~S~%" (o! drawable wh-engine:actor) mouse-button))
|
||||
))))
|
||||
|
||||
(defun on-mouse-up (mouse-location mouse-button)
|
||||
())
|
||||
|
|
|
|||
|
|
@ -114,9 +114,9 @@
|
|||
when handler
|
||||
collect `(,(cdr handler)
|
||||
(vec2 (truncate mouse-x whe/render:*pixel-scale*)
|
||||
(truncate mouse-y whe/render:*pixel-scale*))
|
||||
(- wh-engine/render:*view-height* (truncate mouse-y whe/render:*pixel-scale*)))
|
||||
(vec2 (truncate delta-x whe/render:*pixel-scale*)
|
||||
(truncate delta-y whe/render:*pixel-scale*))
|
||||
(- (truncate delta-y whe/render:*pixel-scale*)))
|
||||
state)))
|
||||
(:mousebuttondown
|
||||
(:x mouse-x :y mouse-y :button button)
|
||||
|
|
@ -126,7 +126,7 @@
|
|||
when handler
|
||||
collect `(,(cdr handler)
|
||||
(vec2 (truncate mouse-x whe/render:*pixel-scale*)
|
||||
(truncate mouse-y whe/render:*pixel-scale*))
|
||||
(- wh-engine/render:*view-height* (truncate mouse-y whe/render:*pixel-scale*)))
|
||||
button)))
|
||||
(:mousebuttonup
|
||||
(:x mouse-x :y mouse-y :button button)
|
||||
|
|
@ -136,7 +136,7 @@
|
|||
when handler
|
||||
collect `(,(cdr handler)
|
||||
(vec2 (truncate mouse-x whe/render:*pixel-scale*)
|
||||
(truncate mouse-y whe/render:*pixel-scale*))
|
||||
(- wh-engine/render:*view-height* (truncate mouse-y whe/render:*pixel-scale*)))
|
||||
button)))
|
||||
(:joyaxismotion
|
||||
(:which joy-id :axis axis :value value)
|
||||
|
|
|
|||
|
|
@ -35,7 +35,7 @@
|
|||
(defmethod draw ((this drawable-test) view)
|
||||
(gl:color (vx4 (o! this colour)) (vy4 (o! this colour)) (vz4 (o! this colour)) (vw4 (o! this colour)))
|
||||
(gl:with-primitives :quads
|
||||
(gl:vertex -0.5 -0.5 0.0 1.0)
|
||||
(gl:vertex 0.5 -0.5 0.0 1.0)
|
||||
(gl:vertex 0.5 0.5 0.0 1.0)
|
||||
(gl:vertex -0.5 0.5 0.0 1.0)))
|
||||
(gl:vertex -0.5 -0.5)
|
||||
(gl:vertex 0.5 -0.5)
|
||||
(gl:vertex 0.5 0.5)
|
||||
(gl:vertex -0.5 0.5)))
|
||||
|
|
|
|||
|
|
@ -25,7 +25,15 @@
|
|||
; methods
|
||||
view-point render-view render-drawable
|
||||
|
||||
*view-width* *view-height* *view-ppu* *pixel-scale*))
|
||||
*view-width* *view-height* *view-ppu* *pixel-scale*
|
||||
|
||||
;; render/render-target.lisp
|
||||
render-target
|
||||
; properties
|
||||
width height framebuffer renderbuffer render-texture
|
||||
; methods
|
||||
bind-for-rendering
|
||||
))
|
||||
|
||||
(in-package wh-engine/render)
|
||||
|
||||
|
|
@ -58,40 +66,18 @@
|
|||
"Re-sort the *world-views* list by render pass."
|
||||
(sort *world-views* #'< :key (lambda (v) (o! (deref-pointer v) render-pass))))
|
||||
|
||||
(let (framebuf renderbuf render-texture win-width win-height)
|
||||
(let (render-target win-width win-height)
|
||||
(defun render-system-init ()
|
||||
(setf win-width (* *view-width* *pixel-scale*)
|
||||
win-height (* *view-height* *pixel-scale*)
|
||||
framebuf (gl:gen-framebuffer)
|
||||
renderbuf (gl:gen-renderbuffer)
|
||||
render-texture (gl:gen-texture))
|
||||
render-target (make-instance 'render-target :width *view-width* :height *view-height*))
|
||||
|
||||
;; set up framebuffer
|
||||
(gl:bind-framebuffer :framebuffer framebuf)
|
||||
|
||||
(gl:bind-texture :texture-2d render-texture)
|
||||
(gl:tex-image-2d :texture-2d 0 :rgba *view-width* *view-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)
|
||||
;; change render target mode
|
||||
(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)
|
||||
|
||||
(gl:framebuffer-texture-2d :framebuffer :color-attachment0 :texture-2d render-texture 0)
|
||||
|
||||
(gl:bind-renderbuffer :renderbuffer renderbuf)
|
||||
(gl:renderbuffer-storage :renderbuffer :depth24-stencil8 *view-width* *view-height*)
|
||||
(gl:bind-renderbuffer :renderbuffer 0)
|
||||
|
||||
(gl:framebuffer-renderbuffer :framebuffer :depth-stencil-attachment :renderbuffer renderbuf)
|
||||
|
||||
;; make sure it's valid
|
||||
(let ((result (gl:check-framebuffer-status :framebuffer)))
|
||||
(unless (gl::enum= result :framebuffer-complete)
|
||||
(error "Failed to create framebuffer: ~S" result)))
|
||||
|
||||
(format t "texture-resident-p: ~S~%" (gl:texture-resident-p render-texture))
|
||||
|
||||
;; set up gl
|
||||
(gl:matrix-mode :projection)
|
||||
(gl:ortho 0 *view-width*
|
||||
|
|
@ -100,13 +86,11 @@
|
|||
(gl:matrix-mode :modelview)
|
||||
(gl:load-identity)
|
||||
(gl:clear-color 0.0 0.0 0.0 1.0)
|
||||
(gl:clear :color-buffer)
|
||||
(gl:clear :depth-buffer))
|
||||
(gl:clear :color-buffer :depth-buffer :stencil-buffer))
|
||||
|
||||
(defun render-system-update ()
|
||||
;; draw to render texture
|
||||
(gl:bind-framebuffer :framebuffer framebuf)
|
||||
(gl:viewport 0 0 *view-width* *view-height*)
|
||||
(o! render-target (bind-for-rendering))
|
||||
(gl:clear :color-buffer)
|
||||
(gl:enable :depth-test)
|
||||
(let ((render-pass nil))
|
||||
|
|
@ -126,7 +110,7 @@
|
|||
(gl:clear :color-buffer)
|
||||
(gl:disable :depth-test)
|
||||
(gl:enable :texture-2d)
|
||||
(gl:bind-texture :texture-2d render-texture)
|
||||
(gl:bind-texture :texture-2d (o! render-target render-texture))
|
||||
(gl:matrix-mode :modelview)
|
||||
(gl:load-identity)
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,90 @@
|
|||
;;;; wh-engine/render/render-target.lisp
|
||||
;;;; Render targets - structures that store a GL framebuffer, renderbuffer, and texture.
|
||||
(in-package wh-engine/render)
|
||||
|
||||
(defclass render-target ()
|
||||
((width :documentation "The width in pixels of this render target."
|
||||
:reader width
|
||||
:type fixnum
|
||||
:initarg :width
|
||||
:initform *view-width*)
|
||||
(height :documentation "The height in pixels of this render target."
|
||||
:reader height
|
||||
:type fixnum
|
||||
:initarg :height
|
||||
:initform *view-height*)
|
||||
(depth-texture-p :documentation "Whether or not to render depth (and stencil) information to a texture."
|
||||
:reader depth-texture-p
|
||||
:type boolean
|
||||
:initarg :depth-texture-p
|
||||
:initform nil)
|
||||
(framebuffer :documentation "The GL framebuffer associated with this render target."
|
||||
:reader framebuffer
|
||||
:type (or fixnum null)
|
||||
:initform nil)
|
||||
(renderbuffer :documentation "The GL renderbuffer associated with this render target."
|
||||
:reader renderbuffer
|
||||
:type (or fixnum null)
|
||||
:initform nil)
|
||||
(depth-texture :documentation "The GL texture containing the depth and stencil output for this render target."
|
||||
:reader depth-texture
|
||||
:type (or fixnum null)
|
||||
:initform nil)
|
||||
(render-texture :documentation "The GL render texture containing the output of this render target."
|
||||
:reader render-texture
|
||||
:type (or fixnum null)
|
||||
:initform nil))
|
||||
(:documentation "Stores a GL framebuffer, and its associated renderbuffer and output texture."))
|
||||
|
||||
(defmethod make-load-form ((this render-target) &optional environment)
|
||||
(declare (ignore environment))
|
||||
`(make-instance ',(class-name (class-of this))
|
||||
:width ,(o! this width) :height ,(o! this height)
|
||||
:depth-texture-p ,(o! this depth-texture-p)))
|
||||
|
||||
(defmethod initialize-instance :after ((this render-target) &key)
|
||||
;; create render texture
|
||||
(setf (o! this :slot render-texture) (gl:gen-texture))
|
||||
(gl:bind-texture :texture-2d (o! this :slot render-texture))
|
||||
(gl:tex-image-2d :texture-2d 0 :rgba
|
||||
(o! this :slot width) (o! this :slot 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)
|
||||
(gl:bind-texture :texture-2d 0)
|
||||
|
||||
(if (o! this depth-texture-p)
|
||||
(progn
|
||||
;; create depth texture
|
||||
(setf (o! this :slot depth-texture) (gl:gen-texture))
|
||||
(gl:bind-texture :texture-2d (o! this :slot depth-texture))
|
||||
(gl:tex-image-2d :texture-2d 0 :depth24-stencil8
|
||||
(o! this :slot width) (o! this :slot height)
|
||||
0 :depth-stencil :unsigned-int-24-8 (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)
|
||||
(gl:bind-texture :texture-2d 0))
|
||||
(progn
|
||||
;; create renderbuffer
|
||||
(setf (o! this :slot renderbuffer) (gl:gen-renderbuffer))
|
||||
(gl:bind-renderbuffer :renderbuffer (o! this :slot renderbuffer))
|
||||
(gl:renderbuffer-storage :renderbuffer :depth24-stencil8 (o! this :slot width) (o! this :slot height))
|
||||
(gl:bind-renderbuffer :renderbuffer 0)))
|
||||
|
||||
;; create framebuffer
|
||||
(setf (o! this :slot framebuffer) (gl:gen-framebuffer))
|
||||
(gl:bind-framebuffer :framebuffer (o! this :slot framebuffer))
|
||||
(gl:framebuffer-texture-2d :framebuffer :color-attachment0 :texture-2d (o! this :slot render-texture) 0)
|
||||
(if (o! this depth-texture-p)
|
||||
(gl:framebuffer-texture-2d :framebuffer :depth-stencil-attachment :texture-2d (o! this :slot depth-texture) 0)
|
||||
(gl:framebuffer-renderbuffer :framebuffer :depth-stencil-attachment :renderbuffer (o! this :slot renderbuffer)))
|
||||
|
||||
(gl:bind-framebuffer :framebuffer 0))
|
||||
|
||||
(defmethod bind-for-rendering ((this render-target))
|
||||
(gl:bind-framebuffer :framebuffer (o! this framebuffer))
|
||||
(gl:viewport 0 0 (o! this width) (o! this height)))
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
;;;; wh-engine/render/shader.lisp
|
||||
;;;; Lisp class for holding & handling shaders.
|
||||
;; (in-package wh-engine/render)
|
||||
|
||||
(defun replace-cross-referenced-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 (collect-cross-referenced-vars (cdr form))))
|
||||
|
||||
(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."
|
||||
(list (collect-shader-vars vert-body)
|
||||
(collect-shader-vars 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)))
|
||||
|
|
@ -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;
|
||||
}
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
;;;; basic-shader.lisp (Lisp shader code)
|
||||
|
||||
#|
|
||||
(define-shader basic-shader
|
||||
(:version 330)
|
||||
(:vertex-shader
|
||||
:in ((vert-pos :type :vec3 :location 0)
|
||||
(vert-uv :type :vec2 :location 1))
|
||||
:out ((uv :type :vec2))
|
||||
:uniform ((model :type :mat4)
|
||||
(view :type :mat4)
|
||||
(proj :type :mat4))
|
||||
:main ((setf *position* (* proj view model (vec4 vert-pos 1.0)))
|
||||
(setf uv vert-uv)))
|
||||
(:fragment-shader
|
||||
:in ((uv :type :vec2))
|
||||
:out ((*frag-colour* :type :vec4))
|
||||
:uniform ((main-tex :type :sampler-2d)
|
||||
(colour :type :vec4))
|
||||
:main ((setf *frag-colour* (* (sample-texture main-tex uv) colour)))))
|
||||
|#
|
||||
|
||||
(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))))
|
||||
|
|
@ -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;
|
||||
}
|
||||
|
|
@ -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);
|
||||
}
|
||||
|
|
@ -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;
|
||||
}
|
||||
|
|
@ -17,18 +17,10 @@
|
|||
:type boolean
|
||||
:initarg :cull-p
|
||||
:initform t)
|
||||
(framebuffer :documentation "The GL framebuffer this view renders to."
|
||||
:reader framebuffer
|
||||
:type (or fixnum null)
|
||||
:initform nil)
|
||||
(renderbuffer :documentation "The GL renderbuffer this view renders depth & stencil data to."
|
||||
:reader renderbuffer
|
||||
:type (or fixnum null)
|
||||
:initform nil)
|
||||
(render-texture :documentation "The GL render texture this view renders color data to."
|
||||
:reader render-texture
|
||||
:type (or fixnum null)
|
||||
:initform nil))
|
||||
(render-target :documentation "The render target this view renders to."
|
||||
:reader render-target
|
||||
:type (or render-target null)
|
||||
:initform nil))
|
||||
(:documentation "Defines a view into the scene, and rendering settings for objects drawn by the view."))
|
||||
|
||||
(defmethod (setf render-pass) (new-val (this view))
|
||||
|
|
@ -37,45 +29,14 @@
|
|||
(sort-world-views))
|
||||
|
||||
(defmethod resume :after ((this view))
|
||||
;; create render texture & framebuffer
|
||||
(unless (and (o! this render-texture) (gl:texture-resident-p (o! this render-texture))
|
||||
(o! this renderbuffer) (gl:is-renderbuffer (o! this renderbuffer))
|
||||
(o! this framebuffer) (gl:is-framebuffer (o! this framebuffer)))
|
||||
;; ensure the old ones are deleted if they exist
|
||||
(when (o! this framebuffer)
|
||||
(gl:delete-framebuffers (list (o! this framebuffer))))
|
||||
(when (o! this render-texture)
|
||||
(gl:delete-texture (o! this render-texture)))
|
||||
(when (o! this renderbuffer)
|
||||
(gl:delete-renderbuffers (list (o! this renderbuffer))))
|
||||
;; create render texture
|
||||
(setf (o! this :slot render-texture) (gl:gen-texture))
|
||||
(gl:bind-texture :texture-2d (o! this render-texture))
|
||||
(gl:tex-image-2d :texture-2d 0 :rgba
|
||||
*view-width* *view-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)
|
||||
(gl:bind-texture :texture-2d 0)
|
||||
;; create renderbuffer
|
||||
(setf (o! this :slot renderbuffer) (gl:gen-renderbuffer))
|
||||
(gl:bind-renderbuffer :renderbuffer (o! this renderbuffer))
|
||||
(gl:renderbuffer-storage :renderbuffer :depth24-stencil8 *view-width* *view-height*)
|
||||
(gl:bind-renderbuffer :renderbuffer 0)
|
||||
;; create framebuffer
|
||||
(setf (o! this :slot framebuffer) (gl:gen-framebuffer))
|
||||
(gl:bind-framebuffer :framebuffer (o! this framebuffer))
|
||||
(gl:framebuffer-texture-2d :framebuffer :color-attachment0 :texture-2d (o! this render-texture) 0)
|
||||
(gl:framebuffer-renderbuffer :framebuffer :depth-stencil-attachment :renderbuffer (o! this renderbuffer))
|
||||
(gl:bind-framebuffer :framebuffer 0)
|
||||
))
|
||||
(unless (o! this render-target)
|
||||
(setf (o! this :slot render-target) (new! render-target :width *view-width* :height *view-height*))))
|
||||
|
||||
(defmethod activate :after ((this view) &key)
|
||||
; Register
|
||||
(pushnew (make-weak-pointer this) *world-views*)
|
||||
(sort-world-views))
|
||||
(when (o! this actor tree-active-p)
|
||||
(pushnew (make-weak-pointer this) *world-views*)
|
||||
(sort-world-views)))
|
||||
|
||||
(defmethod destroy :before ((this view))
|
||||
(unless (o! this destroyed-p)
|
||||
|
|
@ -123,18 +84,28 @@
|
|||
do (o! this (render-drawable drawable view-matrix)))
|
||||
))
|
||||
|
||||
(defun transform-box (box drawable-matrix view-matrix)
|
||||
(with-vec2 (ax ay) (car box)
|
||||
(with-vec2 (bx by) (cdr box)
|
||||
(let ((box-a (vxy-trunc (n*m view-matrix
|
||||
(m* drawable-matrix (vec3 ax ay 1)))))
|
||||
(box-b (vxy-trunc (n*m view-matrix
|
||||
(m* drawable-matrix (vec3 bx by 1)))))
|
||||
(box-ab (vxy-trunc (n*m view-matrix
|
||||
(m* drawable-matrix (vec3 ax by 1)))))
|
||||
(box-ba (vxy-trunc (n*m view-matrix
|
||||
(m* drawable-matrix (vec3 bx ay 1))))))
|
||||
(values (vmin box-a box-b box-ab box-ba)
|
||||
(vmax box-a box-b box-ab box-ba))))))
|
||||
|
||||
(defun in-view-p (drawable drawable-matrix view-matrix view-box)
|
||||
"Determine if drawable is in the view defined by view-matrix and view-box."
|
||||
(let ((drawable-culling-box (o! drawable culling-box))
|
||||
box-a box-b)
|
||||
(setf box-a (vxy-trunc (m* view-matrix
|
||||
(m* drawable-matrix (vxy1 (car drawable-culling-box))))))
|
||||
(setf box-b (vxy-trunc (m* view-matrix
|
||||
(m* drawable-matrix (vxy1 (cdr drawable-culling-box))))))
|
||||
(multiple-value-bind (box-min box-max)
|
||||
(transform-box (o! drawable culling-box) drawable-matrix view-matrix)
|
||||
;; If it's in view at all, either its top-right corner is >= bottom-left of view,
|
||||
;; or its bottom-left is <= top-right of view
|
||||
(or (v>= (vmax box-a box-b) (car view-box))
|
||||
(v<= (vmin box-a box-b) (cdr view-box)))))
|
||||
(or (v>= box-max (car view-box))
|
||||
(v<= box-min (cdr view-box)))))
|
||||
|
||||
(defmethod render-drawable ((this view) drawable view-matrix)
|
||||
"Render drawable with the precomputed view-matrix."
|
||||
|
|
|
|||
Loading…
Reference in New Issue