deliantra/Deliantra/Deliantra.pm

package Crossfire;
=head1 NAME

Crossfire - Crossfire maphandling

=cut

our $VERSION = '0.1';

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) = @_;

   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.

   \%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.3
Committed:	Sat Feb 4 23:56:14 2006 UTC (18 years, 3 months ago) by elmex
Branch:	MAIN
Changes since 1.2:	+1 -1 lines
Log Message:	added makefile
#	User	Rev	Content
1	elmex	1.1	package Crossfire;
2			=head1 NAME
3
4			Crossfire - Crossfire maphandling
5
6			=cut
7
8	elmex	1.3	our $VERSION = '0.1';
9	elmex	1.1
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	elmex	1.2	my ($path) = @_;
52	elmex	1.1
53	elmex	1.2	my %arc;
54			my ($more, $prev);
55
56			open my $fh, "<:raw", $path
57			or die "$path: $!";
58	elmex	1.1
59	elmex	1.2	my $parse_block; $parse_block = sub {
60			my %arc = @_;
61	elmex	1.1
62			while (<$fh>) {
63			s/\s+$//;
64	elmex	1.2	if (/^end$/i) {
65			last;
66			} elsif (/^arch (\S+)$/) {
67			push @{ $arc{inventory} }, $parse_block->(_name => $1);
68			} elsif (/^lore$/) {
69			while (<$fh>) {
70			last if /^endlore\s*$/i;
71			$arc{lore} .= $_;
72			}
73			} elsif (/^msg$/) {
74			while (<$fh>) {
75			last if /^endmsg\s*$/i;
76			$arc{msg} .= $_;
77	elmex	1.1	}
78	elmex	1.2	} elsif (/^(\S+)\s(.)$/) {
79			$arc{lc $1} = $2;
80	elmex	1.1	} elsif (/^\s*($\|#)/) {
81			#
82			} else {
83	elmex	1.2	warn "$path: unparsable line '$_' in arch $arc{_name}";
84	elmex	1.1	}
85			}
86
87	elmex	1.2	\%arc
88			};
89
90			while (<$fh>) {
91			s/\s+$//;
92			if (/^more$/i) {
93			$more = $prev;
94			} elsif (/^object (\S+)$/i) {
95			my $name = $1;
96			my $arc = $parse_block->(_name => $name);
97	elmex	1.1
98	elmex	1.2	if ($more) {
99			$more->{more} = $arc;
100			} else {
101			$arc{$name} = $arc;
102			}
103			$prev = $arc;
104			$more = undef;
105			} elsif (/^arch (\S+)$/i) {
106			push @{ $arc{arch} }, $parse_block->(_name => $1);
107			} elsif (/^\s*($\|#)/) {
108			#
109			} else {
110			warn "$path: unparseable top-level line '$_'";
111	elmex	1.1	}
112	elmex	1.2	}
113	elmex	1.1
114	elmex	1.2	undef $parse_block; # work around bug in perl not freeing $fh etc.
115
116			\%arc
117	elmex	1.1	}
118
119			sub cfmap_meta($;$) {
120			my ($self, $mapa, $mapname) = @_;
121
122			my $arch = $self->{arch};
123
124			my %meta;
125
126			my ($mapx, $mapy);
127
128			my $map;
129
130			for (@{ $mapa->{arch} }) {
131			my ($x, $y) = ($_->{x}, $_->{y});
132
133			if ($_->{_name} eq "map") {
134			$meta{info} = $_;
135
136			$mapx = $_->{width} \|\| $x;
137			$mapy = $_->{height} \|\| $y;
138			} else {
139			push @{ $map->[$x][$y] }, $_;
140
141			# arch map is unreliable w.r.t. width and height
142			$mapx = $x + 1 if $mapx <= $x;
143			$mapy = $y + 1 if $mapy <= $y;
144			#$mapx = $a->{x} + 1, warn "$mapname: arch '$a->{_name}' outside map width at ($a->{x}\|$a->{y})\n" if $mapx <= $a->{x};
145			#$mapy = $a->{y} + 1, warn "$mapname: arch '$a->{_name}' outside map height at ($a->{x}\|$a->{y})\n" if $mapy <= $a->{y};
146			}
147			}
148
149			$meta{width} = $mapx;
150			$meta{height} = $mapy;
151
152			my %draw_info;
153			my %map_info;
154
155			# first pass, gather face stacking order, border and corner info
156			for my $x (0 .. $mapx - 1) {
157			my $col = $map->[$x];
158			for my $y (0 .. $mapy - 1) {
159			my $as = $col->[$y] \|\| [];
160
161			for my $layer (0 .. $#$as) {
162			my $a = $as->[$layer];
163
164			my $o = $arch->{$a->{_name}}
165			or (warn "$mapname: arch '$a->{_name}' not found at ($x\|$y)\n"), next;
166
167			#my $is_floor = exists $a->{is_floor} ? $a->{is_floor} : $o->{is_floor};
168			my $level = $layer * 256;
169
170			$level -= 100 * 256 if $o->{_name} eq "blocked";
171
172			while ($o) {
173			my $face = $a->{face} \|\| $o->{face};
174
175			my $mx = $x + $o->{x};
176			my $my = $y + $o->{y};
177
178			last if 0 > $mx \|\| $mx >= $mapx
179			\|\| 0 > $my \|\| $my >= $mapy;
180
181			push @{ $map_info{$level}{$mx, $my} }, $a;
182
183			$o = $o->{more};
184			$level = ($layer + 1000) * 2; # put "big things" on top, no matter what
185			}
186			}
187			}
188			}
189
190			# third pass, gather meta info
191			for my $level (sort { $a <=> $b } keys %map_info) {
192			my $info = $map_info{$level};
193
194			while (my ($xy, $as) = each %$info) {
195			my ($x, $y) = split $;, $xy;
196
197			next if $x < 0 \|\| $x >= $mapx
198			\|\| $y < 0 \|\| $y >= $mapy;
199
200			push @{ $meta{map}[$x][$y] }, $_ for @$as;
201			}
202			}
203
204			\%meta
205			}
206
207			sub new {
208			my $class = shift;
209			my $self = bless { }, $class;
210			$self->{arch} = read_arch "$LIB/archetypes";
211			$self->{tile} = read_pak "$LIB/crossfire.0";
212			$self
213			}
214
215			sub read {
216			my ($self, $file) = @_;
217			my $mapa = read_arch $file;
218			my $map = $self->cfmap_meta ($mapa, $file);
219			print "READ: ".join(',', %{$map->{info}})."\n";
220			return $map;
221			}
222
223			=head1 AUTHOR
224
225			Marc Lehmann <schmorp@schmorp.de>
226			http://home.schmorp.de/
227
228			Robin Redeker <elmex@ta-sa.org>
229			http://www.ta-sa.org/
230
231			=cut
232			1;