Tic-Tac-Toe game model (sample implementation, and unit tests).

gistfile1.pl

use strict;
use warnings;
use 5.010000;
use ExtUtils::MakeMaker;

WriteMakefile(
  NAME              => 'TicTac',
  AUTHOR            => q{David Oswald <davido [@at] gmail [d.o.t] com>},
  VERSION           => '0.01',
  ABSTRACT          => 'TicTacToe game example.',
  LICENSE           => 'artistic_2',
  MIN_PERL_VERSION  => '5.010000',
  PL_FILES          => {},
  BUILD_REQUIRES => {
    'Test::More' => '0',         # Core.
  },
  PREREQ_PM => {
    'List::Util'       => '0',   # Core.
  },
  META_MERGE => {
    provides => {
      'TicTac' => {
        file    => 'lib/TicTac.pm',
        version => '0.01'
      },
    },
  },
  dist  => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
  clean => { FILES    => 'TicTac-*' },
);

test_tictac.t

#!/usr/bin/env perl

use strict;
use warnings;
use Test::More;
use lib 'lib';

BEGIN {
    use_ok('TicTac') || BAIL_OUT;
}

is( ref TicTac::TEST_REX, 'Regexp', 'Regex object constant declared.' );
is( TicTac::MIN_POSITION, 0, 'MIN_POSITION constant.' );
is( TicTac::MAX_POSITION, 8, 'MAX_POSITION constant.' );

can_ok(
    new_ok('TicTac'),   # isa_ok is implicit here.
    qw( winner        board        _decompose_move
        _valid_move   _place_move  _set_position play_moves )
);

# Note: These two tests break encapsulization.
is( TicTac->new->{board}, '---------', 'Empty board initialized.' );
is( TicTac->new('xxxoooxxx')->{board}, 'xxxoooxxx', 'Pre-set board.' );

# We'll use our accessor from now on.
is( TicTac->new->board, '---------', 'Board accessor gets.' );
my $game = TicTac->new;
$game->board('xxxoooxxx');
is( $game->board, 'xxxoooxxx', 'Board accessor sets.' );

my %trial_wins = (
    'Three in first row.'       => [ 'xxx......', 'x'   ],
    'Three in last row.'        => [ '......xxx', 'x'   ],
    'Three in first column.'    => [ 'o..o..o..', 'o'   ],
    'Three in last column.'     => [ '..x..x..x', 'x'   ],
    'Forward diagonal.'         => [ 'o...o...o', 'o'   ],
    'Backward diagonal.'        => [ '..o.o.o..', 'o'   ],
    'X wins vertically.'        => [ '.oxoox..x', 'x'   ],
    'O wins vertically.'        => [ 'xo..oxxo.', 'o'   ],
    'No winner, full board.'    => [ 'xoxoxooxo', undef ],
    'No winner, three-in-a-row' => [ '..ooo..o.', undef ],
    'X wins, diamond pattern.'  => [ 'x.x.x.x.x', 'x'   ],
    'No winner, rev-diamond.'   => [ '.x.x.x.x.', undef ],
);

while ( my ( $test_desc, $criteria ) = each %trial_wins ) {
    my ( $board, $expect ) = @{$criteria};
    is( TicTac->new($board)->winner(), $expect, $test_desc );
}

is_deeply( [ TicTac->new->_decompose_move('x5') ],
    [qw( x 5 )], '_decompose_move splits player id from grid location.' );

ok( TicTac->new('x-xxxxxxx')->_valid_move(1),  'Allow valid move.' );
ok( !TicTac->new('x-xxxooxx')->_valid_move(0), 'Disallow invalid move.' );
ok( !TicTac->new('---------')->_valid_move(-1), 'Disallow undeflow moves.' );
ok( !TicTac->new('---------')->_valid_move(9), 'Disallow overflow moves.' );

my $placer = TicTac->new('x-o-xxxxx');
$placer->_set_position( 8, 'o' );
is( $placer->board, 'x-o-xxxxo', 'set_position succeeds.' );
ok( $placer->_place_move( 'x', 1 ), 'Placed a valid move.' );
is( $placer->board, 'xxo-xxxxo', 'Board updated with x placement.' );
ok( !$placer->_place_move( 'o', 0 ), 'Failed to place an invalid move.' );
is( $placer->board, 'xxo-xxxxo', 'Board not updated with invalid move.' );

is( TicTac->new->play_moves(qw( x0 x1 x2 )),       'x', 'X wins!' );
is( TicTac->new->play_moves(qw( x1 o2 x4 o0 x7 )), 'x', 'X won again!' );
is( TicTac->new->play_moves(qw( x0 o6 x1 o2 x8 o4 )), 'o', 'O wins!' );
is( TicTac->new->play_moves(qw() ), undef, 'No winner.' );
is( TicTac->new->play_moves(qw( x0 o2 x1 o3 x5 o4 x6 o7 x8 )), undef,
    'Full board, no winner.'
);

eval { TicTac->new->play_moves(qw( x0 x0 ) )};
like( $@ , qr/invalid game/i, 'Dies when game play includes invalid moves.' );

done_testing();

TicTac.pm

package TicTac;

use strict;
use warnings;
use Carp;
use List::Util qw( first );

our $VERSION = '0.01';

use constant TEST_REX => qr/
  (?:
      (?:  (?<horiz> (?&MARKER) ) \g{horiz}{2} (?:...)* $ ) # Rows.
    | (?:  (?<vert>  (?&MARKER) ) (?:..\g{vert}){2}       ) # Columns.
    | (?: ^(?<fdiag> (?&MARKER) ) (?:...\g{fdiag}){2}     ) # Fwd diag.
    | (?:  (?<rdiag> (?&MARKER) ) (?:.\g{rdiag}){2}..   $ ) # Rev diag.
  )
  (?(DEFINE) (?<MARKER>[xo]) )
/ix;

use constant MIN_POSITION => 0;
use constant MAX_POSITION => 8;

sub new {
    my ( $class, $board ) = @_;
    return bless { board => $board // '---------' }, $class;
}

sub winner {
    my $self = shift;
    return first { defined } @+{ qw/ horiz vert fdiag rdiag / } # Slice
      if $self->board =~ TEST_REX;
    return;
}

sub board {
    my ( $self, $board ) = @_;
    $self->{board} = $board if defined $board;
    return $self->{board};
}

sub _decompose_move {
    my ( $self, $move ) = @_;
    return split //, $move;
}

sub _valid_move {
    my ( $self, $place ) = @_;
    # No match means empty spot: move is ok.
    return 0 if $place < MIN_POSITION || $place > MAX_POSITION;
    return 0 if substr( $self->board, $place, 1 ) =~ /[xo]/i;
    return 1;
}

sub _set_position {
    my ( $self, $position, $mark ) = @_;
    substr $self->{board}, $position, 1, $mark;
    return; # Unused rv.
}

sub _place_move {
    my ( $self, $who, $position ) = @_;
    if( $self->_valid_move($position) ) {
        $self->_set_position( $position, $who );
        return 1;
    }
    return 0;
}

sub play_moves {
    my ( $self, @moves ) = @_;
    foreach my $move (@moves) {
        croak 'Invalid game!'
          if !$self->_place_move( $self->_decompose_move($move) );
        if( my $winner = $self->winner ) {
            return $winner;
        }
    }
    return; # Nobody won.
}

1;