Deliantra/Deliantra/Map.pm

=head1 NAME

Crossfire::Map - represent a crossfire map

=cut

package Crossfire::Map;

our $VERSION = '0.1';

use strict;

use Carp ();
use Crossfire;

use base 'Exporter';

sub new {
   my ($class, $width, $height) = @_;

   bless { width => $width, height => $height }, $class
}

sub new_from_file  {
   new_from_archlist {$_[0]} read_arch $_[1]
}

sub new_from_archlist {
   my ($class, $mapa) = @_;

   my %meta;

   my ($mapx, $mapy);

   my $map;

   for (@{ $mapa->{arch} }) {
      my ($x, $y) = (delete $_->{x}, delete $_->{y});

      if ($_->{_name} eq "map") {
         $meta{info} = $_;

         $mapx = $_->{width}  || $x;
         $mapy = $_->{height} || $y;
      } else {
         push @{ $map->[$x][$y] }, $_;

         # arch map is unreliable w.r.t. width and height
         $mapx = $x + 1 if $mapx <= $x;
         $mapy = $y + 1 if $mapy <= $y;
         #$mapx = $a->{x} + 1, warn "$mapname: arch '$a->{_name}' outside map width at ($a->{x}|$a->{y})\n" if $mapx <= $a->{x};
         #$mapy = $a->{y} + 1, warn "$mapname: arch '$a->{_name}' outside map height at ($a->{x}|$a->{y})\n" if $mapy <= $a->{y};
      }
   }

   $meta{width}  = $mapx;
   $meta{height} = $mapy;
   $meta{map}    = $map;

   bless \%meta, $class
}

sub new_pickmap {
   my ($class, $archs, $width) = @_;

   # sort archs alphabetically
   my $archs = [ sort { ${$a}->{_name} cmp ${$b}->{_name} } @$archs ];

   $width ||= 10; # default width

   my $num = @$archs;
   my $map = { };
   # overall placement coords
   my $x = 0; 
   my $y = 0;

   my ($maxh, $maxw) = (0, 0); # maximum sizes, to set map width/height later
   my $drawn_archs = 1;                  # line-break counter
   my $max_line_height = 1;

   for (my $i = 0; $i < $num; $i++) {
      defined  ${$archs->[$i]}->{face} or next;

      # check whether this tile was already written (see below at (b))
      unless (defined $map->{map}[$x][$y]) {
         my ($xoffs, $yoffs, $arch_w, $arch_h) = arch_extends (${$archs->[$i]});

         if ($x + $arch_w > $width) {
            $y += $max_line_height;
            $max_line_height = 1;
            $x = 0;
         }

         # these are special placement coords, for chained faces which
         # have a special placement offset
         my ($place_x, $place_y) = ($x, $y);
         $xoffs < 0 and
            $place_x += -$xoffs;
         $yoffs < 0 and
            $place_y += -$yoffs;

         # iterate over the tiles this arch takes
         # NOTE: Chained archs are maybe not a rectangle, but i don't care
         # much for that on pickmaps

         for (my $xi = 0; $xi < $arch_w; $xi++) {
            for (my $yi = 0; $yi < $arch_h; $yi++) {

               my ($lx, $ly) = ($x + $xi, $y + $yi);

               if ($lx == $place_x and $ly == $place_y) {
                  push @{$map->{map}[$place_x][$place_y]}, my $a = ${$archs->[$i]};

               } else {

                  # (b): here we set occupied tiles, but without the arch
                  $map->{map}[$lx][$ly] = [];
               }
            }
         }
         $drawn_archs++;

         $x += $arch_w;

         $max_line_height < $arch_h
            and $max_line_height = $arch_h;

      } else {
         $i--;
      }

      $maxw = List::Util::max $maxw, $x;
      $maxh = List::Util::max $maxh, $y;
   }

   $map->{height} = $maxh;
   $map->{width}  = $maxw;

   $map
}

sub resize {
   my ($self, $width, $height) = @_;

   $self->{width}  = $width;
   $self->{height} = $height;

   # i am sure this can be done more elegantly
   @{$self->{map}} = @{$self->{map}}[0 .. $width - 1];

   for (@{$self->{map}}) {
      @$_ = @$_[0 .. $height - 1];
   }
}

sub as_archlist {
   my ($self) = @_;

   # wing map so we have no extra-map arches
   $self->resize ($self->{width}, $self->{height});

   my @arch;

   for my $x (0 .. $self->{width} - 1) {
      my $ass = $self->{map}[$x];
      for my $y (0 .. $self->{height} - 1) {
         for my $a (@{ $ass->[$y] || [] }) {
            # note: big faces _may_ span map boundaries

            my %a = %$a;
            delete $a{x};
            delete $a{y};
            $a{x} = $x if $x;
            $a{y} = $y if $y;

            push @arch, \%a;
         }
      }
   }

   # now assemble meta info
   my %meta = %{$self->{info}};
   $meta{x} = $self->{width};
   $meta{y} = $self->{height};

   unshift @arch, \%meta;

   \@arch
}

sub as_mapstring {
   my ($self) = @_;

   my $arch = $self->as_archlist;

   my $str;

   my $append; $append = sub {
      my %a = %{$_[0]};

      $str .= "arch " . (delete $a{_name}) . "\n";

      my $inv = delete $a{arch};

      # put inventory last
      for my $k (sort keys %a) {
         if (my $end = $Crossfire::FIELD_MULTILINE{$k}) {
            $a{$k} =~ s/\n$//;
            $str .= "$k\n$a{$k}\n$end\n";
         } else {
            $str .= "$k $a{$k}\n";
         }
      }

      if ($inv) {
         $append->($_) for @$inv;
      }

      $str .= "end\n";

   };
      
   for (@$arch) {
      $append->($_);
   }

   $str
}

sub write_file {
   my ($self, $path) = @_;

   open my $fh, ">", "$path~"    or Carp::croak "$path~: $!";
   print $fh $self->as_mapstring or Carp::croak "$path~: $!";
   close $fh                     or Carp::croak "$path~: $!";

   rename "$path~", $path;
}

=head1 AUTHOR

 Marc Lehmann <schmorp@schmorp.de>
 http://home.schmorp.de/

 Robin Redeker <elmex@ta-sa.org>
 http://www.ta-sa.org/

=cut

1
Revision:	1.3
Committed:	Thu Feb 9 21:00:33 2006 UTC (18 years, 3 months ago) by root
Branch:	MAIN
Changes since 1.2:	+6 -4 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	=head1 NAME
2
3			Crossfire::Map - represent a crossfire map
4
5			=cut
6
7			package Crossfire::Map;
8
9			our $VERSION = '0.1';
10
11			use strict;
12
13	root	1.2	use Carp ();
14	root	1.1	use Crossfire;
15
16			use base 'Exporter';
17
18			sub new {
19			my ($class, $width, $height) = @_;
20
21			bless { width => $width, height => $height }, $class
22			}
23
24			sub new_from_file {
25			new_from_archlist {$_[0]} read_arch $_[1]
26			}
27
28			sub new_from_archlist {
29			my ($class, $mapa) = @_;
30
31			my %meta;
32
33			my ($mapx, $mapy);
34
35			my $map;
36
37			for (@{ $mapa->{arch} }) {
38			my ($x, $y) = (delete $_->{x}, delete $_->{y});
39
40			if ($_->{_name} eq "map") {
41			$meta{info} = $_;
42
43			$mapx = $_->{width} \|\| $x;
44			$mapy = $_->{height} \|\| $y;
45			} else {
46			push @{ $map->[$x][$y] }, $_;
47
48			# arch map is unreliable w.r.t. width and height
49			$mapx = $x + 1 if $mapx <= $x;
50			$mapy = $y + 1 if $mapy <= $y;
51			#$mapx = $a->{x} + 1, warn "$mapname: arch '$a->{_name}' outside map width at ($a->{x}\|$a->{y})\n" if $mapx <= $a->{x};
52			#$mapy = $a->{y} + 1, warn "$mapname: arch '$a->{_name}' outside map height at ($a->{x}\|$a->{y})\n" if $mapy <= $a->{y};
53			}
54			}
55
56			$meta{width} = $mapx;
57			$meta{height} = $mapy;
58			$meta{map} = $map;
59
60			bless \%meta, $class
61			}
62
63			sub new_pickmap {
64			my ($class, $archs, $width) = @_;
65
66			# sort archs alphabetically
67			my $archs = [ sort { ${$a}->{_name} cmp ${$b}->{_name} } @$archs ];
68
69			$width \|\|= 10; # default width
70
71			my $num = @$archs;
72			my $map = { };
73			# overall placement coords
74			my $x = 0;
75			my $y = 0;
76
77			my ($maxh, $maxw) = (0, 0); # maximum sizes, to set map width/height later
78			my $drawn_archs = 1; # line-break counter
79			my $max_line_height = 1;
80
81			for (my $i = 0; $i < $num; $i++) {
82			defined ${$archs->[$i]}->{face} or next;
83
84			# check whether this tile was already written (see below at (b))
85			unless (defined $map->{map}[$x][$y]) {
86			my ($xoffs, $yoffs, $arch_w, $arch_h) = arch_extends (${$archs->[$i]});
87
88			if ($x + $arch_w > $width) {
89			$y += $max_line_height;
90			$max_line_height = 1;
91			$x = 0;
92			}
93
94			# these are special placement coords, for chained faces which
95			# have a special placement offset
96			my ($place_x, $place_y) = ($x, $y);
97			$xoffs < 0 and
98			$place_x += -$xoffs;
99			$yoffs < 0 and
100			$place_y += -$yoffs;
101
102			# iterate over the tiles this arch takes
103			# NOTE: Chained archs are maybe not a rectangle, but i don't care
104			# much for that on pickmaps
105
106			for (my $xi = 0; $xi < $arch_w; $xi++) {
107			for (my $yi = 0; $yi < $arch_h; $yi++) {
108
109			my ($lx, $ly) = ($x + $xi, $y + $yi);
110
111			if ($lx == $place_x and $ly == $place_y) {
112			push @{$map->{map}[$place_x][$place_y]}, my $a = ${$archs->[$i]};
113
114			} else {
115
116			# (b): here we set occupied tiles, but without the arch
117			$map->{map}[$lx][$ly] = [];
118			}
119			}
120			}
121			$drawn_archs++;
122
123			$x += $arch_w;
124
125			$max_line_height < $arch_h
126			and $max_line_height = $arch_h;
127
128			} else {
129			$i--;
130			}
131
132			$maxw = List::Util::max $maxw, $x;
133			$maxh = List::Util::max $maxh, $y;
134			}
135
136			$map->{height} = $maxh;
137			$map->{width} = $maxw;
138
139	root	1.2	$map
140			}
141
142			sub resize {
143			my ($self, $width, $height) = @_;
144
145			$self->{width} = $width;
146			$self->{height} = $height;
147
148			# i am sure this can be done more elegantly
149			@{$self->{map}} = @{$self->{map}}[0 .. $width - 1];
150
151			for (@{$self->{map}}) {
152			@$_ = @$_[0 .. $height - 1];
153			}
154			}
155
156			sub as_archlist {
157			my ($self) = @_;
158
159			# wing map so we have no extra-map arches
160			$self->resize ($self->{width}, $self->{height});
161
162			my @arch;
163
164			for my $x (0 .. $self->{width} - 1) {
165			my $ass = $self->{map}[$x];
166			for my $y (0 .. $self->{height} - 1) {
167			for my $a (@{ $ass->[$y] \|\| [] }) {
168			# note: big faces _may_ span map boundaries
169
170			my %a = %$a;
171			delete $a{x};
172			delete $a{y};
173			$a{x} = $x if $x;
174			$a{y} = $y if $y;
175
176			push @arch, \%a;
177			}
178			}
179			}
180
181			# now assemble meta info
182			my %meta = %{$self->{info}};
183			$meta{x} = $self->{width};
184			$meta{y} = $self->{height};
185
186			unshift @arch, \%meta;
187
188			\@arch
189			}
190
191			sub as_mapstring {
192			my ($self) = @_;
193
194			my $arch = $self->as_archlist;
195
196			my $str;
197
198			my $append; $append = sub {
199			my %a = %{$_[0]};
200
201			$str .= "arch " . (delete $a{_name}) . "\n";
202
203	root	1.3	my $inv = delete $a{arch};
204	root	1.2
205	root	1.3	# put inventory last
206	root	1.2	for my $k (sort keys %a) {
207			if (my $end = $Crossfire::FIELD_MULTILINE{$k}) {
208			$a{$k} =~ s/\n$//;
209			$str .= "$k\n$a{$k}\n$end\n";
210			} else {
211			$str .= "$k $a{$k}\n";
212			}
213			}
214
215	root	1.3	if ($inv) {
216			$append->($_) for @$inv;
217			}
218
219	root	1.2	$str .= "end\n";
220
221			};
222
223			for (@$arch) {
224			$append->($_);
225			}
226
227			$str
228			}
229
230			sub write_file {
231			my ($self, $path) = @_;
232
233			open my $fh, ">", "$path~" or Carp::croak "$path~: $!";
234			print $fh $self->as_mapstring or Carp::croak "$path~: $!";
235			close $fh or Carp::croak "$path~: $!";
236
237			rename "$path~", $path;
238	root	1.1	}
239
240			=head1 AUTHOR
241
242			Marc Lehmann <schmorp@schmorp.de>
243			http://home.schmorp.de/
244
245			Robin Redeker <elmex@ta-sa.org>
246			http://www.ta-sa.org/
247
248			=cut
249
250			1