API

Note: The following is from the archives of the old wiki, with a few formatting tweaks. It may not be up to date.

Super Duper API

A number of people have expressed an interest in assisting in the growth of SDG by either submitting games or working on AI code. This page is an attempt to clarify how this can be done.

AI

I will first start with AI coding, as this is entirely different from creating a new game. If you wish to add/improve on an existing game's AI, no actual coding is required. The AI algorithms used at SDG expect that each board position can be reduced to a single numerical score for each player. The AI then searches all the possible positions and selects the move that will result in the highest overall score. To work on an AI, simply visit the wiki page for the game in question and add/update the AI section and provide for me a detailed algorithm as to how to reduce a given position to a numerical value (positive, negative, integer, floating-point, whatever). I will then translate this into the appropriate Perl code and you can test it out!

There are still caveats, however. The main one being that some games generate a prohibitively large game tree that is simply unfeasible to parse. The most obvious example is Homeworlds. The list of possible moves for each turn is immense and extremely difficult to process with any alacrity. Pikemen also poses a similar problem. That said, I warmly welcome any input as to AI creation and improvement.

New Games

The first thing to realize is that I did not originally design SDG with a third-party-friendly API. Unfortunately, it will take some time, and lots of back-and-forth between you and me, before things start working. That said, I am very excited to work with interested parties in the designing of new games. I am completely open to any questions or concerns you may have. Feel free to [[ac.snotlad|noraa#ac.snotlad|noraa|contact me]].

Absolute Basics

- SDG is coded entirely in Perl. This is unavoidable.
- SDG uses the [framework as found on [[http://search.cpan.org|CPAN].
- It is expected that you will use [[http://www.imagemagick.org/script/perl-magick.php|Image::Magick]] for all graphics generation.

What Exactly Do I Do?

All that is required of you is to code a working Games::AlphaBeta::Pos object. This object I then take and "plug in" to the overall framework. I will do my very best to explain how this is to be done. I will include below extracts from existing code to illustrate. If things are not clear, please contact me.

Header and Globals

<code perl>
package Mygame::Pos;
use base Games::AlphaBeta::Position;
use strict;

use Image::Magick;

my $datadir = '';
my $imgdatadir = '';
</code>

This is basically what should appear at the top of your Pos object. The variables ''$datadir'' and ''$imgdatadir'' point to static directories on the server where you can store whatever data your game ends up needing (stock images and the like). This is also where you can declare any other variables and information globally needed by your object. It should be noted that you may create as many auxilliary objects as you need for your game. Simply ''use'' them at the top of your Pos object.

Real Example - Homeworlds

package Homeworlds::Pos;
use base Games::AlphaBeta::Position;
use lib '/home/html/games/lib';
use strict;

use Image::Magick;
use Homeworlds::Ship;
use Homeworlds::System::Home;
use Homeworlds::System::Peripheral;
use YAML qw(Dump DumpFile Load LoadFile);

my $rootdir = '/home/html/games/';
my $datadir = $rootdir.'data/homeworlds/';
my $imgdatadir = $rootdir.'data/images/homeworlds/';
my $imgdir = $rootdir.'HTML/images/games/';
my @seats = qw(N S E W);
my %perspective = (N=>{N=>'S', E=>'W', S=>'N', W=>'E'}, E=>{N=>'E', E=>'S', S=>'W', W=>'N'}, 
        S=>{N=>'N', E=>'E', S=>'S', W=>'W'}, W=>{N=>'W', E=>'N', S=>'E', W=>'S'});
my %rotation = (N=>180, E=>90, S=>0, W=>270);
my %techtype = qw(Y propulsion G construction B conversion R weapons);
my %colorname = qw(Y yellow G green B blue R red);
my %colorabbrev = qw(YELLOW Y GREEN G BLUE B RED R);
my %seat2name = qw(N North E East S South W West);

Constructor

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;

    my $self = $class->SUPER::new() || return undef;

    $self->player('Player1');
    return $self;
}

This is the bare minimum constructor. At the very least it must call ''Games::AlphaBeta::Pos::new()'', set the current player, and return the blessed object. This is not a very useful object, however. Here is also where you would devise a way to represent the game board and any other state variables you might need. Here are some RL examples:

Real Example - Impasse

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;

    my $self = $class->SUPER::new() || return undef;

    $self->{board} = {};

    #seed board
    $self->{board}->{a1} = 'R';
    $self->{board}->{c1} = 'B2';
    $self->{board}->{e1} = 'R';
    $self->{board}->{g1} = 'B2';
    $self->{board}->{b2} = 'B2';
    $self->{board}->{d2} = 'R';
    $self->{board}->{f2} = 'B2';
    $self->{board}->{h2} = 'R';

    $self->{board}->{b8} = 'R2';
    $self->{board}->{d8} = 'B';
    $self->{board}->{f8} = 'R2';
    $self->{board}->{h8} = 'B';
    $self->{board}->{a7} = 'B';
    $self->{board}->{c7} = 'R2';
    $self->{board}->{e7} = 'B';
    $self->{board}->{g7} = 'R2';

    $self->player('R');
    return $self;
}

Real Example - Byte

This example shows the ''$variant'' variable. Variants are given full names like International or Expert Mode and can be passed to your object by the framework. Do with them what you will!

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;

    my $self = $class->SUPER::new() || return undef;

    my ($variants) = @_;
    $self->{international} = 0;
    if ( (defined $variants) && (ref($variants) eq 'ARRAY') ) {
        foreach my $variant (@$variants) {
            if ($variant =~ /^international/i) {
                $self->{international} = 1;
            }
        }
    }

    $self->{score}->{B} = 0;
    $self->{score}->{R} = 0;
    $self->{stacks} = [];
    $self->{lastpoint} = undef;
    $self->{board} = {};
    #seed board
        #blue
        my @ranks = qw(2 4 6);
        my @files = qw(a c e g);
        if ($self->{international}) {
            push @ranks, 8;
            push @files, 'i';
        }
        foreach my $col (@files) {
            foreach my $row (@ranks) {
                push @{$self->{board}->{$col.$row}}, 'R';
            }
        }
        #red
        @ranks = qw(3 5 7);
        @files = qw(b d f h);
        if ($self->{international}) {
            push @ranks, 9;
            push @files, 'j';
        }
        foreach my $col (@files) {
            foreach my $row (@ranks) {
                push @{$self->{board}->{$col.$row}}, 'B';
            }
        }

    $self->player('R');

    return $self;
}

findmoves()

This routine is expected to return a list of all legal moves for a given player in the current position. If you ever want an AI for your game, this routine is required. If, however, an AI is truly impossible (a la Homeworlds) then this routine can be omitted. Even so, the ''findmoves()'' routine can make your life infinitely easier. If you have a working ''findmoves()'' routine then your ''apply()'' can forego all error checking. Pikemen is an example of a game for which an AI is unfeasible, but generating a list of moves is trivial, so why not make your life easier?!

Real Example - Pikemen

This excerpt introduces two(2) home-rolled convenience routines. These are not provided by Games::AlphaBeta nor by the larger SDG framework. You are expected to write whatever routines you need, appropriate to your coding style. The routines in question are ''getOccupied()'' which returns a list of occupied cells, and ''nextCell()'' which takes a starting location and direction and returns the next cell (or ''undef'' if at the edge of the board).

The other issue that comes up here is the shuffling of the move list that occurs at the end of the excerpt. This is really only necessary if you plan on implementing an AI. As discussed above, the AI algorithm reduces all board positions to a single numerical value. Often, multiple moves will result in the same score. In this case, the first move encountered will be selected. If you never randomize your list of legal moves, then the AI will always select the same move given the same position. This is generally undesireable.

sub findmoves {
    my ($self, $player) = @_;
    $player = $self->player() if (! defined $player);
    my $color = $self->{players}->[$player];
    my %moves = ();

    foreach my $cell (@{$self->getOccupied()}) {
        my ($currColor, $size, $dir) = ($self->{board}->{$cell} =~ /^([RGBY])([123])(NE|NW|SE|SW|N|E|S|W|U)$/);
        next if ($currColor ne $color);

        #reorientation only
        foreach my $newdir (@dirs) {
            next if ($dir eq $newdir);
            $moves{$cell."($newdir)"} = 1;
        }

        #movement/captures
        if ($dir ne 'U') {
            my $next = $cell;
            while (1) {    #POSSIBLE INFINITE LOOP SITUATION
                $next = nextCell($next, $dir) || last;
                if (exists $self->{board}->{$next}) {
                    my $piece = $self->{board}->{$next};
                    my ($nextColor, $nextSize, $nextDir) = ($piece =~ /^([RGBY])([123])(NE|NW|SE|SW|N|E|S|W|U)$/);
                    last if ($nextColor eq $color); #can't capture your own pieces
                    last if ( ($nextDir eq 'U') && ($size <= $nextSize) );
                    my $move = $cell.'x'.$next;
                    $moves{$move} = 1;
                    foreach my $newdir (@dirs) {
                        next if ($dir eq $newdir);
                        $moves{$move."($newdir)"} = 1;
                    }
                    last;
                } else {
                    my $move = $cell.'-'.$next;
                    $moves{$move} = 1;
                    foreach my $newdir (@dirs) {
                        next if ($dir eq $newdir);
                        $moves{$move."($newdir)"} = 1;
                    }
                }
            }
        }
    }

    my @moves = keys %moves;
    use Algorithm::Numerical::Shuffle;
    @moves = Algorithm::Numerical::Shuffle::shuffle(@moves);
    return wantarray ? @moves : \@moves;
}

Real Example - Wizard's Garden

sub findmoves {
    my ($self) = @_;
    my %moves = ();

    if ($self->{turnnum} > 4) {
        foreach my $col ('A'..'D') {
            foreach my $row (1..4) {
                my $cell = $col.$row;
                next if (exists $self->{board}->{$cell});
                next if (! $self->hasAdj($cell));
                $moves{'b'.$cell} = 1;
                $moves{'w'.$cell} = 1;
            }
        }
    } else {
        foreach my $col ('A'..'D') {
            foreach my $row (1..4) {
                my $cell = $col.$row;
                next if (exists $self->{board}->{$cell});
                next if ($self->hasAdj($cell));
                $moves{'b'.$cell} = 1;
                $moves{'w'.$cell} = 1;
            }
        }
    }

    my @moves = keys %moves;
    use Algorithm::Numerical::Shuffle;
    @moves = Algorithm::Numerical::Shuffle::shuffle(@moves);
    return wantarray ? @moves : \@moves;
}

apply()

The ''apply()'' routine is the heart of your game. This routine takes a given move, updates the position, and decides who's turn it is next. As mentioned before, if you have a working ''findmoves()'' then this routine does not need to do any error checking. Otherwise, you will have to verify the given input and be prepared to provide useful errors. There are a number of ways you can provide feedback to the framework and it really depends on the type of game you are writing. The way I do it is to simply store the result of the move in some arbitrary variable (in my case ''lastresult'') and then the game board code can query that and output the appropriate chat message. Perl's axim, however, is There Is More Than One Way To Do It and I am of course open to different solutions if you would like to do something different.

Real Example - Wizard's Garden

This is one of the simplest ''apply()'' routines we have, I think.

sub apply {
    my ($self, $move, $player) = @_;
    $player = $self->player() if (! defined $player);

    my ($color, $cell) = ($move =~ /^([bw])([A-D][1-4])$/);

    $self->{lastpoint} = undef;
    #place the piece
    $self->setCell($cell, $color);
    $self->{stash}--;
    #flip surrounding pieces
    foreach my $dir (@dirs) {
        my $next = nextCell($cell, $dir) || next;
        $self->flipCell($next);
    }
    #check for harvest
    $self->{lastresult} = $self->harvest($player);
    return 1;
}

Real Example - Impasse

This shows a possible way to handle more complex notation.

sub apply {
    my ($self, $move, $color) = @_;
    $color = $self->player() if (! defined $color);
    return undef if (! defined $move);
    my @moves = split(/\//, $move);

    # undef:        unrecognized move
    # move:            successful move
    # transpose:    successful transposition
    # bear-off:        successful bear-off
    # crown:        successful crown
    my $result = [];

    foreach my $move (@moves) {
        my ($src, $type, $target) = ($move =~ /^([a-h][1-8])([\-\~\+])(([a-h][1-8])|(\(off\)))$/);
        return undef if (! defined $src);

        if ($type eq '-') {            #move
            if ($target eq '(off)') {
                if ($self->{board}->{$src} eq $color.'2') {
                    $self->{board}->{$src} = $color;
                } else {
                    delete $self->{board}->{$src};
                }
                push @$result, ['bear-off', $src];
            } else {
                my $piece = $self->{board}->{$src};
                $self->{board}->{$target} = $piece;
                delete $self->{board}->{$src};
                push @$result, ['move', $src, $target];
            }
        } elsif ($type eq '~') {    #transpose
            $self->{board}->{$src} = $color;
            $self->{board}->{$target} = $color.'2';
            push @$result, ['transpose', $src, $target];
        } elsif ($type eq '+') {    #crown
            delete $self->{board}->{$src};
            $self->{board}->{$target} = $color.'2';
            push @$result, ['crown', $src, $target];
        }
    }

    if (scalar(@$result) > 0) {
        $self->player($oppColor{$color});
    }
    $self->{lastresult} = $result;
}

Real Example - Homeworlds

This is the most complicated example. This ''apply()'' routine has to do all the error checking as well. Don't be surprised if the following makes no sense to you. I doesn't to me either half the time :-)

sub apply {
    my ($self, $movesArray, $seat) = @_;
    $seat = $self->{players}->[$self->player()] if (! defined $seat);
    return undef if ( (! defined $movesArray) || (ref($movesArray) ne 'ARRAY') || (scalar(@$movesArray) != 2) );
    my ($username, $moves) = @$movesArray;
    #my $moves = $movesArray->[1];
    #my $username = $movesArray->[0];
    return undef if ( (! defined $moves) || (ref($moves) ne 'ARRAY') || (scalar(@$moves) == 0) );

    $self->{lastelimination} = undef;
    my $result  = [];
    my $errors = [];
    my %actions = qw(free 1 R 0 G 0 B 0 Y 0);
    my $globalActions = 0;

    MOVE:
    foreach my $move (@$moves) {
        last if (scalar(@$errors) > 0);
        next if ($move =~ /^\s*$/);

        my ($cmd, @args) = split(/\s+/, $move); $cmd = lc($cmd);
        if ($cmd eq 'homeworld') {
            if (! canAct(\%actions)) {
                push @$errors, "You have no more actions.";
                last MOVE;
            }
            if (exists $self->{systems}->{home}->{$seat}) {
                push @$errors, "You already have a homeworld!";
                last MOVE;
            }

            my ($star1, $star2, $ship, $override) = @args;
            $star1 = uc($star1); $star2 = uc($star2); $ship = uc($ship);
            my $name = $username;
            #if ( (! defined $name) || ($name !~ /^[A-Za-z][A-Za-z0-9\_\-\']{1,14}$/) ) {
            #    push @$errors, "You must provide a name from 2-15 characters long using the characters [A-Za-z0-9_-'].";
            #    last MOVE;
            #}

            if (exists $self->{systems}->{all}->{$name}) {
                push @$errors, "A system has already been mapped with the name $name.";
                last MOVE;
            }

            foreach my $star ($star1, $star2, $ship) {
                if (! $self->takeStash($star)) {
                    push @$errors, "There are no $star pieces left in the stash to take.";
                    last MOVE;
                }
            }
            my $system = Homeworlds::System::Home->new($name, [$star1, $star2], $seat) || (push @$errors, "The System object could not be created.");
            my $shipObj = Homeworlds::Ship->new(split(//, $ship), $seat) || (push @$errors, "The Ship object could not be created.");

            #check for standard beginner errors
            if ( (! defined $override) || ($override ne '*') ) {
                #too small of a starting ship
                my $smallship = 0;
                $smallship = 1 if ($ship !~ /3$/);

                #less than 3 distinct colours
                my $fewcolors = 0;
                my %colors = ();
                foreach my $var ($star1, $star2, $ship) {
                    my ($color, $size) = split(//, $var);
                    $colors{uc($color)} = 1;
                }
                $fewcolors = 1 if (scalar(keys %colors) < 3);

                #same star size
                my $samestars = 0;
                my %sizes = ();
                foreach my $var ($star1, $star2) {
                    my ($color, $size) = split(//, $var);
                    $sizes{$size} = 1;
                }
                $samestars = 1 if (scalar(keys %sizes) < 2);

                #no green or yellow
                my $wrongtech = 0;
                $wrongtech = 1 if ( (! exists $colors{Y}) || (! exists $colors{G}) );

                if ($smallship) {
                    push @$errors, "It is very important to start with a size 3 ship!  To override this check, please append an asterisk (*) to the end of the 'homeworld' command (eg. homeworld y1 b2 g2 *).";
                    last MOVE;
                } elsif ($wrongtech) {
                    push @$errors, "It is very important that your homeworld have access to Yellow and Green technologies!  To override this check, please append an asterisk (*) to the end of the 'homeworld' command (eg. homeworld r1 b2 r3 *).";
                    last MOVE;
                } elsif ($fewcolors) {
                    push @$errors, "It is very important to include 3 different colours in your homeworld!  To override this check, please append an asterisk (*) to the end of the 'homeworld' command (eg. homeworld y1 y2 g3 *).";
                    last MOVE;
                } elsif ($samestars) {
                    push @$errors, "It is very important that your starting stars be different sizes!  To override this check, please append an asterisk (*) to the end of the 'homeworld' command (eg. homeworld y1 b1 g3 *).";
                    last MOVE;
                }
            }

            if ( (defined $system) && (defined $shipObj) ) {
                if (! $system->addShip($shipObj)) {
                    push @$errors, "The ship cannot dock in that system.";
                    last MOVE;
                }
                if (! $self->addSystem($system)) {
                    push @$errors, "The Position object did not accept the System.";
                    last MOVE;
                }
                push @$result, $seat2name{$seat}." seat has established a Homeworld.";
            }

        } elsif ($cmd eq 'discover') {
            if (! canAct(\%actions, 'Y')) {
                push @$errors, "You have no more actions.";
                last MOVE;
            }

            my ($ship, $fromSystem, $star, $newName) = @args;
            $ship = uc($ship); $star = uc($star);

            if ( (! defined $newName) || ($newName !~ /^[A-Za-z][A-Za-z0-9\_\-]{1,14}$/) ) {
                push @$errors, "You must provide a name from 2-15 characters long using the characters [A-Za-z0-9_-].";
                last MOVE;
            }

            #does the System exist?
            my $from = $self->getSystem($fromSystem);
            if (! defined $from) {
                push @$errors, "The ".ucfirst(lc($fromSystem))." system does not exist.";
                last MOVE;
            }

            #does the Ship exist?
            if (! $from->existsShip($ship.$seat)) {
                push @$errors, "You do not own the ship $ship in the ".$from->name()." system.";
                last MOVE;
            }

            #does the user have access to Yellow?
            if (! $from->hasColor('Y', $seat)) {
                if ( (! $globalActions) || (! $from->isOccupied($seat)) ) {
                    push @$errors, "You do not have access to propulsion technology (YELLOW) in this sector.";
                    last MOVE;
                }
            }

            #are the systems connected
            my $connected = 1;
            foreach my $existingStar (@{$from->stars()}) {
                my ($newSize) = ($star =~ /(\d)$/);
                my ($existingSize) = ($existingStar =~ /(\d)$/);
                if ($newSize == $existingSize) {
                    $connected = 0;
                    last;
                }
            }
            if (! $connected) {
                push @$errors, "These systems are not connected.";
                last MOVE;
            }

            #is name valid?
            if ( (! defined $newName) || ($newName !~ //) ) {
                push @$errors, "The name you provided for the newly discovered system is invalid.  It must be no longer than 15 characters and can only contain [A-Za-z0-9_-'].";
                last MOVE;
            }
            if (exists $self->{systems}->{all}->{$newName}) {
                push @$errors, "A system has already been mapped with the name $newName.";
                last MOVE;
            }

            #are there sufficient pieces in the stash
            if (! $self->takeStash($star)) {
                push @$errors, "There are insufficient $star pieces in the stash.";
                last MOVE;
            }

            my $newSystem = Homeworlds::System::Peripheral->new($newName, $star);
            if (! defined $newSystem) {
                push @$errors, "The System object could not be created.";
                last MOVE;
            }

            if (! $from->moveShip($ship.$seat, $newSystem)) {
                push @$errors, "The ship could not be moved.";
                last MOVE;
            }

            if ($self->addSystem($newSystem)) {
                push @$result, $seat2name{$seat}."'s ship $ship discovered a new star system!  It has been named $newName.";
            } else {
                push @$errors, "The new System object could not be created.";
                last MOVE;
            }

        } elsif ($cmd eq 'move') {
            if (! canAct(\%actions, 'Y')) {
                push @$errors, "You have no more actions.";
                last MOVE;
            }

            my ($ship, $fromSystem, $toSystem) = @args;
            $ship = uc($ship);

            #do the Systems exist?
            my $from = $self->getSystem($fromSystem);
            if (! defined $from) {
                push @$errors, "The ".ucfirst(lc($fromSystem))." system does not exist.";
                last MOVE;
            }
            my $to = $self->getSystem($toSystem);
            if (! defined $to) {
                push @$errors, "The ".ucfirst(lc($toSystem))." system does not exist.";
                last MOVE;
            }

            #does the Ship exist?
            if (! $from->existsShip($ship.$seat)) {
                push @$errors, "You do not own a ship $ship in the ".$from->name()." system.";
                last MOVE;
            }

            #does the user have access to Yellow?
            if (! $from->hasColor('Y', $seat)) {
                if ( (! $globalActions) || (! $from->isOccupied($seat)) ) {
                    push @$errors, "You do not have access to propulsion technology (YELLOW) in this sector.";
                    last MOVE;
                }
            }

            #are the systems connected
            my $connected = 1;
            STARCHECK:
            foreach my $existingStar (@{$from->stars()}) {
                foreach my $newStar (@{$to->stars()}) {
                    my ($newSize) = ($newStar =~ /(\d)$/);
                    my ($existingSize) = ($existingStar =~ /(\d)$/);
                    if ($newSize == $existingSize) {
                        $connected = 0;
                        last STARCHECK;
                    }
                }
            }
            if (! $connected) {
                push @$errors, "These systems are not connected.";
                last MOVE;
            }

            if (! $from->moveShip($ship.$seat, $to)) {
                push @$errors, "The ship could not be moved.";
                last MOVE;
            }

            push @$result, $seat2name{$seat}." moved their $ship ship from ".$from->name()." to ".$to->name().".";

        } elsif ($cmd eq 'construct') {
            if (! canAct(\%actions, 'G')) {
                push @$errors, "You have no more actions.";
                last MOVE;
            }

            my ($ship, $inSystem) = @args;
            $ship = uc($ship);

            #does the System exist?
            my $system = $self->getSystem($inSystem);
            if (! defined $system) {
                push @$errors, "The ".ucfirst(lc($inSystem))." system does not exist.";
                last MOVE;
            }

            #does the user have access to Green?
            if (! $system->hasColor('G', $seat)) {
                if ( (! $globalActions) || (! $system->isOccupied($seat)) ) {
                    push @$errors, "You do not have access to construction yards (GREEN) in this sector.";
                    last MOVE;
                }
            }

            #does the player already have a ship of that colour in the system?
            my ($color, $size) = split(//, $ship);
            if ( (! $system->existsShip($color.'1'.$seat)) && (! $system->existsShip($color.'2'.$seat)) && (! $system->existsShip($color.'3'.$seat)) ) {
                push @$errors, "To build a new ship you must already control one of the same colour ($color).";
                last MOVE;
            }

            #are there sufficient pieces in the stash
            if (! $self->takeStash($color.$size)) {
                push @$errors, "There are insufficient $color$size pieces in the stash.";
                last MOVE;
            }

            #did the player choose the smallest size available in that colour?
            if ( ($size == 2) && ($self->hasStash($color.'1')) ) {
                push @$errors, "You must choose the smallest available $color piece.";
                last MOVE;
            } elsif ( ($size == 3) && ( ($self->hasStash($color.'1')) || ($self->hasStash($color.'2')) ) ) {
                push @$errors, "You must choose the smallest available $color piece.";
                last MOVE;
            }

            #create the ship
            my $objShip = Homeworlds::Ship->new($color, $size, $seat);
            if (! defined $objShip) {
                push @$errors, "Unable to create Ship object.";
                last MOVE;
            }

            #dock it
            if (! $system->addShip($objShip)) {
                push @$errors, "The new ship was unable to dock in the ".$system->name()." system.";
                last MOVE;
            }

            push @$result, $seat2name{$seat}." created a $ship ship in the ".$system->name()." system.";

        } elsif ($cmd eq 'trade') {
            if (! canAct(\%actions, 'B')) {
                push @$errors, "You have no more actions.";
                last MOVE;
            }

            my ($oldShip, $newShip, $inSystem) = @args;
            $oldShip = uc($oldShip); $newShip = uc($newShip);

            #does the System exist?
            my $system = $self->getSystem($inSystem);
            if (! defined $system) {
                push @$errors, "The ".ucfirst(lc($inSystem))." system does not exist.";
                last MOVE;
            }

            #does the user have access to Blue?
            if (! $system->hasColor('B', $seat)) {
                if ( (! $globalActions) || (! $system->isOccupied($seat)) ) {
                    push @$errors, "You do not have access to salvage yards (BLUE) in this sector.";
                    last MOVE;
                }
            }

            #are the ships the same size
            my ($oldColor, $oldSize) = split(//, $oldShip);
            my ($newColor, $newSize) = split(//, $newShip);
            if ($newSize != $oldSize) {
                push @$errors, "You can only trade-in ships of the same size.";
                last MOVE;
            }

            #are there sufficient pieces in the stash
            if (! $self->takeStash($newShip)) {
                push @$errors, "There are insufficient $newShip pieces in the stash.";
                last MOVE;
            }

            #delete old ship
            if (! $system->delShip($oldShip.$seat)) {
                push @$errors, "$oldShip could not be destroyed.";
                last MOVE;
            }
            if (! $self->addStash($oldShip)) {
                push @$errors, "An unexpected error occurred while placing an $oldShip piece back in the stash.";
                last MOVE;
            }

            #create the new ship
            my $objShip = Homeworlds::Ship->new(split(//, $newShip), $seat);
            if (! defined $objShip) {
                push @$errors, "Unable to create Ship object.";
                last MOVE;
            }

            #dock it
            if (! $system->addShip($objShip)) {
                push @$errors, "The new ship was unable to dock in the ".$system->name()." system.";
                last MOVE;
            }

            push @$result, $seat2name{$seat}." traded their old $oldShip ship for a shiny new $newShip in the ".$system->name()." system.";

        } elsif ($cmd eq 'attack') {
            if (! canAct(\%actions, 'R')) {
                push @$errors, "You have no more actions.";
                last MOVE;
            }

            my ($ship, $inSystem) = @args;
            $ship = uc($ship);

            #does the System exist?
            my $system = $self->getSystem($inSystem);
            if (! defined $system) {
                push @$errors, "The ".ucfirst(lc($inSystem))." system does not exist.";
                last MOVE;
            }

            #does the user have access to Red?
            if (! $system->hasColor('R', $seat)) {
                if ( (! $globalActions) || (! $system->isOccupied($seat)) ) {
                    push @$errors, "You do not have access to sufficient weapons technology (RED) in this sector.";
                    last MOVE;
                }
            }

            #can you outgun the existing ship
            my $targetShip = $system->getShip($ship);
            if (! defined $targetShip) {
                push @$errors, "The ship $ship$seat could not be found in the ".$system->name()." system.";
                last MOVE;
            }
            my $sufficient = 0;
            foreach my $myShip (@{$system->getShips()}) {
                next if ($myShip->seat() ne $seat);
                if ($myShip->size() >= $targetShip->size()) {
                    $sufficient = 1;
                    last;
                }
            }
            if (! $sufficient) {
                push @$errors, "You are outgunned.  There is no way you can overcome the ship $ship.";
                last MOVE;
            }

            my $oldSeat = $targetShip->seat();
            $targetShip->seat($seat);
            if ($targetShip->seat() ne $seat) {

                push @$errors, "The Ship object could not be updated.";
                last MOVE;
            }

            push @$result, "A fight broke out in the ".$system->name()." system!  ".$seat2name{$oldSeat}."'s ".$targetShip->color().$targetShip->size()." ship was overtaken by $seat2name{$seat}.";

        } elsif ($cmd eq 'sacrifice') {
            if (! canAct(\%actions)) {
                push @$errors, "You have no more actions.";
                last MOVE;
            }

            my ($ship, $inSystem) = @args;
            $ship = uc($ship);

            #does the System exist?
            my $system = $self->getSystem($inSystem);
            if (! defined $system) {
                push @$errors, "The ".ucfirst(lc($inSystem))." system does not exist.";
                last MOVE;
            }

            #does the ship exist
            my $shipObj = $system->getShip($ship.$seat);
            if (! defined $shipObj) {
                push @$errors, "You do not control a $ship ship in the ".$system->name()." system.";
                last MOVE;
            }

            my ($color, $size) = split(//, $ship);
            $globalActions = 1;
            $actions{$color} = $size;

            if (! $system->delShip($shipObj->spec())) {
                push @$errors, "The ship $ship could not be destroyed.";
                last MOVE;
            }
            if (! $self->addStash($ship)) {
                push @$errors, "An unexpected error occurred while placing an $ship piece back in the stash.";
                last MOVE;
            }

            push @$result, $seat2name{$seat}."'s ship $ship was sacrificed in the ".$system->name()." system.";

        } elsif ($cmd eq 'catastrophe') {
            my ($inSystem, $color) = @args;
            $color = uc($color);

            $color = $colorabbrev{$color} if (exists $colorabbrev{$color});
            if (! exists $colorname{$color}) {
                push @$errors, "You did not provide a recognized colour name.";
                last MOVE;
            }

            #does the System exist?
            my $system = $self->getSystem($inSystem);
            if (! defined $system) {
                push @$errors, "The ".ucfirst(lc($inSystem))." system does not exist.";
                last MOVE;
            }

            if ($system->countColor($color) < 4) {
                push @$errors, "The ".$system->name()." system is not overpopulated with $color.";
                last MOVE;
            }

            my $pieces = $system->delColor($color);
            foreach my $piece (@$pieces) {
                if (! $self->addStash($piece)) {
                    push @$errors, "An unexpected error occurred while placing an $piece piece back in the stash.";
                    last MOVE;
                }
            }
            push @$result, "A catastrophe occurred in the ".$system->name()." system.  All ".$techtype{$color}." ($color) technology was lost.";

        } elsif ($cmd eq 'pass') {
            foreach my $key (keys %actions) {
                if ($actions{$key} > 0) {
                    $actions{$key}--;
                    last;
                }
            }
            push @$result, "$seat2name{$seat} seat passes.";
        } else {
            push @$errors, "$cmd is an unrecognized command.";
            last MOVE;
        }

        #did the player eliminate himself?
        if (exists $self->{systems}->{home}->{$seat}) {
            my $homeSystemName = $self->{systems}->{home}->{$seat};
            my $homeSystem = $self->{systems}->{all}->{$homeSystemName};
            if (! $homeSystem->isOccupied()) {
                push @$errors, "You may not cause your own elmination.  You must ensure you control at least one ship in your home system at the end of your turn.";
            }
        }

        #prune systems
        foreach my $systemName (keys %{$self->{systems}->{all}}) {
            my $system = $self->{systems}->{all}->{$systemName} || die $systemName;
            if ($system->{prune}) {
                if ($system->{prune} == 1) {
                    push @$result, "The ".$system->name()." system has been abandoned to the hyperspatial flux.";
                } elsif ($system->{prune} == 2) {
                    push @$result, "The ".$system->name()." system has gone supernova.";
                }
                if (ref($system) eq 'Homeworlds::System::Home') {
                    $self->{lastelimination} = [$seat, $self->getRelation($seat, $system->seat())];
                    push @$result, $seat2name{$system->seat()}." seat has been eliminated.";
                    $self->eliminatePlayer($system->seat());
                }
                $self->delSystem($system);
            }
        }

        #were other players eliminated (by loss of control)
        foreach my $oppSeat (@{$self->{players}}) {
            next if ($oppSeat eq $seat);
            next if (! exists $self->{systems}->{home}->{$oppSeat});
            my $systemName = $self->{systems}->{home}->{$oppSeat};
            my $oppSystem = $self->{systems}->{all}->{$systemName} || die $oppSeat;
            if (! $oppSystem->isOccupied()) {
                $self->{lastelimination} = [$seat, $self->getRelation($seat, $oppSeat)];
                push @$result, $seat2name{$oppSeat}." seat has lost control of their own homeworld.  This has resulted in their elimination.";
                $self->eliminatePlayer($oppSeat);
            }
        }
    }

    #does the player have unused actions?
    my $sum = 0;
    foreach my $actions (values %actions) {
        $sum += $actions;
    }
    if ( ($sum > 0) && (scalar(@$errors) == 0) ) {
        push @$errors, "You have $sum unused action".(($sum > 1) ? 's' : '').".  This system requires you to explicitely PASS any undesired actions.";
    }

    if (scalar(@$errors) == 0) {
        $self->nextPlayer();
        $self->{lastresult} = [1,$result];
    } else {
        $self->{lastresult} = [0,$errors];
    }
}

draw()

Next to the ''apply()'' routine, this is the most important. Can't play unless you can see what's happening! There are lots of different ways you could approach this. If you need help designing a game board, please let me know. I can easily generate variations on existing boards if that can help you. Don't forget that you can use auxilliary objects to help you in complicated situations. In Homeworlds, for example, the main ''draw()'' routine asks the Homeworlds::System and Homeworlds::Ship objects to ''draw()'' themselves and then composits them into the larger map.

Real Example - Wizard's Garden

This is the simplest example.

sub draw {
    my ($self) = @_;

    my $img = Image::Magick->new(size=>'200x200');
    $img->Read('png:'.$imgdatadir.'garden.png');

    #draw harvested markers
    if (scalar(@{$self->{harvested}}) > 0) {
        my $subimg = $self->getImg('X');
        foreach my $cell (@{$self->{harvested}}) {
            my ($x, $y) = $self->cell_toXY($cell);
            $img->Composite(image=>$subimg, compose=>'over', x=>$x, y=>$y);
        }
    }

    #draw the pieces
    my @cells = $self->getOccupied();
    foreach my $cell (@cells) {
        my $contents = $self->getCell($cell);

        #get piece
        my $subimg = $self->getImg(uc($contents));

        #draw the piece
        my ($x, $y) = $self->cell_toXY($cell);
        $img->Composite(image=>$subimg, x=>$x, y=>$y, compose=>'over');
    }

    return $img;
}

Real Example - Branches, Twigs, and Thorns

This is an example of a board that changes depending on the number of players.

sub draw {
    my ($self) = @_;

    my $pts = $points4;
    if ($self->{numplayers} == 4) {
        $pts = $points8;
    }

    my $img;
    if ($self->{numplayers} == 2) {
        $img = Image::Magick->new(size=>'380x220');
        $img->Read('png:'.$imgdatadir.'bttboard4.png');
    } else {
        $img = Image::Magick->new(size=>'380x380');
        $img->Read('png:'.$imgdatadir.'bttboard8.png');
    }

    #mark last placed piece
    if (defined $self->{lastplaced}) {
        my $lastx = $pts->{$self->{lastplaced}}->{x};
        my $lasty = $pts->{$self->{lastplaced}}->{y};
        $img->ColorFloodfill(fill=>'rgb(240,240,240)', bordercolor=>'black', x=>$lastx+10, y=>$lasty+10);
    }

    #draw the pieces
    foreach my $cell (@{$self->getOccupied()}) {
        my $contents = $self->{board}->{$cell};    #$self->getCell($cell);

        my $x = $pts->{$cell}->{x};
        my $y = $pts->{$cell}->{y};
        if ($contents eq 'NULL') {
            $img->ColorFloodfill(fill=>'black', x=>$x+10, y=>$y+10); #bordercolor=>'black', 
        } elsif ($contents eq 'ROOT') {
            my $subimg = Image::Magick->new(size=>'40x40');
            $subimg->Read('png:'.$imgdatadir.'root.png');
            $img->Composite(image=>$subimg, compose=>'over', x=>$x, y=>$y);
        } else {
            my $subimg = getPiece($contents);
            $img->Composite(image=>$subimg, compose=>'over', x=>$x, y=>$y);
        }
    }
    return $img;
}

endpos()

This routine is not strictly necessary but can help speed up the AI in some situations. The AI algorithm will keep examining positions until:
- the given depth has been reached
- ''findmoves()'' returns an empty list
- ''endpos()'' returns 1

In Pikemen, for example, ''findmoves()'' will continue to return valid moves even though a player may have reached the target score. ''endpos()'' would catch this situation and stop the AI from going any further along that branch of the game tree.

Real Example - Wizard's Garden

sub endpos {
    my ($self) = @_;

    return 1 if ($self->{stash} == 0);
    return 1 if (scalar(@{$self->getOccupied()}) == 16);
    return 1 if ( (scalar(@{$self->getOccupied()}) == 0) && ($self->{turnnum} > 1) );
    return 0;
}

evaluate()

Last, but not least, is the AI routine, ''evaluate()''. This is the routine that must return a single numerical value for a given player in the current position. The AI can be as simple or as complex as you wish, just be aware of speed issues.

Real Example - Impasse

sub evaluate {
    my ($self, $color) = @_;
    $color = $self->player() if (! defined $color);
    my $oppColor = $oppColor{$color};

    my $myScore = $self->countPieces($color);
    my $theirScore = $self->countPieces($oppColor);
    return ($theirScore - $myScore);
}

Summary

In the immortal words of Douglas Adams, "Don't panic!" If you are serious about coding a game, don't hesitate to contact me and I can help clarify any questions you may have. Hopefully the above has been helpful. If you have any suggestions or general feedback regarding this page, please let me know. Good luck!

Unless otherwise stated, the content of this page is licensed under Creative Commons Attribution-ShareAlike 3.0 License