root/veekun/trunk/lib/Vee/Controller/Dex.pm

Revision 474, 45.6 KB (checked in by eevee, 12 months ago)

Fixed a handful of warnings.
Line 
1package Vee::Controller::Dex;
2
3use strict;
4use warnings;
5use base 'Catalyst::Controller';
6
7use Vee::Dex;
8use String::Approx 'adist';
9use JSON;
10use Scalar::Util qw/weaken/;
11use List::Util qw/first min max sum/;
12use List::MoreUtils qw/uniq/;
13use Storable qw/dclone/;
14use Data::Dumper;
15
16# TODO: move this somewhere shared
17my $MAX_WILDCARD_RESULTS = 10;  # maximum wildcard matches per category
18my $MAX_LEARNERS = 50;  # maximum learners per method on a move page
19
20=head1 NAME
21
22Vee::Controller::Dex - Pokedex Controller
23
24=head1 SYNOPSIS
25
26See L<Vee>
27
28=head1 DESCRIPTION
29
30Catalyst Controller for Pokedex lookup, pages, and listings.
31
32=cut
33
34=head1 METHODS
35
36=cut
37
38=head2 auto
39
40Injects the hash of useful Pokedex variables into the stash for TT use.
41
42=cut
43
44sub auto : Private {
45    my ($self, $c) = @_;
46    my $s = $c->stash;
47   
48    $s->{extra_css} = ['dex'];
49    $s->{nav}{help} = $c->uri_for('/dex');
50
51    # TODO: kinda hacky!  move this elsewhere, where it won't leak?
52    weaken $c;
53    $s->{dex_uri} = sub { $_[1] = lc $_[1] unless ref $_[1]; $c->uri('Dex', @_) };
54
55    $c->stash( %Vee::Dex::all );
56
57    return 1;
58}
59
60=head2 lookup
61
62=cut
63
64sub lookup_path : Path('lookup') : Args(1) {
65    my ($self, $c) = @_;
66    $c->detach('lookup');
67}
68
69sub lookup : Path : Args(0) {
70    my ($self, $c) = @_;
71
72    my $entry;
73    if ($c->req->args->[0]) {
74        # /dex/Eevee
75        $entry = $c->req->args->[0];
76    } elsif (exists $c->req->params->{entry}) {
77        # /dex?entry=Eevee
78        $entry = $c->req->params->{entry};
79    } elsif (scalar (keys %{$c->req->query_parameters}) == 0 && $ENV{QUERY_STRING}) {
80        # /dex?Eevee
81        # TODO: not sure I even like this; possibly remove it (or do a redirect) since path works
82        $entry = $ENV{QUERY_STRING};
83    }
84
85    # if this was reached by just /dex, then skip to the static code
86    if (not defined $entry) {
87        $c->detach(
88            '/default',
89            [ $self->action_namespace($c), @{ $c->req->args } ]
90        );
91    # ...or berate the user
92    } elsif (not $entry) {
93        $c->vee_abort('Please enter a Pok&eacute;mon, move, type, etc to look up.');
94    }
95
96    # easter egg
97    if ($entry =~ /^annon (.+)$/) { $c->detach('egg_annon', [ $1, 'icons' ]) }
98    if ($entry =~ /^ANNON (.+)$/) { $c->detach('egg_annon', [ $1, 'dp' ]) }
99
100    # branch if wildcards detected
101    if ($entry =~ /[?*]/) {
102        $c->detach('lookup_wildcard', [ $entry ]);
103    }
104
105    # some special possibilities
106    if    ($entry =~ /^tm ?(\d{1,2})$/i) { $c->res->redirect( $c->uri('Dex', 'tms', $1      ) ); return }
107    elsif ($entry =~ /^hm ?(\d{1,2})$/i) { $c->res->redirect( $c->uri('Dex', 'tms', $1 + 100) ); return }
108    elsif ($entry =~ /^random(?: (pokemon|move|type))?$/i) {
109        my $type = $1 || 'pokemon';
110        my $url = $c->uri('Dex', plural($type), 'random');
111        $url .= '/' . $c->session->{last_pokemon_view}
112            if $type eq 'pokemon'
113            and $c->session->{last_pokemon_view};
114        $c->res->redirect($url);
115        return;
116    }
117
118    # the usual suspects
119    # we have this giant hash of possible fuzzy matches lying around, so why not use it?
120    my $fuzzy_value = $FuzzyMatches{ lc $entry };
121    if ($fuzzy_value) {
122        my $url = $c->uri('Dex', plural($fuzzy_value->{type}), lc $fuzzy_value->{name});
123        $url .= '/' . $c->session->{last_pokemon_view}
124            if $fuzzy_value->{type} eq 'pokemon'
125            and $c->session->{last_pokemon_view};
126        $c->res->redirect($url);
127        return;
128    }
129
130    # if that didn't work, use the accessor functions...
131    my $result;
132    for my $class (qw/pokemon move type/) {
133        no strict 'refs';
134        $result = &{"get_$class"}($entry);
135        use strict 'refs';
136        next unless $result;
137
138        if (ref $result eq 'SCALAR') {
139            $c->vee_abort('"', $entry, qq'" is an invalid query.  $$result');
140        }
141
142        my ($name, $suffix);
143        if ($class eq 'pokemon') {
144            $name = lc $PokemonNames[$result];
145            $suffix = '/' . $c->session->{last_pokemon_view} if $c->session->{last_pokemon_view};
146        } elsif ($class eq 'move') {
147            $name = lc $MoveData[$result]->name;
148        } else {
149            $name = $result;
150        }
151
152        $c->res->redirect( $c->uri('Dex', plural($class), $name) . $suffix );
153        return;
154    }
155   
156    # STILL nothing
157    if (!$result) {
158        $c->detach('lookup_fuzzy', [ $entry ]);
159    }
160   
161}
162
163=head2 lookup_wildcard
164
165Searches through names using wildcards.
166
167=cut
168
169sub lookup_wildcard : Private {
170    my ($self, $c, $entry) = @_;
171    my $s = $c->stash;
172   
173    $s->{page_title} = 'Wildcard Lookup';
174    $s->{crumbs}     = [ '<a href="' . $c->uri('Dex') . '">Pok&eacute;dex</a>', 'Wildcard Lookup' ];
175   
176    (my $test = $entry) =~ s/[^-_ 0-9a-zA-Z]//g;
177    if (2 > length $test) {
178        $c->vee_abort('Your entry ', $entry, ' is too vague.  Please try to tone down the use of wildcards.');
179        die;
180    }
181   
182    my $orig = $entry;
183
184    # cleanse all special characters and change ?/* to regex notation
185    $entry =~ s/([^-_ 0-9a-zA-Z])/\\$1/g;
186    $entry =~ s/\\\?/./g;
187    $entry =~ s/\\\*/.*/g;
188
189    my $re = qr/^$entry$/i;
190    my (%results, %overflow);
191   
192    # Arrange the results by type
193    my @keys = grep { $_ =~ $re } keys %FuzzyMatches;
194    for my $key (@keys) {
195        my $type  = $FuzzyMatches{$key}{type};
196        my $array = ($results{$type} ||= []);
197
198        push @$array, $FuzzyMatches{$key};
199    }
200
201    # Sort by name, for lack of anything particularly better
202    for my $type (keys %results) {
203        my $array = $results{$type};
204        @$array = sort {
205            $a->{name} cmp $b->{name}
206        } @$array;
207
208        # Don't go crazy listing matches
209        if (@$array > $MAX_WILDCARD_RESULTS) {
210            @$array = @$array[ 0 .. $MAX_WILDCARD_RESULTS - 1 ];
211            $overflow{$type} = 1;
212        }
213    }
214
215    my $total = @keys;
216    $c->vee_stop('No match for ', $orig, ' was found.  You may wish to try the <a href="' . $c->uri('Dex', 'pokemon_list') . '">Pok&eacute;mon list</a>, <a href="' . $c->uri('Dex', 'move_list') . '">move list</a>, <a href="' . $c->uri('Dex', 'type_list') . '">type list</a>, etc. to find what you are looking for.') unless $total;
217   
218    $s->{entry}    = $orig;
219    $s->{results}  = \%results;
220    $s->{overflow} = \%overflow;
221    $s->{template} = 'dex/lookup/wildcard.tt';
222}
223
224=head2 lookup_fuzzy
225
226Fuzzy search for when all else fails.
227
228=cut
229
230sub lookup_fuzzy : Private {
231    my ($self, $c, $entry) = @_;
232    my $s = $c->stash;
233   
234    $s->{page_title} = 'Fuzzy Lookup';
235   
236    if (4 > length $entry) {
237        $c->vee_stop('There is nothing in the database with a name of ', $entry, ', and fuzzy lookup can only be done with between four and twenty-four characters.');
238    }
239   
240    my @results = get_fuzzy($entry);
241
242    if (!@results) {
243        $c->vee_stop('No match for ', $entry, ' was found.  You may wish to try the <a href="' . $c->uri('Dex', 'pokemon_list') . '">Pok&eacute;mon list</a>, <a href="' . $c->uri('Dex', 'move_list') . '">move list</a>, or <a href="' . $c->uri('Dex', 'type_list') . '">type list</a> to find what you are looking for.');
244    }
245
246    # check to see if we only got one real result, regardless of how many languages it's in
247    my @uniques = uniq map { join "\n", @$_{qw/ type id /} } @results;
248    if (@uniques == 1) {
249        $c->flash->{info_msg} = 'You entered ' . $c->vee_cleanse($entry) . ", but there is no page with that name.  This page is the only close match.";
250        $c->res->redirect( $c->uri('Dex', plural( $results[0]{type} ), lc $results[0]{name}) );
251        return;
252    }
253
254    @results = @results[0 .. 19] if @results > 20;
255
256    $s->{entry} = $c->vee_cleanse($entry);
257    $s->{results} = \@results;
258    $s->{template} = 'dex/lookup/fuzzy.tt';
259}
260
261################################################################################
262
263=head2 ability_list
264
265=cut
266
267sub ability_list : Path('abilities') : Args(0) {
268    my ($self, $c) = @_;
269    my $s = $c->stash;
270   
271    $s->{page_title} = 'Ability List';
272    $s->{crumbs}     = [ '<a href="' . $c->uri('Dex') . '">Pok&eacute;dex</a>', 'Abilities' ];
273
274    $s->{template} = 'dex/list/abilities.tt';
275    $c->forward('/cache');
276
277    $s->{abilities_rs} = $c->model('DBIC::Abilities')->search({
278        'me.id' => { '<' => 200 },
279    }, {
280        order_by  => 'me.id ASC',
281        group_by  => 'me.id',
282        join      => 'pokemon_abilities',
283        '+select' => 'COUNT(DISTINCT pokemon_abilities.pokemon_id)',
284        '+as'     => 'pokemon_count',
285    });
286}
287
288=head2 abilities
289
290=cut
291
292sub abilities : Local : Args(1) {
293    my ($self, $c, $abil_name) = @_;
294    my $s = $c->stash;
295
296    my $row = $c->model('DBIC::Abilities')->find({ name => $abil_name })
297        or $c->vee_abort('No such ability ', $abil_name, '.');
298   
299    $s->{page_title} = $row->name . ' - Ability #' . $row->id;
300    $s->{crumbs}     = [
301        '<a href="' . $c->uri('Dex') . '">Pok&eacute;dex</a>',
302        '<a href="' . $c->uri('Dex', 'ability_list') . '">Abilities</a>',
303        $row->name,
304    ];
305
306    add_rel_links( $c,
307        ($row->id - 2) % $#AbilityNames + 1,
308        ($row->id + 0) % $#AbilityNames + 1,
309        sub { {
310            id    => $_[0],
311            title => $AbilityNames[ $_[0] ],
312            url   => $c->uri('Dex', 'abilities', lc $AbilityNames[ $_[0] ]),
313        } }
314    );
315
316    $s->{template} = 'dex/page/ability.tt';
317#    $c->forward('/cache'); -- TODO: necessary?
318
319    $s->{this}       = $row;
320    $s->{generation} = $row->id <= 76 ? 2 : 3;  # TODO: better
321
322    $s->{pokemon}    = [
323        $row->pokemon(undef, { distinct => 1, order_by => 'name' })
324    ];
325}
326
327################################################################################
328
329=head2 tm_list
330
331=cut
332
333sub tm_list : Path('tms') : Args(0) {
334    my ($self, $c) = @_;
335   
336    $c->stash->{page_title} = 'TM List';
337    $c->stash->{crumbs}     = [ '<a href="' . $c->uri('Dex') . '">Pok&eacute;dex</a>', 'TMs' ];
338
339    $c->stash->{template}   = 'dex/list/tms.tt';
340    $c->forward('/cache', [ $c->req->params->{gen} ]);
341}
342
343=head2 tms
344
345=cut
346
347sub tms : Local : Args(1) {
348    my ($self, $c) = @_;
349    my $s = $c->stash;
350
351    my $id = $c->req->args->[0];
352    my @tms = $c->model('DBIC::Machines')->search({ id => $id });
353   
354    # check to see if there is only one move, ever, that corresponds to this TM
355    my %set = map { $_->move_id => 1 } @tms;
356
357    if (!@tms) {
358        $c->vee_abort('There is no TM with a number of ', $id, '.  If you were looking for an HM, they have 100 added to the numbers.');
359    } elsif (1 == scalar keys %set) {
360        # TODO: remove this?
361        $c->res->redirect( $c->uri('Dex', 'moves', lc $MoveData[ $tms[0]->move_id ]->name) );
362    }
363
364    $s->{page_title} = tm_name($id);
365    $s->{crumbs}     = [
366        '<a href="' . $c->uri('Dex') . '">Pok&eacute;dex</a>',
367        '<a href="' . $c->uri('Dex', 'tm_list') . '">TMs</a>',
368        tm_name($id),
369    ];
370
371    $s->{tm_id} = $id;
372    $s->{tms} = \@tms;
373
374    $s->{template} = 'dex/page/tm.tt';
375}
376
377################################################################################
378
379=head2 pokemon_list
380
381=cut
382
383my @pokemon_lists = ( 0 .. $#Generations, qw/ national johto hoenn sinnoh / );
384
385sub pokemon_list : Path('pokemon') : Args(0) {
386    my ($self, $c) = @_;
387    my $s = $c->stash;
388   
389    my $gen = $c->req->params->{gen};
390    if (not defined $gen or not Vee::Utils::in($gen => @pokemon_lists)) {
391        $gen = $#Generations;
392    }
393    $s->{gen} = $gen;
394
395    $s->{page_title} = 'Pok&eacute;mon List';
396    $s->{crumbs}     = [ '<a href="' . $c->uri('Dex') . '">Pok&eacute;dex</a>', 'Pok&eacute;mon' ];
397
398    $s->{template} = 'dex/list/pokemon.tt';
399    $c->forward('/cache', [ $gen ]);
400
401    my (%query, @extra_order, %search_params);
402    if (Vee::Utils::isnum($gen)) {
403        %query = (
404            'pokemon.id' => {
405                -between => [
406                    ($gen ? $Generations[$gen - 1]{maxid} : 0) + 1,
407                    $Generations[$gen]{maxid}
408                ]
409            },
410        );
411        $s->{dim} = sub {
412            $gen != ( grep { $Generations[$_]{maxid} >= $_[0]->id } 0 .. $#Generations )[0]
413        };
414        %search_params = ( generation => $gen );
415    } elsif ($gen eq 'national') {
416        # no limiting, nothing dimmed
417        $s->{dim} = sub { 0 };
418
419        # teensy hack to force a search for everything
420        %search_params = ( sort => 'id' );
421    } else {
422        # belongs in this dex iff it has a number for this gen
423        my $col = "id_$gen";
424        %query  = (
425            "pokemon.$col" => { '!=', 0 },
426        );
427        $s->{dim} = sub {
428            not $_[0]->$col
429        };
430
431        # sort by the base's regional id first, which will get them in the right
432        # chain order for this region, and then let the normal id sorting sort
433        # them within each chain
434        @extra_order = "MIN(pokemon.$col) ASC";
435
436        # grab the gen number from @Generations
437        %search_params = (
438            basedex => grep {
439                $gen eq lc $Generations[$_]{region}
440            } 1 .. $#Generations
441        );
442
443        $s->{region_column} = $col;
444    }
445
446    $s->{search_params} = \%search_params;
447
448    # in this query:
449    #   'pokemon' is a *join* that lists Pokemon from the selected generation
450    #   'me' is the table we are selecting from, listing Pokemon related to any from 'pokemon'
451    $s->{pokemon_rs} = $c->model('DBIC::Pokemon')->search({
452        'me.id'      => { '<=', $Generations[-1]{maxid} },
453        %query,
454    }, {
455        join     => { evo_chain => 'pokemon' },
456        prefetch => { pokemon_abilities => 'ability' },
457        group_by => [ 'me.id', 'pokemon_abilities.ability_id' ],
458        order_by => [ @extra_order, "pokemon.id ASC", "FIND_IN_SET('baby', me.flags) DESC", 'me.id ASC' ],
459    });
460}
461
462=head2 pokemon
463
464=cut
465
466# order of games; only used in move table really, otherwise it would be in Vee::Dex
467my %column_order;
468{
469    my $i = -1;
470    %column_order = map { $i++; $_ => $i } qw/rb y gs c rusa frlg dp pt/;
471}
472
473sub pokemon : Local : Args(1) {
474    my ($self, $c) = @_;
475    my $s = $c->stash;
476
477    # TODO: hm this kinda blows; give up on get_row imo
478    my $row = get_row($c, 'Pokemon', undef, $c->req->params->{alt_form});
479    # TODO: log these in case the links are my fault
480    $c->vee_abort('There is no such Pok&eacute;mon ', $c->req->args->[0], '.  If you are messing with my URLs, please stop.  If you came here via a link, please inform its owner that it is invalid.') unless $row;
481
482    delete $c->session->{last_pokemon_view};
483
484    $s->{page_title}  = $row->name . ' - Pok&eacute;mon #' . $row->real_pokemon_id;
485    $s->{page_header} = $row->name;
486    $s->{extra_js}    = ['dexutils'];
487    $s->{link_name}   = 'dex';
488    $s->{crumbs}      = [
489        '<a href="' . $c->uri('Dex') . '">Pok&eacute;dex</a>',
490        '<a href="' . $c->uri('Dex', 'pokemon_list') . '">Pok&eacute;mon</a>',
491        $row->name,
492    ];
493
494    add_rel_links( $c,
495        ($row->real_pokemon_id - 2) % $Generations[-1]{maxid} + 1,
496        ($row->real_pokemon_id + 0) % $Generations[-1]{maxid} + 1,
497        sub { {
498            id    => $_[0],
499            title => $PokemonNames[ $_[0] ],
500            url   => $c->uri('Dex', 'pokemon', lc $PokemonNames[ $_[0] ]),
501        } }
502    );
503
504    $s->{template} = 'dex/page/pokemon.tt';
505    $c->forward('/cache', [ $row->id ]);
506
507    $s->{this}       = $row;
508    $s->{pid}        = Vee::Utils::pad($row->id, 3);
509    $s->{generation} = my $generation = ( grep { $Generations[$_]{maxid} >= $row->real_pokemon_id } 0 .. $#Generations )[0];
510
511    # alt forms
512    if ($row->alt_form) {
513        my @alts;
514        my $alt_rs = $c->model('DBIC::Pokemon')->search({
515            real_pokemon_id  => $row->real_pokemon_id,
516        }, {
517            columns  => ['alt_form'],
518            order_by => 'id',
519        });
520        while (my $alt_row = $alt_rs->next) {
521            push @alts, $alt_row->alt_form;
522        }
523        $s->{alternate_forms} = \@alts;
524    }
525       
526    # evolution chain
527    my @family = $row->evo_chain->pokemon( \'id = real_pokemon_id', { columns => [qw/id evo_parent_id evo_method evo_param/] } );
528    my %evtrees;
529    $evtrees{$_->id} = { id => $_->id, parent => $_->evo_parent_id, method => $_->evo_method, param => $_->evo_param, children => [] } for @family;
530    push @{ $evtrees{ $_->{parent} }{children} }, $_ for sort { $a->{id} <=> $b->{id} } grep { $_->{parent} } values %evtrees;
531    for my $node (values %evtrees) { add_evolution_desc($node, $row->evo_chain) }
532    $s->{evtree} = ( grep { !$_->{parent} } values %evtrees )[0];  # should only be one with no parent: the root
533    calculate_tree_width($s->{evtree});
534
535    # type effectiveness
536    $s->{type_effects} = { map { $_ => type_effect($_, $row->type1, $row->type2) } @TypeNames };
537
538    # statistics
539    calculate_stats($c, $row);
540   
541    # breeding
542    my $compat_rs = $c->model('DBIC::Pokemon')->search({
543        'breeds.breed' => [ map { $_->breed } $row->breeds ], 
544    }, {
545        join     => 'breeds',
546    });
547    $s->{compatibility}{all}  = $compat_rs->count;
548    # TODO: this is actually wrong; fix when bug #88 is fixed please
549    $s->{compatibility}{base} = $compat_rs->search({ evo_parent_id => 0 })->count;
550
551    # held items
552    $s->{held_items} = [ $row->pokemon_items(undef, { order_by => 'rarity DESC', prefetch => 'item' }) ];
553
554    # wee bit of flavor text
555    $s->{flavors} = {
556        map { $_->generation => $_->text } $row->flavors
557    };
558
559    my %new_encounters;
560    my @new_encounters = $row->sane_encounters;
561    $s->{new_encounters} = \@new_encounters;
562
563    # moves from here down
564    # slurp everything this Pokemon can learn, complete with egg moves if necessary
565    my $moves_rs = $c->model('DBIC::PokemonMoves')->search( {
566        pokemon_id => $row->id,
567    } );
568   
569    my %moves = (
570        level => [],
571        egg => [],
572        tutor => [],
573        machine => [],
574        other => [],
575    );
576    while (my $move_row = $moves_rs->next) {
577        my $table_row = {
578            move_id => $move_row->move_id,
579            level => $move_row->level,
580            versions => { map { $_ => $move_row->level || 1 } split /,/, $move_row->versions },
581        };
582
583        my $method = $move_row->method;
584        if (!Vee::Utils::in($method, qw/level egg tutor machine/)) {
585            $table_row->{method} = $method;
586            $method = 'other';
587        }
588
589        push @{ $moves{$method} }, $table_row;
590    }
591   
592    # sorting go!
593    @{ $moves{$_} } = sort {
594        $a->{level} <=> $b->{level} or
595        $MoveData[ $a->{move_id} ]->name cmp $MoveData[ $b->{move_id} ]->name
596    } @{ $moves{$_} } for qw/ level egg machine /;
597   
598    # column reduction
599    my %move_columns = ( );
600   
601    my @column_pairs = ( [qw/rb y/], [qw/gs c/], [qw/rusa frlg/], [qw/dp pt/] );
602    my @column_deletions = (1) x @column_pairs;
603   
604    for my $move (@{ $moves{level} }, @{ $moves{egg} }, @{ $moves{machine} }) {
605        for my $p (0 .. $#column_pairs) {
606            $column_deletions[$p] = 0 if ($move->{versions}{ $column_pairs[$p][0] } || 0) != ($move->{versions}{ $column_pairs[$p][1] } || 0);
607        }
608    }
609    for my $p (0 .. $#column_pairs) {
610        next unless $generation <= $p;
611        $move_columns{ $column_pairs[$p][0] } = 1;
612        $move_columns{ $column_pairs[$p][1] } = 1 unless $column_deletions[$p];
613    }
614       
615    $s->{move_columns} = [ sort { $column_order{$a} <=> $column_order{$b} } keys %move_columns ];
616    $s->{move_columns_inv} = \%move_columns;
617
618    # The following mess is the code to compact the level move display as much
619    # as humanly possible.  This is the third incarnation of the code, and it
620    # is the most efficient, well-written, and well-documented version so far.
621    # I am quite pleased with it.  Enjoy.
622
623    # This is for slight ease of typing, as well as reading with coloring.
624    my $lev_moves = $moves{level};
625
626    # Continue to run through the list as long as we are still doing something.
627    # There should be no possible way that this creates an infinite loop.
628    my $merges;
629    do {
630        $merges = 0;
631        my $i = -1;
632        while (++$i <= $#$lev_moves) {  # shouldn't use a for since the size of the array changes
633            # find the next row index with the same move id
634            my $next_idx = first { $lev_moves->[$_]{move_id} == $lev_moves->[$i]{move_id} } $i + 1 .. $#$lev_moves;
635            next if not defined $next_idx;
636
637            # make the following mess easier to read/write
638            my $this = $lev_moves->[$i];
639            my $next = $lev_moves->[$next_idx];
640
641            # Ensure there are no level-up moves between these two that have the
642            # same version, as that would wreck the ordering.
643            # Note that there need to be TWO checks; one going in each direction.
644            # For example:
645            #   1 - Tail Whip
646            #   2 - Bubble
647            #   - 3 Tail Whip
648            # It is illegal to move the first Tail Whip forwards, but the last one
649            # can be moved backwards with no problems.
650            my ($forward_ok, $backward_ok) = (1, 1);
651            my %versions = map { $_ => 1 } keys(%{ $this->{versions} }), keys(%{ $next->{versions} });
652            for my $version (keys %versions) {
653                for my $mid_idx ($i + 1 .. $next_idx - 1) {
654                    next if not defined $lev_moves->[$mid_idx]{versions}{$version};
655                    $forward_ok  = 0 if defined $this->{versions}{$version} &&
656                        $lev_moves->[$mid_idx]{versions}{$version} > $this->{versions}{$version};
657
658                    $backward_ok = 0 if defined $next->{versions}{$version} &&
659                        $lev_moves->[$mid_idx]{versions}{$version} < $next->{versions}{$version};
660                }
661            }
662            next if not $forward_ok and not $backward_ok;
663
664            # merge one row into the other, forward by default (this is arbitrary)
665            my ($from, $into, $from_idx) = $forward_ok ? ($this, $next, $i) : ($next, $this, $next_idx);
666            for my $version (keys %{ $from->{versions} }) {
667                next if exists $into->{versions}{$version};
668                $into->{versions}{$version} = $from->{versions}{$version};
669                delete $from->{versions}{$version};
670                $merges++;
671            }
672            if (scalar keys %{ $from->{versions} } == 0) { 
673                # only move id left, so delete this row and redo to hit the next one
674                splice @$lev_moves, $from_idx, 1;
675                redo;
676            }
677        }
678    } while ($merges);
679
680    $s->{moves} = \%moves;
681}
682
683sub pokemon_chain : Chained('/') : PathPart('dex/pokemon') : CaptureArgs(1) {;}
684
685=head2 flavor
686
687=cut
688
689sub flavor : Chained('pokemon_chain') : Args(0) {
690    my ($self, $c) = @_;
691    my $s = $c->stash;
692   
693    my $poke = $c->req->captures->[0];
694
695    my $row = get_row($c, 'Pokemon', $poke);
696    $c->vee_abort('There is no such Pok&eacute;mon ', $poke, '.  If you are messing with my URLs, please stop.  If you came here via a link, please inform its owner that it is invalid.') unless $row;
697
698    $c->session->{last_pokemon_view} = 'flavor';
699
700    $s->{this} = $row;
701    $s->{flavors} = {
702        map { $_->generation => $_->text } $row->flavors
703    };
704    $s->{generation} = ( grep { $Generations[$_]{maxid} >= $row->real_pokemon_id } 0 .. $#Generations )[0];
705
706    $s->{page_title} = $row->name . ' - Flavor Text and Images';
707    $s->{crumbs}     = [
708        '<a href="' . $c->uri('Dex') . '">Pok&eacute;dex</a>',
709        '<a href="' . $c->uri('Dex', 'pokemon_list') . '">Pok&eacute;mon</a>',
710        '<a href="' . $c->uri('Dex', 'pokemon', lc $row->name) . '">' . $row->name . '</a>',
711        'Flavor Text and Images',
712    ];
713
714    add_rel_links( $c,
715        ($row->id - 2) % $Generations[-1]{maxid} + 1,
716        ($row->id + 0) % $Generations[-1]{maxid} + 1,
717        sub { {
718            id    => $_[0],
719            title => $PokemonNames[ $_[0] ],
720            url   => $c->uri('Dex', 'pokemon', lc $PokemonNames[ $_[0] ]) . '/flavor',
721        } }
722    );
723
724    $s->{template} = 'dex/page/pokemon/flavor.tt';
725}
726
727################################################################################
728
729=head2 move_list
730
731=cut
732
733sub move_list : Path('moves') : Args(0) {
734    my ($self, $c) = @_;
735    my $s = $c->stash;
736
737    $s->{list} = undef;  # everything I need is in @MoveData
738   
739    $s->{page_title } = 'Move List';
740    $s->{crumbs     } = [ '<a href="' . $c->uri('Dex') . '">Pok&eacute;dex</a>', 'Moves' ];
741
742    $s->{template} = 'dex/list/moves.tt';
743}
744
745=head2 moves
746
747=cut
748
749sub moves : Local : Args(1) {
750    my ($self, $c) = @_;
751    my $s = $c->stash;
752
753    my $row = get_row($c, 'Moves');
754    $c->vee_abort('There is no such move ', $c->req->args->[0], '.  If you are messing with my URLs, please stop.  If you came here via a link, please inform its owner that it is invalid.') unless $row;
755
756    $s->{page_title } = $row->name . ' - Move #' . $row->id;
757    $s->{page_header} = $row->name;
758    $s->{link_name  } = 'dex';
759    $s->{crumbs     } = [
760        '<a href="' . $c->uri('Dex') . '">Pok&eacute;dex</a>',
761        '<a href="' . $c->uri('Dex', 'move_list') . '">Moves</a>',
762        $row->name,
763    ];
764
765    add_rel_links( $c,
766        ($row->id - 2) % $#MoveData + 1,
767        ($row->id + 0) % $#MoveData + 1,
768        sub { {
769            id    => $_[0],
770            title => $MoveData[ $_[0] ]->name,
771            url   => $c->uri('Dex', 'moves', lc $MoveData[ $_[0] ]->name),
772        } }
773    );
774
775    $s->{template} = 'dex/page/move.tt';
776    $c->forward('/cache', [ $row->id ]);
777   
778    $s->{this} = $row;
779    $s->{pid} = Vee::Utils::pad($row->id, 3);
780    $s->{generation} = my $generation = ( grep { $Generations[$_]{maxmoveid} >= $row->id } 0 .. $#Generations )[0];
781   
782    $s->{percentile} = defined $row->power
783        ? Vee::Utils::round( $c->model('DBIC::Moves')->count({ power => { '!=' => undef, '<' => $row->power } }) / $DamagingMoveCount * 100, 1 )
784        :'n/a';
785    $s->{tm_info} = { map { $_->generation => $_ } $c->model('DBIC::Machines')->search({ move_id => $row->id }) };
786
787    # status effect
788    my $status = $row->status;
789    if (!$status) {
790        $status = 'none'
791    } else {
792        my @s = split / /, $status;
793        for my $s (@s) {
794            if ($s =~ /^([a-z]+)((?:\+|-|\^)+)$/) {
795                $s = $MoveEffects{$1} . ' ' . $MoveAmounts{$2};
796            } else {
797                $s = $MoveEffects{$s};
798            }
799        }
800        $status = join ', ', @s;
801    }
802    $s->{status} = $status;
803
804    # contest stuffs
805    my $contest_family_rs = $c->model('DBIC::Moves')->search({ contest_effect_id => $row->contest_effect_id, id => { '!=', $row->id } }, { columns => [qw/id name contest_type/], order_by => 'name ASC' });
806    my %contest_family;
807    $s->{contest_family_count} = 0;
808    while (my $move = $contest_family_rs->next) {
809        push @{ $contest_family{ $move->contest_type } }, $move;
810        $s->{contest_family_count}++;
811    }
812    $s->{contest_family} = \%contest_family;
813    $s->{reverse_combos} = [ map { $_->id } $c->model('DBIC::Moves')->search(\( 'FIND_IN_SET(' . $row->id . ', combos)' ), { columns => ['id'], order_by => 'name ASC' }) ];
814
815    # Fetch list of Pokemon
816    my %pokemon_count;
817    my %valid_methods = map { $_ => 1 } qw/level egg tutor machine/;
818    my $pokemoves_rs = $c->model('DBIC::PokemonMoves')->search({ move_id => $row->id });
819    my %pokemon_hash;  # method => pokemon id => version => level
820    while (my $pm = $pokemoves_rs->next) {
821        my $method = 'other';
822        $method = $pm->method if $valid_methods{ $pm->method };
823        my @versions;
824
825        if ($method eq 'other') {
826            # XXX: this will break if there are more other moves than the max
827            @versions = ('all');
828        } else {
829            @versions = split /,/, $pm->versions;
830        }
831
832        for my $ver (@versions) {
833            $pokemon_hash{$method}{$pm->pokemon_id}{pokemon} ||= $pm->pokemon;
834            $pokemon_hash{$method}{$pm->pokemon_id}{$ver} = $pm->level || 1;
835        }
836        $pokemon_count{ $pm->pokemon_id } = 1;
837    }
838
839    my %learners;  # method => [ version => level, pokemon => pokemon ]
840    for my $method (keys %pokemon_hash) {
841        my @sorted_learners = sort {
842            $a->{pokemon}->name cmp $b->{pokemon}->name
843        } values %{ $pokemon_hash{$method} };
844       
845        if ($method ne 'level' and @sorted_learners > $MAX_LEARNERS) {
846            $learners{$method} = {};
847            for my $learner_hash (@sorted_learners) {
848                for my $version (keys %$learner_hash) {
849                    $learners{$method}{$version}++;
850                }
851                $learners{$method}{all}++;
852            }
853        } else {
854            $learners{$method} = \@sorted_learners;
855        }
856    }
857
858    $s->{learners} = \%learners;
859    $s->{pokemon_count} = scalar keys %pokemon_count;
860}
861
862################################################################################
863
864=head2 type_list
865
866=cut
867
868sub type_list : Path('types') : Args(0) {
869    my ($self, $c) = @_;
870    my $s = $c->stash;
871   
872    $s->{list} = undef;  # everything I need is in %TypeData
873
874    $s->{page_title } = 'Type Chart';
875    $s->{crumbs     } = [ '<a href="' . $c->uri('Dex') . '">Pok&eacute;dex</a>', 'Types' ];
876
877    $s->{template} = 'dex/list/types.tt';
878}
879
880=head2 types
881
882=cut
883
884sub types : Local : Args(1) {
885    my ($self, $c) = @_;
886    my $s = $c->{stash};
887
888    my $row = get_row($c, 'Types');
889    $c->vee_abort('There is no such type ', $c->req->args->[0], '.  If you are messing with my URLs, please stop.  If you came here via a link, please inform its owner that it is invalid.')
890        unless $row;
891
892    $s->{page_title}  = ucfirst($row->name) . ' - Type #' . $s->{hid};
893    $s->{page_header} = ucfirst $row->name;
894    $s->{link_name}   = 'dex';
895    $s->{crumbs}      = [
896        '<a href="' . $c->uri('Dex') . '">Pok&eacute;dex</a>',
897        '<a href="' . $c->uri('Dex', 'type_list') . '">Types</a>',
898        $row->name,
899    ];
900   
901    $s->{template} = 'dex/page/type.tt';
902    $c->forward('/cache', [ $row->id ]);
903
904    $s->{hid}         = $row->internal_id + 1;
905    $s->{generation}  = ($row->name eq 'dark' || $row->name eq 'steel') ? 1 : 0;
906
907    $s->{this}       = $row;
908    $s->{moves_rs}   = $c->model('DBIC::Moves')->search({ type => $row->name }, { order_by => 'name ASC', columns => ['id'] });
909    $s->{pokemon_rs} = $c->model('DBIC::Pokemon')->search( {
910        id => { '<=', $Generations[-1]{maxid} },
911        -or => [ type1 => $row->name, type2 => $row->name ],
912    }, {
913        order_by => 'name ASC',
914        columns => [qw/ id name type1 type2 /],
915    } );
916}
917
918################################################################################
919
920=head2 location_list
921
922List of areas.  In D/P.
923
924=cut
925
926sub location_list : Path('locations') : Args(0) {
927    my ($self, $c) = @_;
928    my $s = $c->stash;
929
930    $s->{locations_rs} = $c->model('DBIC::Locations')->search(undef, { order_by => 'name' });
931
932    $s->{template} = 'dex/list/locations.tt';
933
934    $s->{page_title}  = 'Locations List';
935    $s->{breadcrumbs} = [ '<a href="' . $c->uri('Dex') . '">Pok&eacute;dex</a>', 'Locations' ];
936}
937
938=head2 locations
939
940Controller to display information about a location; so far, only D/P, and only
941the wild Pokemon there.
942
943=cut
944
945sub locations : Local : Args(1) {
946    my ($self, $c) = @_;
947    my $s = $c->stash;
948
949    my $row = $c->model('DBIC::Locations')->search({
950        name     => $c->req->args->[0],
951    })->single
952        or $c->vee_abort("No such location ", $c->req->args->[0], ".  I only have D/P so far, sorry!");
953
954    $s->{page_title} = $row->name;
955    $s->{crumbs}     = [
956        'Pok&eacute;dex',
957        '<a href="' . $c->uri('Dex', 'location_list') . '">Locations</a>',
958        $row->name,
959    ];
960
961    $s->{template} = 'dex/page/location.tt';
962    $c->forward('/cache', [ $row->id ]);
963
964    my %encounters;
965
966    my $sections_rs = $row->sections_rs;
967    while (my $section = $sections_rs->next) {
968        my $grouped_pokemon_rs = $section->encounters_rs( {
969            version  => 'diamond',
970        }, {
971            group_by => 'pokemon_id',
972        } );
973
974        while (my $enc_pokemon = $grouped_pokemon_rs->next) {
975            my $encounters_rs = $section->encounters_rs( {
976                version     => 'diamond',
977                pokemon_id  => $enc_pokemon->pokemon->id,
978            } );
979            $encounters_rs->reset;
980
981            push @{ $encounters{$section->name} }, Vee::Dex::EncounterSet->new(
982                $encounters_rs,
983                $enc_pokemon->pokemon,
984            );
985        }
986
987        @{ $encounters{$section->name} } = sort {
988            $a->pokemon->name cmp $b->pokemon->name
989        } @{ $encounters{$section->name} };
990    }
991
992    $s->{this}       = $row;
993    $s->{encounters} = \%encounters;
994}
995
996################################################################################
997
998=head2 item_list
999
1000=cut
1001
1002sub item_list : Path('items') : Args(0) {
1003    my ($self, $c) = @_;
1004    my $s = $c->stash;
1005   
1006    $s->{page_title} = 'Item List';
1007    $s->{crumbs}     = [ '<a href="' . $c->uri('Dex') . '">Pok&eacute;dex</a>', 'Items' ];
1008
1009    $s->{template} = 'dex/list/items.tt';
1010    $c->forward('/cache');
1011
1012    my $items_rs = $c->model('DBIC::Items')->search(undef, {
1013        order_by  => 'me.name',
1014    });
1015
1016    # eh this sucks; TODO cache?
1017    my %item_categories;
1018    while (my $item = $items_rs->next) {
1019        push @{ $item_categories{$item->category} }, $item;
1020    }
1021
1022    $s->{item_categories} = \%item_categories;
1023}
1024
1025=head2 items
1026
1027=cut
1028
1029sub items : Local : Args(1) {
1030    my ($self, $c, $item_name) = @_;
1031    my $s = $c->stash;
1032
1033    my $row = $c->model('DBIC::Items')->find({
1034        name     => $item_name,
1035    }, {
1036        prefetch => { berry => [], pokemon_items => 'pokemon' },
1037    }) or $c->vee_abort('No such item ', $item_name, '.');
1038   
1039    $s->{page_title} = $row->name . ' - Item #' . $row->game_id;
1040    $s->{crumbs}     = [
1041        '<a href="' . $c->uri('Dex') . '">Pok&eacute;dex</a>',
1042        '<a href="' . $c->uri('Dex', 'item_list') . '">Items</a>',
1043        $row->name
1044    ];
1045
1046    add_rel_links( $c,
1047        ($row->id - 2) % $#ItemNames + 1,
1048        ($row->id + 0) % $#ItemNames + 1,
1049        sub { {
1050            id    => $_[0],
1051            title => $ItemNames[ $_[0] ],
1052            url   => $c->uri('Dex', 'items', lc $ItemNames[ $_[0] ]),
1053        } }
1054    );
1055
1056    $s->{template} = 'dex/page/item.tt';
1057#    $c->forward('/cache'); -- TODO: necessary?
1058
1059    $s->{this}       = $row;
1060    $s->{generation} = 3;
1061}
1062
1063=head2 berry_list
1064
1065=cut
1066
1067sub berry_list : Path('berries') : Args(0) {
1068    my ($self, $c) = @_;
1069    my $s = $c->stash;
1070
1071    $s->{berries_rs} = $c->model('DBIC::Berries')->search(undef, { prefetch => 'item' });
1072   
1073    $s->{page_title} = 'Berry List';
1074    $s->{crumbs}     = [
1075        '<a href="' . $c->uri('Dex') . '">Pok&eacute;dex</a>',
1076        '<a href="' . $c->uri('Dex', 'item_list') . '">Items</a>',
1077        'Berries'
1078    ];
1079
1080    $s->{template} = 'dex/list/berries.tt';
1081#    $c->forward('/cache'); -- TODO: necessary?
1082}
1083
1084################################################################################
1085
1086=head2 suggest
1087
1088Controller for Pokedex entry suggestions.
1089
1090=cut
1091
1092sub suggest : Local : Args(0) {
1093    my ($self, $c) = @_;
1094    my $search   = $c->req->params->{search} || '';
1095    my $type     = $c->req->params->{type};
1096    my $extended = $c->req->params->{extended};
1097    my @suggestions = ();
1098
1099    if ($search) {
1100        my $len       = length $search;
1101        my $lc_search = lc $search;
1102
1103        my @keys = grep { $lc_search eq substr $_, 0, $len } keys %FuzzyMatches;
1104
1105        # exclude foreign languages...
1106        # TODO: don't?
1107        @keys = grep { $_ eq lc $FuzzyMatches{$_}{name} } @keys;
1108
1109        if ($type) {
1110            @keys = grep { $FuzzyMatches{$_}{type} eq $type } @keys;
1111        }
1112
1113        @keys = sort @keys;
1114
1115        for my $key (@keys) {
1116            my $fuzzy_row = $FuzzyMatches{$key};
1117
1118            if (not $extended) {
1119                # Dummy mode; just slap the name on the list and go on
1120                push @suggestions, $fuzzy_row->{name};
1121                next;
1122            }
1123
1124            my $row = {
1125                label => $fuzzy_row->{name},
1126            };
1127
1128            if ($fuzzy_row->{type} eq 'pokemon') {
1129                $row->{image} = $c->uri_for( sprintf '/dex-images/icons/%03d.png', $fuzzy_row->{id} );
1130                $row->{bottom_align} = 1;
1131            } elsif ($fuzzy_row->{type} eq 'move') {
1132                $row->{image} = $c->uri_for( sprintf '/dex-images/gameui/%s.png', $MoveData[ $fuzzy_row->{id} ]->type );
1133            } elsif ($fuzzy_row->{type} eq 'type') {
1134                $row->{image} = $c->uri_for( sprintf '/dex-images/gameui/%s.png', $fuzzy_row->{name} );
1135            } elsif ($fuzzy_row->{type} eq 'item') {
1136                my $name = lc $fuzzy_row->{name};
1137                $name =~ tr/ /-/;
1138                $name =~ tr/-a-z0-9//cd;
1139                $row->{image} = $c->uri_for( sprintf '/dex-images/items/%s.png', $name );
1140                $row->{left_4px} = 1;
1141            }
1142
1143            # hack to stringify URIs to make JSON happy
1144            $row->{image} .= '' if $row->{image};
1145
1146            push @suggestions, $row;
1147        }
1148    }
1149   
1150    my $obj = [ $search, \@suggestions ];
1151
1152    $c->res->content_type('application/x-suggestions+json; charset=utf-8');
1153    $c->res->body( to_json($obj) );
1154}
1155
1156################################################################################
1157
1158=head2 egg_annon
1159
1160Annondex easter egg.
1161
1162=cut
1163
1164sub egg_annon : Private {
1165    my ($self, $c, $string, $dir) = @_;
1166    my $s = $c->stash;
1167
1168    $s->{page_title} = 'Ooooeeeeoooo~';
1169
1170    $string = lc $string;
1171    $string =~ tr/a-z!? //cd;
1172    $s->{string}   = $string;
1173    $s->{dir}      = $dir;
1174    $s->{template} = 'dex/eggs/annon.tt';
1175}
1176
1177################################################################################
1178
1179=head2 get_row
1180
1181=cut
1182
1183sub get_row {
1184    my ($c, $table, $id, $alt_form) = @_;
1185    $id ||= $c->req->args->[0];
1186   
1187    my $rs = $c->model('DBIC')->resultset($table);
1188   
1189    my @extra;
1190    # n.b.: can ONLY prefetch one has_many here; DBIx::Class will refuse more due to cross-product effect
1191    if ($table eq 'Pokemon') { @extra = ( prefetch => [qw/evo_chain pokemon_moves/], order_by => 'pokemon_moves.move_id ASC' ) }
1192    elsif ($table eq 'Moves') { @extra = ( prefetch => 'pokemon_moves', order_by => 'pokemon_moves.pokemon_id ASC' ) }
1193   
1194    if ($id eq 'random') {
1195        if ($table eq 'Pokemon') { $id = $PokemonNames[ 1 + rand $#PokemonNames ] }
1196        elsif ($table eq 'Moves') { $id = $MoveData[ 1 + rand $#MoveData ]->name }
1197        elsif ($table eq 'Types') { $id = $TypeNames[ rand @TypeNames ] }
1198    }
1199
1200    $rs = $rs->search({ name => $id }, { @extra });
1201    $rs = $rs->search({ alt_form => $alt_form }) if $alt_form;
1202    return $rs->single;
1203}
1204
1205################################################################################
1206
1207=head2 add_rel_links
1208
1209Adds <link> tag information to the stash.
1210
1211TODO: Move this out of here into something more generic, link it up with the
1212breadcrumbs somehow, generally clean it up, refactor it for dex pages since
1213they end up having largely the same code everywhere.
1214
1215=cut
1216
1217sub add_rel_links {
1218    my ($c, $prev, $next, $generator) = @_;
1219    my $s = $c->stash;
1220
1221    $s->{nav}{start} = $generator->(1);
1222    $s->{nav}{prev}  = $generator->($prev) if defined $prev;
1223    $s->{nav}{next}  = $generator->($next) if defined $next;
1224}
1225
1226################################################################################
1227
1228=head2 calculate_tree_width
1229
1230Runs through an evolution chain tree (or similar, really) and assigns the
1231'width' param of each node the sum of the widths of its children.
1232
1233=cut
1234
1235sub calculate_tree_width {
1236    my $tree = shift;
1237    unless (@{ $tree->{children} }) {
1238        $tree->{width} = 1;
1239        return 1;
1240    }
1241   
1242    my $width = 0;
1243    for my $child (@{ $tree->{children} }) {
1244        calculate_tree_width($child);
1245        $width += $child->{width};
1246    }
1247    return $tree->{width} = $width;
1248}
1249
1250=head2 calculate_stats
1251
1252Adds stat percentiles and averages to the stash.
1253
1254=cut
1255
1256sub calculate_stats {
1257    my ($c, $row) = @_;
1258    # statistics
1259    # XXX: what a terrible fucking hack
1260    my $stat_average;
1261    $stat_average += $row->$_ for @StatColumns;
1262    $stat_average /= @StatColumns;
1263    $c->stash->{stat_average} = $stat_average;
1264   
1265    my %stat_percentiles;
1266    for my $stat (@StatColumns) {
1267        $stat_percentiles{$stat} = Vee::Utils::round(
1268            $c->model('DBIC::Pokemon')->count({
1269                id    => { '<=', $Generations[-1]{maxid} },
1270                $stat => { '<', $row->$stat }
1271            }) / $#PokemonNames * 100,
1272            1
1273        );
1274    }
1275    $stat_percentiles{average} = Vee::Utils::round(
1276        $c->model('DBIC::Pokemon')->count({
1277            -and => [
1278                { id => { '<=', $Generations[-1]{maxid} } },
1279                \ "(stat_at + stat_de + stat_sa + stat_sd + stat_sp + stat_hp) / 6 < $stat_average"
1280            ],
1281        }) / $#PokemonNames * 100,
1282        1
1283    );
1284    $c->stash->{stat_percentiles} = \%stat_percentiles;
1285}
1286
1287=head2 get_locations
1288
1289Fetches the locations for a given Pokemon (row) and returns a hash.
1290
1291In: Pokemon db row
1292
1293Out: { location => { section => { method => { level => "a - b", rarity => x } } } }
1294
1295=cut
1296
1297sub get_locations {
1298    my ($pokemon) = @_;
1299
1300    my $encounters_rs = $pokemon->encounters_rs(undef, {
1301        prefetch  => 'location',
1302        group_by  => [qw/ location_id section method /],
1303
1304        # this minor hackery will essentially collapse multiple rows for a method into one short one we care about
1305        '+select' => [
1306            \ 'GROUP_CONCAT(rarity SEPARATOR " ") AS rarity',
1307            \ 'MIN(min_level) AS min_level',
1308            \ 'MAX(max_level) AS max_level',
1309        ],
1310        '+as'     => [qw/ rarity min_level max_level /],
1311    } );
1312
1313    my %locations;
1314    while (my $encounter = $encounters_rs->next) {
1315        my $level;
1316        if (not $encounter->min_level) {
1317            $level = '';
1318        } elsif ($encounter->min_level == $encounter->max_level) {
1319            $level = $encounter->min_level;
1320        } else {
1321            $level = $encounter->min_level . ' - ' . $encounter->max_level;
1322        }
1323
1324        $locations{ $encounter->location->name }{ $encounter->section }{ $encounter->method } = { level => $level, rarity => min $encounter->rarity };
1325    }
1326
1327    return \%locations;
1328}
1329
1330=head2 add_evolution_desc
1331
1332Adds a readable blurb to an evolution node, based on the method, param, and
1333chain.
1334
1335=cut
1336
1337sub add_evolution_desc {
1338    my ($node, $chain) = @_;
1339    if (@{$node->{children}} and $node->{children}[0]{id} < $node->{id}) {
1340        $node->{blurb} = 'Baby form';
1341        if ($chain->baby_item) {
1342            $node->{blurb} .= ' (mother must hold ' . $chain->baby_item . ')';
1343        }
1344        $node->{item} = 'lucky-egg';
1345
1346    } elsif (!$node->{parent}) {
1347        $node->{blurb} = 'Base form';
1348        $node->{item} = 'poke-ball';
1349
1350    } elsif ($node->{method} =~ /^item(male|female|)$/) {
1351        $node->{blurb} = "Use a $node->{param}";
1352        if ($1) {
1353            $node->{blurb} .= " on a $1";
1354        }
1355        ($node->{item} = lc $node->{param}) =~ tr/ /-/;
1356        $node->{item} =~ tr/-a-z0-9//cd;
1357
1358    } elsif ($node->{method} =~ /^level(male|female|)$/) {
1359        $node->{blurb} = 'Raise' . ($1 ? " a $1" : '') . " to level $node->{param}";
1360        $node->{item} = 'rare-candy';
1361
1362    } elsif ($node->{method} eq 'levelarea') {
1363        $node->{blurb} = "Level up while at $node->{param}";
1364        $node->{item} = 'town-map';
1365
1366    } elsif ($node->{method} eq 'trade') {
1367        $node->{blurb} = "Trade";
1368        if ($node->{param}) {
1369            $node->{blurb} .= " with $node->{param} attached" ;
1370            ($node->{item} = lc $node->{param}) =~ tr/ /-/;
1371            $node->{item} =~ tr/-a-z0-9//cd;
1372        } else {
1373            $node->{item} = 'gameui/trade';
1374        }
1375
1376    } elsif ($node->{method} =~ /^hold(day|night)$/) {
1377        $node->{blurb} = "Level up while holding $node->{param}";
1378        if ($1 eq 'day') {
1379            $node->{blurb} .= " during the day";
1380        } elsif ($1 eq 'night') {
1381            $node->{blurb} .= " at night";
1382        }
1383        ($node->{item} = lc $node->{param}) =~ tr/ /-/;
1384        $node->{item} =~ tr/-a-z0-9//cd;
1385
1386    } elsif ($node->{method} eq 'move') {
1387        $node->{blurb} = "Level up while knowing " . $MoveData[ $node->{param} ]->name;
1388        $node->{item} = 'tm-' . $MoveData[ $node->{param} ]->type;
1389
1390    } elsif ($node->{method} =~ /^happiness(day|night|)$/) {
1391        $node->{blurb} = "Happiness";
1392        if ($1 eq 'day') {
1393            $node->{blurb} .= " during the day";
1394        } elsif ($1 eq 'night') {
1395            $node->{blurb} .= " at night";
1396        }
1397        $node->{item} = 'heart-scale';
1398        if ($node->{param}) {
1399            $node->{blurb} .= ", or use $node->{param}";
1400            $node->{item} = $1 eq 'day' ? 'gameui/daytime' : 'gameui/night';
1401        }
1402
1403    } elsif ($node->{method} eq 'dnadigivolve') {
1404        $node->{blurb} = "Level up with a $PokemonNames[ $node->{param} ] in the party";
1405        $node->{item} = 'net-ball';
1406
1407    } elsif ($node->{method} eq 'divineintervention') {
1408        $node->{blurb} = "Appears in an empty belt slot after you get a $node->{param} by evolution";
1409        $node->{item} = 'leftovers';
1410
1411    } elsif ($node->{method} eq 'level+attack') {
1412        $node->{blurb} = "Raise to level $node->{param} when Attack &gt; Defense";
1413        $node->{item} = 'x-attack';
1414
1415    } elsif ($node->{method} eq 'level+defense') {
1416        $node->{blurb} = "Raise to level $node->{param} when Attack &lt; Defense";
1417        $node->{item} = 'x-defend';
1418
1419    } elsif ($node->{method} eq 'level+equal') {
1420        $node->{blurb} = "Raise to level $node->{param} when Attack = Defense";
1421        $node->{item} = 'x-speed';
1422
1423    } elsif ($node->{method} eq 'beauty') {
1424        $node->{blurb} = "Raise Beauty to at least 171 and raise one level";
1425        $node->{item} = 'blue-scarf';
1426
1427    } elsif ($node->{method} eq 'none') {
1428        $node->{blurb} = "Cannot be obtained by evolution";
1429        $node->{item} = 'everstone';
1430
1431    } else {
1432        $node->{blurb} = "Not recognized: " . $node->{method};
1433        $node->{blurb} .= " [ $node->{param} ]" if $node->{param};
1434        $node->{item} = 'parcel';
1435    }
1436
1437    $node->{item} = 'items/' . $node->{item}
1438        unless $node->{item} =~ m#/#;
1439}
1440
1441=head1 AUTHOR
1442
1443Maintainer: Alex "Eevee" Munroe (C<veekun@veekun.com>)
1444
1445See the included F<AUTHORS> file for a full list of contributers.
1446
1447=head1 LICENSE
1448
1449See the included F<LICENSE> file.
1450
1451=cut
1452
14531;
Note: See TracBrowser for help on using the browser.