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 { info => { _name => 'map' }, 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 $max_line_height = 1;

   for (my $i = 0; $i < $num; $i++) {
      # check whether this tile was already written (see below at (b))
      unless (defined $map->{map}[$x][$y]) {
         my ($x1, $y1, $x2, $y2) = arch_extents ${$archs->[$i]};

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

         $map->{map}[$x - $x1][$y - $y1] = [${$archs->[$i]}];

         $x += $x2 - $x1 + 1;

         $max_line_height = List::Util::max $max_line_height, $y2 - $y1 + 1;

      } else {
         $i--;
      }

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

   $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] || [] }) {
            next if $a->{_virtual};

            # 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
   if ($self->{info}) {
      my %meta = %{$self->{info}};

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

      unshift @arch, Crossfire::normalize_arch \%meta;
   }

   \@arch
}

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

   my $arch = $self->as_archlist;

   my $str;

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

      Crossfire::normalize_arch \%a;

      # undo the bit-split we did before
      if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) {
         $a{attack_movement} = (delete $a{attack_movement_bits_0_3})
                             | (delete $a{attack_movement_bits_4_7});
      }

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

      my $inv = delete $a{inventory};
      delete $a{more}; # arches do not support 'more', but old maps can contain some

      my @kv;

      for ($a{_name} eq "map"
           ? @Crossfire::FIELD_ORDER_MAP
           : @Crossfire::FIELD_ORDER) {
         push @kv, [$_, delete $a{$_}]
            if exists $a{$_};
      }

      for (sort keys %a) {
         next if /^_/; # ignore our _-keys
         push @kv, [$_, delete $a{$_}];
      }

      for (@kv) {
         my ($k, $v) = @$_;

         if (my $end = $Crossfire::FIELD_MULTILINE{$k}) {
            $v =~ s/\n$//;
            $str .= "$k\n$v\n$end\n";
         } elsif (exists $Crossfire::FIELD_MOVEMENT{$k}) {
            if ($v & ~Crossfire::MOVE_ALL or !$v) {
               $str .= "$k $v\n";

            } elsif ($v & Crossfire::MOVE_ALLBIT) {
               $str .= "$k all";

               $str .= " -walk"     unless $v & Crossfire::MOVE_WALK;
               $str .= " -fly_low"  unless $v & Crossfire::MOVE_FLY_LOW;
               $str .= " -fly_high" unless $v & Crossfire::MOVE_FLY_HIGH;
               $str .= " -swim"     unless $v & Crossfire::MOVE_SWIM;
               $str .= " -boat"     unless $v & Crossfire::MOVE_BOAT;

               $str .= "\n";

            } else {
               $str .= $k;

               $str .= " walk"     if $v & Crossfire::MOVE_WALK;
               $str .= " fly_low"  if $v & Crossfire::MOVE_FLY_LOW;
               $str .= " fly_high" if $v & Crossfire::MOVE_FLY_HIGH;
               $str .= " swim"     if $v & Crossfire::MOVE_SWIM;
               $str .= " boat"     if $v & Crossfire::MOVE_BOAT;

               $str .= "\n";
            }
         } else {
            $str .= "$k $v\n";
         }
      }

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

      $str .= "end\n";

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

   $str
}

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

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

   stat $path;
   
   chmod +(stat _)[2] & 0777, "$path~";
   chown +(stat _)[4,5], "$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.21
Committed:	Fri Mar 31 21:06:49 2006 UTC (18 years, 2 months ago) by root
Branch:	MAIN
Changes since 1.20:	+3 -3 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	elmex	1.8	bless { info => { _name => 'map' }, width => $width, height => $height }, $class
22	root	1.1	}
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	root	1.20	my $archs = [ sort { $a->{_name} cmp $b->{_name} } @$archs ];
68	root	1.1
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 $max_line_height = 1;
79
80			for (my $i = 0; $i < $num; $i++) {
81			# check whether this tile was already written (see below at (b))
82			unless (defined $map->{map}[$x][$y]) {
83	root	1.5	my ($x1, $y1, $x2, $y2) = arch_extents ${$archs->[$i]};
84	root	1.1
85	root	1.5	if ($x + $x2 - $x1 + 1 > $width) {
86	root	1.1	$y += $max_line_height;
87			$max_line_height = 1;
88			$x = 0;
89			}
90
91	root	1.5	$map->{map}[$x - $x1][$y - $y1] = [${$archs->[$i]}];
92	root	1.1
93	root	1.5	$x += $x2 - $x1 + 1;
94	root	1.1
95	root	1.5	$max_line_height = List::Util::max $max_line_height, $y2 - $y1 + 1;
96	root	1.1
97			} else {
98			$i--;
99			}
100
101			$maxw = List::Util::max $maxw, $x;
102	root	1.7	$maxh = List::Util::max $maxh, $y + $max_line_height;
103	root	1.1	}
104
105			$map->{height} = $maxh;
106			$map->{width} = $maxw;
107
108	root	1.2	$map
109			}
110
111			sub resize {
112			my ($self, $width, $height) = @_;
113
114			$self->{width} = $width;
115			$self->{height} = $height;
116
117			# i am sure this can be done more elegantly
118			@{$self->{map}} = @{$self->{map}}[0 .. $width - 1];
119
120			for (@{$self->{map}}) {
121			@$_ = @$_[0 .. $height - 1];
122			}
123			}
124
125			sub as_archlist {
126			my ($self) = @_;
127
128			# wing map so we have no extra-map arches
129			$self->resize ($self->{width}, $self->{height});
130
131			my @arch;
132
133			for my $x (0 .. $self->{width} - 1) {
134			my $ass = $self->{map}[$x];
135			for my $y (0 .. $self->{height} - 1) {
136			for my $a (@{ $ass->[$y] \|\| [] }) {
137	root	1.6	next if $a->{_virtual};
138
139	root	1.2	# note: big faces _may_ span map boundaries
140
141			my %a = %$a;
142			delete $a{x};
143			delete $a{y};
144			$a{x} = $x if $x;
145			$a{y} = $y if $y;
146
147			push @arch, \%a;
148			}
149			}
150			}
151
152			# now assemble meta info
153	root	1.18	if ($self->{info}) {
154			my %meta = %{$self->{info}};
155	root	1.2
156	root	1.18	$meta{width} = $self->{width};
157			$meta{height} = $self->{height};
158	root	1.4
159	root	1.18	unshift @arch, Crossfire::normalize_arch \%meta;
160			}
161	root	1.2
162			\@arch
163			}
164
165			sub as_mapstring {
166			my ($self) = @_;
167
168			my $arch = $self->as_archlist;
169
170			my $str;
171
172			my $append; $append = sub {
173			my %a = %{$_[0]};
174
175	root	1.4	Crossfire::normalize_arch \%a;
176
177	root	1.15	# undo the bit-split we did before
178	root	1.16	if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) {
179	root	1.15	$a{attack_movement} = (delete $a{attack_movement_bits_0_3})
180			\| (delete $a{attack_movement_bits_4_7});
181			}
182
183	root	1.14	$str .= "arch $a{_name}\n";
184	root	1.2
185	root	1.10	my $inv = delete $a{inventory};
186	root	1.14	delete $a{more}; # arches do not support 'more', but old maps can contain some
187	root	1.2
188	root	1.12	my @kv;
189
190	root	1.14	for ($a{_name} eq "map"
191			? @Crossfire::FIELD_ORDER_MAP
192			: @Crossfire::FIELD_ORDER) {
193	root	1.12	push @kv, [$_, delete $a{$_}]
194			if exists $a{$_};
195			}
196
197			for (sort keys %a) {
198			next if /^_/; # ignore our _-keys
199			push @kv, [$_, delete $a{$_}];
200			}
201
202			for (@kv) {
203			my ($k, $v) = @$_;
204	root	1.6
205	root	1.2	if (my $end = $Crossfire::FIELD_MULTILINE{$k}) {
206	root	1.12	$v =~ s/\n$//;
207			$str .= "$k\n$v\n$end\n";
208	root	1.17	} elsif (exists $Crossfire::FIELD_MOVEMENT{$k}) {
209			if ($v & ~Crossfire::MOVE_ALL or !$v) {
210			$str .= "$k $v\n";
211
212			} elsif ($v & Crossfire::MOVE_ALLBIT) {
213			$str .= "$k all";
214
215			$str .= " -walk" unless $v & Crossfire::MOVE_WALK;
216			$str .= " -fly_low" unless $v & Crossfire::MOVE_FLY_LOW;
217			$str .= " -fly_high" unless $v & Crossfire::MOVE_FLY_HIGH;
218			$str .= " -swim" unless $v & Crossfire::MOVE_SWIM;
219			$str .= " -boat" unless $v & Crossfire::MOVE_BOAT;
220
221			$str .= "\n";
222
223			} else {
224			$str .= $k;
225
226			$str .= " walk" if $v & Crossfire::MOVE_WALK;
227			$str .= " fly_low" if $v & Crossfire::MOVE_FLY_LOW;
228			$str .= " fly_high" if $v & Crossfire::MOVE_FLY_HIGH;
229			$str .= " swim" if $v & Crossfire::MOVE_SWIM;
230			$str .= " boat" if $v & Crossfire::MOVE_BOAT;
231
232			$str .= "\n";
233			}
234	root	1.2	} else {
235	root	1.12	$str .= "$k $v\n";
236	root	1.2	}
237			}
238
239	root	1.3	if ($inv) {
240			$append->($_) for @$inv;
241			}
242
243	root	1.2	$str .= "end\n";
244
245			};
246
247			for (@$arch) {
248			$append->($_);
249			}
250
251			$str
252			}
253
254			sub write_file {
255			my ($self, $path) = @_;
256
257	root	1.21	open my $fh, ">:raw:utf8", "$path~" or Carp::croak "$path~: $!";
258			print $fh $self->as_mapstring or Carp::croak "$path~: $!";
259			close $fh or Carp::croak "$path~: $!";
260	root	1.2
261	root	1.19	stat $path;
262
263			chmod +(stat _)[2] & 0777, "$path~";
264			chown +(stat _)[4,5], "$path~";
265
266	root	1.2	rename "$path~", $path;
267	root	1.1	}
268
269			=head1 AUTHOR
270
271			Marc Lehmann <schmorp@schmorp.de>
272			http://home.schmorp.de/
273
274			Robin Redeker <elmex@ta-sa.org>
275			http://www.ta-sa.org/
276
277			=cut
278
279			1