| 135 | | =head2 backtrace |
| 136 | | |
| 137 | | Calculates parents for an egg move. |
| 138 | | |
| 139 | | =cut |
| 140 | | |
| 141 | | sub backtrace : Chained('pokemon_chain') : Args(1) { |
| 142 | | my ($self, $c) = @_; |
| 143 | | my $s = $c->stash; |
| 144 | | |
| 145 | | my $gen = 'dp'; # TODO: :( |
| 146 | | |
| 147 | | my $pokemon_name = $c->req->captures->[0]; |
| 148 | | my $move_name = $c->req->args ->[0]; |
| 149 | | |
| 150 | | # For some reason, Catalyst::DispatchType::Chained doesn't url-decode either |
| 151 | | # args or captures, so do it here; this is safe to do since valid move and |
| 152 | | # Pokemon names will never ever contain percent signs.. I hope. |
| 153 | | $pokemon_name =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; |
| 154 | | $move_name =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; |
| 155 | | |
| 156 | | my $pokemon = $c->model('DBIC::Pokemon')->single({ name => $pokemon_name }, { prefetch => 'breeds' }); |
| 157 | | my $move = $c->model('DBIC::Moves') ->single({ name => $move_name }); |
| 158 | | |
| 159 | | $c->vee_stop('No such Pokémon ', $pokemon_name, '.') |
| 160 | | if not $pokemon; |
| 161 | | $c->vee_stop('No such move ', $move_name, '.') |
| 162 | | if not $move; |
| 163 | | |
| 164 | | $s->{page_title} = $pokemon->name . ' - ' . $move->name . ' parents'; |
| 165 | | $s->{crumbs} = [ |
| 166 | | '<a href="' . $c->uri('Dex') . '">Pokédex</a>', |
| 167 | | '<a href="' . $c->uri('Dex', 'pokemon_list') . '">Pokémon</a>', |
| 168 | | '<a href="' . $c->uri('Dex', 'pokemon', lc $pokemon->name) . '">' . $pokemon->name . '</a>', |
| 169 | | 'Breeding chains', |
| 170 | | '<a href="' . $c->uri('Dex', 'moves', lc $move->name) . '">' . $move->name . '</a>', |
| 171 | | ]; |
| 172 | | |
| 173 | | # ensure this move is actually inheritable |
| 174 | | # TODO: should I error if the move is learnable normally? |
| 175 | | my $inheritable_ct = $c->model('DBIC::PokemonMoves')->count({ |
| 176 | | pokemon_id => $pokemon->id, |
| 177 | | move_id => $move->id, |
| 178 | | method => [qw/ egg machine /], |
| 179 | | -nest => \ "FIND_IN_SET('$gen', versions)", |
| 180 | | }); |
| 181 | | $c->vee_stop('', $pokemon->name, " can't inherit ", $move->name, '.') unless $inheritable_ct; |
| 182 | | |
| 183 | | my $gender_restriction; |
| 184 | | if ($pokemon->gender_rate == 255) { |
| 185 | | # must also be genderless, i.e. bred with Ditto |
| 186 | | $gender_restriction = 255; |
| 187 | | } else { |
| 188 | | # cannot be single-gender or genderless |
| 189 | | $gender_restriction = { -not_in => [ 0, 254, 255 ] }; |
| 190 | | } |
| 191 | | |
| 192 | | ### grab the methods by which any Pokemon learn the move |
| 193 | | |
| 194 | | my $methods_rs = $c->model('DBIC::PokemonMoves')->search({ |
| 195 | | move_id => $move->id, |
| 196 | | method => [qw[ level egg machine ]], |
| 197 | | -nest => \ "FIND_IN_SET('$gen', versions)", |
| 198 | | 'pokemon.gender_rate' => $gender_restriction, |
| 199 | | }, { |
| 200 | | join => 'pokemon', |
| 201 | | }); |
| 202 | | my %learn_methods; |
| 203 | | while (my $row = $methods_rs->next) { |
| 204 | | my $method = ucfirst $row->method; |
| 205 | | if ($row->method eq 'level') { |
| 206 | | $method .= ' ' . $row->level; |
| 207 | | } elsif ($row->method eq 'machine') { |
| 208 | | $method = 'TM/HM'; |
| 209 | | } |
| 210 | | push @{ $learn_methods{ $row->pokemon_id } }, $method; |
| 211 | | } |
| 212 | | |
| 213 | | ### do a SEPARATE query to grab all the possible Pokemon at once |
| 214 | | # (DBIC seems to get confused if I prefetch { pokemon => breeds } above) |
| 215 | | # XXX: is this my fault or theirs? |
| 216 | | |
| 217 | | my $learners_rs = $c->model('DBIC::Pokemon')->search({ |
| 218 | | id => [ keys %learn_methods ], |
| 219 | | }, { |
| 220 | | prefetch => 'breeds', |
| 221 | | order_by => 'me.id ASC', |
| 222 | | }); |
| 223 | | |
| 224 | | my (%pokemon); |
| 225 | | while (my $row = $learners_rs->next) { |
| 226 | | $pokemon{ $row->id } = $row; |
| 227 | | } |
| 228 | | |
| 229 | | my %breeding_tree = ( $pokemon->id => {} ); |
| 230 | | |
| 231 | | my %seen = ( $pokemon->id => 0 ); # hash of ( poke_id => 1, ... ) |
| 232 | | my $cur_level = 0; # current tree level |
| 233 | | my @this_level = %breeding_tree; # array of ( poke_id, hashref, ... ) on this level |
| 234 | | |
| 235 | | ### build the breeding-chain tree |
| 236 | | # What we need is a tree of ancestors that can learn the move and pass it |
| 237 | | # down; it should look something like this: |
| 238 | | # pokemon => { |
| 239 | | # a => { |
| 240 | | # b => {}, |
| 241 | | # c => {}, |
| 242 | | # d => { |
| 243 | | # e => {}, |
| 244 | | # }, |
| 245 | | # }, |
| 246 | | # f => { |
| 247 | | # g => {}, |
| 248 | | # d => [ref to former d], |
| 249 | | # }, |
| 250 | | # } |
| 251 | | # The rules are basically that: |
| 252 | | # 1. Every Pokemon is a key in a hash |
| 253 | | # 2. Each corresponding value is a similar hash, containing a list of |
| 254 | | # Pokemon that are compatible |
| 255 | | # 3. No infinite looping! |
| 256 | | |
| 257 | | do { |
| 258 | | $cur_level++; |
| 259 | | my %branches; |
| 260 | | |
| 261 | | while (my $pokemon_id = shift @this_level) { |
| 262 | | my $this_poke = $pokemon{$pokemon_id}; |
| 263 | | my $hashref = shift @this_level; |
| 264 | | |
| 265 | | for my $pokemon_id (keys %pokemon) { |
| 266 | | next if not $this_poke->can_breed_with( $pokemon{$pokemon_id} ); |
| 267 | | |
| 268 | | if (exists $seen{ $pokemon_id }) { |
| 269 | | # don't put anything if this Pokemon has been seen higher |
| 270 | | # in the chain; needless descending is bad |
| 271 | | $hashref->{ $pokemon_id } = undef |
| 272 | | unless $seen{ $pokemon_id } < $cur_level; |
| 273 | | } else { |
| 274 | | $hashref->{$pokemon_id} = ( $branches{$pokemon_id} ||= {} ); |
| 275 | | $seen{$pokemon_id} = $cur_level; |
| 276 | | } |
| 277 | | } |
| 278 | | } |
| 279 | | |
| 280 | | @this_level = %branches; |
| 281 | | } while ($cur_level < 10 and @this_level); |
| 282 | | |
| 283 | | ### find the optimal path |
| 284 | | |
| 285 | | # since there should only be a small finite number of Pokemon, we can just |
| 286 | | # iterate over every possibility; flatten into arrays, and take whichever |
| 287 | | # is shortest |
| 288 | | |
| 289 | | # TODO: merge this with the actual building of the tree, and toss useless |
| 290 | | # branches as we go; right now this sub MODIFIES THE TREE, pruning any |
| 291 | | # branches it finds that don't end with a level; this makes the dupe |
| 292 | | # removal up top a little silly! |
| 293 | | my $flattener; $flattener = sub { |
| 294 | | my ($branch) = @_; |
| 295 | | my @subchains; |
| 296 | | |
| 297 | | for my $key (keys %$branch) { |
| 298 | | if (grep /level/i, @{ $learn_methods{$key} }) { |
| 299 | | # consider this Pokemon an endpoint if it learns the move |
| 300 | | # naturally; TMs don't count since they are of limited quantity |
| 301 | | push @subchains, [ $key ]; |
| 302 | | $branch->{$key} &&= {}; |
| 303 | | next; |
| 304 | | } |
| 305 | | |
| 306 | | # ...otherwise, only add more chains if this branch has any valid |
| 307 | | # subchains of its own |
| 308 | | my @child_chains = $flattener->( $branch->{$key} ); |
| 309 | | if (@child_chains) { |
| 310 | | push @subchains, map [ $key, @$_ ], @child_chains; |
| 311 | | } else { |
| 312 | | delete $branch->{$key}; |
| 313 | | } |
| 314 | | } |
| 315 | | |
| 316 | | return @subchains; |
| 317 | | }; |
| 318 | | |
| 319 | | # only take the shortest chains; it's possible there could be several! |
| 320 | | my @flat_chains = sort { $#$a <=> $#$b } $flattener->( \%breeding_tree ); |
| 321 | | my @optimal_path = grep { $#$_ == $#{ $flat_chains[0] } } @flat_chains; |
| 322 | | @$_ = reverse @$_ for @optimal_path; |
| 323 | | |
| 324 | | ### cram everything important into the stash |
| 325 | | $s->{breeding_tree} = \%breeding_tree; |
| 326 | | $s->{pokemon} = \%pokemon; |
| 327 | | $s->{learn_methods} = \%learn_methods; |
| 328 | | $s->{optimal} = \@optimal_path; |
| 329 | | |
| 330 | | $s->{template} = 'dex/utils/backtrace.tt'; |
| 331 | | |
| 332 | | # $c->res->body(join "<br/>", map { qq'<a href="/dex/pokemon/$PokemonNames[$_]">$PokemonNames[$_]</a>' } @other_learners); |
| 333 | | |
| 334 | | # TODO: |
| | 135 | # OLD TODO: |
| | 151 | =head2 breeding_chains |
| | 152 | |
| | 153 | Finds a family tree that can be bred through to obtain a given Pokemon and a |
| | 154 | given set of egg or TM moves. |
| | 155 | |
| | 156 | =cut |
| | 157 | |
| | 158 | # NOT A METHOD |
| | 159 | # Helper sub for constructiny the tree below, out of nodes that look like: |
| | 160 | # { |
| | 161 | # groups => [ $code1, $code2 ], |
| | 162 | # pokemon => \@pokemon, |
| | 163 | # children => \@nodes, |
| | 164 | # } |
| | 165 | # The second parameter is a hash of code1;code2 => $node, used for node |
| | 166 | # lookup and modified as we go to ensure nodes are inserted only once. |
| | 167 | # This sub acts breadth-first, NOT the usual recursive depth-first. This is |
| | 168 | # to ensure that groups are placed as high in the tree as possible. |
| | 169 | sub _build_egg_groups_tree { |
| | 170 | my ($root_node, $egg_node_map_ref) = @_; |
| | 171 | my @nodes_by_depth = ($root_node); |
| | 172 | |
| | 173 | # Run over a list of nodes in depth order, building it as we add more |
| | 174 | # children |
| | 175 | my $i = 0; |
| | 176 | while ($i <= $#nodes_by_depth) { |
| | 177 | my $node = $nodes_by_depth[$i]; |
| | 178 | |
| | 179 | my %my_groups_map = map { $_ => 1 } @{ $node->{groups} }; |
| | 180 | |
| | 181 | while ( my ($code, $other_node) = each %{$egg_node_map_ref} ) { |
| | 182 | next if not grep { $my_groups_map{$_} } |
| | 183 | @{ $other_node->{groups} }; |
| | 184 | |
| | 185 | push @{ $node->{children} }, $other_node; |
| | 186 | push @nodes_by_depth, $other_node; |
| | 187 | |
| | 188 | delete $egg_node_map_ref->{$code}; |
| | 189 | } |
| | 190 | |
| | 191 | $i++; |
| | 192 | } |
| | 193 | |
| | 194 | # Run back through the list in reverse order, removing egg-only learners |
| | 195 | # from leaf nodes; going in reverse order guarantees we remove such nodes |
| | 196 | # before looking at their parents |
| | 197 | for my $node (reverse @nodes_by_depth) { |
| | 198 | # Remove any of my children who have no useful Pokemon |
| | 199 | @{ $node->{children} } = grep { |
| | 200 | @{ $_->{pokemon} } |
| | 201 | } @{ $node->{children} }; |
| | 202 | |
| | 203 | # Remove any of my own Pokemon that can only learn the move via egg, |
| | 204 | # but only if there's no children for them to get the move from |
| | 205 | if (not @{ $node->{children} }) { |
| | 206 | @{ $node->{pokemon} } = grep { |
| | 207 | grep { $_->method ne 'egg' } $_->pokemon_moves |
| | 208 | } @{ $node->{pokemon} }; |
| | 209 | } |
| | 210 | } |
| | 211 | |
| | 212 | return; |
| | 213 | } |
| | 214 | |
| | 215 | # Recursively flattens a tree into a list of nodes with an indent added to |
| | 216 | # each node. Named generically because it only cares that the nodes are |
| | 217 | # hashrefs and list their children with an arrayref keyed under 'children'. |
| | 218 | sub _flatten_tree { |
| | 219 | my ($node, $indent) = @_; |
| | 220 | $indent ||= 0; |
| | 221 | |
| | 222 | $node->{indent} = $indent; |
| | 223 | my @flattened_tree = ($node); |
| | 224 | |
| | 225 | for my $child_node (@{ $node->{children} }) { |
| | 226 | push @flattened_tree, _flatten_tree($child_node, $indent + 1); |
| | 227 | } |
| | 228 | |
| | 229 | return @flattened_tree; |
| | 230 | } |
| | 231 | |
| | 232 | sub breeding_chains |
| | 233 | : Path('calculators/breeding_chains') |
| | 234 | : Args(0) |
| | 235 | : FormConfig('dex/utils/breeding_chains.yml') |
| | 236 | { |
| | 237 | my ($self, $c) = @_; |
| | 238 | my $s = $c->stash; |
| | 239 | my $form = $s->{form}; |
| | 240 | $s->{template} = 'dex/utils/breeding_chains.tt'; |
| | 241 | $s->{page_title} = 'Breeding Chains'; |
| | 242 | |
| | 243 | if (not $form->submitted or $form->has_errors) { |
| | 244 | return; |
| | 245 | } |
| | 246 | |
| | 247 | # XXX do the retrievals in Inflator code |
| | 248 | my $pokemon = $c->model('DBIC::Pokemon')->find($form->param_value('pokemon')); |
| | 249 | warn join '|', $form->param_list('move'); |
| | 250 | my @moves = map { $c->model('DBIC::Moves')->find($_) } $form->param_list('move'); |
| | 251 | |
| | 252 | # XXX |
| | 253 | my $version = 'dp'; |
| | 254 | |
| | 255 | my @learners = $c->model('DBIC::Pokemon')->search( { |
| | 256 | -or => [ { |
| | 257 | 'pokemon_moves.move_id' => $moves[0]->id, |
| | 258 | 'pokemon_moves.method' => [qw[ level egg machine ]], |
| | 259 | -nest => \ "FIND_IN_SET('dp', pokemon_moves.versions)", |
| | 260 | # 'pokemon.gender_rate' => $gender_restriction, |
| | 261 | }, { |
| | 262 | # Smeargle can, technically, learn anything |
| | 263 | name => 'Smeargle', |
| | 264 | } ], |
| | 265 | }, { |
| | 266 | prefetch => ['breeds', 'pokemon_moves'], |
| | 267 | } ); |
| | 268 | |
| | 269 | my @egg_group_nodes; # see above for node def |
| | 270 | my %egg_code_map; # code1;code2 => $node |
| | 271 | for my $learner_pokemon (@learners) { |
| | 272 | my @groups = sort $learner_pokemon->breeding_groups; |
| | 273 | my $code = join ';', @groups; |
| | 274 | |
| | 275 | # Keep a map of codes to make them quick to find |
| | 276 | if (not exists $egg_code_map{$code}) { |
| | 277 | push @egg_group_nodes, { |
| | 278 | groups => \@groups, |
| | 279 | pokemon => [], |
| | 280 | children => [], |
| | 281 | }; |
| | 282 | $egg_code_map{$code} = $egg_group_nodes[-1]; |
| | 283 | } |
| | 284 | |
| | 285 | push @{ $egg_code_map{$code}{pokemon} }, $learner_pokemon; |
| | 286 | } |
| | 287 | |
| | 288 | # Create a fake root node for just the Pokemon of interest and build the |
| | 289 | # tree iteratively from there |
| | 290 | my %egg_groups_tree = ( |
| | 291 | groups => [ $pokemon->breeding_groups ], |
| | 292 | pokemon => [ $pokemon ], |
| | 293 | children => [], |
| | 294 | ); |
| | 295 | _build_egg_groups_tree(\%egg_groups_tree, \%egg_code_map); |
| | 296 | |
| | 297 | # Flatten the tree into a list with 'indent' keys added; far easier to do |
| | 298 | # this now than to shoehorn it into TT |
| | 299 | my @flattened_tree = _flatten_tree(\%egg_groups_tree); |
| | 300 | |
| | 301 | $s->{ flattened_tree } = \@flattened_tree; |
| | 302 | $s->{ version } = $version; |
| | 303 | $s->{ moves } = \@moves; |
| | 304 | |
| | 305 | # XXX error form validation better :(? |
