Games::Alak - simple game-tree implementation of a gomoku-like game

  % perl -MGames::Alak -e Games::Alak::play
   ...Or just run Alak.pm as if it were a program...
   ...Program responds with output, and a prompt:

  Lookahead set to 3.  I am X, you are O.
  Enter h for help
  X moves from 1 to 5, yielding .xxxx..oooo
  alak>
   ...and now you enter the commands to play.

   xxxx___oooo

  xxxx___oooo
    ^         Move 1: X moves from 3 (shown with caret) to 5
               (Note that any of X's pieces could move, but
               that the only place they could move to is 5.)
  xx_xx__oooo
          ^   Move 2: O moves from 9 to 7.
  xx_xx_oo_oo
     ^        Move 3: X moves from 4 to 6.
  xx__xxoo_oo
           ^  Move 4: O (stupidly) moves from 10 to 9.
  xx__xxooo_o
      ^       Move 5: X moves from 5 to 10, making the board
              "xx___xoooxo".  The three o's that X just
              surrounded are removed. 
  xx___x___xo
              O has only one piece, so has lost.

#!/usr/bin/perl
require 5;
package Games::Alak;
use strict;
use vars qw($Tree $Term $Max_depth $VERSION);
$VERSION = '0.19';
# BEGIN {$^W = 1}; # warnings on

use constant BOARD_SIZE => 11;
use constant ENDGAME  => 1000;
die( "Board_size " , BOARD_SIZE, " is too small!") if BOARD_SIZE < 9;

use constant NEW_BOARD_STRING =>
 ('xxxx' . ('.' x (BOARD_SIZE - 8)) . 'oooo');

#--------------------------------------------------------------------------

sub play {
  my($x_best_move, @o_move_chosen, $from, $to);
  
  $Max_depth = 3; # must be an integer > 0
  $Tree = _new_node(NEW_BOARD_STRING, 'x', -1,-10,0);
  
  use Term::ReadLine;
  $Term = Term::ReadLine->new('Alak');
  my $out = $Term->OUT;
  select($out) if $out;

  print "Lookahead set to $Max_depth.  I am X, you are O.\n";
  print "Enter h for help\n";
  
 Main_loop:
  while(1) {
    grow($Tree);
    $x_best_move = optimal_move($Tree, 'x');

    die "No X move possible?!" unless $x_best_move;
    $Tree = $x_best_move;  # select that node

    printf "X moves from %s to %s, yielding %s\n",
      1 + $Tree->{'last_move_from'},
      1 + $Tree->{'last_move_to'},
      $Tree->{'board'};
    
    if($Tree->{'endgame'}) {
      print "Endgame.  X wins after ",
         $Tree->{'move_count'}, " moves.\n";
      last;
    }
    grow($Tree) unless @{$Tree->{'successors'}};

   Get_move:
    {
      ($from, $to) = prompt_for_next_move();
      --$from; # we index from 0, not 1
      --$to;
      
      # check legality
      @o_move_chosen =
        grep $_->{'last_move_from'} eq $from &&
             $_->{'last_move_to'}   eq $to,
            @{$Tree->{'successors'}};
      if(@o_move_chosen > 1) {
        die "PANIC!? ", $Tree->{'board'};
      } elsif(@o_move_chosen == 0) {
        print "Invalid move!\n";
        redo Get_move;
      } else {
        # That move designates just one successor
        $Tree = $o_move_chosen[0];  # select that node.
      }
    }        

    printf "O moves from %s to %s, yielding %s\n",
      1 + $Tree->{'last_move_from'},
      1 + $Tree->{'last_move_to'},
      $Tree->{'board'};

    if($Tree->{'endgame'}) {
      print "Endgame.  O wins after ",
         $Tree->{'move_count'}, " moves.\n";
      last;
    }
  }
}

#--------------------------------------------------------------------------

sub prompt_for_next_move { # prompting
  my $line;
  while(defined($line = $Term->readline('alak>'))) {
    $line =~ s/^\s+//s;
    $line =~ s/\s+$//s;
    next unless length($line);
    $Term->addhistory($line);

    # Knuckle-headed command parsing:

    if($line =~ m/^q/s) {
      last;  # quit
    } elsif($line =~ m/^(\d+)\s*to\s*(\d+)$/s) {
      return($1, $2);
    } elsif($line =~ m/^g(?:row)?$/s) {
      grow($Tree);
      print "Tree grown.\n";
    } elsif($line eq 'reset') {
      $Tree = _new_node(NEW_BOARD_STRING, 'o', -1,-1,0,0);
      grow($Tree);
      print "Board reset to ", NEW_BOARD_STRING, "\nYour move.\n";
    } elsif($line =~ m/^reset\s+([.ox]+)/s) {
      my $board = $1;
      if(length($board) != BOARD_SIZE) {
        print "But a board has to be ", BOARD_SIZE, " wide, not ",
          length($board), "\n";
      } elsif($board !~ m/\./s) {
        print "But there's no spaces on board $board\n";
      } elsif(($board =~ tr/x//) < 2) {
        print "But there's fewer than two x's in board $board\n";
      } elsif(($board =~ tr/o//) < 2) {
        print "But there's fewer than two o's in board $board\n";
      } else {
        $Tree = _new_node($board, 'o',-1,-1,0,0);
        grow($Tree);
        print "Board reset to $board\nYour move.\n";
      }
    } elsif($line =~ m/^d(?:ump)?\s*(\d+)?$/s) {
      dump_tree($Tree, defined($1) ? ($1 + 1) : undef);
    } elsif($line eq 'advise' or $line eq 'advice') {
      my $m = optimal_move($Tree,'o');
      printf "Try %d to %d.\n",
        1 + $m->{'last_move_from'},
        1 + $m->{'last_move_to'},
      ;
    } elsif($line =~ m/l(?:ookahead)?\s+([1-9]+)$/s) {
      $Max_depth = $1;
      print "Lookahead set to $1.\n";
    } elsif($line =~ m/^h/s) {
      print
        "Commands:\n",
        "  q -- quit\n",
        "  dump N -- dump game tree to depth N.\n",
        "  lookahead N -- set tree-deepening depth to N.\n",
        "  advise -- have me suggest a move.\n",
        "  reset -- start anew.\n",
        "  reset xxx.o.x..oo -- start anew from the board specified.\n",
        "  N to N -- move piece from N to N.\n",
        "  h -- help (this message)\n",
        "\n",
    } else {
      print "Unknown command.  Enter h for help.\n";
    }
  }

  # Either we got undef back, or lasted out from 'q'
  print "Quitting.\n";
  exit;
}
  
#--------------------------------------------------------------------------

sub _new_node {
  return
    {
     'board'          => $_[0],
     'whose_turn'     => $_[1],
     'last_move_from' => $_[2], 
     'last_move_to'   => $_[3],
     'last_move_payoff' => $_[4],
      # payoff to x, that is.
     'move_count' => $_[5],
     'successors' => [],
    };
}

#--------------------------------------------------------------------------

sub grow {
  my $n = $_[0];
  my $depth = $_[1] || 0;
  figure_successors($n)
   unless
    $depth >= $Max_depth
    or @{$n->{'successors'}}
    or $n->{'endgame'};
  
  if(@{$n->{'successors'}}) {
    my $a_payoff_sum = 0;
    foreach my $s (@{$n->{'successors'}}) {
      grow($s, $depth + 1);  # RECURSE
      $a_payoff_sum += $s->{'average_payoff'};
    }
    $n->{'average_payoff'} =
      $a_payoff_sum / @{$n->{'successors'}};
  } else {
    $n->{'average_payoff'} = $n->{'last_move_payoff'};
  }
}

#--------------------------------------------------------------------------

sub optimal_move {
  my($board, $mover) = @_;
  # given a board (node), return the successors that are the
  #   best for the mover.
  # (in scalar context, randomly choose from
  #  the best ones, if there's a tie for first place)

  my @best_cases;  
  foreach my $c (@{$board->{'successors'}}) {
    my $this_payoff = $c->{'average_payoff'};
    if(!@best_cases  # nothing seen yet
       or $best_cases[0]{'average_payoff'} == $this_payoff
         # tie for first place so far
    ) {
      push @best_cases, $c;
    } elsif(
        $mover eq 'x' # does 'best' mean HIGH payoff?
        ? ($this_payoff > $best_cases[0]{'average_payoff'}) # max!
        : ($this_payoff < $best_cases[0]{'average_payoff'}) # min!
    ) {
        @best_cases = ($c);
    }
     # otherwise what's there is not as good as what we've got
  }
  return $best_cases[0] if @best_cases == 1; # no tie
  return $best_cases[rand @best_cases] if @best_cases;
  return undef;  # shouldn't ever happen!
}


#--------------------------------------------------------------------------

{
  my($depth, $census, $max_depth_seen, $show_to_depth);
  
  sub dump_tree {
    # wrapper around _dump_recursor
    my $starting_node;
    ($starting_node, $show_to_depth) = @_;
    # initialize things
    $depth = $census = $max_depth_seen = 0;
    _dump_recursor($starting_node);
    printf "%d in tree of depth %d (branching factor %.2f)\n",
      $census, $max_depth_seen, 
      $census ** (1/($max_depth_seen || 1)),
    ;
  }
  
  sub _dump_recursor {
    my $n = $_[0];
    
    ++$census;
    $max_depth_seen = $depth if $depth > $max_depth_seen;
    printf "  %s%s    %s %2s to %2s %s %s %s\n",
      ' : ' x $depth, # indenting
      $n->{'board'},
      $n->{'whose_turn'} eq 'o' ? 'x' : 'o',
      # Count places on the board starting at 1:
      1 + $n->{'last_move_from'},
      1 + $n->{'last_move_to'},
      omit_if_zero('Immediate score = ', $n->{'last_move_payoff'}),
      omit_if_zero('Avg score = ', $n->{'average_payoff'}),
      $n->{'endgame'} ? 'endgame' : '',
     unless defined($show_to_depth) and $show_to_depth <= $depth;
    
    if(@{$n->{'successors'}}) {
      ++$depth;
      foreach my $s (@{$n->{'successors'}}) {
        _dump_recursor($s);
      }
      --$depth;
    }
    
    return;
  }
}

sub omit_if_zero {
  return '' unless $_[1];
  return join(' ', $_[0], substr($_[1],0,5));
}

#--------------------------------------------------------------------------

sub figure_successors {  # ...of a given node
  die "I need a board!" unless ref $_[0] eq 'HASH';
  my $node = $_[0];
  return if $node->{'endgame'}
   or $node->{'board'} =~ tr/x// < 2
   or $node->{'board'} =~ tr/o// < 2;

  my $board = $node->{'board'};
  my $mover = $node->{'whose_turn'};
  my $other;
  if($mover eq 'x') { $other = 'o' }
  elsif ($mover eq 'o') { $other = 'x' }
  else {die "Mover \"$mover\" is neither x nor o!"; }

  my $successors = $node->{'successors'};
  die "I already figured successors for this!?" if @$successors;

  my $this_move_count = 1 + ($node->{'move_count'} || 0);

  foreach(my $i = 0; $i < BOARD_SIZE; $i++) {
    next unless substr($board,$i,1) eq $mover;

    # Find the first blanks to the left and
    #  to the right of the current piece
    foreach my $to (
      rindex($board,'.',$i-1),
       index($board,'.',$i+1),
    ) {
      next if $to == -1;
       # if no move possible in this direction

      my $new_board = $board;
      substr($new_board, $i, 1) = '.'; # move from...
      substr($new_board, $to,1) = $mover; # ...to

      my $payoff = 0;

      # Now see if a move from $i to $to deletes nonmover's pieces!
      # Look for mover's piece and other pieces in the part of
      #  the board that's to my left, and my right.
      # (This is the only really scary code in this program.  Honest!)
      $payoff += length $1   # look to the left
       if $to > 1 and
        $mover eq 'o'
         ? substr($new_board,0,$to) =~ s/o(x+)$/'o' . ('.' x length $1)/se
         : substr($new_board,0,$to) =~ s/x(o+)$/'x' . ('.' x length $1)/se;
      $payoff += length $1   # look to the right
       if $to < BOARD_SIZE - 2 and
        $mover eq 'o'
         ? substr($new_board,$to+1) =~ s/^(x+)o/('.' x length $1) . 'o'/se
         : substr($new_board,$to+1) =~ s/^(o+)x/('.' x length $1) . 'x'/se;

      # Exaggerate payoff if $mover wins
      my $is_endgame;
      if( grep($_ eq $other, split '', $new_board) < 2 ) {
        $payoff = ENDGAME;
        $is_endgame = 1;
      }
      $payoff = 0 - $payoff if $mover eq 'o';
         # harming X is a /negative/ payoff

      push @$successors,
        _new_node(
          $new_board,
          $other, # it's other guy's turn now
          $i,
          $to,
          $payoff,
          $this_move_count,
        );
      $successors->[-1]{'endgame'} = 1 if $is_endgame;
       # THAT node shouldn't have successors
    }
  }
  return;
}

#--------------------------------------------------------------------------
play() unless caller;
 # if this module is what was run (instead of used), then start game

#--------------------------------------------------------------------------
1;

__END__