# Games::Construder - A 3D Game written in Perl with an infinite and modifiable world.
# Copyright (C) 2011 Robin Redeker
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU Affero General Public License as
# published by the Free Software Foundation, either version 3 of the
# License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU Affero General Public License for more details.
#
# You should have received a copy of the GNU Affero General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
#
package Games::Construder::Client::World;
use common::sense;
use Games::Construder::Vector;
use Games::Construder;
use POSIX qw/floor/;
use Object::Event;
require Exporter;
use POSIX qw/floor/;
our @ISA = qw/Exporter/;
our @EXPORT = qw/
world_pos2chunk
world_visible_chunks_at
world_collide
world_collide_cylinder_aabb
world_is_solid_box
world_intersect_ray_box
world_get_box_at
world_get_chunk world_get_chunk_at
world_set_chunk
world_delete_chunk
world_change_chunk_at world_change_chunk
world_pos2id
world_id2pos
world_find_free_spot
world_init
world
/;
=head1 NAME
Games::Construder::Client::World - Client collision detection and world utilities
=over 4
=cut
our $CHNK_SIZE = 12;
our $BSPHERE = sqrt (3 * (($CHNK_SIZE/2) ** 2));
my @CHUNKS;
sub world_init {
}
sub world_pos2chunk {
@{vfloor (vsdiv ($_[0], $CHNK_SIZE))};
}
sub world_pos2id {
my ($pos) = @_;
join "x", map { $_ < 0 ? "N" . abs ($_) : $_ } @{vfloor ($pos)};
}
sub world_id2pos {
my ($id) = @_;
[map { s/^N/-/; $_ } split /x/, $id]
}
sub world_intersect_ray_box {
my ($pos, $dir, $bmi) = @_;
my $bma = vaddd ($bmi, 1, 1, 1);
my $tmin = -9999.99;
my $tmax = 9999.99; # arbitrary max distance :->
#d#warn "IRFAY pos ".vstr($pos)." dir " . vstr ($dir)
#d# . " bmi " .vstr ($bmi) . "-".vstr($bma)."\n";
for my $i (0..2) {
if (abs ($dir->[$i]) < 0.01) { # parallel to an axis?
return if
$pos->[$i] < $bmi->[$i]
|| $pos->[$i] > $bma->[$i];
} else {
my $ood = 1.0 / $dir->[$i];
my $t1 = ($bmi->[$i] - $pos->[$i]) * $ood;
my $t2 = ($bma->[$i] - $pos->[$i]) * $ood;
#d# warn "T1[$i] $t1 T2 $t2 TMIN $tmin TMAX $tmax\n";
($t1, $t2) = ($t2, $t1) if $t1 > $t2;
#d# warn "BT1[$i] $t1 T2 $t2 TMIN $tmin TMAX $tmax\n";
$tmin = $t1 if $t1 > $tmin;
$tmax = $t2 if $t2 < $tmax;
return if $tmin > $tmax; # no intersection anymore!
}
}
#d# warn "OUTPUT $tmin: " . vstr (vadd ($pos, vsmul ($dir, $tmin))) . "\n";
return ($tmin, vadd ($pos, vsmul ($dir, $tmin))); # return intersection position!
}
sub _collide_sphere_box {
my ($sphere_pos, $sphere_rad, $box) = @_;
my $abpt =
Games::Construder::Math::point_aabb_distance (
@$sphere_pos, @$box, @{vaddd ($box, 1, 1, 1)});
my $dv = vsub ($sphere_pos, $abpt);
#d#warn "solid box at $cur_box, dist vec $dv |"
#d# . (sprintf "%9.4f", $dv->length) . "\n";
my $dvlen = vlength ($dv);
if ($dvlen == 0) { # ouch, directly in the side?
# find the direction away from the center
my $inside_dir = vsub ($sphere_pos, vadd ($box, 0.5, 0.5, 0.5));
if (vlength ($inside_dir) > 0.0001) {
vinorm ($inside_dir);
} else { # he IS in the center
$inside_dir = [0, 1, 0]; # move up :)
}
# and move out one radius!
return ($inside_dir, vsmul ($inside_dir, $sphere_rad));
warn "player landed directly on the surface\n";
return ([0, 0, 0]);
}
if ($dvlen < $sphere_rad) {
my $back_dist = ($sphere_rad - $dvlen) + 0.00001;
return ($dv, vsmul (vnorm ($dv, $dvlen), $back_dist));
}
return ()
}
sub world_is_solid_box { $_[0]->[2] && $_[0]->[0] != 0 }
sub world_adjacent_walls {
my ($pos, $rad) = @_;
my %poses;
for my $dx (-$rad, $rad) {
for my $dz (-$rad, $rad) {
my $p = vfloor (vaddd ($pos, $dx, 0, $dz));
$poses{world_pos2id ($p)} = $p;
}
}
values %poses
}
# collide sphere at $pos with radius $rad
# 0.00059 secsPcoll in flight without collisions
# 0.00171secsPcoll to 0.00154secsPcoll when colliding with floor
# after own vector math module:
# 0.00032 secsPcoll in flight
# 0.00068 secsPcoll on floor # i find this amazing!
sub world_collide {
my ($pos, $rad, $plh, $rcoll) = @_;
my ($rec, $orig_pos) = (0, [@$pos]);
RECOLLIDE:
$rec++;
# we collide too much:
if ($rec > 8) {
#d# warn "collision occured on too many things. we couldn't backoff!";
my $np = world_find_free_spot ($orig_pos, 0);
$$rcoll = 1;
$np = $orig_pos unless $np;
$np = vaddd ($np, $rad + 0.01, $rad + 0.01, $rad + 0.01);
return $np;
}
my @wall_boxes = world_adjacent_walls ($pos, $rad);
my @wboxes;
for (@wall_boxes) {
my $b = vfloor (vaddd ($_, 0, $plh, 0));
push @wboxes, $_, $b;
}
for my $cur_box (@wboxes) {
next unless Games::Construder::World::is_solid_at (@$cur_box);
$cur_box->[1] = 0;
my ($col_dir, $pos_adj) =
_collide_sphere_box ([$pos->[0], 0, $pos->[2]], $rad, $cur_box);
if ($col_dir) { # collided!
$$rcoll = vaccum ($$rcoll, $col_dir);
if (defined $pos_adj) { # was able to move to safer location?
$pos = vadd ($pos, $pos_adj);
goto RECOLLIDE;
} else { # collided with something, but unable to move to safe location
warn "player collided with something, but we couldn't repell him!";
return ($orig_pos);
}
}
}
for my $sphere_y (0, $plh) {
my ($spos, $srad, $coll_y) =
(vaddd ($pos, 0, $sphere_y, 0), $rad, $sphere_y > 0 ? -1 : 1);
# the "current" block
my $my_box = vfloor ($spos);
my (@xr, @yr, @zr);
my ($ax, $ay, $az) = (
abs ($spos->[0] - int $spos->[0]),
abs ($spos->[1] - int $spos->[1]),
abs ($spos->[2] - int $spos->[2])
);
push @xr, $ax > 0.5 ? (0, 1) : (0, -1);
push @yr, $ay > 0.5 ? (0, 1) : (0, -1);
push @zr, $az > 0.5 ? (0, 1) : (0, -1);
$xr[1] *= -1 if $spos->[0] < 0;
$yr[1] *= -1 if $spos->[1] < 0;
$zr[1] *= -1 if $spos->[2] < 0;
#d# warn "sphere pos @$spos: checking [@xr|@yr|@zr]\n";
for my $x (@xr) {
for my $y (@yr) {
for my $z (@zr) {
my $cur_box = vaddd ($my_box, $x, $y, $z);
next unless Games::Construder::World::is_solid_at (@$cur_box);
my ($col_dir, $pos_adj) = _collide_sphere_box ($spos, $srad, $cur_box);
if ($col_dir) { # collided!
$$rcoll = vaccum ($$rcoll, $col_dir);
if (defined $pos_adj) { # was able to move to safer location?
$pos = vadd ($pos, $pos_adj);
goto RECOLLIDE;
} else { # collided with something, but unable to move to safe location
warn "player collided with something, but we couldn't repell him!";
return ($orig_pos);
}
}
}
}
}
}
return ($pos);
}
sub world_find_free_spot {
my ($pos, $wflo) = @_;
$wflo = 0 unless defined $wflo;
Games::Construder::World::find_free_spot (@$pos, $wflo);
}
=back
=head1 AUTHOR
Robin Redeker, C<< <elmex@ta-sa.org> >>
=head1 COPYRIGHT & LICENSE
Copyright 2011 Robin Redeker, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the terms of the GNU Affero General Public License.
=cut
1;