forked from Shirakumo/kandria
-
Notifications
You must be signed in to change notification settings - Fork 0
/
shadow-map.lisp
174 lines (146 loc) · 7.08 KB
/
shadow-map.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
(in-package #:org.shirakumo.fraf.kandria)
(define-shader-entity shadow-geometry (vertex-entity)
((caster :initarg :caster :initform (error "CASTER required"))))
(defmethod initialize-instance :after ((caster shadow-geometry) &key data)
(let* ((data (make-array (length data) :adjustable T :fill-pointer T :element-type 'single-float
:initial-contents data))
(vbo (make-instance 'vertex-buffer :data-usage :dynamic-draw :buffer-data data))
(vao (make-instance 'vertex-array :vertex-form :triangles
:bindings `((,vbo :size 2 :offset 0 :stride 8))
:size (/ (length data) 2))))
(setf (vertex-array caster) vao)))
(defmethod add-shadow-line ((vbo vertex-buffer) a b)
(let* ((data (buffer-data vbo)))
;; Vertices arranged in the following manner, such that
;; bottom vertices that should be moved are always at an
;; even modulus, for easy testing in the vertex shader.
;; 0 _1 2
;; _3 4 _5
(vector-push-extend (vx a) data)
(vector-push-extend (vy a) data)
(vector-push-extend (vx a) data)
(vector-push-extend (vy a) data)
(vector-push-extend (vx b) data)
(vector-push-extend (vy b) data)
(vector-push-extend (vx b) data)
(vector-push-extend (vy b) data)
(vector-push-extend (vx b) data)
(vector-push-extend (vy b) data)
(vector-push-extend (vx a) data)
(vector-push-extend (vy a) data)))
(defmethod apply-transforms progn ((caster shadow-geometry))
(apply-transforms (slot-value caster 'caster)))
(defmethod render :around ((caster shadow-geometry) (program shader-program))
(let* ((caster (slot-value caster 'caster))
(bsize (bsize caster)))
;; We fade the caster a bit in order to ensure shadows can cast onto other chunks.
(let* ((camera (camera +world+))
(view (in-view-tester camera))
(diff (* 0.5 (+ 600 (- (vz view) (vx view))))))
(setf (uniform program "strength") (- 1.0 (clamp 0.0 (/ (- (abs (- (vx (location camera)) (vx (location caster)))) (vx bsize)) diff) 1.0)))
(call-next-method))))
(defclass shadow-caster ()
((shadow-geometry :accessor shadow-geometry)))
(defmethod initialize-instance ((caster shadow-caster) &key)
(call-next-method)
(setf (shadow-geometry caster) (make-instance 'shadow-geometry :caster caster)))
(defmethod stage :after ((caster shadow-caster) (area staging-area))
(stage (shadow-geometry caster) area))
(defgeneric compute-shadow-geometry (caster geometry))
(defmethod compute-shadow-geometry ((caster shadow-caster) (_ (eql T)))
(compute-shadow-geometry caster (shadow-geometry caster)))
(defmethod compute-shadow-geometry ((caster shadow-caster) (geometry shadow-geometry))
(compute-shadow-geometry caster (caar (bindings (vertex-array geometry)))))
(defmethod compute-shadow-geometry :after (caster (vbo vertex-buffer))
(when (allocated-p vbo)
(with-eval-in-render-loop (+world+)
(resize-buffer vbo (* 4 (length (buffer-data vbo))) :data (buffer-data vbo)))))
(defmethod compute-shadow-geometry :after (caster (geometry shadow-geometry))
(setf (size (vertex-array geometry))
(/ (length (buffer-data (caar (bindings (vertex-array geometry))))) 2)))
(define-shader-pass shadow-map-pass (per-object-pass single-shader-pass)
((name :initform 'shadow-map-pass)
(shadow-map :port-type output :texspec (:internal-format :r8))
(local-shade :initform 0.0 :accessor local-shade)
(fc :initform 0 :accessor fc))
(:buffers (kandria gi)))
(defmethod object-renderable-p ((object renderable) (pass shadow-map-pass)) NIL)
(defmethod object-renderable-p ((object shadow-caster) (pass shadow-map-pass)) T)
(defmethod object-renderable-p ((object shadow-geometry) (pass shadow-map-pass)) T)
(defmethod construct-frame ((pass shadow-map-pass))
(let* ((frame (frame pass))
(index 0)
(total (array-total-size frame))
(renderable-table (trial::renderable-table pass)))
(flet ((store (object program)
(when (<= total (incf index))
(adjust-array frame (* 2 total))
(loop for i from total below (* 2 total)
do (setf (aref frame i) (cons NIL NIL)))
(setf total (* 2 total)))
(let ((entry (aref frame (1- index))))
(setf (car entry) object)
(setf (cdr entry) program))))
(when (region +world+)
(let ((container (tvec 0 0 0 0)))
(v<- container (in-view-tester (camera +world+)))
(decf (vx container) 300)
(decf (vy container) 300)
(incf (vz container) 300)
(incf (vw container) 300)
(do-fitting (object (bvh (region +world+)) container)
(let* ((object (when (typep object 'shadow-caster)
(shadow-geometry object)))
(program (gethash object renderable-table)))
(when program
(store object program)))))))
(setf (fill-pointer frame) index)
frame))
(defmethod enter ((caster shadow-caster) (pass shadow-map-pass))
(enter (shadow-geometry caster) pass))
(defmethod leave ((caster shadow-caster) (pass shadow-map-pass))
(leave (shadow-geometry caster) pass))
(defmethod render ((pass shadow-map-pass) target)
(when (setting :display :shadows)
(call-next-method)))
(defmethod render :before ((pass shadow-map-pass) target)
(gl:blend-func :src-alpha :one)
(gl:clear-color 0 0 0 0))
(defmethod render :after ((pass shadow-map-pass) target)
(gl:blend-func :src-alpha :one-minus-src-alpha)
(let ((player (unit 'player T)))
(setf (fc pass) (mod (+ (fc pass) 1) 60))
(when (and player (= 0 (fc pass)))
(let* ((pos (m* (projection-matrix) (view-matrix) (vec (vx (location player)) (+ (vy (location player)) 8) 0 1)))
(px (nv/ (nv+ pos 1) 2)))
(gl:bind-framebuffer :read-framebuffer (gl-name (framebuffer pass)))
(cffi:with-foreign-object (pixel :uint8)
(%gl:read-pixels (floor (clamp 0 (* (vx px) (width pass)) (1- (width pass))))
(floor (clamp 0 (* (vy px) (height pass)) (1- (height pass))))
1 1 :red :unsigned-byte pixel)
(setf (local-shade pass) (/ (cffi:mem-ref pixel :uint8) 256.0)))))))
(defmethod force-lighting ((pass shadow-map-pass))
(setf (fc pass) 59))
(defmethod handle ((ev force-lighting) (pass shadow-map-pass))
(force-lighting pass))
(define-class-shader (shadow-map-pass :vertex-shader)
"layout(location = 0) in vec2 vertex_position;
uniform mat4 model_matrix;
uniform mat4 view_matrix;
uniform mat4 projection_matrix;
void main(){
maybe_call_next_method();
vec2 vertex = (model_matrix * vec4(vertex_position, 0, 1)).xy;
if(gl_VertexID % 2 != 0){
vec2 direction = normalize(gi.location - vertex);
vertex = vertex - direction*100000;
}
gl_Position = projection_matrix * view_matrix * vec4(vertex, 0, 1);
}")
(define-class-shader (shadow-map-pass :fragment-shader)
"out vec4 color;
uniform float strength = 1.0;
void main(){
maybe_call_next_method();
color = vec4(0.5*strength,0.0,0.0,1.0);
}")