-
Notifications
You must be signed in to change notification settings - Fork 0
/
compact.cirru
269 lines (268 loc) · 11.3 KB
/
compact.cirru
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
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
{} (:package |sapium)
:configs $ {} (:init-fn |sapium.app.main/main!) (:reload-fn |sapium.app.main/reload!) (:version |0.0.20)
:modules $ [] |touch-control/ |respo.calcit/ |memof/ |quaternion/
:entries $ {}
:files $ {}
|sapium.app.main $ {}
:defs $ {}
|*store $ quote
defatom *store $ {}
:tab $ turn-keyword (get-env "\"tab" "\"axis")
:states $ {}
|dispatch! $ quote
defn dispatch! (op data)
when dev? $ js/console.log "\"Dispatch:" op data
if (= op :city-spin)
do $ swap! *dirty-uniforms update :spin-city
fn (x)
+ x $ * 0.01 data
let
store @*store
next $ if (list? op)
update-states store $ [] op data
case-default op
do (js/console.warn "\"unknown op" op) nil
:cube-right $ update store :v inc
:tab-focus $ assoc store :tab data
:move-p1 $ assoc store :p1 data
if (some? next) (reset! *store next)
|main! $ quote
defn main! ()
if dev? $ load-console-formatter!
twgl/setDefaults $ js-object (:attribPrefix "\"a_")
render-control!
start-control-loop! 10 on-control-event
set! js/window.onresize $ fn (e) (reset-canvas-size!) (render-app!)
reset-canvas-size!
render-app!
|on-control-event $ quote
defn on-control-event (elapsed states delta)
let
l-move $ map (:left-move states) refine-strength
r-move $ map (:right-move states) refine-strength
r-delta $ :right-move delta
l-delta $ :left-move delta
left-a? $ :left-a? states
right-a? $ or (:right-a? states) (:shift? states)
right-b? $ :right-b? states
left-b? $ :left-b? states
; println "\"L" l-move "\"R" r-move
when
not= 0 $ nth l-move 1
move-viewer-by! 0 0 $ negate
* 2 elapsed $ nth l-move 1
when
not= 0 $ nth l-move 0
rotate-glance-by!
* -0.5 elapsed $ nth l-move 0
, 0
when
and (not right-a?)
not= ([] 0 0) r-move
move-viewer-by!
* 2 elapsed $ nth r-move 0
* 2 elapsed $ nth r-move 1
, 0
when
and right-a? $ not= 0 (nth r-move 1)
rotate-glance-by! 0 $ * 0.5 (nth r-move 1) elapsed
when
and right-a? $ not= 0 (nth r-move 0)
spin-glance-by! $ * -0.5 (nth r-move 0) elapsed
when
or
not= l-move $ [] 0 0
not= r-move $ [] 0 0
render-app!
|refine-strength $ quote
defn refine-strength (x)
&* x 0.1 $ sqrt
js/Math.abs $ &* x 0.01
|reload! $ quote
defn reload! () $ if (nil? build-errors)
do (render-app!) (replace-control-loop! 10 on-control-event)
set! js/window.onresize $ fn (e) (reset-canvas-size!) (render-app!)
hud! "\"ok~" "\"OK"
hud! "\"error" build-errors
|render-app! $ quote
defn render-app! () $ let
vs $ inline-shader "\"rhombus.vert"
fs $ inline-shader "\"rhombus.frag"
gl @*gl-context
program-info $ cached-build-program gl vs fs
scaled-width $ * dpr js/window.innerWidth
scaled-height $ * dpr js/window.innerHeight
arrays $ let
arr $ js-object
:position $ .!createAugmentedTypedArray twgl/primitives 2 6
:uv $ .!createAugmentedTypedArray twgl/primitives 2 6
.!push (.-position arr) -1 -1 1 -1 -1 1 -1 1 1 -1 1 1
.!push (.-uv arr) 0 0 1 0 0 1 0 1 1 0 1 1
, arr
buffer-info $ twgl/createBufferInfoFromArrays gl arrays
uniforms $ js-object
:u_screen_resolution $ js-array scaled-width scaled-height
:u_time $ * 0.001 (js/performance.now)
:forward $ to-js-data @*viewer-forward
:upward $ to-js-data @*viewer-upward
:viewer_position $ do (to-js-data @*viewer-position) (; js-array 0 0 0)
twgl/resizeCanvasToDisplaySize (.-canvas gl) dpr
.!enable gl $ .-DEPTH_TEST gl
.!enable gl $ .-CULL_FACE gl
.!viewport gl 0 0 scaled-width scaled-height
.!clearColor gl 0 0 0 1
.!clear gl $ bit-or (.-COLOR_BUFFER_BIT gl) (.-DEPTH_BUFFER_BIT gl)
.!useProgram gl $ .-program program-info
twgl/setBuffersAndAttributes gl program-info buffer-info
twgl/setUniforms program-info uniforms
twgl/drawBufferInfo gl buffer-info $ .-TRIANGLES gl
|reset-canvas-size! $ quote
defn reset-canvas-size! ()
; -> canvas .-width $ set! (&* dpr js/window.innerWidth)
; -> canvas .-height $ set! (&* dpr js/window.innerHeight)
-> canvas .-style .-width $ set! (str js/window.innerWidth "\"px")
-> canvas .-style .-height $ set! (str js/window.innerHeight "\"px")
:ns $ quote
ns sapium.app.main $ :require ("\"./calcit.build-errors" :default build-errors) ("\"bottom-tip" :default hud!)
sapium.config :refer $ dev? dpr inline-shader cached-build-program
"\"twgl.js" :as twgl
touch-control.core :refer $ render-control! start-control-loop! replace-control-loop!
sapium.global :refer $ *gl-context canvas
memof.once :refer $ reset-memof1-caches!
sapium.perspective :refer $ *viewer-position *viewer-forward *viewer-upward transform-3d new-lookat-point move-viewer-by! rotate-glance-by! spin-glance-by!
|sapium.config $ {}
:defs $ {}
|*shader-programs $ quote
defatom *shader-programs $ {}
|back-cone-scale $ quote (def back-cone-scale 1)
|cached-build-program $ quote
defn cached-build-program (gl vs fs)
let
caches @*shader-programs
field $ str vs &newline "\"@@@@@@" &newline fs
if (&map:contains? caches field) (&map:get caches field)
let
program $ twgl/createProgramInfo gl (js-array vs fs)
if (nil? program) (raise "\"Failed to compile shader")
swap! *shader-programs assoc field program
, program
|dev? $ quote
def dev? $ = "\"dev" (get-env "\"mode" "\"release")
|dpr $ quote (def dpr js/window.devicePixelRatio)
|half-pi $ quote
def half-pi $ * 0.5 &PI
|hide-tabs? $ quote
def hide-tabs? $ = "\"true" (get-env "\"hide-tabs" "\"false")
|inline-shader $ quote
defmacro inline-shader (name)
let
shader $ if (blank? calcit-dirname) (str "\"shaders/" name)
let
dir $ if (.ends-with? calcit-dirname "\"/") calcit-dirname (str calcit-dirname "\"/")
str dir "\"shaders/" name
println "\"reading shader file:" name
read-file shader
|mobile? $ quote
def mobile? $ .!mobile (new mobile-detect js/window.navigator.userAgent)
:ns $ quote
ns sapium.config $ :require ("\"mobile-detect" :default mobile-detect) ("\"twgl.js" :as twgl)
sapium.$meta :refer $ calcit-dirname
|sapium.global $ {}
:defs $ {}
|*gl-context $ quote
defatom *gl-context $ .!getContext canvas "\"webgl"
|canvas $ quote
def canvas $ js/document.querySelector "\"canvas"
:ns $ quote (ns sapium.global)
|sapium.math $ {}
:defs $ {}
|&v+ $ quote
defn &v+ (a b)
let[] (x y z) a $ let[] (x2 y2 z2) b
[] (&+ x x2) (&+ y y2) (&+ z z2)
|&v- $ quote
defn &v- (a b)
let[] (x y z) a $ let[] (x2 y2 z2) b
[] (&- x x2) (&- y y2) (&- z z2)
|c-distance $ quote
defn c-distance (p1 p2)
let-sugar
[] x y
, p1
([] a b) p2
sqrt $ +
pow (- x a) 2
pow (- y b) 2
|square $ quote
defn square (x) (&* x x)
|sum-squares $ quote
defn sum-squares (a b)
&+ (&* a a) (&* b b)
:ns $ quote
ns sapium.math $ :require
sapium.core :refer $ new-lookat-point &v- &v+
sapium.hud :refer $ hud-display
sapium.global :refer $ *viewer-position
sapium.config :refer $ back-cone-scale
|sapium.perspective $ {}
:defs $ {}
|*viewer-forward $ quote
defatom *viewer-forward $ [] 0 0 -1
|*viewer-position $ quote
defatom *viewer-position $ [] 0 1 4
|*viewer-upward $ quote
defatom *viewer-upward $ [] 0 1 0
|move-viewer-by! $ quote
defn move-viewer-by! (x0 y0 z0)
let
dv $ to-viewer-axis x0 y0 z0
position @*viewer-position
reset! *viewer-position $ &v+ position dv
; println ([] x0 y0 z0) |=> $ [] dx dy dz
|rotate-glance-by! $ quote
defn rotate-glance-by! (x y)
if (not= x 0)
let
da $ * x 0.1
forward @*viewer-forward
upward @*viewer-upward
rightward $ v-cross upward forward
reset! *viewer-forward $ &v+
v-scale forward $ js/Math.cos da
v-scale rightward $ js/Math.sin da
if (not= y 0)
let
da $ * y 0.1
forward @*viewer-forward
upward @*viewer-upward
reset! *viewer-forward $ &v+
v-scale forward $ js/Math.cos da
v-scale upward $ js/Math.sin da
reset! *viewer-upward $ &v+
v-scale upward $ js/Math.cos da
v-scale forward $ negate (js/Math.sin da)
|spin-glance-by! $ quote
defn spin-glance-by! (v)
if (not= v 0)
let
da $ * v 0.1
forward @*viewer-forward
upward @*viewer-upward
rightward $ v-cross upward forward
reset! *viewer-upward $ &v+
v-scale upward $ js/Math.cos da
v-scale rightward $ js/Math.sin da
|to-viewer-axis $ quote
defn to-viewer-axis (x y z) (; "\"converting from WebGL coordinate to object coordinate")
let
forward @*viewer-forward
upward @*viewer-upward
rightward $ v-cross upward forward
&v+
&v+
v-scale rightward $ negate x
v-scale upward y
v-scale forward $ negate z
:ns $ quote
ns sapium.perspective $ :require
quaternion.core :refer $ v-cross v-scale v-dot &v- &v+