liquid-fixpoint-0.1.0.0: external/ocamlgraph/src/graphviz.ml
(**************************************************************************)
(* *)
(* Ocamlgraph: a generic graph library for OCaml *)
(* Copyright (C) 2004-2007 *)
(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software 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. *)
(* *)
(**************************************************************************)
(* $Id: graphviz.ml,v 1.4 2006-05-09 10:19:37 conchon Exp $ *)
(** Interface with {i GraphViz}
This module provides a basic interface with dot and neato,
two programs of the GraphViz toolbox.
These tools are available at the following URLs:
http://www.graphviz.org/
http://www.research.att.com/sw/tools/graphviz/
*)
open Format
(***************************************************************************)
(** {2 Common stuff} *)
(** Because the neato and dot engines present a lot of common points -
in particular in the graph description language, large parts of
the code is shared. First, the [!CommonAttributes] module defines
attributes of graphs, nodes and edges that are understood by the
two engines. Second, given a module (of type [!ENGINE])
describing an engine the [!MakeEngine] functor provides suitable
interface function for it. *)
(*-------------------------------------------------------------------------*)
(** {3 Common attributes} *)
type color = int
let fprint_color ppf color =
fprintf ppf "\"#%06X\"" color
let fprint_string ppf s = fprintf ppf "\"%s\"" s
(* let s' = String.escaped s in
if s' = s && s <> ""
then fprintf ppf "%s" s
else fprintf ppf "\"%s\"" s'*)
let fprint_string_user ppf s =
(* let s = String.escaped s in*)
fprintf ppf "\"%s\"" s
type arrow_style =
[ `None | `Normal | `Inv | `Dot | `Odot | `Invdot | `Invodot ]
let fprint_arrow_style ppf = function
`None -> fprintf ppf "none"
| `Normal -> fprintf ppf "normal"
| `Inv -> fprintf ppf "inv"
| `Dot -> fprintf ppf "dot"
| `Odot -> fprintf ppf "odot"
| `Invdot -> fprintf ppf "invdot"
| `Invodot -> fprintf ppf "invodot"
let fprint_dir ppf = function
`TopToBottom -> fprintf ppf "TB"
| `LeftToRight -> fprintf ppf "LR"
(** The [ATTRIBUTES] module type defines the interface for the engines. *)
module type ATTRIBUTES = sig
type graph (** Attributes of graphs. *)
type vertex (** Attributes of vertices. *)
type edge (** Attributes of edges. *)
(** Attributes of (optional) boxes around vertices. *)
type subgraph = {
sg_name : string; (** Box name. *)
sg_attributes : vertex list; (** Box attributes. *)
}
end
(** The [CommonAttributes] module defines attributes for graphs, nodes and
edges that are available in the two engines, dot and neato. *)
module CommonAttributes = struct
(** Attributes of graphs. *)
type graph =
[ `Center of bool
(** Centers the drawing on the page. Default value is [false]. *)
| `Fontcolor of color
(** Sets the font color. Default value is [black]. *)
| `Fontname of string
(** Sets the font family name. Default value is ["Times-Roman"]. *)
| `Fontsize of int
(** Sets the type size (in points). Default value is [14]. *)
| `Label of string
(** Caption for graph drawing. *)
| `Orientation of [ `Portrait | `Landscape ]
(** Sets the page orientation. Default value is [`Portrait]. *)
| `Page of float * float
(** Sets the PostScript pagination unit, e.g [8.5, 11.0]. *)
| `Pagedir of [ `TopToBottom | `LeftToRight ]
(** Traversal order of pages. Default value is [`TopToBottom]. *)
| `Size of float * float
(** Sets the bounding box of drawing (in inches). *)
| `OrderingOut
(** Constrains order of out-edges in a subgraph according to
their file sequence *)
]
(** Attributes of nodes. *)
type vertex =
[ `Color of color
(** Sets the color of the border of the node. Default value is [black]
*)
| `Fontcolor of color
(** Sets the label font color. Default value is [black]. *)
| `Fontname of string
(** Sets the label font family name. Default value is
["Times-Roman"]. *)
| `Fontsize of int
(** Sets the label type size (in points). Default value is [14]. *)
| `Height of float
(** Sets the minimum height. Default value is [0.5]. *)
| `Label of string
(** Sets the label printed in the node. The string may include escaped
newlines [\n], [\l], or [\r] for center, left, and right justified
lines.
Record labels may contain recursive box lists delimited by { | }.
*)
| `Orientation of float
(** Node rotation angle, in degrees. Default value is [0.0]. *)
| `Peripheries of int
(** Sets the number of periphery lines drawn around the polygon. *)
| `Regular of bool
(** If [true], then the polygon is made regular, i.e. symmetric about
the x and y axis, otherwise the polygon takes on the aspect
ratio of the label. Default value is [false]. *)
| `Shape of
[`Ellipse | `Box | `Circle | `Doublecircle | `Diamond
| `Plaintext | `Record | `Polygon of int * float]
(** Sets the shape of the node. Default value is [`Ellipse].
[`Polygon (i, f)] draws a polygon with [n] sides and a skewing
of [f]. *)
| `Style of [ `Filled | `Solid | `Dashed | `Dotted | `Bold | `Invis ]
(** Sets the layout style of the node. Several styles may be combined
simultaneously. *)
| `Width of float
(** Sets the minimum width. Default value is [0.75]. *)
]
(** Attributes of edges. *)
type edge =
[ `Color of color
(** Sets the edge stroke color. Default value is [black]. *)
| `Decorate of bool
(** If [true], draws a line connecting labels with their edges. *)
| `Dir of [ `Forward | `Back | `Both | `None ]
(** Sets arrow direction. Default value is [`Forward]. *)
| `Fontcolor of color
(** Sets the label font color. Default value is [black]. *)
| `Fontname of string
(** Sets the label font family name. Default value is
["Times-Roman"]. *)
| `Fontsize of int
(** Sets the label type size (in points). Default value is [14]. *)
| `Label of string
(** Sets the label to be attached to the edge. The string may include
escaped newlines [\n], [\l], or [\r] for centered, left, or right
justified lines. *)
| `Labelfontcolor of color
(** Sets the font color for head and tail labels. Default value is
[black]. *)
| `Labelfontname of string
(** Sets the font family name for head and tail labels. Default
value is ["Times-Roman"]. *)
| `Labelfontsize of int
(** Sets the font size for head and tail labels (in points).
Default value is [14]. *)
| `Style of [ `Solid | `Dashed | `Dotted | `Bold | `Invis ]
(** Sets the layout style of the edge. Several styles may be combined
simultaneously. *)
]
(** Pretty-print. *)
let fprint_orientation ppf = function
`Portrait -> fprintf ppf "portrait"
| `Landscape -> fprintf ppf "landscape"
let fprint_graph ppf = function
`Center b -> fprintf ppf "center=%i" (if b then 1 else 0)
| `Fontcolor a -> fprintf ppf "fontcolor=%a" fprint_color a
| `Fontname s -> fprintf ppf "fontname=%a" fprint_string s
| `Fontsize i -> fprintf ppf "fontsize=%i" i
| `Label s -> fprintf ppf "label=%a" fprint_string_user s
| `Orientation a -> fprintf ppf "orientation=%a" fprint_orientation a
| `Page (x, y) -> fprintf ppf "page=\"%f,%f\"" x y
| `Pagedir a -> fprintf ppf "pagedir=%a" fprint_dir a
| `Size (x, y) -> fprintf ppf "size=\"%f,%f\"" x y
| `OrderingOut -> fprintf ppf "ordering=out"
let fprint_shape ppf = function
| `Ellipse -> fprintf ppf "ellipse"
| `Box -> fprintf ppf "box"
| `Circle -> fprintf ppf "circle"
| `Doublecircle -> fprintf ppf "doublecircle"
| `Diamond -> fprintf ppf "diamond"
| `Plaintext -> fprintf ppf "plaintext"
| `Record -> fprintf ppf "record"
| `Polygon (i, f) -> fprintf ppf "polygon, sides=%i, skew=%f" i f
let fprint_node_style ppf = function
`Filled -> fprintf ppf "filled"
| `Solid -> fprintf ppf "solid"
| `Dashed -> fprintf ppf "dashed"
| `Dotted -> fprintf ppf "dotted"
| `Bold -> fprintf ppf "bold"
| `Invis -> fprintf ppf "invis"
let fprint_vertex ppf = function
`Color a -> fprintf ppf "color=%a" fprint_color a
| `Fontcolor a -> fprintf ppf "fontcolor=%a" fprint_color a
| `Fontname s -> fprintf ppf "fontname=%a" fprint_string s
| `Fontsize i -> fprintf ppf "fontsize=%i" i
| `Height f -> fprintf ppf "height=%f" f
| `Label s -> fprintf ppf "label=%a" fprint_string_user s
| `Orientation f -> fprintf ppf "orientation=%f" f
| `Peripheries i -> fprintf ppf "peripheries=%i" i
| `Regular b -> fprintf ppf "regular=%b" b
| `Shape a -> fprintf ppf "shape=%a" fprint_shape a
| `Style a -> fprintf ppf "style=%a" fprint_node_style a
| `Width f -> fprintf ppf "width=%f" f
let fprint_edge_style =
fprint_node_style
let fprint_arrow_direction ppf = function
`Forward -> fprintf ppf "forward"
| `Back -> fprintf ppf "back"
| `Both -> fprintf ppf "both"
| `None -> fprintf ppf "none"
let fprint_edge ppf = function
`Color a -> fprintf ppf "color=%a" fprint_color a
| `Decorate b -> fprintf ppf "decorate=%b" b
| `Dir a -> fprintf ppf "dir=%a" fprint_arrow_direction a
| `Fontcolor a -> fprintf ppf "fontcolor=%a" fprint_color a
| `Fontname s -> fprintf ppf "fontname=%a" fprint_string s
| `Fontsize i -> fprintf ppf "fontsize=%i" i
| `Label s -> fprintf ppf "label=%a" fprint_string_user s
| `Labelfontcolor a -> fprintf ppf "labelfontcolor=%a" fprint_color a
| `Labelfontname s -> fprintf ppf "labelfontname=\"%s\"" s
(* (String.escaped s) *)
| `Labelfontsize i -> fprintf ppf "labelfontsize=%i" i
| `Style a -> fprintf ppf "style=%a" fprint_edge_style a
end
(*-------------------------------------------------------------------------*)
(** {3 The [MakeEngine] functor} *)
(** An engine is described by a module of the following signature. *)
module type ENGINE = sig
module Attributes : sig
include ATTRIBUTES
val fprint_graph:formatter -> graph -> unit
val fprint_vertex: formatter -> vertex -> unit
val fprint_edge: formatter -> edge -> unit
end
(** The litteral name of the engine. *)
val name: string
(** The keyword for graphs ("digraph" for dot, "graph" for neato) *)
val opening: string
(** The litteral for edge arrows ("->" for dot, "--" for neato) *)
val edge_arrow: string
end
module type GRAPH = sig
end
module MakeEngine
(EN: ENGINE)
(X : sig
type t
module V : sig type t end
module E : sig type t val src : t -> V.t val dst : t -> V.t end
val iter_vertex : (V.t -> unit) -> t -> unit
val iter_edges_e : (E.t -> unit) -> t -> unit
val graph_attributes: t -> EN.Attributes.graph list
val default_vertex_attributes: t -> EN.Attributes.vertex list
val vertex_name : V.t -> string
val vertex_attributes: V.t -> EN.Attributes.vertex list
val default_edge_attributes: t -> EN.Attributes.edge list
val edge_attributes: E.t -> EN.Attributes.edge list
val get_subgraph : V.t -> EN.Attributes.subgraph option
end) =
struct
let command = ref EN.name
let set_command cmd =
command := cmd
exception Error of string
let handle_error f arg =
try
f arg
with
Error msg ->
Printf.eprintf "%s: %s failure\n %s\n"
Sys.argv.(0) EN.name msg;
flush stderr;
exit 2
(** [fprint_graph_attributes ppf list] pretty prints a list of
graph attributes on the formatter [ppf]. Attributes are separated
by a ";". *)
let fprint_graph_attributes ppf list =
List.iter (function att ->
fprintf ppf "%a;@ " EN.Attributes.fprint_graph att
) list
(** [fprint_graph_attribute printer ppf list] pretty prints a list of
attributes on the formatter [ppf], using the printer [printer] for
each attribute. The list appears between brackets and attributes
are speparated by ",". If the list is empty, nothing is printed. *)
let fprint_attributes fprint_attribute ppf = function
[] -> ()
| hd :: tl ->
let rec fprint_attributes_rec ppf = function
[] -> ()
| hd' :: tl' ->
fprintf ppf ",@ %a%a"
fprint_attribute hd'
fprint_attributes_rec tl'
in
fprintf ppf " [@[<hov>%a%a@]]"
fprint_attribute hd
fprint_attributes_rec tl
(** [fprint_graph_attributes ppf list] pretty prints a list of
node attributes using the format of [fprint_attributes]. *)
let fprint_node_attributes ppf list =
fprint_attributes EN.Attributes.fprint_vertex ppf list
(** [fprint_graph_attributes ppf list] pretty prints a list of
edge attributes using the format of [fprint_attributes]. *)
let fprint_edge_attributes ppf list =
fprint_attributes EN.Attributes.fprint_edge ppf list
(** [fprint_graph ppf graph] pretty prints the graph [graph] in
the CGL language on the formatter [ppf]. *)
let fprint_graph ppf graph =
let subgraphs = Hashtbl.create 7 in
(* Printing nodes. *)
let print_nodes ppf =
let default_node_attributes = X.default_vertex_attributes graph in
if default_node_attributes <> [] then
fprintf ppf "node%a;@ "
fprint_node_attributes default_node_attributes;
X.iter_vertex
(function node ->
begin match X.get_subgraph node with
| None -> ()
| Some sg ->
try
let (sg,nodes) =
Hashtbl.find subgraphs sg.EN.Attributes.sg_name
in
Hashtbl.replace subgraphs
sg.EN.Attributes.sg_name (sg,node::nodes)
with Not_found ->
Hashtbl.add subgraphs sg.EN.Attributes.sg_name (sg,[node])
end;
fprintf ppf "%s%a;@ "
(X.vertex_name node)
fprint_node_attributes (X.vertex_attributes node))
graph
in
(* Printing subgraphs *)
let print_subgraphs ppf =
Hashtbl.iter
(fun name (sg,nodes) ->
fprintf ppf "@[<v 2>subgraph cluster_%s { %t%t };@]@\n"
name
(fun ppf ->
(List.iter
(fun n ->
fprintf ppf "%a;@\n" EN.Attributes.fprint_vertex n)
sg.EN.Attributes.sg_attributes))
(fun ppf ->
(List.iter
(fun n -> fprintf ppf "%s;" (X.vertex_name n))
nodes))
)
subgraphs
in
(* Printing edges *)
let print_edges ppf =
let default_edge_attributes = X.default_edge_attributes graph in
if default_edge_attributes <> [] then
fprintf ppf "edge%a;@ "
fprint_edge_attributes default_edge_attributes;
X.iter_edges_e (function edge ->
fprintf ppf "%s %s %s%a;@ "
(X.vertex_name (X.E.src edge))
EN.edge_arrow
(X.vertex_name (X.E.dst edge))
fprint_edge_attributes (X.edge_attributes edge)
) graph
in
fprintf ppf "@[<v>%s G {@ @[<v 2> %a"
EN.opening
fprint_graph_attributes (X.graph_attributes graph);
fprintf ppf "%t@ " print_nodes;
fprintf ppf "%t@ " print_subgraphs;
fprintf ppf "%t@ " print_edges;
fprintf ppf "@]}@]"
(** [output_graph oc graph] pretty prints the graph [graph] in the dot
language on the channel [oc]. *)
let output_graph oc graph =
let ppf = formatter_of_out_channel oc in
fprint_graph ppf graph;
pp_print_flush ppf ()
end
(***************************************************************************)
(** {2 Interface with the dot engine} *)
(** The [DotAttributes] module defines attributes for graphs, nodes and edges
that are available in the dot engine. *)
module DotAttributes = struct
(** Attributes of graphs. They include all common graph attributes and
several specific ones. All attributes described in the "dot User's
Manual, February 4, 2002" are handled, excepted: clusterank, color,
compound, labeljust, labelloc, ordering, rank, remincross, rotate,
searchsize and style.
*)
type graph =
[ CommonAttributes.graph
| `Bgcolor of color
(** Sets the background color and the inital fill color. *)
| `Comment of string
(** Comment string. *)
| `Concentrate of bool
(** If [true], enables edge concentrators. Default value is [false]. *)
| `Fontpath of string
(** List of directories for fonts. *)
| `Layers of string list
(** List of layers. *)
| `Margin of float
(** Sets the page margin (included in the page size). Default value is
[0.5]. *)
| `Mclimit of float
(** Scale factor for mincross iterations. Default value is [1.0]. *)
| `Nodesep of float
(** Sets the minimum separation between nodes, in inches. Default
value is [0.25]. *)
| `Nslimit of int
(** If set of [f], bounds network simplex iterations by [f *
<number of nodes>] when ranking nodes. *)
| `Nslimit1 of int
(** If set of [f], bounds network simplex iterations by [f *
<number of nodes>] when setting x-coordinates. *)
| `Ranksep of float
(** Sets the minimum separation between ranks. *)
| `Quantum of float
(** If not [0.0], node label dimensions will be rounded to integral
multiples of it. Default value is [0.0]. *)
| `Rankdir of [ `TopToBottom | `LeftToRight ]
(** Direction of rank ordering. Default value is [`TopToBottom]. *)
| `Ratio of [ `Float of float | `Fill | `Compress| `Auto ]
(** Sets the aspect ratio. *)
| `Samplepoints of int
(** Number of points used to represent ellipses and circles on output.
Default value is [8]. *)
| `Url of string
(** URL associated with graph (format-dependent). *)
]
(** Attributes of nodes. They include all common node attributes and
several specific ones. All attributes described in the "dot User's
Manual, February 4, 2002" are handled, excepted: bottomlabel, group,
shapefile and toplabel.
*)
type vertex =
[ CommonAttributes.vertex
| `Comment of string
(** Comment string. *)
| `Distortion of float
(* TEMPORARY *)
| `Fillcolor of color
(** Sets the fill color (used when `Style filled). Default value
is [lightgrey]. *)
| `Fixedsize of bool
(** If [true], forces the given dimensions to be the actual ones.
Default value is [false]. *)
| `Layer of string
(** Overlay. *)
| `Url of string
(** The default url for image map files; in PostScript files,
the base URL for all relative URLs, as recognized by Acrobat
Distiller 3.0 and up. *)
| `Z of float
(** z coordinate for VRML output. *)
]
(** Attributes of edges. They include all common edge attributes and
several specific ones. All attributes described in the "dot User's
Manual, February 4, 2002" are handled, excepted: lhead and ltail.
*)
type edge =
[ CommonAttributes.edge
| `Arrowhead of arrow_style
(** Sets the style of the head arrow. Default value is [`Normal]. *)
| `Arrowsize of float
(** Sets the scaling factor of arrowheads. Default value is [1.0]. *)
| `Arrowtail of arrow_style
(** Sets the style of the tail arrow. Default value is [`Normal]. *)
| `Comment of string
(** Comment string. *)
| `Constraints of bool
(** If [false], causes an edge to be ignored for rank assignment.
Default value is [true]. *)
| `Headlabel of string
(** Sets the label attached to the head arrow. *)
| `Headport of [ `N | `NE | `E | `SE | `S | `SW | `W | `NW ]
(* TEMPORARY *)
| `Headurl of string
(** Url attached to head label if output format is ismap. *)
| `Labelangle of float
(** Angle in degrees which head or tail label is rotated off edge.
Default value is [-25.0]. *)
| `Labeldistance of float
(** Scaling factor for distance of head or tail label from node.
Default value is [1.0]. *)
| `Labelfloat of bool
(** If [true], lessen constraints on edge label placement.
Default value is [false]. *)
| `Layer of string
(** Overlay. *)
| `Minlen of int
(** Minimum rank distance between head an tail. Default value is [1]. *)
| `Samehead of string
(** Tag for head node; edge heads with the same tag are merged onto the
same port. *)
| `Sametail of string
(** Tag for tail node; edge tails with the same tag are merged onto the
same port. *)
| `Taillabel of string
(** Sets the label attached to the tail arrow. *)
| `Tailport of [ `N | `NE | `E | `SE | `S | `SW | `W | `NW ]
(* TEMPORARY *)
| `Tailurl of string
(** Url attached to tail label if output format is ismap. *)
| `Weight of int
(** Sets the integer cost of stretching the edge. Default value is
[1]. *)
]
type subgraph = {
sg_name : string;
sg_attributes : vertex list;
}
(** {4 Pretty-print of attributes} *)
let rec fprint_string_list ppf = function
[] -> ()
| [hd] -> fprintf ppf "%s" hd
| hd :: tl -> fprintf ppf "%s,%a" hd fprint_string_list tl
let fprint_ratio ppf = function
`Float f -> fprintf ppf "%f" f
| `Fill -> fprintf ppf "fill"
| `Compress -> fprintf ppf "compress"
| `Auto -> fprintf ppf "auto"
let fprint_graph ppf = function
#CommonAttributes.graph as att -> CommonAttributes.fprint_graph ppf att
| `Bgcolor a -> fprintf ppf "bgcolor=%a" fprint_color a
| `Comment s -> fprintf ppf "comment=%a" fprint_string s
| `Concentrate b -> fprintf ppf "concentrate=%b" b
| `Fontpath s -> fprintf ppf "fontpath=%a" fprint_string s
| `Layers s -> fprintf ppf "layers=%a" fprint_string_list s
| `Margin f -> fprintf ppf "margin=%f" f
| `Mclimit f -> fprintf ppf "mclimit=%f" f
| `Nodesep f -> fprintf ppf "nodesep=%f" f
| `Nslimit i -> fprintf ppf "nslimit=%i" i
| `Nslimit1 i -> fprintf ppf "nslimit1=%i" i
| `Ranksep f -> fprintf ppf "ranksep=%f" f
| `Quantum f -> fprintf ppf "quantum=%f" f
| `Rankdir a -> fprintf ppf "rankdir=%a" fprint_dir a
| `Ratio a -> fprintf ppf "ratio=%a" fprint_ratio a
| `Samplepoints i -> fprintf ppf "samplepoints=%i" i
| `Url s -> fprintf ppf "URL=\"%s\"" s (*(String.escaped s)*)
let fprint_vertex ppf = function
#CommonAttributes.vertex as att ->
CommonAttributes.fprint_vertex ppf att
| `Comment s -> fprintf ppf "comment=%a" fprint_string s
| `Distortion f -> fprintf ppf "distortion=%f" f
| `Fillcolor a -> fprintf ppf "fillcolor=%a" fprint_color a
| `Fixedsize b -> fprintf ppf "fixedsize=%b" b
| `Layer s -> fprintf ppf "layer=%a" fprint_string s
| `Url s -> fprintf ppf "URL=\"%s\"" s (*(String.escaped s)*)
| `Z f -> fprintf ppf "z=%f" f
let fprint_port ppf = function
`N -> fprintf ppf "n"
| `NE -> fprintf ppf "ne"
| `E -> fprintf ppf "e"
| `SE -> fprintf ppf "se"
| `S -> fprintf ppf "s"
| `SW -> fprintf ppf "sw"
| `W -> fprintf ppf "w"
| `NW -> fprintf ppf "nw"
let fprint_edge ppf = function
#CommonAttributes.edge as att -> CommonAttributes.fprint_edge ppf att
| `Arrowhead a -> fprintf ppf "arrowhead=%a" fprint_arrow_style a
| `Arrowsize f -> fprintf ppf "arrowsize=%f" f
| `Arrowtail a -> fprintf ppf "arrowtail=%a" fprint_arrow_style a
| `Comment s -> fprintf ppf "comment=%a" fprint_string s
| `Constraints b -> fprintf ppf "constraints=%b" b
| `Headlabel s -> fprintf ppf "headlabel=%a" fprint_string s
| `Headport a -> fprintf ppf "headport=%a" fprint_port a
| `Headurl s -> fprintf ppf "headURL=%a" fprint_string s
| `Labelangle f -> fprintf ppf "labelangle=%f" f
| `Labeldistance f -> fprintf ppf "labeldistance=%f" f
| `Labelfloat b -> fprintf ppf "labelfloat=%b" b
| `Layer s -> fprintf ppf "layer=%a" fprint_string s
| `Minlen i -> fprintf ppf "minlen=%i" i
| `Samehead s -> fprintf ppf "samehead=%a" fprint_string s
| `Sametail s -> fprintf ppf "sametail=%a" fprint_string s
| `Taillabel s -> fprintf ppf "taillabel=%a" fprint_string s
| `Tailport a -> fprintf ppf "tailport=%a" fprint_port a
| `Tailurl s -> fprintf ppf "tailURL=%a" fprint_string s
| `Weight i -> fprintf ppf "weight=%i" i
end
module Dot =
MakeEngine (struct
module Attributes = DotAttributes
let name = "dot"
let opening = "digraph"
let edge_arrow = "->"
end)
(***************************************************************************)
(** {2 Interface with the neato engine} *)
(** The [NeatoAttributes] module defines attributes for graphs, nodes and edges
that are available in the neato engine. *)
module NeatoAttributes = struct
(** Attributes of graphs. They include all common graph attributes and
several specific ones. All attributes described in the "Neato User's
manual, April 10, 2002" are handled. *)
type graph =
[ CommonAttributes.graph
| `Margin of float * float
(** Sets the page margin (included in the page size). Default value is
[0.5, 0.5]. *)
| `Start of int
(** Seed for random number generator. *)
| `Overlap of bool
(** Default value is [true]. *)
| `Spline of bool
(** [true] makes edge splines if nodes don't overlap.
Default value is [false]. *)
| `Sep of float
(** Edge spline separation factor from nodes. Default value
is [0.0]. *)
]
(** Attributes of nodes. They include all common node attributes and
several specific ones. All attributes described in the "Neato User's
manual, April 10, 2002" are handled. *)
type vertex =
[ CommonAttributes.vertex
| `Pos of float * float
(** Initial coordinates of the node. *)
]
(** Attributes of edges. They include all common edge attributes and
several specific ones. All attributes described in the "Neato User's
manual, April 10, 2002" are handled. *)
type edge =
[ CommonAttributes.edge
| `Id of string
(** Optional value to distinguish multiple edges. *)
| `Len of float
(** Preferred length of edge. Default value is [1.0]. *)
| `Weight of float
(** Strength of edge spring. Default value is [1.0]. *)
]
type subgraph = {
sg_name : string;
sg_attributes : vertex list;
}
(** {4 Pretty-print of attributes} *)
let fprint_graph ppf = function
#CommonAttributes.graph as att -> CommonAttributes.fprint_graph ppf att
| `Margin (f1, f2) -> fprintf ppf "margin=\"%f,%f\"" f1 f2
| `Start i -> fprintf ppf "start=%i" i
| `Overlap b -> fprintf ppf "overlap=%b" b
| `Spline b -> fprintf ppf "spline=%b" b
| `Sep f -> fprintf ppf "sep=%f" f
let fprint_vertex ppf = function
#CommonAttributes.vertex as att ->
CommonAttributes.fprint_vertex ppf att
| `Pos (f1, f2) -> fprintf ppf "pos=\"%f,%f\"" f1 f2
let fprint_edge ppf = function
#CommonAttributes.edge as att -> CommonAttributes.fprint_edge ppf att
| `Id s -> fprintf ppf "id=%a" fprint_string s
| `Len f -> fprintf ppf "len=%f" f
| `Weight f -> fprintf ppf "weight=%f" f
end
module Neato =
MakeEngine (struct
module Attributes = NeatoAttributes
let name = "neato"
let opening = "graph"
let edge_arrow = "--"
end)