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