(* Js_of_ocaml example * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2012 Pierre Chambart * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) open Lwt open Js let error f = Printf.ksprintf (fun s -> Firebug.console##error (Js.string s); failwith s) f let debug f = Printf.ksprintf (fun s -> Firebug.console##log(Js.string s)) f let alert f = Printf.ksprintf (fun s -> Dom_html.window##alert(Js.string s); failwith s) f let check_error gl = if gl##getError() <> gl##_NO_ERROR then error "WebGL error" let init_canvas canvas_id = let canvas = Opt.get (Opt.bind ( Dom_html.document##getElementById(string canvas_id) ) Dom_html.CoerceTo.canvas) (fun () -> error "can't find canvas element %s" canvas_id) in let gl = Opt.get (try WebGL.getContext canvas with e -> null) (fun () -> alert "can't initialise webgl context") in canvas, gl let load_shader (gl:WebGL.renderingContext t) shader text = gl##shaderSource(shader,text); gl##compileShader(shader); if not (to_bool gl##getShaderParameter(shader, gl##_COMPILE_STATUS_)) then error "An error occurred compiling the shaders: \n%s\n%s" (to_string text) (to_string gl##getShaderInfoLog(shader)) let create_program (gl:WebGL.renderingContext t) vert_src frag_src = let vertexShader = gl##createShader(gl##_VERTEX_SHADER_) in let fragmentShader = gl##createShader(gl##_FRAGMENT_SHADER_) in load_shader gl vertexShader vert_src; load_shader gl fragmentShader frag_src; let prog = gl##createProgram() in gl##attachShader(prog,vertexShader); gl##attachShader(prog,fragmentShader); gl##linkProgram(prog); if not (to_bool gl##getProgramParameter(prog, gl##_LINK_STATUS_)) then error "Unable to link the shader program."; prog let get_source src_id = let script = Opt.get (Opt.bind ( Dom_html.document##getElementById(string src_id) ) Dom_html.CoerceTo.script) (fun () -> error "can't find script element %s" src_id) in script##text let float32array a = let array = jsnew Typed_array.float32Array(Array.length a) in Array.iteri (fun i v -> Typed_array.set array i v) a; array let int16array a = let array = jsnew Typed_array.int16Array(Array.length a) in Array.iteri (fun i v -> Typed_array.set array i v) a; array module Proj3D = struct type t = float array let scale x y z = [| x; 0.; 0.; 0.; 0.; y ; 0.; 0.; 0.; 0.; z ; 0.; 0.; 0.; 0.; 1.; |] let translate x y z = [| 1.; 0.; 0.; 0.; 0.; 1.; 0.; 0.; 0.; 0.; 1.; 0.; x ; y ; z ; 1.; |] let rotate_x t = [| 1.; 0.; 0.; 0.; 0.; cos t; sin t; 0.; 0.; -.sin t; cos t; 0.; 0.; 0.; 0.; 1.; |] let rotate_y t = [| cos t; 0.; -.sin t; 0.; 0.; 1.; 0.; 0.; sin t; 0.; cos t; 0.; 0.; 0.; 0.; 1.; |] let c i j = i * 4 + j let o i = i/4, i mod 4 let mult m1 m2 = let v p = let i,j = o p in m1.(c i 0) *. m2.(c 0 j) +. m1.(c i 1) *. m2.(c 1 j) +. m1.(c i 2) *. m2.(c 2 j) +. m1.(c i 3) *. m2.(c 3 j) in Array.init 16 v let array m = float32array m end type line = | V of (float * float * float) | VN of (float * float * float) | F of ((int*int) * (int*int) * (int*int)) let line_regexp = Regexp.regexp "(v|vn|f)\\ ([^\\ ]+)\\ ([^\\ ]+)\\ ([^\\ ]+)" let couple_regexp = Regexp.regexp "([0-9]+)//([0-9]+)" let read_coord_couple c = match Regexp.string_match couple_regexp c 0 with | None -> None | Some res -> match List.map (Regexp.matched_group res) [1;2] with | [Some v; Some vn] -> Some (int_of_string v,int_of_string vn) | _ -> None let read_line l = match Regexp.string_match line_regexp l 0 with | None -> None | Some res -> match List.map (Regexp.matched_group res) [1;2;3;4] with | [Some "v"; Some x; Some y; Some z] -> Some (V (float_of_string x, float_of_string y, float_of_string z)) | [Some "vn"; Some x; Some y; Some z] -> Some (VN (float_of_string x, float_of_string y, float_of_string z)) | [Some "f"; Some x; Some y; Some z] -> (match List.map read_coord_couple [x;y;z] with | [ Some x; Some y; Some z ] -> Some (F (x,y,z)) | r -> None) | _ -> None let array_iter f a = let rec aux i = match Optdef.to_option (array_get a i) with | None -> () | Some s -> f s; aux (i+1) in aux 0 let concat a = let length = Array.fold_left (fun len l -> len + List.length l) 0 a in let next = let pos = ref (-1) in let l = ref [] in let rec aux _ = match !l with | t::q -> l := q; t | [] -> incr pos; l := a.(!pos); aux 0 in aux in Array.init length next let make_model vertex norm face = let vertex' = Array.init (Array.length face) (fun i -> let ((av,an),(bv,bn),(cv,cn)) = face.(i) in let (a1,a2,a3) = vertex.(av-1) in let (b1,b2,b3) = vertex.(bv-1) in let (c1,c2,c3) = vertex.(cv-1) in [a1;a2;a3;b1;b2;b3;c1;c2;c3]) in let norm' = Array.init (Array.length face) (fun i -> let ((av,an),(bv,bn),(cv,cn)) = face.(i) in let (a1,a2,a3) = norm.(an-1) in let (b1,b2,b3) = norm.(bn-1) in let (c1,c2,c3) = norm.(cn-1) in [a1;a2;a3;b1;b2;b3;c1;c2;c3]) in let vertex = float32array (concat vertex') in let norm = float32array (concat norm') in vertex, norm let read_model s = let a = str_array ((string s)##split(string "\n")) in (Unsafe.coerce Dom_html.window)##arr <- a; let vertex = ref [] in let norm = ref [] in let face = ref [] in array_iter (fun s -> match read_line (to_string s) with | None -> () | Some (F (a,b,c)) -> face := (a,b,c)::!face | Some (V (a,b,c)) -> vertex := (a,b,c)::!vertex | Some (VN (a,b,c)) -> norm := (a,b,c)::!norm) a; make_model (Array.of_list (List.rev !vertex)) (Array.of_list (List.rev !norm)) (Array.of_list (List.rev !face)) let fetch_model s = XmlHttpRequest.perform_raw_url s >|= (fun frame -> read_model frame.XmlHttpRequest.content) let pi = 4. *. (atan 1.) let start (pos,norm) = let fps_text = Dom_html.document##createTextNode (Js.string "loading") in Opt.iter (Opt.bind ( Dom_html.document##getElementById(string "fps") ) Dom_html.CoerceTo.element) (fun span -> Dom.appendChild span fps_text); let canvas, gl = init_canvas "canvas" in let prog = create_program gl (get_source "vertex-shader") (get_source "fragment-shader") in gl##useProgram(prog); check_error gl; debug "program loaded"; gl##enable(gl##_DEPTH_TEST_); gl##depthFunc(gl##_LESS); let proj_loc = gl##getUniformLocation(prog, string "u_proj") in let lightPos_loc = gl##getUniformLocation(prog, string "u_lightPos") in let ambientLight_loc = gl##getUniformLocation(prog, string "u_ambientLight") in let lightPos = float32array [| 3.; 0.; -. 1. |] in let ambientLight = float32array [| 0.1; 0.1; 0.1 |] in gl##uniform3fv_typed(lightPos_loc, lightPos); gl##uniform3fv_typed(ambientLight_loc, ambientLight); let pos_attr = gl##getAttribLocation(prog, string "a_position") in gl##enableVertexAttribArray(pos_attr); let array_buffer = gl##createBuffer() in gl##bindBuffer(gl##_ARRAY_BUFFER_,array_buffer); gl##bufferData(gl##_ARRAY_BUFFER_,pos,gl##_STATIC_DRAW_); gl##vertexAttribPointer(pos_attr, 3, gl##_FLOAT, _false, 0, 0); let norm_attr = gl##getAttribLocation(prog, string "a_normal") in gl##enableVertexAttribArray(norm_attr); let norm_buffer = gl##createBuffer() in gl##bindBuffer(gl##_ARRAY_BUFFER_,norm_buffer); gl##bufferData(gl##_ARRAY_BUFFER_,norm,gl##_STATIC_DRAW_); gl##vertexAttribPointer(norm_attr, 3, gl##_FLOAT, _false, 0, 0); let mat = Proj3D.( mult (rotate_x (pi/.2.)) (mult (scale 0.5 0.5 0.5) (translate (0.) (0.) 0.))) in check_error gl; debug "ready"; let get_time () = to_float ((jsnew date_now ())##getTime()) in let last_draw = ref (get_time ()) in let draw_times = Queue.create () in let rec f () = let t = to_float (jsnew date_now ())##getTime() /. 1000. in let mat' = Proj3D.mult mat (Proj3D.rotate_y (1. *. t)) in gl##uniformMatrix4fv_typed(proj_loc, _false, Proj3D.array mat'); gl##clear(gl##_DEPTH_BUFFER_BIT_ lor gl##_COLOR_BUFFER_BIT_); gl##drawArrays(gl##_TRIANGLES, 0, pos##length / 3); check_error gl; let now = get_time () in Queue.push (now -. !last_draw) draw_times; last_draw := now; if Queue.length draw_times > 50 then ignore (Queue.pop draw_times); let fps = (1. /. ( Queue.fold (+.) 0. draw_times )) *. (Pervasives.float (Queue.length draw_times)) *. 1000. in fps_text##data <- string (Printf.sprintf "%.1f" fps); Lwt_js.sleep 0.02 >>= f in f () let go _ = ignore ( catch (fun () -> fetch_model "monkey.model" >>= start) (fun exn -> error "uncaught exception: %s" (Printexc.to_string exn))); _true let _ = Dom_html.window##onload <- Dom_html.handler go