examples/cribbage_scoring.pl

   1 use v6;
   2
   3 # Brute force proof that every cribbage hand with a 5 is >= 2 points
   4 # See http://perlmonks.org/index.pl?node_id=458728 for details
   5
   6 # The following code will not work yet as of revision 4167
   7 # There are two bugs and two unimplemented features
   8 # Bug 1     - t/pugsbugs/return_with_trailing_stuff.t
   9 # Bug 2     - t/pugsbugs/postincrement_in_subscripts.t
  10 # Feature 1 - t/operators/hyper.t (hyper dereferencing)
  11 # Feature 2 - t/statements/last.t (last <label>)
  12
  13 my @combo;
  14 my $next = combo(5, new_deck());
  15 while @combo == 1 {
  16     # Skip all hands that do not contain a 5
  17 #    next if none( @combo.>>.<val> ) == 5;
  18
  19     # Skip all hands that have a score of at least 2
  20 #    next if score( @combo ) > 1;
  21
  22     # Print out the rest
  23 #    say ~@combo.>>.<suit>;
  24 }
  25
  26 sub score ( @hand ) returns Int {
  27     my $score = 0;
  28
  29     # [234] of a kind
  30     my %ordval;
  31     for @hand.>>.<num> { %ordval{$_}++ };
  32     for %ordval.values { $score += $_ * $_ - 1 }
  33
  34     # Flush
  35     $score += ([eq] @hand[0..3].>>.<suit>)
  36         ?? ([eq] @hand[3,4].>>.<suit>) ?? 5 !! 4
  37         !! 0;
  38
  39     # Check for right-jack, @hand[*-1] is community card
  40     $score++ if grep { $_<num> == 11 && $_<suit> eq @hand[*-1]<suit> }, @hand[0..3];
  41
  42     # Count 15's
  43     my @vals = @hand>>.<val>;
  44     for 2 .. 5 {
  45         my $next = combo($_, @vals);
  46         while my @combo = $next() { $score += 2 if ([+] @combo) == 15 }
  47     }
  48
  49     # Runs
  50     SPAN:
  51     for 5, 4, 3 -> $span {
  52         for (sort { $^a <=> $^b }, %ordval.keys) -> $start {
  53             if all( %ordval{$start .. $start + $span} ) > 1 {
  54                 $score += [*] %ordval{$start .. $start + $span}, $span;
  55                 last SPAN;
  56             }
  57         }
  58     }
  59     return $score;
  60 }
  61
  62 sub combo (Int $by is copy, @list is copy) {
  63     my @position = 0 .. $by - 2, $by - 2;
  64     my @stop     = @list.elems - $by .. @list.end;
  65     my $done     = undef;
  66     return sub {
  67         return () if $done;
  68         my $cur = @position.end;
  69         while ++@position[ $cur ] > @stop[ $cur ] {
  70             @position[ --$cur ]++;
  71             next if @position[ $cur ] > @stop[ $cur ];
  72             my $new_pos = @position[ $cur ];
  73             @position[ $cur .. @position.end ] = $new_pos .. $new_pos + $by;
  74             last;
  75         }
  76         $done = 1 if @position[ 0 ] == @stop[ 0 ];
  77         return @list[ @position ];
  78     };
  79 }
  80
  81 sub new_deck () returns Array {
  82     return (1..13).map: -> $num {
  83         <H D C S>.map: -> $suit {
  84             { num => $num, val => $num > 10 ?? 10 !! $num, suit => $suit };
  85         }
  86     };
  87 }