path: root/lib/Bot/Zulip/Chess.pm

package Bot::Zulip::Chess;
use 5.020;
use feature 'signatures', 'postderef';
use experimental 'signatures', 'postderef';
use Moose;
no warnings 'experimental::signatures';
no warnings 'experimental::postderef';

use Chess::Rep;
use JSON::PP;
use Path::Class;
use Try::Tiny;
use WebService::Zulip;

has api_key => (
    is       => 'ro',
    isa      => 'Str',
    required => 1,
);

has api_user => (
    is       => 'ro',
    isa      => 'Str',
    required => 1,
);

has bot_name => (
    is       => 'ro',
    isa      => 'Str',
    required => 1,
);

has streams => (
    is       => 'ro',
    isa      => 'ArrayRef[Str]',
    required => 1,
);

has white_player => (
    is        => 'rw',
    isa       => 'Str',
    predicate => 'has_white_player',
    clearer   => 'clear_white_player',
);

has black_player => (
    is        => 'rw',
    isa       => 'Str',
    predicate => 'has_black_player',
    clearer   => 'clear_black_player',
);

has _zulip => (
    is      => 'ro',
    isa     => 'WebService::Zulip',
    lazy    => 1,
    default => sub ($self) {
        my $zulip = WebService::Zulip->new(
            api_key  => $self->api_key,
            api_user => $self->api_user,
        );
        # XXX move this into WebService::Zulip
        $zulip->{_ua}->post('https://api.zulip.com/v1/users/me/subscriptions', {subscriptions => encode_json([ map { +{ name => $_ } } $self->streams->@* ])});
        $zulip
    },
);

has _queue => (
    is  => 'ro',
    isa => 'HashRef',
    lazy => 1,
    default => sub ($self) {
        $self->_zulip->get_message_queue
    },
);

has _chessboard => (
    is      => 'ro',
    isa     => 'Chess::Rep',
    lazy    => 1,
    default => sub ($self) {
        my $board = Chess::Rep->new;
        my $record = $self->_record_file;
        if (-e $record) {
            try {
                warn "Loading a previous game...";
                chomp(my @lines = $record->slurp);
                $self->white_player(shift @lines);
                $self->black_player(shift @lines);
                warn "Between " . $self->white_player
                   . " and " . $self->black_player;
                for my $turn (@lines) {
                    my ($white, $black) = split ' ', $turn;
                    $board->go_move($white) if $white;
                    $board->go_move($black) if $black;
                }
                my $status = $board->status;
                if ($status->{mate} || $status->{stalemate}) {
                    die "Game is over";
                }
            }
            catch {
                warn $_;
                $board = Chess::Rep->new;
            }
        }
        $board
    },
    clearer => '_clear_chessboard',
);

has _record_file => (
    is  => 'ro',
    isa => 'Path::Class::File',
    lazy => 1,
    default => sub { file('current.game') },
);

has _temp_move => (
    is  => 'rw',
    isa => 'Str',
);

sub run ($self) {
    while (1) {
        $self->step
    }
}

sub step ($self) {
    my $res = $self->_zulip->get_new_events(
        queue_id      => $self->_queue->{queue_id},
        last_event_id => $self->_queue->{last_event_id},
        dont_block    => 'false',
    );
    for my $event ($res->{events}->@*) {
        next unless $event->{type} eq 'message';
        my $message = $event->{message};
        next if $message->{type} eq 'private';
        my $bot_name = $self->bot_name;
        my $content = $message->{content};
        next unless $content =~ s/^\@\*\*$bot_name\*\*//;
        $content =~ s/^\s*|\s*$//g;
        my $response = $self->handle_move(
            $message->{sender_full_name}, $content
        );
        my $to = $message->{type} eq 'private' ? $message->{sender_email} : $message->{display_recipient};
        $self->_zulip->send_message(
            content => $response,
            subject => $message->{subject},
            to      => $to,
            type    => $message->{type},
        );
    }
    $self->_queue->{last_event_id} = $self->_zulip->get_last_event_id($res);
}

sub handle_move ($self, $player, $move) {
    if ($move eq 'state') {
        return $self->draw_state;
    }

    if (!$self->players_turn($player)) {
        return "It's not your turn!";
    }
    else {
        if ($self->needs_new_player) {
            $self->set_new_player($player);
        }

        return try {
            if ($move eq 'resign') {
                my $msg = '@**' . $self->current_player . "** resigned";
                $self->reset_board;
            }
            else {
                my $res = $self->_chessboard->go_move($move);
                my $parsed_move = $res->{san};
                if ($self->needs_new_player) {
                    $self->_temp_move($parsed_move);
                }
                else {
                    $self->_record_file->spew(
                        iomode => 'a',
                        $parsed_move . ($self->_chessboard->to_move ? "\n" : " ")
                    );
                }
                $self->draw_state;
            }
        }
        catch {
            s/ at .* line .*//r;
        };
    }
}

sub needs_new_player ($self) {
    return !$self->has_white_player || !$self->has_black_player
}

sub set_new_player ($self, $player) {
    if (!$self->has_white_player) {
        warn "$player is now playing White";
        $self->white_player($player)
    }
    elsif (!$self->has_black_player) {
        warn "$player is now playing Black";
        $self->black_player($player);
        $self->_record_file->spew(
            $self->white_player . "\n"
          . $self->black_player . "\n"
          . $self->_temp_move . " "
        );
    }
    else {
        die "Both players are already full";
    }
}

sub draw_state ($self) {
    my $board = $self->format_board =~ s/^/    /gmr;
    my $status = $self->_chessboard->status;

    if ($status->{mate}) {
        $board .= "CHECKMATE\n";
        $self->reset_board;
        return $board;
    }
    elsif ($status->{stalemate}) {
        $board .= "STALEMATE\n";
        $self->reset_board;
        return $board;
    }
    elsif ($status->{check}) {
        $board .= "CHECK\n";
    }

    my $to_move = $self->current_player;
    if ($to_move) {
        $to_move = '@**' . $to_move . '**';
    }
    else {
        $to_move = "A new opponent";
    }
    $board .= $to_move . " ("
            . ($self->_chessboard->to_move ? 'White' : 'Black')
            . ") to move\n";

    return $board;
}

sub current_player ($self) {
    my $method = $self->_chessboard->to_move ? 'white_player' : 'black_player';
    return $self->$method;
}

sub players_turn ($self, $player) {
    return if !$self->has_black_player
           && $self->has_white_player
           && $self->white_player eq $player;

    my $expected_player = $self->current_player;
    return 1 if !defined($expected_player);
    return 1 if $expected_player eq $player;

    return;
}

sub reset_board ($self) {
    $self->_record_file->move_to(time() . ".game");
    $self->clear_white_player;
    $self->clear_black_player;
    $self->_clear_chessboard;
}

my %pieces = (
    p   => "\N{BLACK CHESS PAWN}",
    P   => "\N{WHITE CHESS PAWN}",
    n   => "\N{BLACK CHESS KNIGHT}",
    N   => "\N{WHITE CHESS KNIGHT}",
    b   => "\N{BLACK CHESS BISHOP}",
    B   => "\N{WHITE CHESS BISHOP}",
    r   => "\N{BLACK CHESS ROOK}",
    R   => "\N{WHITE CHESS ROOK}",
    q   => "\N{BLACK CHESS QUEEN}",
    Q   => "\N{WHITE CHESS QUEEN}",
    k   => "\N{BLACK CHESS KING}",
    K   => "\N{WHITE CHESS KING}",
);
sub format_board ($self) {
    my $board = $self->_chessboard->dump_pos;

    for my $piece (keys %pieces) {
        $board =~ s/$piece/$pieces{$piece}/g;
    }

    $board =~ s/\+/\N{BOX DRAWINGS LIGHT VERTICAL AND HORIZONTAL}/g;
    $board =~ s/\|-/\N{BOX DRAWINGS LIGHT VERTICAL AND RIGHT}-/g;
    $board =~ s/-\|/-\N{BOX DRAWINGS LIGHT VERTICAL AND LEFT}/g;
    $board =~ s/\|/\N{BOX DRAWINGS LIGHT VERTICAL}/g;
    $board =~ s/-/\N{BOX DRAWINGS LIGHT HORIZONTAL}/g;

    $board = "\N{BOX DRAWINGS LIGHT DOWN AND RIGHT}"
           . ("\N{BOX DRAWINGS LIGHT HORIZONTAL}\N{BOX DRAWINGS LIGHT DOWN AND HORIZONTAL}" x 7) . "\N{BOX DRAWINGS LIGHT HORIZONTAL}"
           . "\N{BOX DRAWINGS LIGHT DOWN AND LEFT}"
           . "\n" . $board . "\n"
           . "\N{BOX DRAWINGS LIGHT UP AND RIGHT}"
           . ("\N{BOX DRAWINGS LIGHT HORIZONTAL}\N{BOX DRAWINGS LIGHT UP AND HORIZONTAL}" x 7) . "\N{BOX DRAWINGS LIGHT HORIZONTAL}"
           . "\N{BOX DRAWINGS LIGHT UP AND LEFT}"
           . "\n A B C D E F G H\n";

    my @board = split "\n", $board;
    my $n = 1;
    for my $i (0..$#board) {
        my $prefix = $i % 2 == 1 && $i < 16 ? (9 - $n++) : " ";
        $board[$i] = $prefix . $board[$i];
    }

    join("\n", @board) . "\n"
}

__PACKAGE__->meta->make_immutable;
no Moose;

1;