1 (* COCANWIKI - a wiki written in Objective CAML.
2 * Written by Richard W.M. Jones <rich@merjis.com>.
3 * Copyright (C) 2004 Merjis Ltd.
4 * $Id: visualise_links.ml.,v 1.1 2004/10/21 11:42:04 rich Exp $
6 * This program is free software; you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation; either version 2 of the License, or
9 * (at your option) any later version.
11 * This program is distributed in the hope that it will be useful,
12 * but WITHOUT ANY WARRANTY; without even the implied warranty of
13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 * GNU General Public License for more details.
16 * You should have received a copy of the GNU General Public License
17 * along with this program; see the file COPYING. If not, write to
18 * the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 * Boston, MA 02111-1307, USA.
30 open Cocanwiki_template
33 let rec takepairs = function
35 | [x] -> invalid_arg "takepairs: odd number of elements in list"
36 | x :: y :: xs -> (x, y) :: takepairs xs
38 let run r (q : cgi) (dbh : Dbi.connection) hostid _ _ =
39 let template = get_template dbh hostid "visualise_links.html" in
41 (* This function generates a layout using the 'dot' program, part of
45 let sth = dbh#prepare_cached "select from_url, to_url from links
47 sth#execute [`Int hostid];
49 let edges = sth#map (function [`String from_url; `String to_url] ->
51 | _ -> assert false) in
58 (List.map (fun (node1, node2) ->
59 sprintf " \"%s\" -> \"%s\";\n" node1 node2)
63 let filename = output_tempfile dotfile in
64 let cmd = sprintf "dot -Tplain %s" filename in
66 let lines = pget cmd in
69 (* For documentation of the output format of 'dot -Tplain', please see:
70 * http://www.research.att.com/%7Eerg/graphviz/info/output.html#d:plain
72 (* Split each line up into fields. Unfortunately some fields are
73 * quoted (if they contain spaces or other special characters) so we
74 * have to deal with that.
77 let n = String.length line in
78 let rec skip_spaces i =
79 if i < n && line.[i] = ' ' then skip_spaces (i+1) else i
83 else if line.[i] = c then i
90 if c = '"' then ( (* quoted field *)
91 let j = find (i+1) '"' in
93 if i < j then String.sub line i (j-i), skip_spaces (j+1)
94 else String.sub line i (n-i), n in
96 ) else ( (* ordinary field *)
97 let j = find (i+1) ' ' in
99 if i < j then String.sub line i (j-i), skip_spaces j
100 else String.sub line i (n-i), n in
101 loop i (field :: acc)
107 let lines = List.map split lines in
109 (* First line is 'graph'. *)
110 let graph_line, lines = List.hd lines, List.tl lines in
112 match graph_line with
113 [ "graph"; _; width; height ] ->
114 float_of_string width, float_of_string height
115 | _ -> assert false in
117 (* Get the nodes and edges. *)
118 let is_node = function "node" :: _ -> true | _ -> false in
119 let is_edge = function "edge" :: _ -> true | _ -> false in
120 let nodes, edges = List.filter is_node lines, List.filter is_edge lines in
122 (* Process the nodes and edges. *)
123 let process_node = function
124 "node" :: url :: x :: y :: width :: height :: _ ->
125 url, (float_of_string x, float_of_string y,
126 float_of_string width, float_of_string height)
129 let nodes = List.map process_node nodes in
131 let process_edge = function
132 "edge" :: node1 :: node2 :: n :: rest ->
133 let n = int_of_string n in
135 List.map (fun (x, y) -> float_of_string x, float_of_string y)
136 (takepairs (List.take (n*2) rest)) in
140 let edges = List.map process_edge edges in
142 (* Scale the whole thing to 1000x1000 pixel coordinates. *)
143 let wscale = 1000. /. width in
144 let hscale = 1000. /. height in
146 let process_node (url, (x, y, width, height)) =
147 url, (x *. wscale, y *. hscale, width *. wscale, height *. hscale)
149 let nodes = List.map process_node nodes in
151 let process_edge (node1, node2, points) =
152 let process_point (x, y) = x *. wscale, y *. hscale in
153 node1, node2, List.map process_point points
155 let edges = List.map process_edge edges in
157 (* Return the layout. *)
158 let layout = nodes, edges in
162 (* XXX In future we are able to load this from the database. *)
163 let nodes, edges = gv_layout () in
166 List.map (fun (url, (x, y, width, height)) ->
167 [ "url", Template.VarString url;
168 "x", Template.VarString (string_of_float x);
169 "y", Template.VarString (string_of_float y);
170 "width", Template.VarString (string_of_float width);
171 "height", Template.VarString (string_of_float height) ])
174 template#table "nodes" table;
177 List.map (fun (node1, node2, points) ->
178 let xpoints, ypoints = List.split points in
181 [ "x", Template.VarString (string_of_float x) ])
185 [ "y", Template.VarString (string_of_float y) ])
188 [ "node1", Template.VarString node1;
189 "node2", Template.VarString node2;
190 "xpoints", Template.VarTable xpoints;
191 "ypoints", Template.VarTable ypoints; ])
194 template#table "edges" table;
205 register_script ~restrict:[CanEdit] run