--- deliantra/Deliantra/Deliantra.pm	2006/02/04 23:56:14	1.3
+++ deliantra/Deliantra/Deliantra.pm	2006/02/05 00:18:26	1.4
@@ -1,10 +1,11 @@
-package Crossfire;
 =head1 NAME
 
 Crossfire - Crossfire maphandling
 
 =cut
 
+package Crossfire;
+
 our $VERSION = '0.1';
 
 use strict;
@@ -12,24 +13,21 @@
 use Storable;
 use List::Util qw(max);
 
-#use Gtk2;
-
-#init Gtk2::Gdk;
-
-my $LIB = $ENV{CROSSFIRE_LIBDIR}
+our $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) = @_;
+our $ARCH;
+our $TILE;
+
+sub read_pak($;$) {
+   my ($path, $cache) = @_;
 
    eval {
-      -M "$VARDIR/crossfire.pak.pst" < -M $path
-      && Storable::retrieve "$VARDIR/crossfire.pak.pst"
+      defined $cache
+      && -M $cache < -M $path
+      && Storable::retrieve $cache
    } or do {
       my %pak;
 
@@ -41,85 +39,93 @@
          read $fh, $pak{$path}, $len;
       }
 
-      Storable::nstore \%pak, "$VARDIR/crossfire.pak.pst";
+      Storable::nstore \%pak, $cache
+         if defined $cache;
 
       \%pak
    }
 }
 
 sub read_arch($;$) {
-   my ($path) = @_;
+   my ($path, $cache) = @_;
+
+   eval {
+      defined $cache
+      && -M $cache < -M $path
+      && Storable::retrieve $cache
+   } or do {
+      my %arc;
+      my ($more, $prev);
+
+      open my $fh, "<:raw", $path
+         or die "$path: $!";
 
-   my %arc;
-   my ($more, $prev);
+      my $parse_block; $parse_block = sub {
+         my %arc = @_;
 
-   open my $fh, "<:raw", $path
-      or die "$path: $!";
+         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}";
+            }
+         }
 
-   my $parse_block; $parse_block = sub {
-      my %arc = @_;
+         \%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} .= $_;
+         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;
             }
-         } elsif (/^(\S+)\s*(.*)$/) {
-            $arc{lc $1} = $2;
+            $prev = $arc;
+            $more = undef;
+         } elsif (/^arch (\S+)$/i) {
+            push @{ $arc{arch} }, $parse_block->(_name => $1);
          } elsif (/^\s*($|#)/) {
             #
          } else {
-            warn "$path: unparsable line '$_' in arch $arc{_name}";
+            warn "$path: unparseable top-level line '$_'";
          }
       }
 
-      \%arc
-   };
+      undef $parse_block; # work around bug in perl not freeing $fh etc.
 
-   while (<$fh>) {
-      s/\s+$//;
-      if (/^more$/i) {
-         $more = $prev;
-      } elsif (/^object (\S+)$/i) {
-         my $name = $1;
-         my $arc = $parse_block->(_name => $name);
+      Storable::nstore \%arc, $cache
+         if defined $cache;
 
-         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 '$_'";
-      }
+      \%arc
    }
-
-   undef $parse_block; # work around bug in perl not freeing $fh etc.
-
-   \%arc
 }
 
-sub cfmap_meta($;$) {
-   my ($self, $mapa, $mapname) = @_;
-
-   my $arch = $self->{arch};
+sub arch2map($;$) {
+   my ($mapa) = @_;
 
    my %meta;
 
@@ -149,75 +155,14 @@
    $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 init($) {
+   my ($cachedir) = @_;
 
-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;
+   $ARCH = read_arch "$LIB/archetypes",  "$cachedir/archetypes.pst";
+   $TILE = read_pak  "$LIB/crossfire.0", "$cachedir/crossfire.0.pst";
 }
 
 =head1 AUTHOR
@@ -229,4 +174,5 @@
  http://www.ta-sa.org/
 
 =cut
-1;
+
+1