I was reminded by a recent Reddit thread of the classic "get a goat, wolf, and cabbage across a river" problem ( spazzy kittens version, painfully verbose Haskell version). You're on the left side of a river with a cabbage, goat, and wolf, and want to get them to the right side. The wolf will eat the goat, and the goat the cabbage, but only if you leave them alone. You can only fit one of them in your boat at a time.
The problem can be solved by computer with some backtracking, or by hand with some thought. Being a Perl programmer, I naturally thought to golf it, and thought that the best solution would involve a clever regex or substitution. Here's a terse, but un-obfuscated version:
sub wgc {
return if $seen{"@_"}++;
my%x=@_;
if ($x{b} && $x{c} && $x{g} && $x{w}) {
print+(sort keys%$_),"\n" for @h;
exit;
} elsif ((!$x{b} && ($x{c} && $x{g} || $x{g} && $x{w})) ||
($x{b} && (!$x{c} && !$x{g} || !$x{g} && !$x{w}))) {
return;
} else {
if ($x{b}) {
delete $x{b};
for ('xx', keys %x) {
my %y=%x;
delete $y{$_};
local @h=(@h, \%y);
wgc(%y);
}
} else {
$x{b}=1; {
local (@h) = (@h, \%x);
wgc(%x);
}
for my $k (qw(c g w)) {
if (!$x{$k}) {
my %y=(%x,$k,1);
local (@h) = (@h, \%y);
wgc(%y);
};
}
}
}
}
wgc
And here's the output, where "b", "c", "g", and "w" represent the boat, cabbage, goat, and wolf being on the right bank:
bg
g
bcg
c
bcw
cw
bcgw
I wasn't clever enough to come up with the regex solution, but here's a compressed version of the above, weighing in at 382379 strokes:
sub w{return if$s{"@_"}++;my%x=@_;if($x{b}&$x{c}&$x{g}&$x{w}){print+(s
+ort keys%$_),"\n"for@h;exit;}elsif(($x{b}||!($x{c}&&$x{g}||$x{g}&&$x{
+w}))&&(!$x{b}||!(!$x{c}&&!$x{g}||!$x{g}&&!$x{w}))){if($x{b}){delete$x
+{b};for(A,keys%x){my%y=%x;delete$y{$_};local@h=(@h,\%y);w(%y)}}else{$
+x{b}=1;{local@h=(@h,\%x);w(%x);}for(qw(c g w)){if(!$x{$_}){my%y=(%x,$
+_,1);local@h=(@h,\%y);w(%y)}}}}}w
Have at it! |
Re: Golf: Cabbage, Goat, Wolf
by tobyink (Canon) on Dec 28, 2013 at 17:25 UTC
|
Paraphrasing XKCD... you take the goat across, row back, and take the cabbage across. You leave the wolf. (Why would you want a wolf?)
Update: here's the original.
use Moops; class Cow :rw { has name => (default => 'Ermintrude') }; say Cow->new->name
| [reply] |
Re: Golf: Cabbage, Goat, Wolf
by Athanasius (Archbishop) on Jan 06, 2014 at 02:06 UTC
|
Hello educated_foo,
Thanks for this, it’s an interesting exercise! I wrote my own backtracking solution:
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.
| [reply]
[d/l]
[select] |
Re: Golf: Cabbage, Goat, Wolf
by hdb (Monsignor) on Jan 06, 2014 at 16:02 UTC
|
@s=(0,(grep{$_%3}1..14),15);%m=map{$t=$_,[grep{$z=($t^$_)&7;($t^$_)&8&
+&
!($t&8&&~$t&$_&7)&&!(~$t&8&&$t&~$_&7)&&($z<3||$z==4)}@s]}@s;sub t{@c=q
+w
(w g c b);join'',map{$_[0]&2**$_?$c[$_]:'_'}0..3}sub p{printf"%s %s\n"
+,
t(~$_),t($_)for@_;print$/}sub r{my($s,$e,$h,%s)=@_;($s==$e&&p@$h)||r($
+_
,$e,[@$h,$_],$_=>1,%s)for grep{!$s{$_}}@{$m{$s}}}r+0,$s[-1],[0],0,1
Update: something's gone wrong in the obfu process. Pls ignore for now.
Update 2: fixed. Even without strict one needs my at times. Now improved to 358 351 characters. | [reply]
[d/l]
[select] |
|
|
Nice! The multiple uses of
&8&& are a nice touch. 345 with a few stupid golf tricks:
@s=(0,(grep$_%3,1..14),15);%m=map{$t=$_,[grep{$z=($t^$_)&7;($t^$_)&8&&
+!($t&8&&~$t&$_&7)&&!(~$t&8&&$t&~$_&7)&&($z<3|$z==4)}@s]}@s;sub t{@c=q
+w(w g c b);join'',map{$_[0]&2**$_?$c[$_]:'_'}0..3}sub p{printf"%s %s\
+n",t(~$_),t$_ for@_;print$/}sub r{my($s,$e,$h,%s)=@_;($s==$e&&p@$h)|r
+($_,$e,[@$h,$_],$_,1,%s)for grep!$s{$_},@{$m{$s}}}r+0,$s[-1],[0],0,1
| [reply]
[d/l] |
|
|
sub t{(sprintf('%04b',@_)=~tr/01/ w/r)&'bcgw'}sub p{printf"%s%8s$/",
t(15-$_),t$_ for@_;print$/}sub r{my($s,$h,%s)=@_;($s^15||p@$h)|r($_,
[@$h,$_],$_,1,%s)for grep{!$s{$_}&&!($s&8&&~$s&$_&7)&&!(~$s&8&&$s&~
$_&7)&&($z=$s^$_)&8&&(($z&=7)<3|$z==4)}15,grep$_%3,1..14}r+0,[0],0,1
| [reply]
[d/l] |
|
|
|
|
|
|
