root/veekun/trunk/lib/Vee/Controller/Dex/Utils.pm @ 406

package Vee::Controller::Dex::Utils;

use strict;
use warnings;
use base 'Catalyst::Controller';

use List::MoreUtils qw/first_index last_index/;
use Vee::Dex;
use Vee::Form;

__PACKAGE__->config->{namespace} = 'dex';

=head1 NAME

Vee::Controller::Dex::Utils - Pokedex utility Controller

=head1 SYNOPSIS

See L<Vee>

=head1 DESCRIPTION

Catalyst Controller for Pokedex-related utilities, calculators, etc.

=head1 METHODS

=cut

=head2 compare

=cut

my $MAX_POKEMON = 8;
my $FONT_MAX = 24;
my $FONT_MIN = 8;
my @versions = qw/rb y gs c rusa frlg dp/;

sub compare : Path('pokemon/compare') : Args(0) {
    my ($self, $c) = @_;
    my $s = $c->stash;

    $s->{page_title} = 'Pok&eacute;mon Comparifier';
    $s->{template} = 'dex/utils/compare.tt';

    $s->{versions} = \@versions;
    $s->{MAX_POKEMON} = $MAX_POKEMON;
    $s->{FONT_MAX} = $FONT_MAX;
    $s->{FONT_MIN} = $FONT_MIN;
    
    my $params = $c->req->params;
    my $version = $params->{version};
    $version = $versions[-1] unless $version and Vee::Utils::in($version, @versions);
    $s->{version} = $version;

    return unless %{$c->req->params};

    # get pokemons
    my @pokemon_raw = Vee::Utils::array($params->{poke});
    @pokemon_raw = @pokemon_raw[0 .. $MAX_POKEMON - 1] if $#pokemon_raw >= $MAX_POKEMON;

    my %randoms;  # used to make sure no Pokemon is randomly picked twice
    my (@pokemon_ids, @bad_pokemon, @pokemon_notes);
    for my $p (0 .. $#pokemon_raw) {
        my $poke = $pokemon_raw[$p];
        next unless $poke;
        
        if ($poke eq 'random') {  # special case: random
            $pokemon_ids[$p] = 1 + int rand $#PokemonNames;
            while ($randoms{ $pokemon_ids[$p] }) {
                $pokemon_ids[$p] = 1 + int rand $#PokemonNames;
            }
            $randoms{ $pokemon_ids[$p] } = 1;

        } elsif (my $result = get_pokemon($poke)) {
            if (ref $result eq 'SCALAR') {
                $pokemon_notes[$p] = $$result
            } else {
                $pokemon_ids[$p] = $result
            }

        } elsif (4 > length $poke) {
            $pokemon_notes[$p] = 'Too short for fuzzy search.';
        } else {
            my @fuzzies = get_fuzzy($poke, 'pokemon');
            if (@fuzzies) {
                $pokemon_ids[$p] = ( shift @fuzzies )->{id};
                @fuzzies = @fuzzies[0 .. 3] if @fuzzies > 4;
                $pokemon_notes[$p] = \@fuzzies;
            } else {
                $pokemon_notes[$p] = "No match found."; 
            }
        }            
    }
    $s->{pokemon_notes} = \@pokemon_notes;
    
    # grab the Pokemon's rows and stick them into an array in the correct order
    my %pokemon_order;
    for my $i (0 .. $#pokemon_ids) {
        next unless $pokemon_ids[$i];
        push @{ $pokemon_order{ $pokemon_ids[$i] } }, $i;
    }
    my @pokemon;

    my (@rows, @pokemon_moves);
    # only do this if there are actually correct Pokemon to look up!
    if (@pokemon_ids) {
        my $pokemon_rs = $c->model('DBIC::Pokemon')->search({
            'me.id' => \@pokemon_ids
        }, {
            # TODO: this sucks; patch dbic
            prefetch => { pokemon_abilities => 'ability' },
        });
        while (my $poke = $pokemon_rs->next) {
            $pokemon[$_] = $poke for @{ $pokemon_order{$poke->id} };
        }
        
        # get moves
        my $move_rs = $c->model('DBIC::PokemonMoves')->search({
            pokemon_id => [ keys %pokemon_order ],
            method     => [qw/level machine egg tutor/],
            -nest      => \ "FIND_IN_SET('$version', versions)",
        });
        while (my $row = $move_rs->next) {
            push @{ $pokemon_moves[ $_ ]{ $row->method } }, $row for @{ $pokemon_order{$row->pokemon_id} }
        }
    }

    $s->{pokemon}       = \@pokemon;
    $s->{pokemon_raw}   = \@pokemon_raw;
    $s->{pokemon_moves} = \@pokemon_moves;

    $s->{template} = 'dex/utils/compare-results.tt';
}

=head2 backtrace

Calculates parents for an egg move.

=cut

sub backtrace : Chained('pokemon_chain') : Args(1) {
    my ($self, $c) = @_;
    my $s = $c->stash;
    
    my $gen = 'dp'; # TODO: :(

    my $pokemon_name = $c->req->captures->[0];
    my $move_name    = $c->req->args    ->[0];

    # For some reason, Catalyst::DispatchType::Chained doesn't url-decode either
    # args or captures, so do it here; this is safe to do since valid move and
    # Pokemon names will never ever contain percent signs..  I hope.
    $pokemon_name =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
    $move_name    =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
    
    my $pokemon = $c->model('DBIC::Pokemon')->single({ name => $pokemon_name }, { prefetch => 'breeds' });
    my $move    = $c->model('DBIC::Moves')  ->single({ name => $move_name    });

    $c->vee_stop('No such Pok&eacute;mon ', $pokemon_name, '.')
        if not $pokemon;
    $c->vee_stop('No such move ', $move_name, '.')
        if not $move;

    $s->{page_title} = $pokemon->name . ' - ' . $move->name . ' parents';
    $s->{crumbs}     = [
        '<a href="' . $c->uri('Dex') . '">Pok&eacute;dex</a>',
        '<a href="' . $c->uri('Dex', 'pokemon_list') . '">Pok&eacute;mon</a>',
        '<a href="' . $c->uri('Dex', 'pokemon', lc $pokemon->name) . '">' . $pokemon->name . '</a>',
        'Breeding chains',
        '<a href="' . $c->uri('Dex', 'moves', lc $move->name) . '">' . $move->name . '</a>',
    ];

    # ensure this move is actually inheritable
    # TODO: should I error if the move is learnable normally?
    my $inheritable_ct = $c->model('DBIC::PokemonMoves')->count({
        pokemon_id => $pokemon->id,
        move_id    => $move->id,
        method     => [qw/ egg machine /],
        -nest      => \ "FIND_IN_SET('$gen', versions)",
    });
    $c->vee_stop('', $pokemon->name, " can't inherit ", $move->name, '.') unless $inheritable_ct;
    
    my $gender_restriction;
    if ($pokemon->gender_rate == 255) {
        # must also be genderless, i.e. bred with Ditto
        $gender_restriction = 255;
    } else {
        # cannot be single-gender or genderless
        $gender_restriction = { -not_in => [ 0, 254, 255 ] };
    }

    ### grab the methods by which any Pokemon learn the move

    my $methods_rs = $c->model('DBIC::PokemonMoves')->search({
        move_id => $move->id,
        method  => [qw[ level egg machine ]],
        -nest   => \ "FIND_IN_SET('$gen', versions)",
        'pokemon.gender_rate' => $gender_restriction,
    }, {
        join => 'pokemon',
    });
    my %learn_methods;
    while (my $row = $methods_rs->next) {
        my $method = ucfirst $row->method;
        if ($row->method eq 'level') {
            $method .= ' ' . $row->level;
        } elsif ($row->method eq 'machine') {
            $method = 'TM/HM';
        }
        push @{ $learn_methods{ $row->pokemon_id } }, $method;
    }

    ### do a SEPARATE query to grab all the possible Pokemon at once
    # (DBIC seems to get confused if I prefetch { pokemon => breeds } above)
    # XXX: is this my fault or theirs?

    my $learners_rs = $c->model('DBIC::Pokemon')->search({
        id => [ keys %learn_methods ],
    }, {
        prefetch => 'breeds',
        order_by => 'me.id ASC',
    });

    my (%pokemon);
    while (my $row = $learners_rs->next) {
        $pokemon{ $row->id } = $row;
    }

    my %breeding_tree = ( $pokemon->id => {} );

    my %seen = ( $pokemon->id => 0 );   # hash of ( poke_id => 1, ... )
    my $cur_level = 0;                  # current tree level
    my @this_level = %breeding_tree;    # array of ( poke_id, hashref, ... ) on this level

    ### build the breeding-chain tree
    # What we need is a tree of ancestors that can learn the move and pass it
    # down; it should look something like this:
    # pokemon => {
    #     a => {
    #         b => {},
    #         c => {},
    #         d => {
    #             e => {},
    #         },
    #     },
    #     f => {
    #         g => {},
    #         d => [ref to former d],
    #     },
    # }
    # The rules are basically that:
    # 1. Every Pokemon is a key in a hash
    # 2. Each corresponding value is a similar hash, containing a list of
    #    Pokemon that are compatible
    # 3. No infinite looping!

    do {
        $cur_level++;
        my %branches;

        while (my $pokemon_id = shift @this_level) {
            my $this_poke = $pokemon{$pokemon_id};
            my $hashref = shift @this_level;

            for my $pokemon_id (keys %pokemon) {
                next if not $this_poke->can_breed_with( $pokemon{$pokemon_id} );

                if (exists $seen{ $pokemon_id }) {
                    # don't put anything if this Pokemon has been seen higher
                    # in the chain; needless descending is bad
                    $hashref->{ $pokemon_id } = undef
                        unless $seen{ $pokemon_id } < $cur_level;
                } else {
                    $hashref->{$pokemon_id} = ( $branches{$pokemon_id} ||= {} );
                    $seen{$pokemon_id} = $cur_level;
                }
            }
        }

        @this_level = %branches;
    } while ($cur_level < 10 and @this_level);

    ### find the optimal path
    
    # since there should only be a small finite number of Pokemon, we can just
    # iterate over every possibility; flatten into arrays, and take whichever
    # is shortest

    # TODO: merge this with the actual building of the tree, and toss useless
    # branches as we go; right now this sub MODIFIES THE TREE, pruning any
    # branches it finds that don't end with a level; this makes the dupe
    # removal up top a little silly!
    my $flattener; $flattener = sub {
        my ($branch) = @_;
        my @subchains;

        for my $key (keys %$branch) {
            if (grep /level/i, @{ $learn_methods{$key} }) {
                # consider this Pokemon an endpoint if it learns the move
                # naturally; TMs don't count since they are of limited quantity
                push @subchains, [ $key ];
                $branch->{$key} &&= {};
                next;
            }

            # ...otherwise, only add more chains if this branch has any valid
            # subchains of its own
            my @child_chains = $flattener->( $branch->{$key} );
            if (@child_chains) {
                push @subchains, map [ $key, @$_ ], @child_chains;
            } else {
                delete $branch->{$key};
            }
        }

        return @subchains;
    };

    # only take the shortest chains; it's possible there could be several!
    my @flat_chains  = sort { $#$a <=> $#$b } $flattener->( \%breeding_tree );
    my @optimal_path = grep { $#$_ == $#{ $flat_chains[0] } } @flat_chains;
    @$_ = reverse @$_ for @optimal_path;
    
    ### cram everything important into the stash
    $s->{breeding_tree} = \%breeding_tree;
    $s->{pokemon}       = \%pokemon;
    $s->{learn_methods} = \%learn_methods;
    $s->{optimal}       = \@optimal_path;

    $s->{template} = 'dex/utils/backtrace.tt';
    
#    $c->res->body(join "<br/>", map { qq'<a href="/dex/pokemon/$PokemonNames[$_]">$PokemonNames[$_]</a>' } @other_learners);
    
#    TODO:
#        ! CHECK to make sure this is a move that the Pokemon can learn via egg *or* TM
#        - female is obvious and is the species of the target child
#        - for previous generations, just look for a Pokemon that only learns via breeding
#            - I suggest removing the breed requirement and doing that with perl code so you can reuse the data
#            - do not bother with anything elses!
#        - also: later look for entire families that match and combine them somehow?  ugh that will be a pain in the ass
#        - GENDERLESS!  they must be dealt with entirely separately
#        - use gender distro, steps, and other stats to figure out optimal chain?
#        
#        - db: merge the egg moves that need it, not sure why that hasn't happened
#            MYSTERY SOLVED: d/p data used babies as bases, I use the first evo as the base.  have to go through babies and fix this  :(
#        - start on my own visual refresh?  use some stock background to try for now I dunno
#        ! don't slurp @other_learners
#        - make a /dex/pokemon/eevee/backtrace that lists all traceable moves?

}

=head2 damage

Calculates damage.

=cut

sub damage : Path('calculators/damage') : Form('dex/damage') : Args(0) {
    my ($self, $c) = @_;
    my $s = $c->stash;
    
    if (%{$c->req->params} and $c->form->validate) {
        my $attack  = $c->req->params->{attack};
        my $defense = $c->req->params->{defense};
        my $power   = $c->req->params->{power};
        my $level   = $c->req->params->{level};
        
        my $damage = int(int( (2 + int($level * 0.4)) * $attack * $power / $defense ) / 50) + 2;
        $damage = 999 if $damage > 999;
        
        my $random = int rand 39;
        
        $s->{damage}     = $damage;
        $s->{min_damage} = int($damage * (217 + $random) / 255);
    }

    $s->{page_title} = 'Damage Calculator';
    $s->{extra_css}  = 'dex';
    $s->{template}   = 'dex/utils/damage.tt';
    
#    $c->res->body("Max damage: $damage <br/> Min damage: " . int($damage * ($random + 217) / 255));
}

=head2 iv

Calculates IVs.

=cut

my $iv_fields = {
    pokemon => { type => 'text', class => 'js-dexsuggest js-dexsuggest-pokemon' },
    level   => { type => 'text' },
    nature  => { type => 'select', options => [ ['ignore' => 'Ignore'], map [ $_ => ucfirst $_ ], sort keys %Natures ], },
};

for my $s (0 .. $#StatColumns) {
    my $stat = $StatColumns[$s];
    $iv_fields->{ $stat }         = { type => 'text', maxlength => 3, tabindex => $s + 1, title => "Enter your Pokemon's calculated stat.", };
    $iv_fields->{ $stat . '_ev' } = { type => 'text', maxlength => 3, tabindex => $s + @StatColumns + 1, title => "Enter your Pokemon's effort value; this is 0 if it was just caught.", };
}


sub iv : Path('calculators/iv') : Args(0) {
    my ($self, $c) = @_;
    my $s = $c->stash;
    my $p = $c->req->params;

    my $form = $s->{form} = Vee::Form->new(
        id => 'stat_calculator',
        fields => $iv_fields,
        params => $c->req->params,
    );

    $s->{page_title} = 'IV/Stat Calculator';
    $s->{extra_css}  = 'dex';
    $s->{template}   = 'dex/utils/iv.tt';

    if ($form->submitted) {
        # TODO: hide this nonsense in Vee::Form?
        my @errors;
        my $pokemon = $c->model('DBIC::Pokemon')->find( get_pokemon($p->{pokemon}) );

        push @errors, "Invalid Pok&eacute;mon entered." if not $pokemon;
        push @errors, "Invalid level entered." if $p->{level} !~ /^(?: [1-9] | \d\d | 100 )$/x;
        if (@errors) {
            $s->{error_msg} = \@errors;
            return;
        }

        # ok done with that validation nonsense
            
        my (@ivs, @iv_ranges, @possible_stats);
        my @nature_change = (1) x 6;
        my $nature_updown = $Natures{ $p->{nature} };
        if (defined $nature_updown) {
            $nature_change[ $nature_updown->{up}   ] = 1.1;
            $nature_change[ $nature_updown->{down} ] = 0.9;
        }

        my $all_exact = 1;
        for my $s (0 .. $#StatColumns) {
            my $stat = $StatColumns[$s];
            my $effort = $p->{ $stat . '_ev' } || 0;
            my $base = $pokemon->$stat;
            my $func = ($stat =~ /hp/) ? \&ingame_hp : \&ingame_stats;

            # possible IVs; doing this inversely is very difficult due to rounding
            for my $iv (0 .. 31) {
                my $calculated = $func->($base, $p->{level}, $iv, $effort);
                $calculated = int( $calculated * $nature_change[$s] );
                $ivs[$s][$iv] = ($calculated == $p->{$stat});
            }

            # IV range in more readable text
            $iv_ranges[$s]{min} = first_index { $_ } @{ $ivs[$s] };
            $iv_ranges[$s]{max} =  last_index { $_ } @{ $ivs[$s] };
            $all_exact = 0
                if $iv_ranges[$s]{min} != $iv_ranges[$s]{max}
                or $iv_ranges[$s]{min} == -1;

            # entire range of possible stats for this Pokemon
            $possible_stats[$s] =
                int( $nature_change[$s] * $func->($base, $p->{level}, 0,  $effort) ) . ' - ' .
                int( $nature_change[$s] * $func->($base, $p->{level}, 31, $effort) );
        }
        $s->{ivs}            = \@ivs;
        $s->{iv_ranges}      = \@iv_ranges;
        $s->{possible_stats} = \@possible_stats;

        # TODO: improve this a bit since even at L100 you rarely get perfect results
        if ($all_exact) {
            $s->{hp_power} = ingame_hp_power( map { $_->{min} } @iv_ranges );
            $s->{hp_type}  = ingame_hp_type ( map { $_->{min} } @iv_ranges );
        }

        $s->{nature}         = $p->{nature};
        $s->{pokemon}        = $pokemon;
    }
}

=head1 AUTHOR

Maintainer: Alex "Eevee" Munroe (C<veekun@veekun.com>)

See the included F<AUTHORS> file for a full list of contributers.

=head1 LICENSE

See the included F<LICENSE> file.

=cut

1;