deliantra/Deliantra/Deliantra.pm

package Crossfire;
=head1 NAME

Crossfire - Crossfire maphandling

=cut

our $VERSION = '1.21';

use strict;

use Storable;
use List::Util qw(max);

#use Gtk2;

#init Gtk2::Gdk;

my $LIB = $ENV{CROSSFIRE_LIBDIR}
   or die "\$CROSSFIRE_LIBDIR must be set\n";

my $VARDIR = "$ENV{HOME}/.gcfedit";
mkdir $VARDIR;

sub T (){ 32 }

sub read_pak($) {
   my ($path) = @_;

   eval {
      -M "$VARDIR/crossfire.pak.pst" < -M $path
      && Storable::retrieve "$VARDIR/crossfire.pak.pst"
   } or do {
      my %pak;

      open my $fh, "<:raw", $path
         or die "$_[0]: $!";
      while (<$fh>) {
         my ($type, $id, $len, $path) = split;
         $path =~ s/.*\///;
         read $fh, $pak{$path}, $len;
      }

      Storable::nstore \%pak, "$VARDIR/crossfire.pak.pst";

      \%pak
   }
}

sub read_arch($;$) {
   my ($path, $cache) = @_;

   eval {
      $cache
      && -M "$VARDIR/$path.pst" < -M $path
      && Storable::retrieve "$VARDIR/$path.pst"
   } or do {
      my %arc;
      my ($more, $prev);

      open my $fh, "<:raw", $path
         or die "$path: $!";

      my $parse_block; $parse_block = sub {
         my %arc = @_;

         while (<$fh>) {
            s/\s+$//;
            if (/^end$/i) {
               last;
            } elsif (/^arch (\S+)$/) {
               push @{ $arc{inventory} }, $parse_block->(_name => $1);
            } elsif (/^lore$/) {
               while (<$fh>) {
                  last if /^endlore\s*$/i;
                  $arc{lore} .= $_;
               }
            } elsif (/^msg$/) {
               while (<$fh>) {
                  last if /^endmsg\s*$/i;
                  $arc{msg} .= $_;
               }
            } elsif (/^(\S+)\s*(.*)$/) {
               $arc{lc $1} = $2;
            } elsif (/^\s*($|#)/) {
               #
            } else {
               warn "$path: unparsable line '$_' in arch $arc{_name}";
            }
         }

         \%arc
      };

      while (<$fh>) {
         s/\s+$//;
         if (/^more$/i) {
            $more = $prev;
         } elsif (/^object (\S+)$/i) {
            my $name = $1;
            my $arc = $parse_block->(_name => $name);

            if ($more) {
               $more->{more} = $arc;
            } else {
               $arc{$name} = $arc;
            }
            $prev = $arc;
            $more = undef;
         } elsif (/^arch (\S+)$/i) {
            push @{ $arc{arch} }, $parse_block->(_name => $1);
         } elsif (/^\s*($|#)/) {
            #
         } else {
            warn "$path: unparseable top-level line '$_'";
         }
      }

      undef $parse_block; # work around bug in perl not freeing $fh etc.

      if ($cache) {
         Storable::nstore \%arc, "$path.pst";
         utime +(stat $path)[8,9], "$path.pst";
      }

      \%arc
   }
}

sub cfmap_meta($;$) {
   my ($self, $mapa, $mapname) = @_;

   my $arch = $self->{arch};

   my %meta;

   my ($mapx, $mapy);

   my $map;

   for (@{ $mapa->{arch} }) {
      my ($x, $y) = ($_->{x}, $_->{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;

   my %draw_info;
   my %map_info;

   # first pass, gather face stacking order, border and corner info
   for my $x (0 .. $mapx - 1) {
      my $col = $map->[$x];
      for my $y (0 .. $mapy - 1) {
         my $as = $col->[$y] || [];

         for my $layer (0 .. $#$as) {
            my $a = $as->[$layer];

            my $o = $arch->{$a->{_name}}
               or (warn "$mapname: arch '$a->{_name}' not found at ($x|$y)\n"), next;

            #my $is_floor = exists $a->{is_floor}    ? $a->{is_floor}    : $o->{is_floor};
            my $level = $layer * 256;

            $level -= 100 * 256 if $o->{_name} eq "blocked";

            while ($o) {
               my $face = $a->{face} || $o->{face};

               my $mx = $x + $o->{x};
               my $my = $y + $o->{y};

               last if 0 > $mx || $mx >= $mapx
                    || 0 > $my || $my >= $mapy;

               push @{ $map_info{$level}{$mx, $my} }, $a;

               $o = $o->{more};
               $level = ($layer + 1000) * 2; # put "big things" on top, no matter what
            }
         }
      }
   }

   # third pass, gather meta info
   for my $level (sort { $a <=> $b } keys %map_info) {
      my $info = $map_info{$level};

         while (my ($xy, $as) = each %$info) {
            my ($x, $y) = split $;, $xy;

            next if $x < 0 || $x >= $mapx
                 || $y < 0 || $y >= $mapy;

            push @{ $meta{map}[$x][$y] }, $_ for @$as;
         }
   }

   \%meta
}

sub new {
   my $class = shift;
   my $self = bless { }, $class;
   $self->{arch} = read_arch "$LIB/archetypes";
   $self->{tile} = read_pak  "$LIB/crossfire.0";
   $self
}

sub read {
   my ($self, $file) = @_;
   my $mapa = read_arch $file;
   my $map = $self->cfmap_meta ($mapa, $file);
   print "READ: ".join(',', %{$map->{info}})."\n";
   return $map;
}

=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.1
Committed:	Sat Feb 4 23:24:03 2006 UTC (18 years, 3 months ago) by elmex
Branch:	MAIN
Log Message:	inital checkin of the Crossfire module and the test script
#	User	Rev	Content
1	elmex	1.1	package Crossfire;
2			=head1 NAME
3
4			Crossfire - Crossfire maphandling
5
6			=cut
7
8			our $VERSION = '1.21';
9
10			use strict;
11
12			use Storable;
13			use List::Util qw(max);
14
15			#use Gtk2;
16
17			#init Gtk2::Gdk;
18
19			my $LIB = $ENV{CROSSFIRE_LIBDIR}
20			or die "\$CROSSFIRE_LIBDIR must be set\n";
21
22			my $VARDIR = "$ENV{HOME}/.gcfedit";
23			mkdir $VARDIR;
24
25			sub T (){ 32 }
26
27			sub read_pak($) {
28			my ($path) = @_;
29
30			eval {
31			-M "$VARDIR/crossfire.pak.pst" < -M $path
32			&& Storable::retrieve "$VARDIR/crossfire.pak.pst"
33			} or do {
34			my %pak;
35
36			open my $fh, "<:raw", $path
37			or die "$_[0]: $!";
38			while (<$fh>) {
39			my ($type, $id, $len, $path) = split;
40			$path =~ s/.*\///;
41			read $fh, $pak{$path}, $len;
42			}
43
44			Storable::nstore \%pak, "$VARDIR/crossfire.pak.pst";
45
46			\%pak
47			}
48			}
49
50			sub read_arch($;$) {
51			my ($path, $cache) = @_;
52
53			eval {
54			$cache
55			&& -M "$VARDIR/$path.pst" < -M $path
56			&& Storable::retrieve "$VARDIR/$path.pst"
57			} or do {
58			my %arc;
59			my ($more, $prev);
60
61			open my $fh, "<:raw", $path
62			or die "$path: $!";
63
64			my $parse_block; $parse_block = sub {
65			my %arc = @_;
66
67			while (<$fh>) {
68			s/\s+$//;
69			if (/^end$/i) {
70			last;
71			} elsif (/^arch (\S+)$/) {
72			push @{ $arc{inventory} }, $parse_block->(_name => $1);
73			} elsif (/^lore$/) {
74			while (<$fh>) {
75			last if /^endlore\s*$/i;
76			$arc{lore} .= $_;
77			}
78			} elsif (/^msg$/) {
79			while (<$fh>) {
80			last if /^endmsg\s*$/i;
81			$arc{msg} .= $_;
82			}
83			} elsif (/^(\S+)\s(.)$/) {
84			$arc{lc $1} = $2;
85			} elsif (/^\s*($\|#)/) {
86			#
87			} else {
88			warn "$path: unparsable line '$_' in arch $arc{_name}";
89			}
90			}
91
92			\%arc
93			};
94
95			while (<$fh>) {
96			s/\s+$//;
97			if (/^more$/i) {
98			$more = $prev;
99			} elsif (/^object (\S+)$/i) {
100			my $name = $1;
101			my $arc = $parse_block->(_name => $name);
102
103			if ($more) {
104			$more->{more} = $arc;
105			} else {
106			$arc{$name} = $arc;
107			}
108			$prev = $arc;
109			$more = undef;
110			} elsif (/^arch (\S+)$/i) {
111			push @{ $arc{arch} }, $parse_block->(_name => $1);
112			} elsif (/^\s*($\|#)/) {
113			#
114			} else {
115			warn "$path: unparseable top-level line '$_'";
116			}
117			}
118
119			undef $parse_block; # work around bug in perl not freeing $fh etc.
120
121			if ($cache) {
122			Storable::nstore \%arc, "$path.pst";
123			utime +(stat $path)[8,9], "$path.pst";
124			}
125
126			\%arc
127			}
128			}
129
130			sub cfmap_meta($;$) {
131			my ($self, $mapa, $mapname) = @_;
132
133			my $arch = $self->{arch};
134
135			my %meta;
136
137			my ($mapx, $mapy);
138
139			my $map;
140
141			for (@{ $mapa->{arch} }) {
142			my ($x, $y) = ($_->{x}, $_->{y});
143
144			if ($_->{_name} eq "map") {
145			$meta{info} = $_;
146
147			$mapx = $_->{width} \|\| $x;
148			$mapy = $_->{height} \|\| $y;
149			} else {
150			push @{ $map->[$x][$y] }, $_;
151
152			# arch map is unreliable w.r.t. width and height
153			$mapx = $x + 1 if $mapx <= $x;
154			$mapy = $y + 1 if $mapy <= $y;
155			#$mapx = $a->{x} + 1, warn "$mapname: arch '$a->{_name}' outside map width at ($a->{x}\|$a->{y})\n" if $mapx <= $a->{x};
156			#$mapy = $a->{y} + 1, warn "$mapname: arch '$a->{_name}' outside map height at ($a->{x}\|$a->{y})\n" if $mapy <= $a->{y};
157			}
158			}
159
160			$meta{width} = $mapx;
161			$meta{height} = $mapy;
162
163			my %draw_info;
164			my %map_info;
165
166			# first pass, gather face stacking order, border and corner info
167			for my $x (0 .. $mapx - 1) {
168			my $col = $map->[$x];
169			for my $y (0 .. $mapy - 1) {
170			my $as = $col->[$y] \|\| [];
171
172			for my $layer (0 .. $#$as) {
173			my $a = $as->[$layer];
174
175			my $o = $arch->{$a->{_name}}
176			or (warn "$mapname: arch '$a->{_name}' not found at ($x\|$y)\n"), next;
177
178			#my $is_floor = exists $a->{is_floor} ? $a->{is_floor} : $o->{is_floor};
179			my $level = $layer * 256;
180
181			$level -= 100 * 256 if $o->{_name} eq "blocked";
182
183			while ($o) {
184			my $face = $a->{face} \|\| $o->{face};
185
186			my $mx = $x + $o->{x};
187			my $my = $y + $o->{y};
188
189			last if 0 > $mx \|\| $mx >= $mapx
190			\|\| 0 > $my \|\| $my >= $mapy;
191
192			push @{ $map_info{$level}{$mx, $my} }, $a;
193
194			$o = $o->{more};
195			$level = ($layer + 1000) * 2; # put "big things" on top, no matter what
196			}
197			}
198			}
199			}
200
201			# third pass, gather meta info
202			for my $level (sort { $a <=> $b } keys %map_info) {
203			my $info = $map_info{$level};
204
205			while (my ($xy, $as) = each %$info) {
206			my ($x, $y) = split $;, $xy;
207
208			next if $x < 0 \|\| $x >= $mapx
209			\|\| $y < 0 \|\| $y >= $mapy;
210
211			push @{ $meta{map}[$x][$y] }, $_ for @$as;
212			}
213			}
214
215			\%meta
216			}
217
218			sub new {
219			my $class = shift;
220			my $self = bless { }, $class;
221			$self->{arch} = read_arch "$LIB/archetypes";
222			$self->{tile} = read_pak "$LIB/crossfire.0";
223			$self
224			}
225
226			sub read {
227			my ($self, $file) = @_;
228			my $mapa = read_arch $file;
229			my $map = $self->cfmap_meta ($mapa, $file);
230			print "READ: ".join(',', %{$map->{info}})."\n";
231			return $map;
232			}
233
234			=head1 AUTHOR
235
236			Marc Lehmann <schmorp@schmorp.de>
237			http://home.schmorp.de/
238
239			Robin Redeker <elmex@ta-sa.org>
240			http://www.ta-sa.org/
241
242			=cut
243			1;