http://www.perlmonks.org?node_id=87617

   1: #! /usr/local/bin/perl -w
   2: 
   3: use strict;
   4: use warnings;
   5: use diagnostics;
   6: use Data::Dumper;
   7: 
   8: # I found the Sunday Times teaser 2021 interesting enough
   9: # to write a program to solve after I had a few goes on
  10: # paper and kept getting it wrong.
  11: #
  12: # It manages to do what should be a depth first search
  13: # using a simple for loop due to the relative simplicity
  14: # of the search space.
  15: # P.S. There is a prize for sending in the first correct
  16: # answers, but you'll need to have a copy of the ST in
  17: # order to find the address.
  18: #
  19: # Problem taken from Sunday Times 10-Jun-01
  20: #
  21: # Spladders, a game like snakes and ladders, is played
  22: # on a board with spaces numbered 0..N .
  23: # A Player starts at 0, casts the die and moves his
  24: # counter forward the number of squares shown. If he
  25: # lands on a prime, he moves up to the next prime.
  26: # If he lands on a square, he moves down to the next
  27: # lower square (e.g. 25 to 16). Tom and I played a game.
  28: # I went first, and we each threw the die seven times.
  29: # Each time, after Tom threw, his position was double mine
  30: # (and never zero).
  31: #
  32: # What were our positions after seven throws ?
  33: 
  34: my $last = 0;
  35: my $next;
  36: my %primes = ();
  37: 
  38: for (2,3,5,7,11,13,17,19,23,29,31,37,41,43,47)
  39: {
  40:    $primes{$last} = int($_);
  41:    $last = $_;
  42: }
  43: delete $primes{0};
  44: 
  45: my %squares = ();
  46: map {$squares{$_ * $_} = int(($_ - 1) * ($_ - 1))} (1..10);
  47: 
  48: my @posshim = ();
  49: my @possme  = ();
  50: my $start   = 0;
  51: my @carry   = ();
  52: my @record  = (0);
  53: my @all     = ();
  54: my %record  = (0=>[0]);
  55: 
  56: ### roll
  57: 
  58: for (1..7)
  59: {
  60:    roll($_);
  61: }
  62: die "Failed, More than 1 possible sequence"
  63:    if @all > 1;
  64: die "Failed, no possible sequences"
  65:    if @all < 0;
  66: 
  67: print "-------\n\n";
  68: report("My final Sequence",@{$record{$all[0]}});
  69: 
  70: 
  71: #########
  72: 
  73: sub roll
  74: {
  75:    my $roll = shift;
  76:    @carry = @record;
  77:    @record = @all = ();
  78:    report("-----\nRoll $roll",@carry);
  79:    for (@carry)
  80:    {
  81:       my $start    = $_;
  82:       print "Starting with $_\n------\n";
  83:       @possme = MyTry($start);
  84:       @posshim = HisTry($start*2);
  85: 
  86:       report("His possibles        ",@posshim);
  87:       #report("My  possibles",@possme);
  88: 
  89:       my @newme  = carry_me(\@possme, @posshim);
  90:       report("My Matching possibles",@newme);
  91:       for my $val (@newme)
  92:       {
  93:          push(@record,$val) unless grep {$_ == $val} @record;
  94:       }
  95:       record($start,@newme);
  96:    }
  97: }
  98: 
  99: sub record
 100: {
 101:    my $end = shift;
 102:    my @poss = @_;
 103:    my $i;
 104:    my @ref;
 105:    my $found = -1;
 106: 
 107:    #print Data::Dumper->Dump([\%record],["Record"]) , $/;
 108:    for my $poss (@poss)
 109:    {
 110:       my @new = @{$record{$end}};
 111:       push(@new,$poss);
 112:       $record{$poss} = \@new;
 113:       report("Carrying Forward",@new);
 114:       push(@all,$poss);
 115: 
 116:    }
 117:    #print Data::Dumper->Dump([\%record],["Post - Record"]) , $/;
 118: }
 119: 
 120: sub report
 121: {
 122:    my $name = shift;
 123:    my $values = join(', ',@_);
 124:    print "$name => [$values]\n";
 125: }
 126: 
 127: sub HisTry
 128: {
 129:    my $start = shift;
 130:    my @poss  = ();
 131:    for my $die (1..6)
 132:    {
 133:       my $mid = $start + $die;
 134:       my $new = move($start,$die);
 135:       $new = move($start,$die);
 136:       my $valid = validHim($new);
 137:       #print "Him => $start + $die => $mid => $new $valid\n";
 138:       push(@poss,$new) if $valid;
 139:    }
 140:    return @poss;
 141: }
 142: 
 143: sub MyTry
 144: {
 145:    my $start = shift;
 146:    my @poss  = ();
 147:    for my $die (1..6)
 148:    {
 149:       my $mid = $start + $die;
 150:       my $new = move($start,$die);
 151:       $new = move($start,$die);
 152:       my $valid = validMe($new);
 153:       #print "Me  => $start + $die => $mid => $new $valid\n";
 154:       push(@poss,$new) if $valid;
 155:    }
 156:    return @poss;
 157: }
 158: 
 159: sub carry_me
 160: {
 161:   my $ref = shift;
 162:   my @him = @_;
 163:   my @new = ();
 164:   for my $value (@$ref)
 165:   {
 166:      push(@new,$value) if grep {$value*2 == $_} @him;
 167:   }
 168:   return @new;
 169: }
 170: 
 171: sub validHim
 172: {
 173:    my $value = shift;
 174:    return 0 if $value % 2;
 175:    return 0 if $value == 0;
 176:    return 1;
 177: }
 178: 
 179: sub validMe
 180: {
 181:    my $value = shift;
 182:    return 0 if $value == 0;
 183:    return 1;
 184: }
 185: 
 186: sub move
 187: {
 188:    my $old = shift;
 189:    my $roll = shift;
 190:    my $new = $old + $roll;
 191:    $new = $primes{$new} if defined($primes{$new});
 192:    $new = $squares{$new} if defined($squares{$new});
 193:    return int($new);
 194: }