(* 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 begin let old_p = pm.pixmap in let p = M.make_pixmap window width height in let r = pm.valid_rect in begin 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 -> () end; pm.pixmap <- Some p; pm.p_width <- width; pm.p_height <- height end 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 = begin match fill with Some c -> M.fill ctx c | None -> () end; begin match stroke with Some c -> M.stroke ctx c | None -> () end 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 cx cy; scale ctx rx ry; arc ctx 0. 0. 1. 0. (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 compute_scale st range = st.zoom_factor ** range#adjustment#value /. st.zoom_factor 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 (float x') (float y') (float w) (float h); M.fill ctx M.white; clip ctx; let x = float x /. scale in let y = float y /. scale in M.scale ctx scale scale; translate ctx (-. st.st_x -. x) (-. 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 begin pm.valid_rect <- empty_rectangle end else if not (rectangle_is_empty pm.valid_rect) then begin (*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 begin if x > 0 then begin assert (x + width >= a.width); redraw st scale x0 y0 0 y x height end else begin assert (x = 0); if a.width > width then redraw st scale x0 y0 width y (a.width - width) height end end; if y > 0 then begin assert (y + height >= a.height); redraw st scale x0 y0 0 0 a.width y; end else begin assert (y = 0); if a.height > height then redraw st scale x0 y0 0 height a.width (a.height - height) end; pm.valid_rect <- { x = x0; y = y0; width = a.width; height = a.height } end; let r = pm.valid_rect in if x < 0 || y < 0 || x + width > r.width || y + height > r.height then begin redraw st scale x0 y0 0 0 a.width a.height; pm.valid_rect <- {x = x0; y = y0; width = a.width; height = a.height }; end; put_pixmap ~dst:(get_drawable window) ~x ~y ~xsrc:x ~ysrc:y ~width ~height (get_pixmap pm) end