-
Notifications
You must be signed in to change notification settings - Fork 7
/
old-utils.lisp
201 lines (187 loc) · 8.43 KB
/
old-utils.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
(in-package #:3bgl-shaders)
;;; some brain-dead utils for shader-related stuff (recompiling
;;; shaders, setting uniforms by name, etc)
(defun uniform-index (program name)
(if program
(gl:get-uniform-location program name)
-1))
(defun uniformi (program name value)
(gl:uniformi (uniform-index program name) value))
(defun uniformf (program name x &optional y z w)
(let ((u (uniform-index program name)))
(unless (minusp u)
(cond
(w (%gl:uniform-4f u (float x) (float y) (float z) (float w)))
(z (%gl:uniform-3f u (float x) (float y) (float z)))
(y (%gl:uniform-2f u (float x) (float y)))
(x (%gl:uniform-1f u (float x)))))))
(defun uniformfv (program name v)
(let ((u (uniform-index program name)))
(unless (minusp u)
(typecase v
;; fast cases
((vector single-float 3)
(%gl:uniform-3f u (aref v 0) (aref v 1) (aref v 2)))
((vector single-float 4)
(%gl:uniform-4f u (aref v 0) (aref v 1) (aref v 2) (aref v 3)))
;; convenient but slower cases
((vector * 4)
(%gl:uniform-4f u (float (elt v 0) 1.0) (float (elt v 1) 1.0)
(float (elt v 2) 1.0) (float (elt v 3) 1.0)))
((vector * 3)
(%gl:uniform-3f u (float (elt v 0) 1.0) (float (elt v 1) 1.0)
(float (elt v 2) 1.0)))
((vector * 2)
(%gl:uniform-2f u (float (elt v 0) 1.0) (float (elt v 1) 1.0)))
((vector * 1)
(%gl:uniform-1f u (float (elt v 0) 1.0)))
))))
(defun uniform-matrix (program name m)
(let ((u (uniform-index program name)))
(unless (minusp u)
(gl:uniform-matrix u 4 (vector m) nil))))
(defun reload-program (old v f &key errorp (verbose t) geometry (version 450))
"compile program from shaders named by V and F, on success, delete
program OLD and return new program, otherwise return OLD"
;; intended to be used like
;; (setf (program foo) (reload-program (program foo) 'vertex 'frag))
(let ((vs (gl:create-shader :vertex-shader))
(fs (gl:create-shader :fragment-shader))
(gs (when geometry (gl:create-shader :geometry-shader)))
(program (gl:create-program))
(uniformh (make-hash-table)))
(unwind-protect
(flet ((c (stage entry)
(multiple-value-bind (source uniforms attributes buffers
structs)
(3bgl-shaders::generate-stage stage entry
:version version)
(declare (ignorable attributes buffers structs))
(loop for u in uniforms
for (l g tt) = u
for o = (gethash l uniformh)
when (and o (not (equalp u o)))
do (format t "duplicate uniform ~s -> ~s~%?" o u)
do (setf (gethash l uniformh)
(cons -1 u)))
source))
(try-shader (shader source)
(when *print-shaders*
(format t "generating shader ~s~%" shader)
(format t "~s~%" source))
(gl:shader-source shader source)
(gl:compile-shader shader)
(cond
((gl:get-shader shader :compile-status)
(gl:attach-shader program shader))
(errorp
(error "shader compile failed: ~s" (gl:get-shader-info-log shader)))
(t
(when verbose
(format verbose "shader compile failed: ~s" (gl:get-shader-info-log shader)))
(return-from reload-program old)))))
(try-shader vs (c :vertex v))
(try-shader fs (c :fragment f))
(when gs
(try-shader gs (c :geometry geometry)))
(gl:link-program program)
(cond
((gl:get-program program :link-status)
;; if it linked, swap with old program so we delete that on uwp
(rotatef old program))
(errorp
(error "program link failed ~s"
(gl:get-program-info-log program)))
(t
(when verbose
(format verbose "program link failed: ~s" (gl:get-program-info-log program))))))
;; clean up on exit
(gl:delete-shader vs)
(gl:delete-shader fs)
;; PROGRAM is either program we just tried to link, or previous one if
;; link succeeded
(when program
(gl:delete-program program)))
(when old
(loop for u being the hash-keys of uniformh
for n = (third (gethash u uniformh))
do (setf (car (gethash u uniformh))
(uniform-index old n))))
(values old uniformh)))
(defparameter *normalize-shader-types*
(alexandria:plist-hash-table
'(:vertex :vertex-shader
:fragment :fragment-shader
:geometry :geometry-shader
:tess-control :tess-control-shader
:tess-eval :tess-evaluation-shader
:compute :compute-shader)))
(defun reload-program* (old stages &key errorp (verbose t) (version 450)
(print *print-shaders*))
"compile program from STAGES, a plist of stage names and entry
points. on success, delete program OLD and return new program,
otherwise return OLD"
;; intended to be used like
;; (setf (program foo) (reload-program (program foo) '(:vertex v :fragment f))
(let ((shaders ())
(program (gl:create-program))
(uniformh (make-hash-table)))
(unwind-protect
(labels ((c (stage entry)
(multiple-value-bind (source uniforms attributes buffers
structs)
(3bgl-shaders::generate-stage stage entry
:version version)
(declare (ignorable attributes buffers structs))
(loop for u in uniforms
for (l g tt) = u
for o = (gethash l uniformh)
when (and o (not (equalp u o)))
do (format t "duplicate uniform ~s -> ~s~%?" o u)
do (setf (gethash l uniformh)
(cons -1 u)))
source))
(try-shader (stage entry-point)
(let ((source (c stage entry-point))
(shader (gl:create-shader stage)))
(push shader shaders)
(when print
(format t "generating shader ~s~%" shader)
(format t "~s~%" source))
(gl:shader-source shader source)
(gl:compile-shader shader)
(cond
((gl:get-shader shader :compile-status)
(gl:attach-shader program shader))
(errorp
(error "shader compile failed: ~s" (gl:get-shader-info-log shader)))
(t
(when verbose
(format verbose "shader compile failed: ~s" (gl:get-shader-info-log shader)))
(return-from reload-program* old))))))
(loop for (.stage entry) on stages by #'cddr
for stage = (gethash .stage *normalize-shader-types* .stage)
do (try-shader stage entry))
(gl:link-program program)
(cond
((gl:get-program program :link-status)
;; if it linked, swap with old program so we delete that on uwp
(rotatef old program))
(errorp
(error "program link failed ~s"
(gl:get-program-info-log program)))
(t
(when verbose
(format verbose "program link failed: ~s" (gl:get-program-info-log program))))))
;; clean up on exit
(map 'nil 'gl:delete-shader shaders)
;; PROGRAM is either program we just tried to link, or previous one if
;; link succeeded
(when program
(gl:delete-program program)))
(when old
(loop for u being the hash-keys of uniformh
for n = (third (gethash u uniformh))
do (setf (car (gethash u uniformh))
(uniform-index old n))))
(values old uniformh)))