#!/usr/bin/perl

require 5.003;

use strict 'subs';

use Getopt::Std;



# To customize the appearance of the source nodes in the postscript-file,
# modify $src_marker below according to what dot is able to process.
$src_marker = ", style=filled, color=lightblue";



#
# subroutines
#
sub check_switches {

    getopts('c:d:l:np:s:');
    $opt_c = 20     unless defined $opt_c and $opt_c > 0;       # default value
    $opt_l = "text" unless defined $opt_l;                      # default value
    $opt_s = "a4"   unless defined $opt_s;                      # default value

    if ($#ARGV or
	$opt_s !~ /^(a4|a3|long|large)$/i or
	$opt_l !~ /^(all|text|fail|path)$/i or
	(defined($opt_n) and defined($opt_p))) {

	print <<END;
Usage: $prg [options] wb_file

You may choose from the following options:

-c chars      minimum number of chars in a line of a labeled node (default: 20)
-d dot_file   write data to dot_file; overrides automatically generated name
-l labeltype  specify which kind of information you want to label the nodes
              with; labeltype must be one of four different choices:
   all        all available information
   text       descriptive text only (default)
   fail       failure types and other remarks
   path       nothing but path numbers
-n            do not execute 'dot -Tps dot_file -o ps_file' automatically,
              so you can customize dot_file before running the command above
-p ps_file    let dot create ps_file; overrides automatically generated name
-s size       size of graph; for individual graph format edit lines 4 to 7 in
              dot_file which begin with "page=", "size=", "rotate=", "rankdir="
   a4         put the whole graph on a single landscape page (default)
   a3         combine 2 portrait pages giving an A3 sized graph
   long       distribute a long narrow graph on 2 landscape pages
   large      create 3 portrait pages for a large graph

Switches -n and -p are mutually exclusive.

If no dot_file is specified with switch -d, wb_file minus suffix ".txt" or
".wb" (if present) plus suffix ".dot" gives the name of dot_file. Similarly,
dot_file minus suffix ".dot" plus suffix ".ps" gives the name of ps_file.

For comments send your e-mail to mhoehl\@rvs.uni-bielefeld.de
END

        exit 1;
    }

    $wb_file = $ARGV[0];
    if (defined $opt_d) {
	$dot_file = $opt_d;
    }
    else {
	$dot_file = $wb_file;
	$dot_file =~ s/\.(txt|wb)$//;
	$dot_file = "$dot_file.dot";
    }
    if (defined $opt_p) {
	$ps_file = $opt_p;
    }
    else {
	$ps_file = $dot_file;
	$ps_file =~ s/\.dot$//;
	$ps_file ="$ps_file.ps";
    }
}



sub read_line {
    do {
	unless ( defined($_ = <>) ) {
	    $end = 1;
	    last READ;
	}
	chomp;
	s/^\s+//;                                       # remove leading spaces
    } while /^$/;                                       # read past empty lines
}



sub is_node {
    return /^(\[|\<|\{|\()/;
}



sub is_conj {
    return /^(\/\\)/;
}



sub is_desc_start {
    return /^\/\*/;
}



sub is_desc_end {
    return /\*\//;
}



sub remove_conj {
    s/^(\/\\\s*)//;                                     # remove /\ and spaces
}



sub test_type {

    $type = "";
    $type = "event"   if (/^ (\[) (.*?) (\]) /x);       # []
    $type = "state"   if (/^ (\<) (.*?) (\>) /x);       # <>
    $type = "process" if (/^ (\{) (.*?) (\}) /x);       # {}
    $type = "unevent" if (/^ (\() (.*?) (\)) /x);       # ()
    unless ($type) {
	die "Left and right side of node specify different types.\nStopped";
    }

    $node = $2;                                         # store path number
    $_ = $';                                            # process rest of line
    s/\s+//;                                            # remove whitespaces
}



sub check_why {

    unless ($node =~ /^\d+(\.\d+)*$/) {                 # 1, 22.333, ...
	die "Why-node has wrong structure.\nStopped";
    }

    $first_why = $node unless defined( $last_why );     # safe first why-node

    $last_why = $node;
}



sub check_bec {

    unless ($node =~ /^(\d+)(\.\d+)*$/                  # 1, 22.333, ...
	    or  $node =~ /^(-)(\.\d+)$/) {              # -.1, -.22, ...
	die "Because-node has wrong structure.\nStopped";
    }

    # direct causes use "-" as abbreviation for parent why-node
    if ($1 eq "-") {
	$node = $last_why . $2;
	$store = 1;
    }
    # always store every single because-node of first why-node
    # even if its path number sais "x" instead of "-.x":
    # we don't expect it to be a link defined in an other place
    elsif ($last_why eq $first_why) { $store = 1; }
    else { $store = 0; }

    if ($store) {
	push @{ $cause_for{$last_why}{DIRECT} }, $node;
    }
    else {
	push @{ $cause_for{$last_why}{LINK} }, $node;
    }
}



sub search_why {

    unless (is_node) {
	die "Expected why-node has wrong type or is missing.\nStopped";
    }

    test_type;
    check_why;
}



sub search_bec {

    unless (is_node) {
	die "Expected because-node has wrong type or is missing.\nStopped";
    }

    test_type;
    check_bec;
}



sub store_node {

    $event  {$node} = $desc if $type eq "event";
    $state  {$node} = $desc if $type eq "state";
    $process{$node} = $desc if $type eq "process";
    $unevent{$node} = $desc if $type eq "unevent";
}



sub modify_desc {

    $desc =~ s/\/\*//;
    $desc =~ s/\*\///;
    if ($desc =~ /\/\*|\*\//) {
	die "Description has wrong format.\nStopped";
    }
    if ($opt_l =~ /^text$/i) { $desc =~ s/\/\/.*//; }
    if ($opt_l =~ /^fail$/i) {
	if ($desc !~ s/.*?\/\///) { $desc = ""; }
    }
    if ($opt_l =~ /^path$/i) { $desc = ""; }
    $desc =~ s/\/\// /g;             # replace // with blank
    $desc =~ s/\s{2,}/ /g;           # replace several spaces with single blank
    $desc =~ s/^\s//;                # remove whitespace at beginning of line
    $desc =~ s/\s$//;                # remove whitespace at end of line
    $desc =~ s/({|"|})/\\$1/g;       # safe { " } for dot by adding backslashes
    $desc =~ s/(.{$opt_c,}?)\s/$1\\n/g;
    # replace first whitespace after >= $opt_c characters with newline

    $desc = "$node\\n$desc";
}



sub search_desc {

    if ($store) {
	unless (is_desc_start) {
	    die "Expected description is missing.\nStopped";
	}

	$desc = $_;

      READ: {
	  if (is_desc_start and is_desc_end) { read_line; }
	  else {
	      until (is_desc_end) {
		  read_line;
		  $desc = "$desc $_";
	      }
	      read_line;
	  }
      }

	modify_desc;
	store_node;
    }
    else {
	  READ: {
	      do {
		  if (is_desc_start) {
		      print "Unnecessary description ignored after link ";
		      print qq("$node" in line $..\n);
		      until (is_desc_end) { read_line; }
		  }
		  read_line;
	      } until (is_node or is_conj);
	  }
	}
    last ANALYZE if $end;
}



sub analyze {

    search_why;
    search_desc;
    for (;;) {
	if (is_conj) {
	    do {
		remove_conj;
		search_bec;
		search_desc;
	    } while (is_conj);
	}
	else {
	    search_bec;
	    search_desc;
	}
	search_why;
    }
}



sub mark_and_count {

    if (not defined @{ $cause_for{$node}{LINK} } and
	not defined @{ $cause_for{$node}{DIRECT} }) {
	print qq($src_marker];\n);
        $_[0]++;
    }
    else {
	print qq(];\n);
        $_[1]++;
    }
}



sub synthesize {

    open(OUTPUT, "> $dot_file") or
	die qq(Could not open "$dot_file" for writing.\nStopped);
    select(OUTPUT);
    $wb_file =~ s/\W+/_/g;               # name of digraph must be alphanumeric
    $size = "10.25,7.25",  $rot = 90 if $opt_s =~ /^a4$/i;
    $size = "14.5,10.25",  $rot =  0 if $opt_s =~ /^a3$/i;
    $size = "21.0,7.25",   $rot = 90 if $opt_s =~ /^long$/i;
    $size = "21.75,10.25", $rot =  0 if $opt_s =~ /^large$/i;

    print <<END;
digraph $wb_file {

margin="0.5,0.5";
page="8.25,11.5";
size="$size";
rotate=$rot;
rankdir=LR;
center=TRUE;
edge [dir=back];
END

    print "\nnode [shape=box];\n";
    foreach $node (sort keys %event) {
	print qq("$node" [label="$event{$node}");
	mark_and_count($src_event, $int_event);
    }

    print "\nnode [shape=polygon,sides=6];\n";
    foreach $node (sort keys %state) {
	print qq("$node" [label="$state{$node}");
	mark_and_count($src_state, $int_state);
    }

    print "\nnode [shape=polygon,sides=8];\n";
    foreach $node (sort keys %process) {
	print qq("$node" [label="$process{$node}");
	mark_and_count($src_process, $int_process);
    }

    print "\nnode [shape=ellipse];\n";
    foreach $node (sort keys %unevent) {
	print qq("$node" [label="$unevent{$node}");
	mark_and_count($src_unevent, $int_unevent);
    }

    print "\n";
    foreach $why (sort keys %cause_for) {
	foreach $type (sort keys %{ $cause_for{$why} }) {
	    if (defined @{ $cause_for{$why}{$type} }) {
		if ($type eq "LINK") {
		    foreach $bec (sort @{ $cause_for{$why}{$type} }) {
			print qq("$why" -> "$bec" [style=dashed];\n);
		    }
		}
		else {
		    print qq("$why" ->);
		    $todo = $max = $#{ $cause_for{$why}{$type} };
		    if ($max) { print " {"; }
		    foreach $bec (sort @{ $cause_for{$why}{$type} }) {
			print qq( "$bec");
			if ($todo--) { print ";"; }
		    }
		    if ($max) { print " };\n"; }
		    else { print ";\n"; }
		}
	    }
	}
    }

    foreach $node (sort keys %cause_for) {
	if (defined @{ $cause_for{$node}{DIRECT} }) {
	    $cnt_direct += @{ $cause_for{$node}{DIRECT} };
	}
	if (defined @{ $cause_for{$node}{LINK} }) {
	    $cnt_link += @{ $cause_for{$node}{LINK} };
	    foreach $link (@{ $cause_for{$node}{LINK} }) {
		unless (defined $event{$link} or
			defined $state{$link} or
			defined $process{$link} or
			defined $unevent{$link}) {
		    push @undef_link, $link;
		}
	    }
	}
    }

    print <<END;

subgraph addspace {

node [$inv_marker];
invis1;
invis2;
invis3;

}

subgraph clusterlegend {

label="Legend and Statistics";

node [shape=box];
int_event [label="$int_event internal events"];
src_event [label="$src_event source events"$src_marker];

node [shape=polygon,sides=6];
int_state [label="$int_state internal states"];
src_state [label="$src_state source states"$src_marker];

node [shape=polygon,sides=8];
int_process [label="$int_process internal processes"];
src_process [label="$src_process source processes"$src_marker];

node [shape=ellipse];
int_unevent [label="$int_unevent internal unevents"];
src_unevent [label="$src_unevent source unevents"$src_marker];

node [$inv_marker];
src_invis1;
int_invis1;
src_invis2;
int_invis2;

int_invis1 -> src_invis1 [label="$cnt_direct direct causes", weight=100];
int_invis2 -> src_invis2 [label="$cnt_link links", weight=100, style=dashed];

edge [style=invis];
int_event -> src_event;
int_state -> src_state;
int_process -> src_process;
int_unevent -> src_unevent;

}

}
END

    close(OUTPUT) or
	die qq(Could not close "$dot_file" after writing.\nStopped);
    select(STDOUT);
    print qq(Writing to "$dot_file" was succesful.\n\n);
}



sub summarize {

    $src = $src_event + $src_state + $src_process + $src_unevent;
    $int = $int_event + $int_state + $int_process + $int_unevent;
    $sum = $src + $int;

    print <<END;
The graph consists of $sum nodes (= $src source nodes + $int internal nodes).
The detailed readings are (source / internal):
$src_event / $int_event events,
$src_state / $int_state states,
$src_process / $int_process processes,
$src_unevent / $int_unevent unevents.
There are $cnt_direct direct causes and $cnt_link links.
END

    if (defined @undef_link) {
	print "\nThe graph contains at least one error! ";
	print "The following links are undefined:\n";
	foreach $link (@undef_link) { print "$link;   "; }
	print "\n";
    }
}



sub dot {

	unless ($opt_n) {
	    print "\nNow executing dot...\n";
	    system "/usr/local/bin/dot -Tps $dot_file -o $ps_file";
	    if ($?) {
		die qq(Could not generate "$ps_file".\nStopped);
	    }
	    print qq(Generation of "$ps_file" was succesful.\n);
	}
}



#
# initialisation
#
$| = 1;
open(STDERR, ">&STDOUT");

$prg = "wb2dot";
$store = 1;                               # store description of first why-node
$inv_marker = "label=\"\", style=invis";  # appearance of invisible nodes
$src_event = $src_state = $src_process = $src_unevent = 0;
$int_event = $int_state = $int_process = $int_unevent = 0;
$cnt_direct = $cnt_link = 0;



#
# main loop
#
print "This is $prg, version 1.0b   Written by Michael Hoehl in 1998.\n\n";

check_switches;

print qq(Processing "$wb_file"...\n);

ANALYZE: {
    read_line;
    analyze;
}

synthesize;

summarize;

dot;

exit 0;