360 lines
10 KiB
Perl
360 lines
10 KiB
Perl
package LasTres::Location;
|
|
|
|
use v5.36.0;
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use feature 'signatures';
|
|
|
|
use LasTres::Planets;
|
|
use Moo::Role;
|
|
|
|
use JSON qw/to_json from_json/;
|
|
use utf8;
|
|
|
|
requires qw/identifier name description parent/;
|
|
|
|
## Implement description($self, $pj = undef);
|
|
# Will be printed to the user.
|
|
## Implement name($self, $pj = undef);
|
|
## Implement identifier($self, $pj = undef);
|
|
# Must be unique across locations of this area.
|
|
|
|
my $planets = LasTres::Planets->new;
|
|
|
|
## OVERRIDE
|
|
# The available actions to do in
|
|
# this location, must return hashref,
|
|
# can be an empty one though.
|
|
sub actions ( $self, $pj ) {
|
|
return [];
|
|
}
|
|
## OVERRIDE
|
|
# The available persons to talk with
|
|
# Must return a hashref, can be a empty
|
|
# one though.
|
|
sub npcs ( $self, $pj ) {
|
|
return [];
|
|
}
|
|
|
|
## OVERRIDE
|
|
# Whenever a player can visit this place.
|
|
# The player to compute will always be the leader.
|
|
sub can_visit ( $self, $pj ) {
|
|
return 1;
|
|
}
|
|
|
|
## OVERRIDE
|
|
# Whenever a player can discover this location with explore.
|
|
# The player will be always the leader.
|
|
# Alternative methods to explore will be able to discover this place
|
|
# for the pj.
|
|
sub can_discover ( $self, $pj ) {
|
|
return 1;
|
|
}
|
|
|
|
## OVERRIDE
|
|
# The percentual chance to discover this place with explore.
|
|
sub chance_discover ( $self, $pj ) {
|
|
return 50;
|
|
}
|
|
|
|
## OVERRIDE
|
|
# Whenever this can be the last discovery option in explore to let the
|
|
# player discover at least something.
|
|
sub allow_forced_discovery ( $self, $pj ) {
|
|
return 1;
|
|
}
|
|
|
|
## OVERRIDE
|
|
# The order for the percentual random calculation, the higher the less priority
|
|
# it has for discover and the later it will be forcedfully discovered.
|
|
sub order ($self) {
|
|
return 1000;
|
|
}
|
|
|
|
## OVERRIDE
|
|
# A place that is a spawn will have a healing action that can be changed
|
|
# and if a team faints they will be teleported there and the action will
|
|
# be triggered, the healing action may cost some resource when the action
|
|
# is triggered manually by the user, if the player cannot pay it the
|
|
# action may appear as disabled.
|
|
sub is_spawn ($self) {
|
|
return 0;
|
|
}
|
|
|
|
## OVERRIDE
|
|
# Return object should ideally extend LasTres::PJAction::DefaultHeal
|
|
# following the advice in this file.
|
|
sub healing_action ($self) {
|
|
if ( $self->is_spawn ) {
|
|
require LasTres::PJAction::DefaultHeal;
|
|
return LasTres::PJAction::DefaultHeal->new;
|
|
}
|
|
}
|
|
|
|
## OVERRIDE (Always use $self->SUPER::on_team_arrival.)
|
|
# The code to be executed when a team reachs this location.
|
|
# It is important that you call super or you will lose
|
|
# REALLY important behaviour such as knows_location.
|
|
sub on_team_arrival ( $self, $team ) {
|
|
$team = $team->get_from_storage;
|
|
for my $pj ( $team->members ) {
|
|
$self->on_pj_arrival($pj);
|
|
}
|
|
}
|
|
|
|
## OVERRIDE (Always use $self->SUPER::on_pj_arrival.)
|
|
# The code to be executed when a pj reachs this location.
|
|
# Call super or bad things will happen such as losing
|
|
# knows_location and update-location.
|
|
sub on_pj_arrival ( $self, $pj ) {
|
|
require LasTres::Redis;
|
|
$pj = $pj->get_from_storage;
|
|
my $redis = LasTres::Redis->new;
|
|
if ( !$pj->knows_location($self) ) {
|
|
$pj->set_known_location($self);
|
|
}
|
|
$self->show_intro($pj);
|
|
$pj->update_location;
|
|
$pj->update_team_sprites;
|
|
$pj->update_actions;
|
|
}
|
|
|
|
## DO NOT EXTEND NOT SUPPORTED.
|
|
sub show_intro ( $self, $pj ) {
|
|
$pj->append_log_line(
|
|
[
|
|
{ text => 'Estas en ' },
|
|
{ color => 'red', text => $self->parent->name($pj) },
|
|
{ text => '/' },
|
|
{ color => 'green', text => $self->name($pj) },
|
|
]
|
|
);
|
|
$pj->append_log_line( [ { text => $pj->location->description }, ] );
|
|
}
|
|
|
|
## OVERRIDE (Always use $self->SUPER)
|
|
sub on_leave ( $self, $team ) {
|
|
require LasTres::Vars;
|
|
for my $member ( $team->members ) {
|
|
$member->clear_var( LasTres::Vars::LOCATION_TEMPORAL() );
|
|
}
|
|
}
|
|
|
|
## DO NOT EXTEND NOT SUPPORTED.
|
|
sub move ( $self, $team ) {
|
|
$team = $team->get_from_storage;
|
|
my $current_location = $team->location;
|
|
$current_location->on_leave($team);
|
|
my $json_array_until_area_current_location =
|
|
to_json( [ $current_location->to_array->@[ 0 .. 2 ] ] );
|
|
my $json_array_until_area_destination =
|
|
to_json( [ $self->to_array->@[ 0 .. 2 ] ] );
|
|
if ( $json_array_until_area_current_location ne
|
|
$json_array_until_area_destination
|
|
|| $self->parent->frames_to_move <= 0 )
|
|
{
|
|
$self->place_team($team);
|
|
return;
|
|
}
|
|
my $schema;
|
|
$team->is_moving(1);
|
|
$team->action_frame(0);
|
|
$team->moving_to( $self->to_json_array );
|
|
$team->update;
|
|
$self->on_team_moving($team);
|
|
}
|
|
|
|
## OVERRIDE (Always use $self->SUPER::on_team_moving.)
|
|
# This is called when a team starts their travel
|
|
# to this location, always call SUPER.
|
|
sub on_team_moving ( $self, $team ) {
|
|
$team = $team->get_from_storage;
|
|
for my $pj ( $team->members ) {
|
|
$self->on_pj_moving($pj);
|
|
}
|
|
$team->send_frame_to_members;
|
|
}
|
|
|
|
## OVERRIDE (Always use $self->SUPER::on_pj_moving.)
|
|
# This is called when a pj is approaching this location
|
|
# via move. It is really important to call super.
|
|
sub on_pj_moving ( $self, $pj ) {
|
|
require LasTres::Redis;
|
|
my $redis = LasTres::Redis->new;
|
|
$pj = $pj->get_from_storage;
|
|
$pj->append_log_line(
|
|
[
|
|
{ text => 'Tu equipo se está moviendo a ' },
|
|
{ color => 'red', text => $self->parent->name($pj) },
|
|
{ text => '/' },
|
|
{ color => 'green', text => $self->name($pj) },
|
|
]
|
|
);
|
|
$pj->update_location;
|
|
$pj->update_actions;
|
|
$pj->update_team_sprites;
|
|
}
|
|
|
|
## DO NOT EXTEND NOT SUPPORTED.
|
|
sub place_team ( $self, $team ) {
|
|
$team = $team->get_from_storage;
|
|
if ( $self->is_spawn ) {
|
|
$team->last_spawn( $self->to_json_array );
|
|
}
|
|
$team->location($self);
|
|
$team->update;
|
|
$self->on_team_arrival($team);
|
|
}
|
|
|
|
## DO NOT EXTEND NOT SUPPORTED.
|
|
sub to_array ($self) {
|
|
my $hash = $self->hash;
|
|
return [
|
|
$hash->{planet}{identifier}, $hash->{super_area}{identifier},
|
|
$hash->{area}{identifier}, $hash->{location}{identifier}
|
|
];
|
|
}
|
|
|
|
## DO NOT EXTEND NOT SUPPORTED.
|
|
sub to_json_array ($self) {
|
|
return to_json( $self->to_array );
|
|
}
|
|
|
|
## DO NOT EXTEND NOT SUPPORTED.
|
|
sub is_connected_by_move ( $self, $otherLocation, $pj = undef ) {
|
|
if ( !defined $otherLocation ) {
|
|
die '$otherLocation must be defined in is_connected.';
|
|
}
|
|
my $json_array_other_location = $otherLocation->to_json_array;
|
|
if ( grep { $_->to_json_array eq $json_array_other_location }
|
|
@{ $self->get_available_locations_to_move_to($pj) } )
|
|
{
|
|
return 1;
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
## DO NOT EXTEND NOT SUPPORTED.
|
|
sub get_available_locations_to_move_to ( $self, $pj = undef ) {
|
|
if ( defined $pj ) {
|
|
$pj = $pj->get_from_storage;
|
|
}
|
|
my $location = $self;
|
|
|
|
my $connected_places = [];
|
|
if ( !$self->pj_is_moving($pj) && $location->can('connected_places') ) {
|
|
@$connected_places = ( @{ $self->connected_places } );
|
|
}
|
|
@$connected_places = (
|
|
@$connected_places, @{ $self->_get_neighbour_locations_accesible($pj) }
|
|
);
|
|
@$connected_places =
|
|
grep { $_->to_json_array ne $location->to_json_array }
|
|
grep {
|
|
$_->to_json_array;
|
|
$_->to_json_array ne to_json( from_json( $pj->team->moving_to ) )
|
|
} @$connected_places;
|
|
if ( defined $pj ) {
|
|
@$connected_places = grep { $_->can_visit($pj) } @$connected_places;
|
|
}
|
|
return $connected_places;
|
|
}
|
|
|
|
## DO NOT EXTEND NOT SUPPORTED.
|
|
sub pj_is_moving ( $self, $pj = undef ) {
|
|
if ( defined $pj ) {
|
|
$pj = $pj->get_from_storage;
|
|
}
|
|
return defined $pj && $pj->team->is_moving;
|
|
}
|
|
|
|
## DO NOT EXTEND NOT SUPPORTED.
|
|
sub _get_neighbour_locations_accesible ( $self, $pj ) {
|
|
my $places = [];
|
|
@$places = @{ $self->parent->children };
|
|
if ( !$self->parent->get_auto_discover && defined $pj ) {
|
|
@$places = grep { $pj->knows_location($_) } @$places;
|
|
@$places = grep { $pj->knows_location($_) } @$places;
|
|
}
|
|
return $places;
|
|
}
|
|
|
|
## DO NOT EXTEND NOT SUPPORTED.
|
|
sub get ( $planet_id, $super_area_id, $area_id, $location_id ) {
|
|
my $planet = $planets->hash->{$planet_id};
|
|
if ( !defined $planet ) {
|
|
die "No such planet $planet_id.";
|
|
}
|
|
my $super_area = $planet->super_areas->{$super_area_id};
|
|
if ( !defined $super_area ) {
|
|
die "No such super_area $super_area_id in planet $planet_id.";
|
|
}
|
|
my $area = $super_area->areas->{$area_id};
|
|
if ( !defined $area ) {
|
|
die
|
|
"No such area $area_id in super_area $super_area_id in planet $planet_id.";
|
|
}
|
|
my $location = $area->locations->{$location_id};
|
|
if ( !defined $location ) {
|
|
die
|
|
"No such location $location_id in area $area_id in super_area $super_area_id in planet $planet_id.";
|
|
|
|
}
|
|
return $location;
|
|
}
|
|
|
|
## DO NOT EXTEND NOT SUPPORTED.
|
|
sub hash ($self) {
|
|
my $location = $self;
|
|
if ( !Moo::Role::does_role( $location, 'LasTres::Location' ) ) {
|
|
die "$location does not implement LasTres::Location.";
|
|
}
|
|
my $area = $location->parent;
|
|
if ( !Moo::Role::does_role( $area, 'LasTres::Area' ) ) {
|
|
die "$area does not implement LasTres::Area.";
|
|
}
|
|
my $super_area = $area->parent;
|
|
if ( !Moo::Role::does_role( $super_area, 'LasTres::SuperArea' ) ) {
|
|
die "$super_area does not implement LasTres::SuperArea.";
|
|
}
|
|
my $planet = $super_area->parent;
|
|
if ( !Moo::Role::does_role( $planet, 'LasTres::Planet' ) ) {
|
|
die "$planet does not implement LasTres::Planet.";
|
|
}
|
|
return {
|
|
planet => {
|
|
name => $planet->name,
|
|
identifier => $planet->identifier,
|
|
},
|
|
super_area => {
|
|
name => $super_area->name,
|
|
identifier => $super_area->identifier,
|
|
},
|
|
area => {
|
|
name => $area->name,
|
|
identifier => $area->identifier,
|
|
can_explore => ( $area->can_explore ? $JSON::true : $JSON::false ),
|
|
},
|
|
location => {
|
|
name => $location->name,
|
|
identifier => $location->identifier,
|
|
},
|
|
};
|
|
}
|
|
|
|
{
|
|
my %instances;
|
|
|
|
sub instance {
|
|
my $class = shift;
|
|
if ( !defined $instances{$class} ) {
|
|
$instances{$class} = $class->new(@_);
|
|
}
|
|
return $instances{$class};
|
|
}
|
|
}
|
|
1;
|