(* 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 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 a =
  let vertex = ref [] in
  let norm = ref [] in
  let face = ref [] in
  Array.iter (fun s ->
    match read_line 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 http_get url =
  XmlHttpRequest.get url >>= fun r ->
  let cod = r.XmlHttpRequest.code in
  let msg = r.XmlHttpRequest.content in
  if cod = 0 || cod = 200
  then Lwt.return msg
  else fst (Lwt.wait ())

let getfile f =
  try
    Lwt.return (Sys_js.file_content f)
  with Not_found ->
    http_get f >|= (fun s -> s)

let fetch_model s =
  getfile s >|= (fun s ->
    let a = Regexp.split (Regexp.regexp "\n") s in
    read_model (Array.of_list a))

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);
  debug "init canvas";
  let canvas, gl = init_canvas "canvas" in
  debug "create program";
  let prog = create_program gl
    (get_source "vertex-shader")
    (get_source "fragment-shader") in
  debug "use program";
  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 (
  debug "fetching model";
  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