(* Js_of_ocaml example
 * http://www.ocsigen.org/js_of_ocaml/
 * Copyright (C) 2010 Jérôme Vouillon
 * Laboratoire PPS - CNRS Université Paris Diderot
 *
 * 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.
 *)

(*
- stop animation when not needed
  ==> not visible
  ==> no change (paused, follow rotation and no lighting)
- Options:
     ==> larger/smaller
- adaptative size
  ==> time 3 frames and take min
  ==> if fast, try larger image

IDEAS
=====
- saisons
- satellites: geostationnaires, différentes altitudes
  ==> trajectoire + mouvement du satellite
- affiche l'axe de rotation de la terre, la direction du soleil
- autres planètes

Sphere tessellation...
   http://sol.gfxile.net/sphere/index.html
   http://www.nihilogic.dk/labs/canvas3dtexture_0.2/

Stop animation when not visible!
===> use window.onfocus/onblur

http://visibleearth.nasa.gov/view_rec.php?id=2431
http://maps.jpl.nasa.gov/
*)

let width = 600
let height = width

let pi = 4. *. atan 1.

let obliquity = 23.5 *. pi /. 180.
let gamma = 2.
let dark = 0.2 ** gamma

(****)

let doc = Dom_html.document
let button_type = Js.string "button"
let button txt action =
  let b = Dom_html.createInput ~_type:button_type doc in
  b##value <- Js.string txt;
  b##onclick <- Dom_html.handler (fun _ -> action (); Js._true);
  b
let toggle_button txt1 txt2 action =
  let state = ref false in
  let txt1 = Js.string txt1 in
  let txt2 = Js.string txt2 in
  let b = Dom_html.createInput ~_type:button_type doc in
  b##value <- txt1;
  b##onclick <- Dom_html.handler
    (fun _ ->
       state := not !state;
       b##value <- if !state then txt2 else txt1;
       action !state;
       Js._true);
  b
let checkbox txt checked action =
  let b = Dom_html.createInput ~_type:(Js.string "checkbox") doc in
  b##checked <- Js.bool checked;
  b##onclick <-
    Dom_html.handler (fun _ -> action (Js.to_bool b##checked); Js._true);
  let lab = Dom_html.createLabel doc in
  Dom.appendChild lab b;
  Dom.appendChild lab (doc##createTextNode (Js.string txt));
  lab

let radio txt name checked action =
  let b =
    Dom_html.createInput
      ~name:(Js.string name) ~_type:(Js.string "radio") doc in
  b##checked <- Js.bool checked;
  b##onclick <-
    Dom_html.handler (fun _ -> action (); Js._true);
  let lab = Dom_html.createLabel doc in
  Dom.appendChild lab b;
  Dom.appendChild lab (doc##createTextNode (Js.string txt));
  lab

(****)

type vertex = { x : float; y : float; z : float }

let vertex x y z = { x = x; y = y; z = z }

type matrix = { r1 : vertex; r2 : vertex; r3 : vertex }

let vect {x = x1; y = y1; z = z1} {x = x2; y = y2; z = z2} =
  {x = x2 -. x1; y = y2 -. y1; z = z2 -. z1}

let cross_product {x = x1; y = y1; z = z1} {x = x2; y = y2; z = z2} =
  {x = y1 *. z2 -. y2 *. z1;
   y = z1 *. x2 -. z2 *. x1;
   z = x1 *. y2 -. x2 *. y1}

let dot_product {x = x1; y = y1; z = z1} {x = x2; y = y2; z = z2} =
  x1 *. x2 +. y1 *. y2 +. z1 *. z2

let matrix_vect_mul m {x = x; y = y; z = z} =
  let {r1 = r1; r2 = r2; r3 = r3} = m in
  let x' = x *. r1.x +. y *. r1.y +. z *. r1.z in
  let y' = x *. r2.x +. y *. r2.y +. z *. r2.z in
  let z' = x *. r3.x +. y *. r3.y +. z *. r3.z in
  {x = x'; y = y'; z = z'}

let matrix_transp m =
  let {r1 = r1; r2 = r2; r3 = r3} = m in
  { r1 = { x = r1.x; y = r2.x; z = r3.x };
    r2 = { x = r1.y; y = r2.y; z = r3.y };
    r3 = { x = r1.z; y = r2.z; z = r3.z } }

let matrix_mul m m' =
  let m' = matrix_transp m' in
  { r1 = matrix_vect_mul m' m.r1;
    r2 = matrix_vect_mul m' m.r2;
    r3 = matrix_vect_mul m' m.r3 }

let normalize v =
  let { x = x; y = y; z = z } = v in
  let r = sqrt (x *. x +. y *. y +. z *. z) in
  { x = x /. r; y = y /. r; z = z /. r }

let xz_rotation phi =
  let cos_phi = cos phi in
  let sin_phi = sin phi in
  { r1 = vertex cos_phi 0. sin_phi;
    r2 = vertex 0.      1.  0.;
    r3 = vertex (-. sin_phi) 0. cos_phi }

let xy_rotation phi =
  let cos_phi = cos phi in
  let sin_phi = sin phi in
  { r1 = vertex     cos_phi  sin_phi 0.;
    r2 = vertex (-. sin_phi) cos_phi 0.;
    r3 = vertex          0.       0. 1. }

let yz_rotation phi =
  let cos_phi = cos phi in
  let sin_phi = sin phi in
  { r1 = vertex 1. 0. 0.;
    r2 = vertex 0. cos_phi sin_phi;
    r3 = vertex 0. (-. sin_phi) cos_phi }

let matrix_identity = xz_rotation 0.

(* Assumes that m is orthogonal *)
let rotate_normal m v = matrix_vect_mul (matrix_transp m) v

(****)

type face = { v1 : int; v2 : int; v3 : int }

let face v1 v2 v3 = { v1 = v1; v2 = v2; v3 = v3 };

type t = { vertices : vertex array; faces : face array }

let rotate_object m o =
  {o with vertices = Array.map (fun v -> matrix_vect_mul m v) o.vertices}

let octahedron =
  { vertices =
      [| vertex   0.   0.   1.;
         vertex   1.   0.   0.;
         vertex   0.   1.   0.;
         vertex (-1.)  0.   0.;
         vertex   0. (-1.)  0.;
         vertex   0.   0. (-1.) |];
    faces =
      [| face 0 1 2;
         face 0 2 3;
         face 0 3 4;
         face 0 4 1;
         face 1 5 2;
         face 1 4 5;
         face 3 5 4;
         face 3 2 5 |] }

(****)

(* 0 <= phi < 2pi *)
(* -pi/2 <= theta <= pi/2 *)
let tesselate_sphere p_div t_div =
  let p_delta = 2. *. pi /. float p_div in
  let t_delta = pi /. float t_div in
  let t_offset = (pi -. t_delta) /. 2. in
  let n = t_div * p_div in
  let vertices = Array.make (n + 2) (vertex 0. 0. 0.) in
  let faces = Array.make (n * 2) (face 0 0 0) in
  let north = n and south = n + 1 in
  vertices.(north) <- vertex 0. (-1.) 0.;
  vertices.(south) <- vertex 0. 1. 0.;
  for i = 0 to p_div - 1 do
    for j = 0 to t_div - 1 do
      let phi = float i *. p_delta in
      let theta = float j *. t_delta -. t_offset in
      let x = cos phi *. cos theta in
      let y = sin theta in
      let z = sin phi *. cos theta in
      let k = i * t_div + j in
      vertices.(k) <- vertex x y z;
      if j = 0 then begin
        faces.(2 * k) <- face north k ((k + t_div) mod n);
        faces.(2 * k + 1) <-
          face south ((k + 2 * t_div - 1) mod n) (k + t_div - 1);
      end else begin
        faces.(2 * k) <- face k ((k + t_div) mod n) (k - 1);
        faces.(2 * k + 1) <-
          face (k - 1) ((k + t_div) mod n) ((k + t_div - 1) mod n)
      end
    done
  done;
  { vertices = vertices; faces = faces }

(****)

let divide all o =
  let vn =
    if all then Array.length o.vertices + Array.length o.faces * 3 / 2 else
    Array.length o.vertices + 16
  in
  let vertices = Array.make vn (vertex 0. 0. 0.) in
  let j = ref (Array.length o.vertices) in
  Array.blit o.vertices 0 vertices 0 !j;
  let fn =
    if all then 4 * Array.length o.faces else Array.length o.faces + 24 in
  let faces = Array.make fn (face 0 0 0) in
  let midpoints = Hashtbl.create 17 in
  let midpoint v1 v2 =
    let p = if v1 < v2 then (v1, v2) else (v2, v1) in
    try
      Hashtbl.find midpoints p
    with Not_found ->
      let v1 = o.vertices.(v1) in
      let v2 = o.vertices.(v2) in
      let v =
        { x = (v1.x +. v2.x) /. 2.;
          y = (v1.y +. v2.y) /. 2.;
          z = (v1.z +. v2.z) /. 2. }
      in
      let v =
        if all || abs_float v1.y = 1. || abs_float v2.y = 1. then
          normalize v
        else
          v
      in
      let res = !j in
assert (res < Array.length vertices);
      vertices.(res) <- v;
      Hashtbl.add midpoints p res;
      incr j; res
  in
  let k = ref 0 in
  for i = 0 to Array.length o.faces - 1 do
    let { v1 = v1; v2 = v2; v3 = v3 } = o.faces.(i) in
    if
      all ||
      abs_float o.vertices.(v1).y = 1. || abs_float o.vertices.(v2).y = 1. ||
      abs_float o.vertices.(v3).y = 1.
    then begin
      let w1 = midpoint v1 v2 in
      let w2 = midpoint v2 v3 in
      let w3 = midpoint v3 v1 in
      faces.(!k) <- { v1 = v1; v2 = w1; v3 = w3 };
      faces.(!k + 1) <- { v1 = w1; v2 = v2; v3 = w2 };
      faces.(!k + 2) <- { v1 = w3; v2 = w2; v3 = v3 };
      faces.(!k + 3) <- { v1 = w1; v2 = w2; v3 = w3 };
      k := !k + 4
    end else begin
      faces.(!k) <- o.faces.(i);
      incr k
    end
  done;
  assert (!j = Array.length vertices);
  assert (!k = Array.length faces);
  { vertices = vertices; faces = faces }

(****)

module Html = Dom_html

let create_canvas w h =
  let c = Html.createCanvas Html.document in
  c##width <- w; c##height <- h; c

(****)

let (>>=) = Lwt.bind

let lwt_wrap f =
  let (t, w) = Lwt.task () in
  let cont x = Lwt.wakeup w x in
  f cont;
  t

(****)

let load_image src =
  let img = Html.createImg Html.document in
  lwt_wrap
    (fun c ->
       img##onload <- Html.handler (fun _ -> c (); Js._false); img##src <- src)
    >>= fun () ->
  Lwt.return img

(****)

let shadow texture =
  let w = texture##width in
  let h = texture##height in
  let canvas = create_canvas w h in
  let ctx = canvas##getContext (Html._2d_) in
  let (w, h) = (w / 8, h / 8) in
  let img = ctx##getImageData (0., 0., float w, float h) in
  let data = img##data in
  let inv_gamma  = 1. /. gamma in
  let update_shadow obliquity =
    let cos_obl = cos obliquity in
    let sin_obl = -. sin obliquity in
    for j = 0 to h - 1 do
      for i = 0 to w / 2 - 1 do
        let k = truncate (4. *. (float i +. float j *. float w)) in
        let k' =
          truncate (4. *. (float w -. float i +. float j *. float w -. 1.)) in
        let theta = (float j /. float h -. 0.5) *. pi in
        let phi = (float i /. float w) *. 2. *. pi in
        let x = cos phi *. cos theta in
        let y = sin theta in
  (*
        let z = sin phi *. cos theta in
  *)
        let (x, y) =
          (x *. cos_obl +. y *. sin_obl,
           -. x *. sin_obl +. y *. cos_obl)
        in
        let c =
          if x > 0. then
            dark
          else
            dark -. x *. (1. -. dark) *. 1.2
        in
        let c = if c <= 1. then c else 1. in
        let c = 255 - truncate (255.99 *. c ** inv_gamma) in
        Html.pixel_set data (k + 3) c;
        Html.pixel_set data (k' + 3) c
      done
    done;
    ctx##putImageData (img, 0., 0.);
    ctx##globalCompositeOperation <- Js.string "copy";
    ctx##save ();
    ctx##scale (8. *. float (w + 2) /. float w, 8. *. float (h + 2) /. float h);
    ctx##translate (-1., -1.);
    ctx##drawImage_fromCanvas (canvas, 0., 0.);
    ctx##restore ()
  in
  update_shadow obliquity;

  let w = texture##width in
  let h = texture##height in
  let canvas' = create_canvas w h in
  let ctx' = canvas'##getContext (Html._2d_) in

  let no_lighting = ref false in

  let update_texture lighting phi =
    if lighting then begin
      no_lighting := false;
      let phi = mod_float phi (2. *. pi) in
      ctx'##drawImage (texture, 0., 0.);
      let i = truncate (mod_float ((2. *. pi -. phi) *. float w /. 2. /. pi)
                          (float w)) in
      ctx'##drawImage_fromCanvas (canvas, float i, 0.);
      ctx'##drawImage_fromCanvas (canvas, float i -. float w, 0.)
    end else if not !no_lighting then begin
      ctx'##drawImage (texture, 0., 0.);
      no_lighting := true
    end
  in
(*
  Dom.appendChild Html.document##body canvas';
*)
  (canvas', update_shadow, update_texture)

(****)

let to_uv tw th {x = x; y = y; z = z} =
  let cst1 = (tw /. 2. -. 0.99) /. pi in
  let cst2 = th /. 2. in
  let cst3 = (th -. 0.99) /. pi in
  let u =
    mod_float (float (truncate (tw -. atan2 z x *. cst1))) tw in
  let v = float (truncate (cst2 +. asin y *. cst3)) in
assert (0. <= u);
assert (u < tw);
assert (0. <= v);
assert (v < th);
  (u, v)

let min (u : float) v = if u < v then u else v
let max (u : float) v = if u < v then v else u

let precompute_mapping_info tw th uv f =
  let { v1 = v1; v2 = v2; v3 = v3 } = f in
let (u1, v1) = uv.(v1) in
let (u2, v2) = uv.(v2) in
let (u3, v3) = uv.(v3) in
let mid = tw /. 2. in

let u1 = if u1 = 0. && (u2 > mid || u3 > mid) then tw -. 2. else u1 in
let u2 = if u2 = 0. && (u1 > mid || u3 > mid) then tw -. 2. else u2 in
let u3 = if u3 = 0. && (u2 > mid || u1 > mid) then tw -. 2. else u3 in

let mth = th -. 2. in
let u1 = if v1 = 0. || v1 >= mth then (u2 +. u3) /. 2. else u1 in
let u2 = if v2 = 0. || v2 >= mth then (u1 +. u3) /. 2. else u2 in
let u3 = if v3 = 0. || v3 >= mth then (u2 +. u1) /. 2. else u3 in

let u1 = max 1. u1 in
let u2 = max 1. u2 in
let u3 = max 1. u3 in

let v1 = max 1. v1 in
let v2 = max 1. v2 in
let v3 = max 1. v3 in

let du2 = u2 -. u1 in
let du3 = u3 -. u1 in
let dv2 = v2 -. v1 in
let dv3 = v3 -. v1 in

let su = dv2*.du3-.dv3*.du2 in
let sv = du2*.dv3-.du3*.dv2 in
let dv3 = dv3 /. sv in
let dv2 = dv2 /. sv in
let du3 = du3 /. su in
let du2 = du2 /. su in

let u = max 0. (min u1 (min u2 u3) -. 4.) in
let v = max 0. (min v1 (min v2 v3) -. 4.) in
let u' = min tw (max u1 (max u2 u3) +. 4.) in
let v' = min th (max v1 (max v2 v3) +. 4.) in
let du = u' -. u in
let dv = v' -. v in
(u1, v1, du2, dv2, du3, dv3, u, v, du, dv)

let draw ctx img shd o uv normals face_info dir =
  Array.iteri
    (fun i { v1 = v1; v2 = v2; v3 = v3 } ->
       let {x = x1; y = y1; z = z1} = o.vertices.(v1) in
       let {x = x2; y = y2; z = z2} = o.vertices.(v2) in
       let {x = x3; y = y3; z = z3} = o.vertices.(v3) in

       if dot_product normals.(i) dir >= 0. then begin
         ctx##beginPath ();
         ctx##moveTo (x1, y1);
         ctx##lineTo (x2, y2);
         ctx##lineTo (x3, y3);
         ctx##closePath ();
         ctx##save();
         ctx##clip ();

let (u1, v1, du2, dv2, du3, dv3, u, v, du, dv) = face_info.(i) in
let dx2 = x2 -. x1 in
let dx3 = x3 -. x1 in
let dy2 = y2 -. y1 in
let dy3 = y3 -. y1 in
let a = dx2*.dv3-.dx3*.dv2 in
let b = dx2*.du3-.dx3*.du2 in
let c = x1 -. a *. u1 -. b *. v1 in
let d = dy2*.dv3-.dy3*.dv2 in
let e = dy2*.du3-.dy3*.du2 in
let f = y1 -. d *. u1 -. e *. v1 in
ctx##transform (a, d, b, e, c, f);
(*
let (u1, v1) = uv.(v1) in
let (u2, v2) = uv.(v2) in
let (u3, v3) = uv.(v3) in
let mid = tw /. 2. in

let u1 = if u1 = 0. && (u2 > mid || u3 > mid) then tw -. 2. else u1 in
let u2 = if u2 = 0. && (u1 > mid || u3 > mid) then tw -. 2. else u2 in
let u3 = if u3 = 0. && (u2 > mid || u1 > mid) then tw -. 2. else u3 in

let mth = th -. 2. in
let u1 = if v1 = 0. || v1 >= mth then (u2 +. u3) /. 2. else u1 in
let u2 = if v2 = 0. || v2 >= mth then (u1 +. u3) /. 2. else u2 in
let u3 = if v3 = 0. || v3 >= mth then (u2 +. u1) /. 2. else u3 in

let u1 = max 1. u1 in
let u2 = max 1. u2 in
let u3 = max 1. u3 in

let v1 = max 1. v1 in
let v2 = max 1. v2 in
let v3 = max 1. v3 in

let du2 = u2 -. u1 in
let du3 = u3 -. u1 in
let dv2 = v2 -. v1 in
let dv3 = v3 -. v1 in
let dx2 = x2 -. x1 in
let dx3 = x3 -. x1 in
let dy2 = y2 -. y1 in
let dy3 = y3 -. y1 in
let a = (dx2*.dv3-.dx3*.dv2) /. (du2*.dv3-.du3*.dv2) in
let b = (dx2*.du3-.dx3*.du2) /. (dv2*.du3-.dv3*.du2) in
let c = x1 -. a *. u1 -. b *. v1 in
let d = (dy2*.dv3-.dy3*.dv2) /. (du2*.dv3-.du3*.dv2) in
let e = (dy2*.du3-.dy3*.du2) /. (dv2*.du3-.dv3*.du2) in
let f = y1 -. d *. u1 -. e *. v1 in

ctx##transform (a, d, b, e, c, f);
let u = max 0. (min u1 (min u2 u3) -. 4.) in
let v = max 0. (min v1 (min v2 v3) -. 4.) in

let u' = min tw (max u1 (max u2 u3) +. 4.) in
let v' = min th (max v1 (max v2 v3) +. 4.) in
let du = u' -. u in
let dv = v' -. v in
*)
ctx##drawImage_fullFromCanvas (shd, u, v, du, dv, u, v, du, dv);
ctx##restore()
       end
    )
    o.faces

let (>>) x f = f x


(*
let o = tesselate_sphere 8 6
let o = octahedron >> divide true >> divide true >> divide false
*)
let o = tesselate_sphere 12 8
(*
let o = octahedron >> divide true >> divide true >> divide true
*)
let v = {x = 0.; y = 0.; z = 1.}

let texture = Js.string "black.jpg"
let texture = Js.string "../planet/land_ocean_ice_cloud_2048.jpg"
let texture = Js.string "../planet/texture.jpg"

let start _ =
  Lwt.ignore_result
    (load_image texture >>= fun texture ->
  let (shd, update_shadow, update_texture) = shadow texture in

  let canvas = create_canvas width height in
  let canvas' = create_canvas width height in
  Dom.appendChild Html.document##body canvas;
  let ctx = canvas##getContext (Html._2d_) in
  let ctx' = canvas'##getContext (Html._2d_) in
  let r = float width /. 2. in
  let tw = float texture##width in
  let th = float texture##height in
  let uv = Array.map (fun v -> to_uv tw th v) o.vertices in
  let normals =
    Array.map
      (fun {v1 = v1; v2 = v2; v3 = v3} ->
         let v1 = o.vertices.(v1) in
         let v2 = o.vertices.(v2) in
         let v3 = o.vertices.(v3) in
         cross_product (vect v1 v2) (vect v1 v3))
      o.faces
  in
  let face_info =
    Array.map (fun f -> precompute_mapping_info tw th uv f) o.faces in

  let paused = ref false in
  let follow = ref false in
  let lighting = ref true in
  let clipped = ref true in

  let obl = ref obliquity in
  let m_obliq = ref (xy_rotation (-.obliquity)) in
  let m = ref matrix_identity in
  let phi_rot = ref 0. in

  let rateText = doc##createTextNode (Js.string "") in
  let add = Dom.appendChild in
  let ctrl = Html.createDiv doc in
  ctrl##className <- Js.string "controls";
  let d = Html.createDiv doc in
  add d (doc##createTextNode (Js.string "Click and drag mouse to rotate."));
  add ctrl d;
  let form = Html.createDiv doc in
  let br () = Html.createBr doc in
  begin
    add form (toggle_button "Pause" "Resume" (fun p -> paused := p));
    add form (br ());
    add form (toggle_button "Follow rotation" "Fixed position"
                (fun f -> follow := f));
    add form (br ());
    add form (button "Reset orientation"
                (fun () -> m := matrix_identity; phi_rot := 0.;
                           m_obliq := xy_rotation (-. !obl)));
    add form (br ());
    let lab = Html.createLabel doc in
    add lab (doc##createTextNode (Js.string "Date:"));
    let s = Html.createSelect doc in
    List.iter
      (fun txt ->
         let o = Html.createOption doc in
         add o (doc##createTextNode (Js.string txt));
         s##add (o, Js.null))
      ["December solstice"; "Equinox"; "June solstice"];
    s##onchange <-
      Html.handler
      (fun _ ->
         let o =
           match s##selectedIndex with
               0 -> obliquity
             | 1 -> 0.
             | _ -> -. obliquity
         in
         update_shadow o; obl := o; (*m_obliq := xy_rotation (-. o);*)
         Js._true);
    add lab s;
    add form lab;
  end;
  Dom.appendChild ctrl form;

  let form = Html.createDiv doc in
  begin
    add form (checkbox "Lighting" true (fun l -> lighting := l));
    add form (br ());
    add form (checkbox "Clip" true (fun l -> clipped := l));
    add form (br ());
    add form (doc##createTextNode (Js.string "Frames per second: "));
    add form rateText
  end;
  add ctrl form;
  add (doc##body) ctrl;
  let p = Html.createP doc in
  p##innerHTML <- Js.string
    "Credit: <a href='http://visibleearth.nasa.gov/'>Visual Earth</a>, Nasa";
  add (doc##body) p;

  let mx = ref 0 in
  let my = ref 0 in
  canvas##onmousedown <- Dom_html.handler
    (fun ev ->
       mx := ev##clientX; my := ev##clientY;
       let c1 =
         Html.addEventListener Html.document Html.Event.mousemove
           (Dom_html.handler
              (fun ev ->
                 let x = ev##clientX and y = ev##clientY in
                 let dx = x - !mx and dy = y - !my in
                 if dy != 0 then
                   m := matrix_mul
                          (yz_rotation (2. *. float dy /. float width)) !m;
                 if dx != 0 then
                   m := matrix_mul
                          (xz_rotation (2. *. float dx /. float width)) !m;
                 mx := x; my := y;
                 Js._true))
           Js._true
       in
       let c2 = ref Js.null in
       c2 := Js.some
         (Html.addEventListener Html.document Html.Event.mouseup
            (Dom_html.handler
               (fun _ ->
                  Html.removeEventListener c1;
                  Js.Opt.iter !c2 Html.removeEventListener;
                  Js._true))
            Js._true);
       Js._false);
  let ti = ref ((jsnew Js.date_now ())##getTime()) in
  let fps = ref 0. in

  let rec loop t phi =
    let rotation = xz_rotation (phi -. !phi_rot) in
    update_texture !lighting phi;
    let m = matrix_mul !m (matrix_mul !m_obliq rotation) in
    let o' = rotate_object m o in
    let v' = rotate_normal m v in

    ctx'##clearRect (0., 0., float width, float height);
    ctx'##save ();
    if !clipped then begin
      ctx'##beginPath();
      ctx'##arc(r, r, r *. 0.95, 0., -. 2. *. pi, Js._true);
      ctx'##clip()
    end;

    ctx'##setTransform (r -. 2., 0., 0., r -. 2., r, r);
    ctx'##globalCompositeOperation <- Js.string "lighter";
    draw ctx' texture shd o' uv normals face_info v';
    ctx'##restore ();

    ctx##globalCompositeOperation <- Js.string "copy";
    ctx##drawImage_fromCanvas (canvas', 0., 0.);
    begin try ignore (ctx##getImageData (0., 0., 1., 1.)) with _ -> () end;
    let t' = (jsnew Js.date_now ())##getTime() in
    fps :=
      (let hz = 1000. /. (t' -. !ti) in
       if !fps = 0. then hz else 0.9 *. !fps +. 0.1 *. hz);
    rateText##data <- Js.string (Printf.sprintf "% 2.f" !fps);
    ti := t';
    Lwt_js.sleep 0.01 >>= fun () ->
    let t' = (jsnew Js.date_now ())##getTime() in
    let dt = t' -. t in
    let dt = if dt < 0. then 0. else if dt > 1000. then 0. else dt in
    let angle = 2. *. pi *. dt /. 1000. /. 10. in
(*
if true then Lwt.return () else
*)
    if not !paused && !follow then phi_rot := !phi_rot +. angle;
    loop t'
      (if !paused then phi else phi +. angle)
  in
  loop ((jsnew Js.date_now ())##getTime()) 0.
); Js._false

let _ =
Html.window##onload <- Html.handler start