Limbic~Region has asked for the wisdom of the Perl Monks concerning the following question:
All,
In my never ending quest to improve my Perl6 skills as well as spread advocacy, I have written the following code to solve thor's problem of proving through brute force that all hands of cribbage with a 5 are worth at least 2 points.
use v6;
my @deck = new_deck();
my $next = combo(5, @deck);
my @combo;
while ( @combo = $next() ) {
# Skip all hands that do not contain a 5
next if ! grep { $_<val> == 5 } @combo;
# Skip all hands that have a score of at least 2
my $score = score( @combo );
next if $score > 1;
# Print out the rest
say join ' ', $score, map -> $_ { $_<disp> ~ $_<suit> } @combo;
}
sub score ( @hand ) returns Int {
my $score = 0;
# Last card is always cut card (for purposes of right-jack and flu
+sh)
# [234] of a kind
my %of_a_kind = (1 => 0, 2 => 2, 3 => 6, 4 => 12);
my %seen;
for ( map -> $_ { $_<disp> } @hand ) {
%seen{$_}++;
}
for ( values %seen ) { $score += %of_a_kind{$_} }
# Flush
my %suit = map -> $_ { $_<suit> => 1 } @hand[0 .. 3];
$score += 4 if +%suit == 1;
$score++ if %suit{ @hand[ -1 ] };
# Count 15's
my @vals = map -> $_ { $_<val> } @hand;
for ( 2 .. 5 ) {
my $next = combo($_, @vals);
my @combo;
while ( @combo = $next() ) {
my $tot = 0;
for ( @combo ) { $tot += $_ }
$score += 2 if $tot == 15;
}
}
# Check for right-jack
for ( @hand[0 .. 3] ) {
if ( $_<disp> eq 'J' ) {
if ( $_<suit> eq @hand[ -1 ]<suit> ) {
$score++;
last;
}
}
}
# Check for runs
my @nums = map -> $_ { $_<num> } @hand;
my $found;
for ( 5, 4, 3 ) {
last if $found;
my $next = combo($_, @nums);
my @combo;
while ( @combo = $next() ) {
@combo = sort { $^a <=> $^b } @combo;
my ($prev, $in_sequence) = (0, 1);
for ( @combo ) {
if ( ! $prev ) {
$prev = $_;
next;
}
if ( $_ - $prev != 1 ) {
$in_sequence = 0;
last;
}
$prev = $_;
}
if ( $in_sequence ) {
$found = 1;
$score += $_;
}
}
}
return $score;
}
sub combo (Int $by is copy, @list is copy) returns Ref {
my @position = 0 .. ($by - 2), $by - 2;
my @stop = @list.elems - $by .. @list.end;
my $done = undef;
return sub {
return () if $done;
my $cur = @position.end;
while ( ++@position[ $cur ] > @stop[ $cur ] ) {
--$cur;
@position[ $cur ]++;
next if @position[ $cur ] > @stop[ $cur ];
my $new_pos = @position[ $cur ];
@position[ $cur .. @position.end ] = $new_pos .. ($new_pos
+ + $by);
last;
}
$done = 1 if @position[ 0 ] == @stop[ 0 ];
return @list[ @position ];
};
}
sub new_deck () returns Array {
my @deck;
my %val = map -> $_ { $_ => $_ } 1..10;
%val{ 11..13 } = (10) xx 3;
my %disp = map -> $_ { $_ => $_ } 2..10;
%disp{ 1, 11..13 } = qw<A J Q K>;
for ( 1..13 ) {
push @deck,
{ 'num' => $_, 'val' => %val{$_}, 'suit' => 'H', 'disp' =>
+ %disp{$_} },
{ 'num' => $_, 'val' => %val{$_}, 'suit' => 'D', 'disp' =>
+ %disp{$_} },
{ 'num' => $_, 'val' => %val{$_}, 'suit' => 'C', 'disp' =>
+ %disp{$_} },
{ 'num' => $_, 'val' => %val{$_}, 'suit' => 'S', 'disp' =>
+ %disp{$_} },
}
return @deck;
}
Your challenge is to refactor or rewrite the code taking advantage of as many features of Perl6 as you can. Obfuscation is frowned on while clear succinct code using a new p6ism is smiled upon. I would encourage everyone to try their solutions using the latest Pugs and if something doesn't work - write a test! A secondary goal is to improve efficiency though it is a must to consider all hands.
If anyone feels that learning isn't reward enough and is interested in a prize, let me know and I will consider one. Any award beyond bragging rights will require a more strict set of rules though. Happy Hacking!
Note: I had to work around a few pugsbugs but hopefully they will be fixed soon making the code better.
Update: The latest and greatest version can now be found here.
Re: Perl6 Contest: Test your Skills
by revdiablo (Prior) on May 19, 2005 at 19:06 UTC
|
Just to get the party started, and without putting much effort into it, you can change this:
next if ! grep { $_<val> == 5 } @combo;
to:
next if none(@a) == 5;
Update: another quick note. Your iterator should be able to be nicely implemented in terms of gather/take. Pugs doesn't have it yet, so I haven't had a chance to play with it enough to be very comfortable, but it would be nice if someone could show how to do that. :-)
Another update: here's my crack at gatherifying your combo generator. I dunno if it's right, but it fits my understanding of how the construct is supposed to work:
sub combo (Int $by is copy, @list is copy) returns Ref {
my @position = 0 .. ($by - 2), $by - 2;
my @stop = @list.elems - $by .. @list.end;
my $done = undef;
gather {
until $done {
my $cur = @position.end;
while ++@position[$cur] > @stop[$cur] {
--$cur;
@position[$cur]++;
next if @position[$cur] > @stop[$cur];
my $new_pos = @position[$cur];
@position[$cur .. @position.end] = $new_pos .. ($new_p
+os + $by);
last;
}
$done = 1 if @position[0] == @stop[0];
take [ @list[@position] ];
}
}
}
As we can see, this was a very straightforward change. My understanding is that this should act lazilly -- possibly as a coroutine -- if used in a lazy context. Instead of returning lists, I have it take array references, because I'm not sure if taking a list would Do The Right Thing. Again, this is just my understanding of the feature. I could have this all wrong.
Update on another update: added until loop around body of gather. I think it's correct this time. :-) | [reply] [d/l] [select] |
|
revdiablo,
Bravo! I intentionally tried to only use things that were not new with p6. Your suggestion is what I would consider "low hanging fruit". There should be plenty of it - which is one purpose of the challenge (getting used to p6isms that make your life easier)!
| [reply] |
Re: Perl6 Contest: Test your Skills
by dragonchild (Archbishop) on May 19, 2005 at 19:07 UTC
|
A little analysis would go a long way. The first thing is that you don't have to score the hand - you have to see if the hand has two points. If it does, you win. If it doesn't, you lose.
- If you have a 10, J, Q, or K anywhere in @hand, you win.
- If you have another 5, you win.
- If you have a pair of anything else, you win.
- If you have 3 cards in a row, you win.
- If +%suit{@hand[0..3]} == 1, you win. The suit of the cut-card is irrelevant.
- The check on the right jack is irrelevant because it's the only 1-point item.
So, the trick is to prove you cannot construct a hand and cut-card that do not meet these criteria. A proof by negation, if you will. I will leave that as an exercise for the reader.
- In general, if you think something isn't in Perl, try it out, because it usually is. :-)
- "What is the sound of Perl? Is it not the sound of a wall that people have stopped banging their heads against?"
| [reply] [d/l] |
|
| [reply] |
|
# Assumption: @hand[0]<val> == 5;
sub is_good( @hand ) returns Bool {
# If you have a 10, J, Q, or K anywhere in @hand, you win.
if any(@hand<val>) == 10 {
return true;
}
# If you have more than one of anything, you win.
my %cardvals;
%cardvals{ @hand[0..4]<num> }++;
if any( %cardvals.values ) > 1 {
return true;
}
# If you have 3+ cards in a row, you win.
for 1 .. 11 -> $start {
if all( @cardvals{ ($start, $start+1, $start+2) } ) {
return true;
}
}
# If +%suit{@hand[0..3]} == 1, you win.
# Note: The suit of the cut-card is irrelevant.
my %suits;
%suits{ @hand[0..3]<suit> }++;
if +%suit == 1 {
return true;
}
# Alternately, this could have been written:
# if all( @hand[0..3]<suit> ) == any( @hand[0..3]<suit> ) {
# return true;
# }
return false;
}
- In general, if you think something isn't in Perl, try it out, because it usually is. :-)
- "What is the sound of Perl? Is it not the sound of a wall that people have stopped banging their heads against?"
| [reply] [d/l] |
|
|
|
Re: Perl6 Contest: Test your Skills
by dragonchild (Archbishop) on May 19, 2005 at 20:03 UTC
|
sub score ( @hand ) returns Int {
my Int $score = 0;
my %cardvals;
%cardvals{ @hand[0..4]<num> }++;
# [234] of a kind
$score += [*]($_,$_-1) for %cardvals.values;
# Flushes
$score += 4 if @hand[0]<suit> ~~ all( @hand[1..3]<suit> );
$score++ if @hand[4]<suit> ~~ all( @hand[0..3]<suit> );
# Fifteens
if any( @hand<val> ) ~~ 5 && any( @hand<val> ) ~~ 10 {
$score += 2 *
( grep -> $_<val> ~~ 5, @hand ) *
( grep -> $_<val> ~~ 10, @hand );
}
# Runs
SPAN: for 5 .. 3 -> $span {
for 1 .. 11 -> $start {
if all( @cardvals{ $start .. $start + $span } ) {
$score += $span;
last SPAN;
}
}
}
# Right-Jack
$score++ if grep ->
$_<disp> ~~ 'J' && $_<suit> ~~ @hand[4]<suit>, @hand[0..3];
return $score;
}
- In general, if you think something isn't in Perl, try it out, because it usually is. :-)
- "What is the sound of Perl? Is it not the sound of a wall that people have stopped banging their heads against?"
| [reply] [d/l] |
|
dragonchild,
Sorry it has taken me a while to reply, but I have been trying to track down bugs and add tests for missing features. Several of them prompted by this reply - so thanks!
my %cardvals;
%cardvals{ @hand[0..4]<num> }++
I don't believe @hand[0..4]<num> works. I believe you need the hyper operator for that as in @hand[0..4]>>.<num>. Since the slice represents the entire array it can be dropped all together - @hand>>.<num> I am not sure about the post increment also needing to be distributed either but my hunch is that it should be.
# [234] of a kind
$score += [*]($_,$_-1) for %cardvals.values;
Clever! To explain what is happening from right to left: The values of the hash are the counts of each in the hand. The infix operator gets the product of the count and the count minus 1 so ( 1 => 0, 2 => 2, 3 => 6, 4 => 12 ). The result is then added to the current $score.
# Fifteens
if any( @hand<val> ) ~~ 5 && any( @hand<val> ) ~~ 10 {
$score += 2 *
( grep -> $_<val> ~~ 5, @hand ) *
( grep -> $_<val> ~~ 10, @hand );
}
I am fairly certain this is inadequate. Consider 2 + 3 + 6 + 4 = 15. (no fives or tens)
# Runs
SPAN: for 5 .. 3 -> $span {
for 1 .. 11 -> $start {
if all( @cardvals{ $start .. $start + $span } ) {
$score += $span;
last SPAN;
}
}
}
Again Clever! In this case though it isn't quite enough. To explain what I believe is going on is that you already have all of the number values stored in a hash. You start looking for runs of 5 then 4 then 3. Then you check for all possible runs of that length by checking if all cards in the hash have a true value. Unfortunately this is where it goes wrong. Consider:
Hand = 2,3,3,4 5
2,3,4,5 = 4 points
2,3,4,5 = 4 points
= 8 points total
Your approach aborts after the first run is found.
| [reply] [d/l] [select] |
|
# Runs
SPAN: for 5 .. 3 -> $span {
for 1 .. 11 -> $start {
if all( @cardvals{ $start .. $start + $span } ) {
$score += $span [*] %cardvals{ $start .. $start + $span};
last SPAN;
}
}
}
Since %cardvals contains the number of each card, that's the number of times the run should be multiplied by. This also correctly handles 2,3,3,4,4. The span is 3 and the multiplier is 1*2*2, which results in 12.
Update: I'm a little reduce-happy. That should really be:$score += $span *<< %cardvals{ $start .. $start + $span};
You're also absolutely right on the fifteens. There are probably several ways to solve it. There's the brute-force method you used, which is perfectly adequate. However, I think we can use junctions to solve our problem. (Junctions rock, you know.)
# Fifteens
$score += 2 * all( 15 == [+]@hand{ any( 0 .. 4 ) } };
I'm not sure that's legal. I've cross-posted it to P6L for @Larry to rip apart.
Update: After japhy's comments, it should probably look something like:
# Fifteens
$score += 2 * all( 15 == [+]%hand{ any( 0 .. 4 ) } )>>.<num>;
I'm trying to figure out the correct way to handle the combinations as a single item.
- In general, if you think something isn't in Perl, try it out, because it usually is. :-)
- "What is the sound of Perl? Is it not the sound of a wall that people have stopped banging their heads against?"
| [reply] [d/l] [select] |
|
|
sub gen_idx_powerset (Int $size is copy) returns Array {
my @c = ([]);
for 0 .. $size-1 -> $i {
push @c, (map { [@$_, $i] }, @c);
}
return @c;
}
# Fifteens
$score += 2 * grep {
15 == [+]( @hand[@$_]>>.<val> )
}, gen_idx_powerset( +@hand );
Notes:
- I'm still trying to figure out a way of generating the powerset of indices without needing the for-loop, but it's an iterative process that needs the list from the prior iteration to work. So, I'm not sure if that's possible.
- I don't know if the parentheses around @hand[@$_]>>.<val> are needed.
- I don't know if it's @hand[@$_] or @hand[$_]. I hope it's the former, but there's some weird stuff about promoting array references in a DWIM-ish fashion which I haven't understood. So, you may be able to golf another character.
- gen_idx_powerset() will return the powerset with the empty set first. Add a reverse if you want to use that as a for-loop. It should also be trivial to convert that into an iterator with gather-take or some similar construct.
- Yes, gen_idx_powerset() is a very elegant algorithm when done recursively. That's not how it came to me at midnight last night, though. I don't think that the tail-call optimization in P6 will help much, and the recursion isn't parallelizable because of the dependence on the prior iteration's results.
sub gen_idx_powerset( Int $i is copy ) {
return [] unless $i > 0;
return (
gen_idx_powerset( $i - 1 ),
(map { [@$_, $i] }, gen_idx_powerset( $i - 1 ) ),
);
}
- In general, if you think something isn't in Perl, try it out, because it usually is. :-)
- "What is the sound of Perl? Is it not the sound of a wall that people have stopped banging their heads against?"
| [reply] [d/l] [select] |
|
|
Re: Perl6 Contest: Test your Skills
by revdiablo (Prior) on May 19, 2005 at 19:47 UTC
|
Another low hanging fruit observation. I didn't want to add another update to my already too-updated post, so I posted a new one. All the () around your conditions are unnecessary. For example, you can change:
while ( @combo = $next() ) {
To:
while @combo = $next() {
(Of course, this ignores the changes I made to the combo sub in my previous post. To take that into account, you would change it to:
for combo() -> $combo {
Or something like that.) | [reply] [d/l] [select] |
|
|