~ubuntu-branches/ubuntu/natty/ocamlgraph/natty : revision 20

15

(* *)

16

(**************************************************************************)

17

18

(* $Id: graphviz.ml,v 1.4 2006-05-09 10:19:37 conchon Exp $ *)

19

20

18

(** Interface with {i GraphViz}

21

19

22

20

This module provides a basic interface with dot and neato,

23

21

two programs of the GraphViz toolbox.

24

22

These tools are available at the following URLs:

25

23

http://www.graphviz.org/

26

http://www.research.att.com/sw/tools/graphviz/

27

28

*)

24

http://www.research.att.com/sw/tools/graphviz/ *)

29

25

30

26

open Format

27

open Pervasives (* for compatibility with ocaml 3.12.0+dev17

28

(incoming ocaml3.12) *)

31

29

32

30

(***************************************************************************)

33

31

(** {2 Common stuff} *)

59

57

fprintf ppf "\"%s\"" s

60

58

61

59

type arrow_style =

62

60

63

61

64

62

let fprint_arrow_style ppf = function

65

63

`None -> fprintf ppf "none"

83

81

84

82

type edge (** Attributes of edges. *)

85

83

86

(** Attributes of (optional) boxes around vertices. *)

84

(** Attributes of (optional) boxes around vertices. *)

87

85

type subgraph = {

88

86

sg_name : string; (** Box name. *)

89

87

sg_attributes : vertex list; (** Box attributes. *)

118

116

| `OrderingOut

119

117

(** Constrains order of out-edges in a subgraph according to

120

118

their file sequence *)

121

]

119

]

122

120

123

121

(** Attributes of nodes. *)

124

122

type vertex =

138

136

(** Sets the label printed in the node. The string may include escaped

139

137

newlines [\n], [\l], or [\r] for center, left, and right justified

140

138

lines.

141

Record labels may contain recursive box lists delimited by { | }.

139

Record labels may contain recursive box lists delimited by { | }.

142

140

*)

143

141

| `Orientation of float

144

142

(** Node rotation angle, in degrees. Default value is [0.0]. *)

159

157

simultaneously. *)

160

158

| `Width of float

161

159

(** Sets the minimum width. Default value is [0.75]. *)

162

]

160

]

163

161

164

162

(** Attributes of edges. *)

165

163

type edge =

167

165

(** Sets the edge stroke color. Default value is [black]. *)

168

166

| `Decorate of bool

169

167

(** If [true], draws a line connecting labels with their edges. *)

170

| `Dir of [ `Forward | `Back | `Both | `None ]

168

| `Dir of [ `Forward | `Back | `Both | `None ]

171

169

(** Sets arrow direction. Default value is [`Forward]. *)

172

170

| `Fontcolor of color

173

171

(** Sets the label font color. Default value is [black]. *)

187

185

(** Sets the font family name for head and tail labels. Default

188

186

value is ["Times-Roman"]. *)

189

187

| `Labelfontsize of int

190

(** Sets the font size for head and tail labels (in points).

188

(** Sets the font size for head and tail labels (in points).

191

189

Default value is [14]. *)

192

190

193

191

(** Sets the layout style of the edge. Several styles may be combined

194

192

simultaneously. *)

195

]

193

]

196

194

197

195

(** Pretty-print. *)

198

196

244

242

| `Style a -> fprintf ppf "style=%a" fprint_node_style a

245

243

| `Width f -> fprintf ppf "width=%f" f

246

244

247

let fprint_edge_style =

245

let fprint_edge_style =

248

246

fprint_node_style

249

247

250

248

let fprint_arrow_direction ppf = function

262

260

| `Fontsize i -> fprintf ppf "fontsize=%i" i

263

261

| `Label s -> fprintf ppf "label=%a" fprint_string_user s

264

262

| `Labelfontcolor a -> fprintf ppf "labelfontcolor=%a" fprint_color a

265

| `Labelfontname s -> fprintf ppf "labelfontname=\"%s\"" s

263

| `Labelfontname s -> fprintf ppf "labelfontname=\"%s\"" s

266

264

(* (String.escaped s) *)

267

265

| `Labelfontsize i -> fprintf ppf "labelfontsize=%i" i

268

266

| `Style a -> fprintf ppf "style=%a" fprint_edge_style a

277

275

module type ENGINE = sig

278

276

279

277

module Attributes : sig

280

include ATTRIBUTES

278

include ATTRIBUTES

281

279

val fprint_graph:formatter -> graph -> unit

282

280

val fprint_vertex: formatter -> vertex -> unit

283

281

val fprint_edge: formatter -> edge -> unit

284

282

end

285

283

286

(** The litteral name of the engine. *)

284

(** The litteral name of the engine. *)

287

285

val name: string

288

286

289

287

(** The keyword for graphs ("digraph" for dot, "graph" for neato) *)

304

302

type t

305

303

module V : sig type t end

306

304

module E : sig type t val src : t -> V.t val dst : t -> V.t end

307

305

308

306

val iter_vertex : (V.t -> unit) -> t -> unit

309

307

val iter_edges_e : (E.t -> unit) -> t -> unit

310

308

327

325

exception Error of string

328

326

329

327

let handle_error f arg =

330

try

328

try

331

329

f arg

332

with

330

with

333

331

Error msg ->

334

332

Printf.eprintf "%s: %s failure\n %s\n"

335

333

Sys.argv.(0) EN.name msg;

336

334

flush stderr;

337

335

exit 2

338

336

339

(** [fprint_graph_attributes ppf list] pretty prints a list of

337

(** [fprint_graph_attributes ppf list] pretty prints a list of

340

338

graph attributes on the formatter [ppf]. Attributes are separated

341

339

by a ";". *)

342

340

let fprint_graph_attributes ppf list =

344

342

fprintf ppf "%a;@ " EN.Attributes.fprint_graph att

345

343

) list

346

344

347

(** [fprint_graph_attribute printer ppf list] pretty prints a list of

345

(** [fprint_graph_attribute printer ppf list] pretty prints a list of

348

346

attributes on the formatter [ppf], using the printer [printer] for

349

347

each attribute. The list appears between brackets and attributes

350

348

are speparated by ",". If the list is empty, nothing is printed. *)

354

352

let rec fprint_attributes_rec ppf = function

355

353

[] -> ()

356

354

| hd' :: tl' ->

357

fprintf ppf ",@ %a%a"

355

fprintf ppf ",@ %a%a"

358

356

fprint_attribute hd'

359

357

fprint_attributes_rec tl'

360

358

in

362

360

fprint_attribute hd

363

361

fprint_attributes_rec tl

364

362

365

(** [fprint_graph_attributes ppf list] pretty prints a list of

363

(** [fprint_graph_attributes ppf list] pretty prints a list of

366

364

node attributes using the format of [fprint_attributes]. *)

367

let fprint_node_attributes ppf list =

365

let fprint_node_attributes ppf list =

368

366

fprint_attributes EN.Attributes.fprint_vertex ppf list

369

370

(** [fprint_graph_attributes ppf list] pretty prints a list of

367

368

(** [fprint_graph_attributes ppf list] pretty prints a list of

371

369

edge attributes using the format of [fprint_attributes]. *)

372

370

let fprint_edge_attributes ppf list =

373

371

fprint_attributes EN.Attributes.fprint_edge ppf list

375

373

(** [fprint_graph ppf graph] pretty prints the graph [graph] in

376

374

the CGL language on the formatter [ppf]. *)

377

375

let fprint_graph ppf graph =

378

let subgraphs = Hashtbl.create 7 in

376

let subgraphs = Hashtbl.create 7 in

379

377

380

378

(* Printing nodes. *)

381

379

383

381

384

382

let default_node_attributes = X.default_vertex_attributes graph in

385

383

if default_node_attributes <> [] then

386

fprintf ppf "node%a;@ "

384

fprintf ppf "node%a;@ "

387

385

fprint_node_attributes default_node_attributes;

388

386

389

X.iter_vertex

387

X.iter_vertex

390

388

(function node ->

391

begin match X.get_subgraph node with

389

begin match X.get_subgraph node with

392

390

| None -> ()

393

| Some sg ->

394

try

395

let (sg,nodes) =

396

Hashtbl.find subgraphs sg.EN.Attributes.sg_name

391

| Some sg ->

392

try

393

let (sg,nodes) =

394

Hashtbl.find subgraphs sg.EN.Attributes.sg_name

397

395

in

398

Hashtbl.replace subgraphs

396

Hashtbl.replace subgraphs

399

397

sg.EN.Attributes.sg_name (sg,node::nodes)

400

with Not_found ->

401

Hashtbl.add subgraphs sg.EN.Attributes.sg_name (sg,[node])

398

with Not_found ->

399

Hashtbl.add subgraphs sg.EN.Attributes.sg_name (sg,[node])

402

400

end;

403

fprintf ppf "%s%a;@ "

401

fprintf ppf "%s%a;@ "

404

402

(X.vertex_name node)

405

fprint_node_attributes (X.vertex_attributes node))

403

fprint_node_attributes (X.vertex_attributes node))

406

404

graph

407

405

408

406

in

409

407

410

408

(* Printing subgraphs *)

411

409

412

let print_subgraphs ppf =

410

let print_subgraphs ppf =

413

411

414

412

Hashtbl.iter

415

(fun name (sg,nodes) ->

413

(fun name (sg,nodes) ->

416

414

fprintf ppf "@[<v 2>subgraph cluster_%s { %t%t };@]@\n"

417

415

name

418

419

(fun ppf ->

420

(List.iter

421

(fun n ->

416

417

(fun ppf ->

418

(List.iter

419

(fun n ->

422

420

fprintf ppf "%a;@\n" EN.Attributes.fprint_vertex n)

423

421

sg.EN.Attributes.sg_attributes))

424

422

425

(fun ppf ->

426

(List.iter

423

(fun ppf ->

424

(List.iter

427

425

(fun n -> fprintf ppf "%s;" (X.vertex_name n))

428

426

nodes))

429

427

)

430

subgraphs

431

428

subgraphs

429

432

430

in

433

431

434

432

(* Printing edges *)

435

433

436

434

let print_edges ppf =

437

435

438

436

let default_edge_attributes = X.default_edge_attributes graph in

439

437

if default_edge_attributes <> [] then

440

fprintf ppf "edge%a;@ "

438

fprintf ppf "edge%a;@ "

441

439

fprint_edge_attributes default_edge_attributes;

442

440

443

441

X.iter_edges_e (function edge ->

521

519

Default value is [8]. *)

522

520

| `Url of string

523

521

(** URL associated with graph (format-dependent). *)

524

]

522

]

525

523

526

524

(** Attributes of nodes. They include all common node attributes and

527

525

several specific ones. All attributes described in the "dot User's

548

546

Distiller 3.0 and up. *)

549

547

| `Z of float

550

548

(** z coordinate for VRML output. *)

551

]

549

]

552

550

553

551

(** Attributes of edges. They include all common edge attributes and

554

552

several specific ones. All attributes described in the "dot User's

565

563

| `Comment of string

566

564

(** Comment string. *)

567

565

| `Constraints of bool

568

(** If [false], causes an edge to be ignored for rank assignment.

566

(** If [false], causes an edge to be ignored for rank assignment.

569

567

Default value is [true]. *)

570

568

| `Headlabel of string

571

569

(** Sets the label attached to the head arrow. *)

574

572

| `Headurl of string

575

573

(** Url attached to head label if output format is ismap. *)

576

574

| `Labelangle of float

577

(** Angle in degrees which head or tail label is rotated off edge.

575

(** Angle in degrees which head or tail label is rotated off edge.

578

576

Default value is [-25.0]. *)

579

577

| `Labeldistance of float

580

(** Scaling factor for distance of head or tail label from node.

578

(** Scaling factor for distance of head or tail label from node.

581

579

Default value is [1.0]. *)

582

580

| `Labelfloat of bool

583

(** If [true], lessen constraints on edge label placement.

581

(** If [true], lessen constraints on edge label placement.

584

582

Default value is [false]. *)

585

583

| `Layer of string

586

584

(** Overlay. *)

601

599

| `Weight of int

602

600

(** Sets the integer cost of stretching the edge. Default value is

603

601

[1]. *)

604

]

602

]

605

603

606

604

type subgraph = {

607

605

sg_name : string;

641

639

| `Url s -> fprintf ppf "URL=\"%s\"" s (*(String.escaped s)*)

642

640

643

641

let fprint_vertex ppf = function

644

#CommonAttributes.vertex as att ->

642

#CommonAttributes.vertex as att ->

645

643

CommonAttributes.fprint_vertex ppf att

646

644

| `Comment s -> fprintf ppf "comment=%a" fprint_string s

647

645

| `Distortion f -> fprintf ppf "distortion=%f" f

707

705

attributes. *)

708

706

end

709

707

710

module Dot =

708

module Dot =

711

709

MakeEngine (struct

712

710

module Attributes = DotAttributes

713

711

let name = "dot"

738

736

(** [true] makes edge splines if nodes don't overlap.

739

737

Default value is [false]. *)

740

738

| `Sep of float

741

(** Edge spline separation factor from nodes. Default value

739

(** Edge spline separation factor from nodes. Default value

742

740

is [0.0]. *)

743

]

741

]

744

742

745

743

(** Attributes of nodes. They include all common node attributes and

746

744

several specific ones. All attributes described in the "Neato User's

749

747

[ CommonAttributes.vertex

750

748

| `Pos of float * float

751

749

(** Initial coordinates of the node. *)

752

]

750

]

753

751

754

752

(** Attributes of edges. They include all common edge attributes and

755

753

several specific ones. All attributes described in the "Neato User's

762

760

(** Preferred length of edge. Default value is [1.0]. *)

763

761

| `Weight of float

764

762

(** Strength of edge spring. Default value is [1.0]. *)

765

]

763

]

766

764

767

765

type subgraph = {

768

766

sg_name : string;

780

778

| `Sep f -> fprintf ppf "sep=%f" f

781

779

782

780

let fprint_vertex ppf = function

783

#CommonAttributes.vertex as att ->

781

#CommonAttributes.vertex as att ->

784

782

CommonAttributes.fprint_vertex ppf att

785

783

| `Pos (f1, f2) -> fprintf ppf "pos=\"%f,%f\"" f1 f2

786

784

792

790

793

791

end

794

792

795

module Neato =

793

module Neato =

796

794

MakeEngine (struct

797

795

module Attributes = NeatoAttributes

798

796

let name = "neato"

799

797

let opening = "graph"

800

798

let edge_arrow = "--"

801

799

end)

800

801

(*

802

Local Variables:

803

compile-command: "make -C .."

804

End:

805

*)