65 lines
1.8 KiB
Perl
65 lines
1.8 KiB
Perl
use strict;
|
|
use warnings;
|
|
no warnings 'uninitialized';
|
|
use feature 'say';
|
|
use constant True => 1;
|
|
use List::Util qw(head uniq);
|
|
|
|
sub GraphNodeColor {
|
|
my(%OneMany, %NodeColor, %NodePool, @ColorPool);
|
|
my(@data) = @_;
|
|
|
|
for (@data) {
|
|
my($a,$b) = @$_;
|
|
push @{$OneMany{$a}}, $b;
|
|
push @{$OneMany{$b}}, $a;
|
|
}
|
|
|
|
@ColorPool = 0 .. -1 + scalar %OneMany;
|
|
$NodePool{$_} = True for keys %OneMany;
|
|
|
|
if ($OneMany{''}) { # skip islanders for now
|
|
delete $NodePool{$_} for @{$OneMany{''}};
|
|
delete $NodePool{''};
|
|
}
|
|
|
|
while (%NodePool) {
|
|
my $color = shift @ColorPool;
|
|
my %TempPool = %NodePool;
|
|
|
|
while (my $n = head 1, sort keys %TempPool) {
|
|
$NodeColor{$n} = $color;
|
|
delete $TempPool{$n};
|
|
delete $TempPool{$_} for @{$OneMany{$n}} ; # skip neighbors as well
|
|
delete $NodePool{$n};
|
|
}
|
|
|
|
if ($OneMany{''}) { # islanders use an existing color
|
|
$NodeColor{$_} = head 1, sort values %NodeColor for @{$OneMany{''}};
|
|
}
|
|
}
|
|
%NodeColor
|
|
}
|
|
|
|
my @DATA = (
|
|
[ [1,2],[2,3],[3,1],[4,undef],[5,undef],[6,undef] ],
|
|
[ [1,6],[1,7],[1,8],[2,5],[2,7],[2,8],[3,5],[3,6],[3,8],[4,5],[4,6],[4,7] ],
|
|
[ [1,4],[1,6],[1,8],[3,2],[3,6],[3,8],[5,2],[5,4],[5,8],[7,2],[7,4],[7,6] ],
|
|
[ [1,6],[7,1],[8,1],[5,2],[2,7],[2,8],[3,5],[6,3],[3,8],[4,5],[4,6],[4,7] ]
|
|
);
|
|
|
|
for my $d (@DATA) {
|
|
my %result = GraphNodeColor @$d;
|
|
|
|
my($graph,$colors);
|
|
$graph .= '(' . join(' ', @$_) . '), ' for @$d;
|
|
$colors .= ' ' . $result{$$_[0]} . '-' . ($result{$$_[1]} // '') . ' ' for @$d;
|
|
|
|
say 'Graph : ' . $graph =~ s/,\s*$//r;
|
|
say 'Colors : ' . $colors;
|
|
say 'Nodes : ' . keys %result;
|
|
say 'Edges : ' . @$d;
|
|
say 'Unique : ' . uniq values %result;
|
|
say '';
|
|
}
|