Games::Pandemic::Tk::Main - main pandemic window

Games-Pandemic documentation Contained in the Games-Pandemic distribution.

Index

Code Index:

NAME

Top

Games::Pandemic::Tk::Main - main pandemic window

VERSION

Top

version 1.111030

METHODS

Top

event: action_done()

Received when current player has finished an action.

event: airlift( $player, $card )

Received when $player wants to play special $card Games::Pandemic::Card::Special::Airlift. Does not require an action.

event: all_cures_discovered()

Received when game is won due to all cures being discovered

event: build_station($city)

Received when $city gained a research station.

event: cure($disease)

Received when a cure has been found for $disease.

event: drop_card($player, $card)

Received when $player drops a $card.

event: end_of_actions()

Received when current player has finished her actions.

event: end_of_cards()

Received when current player has received her cards for this turn.

event: end_of_propagation()

Received when propagation is done

event: epidemic($city)

Received when a new epidemic strikes $city.

event: eradicate($disease)

Received when $disease has been eradicated.

event: forecast( $player, $card )

Received when $player wants to play special $card Games::Pandemic::Card::Special::Forecast. Does not require an action.

event: gain_card($player, $card)

Received when $player got a new $card.

event: game_over()

Received when game is over: user cannot advance the game any more.

event: government_grant( $player, $card )

Received when $player wants to play special $card Games::Pandemic::Card::Special::GovernmentGrant. Does not require an action.

event: infection($city, $outbreak)

Received when $city gets infected. $outbreak is true if this infection lead to a disease outbreak.

event: new_game()

Received when the controller started a new game. Display the new map (incl. cities), action & statusbar.

event: new_player( $player )

Received when the controller has just created a new player.

event: next_action

Received when player needs to do its next action.

event: next_player( $player )

Received when $player starts its turn.

event: no_more_cards()

Received when game is over due to a lack of cards to deal.

event: no_more_cubes( $disease )

Received when game is over due to a lack of cards to deal.

event: one_quiet_night( $player, $card )

Received when $player wants to play special $card Games::Pandemic::Card::Special::OneQuietNight. Does not require an action.

event: player_move( $player, $from ,$to )

Received when $player has moved between $from and $to cities.

event: resilient_population( $player, $card )

Received when $player wants to play special $card Games::Pandemic::Card::Special::ResilientPopulation. Does not require an action.

event: too_many_cards( $player )

Received when $player has too many cards: she must drop some before the game can continue.

event: too_many_outbreaks()

Received when there are too many outbreaks, and game is over.

event: treatment( $city )

Received when $city has been treated.

ACKNOWLEDGEMENT

Top

Thanks to the various artists that provide their work for free, we need them just as much we need coders.

I used the following icons:

* research station symbol by Klukeart (Miriam Moshinsky), under a free license for non-commercial use
* research station icon by IconsLand, under a free license for non- commercial use
* discover icon by Klukeart (Miriam Moshinsky), under a free license for non commercial use
* syringue icon by Everaldo Coelho, under an lgpl license
* share icon by Everaldo Coelho , under a gpl license
* pass icon by Zeus Box Studio, under a cc-by license
* trash icon by Jojo Mendoza, under a cc-nd-nc license
* warning icon by Gnome artists, under a gpl license
* success icon by Gnome artists, under a gpl license
* quiet night icon by David Vignoni, under a lgpl license
* government grant icon by Webdesigner Depot, under a free license for commercial use
* resilient population icon by Gnome Project, under a GPL license
* airlift icon by IconsLand, under a free license for non- commercial use
* airlift icon by David Vignoni, under a LGPL license

AUTHOR

Top

Jerome Quelin

COPYRIGHT AND LICENSE

Top

This software is Copyright (c) 2009 by Jerome Quelin.

This is free software, licensed under:

  The GNU General Public License, Version 2, June 1991
Games-Pandemic documentation Contained in the Games-Pandemic distribution. 
#
# This file is part of Games-Pandemic
#
# This software is Copyright (c) 2009 by Jerome Quelin.
#
# This is free software, licensed under:
#
#   The GNU General Public License, Version 2, June 1991
#
use 5.010;
use strict;
use warnings;

package Games::Pandemic::Tk::Main;
BEGIN {
  $Games::Pandemic::Tk::Main::VERSION = '1.111030';
}
# ABSTRACT: main pandemic window

use Convert::Color;
use File::Spec::Functions qw{ catfile };
use Image::Size;
use List::Util            qw{ min };
use Math::Gradient        qw{ array_gradient };
use Moose                 0.92;
use MooseX::Has::Sugar;
use MooseX::POE;
use MooseX::SemiAffordanceAccessor;
use Readonly;
use Tk;
use Tk::Action;
use Tk::Balloon;
use Tk::Font;
use Tk::JPEG;
use Tk::Pane;
use Tk::PNG;
use Tk::ToolBar;
use Tk::Sugar;

use Games::Pandemic::Config;
use Games::Pandemic::I18n       qw{ T };
use Games::Pandemic::Tk::Dialog::Action;
use Games::Pandemic::Tk::Dialog::Airlift;
use Games::Pandemic::Tk::Dialog::ChooseDisease;
use Games::Pandemic::Tk::Dialog::DropCards;
use Games::Pandemic::Tk::Dialog::Forecast;
use Games::Pandemic::Tk::Dialog::GiveCard;
use Games::Pandemic::Tk::Dialog::GovernmentGrant;
use Games::Pandemic::Tk::Dialog::ResilientPopulation;
use Games::Pandemic::Tk::Dialog::Simple;
use Games::Pandemic::Tk::Dialog::ViewCards;
use Games::Pandemic::Tk::PlayerCards;
use Games::Pandemic::Tk::Utils  qw{ image pandemic_icon };
use Games::Pandemic::Utils;

Readonly my $K  => $poe_kernel;
Readonly my $mw => $poe_main_window; # already created by poe
Readonly my $RADIUS     => 10;
Readonly my $TIME_BLINK => 0.5;
Readonly my $TIME_DECAY => 0.150;
Readonly my $TIME_GLOW  => 0.150;

# -- attributes

# a hash with all the widgets, for easier reference.
has _widgets => (
    ro,
    traits  => ['Hash'],
    isa     => 'HashRef',
    default => sub { {} },
    handles => {
        _set_w => 'set',
        _w     => 'get',
        _del_w => 'delete',
    },
);

# a hash with all the actions.
has _actions => (
    ro,
    traits  => ['Hash'],
    isa     => 'HashRef',
    default => sub { {} },
    handles => {
        _set_action => 'set',
        _action     => 'get',
    },
);

# color gradient for outbreak scale
has _outbreak_gradient => (
    ro,
    auto_deref,
    lazy_build,
    traits  => ['Array'],
    isa     => 'ArrayRef[ArrayRef]',
    handles => {
        _outbreak_color           => 'get',   # my $c = $main->_outbreak_color($i);
        _add_to_outbreak_gradient => 'push',  # my $c = $main->_add_to_outbreak_gradient($rgb);
    }
);

# color gradient for infection rate
has _infection_rate_gradient => (
    ro,
    auto_deref,
    lazy_build,
    traits  => ['Array'],
    isa     => 'ArrayRef[Str]',
    handles => {
        _next_infection_rate_color => 'shift',
        _add_infection_rate_color  => 'push',
    }
);


# currently selected player
has _selplayer => ( rw, weak_ref, isa => 'Games::Pandemic::Player' );


# it's not usually a good idea to retain a reference on a poe session,
# since poe is already taking care of the references for us. however, we
# need the session to call ->postback() to set the various gui callbacks
# that will be fired upon gui events.
has _session => ( rw, weak_ref, isa=>'POE::Session' );


# -- initialization

#
# START()
#
# called as poe session initialization.
#
sub START {
    my ($self, $session) = @_[OBJECT, SESSION];
    $K->alias_set('main');
    $self->_set_session($session);
    $self->_build_gui;
}


sub _build__infection_rate_gradient {
    my @gradient =
        map { sprintf "#%02x%02x%02x", @$_ }
        array_gradient([15,71,15], [212,219,16], 50);
    push @gradient, reverse @gradient;
    return \@gradient;
}

sub _build__outbreak_gradient {
    my $self = shift;
    my $scale = $self->_w('outbreaks');

    my $color = substr( ($scale->configure(-troughcolor))[3], 1);
    my $c = Convert::Color->new("rgb8:$color");
    my @gradient = array_gradient([ map {$_*255} $c->rgb ], [255,0,0], 9);
    return \@gradient;
}



# -- public events


event action_done => sub {
    my $self = $_[OBJECT];
    $self->_update_status;
};



event airlift => sub {
    my ($self, $player, $card) = @_[OBJECT, ARG0..$#_];
    Games::Pandemic::Tk::Dialog::Airlift->new(
        parent => $mw,
        player => $player,
        card   => $card,
    );
};



event all_cures_discovered => sub {
    # warn user
    Games::Pandemic::Tk::Dialog::Simple->new(
        parent => $mw,
        title  => T('You won!'),
        header => T('Congratulations'),
        icon   => catfile($SHAREDIR, 'icons', 'success-48.png'),
        text   => T(  "You won: you discovered all the cures."
                    . "\n\n"
                    . "Perhaps is it time to augment difficulty?" ),
    );
};



event build_station => sub {
    my ($self, $city) = @_[OBJECT, ARG0];
    $self->_draw_station($city);
    $self->_update_status;
};



event cure => sub {
    my ($self, $disease) = @_[OBJECT, ARG0];
    $self->_w('tooltip')->attach(
        $self->_w("lab_cure_$disease"),
        -msg=> sprintf( T("cure found\nfor %s"), $disease->name ),
    );
    $self->_update_status;
};



event drop_card => sub {
    my ($self, $player, $card) = @_[OBJECT, ARG0..$#_];
    $K->post( cards => 'drop_card', $player, $card );
    $self->_update_status; # deck count
};



event end_of_actions => sub {
    my $self = $_[OBJECT];
    $self->_update_actions;
};



event end_of_cards => sub {
    my $self = $_[OBJECT];
    $self->_update_actions;
};



event end_of_propagation => sub {
    my $self = $_[OBJECT];
    $self->_update_actions;
};



event epidemic => sub {
    my ($self, $city) = @_[OBJECT, ARG0];

    # warn user
    my $format = T('%s epidemic strikes in %s.');
    Games::Pandemic::Tk::Dialog::Simple->new(
        parent => $mw,
        title  => T('Warning'),
        header => T('New epidemic'),
        icon   => catfile($SHAREDIR, 'icons', 'warning-48.png'),
        text   => sprintf($format, $city->disease->name, $city->name)
    );
};



event eradicate => sub {
    my ($self, $disease) = @_[OBJECT, ARG0];
    my $label = $self->_w("lab_cure_$disease");
    $label->configure(
        -image => image( $disease->image('golden-cure', 32) ) );
    $self->_w('tooltip')->attach(
        $label,
        -msg => sprintf( T("%s:\ndisease eradicated"), $disease->name ),
    );
};



event forecast => sub {
    my ($self, $player, $card) = @_[OBJECT, ARG0..$#_];
    Games::Pandemic::Tk::Dialog::Forecast->new(
        parent => $mw,
        player => $player,
        card   => $card,
    );
};



event gain_card => sub {
    my ($self, $player, $card) = @_[OBJECT, ARG0..$#_];
    $K->post( cards => 'gain_card', $player, $card );
    $self->_update_status; # deck count
};



event game_over => sub {
    my $self = shift;
    $self->_update_status;
    $self->_action($_)->disable for ( "continue",
        map { "action_$_" } qw{ build discover treat share pass drop } );
};



event government_grant => sub {
    my ($self, $player, $card) = @_[OBJECT, ARG0..$#_];
    Games::Pandemic::Tk::Dialog::GovernmentGrant->new(
        parent => $mw,
        player => $player,
        card   => $card,
    );
};



event infection => sub {
    my ($self, $city, $outbreak) = @_[OBJECT, ARG0, ARG1];

    # draw city infections
    $self->_draw_infection($city);

    # update status bar
    $self->_update_status;

    # compute decay colors
    my @from = (0, 255, 0);
    my @to   = (0, 0, 0);
    my $steps = 20;
    my @colors;
    foreach my $i ( 0 .. $steps ) {
        my $r = $from[0] + int( ($to[0] - $from[0]) / $steps * $i );
        my $g = $from[1] + int( ($to[1] - $from[1]) / $steps * $i );
        my $b = $from[2] + int( ($to[2] - $from[2]) / $steps * $i );
        push @colors, sprintf( "#%02x%02x%02x", $r, $g, $b );
    }
    $self->yield( _decay => $city, \@colors );
};



event new_game => sub {
    my $self = shift;
    my $c = $self->_w('canvas');
    my $s = $self->_session;

    # add missing gui elements
    $self->_build_action_bar;
    $self->_build_status_bar;
    Games::Pandemic::Tk::PlayerCards->new( parent=>$mw );

    # remove everything on the canvas
    $c->delete('all');

    # prevent some actions
    $self->_action('new')->disable;
    $self->_action('load')->disable;
    $self->_action('close')->enable;
    $self->_action('show_cards')->enable;

    # the background image
    my $map    = Games::Pandemic->instance->map;
    my $bgpath = $map->background_path;
    my ($xmax, $ymax) = imgsize($bgpath);
    my $bg = image($bgpath);
    $c->createImage(0, 0, -anchor=>'nw', -image=>$bg, -tags=>['background']);
    $c->lower('background', 'all');

    # place the cities on the map
    my @smooth = ( -smooth => 1, -splinesteps => 5 );
    foreach my $city ( $map->all_cities ) {
        $self->_draw_city($city);
        my $x = $city->coordx;
        my $y = $city->coordy;

        # draw connections between cities
        foreach my $n ( $city->neighbours ) {
            my $xn = $n->coordx;
            my $yn = $n->coordy;
            next if $xn < $x; # line already drawn
            if ( ($xn-$x) > $xmax/2 ) {
                $c->createLine( $x, $y, 0, ($y+$yn)/2, -fill => 'red', -tags=>['line'], @smooth );
                $c->createLine( $xn, $yn, $xmax, ($y+$yn)/2, -fill => 'red', -tags=>['line'], @smooth );
            } else {
                $c->createLine( $x, $y, $xn, $yn, -fill => 'red', -tags=>['line'], @smooth );
            }
        }
    }

    $c->raise('city',    'all');
    $c->raise('station', 'all');
    $c->raise('name',    'all');
    $c->bind( 'spot', '<1>', $s->postback('_city_click') );

    # draw the starting station
    my $start = $map->start_city;
    $self->_draw_station($start);
};



event new_player => sub {
    my ($self, $player) = @_[OBJECT, ARG0];

    # adding the player to player cards window
    $K->post( cards => 'new_player', $player );

    # drawing the pawn on the canvas
    my $c = $self->_w('canvas');
    my @placed = $c->find( withtag => 'player' );
    # each player will be located at a given offset of the city center,
    # in order not to overlap each other.
    my @offsets = ( [-8, -10], [8, -10], [  0, -20], [-15, -20], [ 15, -20] );
    my $offsets = $offsets[ scalar(@placed) ];
    my $city = $player->location;
    my $x = $city->coordx + $offsets->[0];
    my $y = $city->coordy + $offsets->[1];
    $c->createImage(
        $x, $y,
        -image  => image( $player->image('pawn',16) ),
        -anchor => 's',
        -tags   => ['player', $player],
    );
};



event next_action => sub {
    my $self = $_[OBJECT];
    $self->_update_status;
    $self->_update_actions;
};



event next_player => sub {
    my ($self, $player) = @_[OBJECT, ARG0];
    my $game = Games::Pandemic->instance;

    # raise back current selected player
    $self->_w('canvas')->raise( $self->_selplayer );
    $self->_set_selplayer( $player );
    $K->delay( _blink_player => $TIME_BLINK, 0 );

    $self->_w('lab_curplayer')->configure(-image=>image($player->image('icon', 32)));
};



event no_more_cards => sub {
    my $self = $_[OBJECT];

    # warn user
    my $header = T('No more cards');
    my $reason = T('there are no more cards to deal.');

    $self->_game_lost($header, $reason);
};



event no_more_cubes => sub {
    my ($self, $disease) = @_[OBJECT, ARG0];

    # warn user
    my $fmt_reason = T( "the %s pandemic is too spread out to be cured." );
    my $header = T('Pandemic out of control');
    my $reason = sprintf $fmt_reason, $disease->name;

    $self->_game_lost($header, $reason);
};



event one_quiet_night => sub {
    my ($self, $player, $card) = @_[OBJECT, ARG0..$#_];

    my $text = $card->description . "\n\n" .
        T('Do you want to play this card?');

    Games::Pandemic::Tk::Dialog::Action->new(
        parent    => $mw,
        title     => T('Special event'),
        header    => $card->label,
        icon      => catfile($SHAREDIR, 'cards', 'one-quiet-night-48.png'),
        text      => $text,
        action    => T('Play'),
        post_args => [ controller=>'one_quiet_night', $player, $card ],
    );
};



event player_move => sub {
    my ($self, $player, $from, $to) = @_[OBJECT, ARG0..$#_];

    # canvas uses delta for move()
    my $dx = $to->coordx - $from->coordx;
    my $dy = $to->coordy - $from->coordy;
    $self->_w('canvas')->move( $player, $dx, $dy );

    # need to update actions if moved with airlift
    $self->_update_actions;
};



event resilient_population => sub {
    my ($self, $player, $card) = @_[OBJECT, ARG0..$#_];
    Games::Pandemic::Tk::Dialog::ResilientPopulation->new(
        parent => $mw,
        player => $player,
        card   => $card,
    );
};



event too_many_cards => sub {
    my ($self, $player) = @_[OBJECT, ARG0];

    # warn user
    my $format = T('Player %s has too many cards. '.
        'Drop some cards (or use some action cards) before continuing.');
    Games::Pandemic::Tk::Dialog::Simple->new(
        parent => $mw,
        title  => T('Warning'),
        header => T('Too many cards'),
        icon   => catfile($SHAREDIR, 'icons', 'warning-48.png'),
        text   => sprintf($format, $player->role)
    );

    # prevent any action but dropping cards
    $self->_action("action_$_")->disable for qw{ build discover treat share pass };
    $self->_action("action_drop")->enable;

    # FIXME: provide a way to drop cards
};


event too_many_outbreaks => sub {
    my $self = shift;

    # warn user
    my $header = T('Too many outbreaks');
    my $reason = T('there were too many outbreaks, pandemics have spread out of control.');

    $self->_game_lost($header, $reason);
};



event treatment => sub {
    my ($self, $city) = @_[OBJECT, ARG0];
    $self->_draw_infection($city);
    $self->_update_status;
};


# -- private events

#
# event: _blink_player( $bool )
#
# make current selected player blink on the map, depending on previous $bool
# visibility satus.  schedule another _blink_player event.
#
event _blink_player => sub {
    my ($self, $lit) = @_[OBJECT, ARG0];
    my $c    = $self->_w('canvas');
    my $curp = $self->_selplayer;
    my $method = $lit ? 'raise' : 'lower';
    $c->$method( $curp );
    $K->delay( _blink_player => $TIME_BLINK, !$lit );
};


#
# event: _decay( $city, \@colors )
#
# change $city outline color to the first element of @colors, and
# schedule another _decay event with the rest of @colors if it's still
# not empty.
#
event _decay => sub {
    my ($self, $city, $colors) = @_[OBJECT, ARG0, ARG1];
    my $c    = $self->_w('canvas');
    my $name = $city->name;
    my $col  = shift @$colors;
    $c->itemconfigure(
        "$name&&spot",
        -outline => $col,
        -width   => min(5, $#$colors+1),
    );
    $K->delay_add( _decay => $TIME_DECAY, $city, $colors ) if $#$colors;
};


event _glow => sub {
    my $self = shift;
    my $game = Games::Pandemic->instance;
    my $color = $self->_next_infection_rate_color;
    $self->_w('lab_infection_rate')->configure(-bg=>$color);
    $K->delay( _glow => $TIME_GLOW / ($game->nb_epidemics+1) );
    $self->_add_infection_rate_color($color);
};

# -- gui events

#
# event: _action_build()
#
# user wishes to build a research station.
#
event _action_build => sub {
    $K->post( controller => 'action', 'build' );
};


#
# event: _action_drop()
#
# user wishes to drop a card, either from current player or if we're in
# a situation of too many cards.
#
event _action_drop => sub {
    my $game = Games::Pandemic->instance;
    my $player = $game->too_many_cards // $game->curplayer; # FIXME://padre
    Games::Pandemic::Tk::Dialog::DropCards->new(
        parent => $mw,
        player => $player,
    );
};


#
# event: _action_discover()
#
# user wishes to discover a cure.
#
event _action_discover => sub {
    my $game = Games::Pandemic->instance;
    my $curp = $game->curplayer;

    my $disease = $curp->is_discover_possible;
    my @cards =
        grep { $_->city->disease eq $disease }
        grep { $_->isa('Games::Pandemic::Card::City') }
        $curp->all_cards;

    # FIXME: choose which cards
    splice @cards, $curp->cards_needed;

    $K->post( controller => 'action', 'discover', $disease, @cards );
};


#
# event: _action_pass()
#
# user wishes to pass.
#
event _action_pass => sub {
    $K->post( controller => 'action', 'pass' );
};


#
# event: _action_share()
#
# user wishes to give a card to another player.
#
event _action_share => sub {
    my $game = Games::Pandemic->instance;
    my $curp = $game->curplayer;
    my $city = $curp->location;

    # get list of players to whom the card can be given
    my @players =
        grep { $_->location eq $city }
        grep { $_ ne $curp }
        $game->all_players;

    # get list of cards to be shared
    my @cards = $curp->can_share_anywhere
        ? grep { $_->isa('Games::Pandemic::Card::City') } $curp->all_cards
        : $curp->owns_city_card($city);

    if ( @players == 1 && @cards == 1 ) {
        $K->post( controller => 'action', 'share', @cards, @players );

    } else {
        Games::Pandemic::Tk::Dialog::GiveCard->new(
            parent  => $mw,
            cards   => \@cards,
            players => \@players,
        );
    }
};


#
# event: _action_treat()
#
# user wishes to treat a disease in her location.
#
event _action_treat => sub {
    my $game = Games::Pandemic->instance;
    my $curp = $game->curplayer;
    my $map  = $game->map;
    my $city = $curp->location;

    # find the city infections
    my @diseases;
    foreach my $disease ( $map->all_diseases ) {
        next if $city->get_infection($disease) == 0;
        push @diseases, $disease;
    }

    # check if city is multi-infected
    if ( scalar @diseases == 1 ) {
        $K->post( controller => 'action', 'treat', $diseases[0] );
    } else {
        Games::Pandemic::Tk::Dialog::ChooseDisease->new(
            parent   => $mw,
            diseases => \@diseases,
        );
    }
};


#
# event: _city_click( undef, [ $canvas ] )
#
# called when used clicked on a city on the canvas.
#
event _city_click => sub {
    my ($self, $args) = @_[OBJECT, ARG1];
    my $game = Games::Pandemic->instance;

    # if we're in a situation of too many cards for a player, user is
    # not allowed to travel
    return $self->yield('too_many_cards', $game->too_many_cards)
        if defined $game->too_many_cards;

    return unless $game->state eq 'actions';

    my ($canvas) = @$args;
    my $map  = $game->map;
    my $player = $game->curplayer; # FIXME: dispatcher

    # find city clicked
    my $item = $canvas->find( withtag => 'current' );
    my ($id) = map { /^c-(.*)/ ? $1 : () } $canvas->gettags($item);
    my $city = $map->city($id);

    if ( $city eq $player->location ) {
        # FIXME: hilight possible travel destinations
    } else {
        return $K->post( controller => 'action', 'move', $player, $city )
            if $player->can_travel_to($city);
        return $K->post( controller => 'action', 'shuttle', $player, $city )
            if $player->can_shuttle_to($city);
        return $K->post( controller => 'action', 'charter', $player, $city )
            if $player->owns_city_card($player->location);
        return $K->post( controller => 'action', 'fly', $player, $city )
            if $player->owns_city_card($city);
    }
};


#
# event: _close()
#
# request to close current game.
#
event _close => sub {
    my $self = shift;
    my $game = Games::Pandemic->instance;

    # remove current timers
    $K->alarm_remove_all;

    # allow some actions
    $self->_action('new')->enable;
    $self->_action('load')->enable;
    $self->_action('close')->disable;
    $self->_action('show_cards')->disable;

    # remove everything from current game
    my $tb = $self->_del_w('tbactions');
    $tb->{CONTAINER}->packForget; # FIXME: breaking encapsulation
    $tb->destroy;
    $self->_del_w('infobar')->destroy;

    my $c = $self->_w('canvas');
    $c->delete('all');

    # destroy player cards window
    $K->post( cards => 'destroy' );

    # redraw initial actions
    $self->_draw_init_screen;

    $K->post( controller => 'close' );
};


#
# event: _continue()
#
# request to move game forward.
#
event _continue => sub {
    my $game = Games::Pandemic->instance;
    $K->post( controller => 'continue' );
};


#
# event: _new()
#
# request a new game to the controller
#
event _new => sub {
    my $game = Games::Pandemic->instance;
    return if $game->is_in_play;
    $K->post( controller => 'new_game' );
};


#
# event: _quit()
#
# user requested to quit the application.
#
event _quit => sub {
    exit; # FIXME: do better than that...
};


#
# event: _show_cards()
#
# user request to toggle player cards visbility
#
event _show_cards => sub {
    $K->post( cards => 'toggle_visibility' );
};


#
# event: _show_past_cards()
#
# user request to see cards already played / dropped.
#
event _show_past_cards => sub {
    my $game = Games::Pandemic->instance;
    my $deck = $game->cards;

    if ( $deck->nbdiscards ) {
        Games::Pandemic::Tk::Dialog::ViewCards->new(
            parent => $mw,
            title  => T('Information'),
            header => T('Discard pile'),
            cards  => [ $deck->past ],
        );
    } else {
        # nothing to show
        Games::Pandemic::Tk::Dialog::Simple->new(
            parent => $mw,
            icon   => catfile($SHAREDIR, 'icons', 'warning-48.png'),
            text   => T('No cards in the discard pile.'),
        );
    }
};


#
# event: _show_past_infections()
#
# user request to see infections already endured.
#
event _show_past_infections => sub {
    my $game = Games::Pandemic->instance;
    my $deck = $game->infection;

    if ( $deck->nbdiscards ) {
        Games::Pandemic::Tk::Dialog::ViewCards->new(
            parent => $mw,
            title  => T('Information'),
            header => T('Past infections'),
            cards  => [ $deck->past ],
        );
    } else {
        # nothing to show
        Games::Pandemic::Tk::Dialog::Simple->new(
            parent => $mw,
            icon   => catfile($SHAREDIR, 'icons', 'warning-48.png'),
            text   => T('No past infections.'),
        );
    }
};


# -- gui creation

#
# $main->_build_action_bar;
#
# create the action bar at the bottom of the window, with the various
# action buttons that a player can press when it's her turn.
#
sub _build_action_bar {
    my $self = shift;
    my $session = $self->_session;

    # create the toolbar
    my $tbmain = $self->_w('toolbar');
    my $tb = $mw->ToolBar(-movable => 0, -in=>$tbmain );
    $self->_set_w('tbactions', $tb);

    # the toolbar widgets
    my @actions = (
        [ 'build',    T('Build a research station')                ],
        [ 'discover', T('Discover a cure')                         ],
        [ 'treat',    T('Treat a disease')                         ],
        [ 'share',    T('Give a card')                             ],
        [ 'pass',     T('Pass your turn')                          ],
        [ 'drop',     T('Drop some cards')                         ],
    );

    # create the widgets
    foreach my $item ( @actions ) {
        my ($action, $tip) = @$item;

        my $image = image( catfile($SHAREDIR, 'actions', "$action.png") );
        my $event = "_action_$action";

        # regular toolbar widgets
        my $widget = $tb->Button(
            -image       => $image,
            -tip         => $tip,
            -command     => $session->postback($event),
        );
        $self->_action("action_$action")->add_widget($widget);
    }

    # player information
    $tb->separator( -movable => 0 );
    my $labcurp = $tb->Label; # for current player image
    $tb->Label( -text => T('actions left: ') );
    my $labturn = $tb->Label;
    $self->_set_w('lab_curplayer', $labcurp);
    $self->_set_w('lab_nbactions', $labturn);

    # continue button
    my $but = $tb->Button(
        -text    => T('Continue'),
        -command => $session->postback('_continue'),
        enabled,
    );
    $self->_action('continue')->add_widget($but);
}


#
# $main->_build_canvas;
#
# create the canvas, where the map will be drawn and the action
# take place.
#
sub _build_canvas {
    my $self = shift;
    my $s = $self->_session;

    my $config = Games::Pandemic::Config->instance;
    my $width  = $config->get( 'canvas_width' );
    my $height = $config->get( 'canvas_height' );

    # creating the canvas
    my $c  = $mw->Canvas(-width=>$width,-height=>$height)->pack(top, xfill2);
    $self->_set_w('canvas', $c);

    # removing class bindings
    foreach my $button ( qw{ 4 5 6 7 } ) {
        $mw->bind('Tk::Canvas', "<Button-$button>",       undef);
        $mw->bind('Tk::Canvas', "<Shift-Button-$button>", undef);
    }
    foreach my $key ( qw{ Down End Home Left Next Prior Right Up } ) {
        $mw->bind('Tk::Canvas', "<Key-$key>", undef);
        $mw->bind('Tk::Canvas', "<Control-Key-$key>", undef);
    }

    # initial actions
    $self->_draw_init_screen;
}


#
# $main->_build_gui;
#
# create the various gui elements.
#
sub _build_gui {
    my $self = shift;
    my $s = $self->_session;

    # hide window during its creation to avoid flickering
    $mw->withdraw;

    # prettyfying tk app.
    # see http://www.perltk.org/index.php?option=com_content&task=view&id=43&Itemid=37
    $mw->optionAdd('*BorderWidth' => 1);

    # set windowtitle
    $mw->title(T('Pandemic'));
    $mw->iconimage( pandemic_icon() );

    # make sure window is big enough
    my $config = Games::Pandemic::Config->instance;
    my $width  = $config->get( 'win_width' );
    my $height = $config->get( 'win_height' );
    $mw->geometry($width . 'x' . $height);

    # create the actions
    my @enabled  = qw{ new load quit };
    my @disabled = (
        qw{ close continue show_cards },
        map { "action_$_" } qw{ build discover drop pass share treat },
    );
    foreach my $what ( @enabled, @disabled ) {
        my $action = Tk::Action->new(
            window   => $mw,
            callback => $s->postback("_$what"),
        );
        $self->_set_action($what, $action);
    }
    # allow some actions
    $self->_action($_)->enable  for @enabled;
    $self->_action($_)->disable for @disabled;

    # the tooltip
    $self->_set_w('tooltip', $mw->Balloon);

    # WARNING: we need to create the toolbar object before anything
    # else. indeed, tk::toolbar loads the embedded icons in classinit,
    # that is when the first object of the class is created - and not
    # during compile time.
    $self->_build_toolbar;
    $self->_build_menubar;
    $self->_build_canvas;

    # center & show the window
    # FIXME: restore last position saved?
    $mw->Popup;
}


#
# $self->_build_menu( $mnuname, $mnulabel, @submenus );
#
# Create the menu $label, with all the @submenus.
# @submenus is a list of [$name, $icon, $accel, $label] items.
# Store the menu items under the name menu_$mnuname_$name.
#
sub _build_menu {
    my ($self, $mnuname, $mnulabel, @submenus) = @_;
    my $menubar = $self->_w('menubar');
    my $s = $self->_session;

    my $menu = $menubar->cascade(-label => $mnulabel);
    foreach my $item ( @submenus ) {
        my ($name, $icon, $accel, $label) = @$item;

        # separators are easier
        if ( $name eq '---' ) {
            $menu->separator;
            next;
        }

        # regular buttons
        my $action = $self->_action($name);
        my $widget = $menu->command(
            -label       => $label,
            -image       => $icon,
            -compound    => 'left',
            -accelerator => $accel,
            -command     => $action->callback,
        );
        $self->_set_w("menu_${mnuname}_${name}", $widget);

        # create the bindings. note: we also need to bind the lowercase
        # letter too!
        $action->add_widget($widget);
        $accel =~ s/Ctrl\+/Control-/;
        $action->add_binding("<$accel>");
        $accel =~ s/Control-(\w)/"Control-" . lc($1)/e;
        $action->add_binding("<$accel>");
    }
}


#
# $main->_build_menubar;
#
# create the window's menu.
#
sub _build_menubar {
    my $self = shift;
    my $s = $self->_session;

    # no tear-off menus
    $mw->optionAdd('*tearOff', 'false');

    #$h->{w}{mnu_run} = $menubar->entrycget(1, '-menu');

    my $menubar = $mw->Menu;
    $mw->configure(-menu => $menubar );
    $self->_set_w('menubar', $menubar);

    # menu game
    my @mnu_game = (
    [ 'new',   'filenew16',   'Ctrl+N', T('~New game')   ],
    [ 'load',  'fileopen16',  'Ctrl+O', T('~Load game')  ],
    [ 'close', 'fileclose16', 'Ctrl+W', T('~Close game') ],
    [ '---'                                              ],
    [ 'quit',  'actexit16',   'Ctrl+Q', T('~Quit')       ],
    );
    $self->_build_menu('game', T('~Game'), @mnu_game);

    # menu view
    my @mnu_view = (
    [ 'show_cards', '', 'F2', T('Player ~cards') ],
    );
    $self->_build_menu('view', T('~View'), @mnu_view);

    # menu actions
    my @mnu_action = (
    [ 'action_build'    , '', 'b', T('~Build a research station') ],
    [ 'action_discover' , '', 'c', T('Discover a ~cure')          ],
    [ 'action_treat'    , '', 't', T('~Treat a disease')          ],
    [ 'action_share'    , '', 's', T('~Give a card')              ],
    [ 'action_pass'     , '', 'p', T('~Pass your turn')           ],
    [ '---'                                                       ],
    [ 'action_drop'     , '', 'd', T('~Drop some cards')          ],
    [ '---'                                                       ],
    [ 'continue'        , '', 'Return', T('Conti~nue')          ],
    );
    $self->_build_menu('action', T('~Action'), @mnu_action);
}


#
# $main->_build_status_bar;
#
# create the status bar at the right of the window.
#
sub _build_status_bar {
    my $self = shift;
    my $game = Games::Pandemic->instance;
    my $map  = $game->map;
    my $s    = $self->_session;
    my $tip  = $self->_w('tooltip');
    my $tipmsg;

    # the status bar itself is a frame
    my $sb = $mw->Frame->pack(right, fillx, -before=>$self->_w('canvas'));
    $self->_set_w( infobar => $sb );

#    # research stations
#    my $fstations = $sb->Frame->pack(top, padx10);
#    my $img_nbstations = $fstations->Label(
#        -image => image( catfile( $SHAREDIR, 'research-station-32.png' ) ),
#    )->pack(@TOP);
#    my $lab_nbstations = $fstations->Label->pack(@TOP);
#    $self->_set_w('lab_nbstations', $lab_nbstations );
#    $tipmsg = T("number of remaining\nresearch stations");
#    $tip->attach($img_nbstations, -msg=>$tipmsg);
#    $tip->attach($lab_nbstations, -msg=>$tipmsg);

    # diseases information
    my $fdiseases = $sb->Frame->pack(top, padx(10));
    my $fcures    = $sb->Frame->pack(top, padx(10));
    foreach my $disease ( $map->all_diseases ) {
        # disease
        my $img_disease = $fdiseases->Label(
            -image => image( $disease->image('cube', 32) ),
        )->pack(top);
        my $lab_disease = $fdiseases->Label->pack(top);
        $self->_set_w("lab_disease_$disease", $lab_disease);
        $tipmsg = sprintf T("number of cubes\nof %s left"), $disease->name;
        $tip->attach($img_disease, -msg=>$tipmsg);
        $tip->attach($lab_disease, -msg=>$tipmsg);

        # cure
        my $lab_cure = $fcures->Label(
            -image => image( $disease->image('cure', 32) ),
        )->pack(top);
        $self->_set_w("lab_cure_$disease", $lab_cure);
        $tipmsg = sprintf T("cure for %s\nnot found"), $disease->name;
        $tip->attach($lab_cure, -msg=>$tipmsg);
    }

    # player cards information
    my $cards  = $game->cards;
    my $fcards = $sb->Frame->pack(top, padx(10));
    my $img_cards = $fcards->Label(
        -image => image( catfile( $SHAREDIR, 'card-player.png' ) ),
    )->pack(top);
    my $lab_cards = $fcards->Label->pack(top);
    $self->_set_w('lab_cards', $lab_cards);
    $img_cards->bind('<Button-1>', $s->postback('_show_past_cards'));
    $lab_cards->bind('<Button-1>', $s->postback('_show_past_cards'));
    $tipmsg = T("number of cards remaining-discarded\nclick to see history");
    $tip->attach($img_cards, -msg=>$tipmsg);
    $tip->attach($lab_cards, -msg=>$tipmsg);

    # infection information
    my $infection = $game->infection;
    my $finfection = $sb->Frame->pack(top, padx(10));
    my $img_infection = $finfection->Label(
        -image => image( catfile( $SHAREDIR, 'card-infection.png' ) ),
    )->pack(top);
    my $lab_infection = $finfection->Label->pack(top);
    $self->_set_w('lab_infection', $lab_infection);
    $img_infection->bind('<Button-1>', $s->postback('_show_past_infections'));
    $lab_infection->bind('<Button-1>', $s->postback('_show_past_infections'));
    $tipmsg = T("number of infections remaining-passed\nclick to see history");
    $tip->attach($img_infection, -msg=>$tipmsg);
    $tip->attach($lab_infection, -msg=>$tipmsg);

    # infection rate
    my $firate = $sb->Frame(-bg=>'black')->pack(top, fillx, padx(10));
    my $lab_irate = $firate->Label->pack(top, xfill2);
    $self->_set_w('lab_infection_rate', $lab_irate);
    $K->delay( _glow => $TIME_GLOW );
    $tipmsg = T("infection rate\n(number of epidemics)");
    $tip->attach($lab_irate, -msg=>$tipmsg);

    # oubreak information
    my $scale = $sb->Scale(
        -orient => 'vertical',
        -sliderlength => 20,
        -from   => 8,
        -to     => 0,
        enabled,
    )->pack(top, padx(10));
    $self->_set_w('outbreaks', $scale);
    $tipmsg = sprintf T("number of outbreaks\n(maximum %s)"), 8; # FIXME: map dependant?
    $tip->attach($scale, -msg=>$tipmsg);
}


#
# $main->_build_toolbar;
#
# create the window toolbar (the one just below the menu).
#
sub _build_toolbar {
    my $self = shift;
    my $session = $self->_session;

    # create the toolbar
    my $tb = $mw->ToolBar( -movable => 0, top );
    $self->_set_w('toolbar', $tb);

    # the toolbar widgets
    my @tb = (
        [ 'Button', 'filenew22',   'new',   T('New game')   ],
        [ 'Button', 'fileopen22',  'load',  T('Load game')  ],
        [ 'Button', 'fileclose22', 'close', T('Close game') ],
        [ 'Button', 'actexit22',   'quit',  T('Quit')       ],
    );

    # create the widgets
    foreach my $item ( @tb ) {
        my ($type, $image, $name, $tip) = @$item;

        # separator is a special case
        $tb->separator( -movable => 0 ), next if $type eq 'separator';
        my $action = $self->_action($name);

        # regular toolbar widgets
        my $widget = $tb->$type(
            -image       => $image,
            -tip         => $tip,
            #-accelerator => $item->[2],
            -command     => $action->callback,
        );
        $self->_set_w( "tbut_$name", $widget );
        $action->add_widget( $widget );
    }
}


# -- private methods

#
# $main->_draw_city($city);
#
# draw $city on the canvas.
# note: this does not draw the diseases, players and research stations.
#
sub _draw_city {
    my ($self, $city) = @_;
    my $c = $self->_w('canvas');

    # fetch city information
    my $id    = $city->id;
    my $name  = $city->name;
    my $color = $city->disease->color(0);
    my $xreal = $city->xreal;
    my $yreal = $city->yreal;
    my $x     = $city->coordx;
    my $y     = $city->coordy;

    # join the 2 circles. this is done first in order to be overwritten
    # by other drawings on the canvas, such as the circles themselves.
    $c->createLine( $xreal, $yreal, $x, $y,
        -width       => 2,
        -fill        => $color,
        -tags        => [ 'city', 'draw', $name ],
        -smooth      => 1,
        -splinesteps => 5,
    );

    # draw the small circle with real position on map
    my $rreal = 2; # 4 pixels diameter
    $c->createOval(
        $xreal-$rreal, $yreal-$rreal, $xreal+$rreal, $yreal+$rreal,
        -fill => $color,
        -tags => ['city', 'draw', $name],
    );

    # draw the big circle that user can click
    $c->createOval(
        $x-$RADIUS, $y-$RADIUS, $x+$RADIUS, $y+$RADIUS,
        -fill => $color,
        -tags => ['city', 'draw', 'spot', $name, "c-$id"],
    );

    # write the city name
    $c->createText(
        $x, $y - $RADIUS * 1.5,
        -text   => $name,
        -fill   => 'black',
        -anchor => 'center',
        -tag    => ['city', $name],
    );
}


#
# $main->_draw_infection($city);
#
# re-draw the infection squares on the canvas for the given $city.
#
sub _draw_infection {
    my ($self, $city) = @_;
    my $game = Games::Pandemic->instance;
    my $map  = $game->map;

    # get number of main infection
    my $maindis = $city->disease;
    my $mainnb  = $city->get_infection( $maindis );
    my $color   = $maindis->color($mainnb);
    my @infections = ( $color ) x $mainnb;

    # update city color
    my $c    = $self->_w('canvas');
    my $name = $city->name;
    $c->itemconfigure( "$name&&draw", -fill => $color );

    # get list of disease items, with their color
    my @diseases =
        sort { $a->id <=> $b->id }
        grep { $_ ne $maindis }
        $map->all_diseases;
    foreach my $disease ( @diseases ) {
        my $nb  = $city->get_infection( $disease );
        my $col = $disease->color($nb);
        push @infections, ( $col ) x $nb;
    }

    # remove all infection items for the city
    $c->delete( "$name&&disease" );

    # draw the infection items
    my $x = $city->coordx;
    my $y = $city->coordy;
    my $tags = [ $name, 'disease' ];

    my $len = 8;
    my $pad = 4;
    foreach my $i ( 0 .. $#infections ) {
        my $xorig = $x + ($#infections/2 -$i) * $len + (($#infections-$i)/2-1) * $pad;
        my $yorig = $y + $RADIUS + $pad;
        $c->createRectangle(
            $xorig, $yorig,
            $xorig+$len, $yorig+$len,
            -fill    => $infections[$i],
            #-outline => undef,
            -tags    => $tags,
        );
    }
}


#
# $main->_draw_init_screen;
#
# draw splash image on canvas + initial actions, to present user with a
# non-empty window by default.
#
sub _draw_init_screen {
    my $self = shift;
    my $c = $self->_w('canvas');
    my $s = $self->_session;

    my $config = Games::Pandemic::Config->instance;
    my $width  = $config->get( 'canvas_width' );
    my $height = $config->get( 'canvas_height' );

    # create the initial welcome screen
    my @tags = ( -tags => ['startup'] );
    # first a background image...
    $c->createImage (
        $width/2, $height/2,
        -anchor => 'center',
        -image  => image( catfile($SHAREDIR, "background.png") ),
        @tags,
    );
    # ... then some basic actions
    my @buttons = (
        [ T('New game') ,  1, '_new'  ],
        [ T('Join game') , 0, '_join' ],
        [ T('Load game') , 0, '_load' ],
    );
    my $pad = 25;
    my $font = $mw->Font(-weight=>'bold');
    foreach my $i ( 0 .. $#buttons ) {
        my ($text, $active, $event) = @{ $buttons[$i] };
        # create the 'button' (really a clickable text)
        my $id = $c->createText(
            $width/2, $height/2 - (@buttons)/2*$pad + $i*$pad,
            $active ? enabled : disabled,
            -text         => $text,
            -fill         => '#dddddd',
            -activefill   => 'white',
            -disabledfill => '#999999',
            -font         => $font,
            @tags,
        );
        # now bind click on this text
        $c->bind( $id, '<1>', $s->postback($event) );
    }
}


#
# $main->_draw_station($city);
#
# draw a research station on the canvas for the given $city.
#
sub _draw_station {
    my ($self, $city) = @_;
    my $c = $self->_w('canvas');

    my $x = $city->coordx;
    my $y = $city->coordy;
    my $name = $city->name;
    my $tags = [ 'station', $name ];
    $c->createImage(
        $x, $y,
        -anchor=>'e',
        -image => image( catfile($SHAREDIR, 'research-station-32.png') ),
        -tags  => $tags,
    );
}


#
# $main->_game_lost( $header, $reason );
#
# show a standard simple dialog announcing end of game for a given $reason.
#
sub _game_lost {
    my ($self, $header, $reason) = @_;
    my $text = T( 'Game is over, you lost: ' )
             . $reason
             . "\n\n"
             . T( 'Try harder next time!' );
    Games::Pandemic::Tk::Dialog::Simple->new(
        parent => $mw,
        title  => T('You lost!'),
        header => $header,
        icon   => catfile($SHAREDIR, 'icons', 'warning-48.png'),
        text   => $text,
    );
};


#
# $main->_update_actions;
#
# update action buttons state depending on player.
#
sub _update_actions {
    my $self = shift;
    my $game = Games::Pandemic->instance;
    my $player = $game->curplayer;

    my @actions = qw{ build discover treat share pass drop };
    given ( $game->state ) {
        when ('actions') {
            foreach my $action ( @actions ) {
                my $check  = "is_${action}_possible";
                my $method = $player->$check ? 'enable' : 'disable';
                $self->_action("action_$action")->$method;
            }
            $self->_action('continue')->disable;
        }
        when ('end_of_actions' || 'end_of_cards') {
            $self->_action("action_$_")->disable for @actions;
            $self->_action('continue')->enable;
        }
    }
}


#
# $main->_update_status;
#
# update the status bar with relevant information.
#
sub _update_status {
    my $self = shift;
    my $game = Games::Pandemic->instance;
    my $curp = $game->curplayer;
    my $map  = $game->map;

#    # research stations
#    $self->_w('lab_nbstations')->configure(-text => $game->stations);

    # diseases information
    foreach my $disease ( $map->all_diseases ) {
        $self->_w("lab_disease_$disease")->configure(-text => $disease->nbleft);
        $self->_w("lab_cure_$disease")->configure(
            $disease->has_cure ? (enabled) : (disabled) );
    }

    # cards information
    my $deck1 = $game->cards;
    my $deck2 = $game->infection;
    my $text1 = $deck1->nbcards . '-' . $deck1->nbdiscards;
    my $text2 = $deck2->nbcards . '-' . $deck2->nbdiscards;
    $self->_w('lab_cards')->configure( -text => $text1 );
    $self->_w('lab_infection')->configure(-text => $text2 );

    # infection rate
    my $lab_irate = $self->_w('lab_infection_rate');
    my $text = sprintf "%d (%d)", $game->infection_rate, $game->nb_epidemics;
    $lab_irate->configure(-text =>$text);

    # number of outbreaks
    my $outbreaks = $game->nb_outbreaks;
    my $scale = $self->_w('outbreaks');
    $scale->configure(enabled); # ->set() doesn't work if disabled
    $scale->set( $outbreaks );
    my $color = Convert::Color::RGB8->new( @{ $self->_outbreak_color($outbreaks) } );
    $scale->configure(
        -troughcolor => '#' . $color->hex,
        enabled,
    );

    # actions left
    $self->_w('lab_nbactions')->configure(-text=>$curp->actions_left);
}


no Moose;
__PACKAGE__->meta->make_immutable;

1;




__END__