Hello educated_foo,
Thanks for this, it’s an interesting exercise! I wrote my own backtracking solution:
#! perl
use strict;
use warnings;
use feature 'state';
use constant DEBUG => 0;
use constant
{
NONE => 0b0000, # 0
CABBAGE => 0b0001, # 1
GOAT => 0b0010, # 2
WOLF => 0b0100, # 4
};
use constant
{
EAT_CABBAGE => GOAT | CABBAGE, # 3
EAT_GOAT => WOLF | GOAT, # 6
ALL => WOLF | GOAT | CABBAGE, # 7
};
my @history = ( [ ALL, NONE ] );
my @solution = ();
if (carry(ALL, NONE))
{
for (@solution)
{
s/0/nothing /;
s/1/the cabbage/;
s/2/the goat /;
s/4/the wolf /;
}
my $step = 1;
print "\n";
printf("%d. $_", $step++) for @solution;
}
else
{
print "\nNo solution found\n";
}
sub carry
{
my ($left_bank, $right_bank) = @_;
state $call = 0
+ if DEBUG;
printf "Enter carry(), call %d. (%03b | %03b)\n",
++$call, $left_bank, $right_bank
+ if DEBUG;
# Carry right
for my $passenger_1 (NONE, CABBAGE, GOAT, WOLF)
{
printf "move (call %d) %03b right (%03b | %03b)\n",
$call, $passenger_1, $left_bank, $right_bank
+ if DEBUG;
if ($passenger_1 && !($left_bank & $passenger_1))
{
printf "abort move right because %03b missing from %03b\n"
+,
$passenger_1, $left_bank
+ if DEBUG;
next;
}
$left_bank -= $passenger_1;
$right_bank += $passenger_1;
printf "Move right made: %03b | %03b\n", $left_bank, $right_ba
+nk if DEBUG;
if ($right_bank == ALL)
{
printf "Done: %03b | %03b\n", $left_bank, $right_bank
+ if DEBUG;
$left_bank == NONE or die "Error: $!";
push @solution, "carry $passenger_1 right\n";
return 1;
}
if ($left_bank == EAT_CABBAGE ||
$left_bank == EAT_GOAT)
{
$left_bank += $passenger_1;
$right_bank -= $passenger_1;
printf "Move right undone because EAT (%03b | %03b)\n",
$left_bank, $right_bank
+ if DEBUG;
next;
}
push @solution, "carry $passenger_1 right\n";
# Carry left
LEFT: for my $passenger_2 (NONE, CABBAGE, GOAT, WOLF)
{
printf "move %03b left\n", $passenger_2
+ if DEBUG;
if ($passenger_2 && !($right_bank & $passenger_2))
{
printf "abort move left because %03b missing from %03b
+\n",
$passenger_2, $right_bank
+ if DEBUG;
next;
}
$left_bank += $passenger_2;
$right_bank -= $passenger_2;
printf "Move left made: %03b | %03b\n", $left_bank, $right
+_bank if DEBUG;
for (@history)
{
if (($_->[0] == $left_bank) &&
($_->[1] == $right_bank))
{
$left_bank -= $passenger_2;
$right_bank += $passenger_2;
printf "Move left undone because REPEAT (%03b | %0
+3b)\n",
$left_bank, $right_bank
+ if DEBUG;
next LEFT;
}
}
push @history, [ $left_bank, $right_bank ];
if ($right_bank == EAT_CABBAGE || $right_bank == EAT_GOAT)
{
$left_bank -= $passenger_2;
$right_bank += $passenger_2;
pop @history;
printf "Move left undone because EAT (%03b | %03b)\n",
$left_bank, $right_bank
+ if DEBUG;
next;
}
push @solution, "carry $passenger_2 left\n";
printf "About to call carry(%03b, %03b)\n", $left_bank, $r
+ight_bank if DEBUG;
if (carry($left_bank, $right_bank))
{
return 1;
}
else
{
$left_bank -= $passenger_2;
$right_bank += $passenger_2;
pop @solution;
printf "Move left undone because call to carry() faile
+d (%03b | %03b)\n",
$left_bank, $right_bank
+ if DEBUG;
}
}
printf "Completed moves left (%03b | %03b)\n", $left_bank, $ri
+ght_bank if DEBUG;
$left_bank += $passenger_1;
$right_bank -= $passenger_1;
pop @solution;
}
printf "Completed moves right (%03b | %03b)\n", $left_bank, $right
+_bank if DEBUG;
return 0;
}
Notes:
- Encoded the cabbage, goat, and wolf using different bits in an integer (+ “no passenger” as 0). This makes it easier to do comparisons and store history.
- The output shows what (if anything) is ferried across the river on each journey, alternating from right to left.
- The implementation took a lot longer to debug than it did to write! So I’ve left the debugging code in place.
Obfuscation was a challenge. I ended up with something that looks pleasingly like line noise1 ;-)
$_=q*H=([7,0]);c(7,0);y`0-4`-cgw`,say FV;sub c{(P,R)=@_;%OPP-=O;R+=O;i
+f(R==
7){ZV,O;return 1}if(P==3|P==6){WY}ZV,O;l:%QRP+=Q;R-=Q;F(H){if($_->[0]=
+=P&$_
->[1]==R){XYl}}ZH,[P,R];if(R==3|R==6){XpopH;Y}ZV,Q;c(P,R)&&return 1;Xp
+opV}W
popV}}*;s=%(.)(.)=F$1(0..2,4){Yif$1&&!($2&$1);=g;s~F~for~g;s!W!P+=O;R-
+=O;!g
;s^X^P-=Q;R+=Q;^g;s+Y+next +g;s#Z#push#g;s@([O-S])@\$$1@g;s&(H|V)&\@$1
+&g;eval
377 characters when run with perl -M5.0102. Developed and tested on Strawberry Perl v5.18.1.
Cheers,
1 “Yes, sometimes Perl looks like line noise to the uninitiated, but to the seasoned Perl programmer, it looks like checksummed line noise with a mission in life.” — merlyn, quoted in Wikipedia’s article on Perl.
2 See Re^4: 2014 Code Golf Challenge.