#!/usr/bin/perl -w
use strict;
use warnings;

# 関数連番。複数subに対応するため。
my $funcnum=0;

# フローチャートの要素データ（参照）リスト
# 要素内容は以下（将来的にはClass::Struct化したい）
# ID => {
# 	ID       => ユニークな識別子（コマンド_行番号）,
# 	command  => コマンド種別,
# 	args     => コマンド引数,
# 	ref      => 参照元ID等のリスト（参照）@refIDs,
# 	level    => 深さ,
# }
my %nodelist;

# @nodelist->{ref}用の参照元データ（参照）リスト
# 要素内容は以下（将来的にはClass::Struct化したい）
# [ID,args]
my @refIDs;
# endswitchでの合流用にbreakを保持する、参照元データ（参照）リスト
# 要素内容は@refIDsと同じ
my @breakstack;
# switch->caseの参照情報を保持する、参照元データ（参照）リスト
# switchが深くなるほど、要素が増えていく。最終要素は直近のswitch
# 要素内容は@refIDsと同じ
my @switchstack;
# endsubでの合流用にbreakを保持する、参照元データ（参照）リスト
# 要素内容は@refIDsと同じ
my @returnlist;

# ラベルへの参照元リスト
# ラベル名 => { ID=>ID, ref=>[@refIDsと同じ] }
my %labellist;


print "digraph {\n\n";
while (<>) {
	my($command,$args) = /^\s*(\w+)\s*(.*?)\s*$/;
	next if not $command;
	SWITCH_COMMAND: {
		$_ = $command;
		my $currentID = "${command}_$.";
		
		# コメント行はスキップ
		next if /^#/;
		
		# case break（非フローチャート要素）
		/^break$/ && do {
			push @breakstack, $refIDs[-1];
			last;
		};
		# case endswitch（非フローチャート要素）
		/^endswitch$/ && do {
			@refIDs=@breakstack;
			pop @switchstack;
			last;
		};
		
		# case sub
		/^sub$/ && do {
			$funcnum++;
			@returnlist = ();
			@switchstack = ();
			@refIDs = ();
			%nodelist = ();
			$command = "start_end";
			print qq/subgraph cluster_$funcnum { label="$args";\n/;
		};
		# case endsub
		/^endsub$/ && do {
			$args    = "END";
			$command = "start_end";
			# return->endsub
			push @refIDs, @returnlist;
			# goto->label
			foreach my $label (keys %labellist) {
				if (not exists $labellist{$label}{ID}) {
					warn "ERROR: not defined label(${label})\n";
				} else {
					if (exists $labellist{$label}{ref}) {
						push @{$nodelist{$labellist{$label}{ID}}{ref}}, @{$labellist{$label}{ref}};
					}
				}
			}
		};
		# case switch
		/^switch$/ && do {
			@breakstack = ();
			push @switchstack, $currentID;
		};
		# case label
		/^label$/ && do {
			$labellist{$args}{ID} = $currentID;
		};
		# calse goto
		/^goto$/ && do {
			# ラベルへの参照元リストへ追加
			# 現状では、参照情報に引数は設定しない（将来的にはコメント的なテキストを設定したい）
			if (not exists $labellist{$args}{ref}) {
				$labellist{$args}{ref} ||= [];
			}
			push @{$labellist{$args}{ref}}, [$currentID, ""];
		};
		# case return
		/^return$/ && do {
			push @returnlist, [$currentID, $args];
			$command = "goto";
		};
		# case case
		/^case$/ && do {
			@refIDs=([$switchstack[-1], $args]);
			$args    = $currentID;
			$command = "label";
		};
		
		# default（全フローチャート要素）
		do {
			$nodelist{$currentID} = {
			    ID       => $currentID,
			    command  => $command,
			    args     => $args,
			    ref      => [@refIDs],
			    level    => scalar @switchstack,
			    };
			@refIDs=([$currentID, ""]);
		};
		# case endsub
		/^endsub$/ && do {
			print @{nodedump(\%nodelist)};
			print "}\n\n";
		};
	}
}

print "}\n";



sub nodedump {
	my $nodelist = shift;
	my @ret;
	
	# default node
	push @ret,
	    qq/# default\n/,
	    qq/edge[labeldistance=1.5,tailport=s,headport=n];\n/,
	    qq/node[height=0.2, width=1];\n/;
	push @ret, "\n";
	
	# switch
	push @ret,
	    qq/# switch\n/,
	    qq/node[shape="diamond", style=""];\n/;
	foreach my $i (grep {$_->{command} eq "switch"} values(%$nodelist)) {
		push @ret,
		    qq/$i->{ID}\[label="$i->{args}", group="$i->{level}"\];\n/;
	}
	push @ret, "\n";
	
	# do
	push @ret,
	    qq/# do\n/,
	    qq/node[shape="rect", style=""];\n/;
	foreach my $i (grep {$_->{command} eq "do"} values(%$nodelist)) {
		push @ret,
		    qq/$i->{ID}\[label="$i->{args}", group="$i->{level}"\];\n/;
	}
	push @ret, "\n";
	
	# call
	push @ret,
	    qq/# call\n/,
	    qq/node[shape="record", style=""];\n/;
	foreach my $i (grep {$_->{command} eq "call"} values(%$nodelist)) {
		push @ret,
		    qq/$i->{ID}\[label="\\ |$i->{args}|\\ ", group="$i->{level}"\];\n/;
	}
	push @ret, "\n";
	
	# start_end
	push @ret,
	    qq/# start_end\n/,
	    qq/node[shape="rect", style="rounded"];\n/;
	foreach my $i (grep {$_->{command} eq "start_end"} values(%$nodelist)) {
		push @ret,
		    qq/$i->{ID}\[label="$i->{args}", group="$i->{level}"\];\n/;
	}
	push @ret, "\n";
	
	# return
	push @ret,
	    qq/# goto(and return)\n/,
	    qq/node[shape="point", height=0, width=0];\n/;
	foreach my $i (grep {$_->{command} eq "goto"} values(%$nodelist)) {
		push @ret,
		    qq/$i->{ID}\[group="$i->{level}"\];\n/;
	}
	push @ret, "\n";
	
	# label
	push @ret,
	    qq/# label\n/,
	    qq/node[shape="point", height=0, width=0];\n/;
	foreach my $i (grep {$_->{command} eq "label"} values(%$nodelist)) {
		push @ret,
		    qq/$i->{ID}\[group="$i->{level}"\];\n/;
	}
	push @ret, "\n";
	
	# edge
	foreach my $i (values(%$nodelist)) {
		foreach my $ref (@{$i->{ref}}) {
			push @ret,
			    qq/$ref->[0] -> $i->{ID}/;
			
			push @ret,
			    qq/[label="$ref->[1]"]/
			    if $ref->[1];
			
			if ((@{$i->{ref}} == 1) && ($i->{command} eq "goto")) {
				push @ret,
				    qq/[arrowhead="none"]/;
			}
			if (($nodelist->{$ref->[0]}{command} ne "goto") && ($i->{command} eq "label")) {
				push @ret,
				    qq/[arrowhead="none"]/;
			}
			if (($nodelist->{$ref->[0]}{command} eq "goto") && (not $ref->[1])) {
				push @ret,
				    qq/[headport=e, constraint=false]/;
			}
			
			push @ret, ";\n";
		}
	}
	push @ret, "\n";
	
	# rank
	foreach my $i (grep {$_->{command} eq "switch"} values(%$nodelist)) {
		my @temp;
		push @ret,
		    qq/{rank=same;/;
		foreach my $j (values(%$nodelist)) {
			next if not @{$j->{ref}};
			if (grep {$_ eq $i->{ID}} map {$_->[0]} @{$j->{ref}}) {
				push @ret,
				    qq/$j->{ID};/;
				
				foreach my $k (values(%$nodelist)) {
					next if @{$k->{ref}} != 1;
					push @temp,
					    qq/$k->{ID}/
					    if grep {$_ eq $j->{ID}} map {$_->[0]} @{$k->{ref}};
				}
			}
		}
		push @ret,
		    qq/}\n/;
		push @ret,
		    qq/{rank=same;/,
		    join(";", @temp),
		    qq/}\n/;
	}
	push @ret, "\n";
	
	
	return \@ret;
} 


__DATA__
sub main2
	do init
label startSwitch
	switch OK?
	#return a
	case 1
		call error_func
		return a
	case 2
		break
	case 4
		do foo
		break
	case X
		goto startSwitch
	endswitch
endsub