Games::Risk::GUI::Startup - startup window

    my $id = Games::Risk::GUI::Startup->spawn(\%params);

  Jerome Quelin

  The GNU General Public License, Version 3, June 2007

#
# This file is part of Games-Risk
#
# This software is Copyright (c) 2008 by Jerome Quelin.
#
# This is free software, licensed under:
#
#   The GNU General Public License, Version 3, June 2007
#
use 5.010;
use strict;
use warnings;

package Games::Risk::GUI::Startup;
BEGIN {
  $Games::Risk::GUI::Startup::VERSION = '3.103040';
}
# ABSTRACT: startup window

use POE             qw{ Loop::Tk };
use List::Util      qw{ shuffle };
use List::MoreUtils qw{ any };
use Readonly;
use Tk;
use Tk::Balloon;
use Tk::BrowseEntry;
use Tk::Font;
use Tk::Sugar;

use Games::Risk::I18N      qw{ T };
use Games::Risk::Resources qw{ image maps $SHAREDIR };

use constant K => $poe_kernel;

Readonly my $WAIT_CLEAN_AI    => 1.000;
Readonly my $WAIT_CLEAN_HUMAN => 0.250;

Readonly my @COLORS => (
    '#333333',  # grey20
    '#FF2052',  # awesome
    '#01A368',  # green
    '#0066FF',  # blue
    '#9E5B40',  # sepia
    '#A9B2C3',  # cadet blue
    '#BB3385',  # red violet
    '#FF681F',  # orange
    '#DCB63B',  # ~ dirty yellow
    '#00CCCC',  # robin's egg blue
    #'#1560BD',  # denim
    #'#33CC99',  # shamrock
    #'#FF9966',  # atomic tangerine
    #'#00755E',  # tropical rain forest
    #'#A50B5E',  # jazzberry jam
    #'#A3E3ED',  # blizzard blue
);
Readonly my @NAMES => (
    T('Napoleon Bonaparte'),   # france,   1769  - 1821
    T('Staline'),              # russia,   1878  - 1953
    T('Alexander the Great'),  # greece,   356BC - 323BC
    T('Julius Caesar'),        # rome,     100BC - 44BC
    T('Attila'),               # hun,      406   - 453
    T('Genghis Kahn'),         # mongolia, 1162  - 1227
    T('Charlemagne'),          # france,   747   - 814
    T('Saladin'),              # iraq,     1137  - 1193
    T('Otto von Bismarck'),    # germany,  1815  - 1898
    T('Ramses II'),            # egypt,    1303BC - 1213BC
);



#--
# Constructor

#
# my $id = Games::Risk::GUI->spawn( \%params );
#
# create a new window containing the board used for the game. refer
# to the embedded pod for an explanation of the supported options.
#
sub spawn {
    my (undef, $args) = @_;

    my $session = POE::Session->create(
        args          => [ $args ],
        inline_states => {
            # private events - session
            _start               => \&_onpriv_start,
            _stop                => sub { warn "gui-startup shutdown\n" },
            _check_errors        => \&_onpriv_check_errors,
            _check_nb_players    => \&_onpriv_check_nb_players,
            _load_defaults       => \&_onpriv_load_defaults,
            _new_player          => \&_onpriv_new_player,
            _player_color        => \&_onpriv_player_color,
            # private events - game
            # gui events
            _but_color           => \&_ongui_but_color,
            _but_delete          => \&_ongui_but_delete,
            _but_new_player      => \&_ongui_but_new_player,
            _but_quit            => \&_ongui_but_quit,
            _but_start           => \&_ongui_but_start,
            # public events
            new_game             => \&_onpub_new_game,
        },
    );
    return $session->ID;
}


#--
# EVENT HANDLERS

# -- public events

sub _onpub_new_game {
    my $h = $_[HEAP];
    $h->{toplevel}->deiconify;
}


# -- private events

#
# event: _check_errors()
#
# check various config errors, such as player without a name, 2 human
# players, etc. disable start game if any error spotted.
#
sub _onpriv_check_errors {
    my ($h, $s) = @_[HEAP, SESSION];

    my $players = $h->{players};
    my @players = grep { defined $_ } @$players;
    my $top = $h->{toplevel};
    my $errstr;

    # remove previous error message
    if ( $h->{error} ) {
        # remove label
        $h->{error}->destroy;
        $h->{error} = undef;

        # allow start to be clicked
        $h->{button}{start}->configure(enabled);
        $top->bind('<Key-Return>', $s->postback('_but_start'));
    }

    # 2 players cannot have the same color
    my %colors;
    @colors{ map { $_->{color} } @players } = (0) x @players;
    $colors{ $_->{color} }++ for @players;
    $errstr = T('Two players cannot have the same color.')
        if any { $colors{$_} > 1 } keys %colors;

    # 2 players cannot have the same name
    my %names;
    @names{ map { $_->{name} } @players } = (0) x @players;
    $names{ $_->{name} }++ for @players;
    $errstr = T('Two players cannot have the same name.')
        if any { $names{$_} > 1 } keys %names;

    # human players
    my $nbhuman = grep { $_->{type} eq T('Human') } @players;
    $errstr = T('Cannot have more than one human player.')            if $nbhuman > 1;
    $errstr = T('Game without any human player not (yet) supported.') if $nbhuman < 1;

    # all players should have a name
    $errstr = T('A player cannot have an empty name.')
        if any { $_->{name} eq '' } @players;

    # there should be at least 2 players
    $errstr = T('Game should have at least 2 players.') if scalar @players < 2;

    # check if there are some errors
    if ( $errstr ) {
        # add warning
        $h->{error} = $h->{frame}{players}->Label(
            -bg => 'red',
            -text => $errstr,
        )->pack(top, fillx);

        # prevent start to be clicked
        $h->{button}{start}->configure(disabled);
        $top->bind('<Key-Return>', undef);
    }
}


#
# event: _check_nb_players
#
# check whether one can add new players.
#
sub _onpriv_check_nb_players {
    my $h = $_[HEAP];

    my $players = $h->{players};
    my @players = grep { defined $_ } @$players;

    # check whether we can add another player
    my @config = ( scalar(@players) >= 10 ) ? (disabled) : (enabled);
    $h->{button}{add_player}->configure(@config);
}


#
# _load_defaults()
#
# load default players, currently hardcoded (FIXME), but later from the
# last choices (saved in a config file somewhere).
#
sub _onpriv_load_defaults {
    # FIXME: hardcoded
    my $user   = $ENV{USER} // $ENV{USERNAME} //$ENV{LOGNAME}; # FIXME: use a module?
    my @names  = ($user, shuffle @NAMES );
    my @types  = (T('Human'), (T('Computer, easy'))x1, (T('Computer, hard'))x2);
    my @colors = @COLORS;
    foreach my $i ( 0..$#types ) {
        K->yield('_new_player', $names[$i], $types[$i], $colors[$i]);
    }
}


#
# event: _new_player([$name], [)
#
# fired when there's a new player created.
#
sub _onpriv_new_player {
    my ($h, $s, @args) = @_[HEAP, SESSION, ARG0..$#_];

    my ($name, $type, $color) = @args;
    my $players = $h->{players};
    my $num = scalar @$players;
    my @choices = ( T('Human'), T('Computer, easy'), T('Computer, hard') );

    # the frame
    $players->[$num]{name}  = $name;
    $players->[$num]{type}  = $type;
    $players->[$num]{color} = $color;
    my $fpl = $h->{frame}{players}->Frame
        ->pack(top, fillx, -before=>$h->{button}{add_player});
    my $f = $fpl->Frame(-bg=>$color)->pack(left, fillx);
    $players->[$num]{line}  = $fpl;
    $players->[$num]{frame} = $f;
    $f->Entry(
        -textvariable => \$players->[$num]{name},
        -validate     => 'all',
        -vcmd         => sub { $s->postback('_check_errors')->(); 1; },
        #-highlightbackground => $color,
    )->pack(left,xfillx);
    my $be = $f->BrowseEntry(
        -variable           => \$players->[$num]{type},
        -background         => $color,
        -listheight         => scalar(@choices)+1,
        -choices            => \@choices,
        -state              => 'readonly',
        -disabledforeground => 'black',
        -browsecmd          => $s->postback('_check_errors'),
    )->pack(left);
    my $bc = $f->Button(
        -bg               => $color,
        -fg               => 'white',
        -activebackground => $color,
        -activeforeground => 'white',
        -image            => image('paintbrush'),
        -command          => $s->postback('_but_color', $num),
    )->pack(left);
    my $ld = $fpl->Label(-image=>image('fileclose16'))->pack(left);
    $ld->bind('<1>', $s->postback('_but_delete', $num));
    $players->[$num]{be_type}   = $be;
    $players->[$num]{but_color} = $bc;

    # max players reached?
    K->yield('_check_nb_players');
}


#
# event: _player_color( [$num, $color] )
#
# called to change color of player number $num to $color.
#
sub _onpriv_player_color {
    my ($h, $args) = @_[HEAP, ARG0];
    my ($num, $color) = @$args;

    $h->{players}[$num]{color} = $color;
    $h->{players}[$num]{frame}->configure(-bg=>$color);
    $h->{players}[$num]{be_type}->configure(-bg=>$color);
    $h->{players}[$num]{but_color}->configure(
        -background => $color,
        -activebackground => $color);

    K->yield('_check_errors');
}


#
# Event: _start( \%params )
#
# Called when the poe session gets initialized. Receive a reference
# to %params, same as spawn() received.
#
sub _onpriv_start {
    my ($h, $s, $args) = @_[HEAP, SESSION, ARG0];

    K->alias_set('startup');
    my $top = $h->{toplevel} = $args->{toplevel};
    $top->title('prisk - ' . T('new game'));
    my $icon = $SHAREDIR->file('icons', '32', 'prisk.png');
    my $mask = $SHAREDIR->file('icons', '32', 'prisk-mask.xbm');
    $top->iconimage( $top->Photo(-file=>$icon) );
    $top->iconmask( '@' . $mask );


    #-- initializations
    $h->{players} = [];

    #-- title
    my $font = $top->Font(-size=>16);
    $top->Label(
        -bg   => 'black',
        -fg   => 'white',
        -font => $font,
        -text => T('New game'),
    )->pack(top,pad20,fillx);

    #-- various resources

    # ballon
    $h->{balloon} = $top->Balloon;

    #-- map selection
    my @choices = maps();
    $h->{map} = 'risk';
    my $fmap = $top->Frame->pack(top, xfill2, pad20);
    $fmap->Label(-text=>'Map', -anchor=>'w')->pack(top, fillx);
    $fmap->BrowseEntry(
        -variable           => \$h->{map},
        -listheight         => scalar(@choices)+1,
        -choices            => \@choices,
        -state              => 'readonly',
        -disabledforeground => 'black',
    )->pack(top );

    #-- frame for players
    my $fpl = $top->Frame->pack(top, xfill2, pad20);
    $fpl->Label(-text=>'Players', -anchor=>'w')->pack(top, fillx);
    $h->{button}{add_player} = $fpl->Button(
        -text    => T('New player...'),
        -command => $s->postback('_but_new_player'),
    )->pack(top,fillx);
    $h->{frame}{players} = $fpl;
    K->yield('_load_defaults');

    #-- bottom frame
    my $fbot = $top->Frame->pack(bottom, fillx, pad20);
    my $b_start = $h->{button}{start} = $fbot->Button(
        -text => T('Start game'),
        -command => $s->postback('_but_start'),
    );
    my $b_quit = $fbot->Button(
        -text => T('Quit'),
        -command => $s->postback('_but_quit'),
    );
    # pack after creation, to have clean focus order
    $b_quit->pack(right,pad1);
    $b_start->pack(right,pad1);

    # window binding
    $top->bind('<Key-Return>', $s->postback('_but_start'));
    $top->bind('<Key-Escape>', $s->postback('_but_quit'));
}


# -- gui events

#
# event: _but_color([$num])
#
# called when button to choose another color for player number $num has
# been clicked.
#
sub _ongui_but_color {
    my ($h, $s, $args) = @_[HEAP, SESSION, ARG0];

    my ($num) = @$args;
    my $top = $h->{toplevel};

    # creating popup window
    my $tc =$top->Menu;
    $tc->overrideredirect(1);  # no window decoration
    foreach my $i ( 0..$#COLORS ) {
        my $color = $COLORS[$i];
        my $row = $i < 5 ? 0 : 1;
        my $col = $i % 5;
        my $l = $tc->Label(
            -bg     => $color,
            -width  => 2,
        )->grid(-row=>$row, -column=>$col);
        $l->bind('<1>', $s->postback('_player_color', $num, $color));
    }

    # poping up
    $tc->Popup(
        -popover => $h->{players}[$num]{but_color},
        -overanchor => 'sw',
        -popanchor  => 'nw',
    );
    $top->bind('<1>', sub { $tc->destroy; $top->bind('<1>',undef); });
    #$tc->bind('<1>', sub { $tc->destroy; $top->bind('<1>',undef); });

    K->yield('_check_errors');
}


#
# event: _but_delete([$num])
#
# called when button to delete player number $num has been clicked.
#
sub _ongui_but_delete {
    my ($h, $args) = @_[HEAP, ARG0];

    # remove player
    my ($num) = @$args;
    $h->{players}[$num]{line}->destroy;
    delete $h->{players}[$num];

    # max players reached?
    K->yield('_check_nb_players');

    # check if we have enough players
    K->yield('_check_errors');
}


#
# event: _but_new_player()
#
# called when button to create a player has been clicked.
#
sub _ongui_but_new_player {
    my $h = $_[HEAP];

    my $players = $h->{players};
    my @players = grep { defined $_ } @$players;

    # pick a name
    my %names;
    @names{ @NAMES } = ();
    delete @names{ map { $_->{name} } @players };
    my $name = ( shuffle keys %names )[0];

    # pick a color
    my %colors;
    @colors{ @COLORS } = ();
    delete @colors{ map { $_->{color} } @players };
    my $color = ( shuffle keys %colors )[0];

    # default type
    my $type = T('Computer, hard');

    # create new player
    K->yield('_new_player', $name, $type, $color);
}


#
# event: _but_quit()
#
# called when button quit is clicked, ie user wants to cancel new game.
# effectively kills the application.
#
sub _ongui_but_quit {
    my $h = $_[HEAP];
    K->post('risk', 'quit');
    K->alias_remove('startup');
    $h->{toplevel}->destroy; # this should be enough by itself
}


#
# event: _but_start()
#
# called when button start is clicked. signal controller to really load
# a game.
#
sub _ongui_but_start {
    my $h = $_[HEAP];

    # remove undef players from list of players. this can happen when
    # deleting some players: it is removed, but the list keeps an undef
    # value.
    my $players = $h->{players};
    my @players = grep { defined $_ } @$players;

    K->post('risk', 'new_game', { players => \@players, map => $h->{map} } );
    $h->{toplevel}->withdraw;
}



1;

__END__