notebook.community

Edit and run

Js_of_ocaml WebGL demo

Run with iocaml -js full <notebook>

This is the WebGL demo from js_of_ocaml. All data (3d model, shader scripts and html display elements) are embedded into the notebook.

To run it execute the following cell, then scroll to the bottom and execute the go() cell.





In [1]:



    


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 fetch_model name = 
    let s = Js.Opt.get (Dom_html.document##getElementById(string name))
        (fun () -> assert false)
    in
    match Dom_html.tagged s with
    | Dom_html.Div(s) -> return (read_model (to_string s##innerHTML))
    | _ -> assert false

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 () = (jsnew date_now ())##getTime() in
  let last_draw = ref (get_time ()) in
  let draw_times = Queue.create () in
  let rec f () =
    let t = (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 "monkeymodel" >>= start)
    (fun exn -> error "uncaught exception: %s" (Printexc.to_string exn)));
  _true

(*let _ = Dom_html.window##onload <- Dom_html.handler go*)



    


















    
Out[1]:

















    
Out[1]:

















    
Out[1]:







val error : ('a, unit, string, 'b) format4 -> 'a = <fun>











    
Out[1]:







val debug : ('a, unit, string, unit) format4 -> 'a = <fun>











    
Out[1]:







val alert : ('a, unit, string, 'b) format4 -> 'a = <fun>











    
Out[1]:







val check_error :
  < _NO_ERROR : < get : 'a96770fe7; .. > Js.gen_prop;
    getError : 'a96770fe7 Js.meth; .. >
  Js.t -> unit = <fun>











    
Out[1]:







val init_canvas :
  string -> Dom_html.canvasElement Js.t * WebGL.renderingContext Js.t = <fun>











    
Out[1]:







val load_shader :
  WebGL.renderingContext Js.t ->
  WebGL.shader Js.t -> Js.js_string Js.t -> unit = <fun>











    
Out[1]:







val create_program :
  WebGL.renderingContext Js.t ->
  Js.js_string Js.t -> Js.js_string Js.t -> WebGL.program Js.t = <fun>











    
Out[1]:







val get_source : string -> Js.js_string Js.t = <fun>











    
Out[1]:







val float32array : float array -> Typed_array.float32Array Js.t = <fun>











    
Out[1]:







val int16array : int array -> Typed_array.int16Array Js.t = <fun>











    
Out[1]:







module Proj3D :
  sig
    type t = float array
    val scale : float -> float -> float -> float array
    val translate : float -> float -> float -> float array
    val rotate_x : float -> float array
    val rotate_y : float -> float array
    val c : int -> int -> int
    val o : int -> int * int
    val mult : float array -> float array -> float array
    val array : float array -> Typed_array.float32Array Js.t
  end











    
Out[1]:







type line =
    V of (float * float * float)
  | VN of (float * float * float)
  | F of ((int * int) * (int * int) * (int * int))











    
Out[1]:







val line_regexp : Regexp.regexp = <abstr>











    
Out[1]:







val couple_regexp : Regexp.regexp = <abstr>











    
Out[1]:







val read_coord_couple : string -> (int * int) option = <fun>











    
Out[1]:







val read_line : string -> line option = <fun>











    
Out[1]:







val array_iter : ('a -> 'b) -> 'a #Js.js_array Js.t -> unit = <fun>











    
Out[1]:







val concat : 'a list array -> 'a array = <fun>











    
Out[1]:







val make_model :
  (float * float * float) array ->
  (float * float * float) array ->
  ((int * int) * (int * int) * (int * int)) array ->
  Typed_array.float32Array Js.t * Typed_array.float32Array Js.t = <fun>











    
Out[1]:







val read_model :
  string -> Typed_array.float32Array Js.t * Typed_array.float32Array Js.t =
  <fun>











    
Out[1]:







val fetch_model :
  string ->
  (Typed_array.float32Array Js.t * Typed_array.float32Array Js.t) Lwt.t =
  <fun>











    
Out[1]:







val pi : float = 3.14159265358979312











    
Out[1]:







val start :
  < buffer : Typed_array.arrayBuffer Js.t Js.readonly_prop;
    byteLength : int Js.readonly_prop; byteOffset : int Js.readonly_prop;
    length : < get : int; .. > Js.gen_prop; .. >
  Js.t * #Typed_array.arrayBufferView Js.t -> 'a Lwt.t = <fun>











    
Out[1]:







val go : 'a -> bool Js.t = <fun>


























Shader scripts are embedded in this cell


















The monkey model is embedded in this cell

















In [3]:



    


go ()



    


















    






program loaded
ready










    
Out[3]:







- : bool Js.t = <abstr>


























This cell embedded that canvas element to which we render




 frames per second













    


    

        

            

            

                Content source: ocamllabs/iocamljs
            

            
Similar notebooks:

            

            
                notebook.community |
                gallery |
                about