=begin

Input format:
-------------
Two possible line formats:
PROFILE
CHILD_PROFILE:PARENT_PROFILE

TODO:
-----
- If all edges leaving a cluster are going to the same node, replace them with
  one heavy edge from the cluster.

=cut

my $arches = qr/alpha|amd64|amd64-fbsd|arm|hppa|ia64|m68k|mips|ppc|ppc64|s390|sh|sparc|sparc-fbsd|x86|x86-fbsd/;
my $arches_prefix = qr/ppc-aix|x86-freebsd|x64-freebsd|hppa-hpux|ia64-hpux|x86-interix|mips-irix|amd64-linux|ia64-linux|x86-linux|ppc-macos|x86-macos|x64-macos|m68k-mint|x86-netbsd|ppc-openbsd|x86-openbsd|x64-openbsd|sparc-solaris|sparc64-solaris|x64-solaris|x86-solaris|x86-winnt/;
my $ppc = qr/powerpc(\/ppc(32|64)?)?/;
my $mips_reltype = qr/(sgi\/ip..(?:\/r10k)?|mipsel|lemote(\/lm2[ef](\/(?:fulong|yeeloong)))?|cobalt)?(\/n(?:32|64))?/;
my $reltype = qr/..bit-userland|cobalt|no-nptl|no-multilib|$rel_reltype/;
my $rel_10 =   qr/10.0(\/($reltype))?/;

my %clusters = (
qr/^arch\/[-.[:alnum:]]+(\/.*)?$/ => 'Base $ARCH',
qr/^default-linux\/($arches|$ppc|base)$/ => 'Old $ARCH',
qr/^default-linux\/mips\/2007.1-dev/ => 'Old MIPS 2007.1 non-release',
qr/^default-linux\/sparc/ => 'Old sparc',
qr/^hardened(\/linux)?\/($arches|$ppc|base)$/ => 'Hardened $ARCH',
qr/^default\/linux\/($arches|$ppc)$/ => 'Linux $ARCH',
qr/^default\/linux\/($arches|$ppc)\/10.0(\/$reltype)?|^default\/linux\/mips\/10.0\/(\/$mips_reltype)?$/ => 'Main 10.0',
qr/^hardened\/linux\/($arches|$ppc)\/10.0(\/$reltype)?$/ => 'Hardened 10.0',
qr/^features(\/[-.[:alnum:]]+)?$/ => 'Features',
qr/^releases\/freebsd-7..$/ => 'Releases - FreeBSD',
qr/^releases\/(200...|10.0)$/ => 'Releases - Linux',
qr/^selinux/ => 'SELinux',
qr/^prefix/ => 'Prefix',
qr/^targets/ => 'Targets',
qr/^uclibc/ => 'uclibc',
qr/^default-bsd/ => 'Old BSD',
qr/^default\/bsd/ => 'New BSD',
);

my @deprecated = (
'default-linux/sh',
'default-linux/arm',
'default-linux/x86',
'default-linux/ia64',
'default-linux/m68k',
'default-linux/s390',
'default-linux/amd64',
'default-linux/alpha',
'hardened/ppc',
'hardened/x86/2.6',
'hardened/x86/minimal',
'hardened/x86',
'hardened/ia64',
'hardened/amd64/multilib',
'hardened/amd64',
'hardened/ppc64',
'uclibc/arm/armeb/2.4',
'uclibc/arm/armeb',
'uclibc/x86/linux24',
'uclibc/x86/linux26',
'uclibc/mips/mipsel/hardened',
'uclibc/mips/mipsel',
'bsd/fbsd/x86/7.2',
'bsd/fbsd/x86/8.0',
'bsd/fbsd/x86/8.2',
'bsd/fbsd/amd64/7.2',
'bsd/fbsd/amd64/8.0',
'bsd/fbsd/amd64/8.2',
'bsd/fbsd/sparc/7.2',
'bsd/fbsd/sparc/8.0',
);


my @ignore = (
 qr/^default\/linux\/($arches|$ppc)\/$rel_10\/desktop$/ => '10.0/desktop',
 qr/^default\/linux\/($arches|$ppc)\/$rel_10\/server$/ => '10.0/server',
 qr/^default\/linux\/($arches|$ppc)\/$rel_10\/developer$/ => '10.0/developer',
 
 qr/^default\/linux\/mips\/$rel_10\/.*\/desktop$/ => 'MIPS 10.0/desktop',
 qr/^default\/linux\/mips\/$rel_10\/.*\/server$/ => 'MIPS 10.0/server',
 qr/^default\/linux\/mips\/$rel_10\/.*\/developer$/ => 'MIPS 10.0/developer',

qr/^hardened\/linux\/($arches|$ppc)\/$rel_10\/desktop$/ => 'Hardened 10.0/desktop',
qr/^hardened\/linux\/($arches|$ppc)\/$rel_10\/server$/ => 'Hardened 10.0/server',
qr/^hardened\/linux\/($arches|$ppc)\/$rel_10\/developer$/ => 'Hardened 10.0/developer',

qr/^selinux\/v2refpolicy\/($arches|$ppc)\/desktop$/ => 'SELinux desktop',
qr/^selinux\/v2refpolicy\/($arches|$ppc)\/server$/ => 'SELinux server',
qr/^selinux\/v2refpolicy\/($arches|$ppc)\/developer$/ => 'SELinux developer',

qr/^default\/linux\/sparc\/experimental\/multilib\/desktop$/ => 'SPARC exp desktop',
qr/^default\/linux\/sparc\/experimental\/multilib\/server$/ => 'SPARC exp server',
qr/^default\/linux\/sparc\/experimental\/multilib\/developer$/ => 'SPARC exp developer',
);

sub should_ignore {
	my $s = shift;
	foreach my $r (@ignore) {
		return 1 if $s =~ $r;
	}
	return 0;
}

my %nodes; 
my $i = 0; 

print "digraph profile {\n";
print "\tnode [fontname=\"Monospace\", shape=box, style=filled, fillcolor=yellow];\n";
print "\trankdir=LR;\n";
print "\tconcentrate=true;\n";
print "\trank=source;\n";
print "\tranksep=\"1.2 equally\"\n";

$nodes{'deprecated'} = 9999999;

print "\n\n";

sub get_id {
	my $s = shift;
	return $nodes{$s} if exists $nodes{$s};
	foreach my $r (@deprecated) {
		return $nodes{'deprecated'} if $s =~ $r;
	}
	$nodes{$s} = ++$i;
	return $nodes{$s};
}

while(<>) {
	chomp;
	my $s = $_;
	next if $s =~ /#/;
	if($s =~ /:/) {
		@v = split /:/, $s;
		chomp $v[0];
		chomp $v[1];
		next if should_ignore($v[0]) or should_ignore($v[1]);
		my $i = get_id($v[0]);
		my $j = get_id($v[1]);
		printf "\tn%d -> n%d; /* %s  ---> %s */ \n", $i, $j, $v[0], $v[1] unless $i == $nodes{'deprecated'} or $j == $nodes{'deprecated'};
	} else {
		get_id($s);
		#printf "n%d [label=\"%s\"];\n", $nodes{$s}, $s;
	}
}
print "\n\n";
foreach my $s (keys %nodes) {
	next if should_ignore($s);
	my $i = get_id($s);
	printf "\tn%d [label=\"%s\"];\n", $i, $s unless $i == $nodes{'deprecated'};
}

print "\n\n";
$i = 0;
foreach my $r (keys %clusters) {
	#print STDERR "regex $r\n";
	printf "\n\tsubgraph cluster_%d {\n", $i++;
	printf "\t\tlabel=\"%s\";\n", $clusters{$r};
	printf "\t\tfillcolor=lightgrey;\n";
	printf "\t\tstyle=filled;\n";
	printf "\t\tnode [style=filled, fillcolor=white];\n";
	foreach my $k (keys %nodes) {
		next if should_ignore($k);
		printf "n%d; ",get_id($k) if $k =~ $r;
	}
	print "\n\t};\n";
}
print "}\n";