hex.pl

#!/usr/bin/perl

use strict;
use Getopt::Long;

my $size = 48;
my $dict = 'dict';
my ($name, $board_file, $reprocess_frequencies, $print_board, $print_html, $print_help);
my $help = qq{Hexiled word-tile simulator

Options:
    --name      specify the name of the player (required)
    --size      specify the board size if generating (default: 48)
    --board     filename specifying the board to use
    --dict      filename specifying the dictionary to use (default: dict)
    --reprocess_frequencies     regenerate the frequency list
    --print_board   prints the board and exits
    --print_html    prints the board as HTML and exits
    --help      show this help

};

GetOptions(
    "name=s"        => \$name,
    "size:i"        => \$size,
    "board:s"       => \$board_file,
    "dict:s"        => \$dict,
    "reprocess_frequencies" => \$reprocess_frequencies,
    "print_board"   => \$print_board,
    "print_html"    => \$print_html,
    "help"          => \$print_help,
) or die($help);

die($help) if $print_help;

if ($name =~ /\W/) {
    die('Error: Name contains invalid characters.');
}

unless (-e $dict) {
    die('Error: Dictionary not found.');
}

if ($board_file && ! -e $board_file) {
    die('Error: Board not found.');
}

my $dictionary = Dictionary->new({
    source => $dict,
    reprocess_frequencies => $reprocess_frequencies || '',
});

my $board = Board->new({
    source => $board_file || '',
    dict => $dictionary,
    used => [],
    size => $size,
});

my $game;

if ($print_board) {
    $board->render;
}
elsif ($print_html) {
    $board->renderHTML;
}
else {
    $game = Game->new({
        board => $board,
        words => [],
        word => [],
    });

    while (<STDIN>) {
        if (/^a (-?\d+),(-?\d+)$/i) {
            if ($game->{board}->isValidTile($game->{board}->get($1, $2), $game->{word}) && !grep {
                $_->[0] == $1 && $_->[1] == $2
            } @{$game->{word}}) {
                push @{$game->{word}}, $game->{board}->get($1, $2);
                print qq{OK\n};
            }
            else {
                print qq{ERROR\n};
                warn "not valid tile";
            }
        }
        elsif (/^s (-?\d+),(-?\d+)$/i) {
            my @data = $game->{board}->getSurroundingTiles($game->{board}->get($1, $2));

            for (@data) {
                printf "%s %d,%d\n", $_->[2], $_->[0], $_->[1];
            }
        }
        elsif (/^s$/i) {
            my $previous = scalar @{$game->{word}} ? $game->{word}[scalar @{$game->{word}} - 1] : undef;

            my @data = $previous ?
                $game->{board}->getSurroundingTiles($previous) :
                $game->{board}->getRequiredTiles;

            for (@data) {
                printf "%s %d,%d\n", $_->[2], $_->[0], $_->[1];
            }
        }
        elsif (/^c$/i) {
            if ($game->{board}->isValidWord($game->{word})) {
                if ($game->commit) {
                    print qq{OK\n};

                    if ($game->complete) {
                        last;
                    }
                }
                else {
                    print qq{ERROR\n};
                    warn "commit failed";
                }
            }
            else {
                print qq{ERROR\n};
                warn "word not valid";
            }
        }
        elsif (/^w$/i) {
            for (@{$game->{word}}) {
                printf qq{%s %d,%d\n}, $_->[2], $_->[0], $_->[1];
            }
        }
        elsif (/^ws$/i) {
            for (@{$game->{words}}) {
                for (@{$_}) {
                    printf qq{%s %d,%d\n}, $_->[2], $_->[0], $_->[1];
                }

                print "\n";
            }
        }
        elsif (/^b$/i) {
            $game->{board}->render;
        }
        elsif (/^v (-?\d+),(-?\d+)$/i) {
            print $game->{board}->get($1, $2)->[2]."\n";
        }
        elsif (/^d$/i) {
            $game->{word} = [];
        }
        elsif (/^h$/i) {
            print qq{Help:

a x,y   adds the letter at the specified co-ordinate to the current word
        This method will return 'OK' on success or 'ERROR' on failure. In the
        case of an error, the current letter will not be added.

s       show the surrounding tiles for the last tile you selected.
        This will return a list of letters and tiles around the current last
        tile you placed, to show you what you have available for your next
        move. It uses the following format if you have started a word, or
        returns 'ERROR' otherwise:
            n 0,7
            o -1,8
            m -2,6
            l -2,7

w       show the current word
        This method will print out the current word so far including co-
        ordinates in the following format, or 'ERROR' if there is no word in
        progress:
            u 0,1
            n -1,2
            i -1,3

c       commits the current word to the game
        The played tiles will be removed and any bombs triggered will detonate,
        removing any affected tiles. Returns 'OK' on success and 'ERROR' on
        failure.

v x,y   shows the letter at position x,y
d       empties the current word
b       print the board
h       this help
r       resign the current game
x       exit without cleanup or save

(Note: all commands are case-insensitive)
};
        }
        elsif (/^r$/i) {
            # resign
            last;
        }
        elsif (/^x$/i) {
            exit;
        }
        else {
            print qq{UNKNOWN\n};
        }
    }

    $game->generateReport;
}






##############################################################################
# objects
{
    use strict;

##############################################################################

    package Base;
    sub new {
        my $class = shift;
        my $self = bless shift || {}, $class;

        $self->load if $self->can('load') && $self->{source};
        $self->init if $self->can('init');

        return $self;
    }

    1;

##############################################################################

    package Dictionary;
    use base qw(Base);
    use List::Util qw(shuffle);

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

        open my $fh, $self->{source} or die "Could not open $self->{source}: $!";

        $self->{data} = [];

        while(<$fh>) {
            chomp;
            push @{$self->{data}}, $_;
        }

        close $fh;
    }

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

        if ($self->{reprocess_frequencies}) {
            my (%letters, $count);

            for (@{$self->{data}}) {
                $letters{lc $_}++ for /./g;
            }

            $count += $letters{$_} for 'a'..'z';
            $self->{frequencies}{$_} = $letters{$_}/$count for 'a'..'z';
        }
        else {
            $self->{frequencies} = {
                'a' => 0.088233,
                'b' => 0.017888,
                'c' => 0.045833,
                'd' => 0.030233,
                'e' => 0.104327,
                'f' => 0.010720,
                'g' => 0.020858,
                'h' => 0.028519,
                'i' => 0.089091,
                'j' => 0.001382,
                'k' => 0.007130,
                'l' => 0.057818,
                'm' => 0.031297,
                'n' => 0.070340,
                'o' => 0.075670,
                'p' => 0.034645,
                'q' => 0.001653,
                'r' => 0.071305,
                's' => 0.061833,
                't' => 0.067725,
                'u' => 0.038707,
                'v' => 0.008946,
                'w' => 0.006137,
                'x' => 0.003067,
                'y' => 0.022895,
                'z' => 0.003748,
            };
        }

        if ($self->{data}) {
            $self->{dict} = {};
            for (@{$self->{data}}) {
                $self->{dict}{$_}++;
            }
        }
    }

    # returns a random letter, weighted by frequency
    sub letter {
        my ($self) = @_;

        my ($n, $l) = (rand);
        for (shuffle('a'..'z')) {
            $n -= $self->{frequencies}{$_};

            if ($n < 0) {
                $l = $_;
                last;
            }
        }

        return $l;
    }

    sub validate {
        my ($self, $word) = @_;

        return !!$self->{dict}{$word};
    }

    1;

##############################################################################

    package Board;
    use base qw(Base);
    use POSIX;

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

        if (!$self->{board}) {
            $self->build;
        }

        $self->use($self->get(0,0));
    }

    sub load {
        my ($self) = @_;
        $self->{board} = {};

        open my $fh, $self->{source} or die "Could not open $self->{source}: $!";

        my @data = ();

        while(<$fh>) {
            chomp;
            push @data, $_;
        }

        @data = reverse @data; # because of how we build the board, make sure we reverse the input

        my ($min, $max) = $self->getMinMax(length $data[0]);

        for my $y ($min..$max) {
            for my $x ($min..$max) {
                $self->set($x, $y, ' '); # create as empty
                next if $x < $min + ceil($y / 2) || $x > $max + ceil($y / 2); # top-left and bottom-right
                next if $x < $min - floor($y / 2) || $x > $max - floor($y / 2); # top-right and bottom-left
                $self->{board}{$x}{$y} = substr $data[$y + $max], $x + $max, 1;
            }
        }

        close $fh;
    }

    sub build {
        my ($self) = @_;
        $self->{board} = {};

        my ($min, $max) = $self->getMinMax;

        for my $y ($min..$max) {
            for my $x ($min..$max) {
                $self->set($x, $y, ' '); # create as empty
                next if $x < $min + ceil($y / 2) || $x > $max + ceil($y / 2); # top-left and bottom-right
                next if $x < $min - floor($y / 2) || $x > $max - floor($y / 2); # top-right and bottom-left/
                $self->set($x, $y, $self->{dict}->letter);
            }
        }

        return $board;
    }

    sub get {
        my ($self, $x, $y) = @_;

        return [$x, $y, $self->{board}{$x}{$y}];
    }

    sub set {
        my ($self, $x, $y, $value) = @_;
        $self->{board} = {} unless $self->{board};
        $self->{board}{$x} = {} unless $self->{board}{$x};

        return $self->{board}{$x}{$y} = $value;
    }

    sub getMinMax {
        my ($self, $size) = @_;
        $size ||= $self->{size};

        return (-$size / 2, $size / 2);
    }

    sub renderHTML {
        my ($self, $report) = @_;
        my ($min, $max) = $self->getMinMax;
        my $width = ($size * 41) + 40;

        print qq{<!DOCTYPE html><html><head><title>Hexiled clone</title><style type="text/css">.hex{font-family:sans-serif;font-size:10px;font-weight:700;text-transform:uppercase}.hex ul{clear:both;list-style:none;padding:0;margin:0}.hex ul:nth-child(odd){margin-left:20px}.hex ul li{float:left;display:block;text-align:center;width:40px;line-height:20px;background:-webkit-gradient(linear,left top,left bottom,color-stop(25%,transparent),color-stop(25%,#ccf),color-stop(75%,#ccf),color-stop(75%,transparent));margin:-5px 1px -4px 0}.hex ul li:after,.hex ul li:before{content:' ';display:block;width:0;height:0;overflow:hidden;border-left:20px dotted transparent;border-right:20px dotted transparent}.hex ul li:before{border-bottom:10px solid #ccf}.hex ul li:after{border-top:10px solid #ccf}.hex ul li[data-active="0"],.hex ul li[data-used="1"]{visibility:hidden}.hex ul li[data-bomb="1"]{background:-webkit-gradient(linear,left top,left bottom,color-stop(25%,transparent),color-stop(25%,#88f),color-stop(75%,#88f),color-stop(75%,transparent))}.hex ul li[data-bomb="1"]:before{border-bottom:10px solid #88f}.hex ul li[data-bomb="1"]:after{border-top:10px solid #88f}.hex ul li:hover{background:-webkit-gradient(linear,left top,left bottom,color-stop(25%,transparent),color-stop(25%,#aaf),color-stop(75%,#aaf),color-stop(75%,transparent))}.hex ul li:hover:before{border-bottom:10px solid #aaf}.hex ul li:hover:after{border-top:10px solid #aaf}</style></head><body style="min-width: ${width}px;"><div class="hex">};

        for my $y ($min..$max) {
            $y = -$y;
            print qq{<ul data-y="$y">};
            for my $x ($min..$max) {
                my $letter = $self->get($x, $y);
                my $character = $letter->[2];
                my $bomb = $character =~ /[jxzq]/ ? '1' : '0';
                my $active = !$self->isEmpty($letter) ? '1' : '0';
                my $used = $self->isUsed($letter) ? '1' : '0';
                my $limit = 0; # TODO
                print qq{<li data-x="$x" data-letter="$character" data-used="$used" data-bomb="$bomb" data-limit="$limit" data-active="$active">$character</li>};
            }
            print qq{</ul>};
        }

        if ($report) {
            print qq{<script type="text/javascript">$report</script><script type="text/javascript">Report.run();</script>};
        }

        print qq{</div></body></html>};
    }

    sub render {
        my ($self) = @_;
        my ($min, $max) = $self->getMinMax;

        for my $y ($min..$max) {
            $y = -$y;
            for my $x ($min..$max) {
                my $letter = $self->get($x, $y);

                if ($self->isUsed($letter) && !$print_board) {
                    print ' ';
                }
                else {
                    print $letter->[2];
                }
            }
            print "\n";
        }
    }

    sub getSurroundingTiles {
        my ($self, $letter) = @_;
        my ($x, $y) = @{$letter};

        return grep {
            $self->isValidTile($_);
        } (
            # need to accomodate the wonky 'grid'
            $self->get($x - ($y % 2 != 0), $y + 1),
            $self->get($x - ($y % 2 != 0) + 1, $y + 1),
            $self->get($x - 1, $y),
            $self->get($x + 1, $y),
            $self->get($x - ($y % 2 != 0), $y - 1),
            $self->get($x - ($y % 2 != 0) + 1, $y - 1)
        );
    }

    sub getRequiredTiles {
        my ($self) = @_;
        my %seen;

        return grep {
             !$seen{join(',', @{$_})}++
        } map {
            $self->getSurroundingTiles($_)
        } @{$self->{used}};
    }

    sub isValidTile {
        my ($self, $letter, $word) = @_;
        my ($x, $y) = @{$letter};

        if ($word) {
            my $previous = $word->[scalar @{$word} - 1];
            if ($previous) {
                my @valid = grep {
                    $_->[0] == $x && $_->[1] == $y
                } $self->getSurroundingTiles($previous);

                return 0 unless @valid;
            }
        }


        return !$self->isEmpty($letter) && !$self->isUsed($letter) && !$self->inCurrentWord($letter);
    }

    sub inCurrentWord {
        my ($self, $letter) = @_;
        my ($x, $y) = @{$letter};
        return grep {
            $_->[0] == $x && $_->[1] == $y
        } @{$game->{word}};
    }

    sub isValidWord {
        my ($self, $word) = @_;

        $self->{dict}->validate(join('', map {
            $_->[2]
        } @{$word}));
    }

    sub isUsed {
        my ($self, $letter) = @_;
        my ($x, $y) = @{$letter};

        return grep {
            $_->[0] == $x && $_->[1] == $y
        } @{$self->{used}};
    }

    sub isEmpty {
        my ($self, $letter) = @_;

        return $letter->[2] =~ /\W/;
    }

    sub isEdge {
        my ($self, $letter) = @_;
        my ($x, $y, $c) = @{$letter};
        my ($min, $max) = $self->getMinMax;

        if ($x == $min || $x == $max || $y == $min || $y == $max || $self->isEmpty($self->get($x, $y - 1)) || $self->isEmpty($self->get($x, $y + 1))) {
            return 1;
        }

        return 0;
    }

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

        return grep {
            $self->isEdge($_)
        } @{$self->{used}};
    }

    sub use {
        my ($self, $letter) = @_;

        push @{$self->{used}}, $letter;
    }

    1;

##############################################################################

    package Game;
    use base qw(Base);

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

        $self->{board}->use($_) for @{$self->{word}};
        push @{$self->{words}}, $self->{word};
        $self->{word} = [];

        return 1;
    }

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

        return $self->{board}->isComplete;
    }

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

        my $report = qq{var moves = [];};
        for (@{$self->{words}}) {
            $report .= 'moves.push('.(join(',', map {
                sprintf qq{[%d, %d, '%s']}, @{$_};
            } @{$_})).');';
        }

        $self->{board}->renderHTML($report);
    }
};