src/FROGS/HexTorus.pm

   1 ##########################################################################
   2 #
   3 #   Copyright (c) 2003-2012 Aymargeddon Development Team
   4 #
   5 #   This file is part of "Last days of Aymargeddon" - a massive multi player
   6 #   onine game of strategy
   7 #
   8 #        This program is free software: you can redistribute it and/or modify
   9 #        it under the terms of the GNU Affero General Public License as
  10 #        published by the Free Software Foundation, either version 3 of the
  11 #        License, or (at your option) any later version.
  12 #
  13 #        This program is distributed in the hope that it will be useful,
  14 #        but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 #        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  16 #
  17 #    See the GNU Affero General Public License for more details.
  18 #
  19 #    You should have received a copy of the GNU Affero General Public License
  20 #    along with this program.  If not, see <http://www.gnu.org/licenses/>.
  21 #
  22 ###########################################################################
  23 #
  24
  25 use strict;
  26 use POSIX qw(ceil floor);
  27
  28 use FROGS::Config;
  29 use FROGS::Map;
  30
  31 # We define two classes, which gives an implementation of Maps as a
  32 # HexTorus.
  33
  34 # TODO: selects to DataBase.pm
  35
  36 #
  37 # Location. This is a class with two coordinates.
  38 #
  39 package Location;
  40
  41 sub new{
  42     my ($class,$x,$y) = @_;
  43
  44     my $self = { -x => $x, -y => $y };
  45     bless($self, $class);
  46 }
  47
  48 sub get{
  49     my $self = shift;
  50
  51     return ($self->{-x},$self->{-y});
  52 }
  53
  54 sub equal{
  55     my ($self, $loc) = @_;
  56     my ($x,$y) = $loc->get();
  57     return ($x == $self->{-x} and $y == $self->{-y});
  58 }
  59
  60 sub to_string{
  61     my $self = shift;
  62     return $self->{-x} . '_' . $self->{-y};
  63 }
  64
  65 sub from_string{
  66     my ($class, $string) = @_;
  67
  68     # print "CLASS: $class, STRING: $string\n";
  69
  70     $string =~ /^(\d+)_(\d+)$/;
  71     my ($x, $y) = ($1,$2);
  72     # print "x: $x, y: $y\n";
  73     my $self = { -x => $1,
  74                  -y => $2,};
  75
  76     bless($self, $class);
  77 }
  78
  79 sub pretty{
  80   my $loc = shift;
  81   $loc =~ s/^(\d+)_(\d+)$/\($1, $2\)/;
  82   return $loc;
  83 }
  84
  85 sub is_wellformed{
  86   my $string = shift;
  87   return 1 if $string =~ /^(\d+)\_(\d+)$/;
  88   return 0;
  89 }
  90
  91 #
  92 # Map. Hextorus.
  93 #
  94 package HexTorus;
  95 @HexTorus::ISA = qw(Map);
  96
  97 sub new{
  98     my $class = shift;
  99     my ($n) = @_;
 100
 101     my $self = {
 102         -size => $n
 103         };
 104
 105     bless($self, $class);
 106 }
 107
 108
 109 # returns a list of neighbours of field x,y in
 110 # an hex-torus with size 2n * n
 111 # this function is more effective than the generalised
 112 # distant_neighbours from Map.pm
 113 # TODO BUG: dont return doubbles in turn-around
 114 sub neighbours{
 115     my $self = shift;
 116     my ($loc) = @_;
 117
 118     my $n = $self->{-size};
 119     my ($x,$y) = $loc->get();
 120
 121     return (new Location($x,($y-1)%$n),
 122             new Location($x,($y+1)%$n),
 123             new Location(($x-1)%($n*2),$y),
 124             new Location(($x+1)%($n*2),$y),
 125             new Location(($x+1)%($n*2),($y-1)%$n),
 126             new Location(($x-1)%($n*2),($y+1)%$n));
 127 }
 128
 129 # returns the neighbour in the given direction.
 130 # direction can be one of qw(NW N NE S SW SE)
 131 sub get_neighbour{
 132   my ($self, $loc, $dir) = @_;
 133   my ($x,$y) = $loc->get();
 134
 135   $dir = uc($dir);
 136   my ($xx,$yy) = ($x,$y);
 137   my $n = $self->{-size};
 138   if($dir eq 'N'){
 139     $yy = ($yy - 1) % $n;
 140   }elsif($dir eq 'S'){
 141     $yy = ($yy + 1) % $n;
 142   }elsif($dir eq 'SW'){
 143     $xx = ($xx - 1) % ($n * 2);
 144     $yy = ($yy + 1) % $n;
 145   }elsif($dir eq 'SE'){
 146     $xx = ($xx + 1) % ($n * 2);
 147   }elsif($dir eq 'NW'){
 148     $xx = ($xx - 1) % ($n * 2);
 149   }elsif($dir eq 'NE'){
 150     $xx = ($xx + 1) % ($n * 2);
 151     $yy = ($yy - 1) % $n;
 152   }else{
 153     Util::log("HexTorus::get_neighbour(): unknown direction: $dir\n",0);
 154     return 0;
 155   }
 156   return Location->new($xx,$yy);
 157 }
 158
 159 # returns the direction from $from to $to (assumes they are neighbours)
 160 sub get_direction{
 161   my($self,$from,$to) = @_;
 162
 163   # print "get_direction(".$from->to_string().", ".$to->to_string().")\n";
 164
 165   for my $dir (qw(NW N NE S SW SE)){
 166     my $neighbour = $self->get_neighbour($from,$dir);
 167     # print "test $dir from ".$from->to_string().": ".$neighbour->to_string()."\n";
 168     return $dir if $to->equal($neighbour);
 169   }
 170   return 0;
 171 }
 172
 173 # returns the distance between two fields in
 174 # an hex-torus with size 2n * n
 175 sub distance{
 176     my $self = shift;
 177     my ($loc1,$loc2) = @_;
 178
 179     my $n = $self->{-size};
 180     my ($xx,$yy) = $loc1->get();
 181     my ($x,$y) = $loc2->get();
 182
 183     if($xx > $n * 2 or $x > $n * 2 or $yy > $n or $y > $n){
 184         print "range error in distance ($n,$xx,$x,$yy,$y) !\n";
 185         return 0;
 186     }
 187
 188     return 0 if($xx == $x and $yy == $y);
 189
 190     my $xd = abs($x-$xx);
 191     $xd = 2 * $n - $xd if $xd > $n;
 192     my $sd = abs($x-$xx+$y -$yy) % $n;
 193     $sd = $n - $sd if 2* $sd > $n;
 194     my $yd = abs($y-$yy);
 195     $yd = $n - $yd if 2 * $yd > $n;
 196
 197     if($xd+$yd+$sd == $n){
 198
 199         if(2*$xd == $n) # this occures only for even n
 200         {
 201             # there must be some easier way to distinguish
 202             # fields in se/nw direction from those in sw/ne
 203             # but this works.
 204             my $xp = abs($x-$xx+1);
 205             $xp = 2 * $n - $xp if $xp > $n;
 206             my $sp = abs($x -$xx +$y -$yy +1) % $n;
 207             $sp = $n - $sp if 2* $sp > $n;
 208             return $xd if $xp+$sp != $xd+$sd;
 209         }
 210         $yd = $sd if $sd > $yd;
 211         return $n-$yd;
 212     }
 213     return $xd if 2 * $xd > $n;
 214     return ($xd+$yd+$sd)/2;
 215 }
 216
 217 # returns a random location
 218 sub random{
 219     my $self = shift;
 220     my $n = $self->{-size};
 221
 222     my $x = POSIX::floor(rand($n*2));
 223     my $y = POSIX::floor(rand($n));
 224
 225     my $loc = new Location($x,$y);
 226     return $loc;
 227 }
 228
 229 # iterator for all locations
 230 sub next{
 231     my $self = shift;
 232     my $loc = shift;
 233     my $n = $self->{-size};
 234
 235     my ($x, $y) = $loc->get();
 236     if(++$x > $n * 2)
 237     {
 238         $x = 0;
 239         $y = 0 if(++$y > $n);
 240     }
 241     return new Location($x, $y);
 242 }
 243
 244 # returns all locations for which $code evals to true
 245 sub grep{
 246     my $self = shift;
 247     my $code = shift;
 248
 249     my $n = $self->{-size};
 250
 251     my @result;
 252     for my $x (0..($n*2-1)){
 253         for my $y (0..($n-1)){
 254             my $loc = new Location($x,$y);
 255             # print $loc->to_string() . "\n";
 256             if(&$code($loc)){
 257                 push @result, $loc;
 258             }
 259         }
 260     }
 261     return @result;
 262 }
 263
 264
 265 sub fill_array{
 266     my $self = shift;
 267     my @mapping = @_;
 268
 269     my @array;
 270     for my $terrain (@mapping){
 271         for my $xy (@{$terrain->[0]}){
 272             my ($x,$y) = $xy->get();
 273             $array[$x][$y] = $terrain->[1],
 274         }
 275     }
 276     return \@array;
 277 }
 278
 279 # TODO: use FROGS::DataBase.pm
 280 sub write_db{
 281     my ($self, $dbh, $game_id, $game_name, $game_speed, $default, @mapping) = @_;
 282     $default = $dbh->quote($default);
 283     $game_name = $dbh->quote($game_name);
 284
 285     my $n = $self->{-size};
 286
 287     # create game
 288     my $insert_game = "INSERT INTO GAME (GAME,NAME,SIZE,SPEED,FORTUNE,START_MANA) VALUES".
 289       " ($game_id,$game_name,$n,$game_speed,".
 290         "$::conf->{-START_FORTUNE},$::conf->{-START_MANA})";
 291     print $insert_game ."\n";
 292     my $h = $dbh->prepare($insert_game);
 293     $h->execute();
 294     $h->finish();
 295
 296     my @db_map = @{$self->fill_array(@mapping)};
 297
 298     # fill map
 299     for my $y (0..($n - 1)){
 300         for my $x ( 0 .. ($n*2-1)){
 301             my $insert_map;
 302             my $loc = new Location($x,$y);
 303             my $loc_string = $dbh->quote($loc->to_string());
 304             if(defined $db_map[$x][$y]){
 305
 306                 $insert_map = "INSERT INTO MAP (GAME,LOCATION,TERRAIN)".
 307                     "VALUES ($game_id,$loc_string,".
 308                         $dbh->quote($db_map[$x][$y]).")";
 309             }else{
 310
 311                 $insert_map = "INSERT INTO MAP (GAME,LOCATION,TERRAIN)".
 312                     "VALUES ($game_id,$loc_string,$default)";
 313             }
 314             # print "$insert_map\n";
 315
 316             $dbh->do($insert_map);
 317         }
 318     }
 319 }
 320
 321 sub write_string{
 322     my $self = shift;
 323     my $default = shift;
 324     my $default_string = shift;
 325     my @mapping = @_;
 326
 327     my @ascii_map = @{$self->fill_array(@mapping)};
 328
 329     my $n = $self->{-size};
 330     my $out = "\n";
 331     for my $y (0..($n - 1)){
 332         for my $x ( 0 .. ($n*2-1)){
 333             if(defined $ascii_map[$x][$y]){
 334                 $out .= $ascii_map[$x][$y] ;
 335             }else{
 336                 $out .= $default;
 337             }
 338             $out .= " ";
 339         }
 340         $out .= "\n" . (' ' x ($y +1));
 341     }
 342     $out .= "\n";
 343
 344     $out .=  "Legend:\n";
 345     $out .= "$default_string:  \t$default\n";
 346     for my $terrain (@mapping){
 347         $out .= $terrain->[2] . ":   \t" .
 348             $terrain->[1] . "\n";
 349     }
 350     return $out;
 351 }
 352
 353 return 1;