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
open Js_of_ocaml
type time_interval = AnimationFrame | Millisecond of float
type regl_config = { time_interval : time_interval }
type texture_mag_option = MagNearest | MagLinear
type texture_min_option =
| MinNearest
| MinLinear
| NearestMipmapNearest
| LinearMipmapNearest
| NearestMipmapLinear
| LinearMipmapLinear
type texture_options = {
mag : texture_mag_option option;
min : texture_min_option option;
crop : ((int * int) * (int * int)) option;
}
type regl_start_config = {
virt_width : float;
virt_height : float;
fbo_num : int;
builtin_programs : string list option;
}
type texture = { name : string; width : int; height : int }
type regl_recv_msg =
| REGLTextureLoaded of texture
| REGLFontLoaded of string
| REGLProgramCreated of string
let encode_config config =
let interval =
match config.time_interval with
| AnimationFrame -> -1.0
| Millisecond ms -> ms
in
Js.Unsafe.obj [| ("interval", Js.Unsafe.inject interval) |]
let encode_texture_options topts =
match topts with
| Some opts ->
let mag_str =
match opts.mag with
| Some MagNearest -> "nearest"
| Some MagLinear -> "linear"
| None -> "linear"
in
let min_str =
match opts.min with
| Some MinNearest -> "nearest"
| Some MinLinear -> "linear"
| Some NearestMipmapNearest -> "nearest mipmap nearest"
| Some LinearMipmapNearest -> "linear mipmap nearest"
| Some NearestMipmapLinear -> "nearest mipmap linear"
| Some LinearMipmapLinear -> "linear mipmap linear"
| None -> "linear"
in
let subimg =
match opts.crop with
| Some ((x, y), (w, h)) ->
let arr = [| x; y; w; h |] in
Js.Unsafe.inject
(Js.array
(Array.map (fun i -> Js.number_of_float (float_of_int i)) arr))
| None -> Js.Unsafe.inject Js.null
in
[
("mag", Js.Unsafe.inject (Js.string mag_str));
("min", Js.Unsafe.inject (Js.string min_str));
("subimg", subimg);
]
| None ->
[
("mag", Js.Unsafe.inject (Js.string "linear"));
("min", Js.Unsafe.inject (Js.string "linear"));
]
let load_texture name url topts =
let opts_list =
("data", Js.Unsafe.inject (Js.string url)) :: encode_texture_options topts
in
let opts_obj = Js.Unsafe.obj (Array.of_list opts_list) in
Js.Unsafe.obj
[|
("_c", Js.Unsafe.inject (Js.string "loadTexture"));
("_n", Js.Unsafe.inject (Js.string name));
("opts", Js.Unsafe.inject opts_obj);
|]
let start_regl config =
match config.builtin_programs with
| Some progs ->
let progs_array = Js.array (Array.of_list (List.map Js.string progs)) in
Js.Unsafe.obj
[|
("_c", Js.Unsafe.inject (Js.string "start"));
("virtWidth", Js.Unsafe.inject config.virt_width);
("virtHeight", Js.Unsafe.inject config.virt_height);
("fboNum", Js.Unsafe.inject config.fbo_num);
("programs", Js.Unsafe.inject progs_array);
|]
| None ->
Js.Unsafe.obj
[|
("_c", Js.Unsafe.inject (Js.string "start"));
("virtWidth", Js.Unsafe.inject config.virt_width);
("virtHeight", Js.Unsafe.inject config.virt_height);
("fboNum", Js.Unsafe.inject config.fbo_num);
|]
let create_regl_program name program =
Js.Unsafe.obj
[|
("_c", Js.Unsafe.inject (Js.string "createGLProgram"));
("_n", Js.Unsafe.inject (Js.string name));
("proto", Js.Unsafe.inject (Regl_program.encode_program program));
|]
let config_regl config =
Js.Unsafe.obj
[|
("_c", Js.Unsafe.inject (Js.string "config"));
("config", Js.Unsafe.inject (encode_config config));
|]
let load_msdf_font name imgurl jsonurl =
Js.Unsafe.obj
[|
("_c", Js.Unsafe.inject (Js.string "loadFont"));
("_n", Js.Unsafe.inject (Js.string name));
("img", Js.Unsafe.inject (Js.string imgurl));
("json", Js.Unsafe.inject (Js.string jsonurl));
|]
let decode_recv_msg v =
let get_string_field path =
try Some (Js.to_string (Js.Unsafe.get v (Js.string path))) with _ -> None
in
let get_int_field path =
try
Some
(int_of_float (Js.float_of_number (Js.Unsafe.get v (Js.string path))))
with _ -> None
in
match get_string_field "_c" with
| Some "loadTexture" -> (
match
( get_int_field "response.width",
get_int_field "response.height",
get_string_field "response.texture" )
with
| Some w, Some h, Some txtname ->
Some (REGLTextureLoaded { name = txtname; width = w; height = h })
| _ -> None)
| Some "loadFont" -> (
match get_string_field "response.font" with
| Some name -> Some (REGLFontLoaded name)
| None -> None)
| Some "createGLProgram" -> (
match get_string_field "response._n" with
| Some name -> Some (REGLProgramCreated name)
| None -> None)
| _ -> None
let execCmd x =
let mlregl = Js.Unsafe.global##.MlREGL in
mlregl##execCmd x
type regl_input =
| Tick of float
| Event of Dom_html.event Js.t
| REGLRecvMsg of regl_recv_msg
type regl_output =
| LoadFont of string * string * string
| LoadTexture of string * string * texture_options option
| StartREGL of regl_start_config
| CreateREGLProgram of string * Regl_program.regl_program
| ConfigREGL of regl_config
let create_app
(init : Dom_html.canvasElement Js.t option -> Js.Unsafe.any -> 'a)
(update :
Dom_html.canvasElement Js.t option ->
'a ->
regl_input ->
'a * Regl_common.renderable * regl_output list) =
let canvas : Dom_html.canvasElement Js.t option ref = ref None in
let model : 'a option ref = ref None in
let update_model (input : regl_input) =
match !model with
| Some m ->
let m', rd, outputs = update !canvas m input in
model := Some m';
List.iter
(function
| LoadFont (name, imgurl, jsonurl) ->
execCmd (load_msdf_font name imgurl jsonurl)
| LoadTexture (name, url, topts) ->
execCmd (load_texture name url topts)
| StartREGL cfg -> execCmd (start_regl cfg)
| CreateREGLProgram (name, prog) ->
execCmd (create_regl_program name prog)
| ConfigREGL cfg -> execCmd (config_regl cfg))
outputs;
Regl_common.render rd
| None -> Js.Unsafe.inject Js.null
in
Js.export "MlApp"
(Js.Unsafe.obj
[|
("bind", Js.Unsafe.inject (fun c -> canvas := Some c));
("init", Js.Unsafe.inject (fun c -> model := Some (init !canvas c)));
("update", Js.Unsafe.inject (fun ts -> update_model (Tick ts)));
("event", Js.Unsafe.inject (fun ev -> update_model (Event ev)));
( "recvREGLCmd",
Js.Unsafe.inject (fun recvcmd ->
match decode_recv_msg recvcmd with
| Some msg -> update_model (REGLRecvMsg msg)
| None -> Js.Unsafe.inject Js.null) );
|])