A whole new approach, using a classical algorithm. Gained a dozen strokes, but still far behind.
#!perl -lna
END{do{for(@a=grep{!$a{$_}}keys%a){$a{$_}--for$a=~/$;\Q$_\E (\S+) /g;delete$a{$_};print}%a&&!@a&&die}while%a}$a{pop@F}+=$_ for($F[0]ne$F[1],0);$a.="$;$_ "
|
s/for/map/ to shave a stroke. Test 27 takes time and memory, but it passes.
#!perl -lna
END{@a=keys%a;T:$b=~/\Q@a/&¨map{($c,$d)=@$_;@a{@a}=0..@a;$b.=" @a",@a[@a{@$_}]=@a[@a{$d,$c}],goto
T if$a{$c}>$a{$d}}@r;$"=$/;print"@a";exit}push@r,[@a{@F}=@F]
|
There was probably a typo in the previous submission, since this once is ok on all tests for me. Except that it breaks the 1 minute barrier on test 27, naturally! ;-)
#!perl -lna
END{@a=keys%a;T:$b=~/\Q@a/&¨map{($c,$d)=@$_;@a{@a}=0..@a;$b.=" @a",@a[@a{@$_}]=@a[@a{$d,$c}],goto
T if$a{$c}>$a{$d}}@r;$"=$/;print"@a";exit}push@r,[@a{@F}=@F]
|
Well after all, this is a sort. So I used a classic approach to sorting: swap elements that are in the wrong order. And keep a list of everything we tried. If we try the same thing twice, then there's a loop. For the record, test 27 requires 3587 swaps, and the string that stores all the possibilities we tried is 6675407 bytes long.
#!perl -lna
END{@a=keys%a;T:$b=~/\Q@a/&¨for(@r){($c,$d)=@$_;@a{@a}=0..@a;$b.=" @a",@a[@a{@$_}]=@a[@a{$d,$c}],goto
T if$a{$c}>$a{$d}}$"=$/;print"@a";exit}push@r,[@a{@F}=@F]
|
Removed the sub that's called once.
#!perl -lna
($0,$b)=@F;$0ne$b&&!$0{$0}{$b}&&$r{$b}++;$0{$0}{$b}=$0{$b}||={};END{while(@a=keys%0){(@_=grep{!$r{$_}}@a)||die;for(@_){$r{$_}--for$_,keys%{$0{$_}};print;delete$0{$_}}}}
|
Removed the index variable from a for loop.
#!perl -lna
($0,$b)=@F;$0ne$b&&!$0{$0}{$b}&&$r{$b}++;$0{$0}{$b}=$0{$b}||={};sub
a{@_||die'';for(@_){$r{$_}--for$_,keys%{$0{$_}};print;delete$0{$_}}}END{a grep{!$r{$_}}keys%0while keys%0}
|
Replaced $a by $0 for consiseness.
#!perl -lna
($0,$b)=@F;$0ne$b&&!$0{$0}{$b}&&$r{$b}++;$0{$0}{$b}=$0{$b}||={};sub a{@_||die'';for$a(@_){$r{$_}--for$a,keys%{$0{$a}};print$a;delete$0{$a}}}END{a grep{!$r{$_}}keys%0while keys%0}
|
Removed @F for consiseness.
#!perl -lna
($a,$b)=@F;$a ne$b&&!$a{$a}{$b}&&$r{$b}++;$a{$a}{$b}=$a{$b}||={};sub a{@_||die'';for$a(@_){$r{$_}--for$a,keys%{$a{$a}};print$a;delete$a{$a}}}END{a grep{!$r{$_}}keys%a while keys%a}
|
Yet another unorthodox entry, where we try to find a solution using a brute force system. This brought test 22 out of memory, which seems to indicate that I need to rework this a bit.
#!perl -lna
@n{@F}=push@r,$_;$"=$/;sub p{my
(@p,%s)=@{+pop};if(@p==keys%n){
print"@p";exit}@s{@p}=1..@p;for
(@r){($a,$b)=split;return if$s{
$a}>$s{$b}}map{p([$_,@p])}grep{
!$s{$_}}keys%n}END{p[];die}
|
With the correct algorithm, it works much better... And I am below 200, too!
#!perl -lna
$F[0]ne$F[1]&&!$a{$F[0]}{$F[1]}&&$r{$F[1]}++;$a{$F[0]}{$F[1]}=$a{$F[1]}||={};sub a{@_||die'';for$a(@_){$r{$_}--for$a,keys%{$a{$a}};print$a;delete$a{$a}}}END{a grep{!$r{$_}}keys%a while keys%a}
|
This one is my first working attempt. Quite lame, particularly the $i++>99&&exit 1 part, that is used to detect cycles....
#!perl -lna
$a{$F[0]}{$F[1]}++;$F[0]ne$F[1]?$r{$F[1]}++:next;exit 1if$a{$F[1]}{$F[0]};sub a{my%b;do{$d{$_}++||print;@b{keys%{$a{$_}}}=();delete$b{$_}}for@_;$i++>99&&exit 1;a(keys%b)if%b}END{a grep{!$r{$_}}keys%a}
|
This is an improvement over the previous unorthodox entry! Now we don't try n^n possibilities, but only n! (factorial n). We will need less memory (but still a lot, since we test all), but a loooot of time to test all the possibilities. Maybe it's less unorthodox, since we don't use glob anymore.(by the way, the glob entry would not work with all chars, like *)
#!perl -lna
@n{@F}=push@r,$_;$"=$/;sub
p{my @a;return[@_]if@_==1;
for$0(@_){push@a,map{[$0,@
$_]}p(grep{$0ne$_}@_)}@a};
END{T:for(p(keys%n)){@s{@s
}=0..(@s=@$_);for(@r){($a,
$b)=split;next T if$s{$a}>
$s{$b}}print"@s";exit}die}
|
This one is very greedy on memory... It asks glob to precompute all the possibilities (and even more!), and then uses the same algorithm as tpr04b.pl to print the first correct one. Since there are $n**$n possibilities ($n being the number of nodes in the graph), it eats up memory very fast!
#!perl -lna
@n{map{"\Q$_"}@F}=push@r,$_;END{$"=",";@t=glob
"{@{[keys%n]}}$;"x keys%n;T:for(@t){$_=$;.$_;/
$;([!-~]+$;).*\1/x&&next;@s{@s}=0..(@s=split$;
);for(@r){($a,$b)=split;next T if$s{$a}>$s{$b}
}print join$/,@s[1..$#s];exit}die}
|
I guess I can shave some more, but to butcher this one, I'll have to change my algorithm. (Changed $c to @c)
#!perl -lna
$_="\Q$_"for@F;$b=0;for$a(@a){$b||$a=~s/ +($F[1]|$F[0]) +/ $_ /&&++$b;@c=$a=~/ (\S+) $/g;$_ eq$a&&next,s/^ @c /$a/&&($a='')for@a}push@a," $_ " if!$b;s/( [!-~]+)\1 /$1 /,/( [!-~]+ ).*\1/&&exit 1for@a;END{$_="@a";s/^ +| +$//g;y/ /
/s;print}
|
Shortening quotemeta, and using the aliasing capabilities of for.
#!perl -lna
$_="\Q$_"for@F;$b=0;for$a(@a){$b||$a=~s/ +($F[1]|$F[0]) +/ $_ /&&++$b;($c)=($a=~/ (\S+) $/g);$_ eq$a&&next,s/^ $c /$a/&&($a='')for@a}push@a," $_ " if!$b;s/( [!-~]+)\1 /$1 /,/( [!-~]+ ).*\1/&&exit 1for@a;END{$_="@a";s/^ +| +$//g;y/ /
/s;print}
|
I thought I found a better approach than the previous one... I hope at least that this one won't be rejected. :-)
#!perl -lna
@F=map{quotemeta}@F;$b=0;for$a(@a){$b||$a=~s/ +($F[1]|$F[0]) +/ $_ /&&++$b;($c)=($a=~/ (\S+) $/g);$_ eq$a&&next,s/^ $c /$a/&&($a='')for@a}push@a," $_ " if!$b;s/( [!-~]+)\1 /$1 /,/( [!-~]+ ).*\1/&&exit 1for@a;END{$_="@a";s/^ +| +$//g;y/ /
/s;print}
|