(* 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.
 *)

(*
- check compatibility + wait page

- files to load set in index.html
  ==> tree.txt, icon directory, image_info.json, image directories

- validation tools

- we should stop updating the canvas when it is not visible
  (opaque overlay)

- do not cache images forever (just keep a list of recently used images)
  ==> keep images used last + twice as many / minimum 200 ?

- spinner: draw it on a canvas
  (===> large canvas...)

- webgl?

- swap image once loaded instead of putting it over the canvas (?)

- récupérer le nom des animaux?
  ==> overlay mechanism:
        save what is below, display overlay; restore when moved

- can we have fast shadows? ==> precompute the shadows in a canvas?
- should we have half size images for better rendering???
  (might make it possible fast shadows?)

- support for touch events
- limit how far we can go

- use history to save current location and random seed

- get all image sizes so that we can size precisely images before
  they are all loaded

==============

- find point closest to center; start drawing from it; stop below a
  given threshold
- speed-up rendering by traversing the tree and stopping when the
  edge length becomes below some thresold

===============

- preferred diameter of each node
  spring-like forces around this diameter
  repulsive forces:
    exponential when below the preferred diameter
    decrease exponentially
  http://en.wikipedia.org/wiki/Hyperbolic_geometry#Circles.2C_spheres_and_balls

- importante répulsion quand trop près!
    ==> surtout pour feuilles!
- cap the acceleration

- metric tree/vp-tree?
  r trees / kd trees
*)

(* List of icons to be prefetched *)
let icons =
  ["commons-38.png"; "wikipedia-38.png"; "info-38.png";
   "meeting-point-38.png"; "globe-38.png"; "ocsigen-powered.png"]

let icon nm = Js.string ("icons/" ^ nm)

let tree_color = Js.string "#794c0d"
(*
let outside_color = Js.string (*"#3d2606"*) "#1e1303"
let outside_color = Js.string (*"#0c1a0d"*) "#070718"
*)

let option var =
  Js.Optdef.get var (fun () -> Js.Unsafe.coerce (jsnew Js.array_empty ()))

class type style = object
  method border : float Js.optdef Js.readonly_prop
  method padding : float Js.optdef Js.readonly_prop
  method backgroundColor : Js.js_string Js.t Js.optdef Js.readonly_prop
  method boundaryColor : Js.js_string Js.t Js.optdef Js.readonly_prop
  method treeColor : Js.js_string Js.t Js.optdef Js.readonly_prop
  method nodeColor : Js.js_string Js.t Js.optdef Js.readonly_prop
  method nodeBackgroundColor : Js.js_string Js.t Js.optdef Js.readonly_prop
  method nodeFont : Js.js_string Js.t Js.optdef Js.readonly_prop
  method buttonColor : Js.js_string Js.t Js.optdef Js.readonly_prop
end

let style : style Js.t = option (Js.Unsafe.global##hyp_style)

class type messages = object
  method info : Js.js_string Js.t Js.optdef Js.readonly_prop
  method recenter : Js.js_string Js.t Js.optdef Js.readonly_prop
  method noRef : Js.js_string Js.t Js.optdef Js.readonly_prop
  method close : Js.js_string Js.t Js.optdef Js.readonly_prop
  method wikimediaCommons : Js.js_string Js.t Js.optdef Js.readonly_prop
  method language : Js.js_string Js.t Js.optdef Js.readonly_prop
  method noRef : Js.js_string Js.t Js.optdef Js.readonly_prop
  method languages : Js.js_string Js.t Js.optdef Js.readonly_prop
  method ok : Js.js_string Js.t Js.optdef Js.readonly_prop
end

(*
let messages : messages Js.t = option (Js.Unsafe.variable "window.hyp_msgs")
*)

let opt_style v default = Js.Optdef.get v (fun () -> default)

(**** Complex numbers ****)

type c = { x : float; y : float }

let one = { x= 1.; y = 0. }

let zero = { x= 0.; y = 0. }

(* Scalar operations *)

let sdiv z s = { x = z.x /. s; y = z.y /. s }

let smul s z = { x = s *. z.x; y = s *. z.y }

(* Norm *)

let sq_norm c = c.x *. c.x +. c.y *. c.y

let norm c = sqrt (sq_norm c)

let normalize c = sdiv c (norm c)

(* Conjugate and negation *)

let conj z = { x = z.x; y = -. z.y }

let neg z = { x = -. z.x; y = -. z.y }

(* Addition, multiplication and division *)

let add z t = { x = z.x +. t.x; y = z.y +. t.y }

let sub z t = { x = z.x -. t.x; y = z.y -. t.y }

let sq_norm_sub z t =
  let x = z.x -. t.x in let y = z.y -. t.y in x *. x +. y *. y

let mul z t =
  { x = z.x *. t.x -. z.y *. t.y;
    y = z.x *. t.y +. z.y *. t.x }

let add_mul a z b =
  { x = a.x *. z.x -. a.y *. z.y +. b.x;
    y = a.x *. z.y +. a.y *. z.x +. b.y }

let div z t = sdiv (mul z (conj t)) (sq_norm t)
let div z t =
  let n = sq_norm t in
  { x = (z.x *. t.x +. z.y *. t.y) /. n;
    y = (z.y *. t.x -. z.x *. t.y) /. n }

(* Möbius transformation, hyperbolic transformation *)

(* (a.z + b) / (c.z + d) *)
let transf a b c d z = div (add_mul a z b) (add_mul c z d)

(* (t.z + p) / (conj p.z + 1) *)
let hyp_transf (p, t) =
  let a = t in
  let b = p in
  let c = mul (conj p) t in
  let d = one in
  fun z -> transf a b c d z

let hyp_transf_vect (p, t) v v' =
  let a = t in
  let b = p in
  let c = mul (conj p) t in
  let d = one in
  for i = 0 to Array.length v - 1 do
    v'.(i) <- transf a b c d v.(i)
  done

(* (z + p) / (conj p.z + 1) *)
let transl p = hyp_transf (p, one)

let compose (p1, t1) (p2, t2) =
  let t2p1 = mul t2 p1 in
  let den = add (mul t2p1 (conj p2)) one in
  (div (add t2p1 p2) den,
   normalize (mul (mul t1 t2) (div (conj den) den)))

(* Transformation from z0 to z1:
   z1 = (z0 + p) / (conj p.z0 + 1)
   ==> p = (z1.z0.conj (z1 - z0) + z1 - z0) / (1 - |z1.z0|^2) *)
let compute_translation z0 z1 =
  let dz = sub z1 z0 in
  let z0z1 = mul z0 z1 in
  sdiv (add (mul z0z1 (conj dz)) dz) (1. -. sq_norm z0z1)

(******)

let (>>=) = Lwt.bind

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

(******)

module Html = Dom_html

let json : < parse : Js.js_string Js.t -> 'a> Js.t = Js.Unsafe.variable "JSON"

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

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 create_canvas w h =
  let d = Html.window##document in
  let c = Html.createCanvas d in
  c##width <- w;
  c##height <- h;
  c

let debug_widget =
  let d = Html.document in
  let w = Html.createDiv d in
  w##style##position <- Js.string "absolute";
  w##style##bottom <- Js.string "0";
  w##style##left <- Js.string "0";
  w##style##lineHeight <- Js.string "0.9em";
  w

let debug_msg s = ()(*
  let d = Html.document in
  Dom.appendChild d##body debug_widget;
  let p = Html.createP d in
  p##innerHTML <- Js.string s;
  Dom.appendChild debug_widget p
                    *)

let handle_drag element move stop click =
  let fuzz = 4 in
  element##onmousedown <- Html.handler
    (fun ev ->
       let x0 = ev##clientX and y0 = ev##clientY in
(*
debug_msg (Format.sprintf "Mouse down %d %d" x0 y0);
*)
       let started = ref false in
       let c1 =
         Html.addEventListener Html.document Html.Event.mousemove
           (Html.handler
              (fun ev ->
                 let x = ev##clientX and y = ev##clientY in
(*
debug_msg (Format.sprintf "Mouse move %d %d %d %d" x0 y0 x y);
*)
                 if
                   not !started && (abs (x - x0) > fuzz || abs (y - y0) > fuzz)
                 then begin
                   started := true;
                   element##style##cursor <- Js.string "move"
                 end;
                 if !started then move x0 y0 x y;
                 Html.stopPropagation ev;
                 Js._true))
           Js._true
       in
       let c2 = ref Js.null in
       c2 := Js.some
         (Html.addEventListener Html.document Html.Event.mouseup
            (Html.handler
               (fun ev ->
(*
debug_msg (Format.sprintf "Mouse up %d %d %d %d" x0 y0 ev##clientX ev##clientY);
*)
                  Html.removeEventListener c1;
                  Js.Opt.iter !c2 Html.removeEventListener;
                  if !started then begin
                    element##style##cursor <- Js.string "";
                    stop ev##clientX ev##clientY
                  end else
                    click ev##clientX ev##clientY;
                  Js._true))
            Js._true);
       Js._true)

let handle_touch_events element move stop cancel click =
  let fuzz = 4 in
  ignore (Html.addEventListener element Html.Event.touchstart
    (Html.handler (fun ev ->
       Js.Optdef.iter (ev##changedTouches##item(0)) (fun touch ->
       let id = touch##identifier in
       let x0 = touch##clientX and y0 = touch##clientY in
(*
debug_msg (Format.sprintf "Touch start %d %d" x0 y0);
*)
       let started = ref false in
       let c1 =
         Html.addEventListener Html.document Html.Event.touchmove
           (Html.handler
              (fun ev ->
                 for i = 0 to ev##changedTouches##length - 1 do
                   Js.Optdef.iter (ev##changedTouches##item(i)) (fun touch ->
                   if touch##identifier = id then begin
                     let x = touch##clientX and y = touch##clientY in
(*
  debug_msg (Format.sprintf "Touch move %d %d %d %d" x0 y0 x y);
*)
                     if
                       not !started &&
                       (abs (x - x0) > fuzz || abs (y - y0) > fuzz)
                     then begin
                       started := true;
                       element##style##cursor <- Js.string "move"
                     end;
                     if !started then move x0 y0 x y
                   end)
                 done;
                 Html.stopPropagation ev;
                 Js._false))
           Js._true
       in
       let c2 = ref Js.null in
       let c3 = ref Js.null in
       c2 := Js.some
         (Html.addEventListener Html.document Html.Event.touchend
            (Html.handler
               (fun ev ->
                  for i = 0 to ev##changedTouches##length - 1 do
                    Js.Optdef.iter (ev##changedTouches##item(i)) (fun touch ->
                    if touch##identifier = id then begin
                      let x = touch##clientX and y = touch##clientY in
(*
debug_msg (Format.sprintf "Touch end %d %d %d %d" x0 y0 x y);
*)
                      Html.removeEventListener c1;
                      Js.Opt.iter !c2 Html.removeEventListener;
                      Js.Opt.iter !c3 Html.removeEventListener;
                      if !started then begin
                        element##style##cursor <- Js.string "";
                        stop x y
                      end else
                        click x y
                    end)
                  done;
                  Js._true))
            Js._true);
       c3 := Js.some
         (Html.addEventListener Html.document Html.Event.touchend
            (Html.handler
               (fun ev ->
                  for i = 0 to ev##changedTouches##length - 1 do
                    Js.Optdef.iter (ev##changedTouches##item(i)) (fun touch ->
                    if touch##identifier = id then begin
                      let x = touch##clientX and y = touch##clientY in
(*
debug_msg (Format.sprintf "Touch cancel %d %d %d %d" x0 y0 x y);
*)
                      Html.removeEventListener c1;
                      Js.Opt.iter !c2 Html.removeEventListener;
                      Js.Opt.iter !c3 Html.removeEventListener;
                      if !started then element##style##cursor <- Js.string "";
                      cancel x y
                    end)
                  done;
                  Js._false))
            Js._true));
       Js._false))
    Js._true)

(*
let handle_touch_events element move stop cancel =
  let fuzz = 4 in
  let id = ref 0 in
  let x0 = ref 0 in
  let y0 = ref 0 in
  ignore (Html.addEventListener element Html.Event.touchstart
    (Html.handler (fun ev ->
       OptDef.iter (ev##changedTouches##item(0)) (fun touch ->
       id := touch##identifier; in
       x0 := touch##clientX;
       y0 := touch##clientY));
(* x0 := ev##pageX; y0 := ev##pageY;*)
debug_msg (Format.sprintf "Touch down %d %d" !x0 !y0);
 Js._false))
    Js._false);
  ignore (Html.addEventListener element Html.Event.touchmove
    (Html.handler
       (fun ev ->
(*
          let x = ev##pageX and y = ev##pageY in
*)
debug_msg (Format.sprintf "Touch move %d %d %d %d" !x0 !y0 x y);
          move !x0 !y0 x y;
          Js._false))
    Js._false);
  ignore (Html.addEventListener element Html.Event.touchend
    (Html.handler (fun _ ->
debug_msg (Format.sprintf "Touch end");
 stop (); Js._false))
    Js._false);
  ignore (Html.addEventListener element Html.Event.touchcancel
    (Html.handler (fun _ -> cancel (); Js._true))
    Js._false)
*)

let roundRectPath c x y w h r =
  let r = min r (min w h /. 2.) in
  c##beginPath ();
  c##moveTo (x +. r, y);
  c##arcTo (x +. w, y, x +. w, y +. r, r);
  c##arcTo (x +. w, y +. h, x +. w -. r, y +. h, r);
  c##arcTo (x, y +. h, x, y +. h -. r, r);
  c##arcTo (x, y, x +. r, y, r)

let text_size_div =
  let doc = Html.document in
  lazy
    (let d = Html.createDiv doc in
     d##style##visibility <- Js.string "hidden";
     d##style##position <- Js.string "absolute";
     d##style##whiteSpace <- Js.string "nowrap";
     Dom.appendChild (doc##body) d;
     d)

let text_size font txt =
  let doc = Html.document in
  let d = Lazy.force text_size_div in
  d##style##font <- font;
  let txt = doc##createTextNode (Js.string txt) in
  Dom.appendChild d txt;
  let res = (d##clientWidth, d##clientHeight) in
  Dom.removeChild d txt;
  res

(******)
    
let default_language () =
  (Js.Optdef.get (Dom_html.window##navigator##language) (fun () ->
   Js.Optdef.get (Dom_html.window##navigator##userLanguage) (fun () ->
   Js.string "en")))##substring(0,2)

let language =
  ref (Js.Optdef.case (Html.window##localStorage)
         default_language
         (fun st ->
            Js.Opt.get (st##getItem(Js.string "hyp_lang")) default_language))

let _ = Firebug.console##log (!language)

let set_language lang =
  Js.Optdef.iter (Html.window##localStorage)
    (fun st -> st##setItem(Js.string "hyp_lang", lang));
  language := lang

let load_messages () =
  getfile "messages.json" >>= fun s ->
  Lwt.return (json##parse (Js.string s))

let local_messages msgs : messages Js.t = option (Js.Unsafe.get msgs !language)

(******)

let screen_transform canvas =
  let offset = opt_style style##border 0.5 +. opt_style style##padding 0. in
  let w = canvas##width in
  let h = canvas##height in
(*
  let r = float (min  w h) /. 2. in
*)
  let rx = float w /. 2. in
  let ry = float h /. 2. in
  let dx = float w /. 2. in
  let dy = float h /. 2. in
  let rx = max 5. (rx -. offset) in
  let ry = max 5. (ry -. offset) in
  (rx, ry, dx, dy)

let eps = 0.05
(*
let to_screen z = ((z.x +. 1.) *. r, (z.y +. 1.) *. r)
*)
let from_screen canvas x y =
  let (rx, ry, dx, dy) = screen_transform canvas in
  let z = { x = (float x -. dx) /. rx; y = (float y -. dy) /. ry } in
  let n = norm z in
  if n <= 1. -. eps then z else sdiv z (n /. (1. -. eps))

let pi = 4. *. atan 1.


let ellipse_arc c cx cy rx ry start fin clock_wise =
 c##save ();
 c##translate (cx, cy);
 c##scale (rx, ry);
 c##arc (0., 0., 1., start, fin, clock_wise);
 c##restore ()

let arc c (rx, ry, dx, dy) z0 z1 z2 =
  let rd = norm (sub z1 z0) in
  let start = atan2 (z1.y-.z0.y) (z1.x-.z0.x) in
  let fin = atan2 (z2.y-.z0.y) (z2.x-.z0.x) in
  c##beginPath ();
  let alpha = mod_float (fin -. start +. 2. *. pi) (2. *. pi) in
(*
Firebug.console##log_4(start, fin, alpha, (alpha > pi));
*)
  if rx = ry then
    c##arc (z0.x *. rx +. dx, z0.y *. rx +. dy, rd *. rx,
            start, fin, Js.bool (alpha > pi))
  else
    ellipse_arc c (z0.x *. rx +. dx) (z0.y *. ry +. dy) (rd *. rx) (rd *. ry)
      start fin (Js.bool (alpha > pi));
  c##stroke ()

let line c (rx, ry, dx, dy) z1 z2 =
  c##beginPath ();
  c##moveTo (z1.x *. rx +. dx, z1.y *. ry +. dy);
  c##lineTo (z2.x *. rx +. dx, z2.y *. ry +. dy);
  c##stroke ()

(*
We have
  |z0|^2 = 1 + r^2  (the "line" is orthogonal to the unit circle)
  |z1-z0|^2 = r^2   (z1 is on the circle)
  |z2-z0|^2 = r^2   (z2 is on the circle)
By solving this set of equations, we get z0.
*)
let segment c transf z1 z2 =
  let d = 2. *. (z1.x *. z2.y -. z1.y *. z2.x) in
  if abs_float d < 0.05 then
    line c transf z1 z2
  else begin
    let n1 = sq_norm z1 +. 1. in
    let n2 = sq_norm z2 +. 1. in
    let z0 =
      { x = (z2.y *. n1 -. z1.y *. n2) /. d;
        y = (z1.x *. n2 -. z2.x *. n1) /. d }
    in
    arc c transf z0 z1 z2
  end

type boxes =
  { bx : float array; by : float array; bw : float array; bh : float array }

let shadow = false

let draw canvas vertices edges nodes boxes =
Firebug.console##time(Js.string "draw");
  let c = canvas##getContext (Html._2d_) in
  let (rx, ry, dx, dy) as transf = screen_transform canvas in
  c##clearRect (0., 0., float canvas##width, float canvas##height);

  let padding = opt_style style##padding 0. in
  c##beginPath ();
  ellipse_arc c dx dy (rx +. padding) (ry +. padding) 0. 7. Js._false;
  Js.Optdef.iter (style##backgroundColor)
    (fun color ->
       c##fillStyle <- color;
       c##fill ());
  Js.Optdef.iter (style##boundaryColor)
    (fun color ->
       c##lineWidth <- 1.;
       c##strokeStyle <- color;
       c##stroke ());

  c##lineWidth <- 2.;
  c##lineCap <- Js.string "round";
  c##strokeStyle <- opt_style (style##treeColor) tree_color;
  let (rx, ry, _, _) = transf in
  for i = 0 to Array.length edges - 1 do
    let (j, j', w) = edges.(i) in
    let z = vertices.(j) in
    let z' = vertices.(j') in
    if rx *. ry *. sq_norm_sub z z' > 4. then begin
      c##lineWidth <- w;
      segment c transf z z'
    end
  done;

  let image_count = ref 0 in
  let large_image_count = ref 0 in
  for i = 0 to Array.length nodes - 1 do
    let (l, img) = nodes.(i) in
    match img with
    | `Img (img, _) ->
        boxes.bw.(i) <- 0.;  (* Invalidate image location. *)
        let z = vertices.(i) in

        let rec min_scale l w h s =
          let s = ref s in
          for i = 0 to Array.length l - 1 do
            let (j, large) = l.(i) in
            let sx = abs_float (vertices.(j).x -. z.x) /. w in
            let sy = abs_float (vertices.(j).y -. z.y) /. h in
            let s' = if sx > sy then sx else sy in
            let s' = if large then s' else 1.9 *. s' in
            if s' < !s then s := s'
          done;
          !s
        in
        if not (Lazy.lazy_is_val img) then begin
          let s = min_scale l 1. 1. 1. in
          if s *. max rx ry > 1. then ignore (Lazy.force img)
        end else begin
          match Lwt.poll (Lazy.force img) with
            Some img ->
(*
        if min_w *. r > 1. && min_h *. r > 1. then begin
*)
              let w = float (img##width) in
              let h = float (img##height) in

(*
              let s = min_scale l w h (1. /. min w h) in
              let scale = s *. r in
*)
              let s = min_scale l 1. 1. 1. in
              let scale = s /. max (w /. rx) (h /. ry) in
              let w = w *. scale /. 2. in
              let h = h *. scale /. 2. in
              if w > 1. && h > 1. then begin
(*
              let ratio = r *. min (min_w /. w) (min_h /. h) in
              let w = w *. ratio in
              let h = h *. ratio in
*)
              if shadow then begin
                c##save();
(*
                let blur = 7. /. img_r *. rd in
                let offset = 5. /. img_r *. rd in
*)
                let blur = 7. *. scale in
                let offset = 5. *. scale in
                c##shadowBlur <- if blur < 1. then 0. else blur;
                c##shadowOffsetX <- if blur < 1. then 0. else offset;
                c##shadowOffsetY <- if blur < 1. then 0. else offset;
                c##shadowColor <- Js.string "black"
              end;
              let x = z.x *. rx +. dx in
              let y = z.y *. ry +. dy in
              c##drawImage_withSize (img, x -. w, y -. h, 2. *. w, 2. *. h);
(*
              c##drawImage_fromCanvasWithSize
                   (img, x -. w, y -. h, 2. *. w, 2. *. h);
*)
              if shadow then c##restore();
              boxes.bx.(i) <- x;
              boxes.by.(i) <- y;
              boxes.bw.(i) <- w;
              boxes.bh.(i) <- h;
              incr image_count;
              if w >= 2. && h >= 2. then incr large_image_count

end
          | None ->
              ()
         end
    | `Txt (circle, Some txt, _) ->
         let z = vertices.(i) in
         let r2 =
           Array.fold_left
             (fun r2 (j, _) -> min r2 (sq_norm (sub vertices.(j) z))) 1. l
         in
         let w = float (txt##width) in
         let h = float (txt##height) in
         let img_d = sqrt (w *. w +. h *. h) in
         let rd = sqrt (r2 *. rx *. ry) *. 0.5 in
         let rd = if rd > img_d /. 2. then img_d /. 2. else rd in
         let w = w /. img_d *. rd in
         let h = h /. img_d *. rd in
         if circle then begin
           c##beginPath ();
           c##fillStyle <- opt_style (style##nodeBackgroundColor) tree_color;
           c##arc(z.x *. rx +. dx, z.y *. ry +. dy,
                  sqrt (w *. w +. h *. h),
                  0., 7., Js._false);
           c##fill ()
         end;
         c##drawImage_fromCanvasWithSize
           (txt, z.x *. rx +. dx -. w, z.y *. ry +. dy -. h, 2. *. w, 2. *. h)
    | `Txt (_, None, _) | `None ->
        ()
  done;
Firebug.console##timeEnd(Js.string "draw");
Firebug.console##log_2(!image_count, !large_image_count)

let default_img = "frog.jpg"
let tree_url = "tree.json"

let (>>) x f = f x

type 'a tree = Node of 'a * 'a tree array

let rec tree_vertice_count n =
  let Node (_, l) = n in
  Array.fold_left (fun s n -> s + tree_vertice_count n) 1 l

let rec tree_edge_count n =
  let Node (_, l) = n in
  Array.fold_left (fun s n -> s + 1 + tree_edge_count n) 0 l

let rec randomize_tree n =
  let Node (info, ch) = n in
  for i = Array.length ch - 1 downto 0 do
    let v = ch.(i) in
    let j = truncate (Js.math##random() *. float (i + 1)) in
    ch.(i) <- ch.(j);
    ch.(j) <- v
  done;
  Array.iter randomize_tree ch

let need_redraw = ref false
let redraw_funct = ref (fun () -> ())

let perform_redraw () =
  need_redraw := false;
  !redraw_funct ()

let schedule_redraw now =
  if not !need_redraw then begin
    need_redraw := true;
    ignore
      (Lwt_js.sleep (if now then 0. else 0.1) >>= fun () ->
       if !need_redraw then perform_redraw ();
       Lwt.return ())
  end

let schedule_redraw now =
  if not !need_redraw then begin
    need_redraw := true;
    Html._requestAnimationFrame
      (Js.wrap_callback (fun () ->
        if !need_redraw then perform_redraw ()))
  end

(*
let load_image src =
  load_image src >>= fun img ->
  let w = img##width in
  let h = img##height in
  let canvas = create_canvas (w + 14) (h + 14) in
  let c = canvas##getContext (Html._2d_) in
  c##shadowBlur <- 7.;
  c##shadowOffsetX <- 5.;
  c##shadowOffsetY <- 5.;
  c##shadowColor <- Js.string "black";
  c##drawImage_withSize (img, 2., 2., float w, float h);
  Lwt.return canvas
*)

let image_node img =
  `Img (lazy (Lwt_js.yield () >>= fun () ->
              load_image (Js.string ("thumbnails/" ^ img ^ ".jpg")) >>=
              fun img -> schedule_redraw false; Lwt.return img),
        img)

let nl_re = Regexp.regexp "\n"
let not_space_re = Regexp.regexp "[^ ]"
let pipe_re = Regexp.regexp "[|]"

let compute_text_node info =
  let font = opt_style (style##nodeFont) (Js.string "20px sans-serif") in
  let (w, h) = text_size font info in
  let w = w + 8 in
  let h = h + 8 in
  let canvas = create_canvas w h in
  let c = canvas##getContext (Html._2d_) in
  c##fillStyle <- opt_style (style##nodeBackgroundColor) tree_color;
  roundRectPath c 0. 0. (float w) (float h) 4.;
  c##fill ();
  c##font <- font;
  c##fillStyle <- opt_style (style##nodeColor) (Js.string "black");
  c##textAlign <- Js.string "center";
  c##textBaseline <- Js.string "middle";
  c##fillText(Js.string info, float w /. 2., float h /. 2.);
  canvas

let compute_text_nodes node_names nodes =
  let names =
    try fst (List.assq !language node_names) with Not_found ->
    try fst (List.assq (Js.string "en") node_names) with Not_found ->
    Hashtbl.create 11
  in
  Html.document##title <- Js.string
    (try Hashtbl.find names "<TITLE>" with Not_found -> "");
  for i = 0 to Array.length nodes - 1 do
    match nodes.(i) with
      (neigh, `Txt (is_root, _, info)) ->
        let canvas =
          try
            Some (compute_text_node (Hashtbl.find names info))
          with Not_found ->
            None
        in
        nodes.(i) <- (neigh, `Txt (is_root, canvas, info))
    | _ ->
        ()
  done

let make_node info is_root children =
  if String.length info = 0 then
    `None
  else if info.[0] = '|' then
    image_node (String.sub info 1 (String.length info - 1))
  else
    `Txt (is_root, None, info)

let compute_nodes node =
  let rec compute is_root n =
    let Node (info, ch) = n in
    let info = make_node (Js.to_string info) is_root ch in
    let ch = Array.map (fun n -> compute false n) ch in
    Node (info, ch)
  in
  compute true node

let list_tl l =
  let rec tl x l = match l with [] -> x | x :: r -> tl x r in
  match l with [] -> assert false | x :: r -> tl x r

let compute_neighbors nodes tree =
  let frontiers = Array.make (Array.length nodes) ([||], [||]) in
  let node_info (Node (i, _)) = i in
  let status i =
    let (_, info) = nodes.(i) in
    (i, info <> `None)
  in
  let rec compute_frontiers node =
    let Node (i, l) = node in
    Array.iter compute_frontiers l;
    frontiers.(i) <-
      if Array.length l = 0 then ([|status i|], [|status i|]) else
      (fst frontiers.(node_info (l.(0))),
       snd frontiers.(node_info (l.(Array.length l - 1))))
(*
      (i :: fst frontiers.(node_info (List.hd l)),
       i :: snd frontiers.(node_info (list_tl l)))
*)
  in
  compute_frontiers tree;
  let neighboors = Array.make (Array.length nodes) [||] in
  let rec compute_neigh node parent lft rght =
    let Node (i, ch) = node in
    let children = Array.map (fun n -> status (node_info n)) ch in
    neighboors.(i) <- Array.concat [parent; lft; rght; children];
    let is_root = Array.length parent = 0 in
    let n = Array.length ch in
    for j = 0 to n - 1 do
      let lft =
        if j > 0 then
          snd frontiers.(node_info ch.(j - 1))
        else if is_root then
          snd frontiers.(node_info ch.(n - 1))
        else
          lft
      in
      let rght =
        if j < n - 1 then
          fst frontiers.(node_info ch.(j + 1))
        else if is_root then
          fst frontiers.(node_info ch.(0))
        else
          rght
      in
      compute_neigh ch.(j) [|status i|] lft rght
    done
  in
  compute_neigh tree [||] [||] [||];
  for i = 0 to Array.length nodes - 1 do
    let (l, info) = nodes.(i) in
    nodes.(i) <- (neighboors.(i), info)
  done

let weight_sum l =
  Array.fold_left (fun s n -> let Node (w, _) = n in s +. w) 0. l

let rec compute_weights node =
  let Node (_, l) = node in
  if Array.length l = 0 then Node (1., [||]) else
  let l' = Array.map compute_weights l in
  Node (0.6 *. weight_sum l', l')

let array_map2 f a1 a2 =
  let l = Array.length a1 in
  assert (Array.length a2 = l);
  if l = 0 then [||] else begin
    let r = Array.create l (f a1.(0) a2.(0)) in
    for i = 1 to l - 1 do
      r.(i) <- f a1.(i) a2.(i)
    done;
    r
  end

let tree_layout node_names root =
  let root = compute_nodes root in
  let node_count = tree_vertice_count root in
  let vertices = Array.make node_count zero in
  let edges = Array.make (tree_edge_count root) (0, 0, 0.) in
  let nodes = Array.make node_count ([||], `None) in
  let vi = ref 0 in
  let ei = ref 0 in
  let weights = compute_weights root in
  let rec layout_rec current current_weights is_root transf lineWidth dir =
    let Node (info, ch) = current in
    let Node (_, ch_weights) = current_weights in
    let i = !vi in
    incr vi;
    vertices.(i) <- fst transf;
    let l = Array.length ch in
    let ch' =
      if l = 0 then [||] else begin
        let j = ref 0 in
        let total_weight = weight_sum ch_weights in
        let w0 =
          ref (if is_root then
                 let Node (w, _) = ch_weights.(0) in
                 (total_weight -. w) /. 2.
               else
                 0.)
        in
        array_map2
          (fun node weights ->
             let Node (w, _) = weights in
             let angle = acos dir.x *. w /. total_weight in
             let th =
               acos dir.x *. ((!w0 +. w /. 2.) /. total_weight *. 2. -. 1.)
             in
             incr j;
             w0 := !w0 +. w;

             let min_angle = pi /. 3. in

             let a =
               { x = (cos angle -. cos min_angle) /.
                     (1. -. cos (min_angle +. angle));
                 y = 0. }
             in
             let dir = {x = cos min_angle; y = sin min_angle} in
             let (a, dir) =
               if a.x > 0.25 then (a, dir) else
               let a = {x = 0.25; y = 0.} in
               (a, transl (neg a) {x = cos angle; y = sin angle})
             in

             let u = compose (a, one) (zero, { x = cos th; y = sin th }) in
             let Node (i', _) as ch =
               layout_rec node weights false (compose u transf)
                 (lineWidth *. 0.94) dir
             in
             let k = !ei in
             incr ei;
             edges.(k) <- (i, i', lineWidth);
             ch)
          ch ch_weights
      end
    in
    nodes.(i) <- ([||], info);
    Node (i, ch')
  in
  let tree = layout_rec root weights true (zero, one) 6. {x = -1.; y = 0.} in
  compute_neighbors nodes tree;
  let boxes =
    { bx = Array.create node_count 0.;
      by = Array.create node_count 0.;
      bw = Array.create node_count 0.;
      bh = Array.create node_count 0. }
  in
  compute_text_nodes node_names nodes;
  (vertices, edges, nodes, boxes)

let load_tree () =
  getfile tree_url >>= fun s ->
  let info
    : Js.js_string Js.t tree *
      (Js.js_string Js.t * (Js.js_string Js.t * Js.js_string Js.t) array *
       Js.js_string Js.t) array
    = json##parse (Js.string s)
  in
  let (tree, node_names) = info in
  randomize_tree tree;
  let node_names =
    node_names
    >> Array.map
         (fun (lang, tbl, about) ->
            let h = Hashtbl.create 101 in
            Array.iter
              (fun (k, v) -> Hashtbl.add h (Js.to_string k) (Js.to_string v))
              tbl;
            (lang, (h, about)))
    >> Array.to_list
  in
  Lwt.return (tree_layout node_names tree, node_names)

let radius_of_length r = (exp r -. 1.) /. (exp r +. 1.)
let length_of_radius r = log ((1. +. r) /. (1. -. r))

type info =
  { name : Js.js_string Js.t;
    url : Js.js_string Js.t;
    attribution : Js.js_string Js.t;
    width : int;
    height : int;
    links : (Js.js_string Js.t * Js.js_string Js.t * Js.js_string Js.t) array;
    img_url : Js.js_string Js.t option }

let load_image_info () : info array Lwt.t =
  getfile "image_info.json" >>= fun s ->
  Lwt.return (json##parse (Js.string s))

let close_button over =
  let color = opt_style (style##buttonColor) (Js.string "#888888") in
  let size = 32 in
  let offset = 4. in
  let lw = 4. in
  let canvas = create_canvas size size in
  let c = canvas##getContext (Html._2d_) in
  c##save ();
  c##lineWidth <- 2.;
  c##strokeStyle <- color;
  if over then begin
    c##shadowBlur <- offset;
    c##shadowColor <- color
  end;
  c##beginPath ();
  let a = offset +. lw /. sqrt 2. in
  let b = float size -. offset -. lw /. sqrt 2. in
  c##moveTo (a, a);
  c##lineTo (b, b);
  c##moveTo (a, b);
  c##lineTo (b, a);
  c##stroke ();
  c##restore ();
  canvas##className <- Js.string (if over then "on" else "off");
  canvas##style##position <- Js.string "absolute";
  canvas##style##top <- Js.string "0";
  canvas##style##right <- Js.string "0";
  canvas

let img_button ?href h src =
  let doc = Html.document in
  let decoration over =
    let img = Html.createImg doc in
    img##src <- icon src;
    let div = Html.createDiv doc in
    div##style##position <- Js.string "absolute";
    div##style##width <- Js.string "38px";
    div##style##height <- Js.string (string_of_int (max 38 h) ^ "px");
    div##style##margin <- Js.string "2px";
    (Js.Unsafe.coerce div##style)##borderRadius <- Js.string "2px";
    let extra = max 6 (44 - h) in
    div##style##padding <- Js.string
(*
      (Format.sprintf "%dpx 3px %dpx 3px" (extra / 2) (extra - extra / 2));
*)
      (string_of_int (extra / 2) ^ "px 3px " ^
       string_of_int (extra - extra / 2) ^ "px 3px");
    div##className <- Js.string
      ("filled_button " ^ if over then "on" else "off");
    Dom.appendChild div img;
    div
  in
  let button = Html.createDiv doc in
  button##className <- Js.string "button";
  button##style##width <- Js.string "48px";
  button##style##height <- Js.string (string_of_int (8 + max 38 h) ^ "px");
  let container =
    match href with
     None ->
       (button :> Html.element Js.t)
   | Some url ->
       let a = Html.createA doc in
       a##target <- Js.string "_blank";
       a##href <- url;
       Dom.appendChild button a;
       (a :> Html.element Js.t)
  in
  Dom.appendChild container (decoration true);
  Dom.appendChild container (decoration false);
  button

let tooltip txt =
  let tooltip = Html.createDiv Html.document in
  tooltip##style##position <- Js.string "absolute";
  tooltip##className <- Js.string "tooltip on";
  tooltip##innerHTML <- txt;
  tooltip

let show_on_click button txt =
  let activated = ref false in
  button##onclick <-
    Html.handler
      (fun ev ->
         if not !activated then begin
           activated := true;
           let c = ref Js.null in
           c := Js.some
             (Html.addEventListener Html.document Html.Event.click
                (Html.handler
                   (fun ev ->
                      ignore
                        (Lwt_js.yield () >>= fun () ->
                         Js.Opt.iter !c Html.removeEventListener;
                         txt##className <- Js.string "text on";
                         activated := false;
                         Lwt.return ());
                      Js._true))
                Js._true);
           txt##className <- Js.string "text";
         end;
         Html.stopPropagation ev; Js._false)

let show_image all_messages image_info name small_image =
  image_info >>= fun image_info ->
  let messages = local_messages all_messages in
(*
  let suffix_re = Regexp.regexp "\\.[^.]*$" in
  let name = Js.string (Regexp.global_replace suffix_re name "") in
*)
  let i = ref (-1) in
  let name_js = Js.string name in
  for j = 0 to Array.length image_info - 1 do
    if name_js == image_info.(j).name then i := j
  done;
  if !i >= 0 then begin
    let info = image_info.(!i) in
Firebug.console##log_2(name, !i);
    let d = Html.document in

    let container = Html.createDiv d in
    container##style##margin <- Js.string "10px";
    container##style##position <- Js.string "absolute";
    container##style##top <- Js.string "0";
    container##style##bottom <- Js.string "0";
    container##style##left <- Js.string "0";
    container##style##right <- Js.string "0";

    let img_container = Html.createDiv d in
    img_container##style##position <- Js.string "absolute";
    img_container##style##top <- Js.string "0";
    img_container##style##bottom <- Js.string "4em";
    img_container##style##left <- Js.string "38px";
    img_container##style##right <- Js.string "38px";

    let wrap elt =
      let w = Html.createDiv d in
      w##style##position <- Js.string "absolute";
      w##style##top <- Js.string "0";
      w##style##bottom <- Js.string "0";
      w##style##left <- Js.string "0";
      w##style##right <- Js.string "0";
      w##style##margin <- Js.string "auto";
(*
      w##style##width <- Js.string "100%";
      w##style##height <- Js.string "100%";
      w##style##maxWidth <- Js.string (string_of_int info.width ^ "px");
*)
      w##style##maxHeight <- Js.string (string_of_int info.height ^ "px");
      Dom.appendChild w elt;
      w
    in

    let img = Html.createImg d in
    begin match Lwt.poll (Lazy.force small_image) with
      Some small_image ->
        let canvas = create_canvas info.width info.height in
        let c = canvas##getContext (Html._2d_) in
        c##drawImage_withSize
          (small_image, 0., 0., float info.width, float info.height);
        canvas##style##display <- Js.string "block";
        canvas##style##height <- Js.string "auto";
        canvas##style##width <- Js.string "auto";
        canvas##style##maxWidth <- Js.string "100%";
        canvas##style##maxHeight <- Js.string "100%";
        canvas##style##marginLeft <- Js.string "auto";
        canvas##style##marginRight <- Js.string "auto";
        let w = wrap canvas in
        Dom.appendChild img_container w;
        img##onload <-
          Html.handler
            (fun _ ->
               Dom.removeChild img_container w;
               Js._false)
    | None ->
        ()
    end;
    img##src <-
      (match info.img_url with
         None     -> Js.string ("images/" ^ name ^ ".jpg")
       | Some url -> url);
    img##width <- info.width;
    img##height <- info.height;
    img##style##display <- Js.string "block";
    img##style##height <- Js.string "auto";
    img##style##width <- Js.string "auto";
    img##style##maxWidth <- Js.string "100%";
    img##style##maxHeight <- Js.string "100%";
    img##style##marginLeft <- Js.string "auto";
    img##style##marginRight <- Js.string "auto";
    let w = wrap img in
    let handle_error _ =
      Dom.removeChild img_container w;
      Js._false
    in
    img##onerror <- Html.handler handle_error;
    img##onabort <- Html.handler handle_error;
    Dom.appendChild img_container w;

    Dom.appendChild container img_container;

    let legend = Html.createDiv d in
    legend##innerHTML <- info.attribution;
(*
    let p = Html.createP d in
    p##innerHTML <-
      Js.string ("See the <a target=\"_blank\" href=\"" ^
                  Js.to_string info.url ^ "\">image \
                  description page</a> on Wikimedia Commons for more \
                  information.");
    Dom.appendChild legend p;
*)
    legend##onclick <-
      Html.handler
        (fun ev -> Html.stopPropagation ev; Js._true);
    legend##className <- Js.string "text";
    legend##style##position <- Js.string "absolute";
    legend##style##bottom <- Js.string "0";
    legend##style##marginRight <- Js.string "auto";
    legend##style##marginLeft <- Js.string "auto";
    Dom.appendChild container legend;

    let background = Html.createDiv d in
    Dom.appendChild background container;
    background##className <- Js.string "overlay";
    background##style##width <- Js.string "100%";
    background##style##height <- Js.string "100%";
    background##style##position <- Js.string "absolute";
    background##style##top <- Js.string "0";
    background##style##left <- Js.string "0";
    background##style##zIndex <- Js.string "1";

    let button = Html.createDiv d in
    button##className <- Js.string "button";
    button##style##position <- Js.string "absolute";
    button##style##top <- Js.string "0";
    button##style##right <- Js.string "0";
    button##style##cursor <- Js.string "pointer";

    Dom.appendChild button (close_button true);
    Dom.appendChild button (close_button false);
    let tt =
      tooltip (opt_style (messages##close)
                 (Js.string "Click anywhere to return to the tree"))
    in
    tt##style##right <- Js.string "32px";
    tt##style##top <- Js.string "20px";
    Dom.appendChild button tt;
    Dom.appendChild background button;

    let buttons = Html.createDiv d in
    buttons##style##position <- Js.string "absolute";
    buttons##style##top <- Js.string "0";
    buttons##style##left <- Js.string "0";
    let url =
      let suffix =
        if !language == Js.string "en" then "" else
        "?uselang=" ^ Js.to_string !language
      in
      "http://commons.wikimedia.org/wiki/File:" ^
      Js.to_string info.url ^ suffix
    in
    let commons = img_button ~href:(Js.string url) 52 "commons-38.png" in
    let tt =
      tooltip (opt_style (messages##wikimediaCommons)
                 (Js.string "See image description on Wikimedia Commons"))
    in
    tt##style##left <- Js.string "48px";
    tt##style##top <- Js.string "12px";
    Dom.appendChild commons tt;
    Dom.appendChild buttons commons;
    let wikipedia = img_button 34 "wikipedia-38.png" in
    let txt = Html.createDiv d in
    let count = ref 0 in
    let dl = Html.createDl d in
    let list title lang =
      let ul = Html.createUl d in
      let empty = ref true in
      Array.iter
        (fun (name, lang', refer) ->
           if lang' == lang then begin
             empty := false;
             let a = Html.createA d in
             Dom.appendChild a (d##createTextNode (name));
             a##target <- Js.string "_blank";
             let refer = Js.to_string refer in
             let url =
               "http://" ^ Js.to_string lang ^ ".wikipedia.org/wiki/" ^
               if String.length refer = 0 then Js.to_string name else refer
             in
             a##href <- Js.string url;
             let li = Html.createLi d in
             Dom.appendChild li a;
             Dom.appendChild ul li
           end)
        info.links;
      if not !empty then begin
        incr count;
        let dd = Html.createDd d in
        Dom.appendChild dd (d##createTextNode (title));
        Dom.appendChild dl dd;
        let dt = Html.createDt d in
        Dom.appendChild dt ul;
        Dom.appendChild dl dt;
      end
    in
    list (opt_style (messages##language) (Js.string "In English")) !language;
    if !language != Js.string "en" then
      list (Js.string "In English") (Js.string "en");
    if !count > 0 then
      Dom.appendChild txt dl
    else
      Dom.appendChild txt
        (d##createTextNode
            (opt_style (messages##noRef) (Js.string "No reference found.")));
    txt##className <- Js.string "text on";
    txt##style##position <- Js.string "absolute";
    txt##style##left <- Js.string "48px";
    txt##style##top <- Js.string "62px";
    txt##style##whiteSpace <- Js.string "nowrap";
    Dom.appendChild wikipedia txt;
    Dom.appendChild buttons wikipedia;

    txt##onclick <- Html.handler (fun ev -> Html.stopPropagation ev; Js._true);
    show_on_click wikipedia txt;

    buttons##onclick <-
      Html.handler (fun ev -> Html.stopPropagation ev; Js._true);
    Dom.appendChild background buttons;

    Dom.appendChild d##body background;
    background##onclick <-
      Html.handler
        (fun _ -> Dom.removeChild d##body background; Js._true)
  end;
  Lwt.return 0

let information_en =
  Js.string
   "<h1>A tree of animals</h1> \
    This <a target=\"_blank\" \
    href=\"http://en.wikipedia.org/wiki/Phylogenetic_tree\">\
    <em>phylogenetic</em> tree</a> displays the relationships among \
    animals.\
    <h2>Usage</h2>\
    Browse the tree by dragging it with the mouse. Click on any image \
    to display a larger version.\
    <h2>Credits</h2>\
    This software and the images it uses are under free licenses. \
    Images are from <a target=\"_blank\" \
    href=\"http://commons.wikimedia.org/wiki/Main_Page\">Wikimedia \
    Commons</a>.  You can click on each image for details.  The \
    software has been written by Jérôme Vouillon (CNRS)."

let show_information_page messages tree_i18n =
  let info =
    try snd (List.assq !language tree_i18n) with Not_found ->
    try snd (List.assq (Js.string "en") tree_i18n) with Not_found ->
    information_en
  in
  let doc = Html.document in
  let txt = Html.createDiv doc in
  txt##className <- Js.string "text";
  txt##style##width <- Js.string "80%";
  txt##style##margin <- Js.string "auto";
  txt##innerHTML <- info;
  let cell = Html.createDiv doc in
  cell##style##display <- Js.string "table-cell";
  cell##style##verticalAlign <- Js.string "middle";
  Dom.appendChild cell txt;
  let table = Html.createDiv doc in
  table##style##width <- Js.string "100%";
  table##style##height <- Js.string "100%";
  table##style##display <- Js.string "table";
  Dom.appendChild table cell;
  let overlay = Html.createDiv doc in
  overlay##className <- Js.string "overlay translucent";
  Dom.appendChild overlay table;
  let c = ref Js.null in
  let close_info () =
    Dom.removeChild (doc##body) overlay;
    Js.Opt.iter !c Html.removeEventListener
  in
  c := Js.some
    (Html.addEventListener Html.document Html.Event.keydown
       (Html.handler
          (fun e ->
             match e##keyCode with
             | 27 | 13 -> close_info (); Js._false
             | _       -> Js._true))
       Js._true);

  let button = Html.createButton doc in
  Dom.appendChild button
    (doc##createTextNode (opt_style (messages##ok) (Js.string "OK")));
  button##onclick <- Html.handler (fun _ -> close_info (); Js._false);
  let button_div = Html.createDiv doc in
  button_div##style##textAlign <- Js.string "center";
  button_div##style##margin <- Js.string "2em auto";
  Dom.appendChild button_div button;
  Dom.appendChild txt button_div;
  Dom.appendChild (doc##body) overlay

let unsupported_messages () =
  let doc = Html.document in
  let txt = Html.createDiv doc in
  txt##className <- Js.string "text";
  txt##style##width <- Js.string "80%";
  txt##style##margin <- Js.string "auto";
  txt##innerHTML <- Js.string
    "Unfortunately, this browser is not supported. \
     Please try again with another browser, \
     such as <a href=\"http://www.mozilla.org/firefox/\">Firefox</a>, \
     <a href=\"http://www.google.com/chrome/\">Chrome</a> or \
     <a href=\"http://www.opera.com/\">Opera</a>.";
  let cell = Html.createDiv doc in
  cell##style##display <- Js.string "table-cell";
  cell##style##verticalAlign <- Js.string "middle";
  Dom.appendChild cell txt;
  let table = Html.createDiv doc in
  table##style##width <- Js.string "100%";
  table##style##height <- Js.string "100%";
  table##style##display <- Js.string "table";
  Dom.appendChild table cell;
  let overlay = Html.createDiv doc in
  overlay##className <- Js.string "overlay";
  Dom.appendChild overlay table;
  Dom.appendChild (doc##body) overlay

let _ =
(*
Random.self_init ();
*)
(* Prefetch icons. *)
List.iter (fun src -> ignore (load_image (icon src))) icons

let all_messages = load_messages ()
let tree_info = load_tree ()
let image_info = load_image_info ()

let start _ =
  Lwt.ignore_result
    (tree_info >>= fun ((vertices, edges, nodes, boxes), tree_i18n) ->
     all_messages >>= fun all_messages ->
     let doc = Html.document in
     let page = doc##documentElement in
     page##style##overflow <- Js.string "hidden";
     page##style##height <- Js.string "100%";
     doc##body##style##overflow <- Js.string "hidden";
     doc##body##style##margin <- Js.string "0px";
     doc##body##style##height <- Js.string "100%";
     let w = page##clientWidth in
     let h = page##clientHeight in
     let canvas = create_canvas w h in
     Dom.appendChild doc##body canvas;

     let tr = ref (zero, one) in
     let tr' = ref !tr in
     let vertices' = Array.copy vertices in
     redraw_funct :=
       (fun () ->
          need_redraw := false;
          Firebug.console##time(Js.string "transform");
(*
          let transf = hyp_transf !tr' in
          for i = 0 to Array.length vertices - 1 do
            vertices'.(i) <- transf vertices.(i)
          done;
*)
          let w = page##clientWidth in
          let h = page##clientHeight in
          if w <> canvas##width || h <> canvas##height then begin
            canvas##width <- w;
            canvas##height <- h
          end;
          hyp_transf_vect !tr' vertices vertices';
          Firebug.console##timeEnd(Js.string "transform");
          draw canvas vertices' edges nodes boxes);
     perform_redraw ();

     Html.window##onresize <- Html.handler
       (fun _ ->
          let page = doc##documentElement in
          let w = page##clientWidth in
          let h = page##clientHeight in
(*
debug_msg (Format.sprintf "Resize %d %d" w h);
*)
          if w <> canvas##width || h <> canvas##height then begin
(*
            canvas##width <- w;
            canvas##height <- h;
            perform_redraw ()
*)
            schedule_redraw true
          end;
          Js._true);

(*
     let eventually t f =
       let scheduled = ref false in
       fun () ->
         if not !scheduled then begin
           scheduled := true;
           ignore
             (Lwt_js.sleep t >>= fun () ->
              scheduled := false;
              f ();
              Lwt.return ())
         end
     in
*)
     let find_box boxes x y =
       let p = ref (-1) in
       for i = 0 to Array.length boxes.bw - 1 do
         if
           Array.unsafe_get boxes.bw i > 0.
             &&
           abs_float (float x -. Array.unsafe_get boxes.bx i) <
           Array.unsafe_get boxes.bw i
             &&
           abs_float (float y -. Array.unsafe_get boxes.by i) <
           Array.unsafe_get boxes.bh i
         then
           p := i
       done;
       !p
     in

     let on_image = ref false in
     let update_cursor x y =
       let i = find_box boxes x y in
       if i <> -1 then begin
         if not !on_image then begin
           canvas##style##cursor <- Js.string "pointer";
           on_image := true
         end
       end else if !on_image then begin
         canvas##style##cursor <- Js.string "";
         on_image := false
       end
     in
     canvas##onmousemove <- Html.handler
       (fun ev -> update_cursor (ev##clientX) (ev##clientY); Js._false);

     handle_drag canvas
      (fun x0 y0 x1 y1 ->
         let z0 = from_screen canvas x0 y0 in
         let z1 = from_screen canvas x1 y1 in
(*
         (* Transformation from z0 to z1:
            z1 = (z0 + p) / (conj p.z0 + 1)
            ==> p = (z1.z0.conj (z1 - z0) + z1 - z0) / (1 - |z1.z0|^2) *)
         let dz = sub z1 z0 in
         let z0z1 = mul z0 z1 in
         let p = sdiv (add (mul z0z1 (conj dz)) dz) (1. -. sq_norm z0z1) in
         tr' := compose !tr (p, one);
*)
         let (p, _) = !tr in
         let z0' = transl (neg p) z0 in
         let p' = compute_translation z0' z1 in
         tr' := (p', one);
         schedule_redraw true
         (*perform_redraw ()*))
      (fun x y -> tr := !tr'; on_image := false; update_cursor x y)
      (fun x y ->
         let i = find_box boxes x y in
         if i > 0 then
           match nodes.(i) with
             _, `Img (img, name) -> ignore (show_image all_messages image_info name img)
           | _                 -> ());

     handle_touch_events canvas
      (fun x0 y0 x1 y1 ->
   Firebug.console##time(Js.string "transform");
         let z0 = from_screen canvas x0 y0 in
         let z1 = from_screen canvas x1 y1 in
(*
         (* Transformation from z0 to z1:
            z1 = (z0 + p) / (conj p.z0 + 1)
            ==> p = (z1.z0.conj (z1 - z0) + z1 - z0) / (1 - |z1.z0|^2) *)
         let dz = sub z1 z0 in
         let z0z1 = mul z0 z1 in
         let p = sdiv (add (mul z0z1 (conj dz)) dz) (1. -. sq_norm z0z1) in
         tr' := compose !tr (p, one);
*)
         let (p, _) = !tr in
         let z0' = transl (neg p) z0 in
         let p' = compute_translation z0' z1 in
         tr' := (p', one);
         schedule_redraw true)
      (fun _ _ -> tr := !tr')
      (fun _ _ -> tr := !tr')
      (fun x y ->
         let i = find_box boxes x y in
         if i > 0 then
           match nodes.(i) with
             _, `Img (img, name) -> ignore (show_image all_messages image_info name img)
           | _                 -> ());

     let handle_key_event ev =
       match ev##keyCode with
          37 -> (* left *)
            let z0 = {x = 0.; y = 0.} in
            let z1 = {x = 0.1; y = 0.} in
            let (p, _) = !tr in
            let z0' = transl (neg p) z0 in
            let p' = compute_translation z0' z1 in
            tr' := (p', one);
            tr := !tr';
            schedule_redraw true;
            Js._false
       | 38 -> (* up *)
            let z0 = {x = 0.; y = 0.} in
            let z1 = {x = 0.; y = 0.1} in
            let (p, _) = !tr in
            let z0' = transl (neg p) z0 in
            let p' = compute_translation z0' z1 in
            tr' := (p', one);
            tr := !tr';
            schedule_redraw true;
           Js._false
       | 39 -> (* right *)
            let z0 = {x = 0.; y = 0.} in
            let z1 = {x = -0.1; y = 0.} in
            let (p, _) = !tr in
            let z0' = transl (neg p) z0 in
            let p' = compute_translation z0' z1 in
            tr' := (p', one);
            tr := !tr';
            schedule_redraw true;
           Js._false
       | 40 -> (* down *)
            let z0 = {x = 0.; y = 0.} in
            let z1 = {x = 0.; y = -0.1} in
            let (p, _) = !tr in
            let z0' = transl (neg p) z0 in
            let p' = compute_translation z0' z1 in
            tr' := (p', one);
            tr := !tr';
            schedule_redraw true;
           Js._false
       | _ ->
           Js._true
     in
     ignore (Html.addEventListener Html.document Html.Event.keydown
               (Html.handler handle_key_event) Js._true);

     let prev_buttons = ref None in
     let rec make_buttons () =
       begin match !prev_buttons with
         None         -> ()
       | Some buttons -> Dom.removeChild doc##body buttons
       end;

       let buttons = Html.createDiv doc in
       buttons##style##position <- Js.string "absolute";
       buttons##style##right <- Js.string "0";
       buttons##style##bottom <- Js.string "0";

       let messages = local_messages all_messages in

       let info = img_button 38 "info-38.png" in
       info##style##position <- Js.string "absolute";
       info##style##bottom <- Js.string "2px";
       info##style##right <- Js.string "0";
       info##style##cursor <- Js.string "pointer";
       info##onclick <-
         Html.handler
           (fun _ -> show_information_page messages tree_i18n; Js._false);
       let tt =
         tooltip (opt_style (messages##info) (Js.string "Information")) in
       tt##style##right <- Js.string "36px";
       tt##style##bottom <- Js.string "36px";
       Dom.appendChild info tt;
       Dom.appendChild buttons info;

       let lang = img_button 38 "globe-38.png" in
       lang##style##position <- Js.string "absolute";
       lang##style##bottom <- Js.string "2px";
       lang##style##right <- Js.string "48px";
       lang##style##cursor <- Js.string "pointer";
       let languages = ["Français", "fr"; "English", "en"] in
       let txt = Html.createDiv doc in
       let dl = Html.createDl doc in
       let ul = Html.createUl doc in
       List.iter
         (fun (name, id) ->
            let a = Html.createA doc in
            Dom.appendChild a (doc##createTextNode (Js.string name));
            a##href <- Js.string "#";
            a##onclick <- Html.handler
              (fun _ ->
                 set_language (Js.string id);
                 make_buttons ();
                 compute_text_nodes tree_i18n nodes;
                 schedule_redraw true;
                 Js._false);
            let li = Html.createLi doc in
            Dom.appendChild li a;
            Dom.appendChild ul li)
         languages;
       let dd = Html.createDd doc in
       Dom.appendChild dd
         (doc##createTextNode((opt_style (messages##languages)
                                 (Js.string "Languages"))));
       Dom.appendChild dl dd;
       let dt = Html.createDt doc in
       Dom.appendChild dt ul;
       Dom.appendChild dl dt;
       Dom.appendChild txt dl;
       txt##className <- Js.string "text on";
       txt##style##position <- Js.string "absolute";
       txt##style##right <- Js.string "0px";
       txt##style##bottom <- Js.string "46px";
       txt##style##whiteSpace <- Js.string "nowrap";
       Dom.appendChild lang txt;
       show_on_click lang txt;
       Dom.appendChild buttons lang;

       let recenter = img_button 38 "meeting-point-38.png" in
       recenter##style##position <- Js.string "absolute";
       recenter##style##bottom <- Js.string "2px";
       recenter##style##right <- Js.string "96px";
       recenter##style##cursor <- Js.string "pointer";
       recenter##onclick <-
         Html.handler (fun _ ->
           tr' := (zero, one);
           tr := !tr';
           schedule_redraw true;
           Js._false);
       let tt =
         tooltip (opt_style (messages##recenter) (Js.string "Recenter")) in
       tt##style##right <- Js.string "36px";
       tt##style##bottom <- Js.string "36px";
       Dom.appendChild recenter tt;
       Dom.appendChild buttons recenter;
       Dom.appendChild doc##body buttons;
       prev_buttons := Some buttons
     in
     make_buttons ();

     let img = Html.createImg doc in
     img##src <- icon "ocsigen-powered.png";
     let a = Html.createA doc in
     a##target <- Js.string "_blank";
     a##href <- Js.string "http://ocsigen.org/";
     Dom.appendChild a img;
     let logo = Html.createDiv doc in
     logo##style##position <- Js.string "absolute";
     logo##style##left <- Js.string "0";
     logo##style##bottom <- Js.string "0";
     Dom.appendChild logo a;
     Dom.appendChild doc##body logo;

     Lwt.return ());
  Js._false

let start _ =
  try
    ignore (Html.createCanvas (Html.window##document));
    start ()
  with Html.Canvas_not_available ->
    unsupported_messages ();
    Js._false

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