src/FROGS/HexTorus.pm

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