summaryrefslogtreecommitdiff
path: root/cesar/common/tools/sdl2dot
diff options
context:
space:
mode:
Diffstat (limited to 'cesar/common/tools/sdl2dot')
-rwxr-xr-xcesar/common/tools/sdl2dot227
1 files changed, 227 insertions, 0 deletions
diff --git a/cesar/common/tools/sdl2dot b/cesar/common/tools/sdl2dot
new file mode 100755
index 0000000000..1d86c14d59
--- /dev/null
+++ b/cesar/common/tools/sdl2dot
@@ -0,0 +1,227 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+my %re = (
+ start => qr/\(\((.*?)\)\)/,
+ pstart => qr/\(\|(.*?)\|\)/,
+ state => qr/\(([^(|X].*?)\)/,
+ call => qr/\|\|(.+?)\|\|/,
+ task => qr/\|([^|%X].*?)\|/,
+ toright => qr/\|(.+?)>/,
+ toleft => qr/<(.+?)\|/,
+ fromright => qr/\|(.+?)</,
+ fromleft => qr/>(.+?)\|/,
+ cond => qr/<(.+?)>/,
+ stop => qr/X(.*?)X/,
+ connector => qr/O(.*?)O/,
+ pstop => qr/\(X(.*?)X\)/,
+ set => qr/\|%(.*?)\|/,
+ 'reset' => qr/\|X(.*?)\|/,
+ 'continue' => qr/\.\.\./,
+);
+my $renode = qr/(?:
+ \( [^(|X].*? \)
+ | \(\( .*? \)\)
+ | \(\| .*? \|\)
+ | \(X .*? X\)
+ | \| [^|%X].*? [|<>]
+ | \|\| .+? \|\|
+ | [<>] .+? [|>]
+ | X .*? X
+ | O .*? O
+ | \|% .*? \|
+ | \|X .*? \|
+ | \.\.\.
+ )/x;
+
+my @edges;
+my %nodes;
+my $name;
+my $using = '';
+
+my $continue_node;
+while (<>)
+{
+ chomp;
+ my $last_node;
+ my %last_edge;
+ next if /^\s*$/;
+ do { $name = $1; next; } if /^\s*# (.+)$/ and !defined $name;
+ do { $using = $1; next; } if /^\s*(\w*):$/;
+ while (1)
+ {
+ unless (/\G\s*($renode)/gc)
+ {
+ /\G(.{0,10})/;
+ die "invalid line \"...$1...\"";
+ }
+ my ($node, $label);
+ for my $k (keys %re)
+ {
+ if ($1 =~ /^$re{$k}$/)
+ {
+ if ($k eq 'continue')
+ {
+ die "invalid continuation" unless defined $continue_node;
+ $node = $continue_node;
+ last;
+ }
+ $node = $1;
+ $node =~ /(?:.*:)?(.*)/;
+ $label = $1;
+ $node = $using . $node if $node =~ /^:.*$/;
+ if (exists $nodes{$node})
+ {
+ !exists $nodes{$node}{node}
+ and $nodes{$node}{node} = $k;
+ $nodes{$node}{node} eq $k
+ or die "changed node type for \"$node\"";
+ }
+ else
+ {
+ $nodes{$node} = { label => $label, node => $k };
+ }
+ #print " n $node $k\n";
+ last;
+ }
+ }
+ defined $node or die 'invalid node';
+ if (defined $last_node)
+ {
+ if ($nodes{$node}{node} eq 'stop')
+ {
+ $last_edge{attr} = 'arrowhead = none, headclip = false';
+ }
+ push @edges, { from => $last_node, to => $node, %last_edge };
+ }
+ $last_node = $node;
+ if (/\G\s*$/)
+ {
+ last;
+ }
+ elsif (/\G\s*--->/gc)
+ {
+ %last_edge = (edge => 'long');
+ }
+ elsif (/\G\s*->/gc)
+ {
+ %last_edge = (edge => 'short');
+ }
+ elsif (/\G\s*--(.*?)->/gc)
+ {
+ %last_edge = (edge => 'longc', cond => $1);
+ }
+ elsif (/\G\s*-(.*?)->/gc)
+ {
+ %last_edge = (edge => 'shortc', cond => $1);
+ }
+ else
+ {
+ /\G(.{0,10})/;
+ die "invalid edge \"$1...\"";
+ }
+ }
+ $continue_node = $last_node;
+}
+
+my %render = (
+ start => sub {
+ my ($n, $l) = @_;
+ $l = ' ' x 16 unless $l;
+ "\t\"$n\" [ shape=sdl_start, label=\"$l\" ]\n";
+ },
+ pstart => sub {
+ my ($n, $l) = @_;
+ $l = ' ' x 12 unless $l;
+ "\t\"$n\" [ shape=sdl_procedure_start, label=\" $l \" ]\n";
+ },
+ state => sub {
+ my ($n, $l) = @_;
+ "\t\"$n\" [ shape=sdl_state, style=filled, fillcolor=lavender, label=\"$l\" ]\n";
+ },
+ call => sub {
+ my ($n, $l) = @_;
+ "\t\"$n\" [ shape=sdl_call, label=\" $l \" ]\n";
+ },
+ task => sub {
+ my ($n, $l) = @_;
+ "\t\"$n\" [ shape=sdl_task, label=\"$l\" ]\n";
+ },
+ toright => sub {
+ my ($n, $l) = @_;
+ "\t\"$n\" [ shape=sdl_output_to_right, label=\"$l \" ]\n";
+ },
+ toleft => sub {
+ my ($n, $l) = @_;
+ "\t\"$n\" [ shape=sdl_output_to_left, label=\" $l\" ]\n";
+ },
+ fromright => sub {
+ my ($n, $l) = @_;
+ "\t\"$n\" [ shape=sdl_input_from_right, label=\"$l \" ]\n";
+ },
+ fromleft => sub {
+ my ($n, $l) = @_;
+ "\t\"$n\" [ shape=sdl_input_from_left, label=\" $l\" ]\n";
+ },
+ cond => sub {
+ my ($n, $l) = @_;
+ "\t\"$n\" [ shape=diamond, peripheries=1, label=\"$l\" ]\n";
+ },
+ stop => sub {
+ my ($n, $l) = @_;
+ "\t\"$n\" [ shape=sdl_stop, label=\"$l\" ]\n";
+ },
+ connector => sub {
+ my ($n, $l) = @_;
+ "\t\"$n\" [ shape=sdl_connector, label=\"$l\" ]\n";
+ },
+ pstop => sub {
+ my ($n, $l) = @_;
+ "\t\"$n\" [ shape=sdl_return, label=\"$l\" ]\n";
+ },
+ set => sub {
+ my ($n, $l) = @_;
+ "\t\"$n\" [ shape=sdl_set, label=\" $l\" ]\n";
+ },
+ 'reset' => sub {
+ my ($n, $l) = @_;
+ "\t\"$n\" [ shape=sdl_reset, label=\" $l\" ]\n";
+ },
+ short => sub {
+ my ($f, $t, $a) = @_;
+ $a = " [ $a ]" if $a;
+ "\t\"$f\" -> \"$t\"$a\n";
+ },
+ shortc => sub {
+ my ($f, $t, $a, $c) = @_;
+ $a = ", $a" if $a;
+ "\t\"$f\" -> \"$t\" [ label=\"$c\"$a ]\n";
+ },
+ long => sub {
+ my ($f, $t, $a) = @_;
+ $a = ", $a" if $a;
+ "\t\"$f\" -> \"$t\" [ weight=0.8$a ]\n";
+ },
+ longc => sub {
+ my ($f, $t, $a, $c) = @_;
+ $a = ", $a" if $a;
+ "\t\"$f\" -> \"$t\" [ weight=0.8, label=\"$c\"$a ]\n";
+ },
+);
+
+$name = 'noname' unless defined $name;
+print <<EOF;
+digraph $name {
+\tnode [ peripheries=0 ]
+EOF
+for (@edges)
+{
+ print $render{$$_{edge}} ($$_{from}, $$_{to}, exists $$_{attr} ? $$_{attr} : '', $$_{cond});
+}
+for (keys %nodes)
+{
+ print $render{$nodes{$_}{node}} ($_, $nodes{$_}{label});
+}
+print "}\n";
+