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

open Scene

let pi = 4. *. atan 1.

(****)

module F (M : sig
  type font

  type color

  type text

  val white : color

  type ctx

  val save : ctx -> unit

  val restore : ctx -> unit

  val scale : ctx -> sx:float -> sy:float -> unit

  val translate : ctx -> tx:float -> ty:float -> unit

  val begin_path : ctx -> unit

  val close_path : ctx -> unit

  val move_to : ctx -> x:float -> y:float -> unit

  val line_to : ctx -> x:float -> y:float -> unit

  val curve_to :
    ctx -> x1:float -> y1:float -> x2:float -> y2:float -> x3:float -> y3:float -> unit

  val arc :
    ctx -> xc:float -> yc:float -> radius:float -> angle1:float -> angle2:float -> unit

  val rectangle : ctx -> x:float -> y:float -> width:float -> height:float -> unit

  val fill : ctx -> color -> unit

  val stroke : ctx -> color -> unit

  val clip : ctx -> unit

  val draw_text :
    ctx -> float -> float -> text -> font -> color option -> color option -> unit

  type window

  type drawable

  type pixmap

  val get_drawable : window -> drawable

  val make_pixmap : window -> int -> int -> pixmap

  val drawable_of_pixmap : pixmap -> drawable

  val get_context : pixmap -> ctx

  val put_pixmap :
       dst:drawable
    -> x:int
    -> y:int
    -> xsrc:int
    -> ysrc:int
    -> width:int
    -> height:int
    -> pixmap
    -> unit

  (****)

  type rectangle =
    { x : int
    ; y : int
    ; width : int
    ; height : int
    }

  val compute_extents :
       ctx
    -> (color, font, text) Scene.element array
    -> (float * float * float * float) array
end) =
struct
  open M

  let empty_rectangle = { x = 0; y = 0; width = 0; height = 0 }

  let rectangle_is_empty r = r.width = 0 || r.height = 0

  (****)

  type pixmap =
    { mutable pixmap : M.pixmap option
    ; mutable p_width : int
    ; mutable p_height : int
    ; mutable valid_rect : rectangle
    }

  let make_pixmap () =
    { pixmap = None; p_width = 0; p_height = 0; valid_rect = empty_rectangle }

  let invalidate_pixmap p = p.valid_rect <- empty_rectangle

  let grow_pixmap pm window width height =
    let width = max width pm.p_width in
    let height = max height pm.p_height in
    if width > pm.p_width || height > pm.p_height
    then (
      let old_p = pm.pixmap in
      let p = M.make_pixmap window width height in
      let r = pm.valid_rect in
      (match old_p with
      | Some old_p ->
          put_pixmap
            ~dst:(drawable_of_pixmap p)
            ~x:0
            ~y:0
            ~xsrc:0
            ~ysrc:0
            ~width:r.width
            ~height:r.height
            old_p
      | None -> ());
      pm.pixmap <- Some p;
      pm.p_width <- width;
      pm.p_height <- height)

  let get_pixmap pm =
    match pm.pixmap with
    | Some p -> p
    | None -> assert false

  (****)

  type st =
    { mutable bboxes : (float * float * float * float) array
    ; scene : (color, font, text) Scene.element array
    ; mutable zoom_factor : float
    ; st_x : float
    ; st_y : float
    ; st_width : float
    ; st_height : float
    ; st_pixmap : pixmap
    }

  (****)

  let perform_draw ctx fill stroke =
    (match fill with
    | Some c -> M.fill ctx c
    | None -> ());
    match stroke with
    | Some c -> M.stroke ctx c
    | None -> ()

  let draw_element ctx e =
    begin_path ctx;
    match e with
    | Path (cmd, fill, stroke) ->
        Array.iter
          (fun c ->
            match c with
            | Move_to (x, y) -> move_to ctx ~x ~y
            | Curve_to (x1, y1, x2, y2, x3, y3) -> curve_to ctx ~x1 ~y1 ~x2 ~y2 ~x3 ~y3)
          cmd;
        perform_draw ctx fill stroke
    | Ellipse (cx, cy, rx, ry, fill, stroke) ->
        save ctx;
        translate ctx ~tx:cx ~ty:cy;
        scale ctx ~sx:rx ~sy:ry;
        arc ctx ~xc:0. ~yc:0. ~radius:1. ~angle1:0. ~angle2:(2. *. pi);
        restore ctx;
        perform_draw ctx fill stroke
    | Polygon (points, fill, stroke) ->
        Array.iteri
          (fun i (x, y) -> if i = 0 then move_to ctx ~x ~y else line_to ctx ~x ~y)
          points;
        close_path ctx;
        perform_draw ctx fill stroke
    | Text (x, y, txt, font, fill, stroke) -> draw_text ctx x y txt font fill stroke

  let intersects ((x1, y1, x2, y2) : float * float * float * float) (x3, y3, x4, y4) =
    x1 <= x4 && y1 <= y4 && x3 <= x2 && y3 <= y2

  let redraw st scale x y x' y' w h =
    (*
Format.eprintf "REDRAW %d %d %d %d@." x' y' w h;
*)
    let ctx = get_context (get_pixmap st.st_pixmap) in
    save ctx;
    if Array.length st.bboxes = 0 && Array.length st.scene > 0
    then st.bboxes <- compute_extents ctx st.scene;
    begin_path ctx;
    rectangle ctx ~x:(float x') ~y:(float y') ~width:(float w) ~height:(float h);
    M.fill ctx M.white;
    clip ctx;
    let x = float x /. scale in
    let y = float y /. scale in
    M.scale ctx ~sx:scale ~sy:scale;
    translate ctx ~tx:(-.st.st_x -. x) ~ty:(-.st.st_y -. y);
    let bbox =
      let x = st.st_x +. x +. (float x' /. scale) in
      let y = st.st_y +. y +. (float y' /. scale) in
      ( x
      , y
      , x +. (float st.st_pixmap.p_width /. scale)
      , y +. (float st.st_pixmap.p_height /. scale) )
    in
    for i = 0 to Array.length st.scene - 1 do
      let box = st.bboxes.(i) in
      let e = st.scene.(i) in
      if intersects box bbox then draw_element ctx e
    done;
    restore ctx

  let redraw st scale x0 y0 window a x y width height =
    let pm = st.st_pixmap in
    grow_pixmap pm window a.width a.height;
    let round x = truncate ((x *. scale) +. 0.5) in
    let x0 = round x0 in
    let x0' = round (((float a.width /. scale) -. st.st_width) /. 2.) in
    let x0 = if x0' > 0 then -x0' else x0 in
    let y0 = round y0 in
    let y0' = round (((float a.height /. scale) -. st.st_height) /. 2.) in
    let y0 = if y0' > 0 then -y0' else y0 in
    let dx = pm.valid_rect.x - x0 in
    let dy = pm.valid_rect.y - y0 in
    (*
Firebug.console##log_6 (dx, pm.valid_rect.width, a.width,
               dy, pm.valid_rect.height, a.height);
*)
    if (dx > 0 && pm.valid_rect.width + dx < a.width)
       || (dy > 0 && pm.valid_rect.height + dy < a.height)
    then pm.valid_rect <- empty_rectangle
    else if not (rectangle_is_empty pm.valid_rect)
    then (
      (*XXX FIX: should redraw up to four rectangles here *)
      (*XXX FIX: does not change pm.valid_rect when it is large enough already and valid *)
      let p = get_pixmap pm in
      let r = pm.valid_rect in
      (*
Format.eprintf "Translation: %d %d@." dx dy;
*)
      if dx <> 0 || dy <> 0
      then
        put_pixmap
          ~dst:(drawable_of_pixmap p)
          ~x:dx
          ~y:dy
          ~xsrc:0
          ~ysrc:0
          ~width:r.width
          ~height:r.height
          p;
      let offset p l d m =
        (* 0 <= p; 0 <= l; p + l <= m *)
        if p + d + l <= 0
        then 0, 0
        else if p + d < 0
        then 0, l + p + d
        else if p + d >= m
        then m, 0
        else if p + d + l > m
        then p + d, m - p - d
        else p + d, l
      in
      let x, width = offset 0 r.width dx pm.p_width in
      let y, height = offset 0 r.height dy pm.p_height in
      if height > 0
      then
        if x > 0
        then (
          assert (x + width >= a.width);
          redraw st scale x0 y0 0 y x height)
        else (
          assert (x = 0);
          if a.width > width then redraw st scale x0 y0 width y (a.width - width) height);
      if y > 0
      then (
        assert (y + height >= a.height);
        redraw st scale x0 y0 0 0 a.width y)
      else (
        assert (y = 0);
        if a.height > height
        then redraw st scale x0 y0 0 height a.width (a.height - height));
      pm.valid_rect <- { x = x0; y = y0; width = a.width; height = a.height });
    let r = pm.valid_rect in
    if x < 0 || y < 0 || x + width > r.width || y + height > r.height
    then (
      redraw st scale x0 y0 0 0 a.width a.height;
      pm.valid_rect <- { x = x0; y = y0; width = a.width; height = a.height });
    put_pixmap
      ~dst:(get_drawable window)
      ~x
      ~y
      ~xsrc:x
      ~ysrc:y
      ~width
      ~height
      (get_pixmap pm)
end