#!perl
#
# pmarad - a command line interface to Game::Marad

use 5.26.0;
use warnings;
use Curses;
use Game::Marad 0.04;

use constant {
    COLOFF => 2,    # two screen columns per one game column

    CURS_START_Y => 4,    # cursor location in a new game (player 1 king)
    CURS_START_X => 5,

    CURS_OFF_Y => 0,      # where board 0,0 is relative to display cursor
    CURS_OFF_X => -3,

    MINCOL => 3,          # cursor constraints - see also boardw in newgame
    MAXCOL => 19,
    MINROW => 0,
    MAXROW => 8,

    NEED_COLS => 24,      # minimum terminal dimensions
    NEED_ROWS => 12,

    NEXT_EVENT => 0,
    NEXT_KEY   => 1,

    STATE_NORMAL => 0,
    STATE_SELECT => 1,

    VICTORY => 15,        # points required to win
};

our $app;

our %piecemap = (
    0  => '.',
    1  => 'R',            # White, player 1
    2  => 'B',
    3  => 'K',
    65 => 'r',            # Black, player 2
    66 => 'b',
    67 => 'k',
);

our %ch_inputs = (        # regular keys (see Curses getchar docs)
    Q       => \&move_quit,
    chr(10) => \&move_select,    # pick or complete a move
    chr(13) => \&move_select,
    chr(32) => \&move_select,
    chr(27) => \&move_cancel,    # unpick a move
    c       => \&move_cancel,    # unpick a move
    chr(12) => \&move_winch,     # control+l to refresh things

    # these are from vi(1)
    h => \&move_west,
    j => \&move_south,
    k => \&move_north,
    l => \&move_east,
    # and these are from rogue(6)
    y => \&move_northwest,
    u => \&move_northeast,
    b => \&move_southwest,
    n => \&move_southeast,
);

our %key_inputs = (    # extended keys (mostly untested)
    410 => \&move_winch,
    331 => \&move_select,    # "0" maybe?

    260 => \&move_west,
    258 => \&move_south,
    259 => \&move_north,
    261 => \&move_east,

    262 => \&move_northwest,
    339 => \&move_northeast,
    360 => \&move_southwest,
    338 => \&move_southeast,
);

run();

sub init {
    # default is 1000 milliseconds, too long unless on a 300 baud line?
    $ENV{ESCDELAY} = 50 unless exists $ENV{ESCDELAY};

    # NOTE do not add "nodelay" without reviewing the getchar loop
    initscr;
    $SIG{WINCH} = 'IGNORE';    # KLUGE lock curses window size
    if ( $COLS < NEED_COLS or $LINES < NEED_ROWS ) {
        endwin;
        printf STDERR "pmarad: screen is too small (need %d,%d)\n", NEED_COLS,
          NEED_ROWS;
        exit 1;
    }
    raw;
    keypad(1);
    noecho;
    $app = newgame();
}

sub newgame {
    state $app;
    $app->{dirty} = 1;
    $app->{game}  = Game::Marad->new;
    $app->{state} = STATE_NORMAL;
    $app->{boardw} //= subwin( 9, 18, 0, 3 );
    $app->@{qw(cursy cursx)} = ( CURS_START_Y, CURS_START_X );
    return $app;
}

sub run {
    init() unless defined $app;
    while (1) {
        update($app);
      KEY:
        my ( $ch, $key ) = getchar;
        my $action;
        if ( defined $key ) {
            $action = $key_inputs{$key};
            goto KEY unless defined $action;
        } elsif ( defined $ch ) {
            $action = $ch_inputs{$ch};
            goto KEY unless defined $action;
        } else {
            # nodelay if set will probably need a napms here to avoid busy
            # looping through a getchar that then too quickly returns
            goto KEY;
        }
        goto KEY if $action->($app) == NEXT_KEY;
    }
}

sub move_west {
    my ($app) = @_;
    $app->{cursx} -= COLOFF;
    return NEXT_EVENT;
}

sub move_south {
    my ($app) = @_;
    $app->{cursy} += 1;
    return NEXT_EVENT;
}

sub move_north {
    my ($app) = @_;
    $app->{cursy} -= 1;
    return NEXT_EVENT;
}

sub move_east {
    my ($app) = @_;
    $app->{cursx} += COLOFF;
    return NEXT_EVENT;
}

# the checks on the diagonals are to prevent the cursor from "sliding"
# along a border; diagonals are only allowed where a proper diagonal
# can happen
sub move_northwest {
    my ($app) = @_;
    if ( $app->{cursy} > MINROW and $app->{cursx} > MINCOL ) {
        $app->{cursy} -= 1;
        $app->{cursx} -= COLOFF;
    }
    return NEXT_EVENT;
}

sub move_northeast {
    my ($app) = @_;
    if ( $app->{cursy} > MINROW and $app->{cursx} < MAXCOL ) {
        $app->{cursy} -= 1;
        $app->{cursx} += COLOFF;
    }
    return NEXT_EVENT;
}

sub move_southwest {
    my ($app) = @_;
    if ( $app->{cursy} < MAXROW and $app->{cursx} > MINCOL ) {
        $app->{cursy} += 1;
        $app->{cursx} -= COLOFF;
    }
    return NEXT_EVENT;
}

sub move_southeast {
    my ($app) = @_;
    if ( $app->{cursy} < MAXROW and $app->{cursx} < MAXCOL ) {
        $app->{cursy} += 1;
        $app->{cursx} += COLOFF;
    }
    return NEXT_EVENT;
}

sub move_cancel {
    my ($app) = @_;
    if ( $app->{state} == STATE_SELECT ) {
        $app->@{qw(dirty state)} = ( 1, STATE_NORMAL );
        return NEXT_EVENT;
    } else {
        $app->{state} = STATE_NORMAL;
        return NEXT_KEY;
    }
}

sub move_quit {
    endwin;
    exit;
}

# pick a source square, or try a move with a destination square
sub move_select {
    my ($app) = @_;

    if ( $app->{state} == STATE_NORMAL ) {
        my ( $row, $col ) = $app->@{qw(cursy cursx)};
        my ( $y,   $x ) = ( $row + CURS_OFF_Y, int( ( $col + CURS_OFF_X ) / COLOFF ) );
        if ( $app->{game}->is_owner( $x, $y ) ) {
            $app->@{qw(state srcy srcx)} = ( STATE_SELECT, $row, $col );
            addch $row, $col, A_BOLD | ord inch $row, $col;
            move $row, $col;
        }
        return NEXT_KEY;

    } elsif ( $app->{state} == STATE_SELECT ) {
        my ( $r, $msg ) = $app->{game}->move(
            int( ( $app->{srcx} + CURS_OFF_X ) / COLOFF ),
            $app->{srcy} + CURS_OFF_Y,
            int( ( $app->{cursx} + CURS_OFF_X ) / COLOFF ),
            $app->{cursy} + CURS_OFF_Y,
        );
        if ( $r == 1 ) {
            $app->@{qw(dirty state)} = ( 1, STATE_NORMAL );
            return NEXT_EVENT;
        } else {
            # not a valid move. better luck next time?
            return NEXT_KEY;
        }
    }
}

sub move_winch {
    my ($app) = @_;
    $app->{dirty} = 1;
    return NEXT_EVENT;
}

sub update {
    my ($app) = @_;
    if ( $app->{dirty} ) {
        touchwin;
        move 0, 0;
        clrtobot;

        my $score = $app->{game}->score;
        if ( $score->[0] >= VICTORY ) {
            victory(1);
        } elsif ( $score->[1] >= VICTORY ) {
            victory(2);
        }

        my $game = $app->{game};
        my ( $board, $grid ) = ( $game->board, $app->{boardw} );
        $score = $game->score;

        addstring 7, 1,  sprintf "%X", $score->[0];
        addstring 7, 21, sprintf "%X", $score->[1];

        if ( $game->player == 0 ) {
            addstring 1, 1, sprintf "%d", $game->move_count;
            addstring 1, 21, ' ';
        } else {
            addstring 1, 1, ' ';
            addstring 1, 21, sprintf "%d", $game->move_count;
        }

        my $maxidx = $board->$#*;
        for my $row ( 0 .. $maxidx ) {
            for my $col ( 0 .. $maxidx ) {
                my $piece = $piecemap{ $board->[$row][$col] } // '?';
                if ( $piece eq '.' and ( $row == 4 xor $col == 4 ) ) {
                    # presumably colors might also help show the center
                    # square, but I'd have to enable those...
                    $piece = ',';
                } elsif ( $row == 4 and $col == 4 ) {
                    $piece = ord($piece) | A_REVERSE;
                }
                addch $grid, $row, $col * COLOFF, $piece;
            }
        }

        noutrefresh $grid;
        doupdate;
        $app->{dirty} = 0;
    }

    # maintain the cursor position, which things like window resizes
    # may like to fiddle with
    if ( $app->{cursx} < MINCOL ) {
        $app->{cursx} = MINCOL;
    } elsif ( $app->{cursx} > MAXCOL ) {
        $app->{cursx} = MAXCOL;
    }
    if ( $app->{cursy} < MINROW ) {
        $app->{cursy} = MINROW;
    } elsif ( $app->{cursy} > MAXROW ) {
        $app->{cursy} = MAXROW;
    }
    move $app->@{qw(cursy cursx)};
}

sub victory {
    my ($player) = @_;
    move 0, 0;
    clrtobot;
    addstring("Player $player wins!");
    getchar;
    move 0, 0;
    clrtobot;
    newgame();
}

__END__

=head1 NAME

B<pmarad> - Perl implementation of the Marad board game

=head1 SYNOPSIS

  pmarad

=head1 DESCRIPTION

Marad is a game for two players that takes place on a nine by
nine board.

The cursor may be moved using L<rogue(6)> keys:

   y  k  u
    \ | /
  h - . - l
    / | \
   b  j  n

Navigate the cursor to a piece you own and select it with space or
enter. To cancel a selection, hit escape or C<c>. To move a selected
piece, move the cursor to some other square then hit space or enter
again. If the move is valid, the piece will move, and the second player
can now make their move.

Hit Q to quit the game.

=head2 Gameplay

A move count (between 1 and 4) is displayed on the side of the player
whose turn it is. A piece will move by this amount, pushing anything in
the way, unless something is stopped by the edge of the board.

The pieces move somewhat like in chess, except for how far they move
being determined at random. The King (C<K> or C<k>) can move in any
direction; the Bishop (C<B> or C<b>) only diagonal and the Rook (C<R> or
C<r>) only in straight lines.

To score points, any piece must be moved and end the turn in the
center square.

The usual gameplay alternates setting your pieces up to score points,
moving them to score points, and the perhaps less important task of
preventing the opposing player from scoring points or pushing your
pieces out of the way.

=head1 ENVIRONMENT

Various environment variables will influence the L<Curses> library. In
particular C<ESCDELAY> sets how long a function key sequence will be
waited for. The library default of C<1000> has been set lower in this
program, unless the user supplies a custom value.

=head1 SEE ALSO

L<gemini://thrig.me/game/marad.gmi> - game rules

L<https://thrig.me/src/marad.git> - has a RULES file

=head1 AUTHOR

Jeremy Mates

=head1 BUGS

L<Curses> must be installed for C<pmarad>, but is not required by the
installation of L<Game::Marad>.

The interface is pretty minimal.

=cut
