-
Notifications
You must be signed in to change notification settings - Fork 0
/
atomic-test3.scm
164 lines (136 loc) · 5.75 KB
/
atomic-test3.scm
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
(format #t "Entering ~a.~%" (current-filename))
;;; modules
(use-modules (ice-9 receive))
(use-modules (rnrs bytevectors))
;;; actual code
(define x-res 1)
(define y-res 1)
(receive (x y w h) (viewport)
(format #t "~a x ~a~%" w h)
(set! x-res w)
(set! y-res h))
;(let ((cam (make-perspective-camera "cam" (list 0 0 5) (list 0 0 -1) (list 0 1 0) 35 (/ x-res y-res) 1 1000)))
; (use-camera cam))
(load "default.shader")
(let ((home (getenv "HOME")))
(append-image-path (string-append home "/render-data/images"))
(append-image-path (string-append home "/render-data/images/wikimedia"))
(append-image-path (string-append home "/render-data/images/sponza")))
(defmacro cmdline (x)
`(query-cmdline ',x))
(define the-scene (make-scene "default"))
(define (custom-uniform-handler de uniform location)
(cond ((string=? uniform "light_dir") (gl:uniform3f location 0 -1 -0.2))
((string=? uniform "light_col") (gl:uniform3f location 1 .9 .9))
((string=? uniform "hemi_dir")
(let ((h (cmdline hemi-dir)))
(gl:uniform3f location (car h) (cadr h) (caddr h))))
(else #f))
)
(define drawelements '())
(make-texture-without-file "frag_mutex" gl#texture-2d x-res y-res gl#red gl#r32f gl#float)
(make-texture-without-file "frag_arrays" gl#texture-2d x-res (* y-res 10) gl#rgba gl#rgba32f gl#float) ; 32 slots per pixel
(define (atomic-buffer-handler de u l)
(cond ((string=? u "mutex_buffer") (gl:uniform1i l 0))
((string=? u "per_frag_array") (gl:uniform1i l 1))
(else #f)))
(define (testcall name mesh material)
(let* ((shader (if (cmdline hemi)
(if (material-has-textures? material)
(find-shader "diffuse-hemi+tex")
(find-shader "diffuse-hemi/frag-arrays"))
(if (material-has-textures? material)
(find-shader "diffuse-dl+tex")
(find-shader "diffuse-dl"))))
(de (make-drawelement name mesh shader material)))
(add-drawelement-to-scene the-scene de)
(prepend-uniform-handler de 'default-matrix-uniform-handler)
(prepend-uniform-handler de 'default-material-uniform-handler)
(prepend-uniform-handler de custom-uniform-handler)
(prepend-uniform-handler de atomic-buffer-handler)
(set! drawelements (cons de drawelements))
))
(let ((fallback (make-material "fallback" (list 1 0 0 1) (list 1 0 0 1) (list 0 0 0 1))))
(receive (min max) (load-objfile-and-create-objects-with-separate-vbos (cmdline model) (cmdline model) testcall fallback)
(let* ((near 1)
(far 1000)
(diam (vec-sub max min))
(diam/2 (vec-div-by-scalar diam 2))
(center (vec-add min diam/2))
(distance (vec-length diam))
(pos (vec-add center (make-vec 0 0 distance))))
(while (> near (/ distance 100))
(set! near (/ near 10)))
(while (< far (* distance 4))
(set! far (* far 2)))
(let ((cam (make-perspective-camera "cam" pos (list 0 0 -1) (list 0 1 0) 35 (/ x-res y-res) near far)))
(use-camera cam))
(set-move-factor! (/ distance 20)))))
;; tex textured quad
(let* ((tqma (make-material "atquad" (make-vec 0 0 0 1) (make-vec 0 1 0 1) (make-vec 0 0 0 1)))
(tqme (make-quad-with-tc "atquad"))
(tqsh (find-shader "quad/show-frag-array-len"))
(de (make-drawelement "atquad" tqme tqsh tqma)))
(material-add-texture tqma (find-texture "frag_mutex"))
(prepend-uniform-handler de 'default-material-uniform-handler)
(prepend-uniform-handler de atomic-buffer-handler))
(let* ((tqma (make-material "clear-mb-mat" (make-vec 0 0 0 1) (make-vec 0 1 0 1) (make-vec 0 0 0 1)))
(tqme (make-quad "cmb"))
(tqsh (find-shader "quad/clear-mutex-buffer"))
(de (make-drawelement "cmb" tqme tqsh tqma)))
(material-add-texture tqma (find-texture "frag_mutex"))
(prepend-uniform-handler de 'default-material-uniform-handler)
(prepend-uniform-handler de atomic-buffer-handler))
(define atomic-counter (make-atomic-buffer "test" 1 1))
(define copy-of-atomic-buffer #f)
(define r .2)
(define g .3)
(define b .8)
(define command-queue '())
(defmacro enqueue (cmd)
`(begin
(format #t "cmd: .~a.~%" ',cmd)
(set! command-queue (cons ',cmd command-queue))))
(define (apply-commands)
(for-each primitive-eval
(reverse command-queue))
(set! command-queue '()))
(defmacro disable-color-output body
`(begin (gl:color-mask gl#false gl#false gl#false gl#false)
,@body
(gl:color-mask gl#true gl#true gl#true gl#true)))
(defmacro disable-depth-output body
`(begin (gl:depth-mask gl#false)
,@body
(gl:depth-mask gl#true)))
(define (display)
(gl:clear-color r g b 1)
(apply-commands)
(gl:clear (logior gl#color-buffer-bit gl#depth-buffer-bit))
(reset-atomic-buffer atomic-counter 0)
(bind-atomic-buffer atomic-counter 0)
(bind-texture-as-image (find-texture "frag_mutex") 0 0 #x88ba gl#r32i)
(bind-texture-as-image (find-texture "frag_arrays") 1 0 #x88ba gl#r32i)
(gl:disable gl#depth-test)
(disable-color-output
(disable-depth-output
(for-each render-drawelement
drawelements)))
(gl:finish 0)
(render-drawelement (find-drawelement "atquad"))
(unbind-texture-as-image (find-texture "frag_mutex") 0)
(unbind-atomic-buffer atomic-counter 0)
(gl:finish 0) ;; bug in wrapper/gen -> glFinish(void);
(set! copy-of-atomic-buffer (read-atomic-buffer atomic-counter))
; (format #t "bv0: ~a~%" (bytevector-s32-native-ref copy-of-atomic-buffer 0))
(let ((clear-de (find-drawelement "cmb"))
(frag-mutex (find-texture "frag_mutex" )))
(disable-color-output
(disable-depth-output
(bind-texture-as-image frag-mutex 0 0 #x88ba gl#r32i)
(render-drawelement clear-de)
(unbind-texture-as-image frag-mutex 0))))
(glut:swap-buffers))
(register-display-function display)
(gl:enable gl#depth-test)
(format #t "Leaving ~a.~%" (current-filename))