#!/usr/local/bin/perl
#
# This program is meant to use check crossfire (version 0.90.?) maps.
# Program wanderers through mapfiles and reports all objects that 
# can't be found in the archetypes, all exit that doesn't lead to
# anywhere and all corrupted mapfiles.
#
# By: Tero Haatanen <Tero.Haatanen@lut.fi>
#
# Usage: wanderer.pl directory

# Set if you want to get warnings about spikes, gates, buttons, et al that
# are not connected.  This can be annoying at times, since many maps use
# these objects for decorations.
$CONNECTED = 0;
$LIB   = "/home/hugin/a/crossfire/crossfire/lib";
$ARCH  = "$LIB/archetypes";
$FACES  = "$LIB/faces";
$ANIM  = "$LIB/animations";
$MAPS  = "$LIB/maps";

if (! $ARGV[0]) {
    print "Usage: wanderer.pl map-directory ... > output.log\n";
    exit;
}

# read filenames to @maps
chdir ($MAPS);
while ($area = shift) {
    &maplist ($area);
}

$* = 1;				# use multiline matches

&faces;
&animations;
# read archetypes
&archetypes;


%ex = &collect ('^type 66$');		# type 66 == exit
%tele = &collect ('^type 41$');		# type 41 == teleport
%conn = &collect ('^type (17|18|26|27|29|30|31|32|91|92|93|94)$');
delete $conn{"spikes_moving"};
delete $conn{"magic_ear"};
%players = &collect ('^type 1$');	# type 1 == player
#
# In theory, I don't think any of these should show up in maps.
# For now, I mostly ignore them so I can more easily check out the
# editor directory and verify everything is in place.
%abilities = &collect('^type (2|10|11|12|19|25|43|44|49|50|52|88|97|110|114|121|141|151)$');

# check exits from archetypes
foreach $a (keys (%ex), keys (%tele)) {
    if ($arches {$a} =~ /^food -?\d+$/) {
	print "Warning: Archetype $a has food field.\n";
    }
}

# some general info
print "=" x 70, "\n";
print "Number of mapfiles = " , @maps + 0, "\n";
print "Number of archetypes = " , values(%arches)+0, ":\n";
print " - Exits ("            , values(%ex)+0,      ")\n";
print " - Teleports ("        , values(%tele)+0,    ")\n";
print " - Connected objects (", values(%conn)+0,    ")\n";
print " - Players ("          , values(%players)+0, ")\n";
print "=" x 70, "\n";

# check maps
while ($file = shift (@maps)) {
    &readmap;
}

# summary of missing archetypes 
if (%missing) {
    print "=" x 70, "\n";
    print "Missing archetypes: ", join (", ", sort keys (%missing)), "\n";
}
# if you don't want list of used objects, uncomment next line
# and you can comment also last line check_obj
# (This isn't very useful, but maybe tells something)

#exit;

#&print_usage();

print " Unused object\n";
foreach $a (sort(keys %arches)) {
	print "$a\n" if (!$objects{$a} && !$players{$a} && !$abilities{$a})
}

exit;

sub print_usage() {
    print "=" x 70, "\nArchetype               count\n";
    $total = 0;
    foreach $a (sort by (keys (%objects))) {
	printf ("%-24s%d\n", $a, $objects{$a});
	$total +=  $objects{$a};
    }
    print '-' x 30, "\nTotal objects           $total\n";
}
# return table containing all objects in the map
sub readmap {
    local ($m);
    $last = "";
    $parent = "";
    
    $/ = "\nend\n";
    if (! open (IN, $file)) {
	print "Can't open map file $file\n";
	return;
    }
    $_ = <IN>;
    if (! /^arch map$/) {
	print "Error: file $file isn't mapfile.\n";
	return;
    }
    print "Testing $file, ";
    print /^name (.+)$/ ? $1 : "No mapname";
    print ", size [", /^x (\d+)$/ ? $1 : 16;
    print ",", /^y (\d+)/ ? $1 : 16, "]";

    if (! /^msg$/) {
	print ", No message\n";
    } elsif (/(\w+@\S+)/) {
	print ", $1\n";
    } else {
	print ", Unknown\n";
    }

    while (<IN>) {
	if (($m = (@_ = /^arch \S+\s*$/g)) > 1) {
	    $parent = /^arch (\S+)\s*$/;
	    # object has inventory
	    local ($inv) = $_;
	    while (<IN>) {
		if (/((.|\n)*end\n)(arch (.|\n)*\nend\n)/) {
		    &check_obj ("$inv$1");
		    &check_obj ($3);
		    last;
		} elsif (/^arch (.|\n)*\nend$/) {
		    &check_obj ($_);
		} elsif (/^end$/) {
		    &check_obj ("$inv$_");
		} else {
		    print "  Error: Corrupted map file $file.\nSegment:\n$_\nLine: $.\n";
		}
	    } 
	    $parent="";
	} elsif (/^More$/ || $m == 1) {
	    &check_obj ($_);
	} else {
	    print "  Error: Corrupted map file $file.\nSegment:\n$_\nLine: $.\n"; 
	}
    }
    close (IN);
}

sub check_obj {
    $_ = shift @_;

    local ($x) = (/^x (\d+)$/)?$1:0;
    local ($y) = (/^y (\d+)$/)?$1:0;
    local($arch) = /^arch (\S+)\s*$/;

    if (! $arches{$1} && $last ne $1) {
	$last = $1;
	print "  Error: Object $last is not defined in archetypes file ($x,$y), arch=$arch\n"; 
	$missing{$last}++;
    } elsif ($ex{$1}) {
	&examine_exit ($_);
    } elsif ($tele{$1}) {
	if (/^food -?\d+$/) {
	    print "  Error: Teleport $1 has food field.\n";
	}
	else {
	    &examine_exit ($_);
	}
    } elsif ($conn{$1} && ! /^connected -?\d+$/) {
	$last = $1;
	print "  Warning: Object $last has not been connected, $x,$y\n" if ($CONNECTED);
    } elsif ($players{$1} && $last ne $1 && ! /^type / ) {
	$last = $1;
	print "  Error: Player $last found in the map.\n";
    } elsif ($1 eq "scroll" && ! /^msg$/) {
	$last = $1;
#	print "  Warning: scroll without message ($x, $y:$parent), should be random_scroll?\n";
    } elsif ($1 eq "potion" && $last ne $1) {
	$last = $1;
#	print "  Warning: potion found, should be random_potion or random_food?\n";
    } elsif ($1 eq "ring" || $1 eq "amulet") {
	$last = $1;
#	print "  Warning: ring/amulet found ($x,$y:$parent), should be random_talisman?\n";
    } 
    $objects{$1}++;
    if (/^color_fg (\S+)$/ || /^color_bg (\S+)$/) {
	$last = $arch;
	print "  Warning:  Object ".$arch." is setting color ($1), $x,$y\n";
    }
    if (/^animation (\S+)$/) {
	print "Error: Object $arch is using an unknown animation $1\n" if (! $anim{$1});
    }
    if (/^face (\S+)$/) {
	print "Error: Object $arch is using an unknown face $1\n" if (! $faces{$1});
    }
}

sub by {
     $_ = $objects{$b} <=> $objects{$a};
     $_ ? $_ : $a cmp $b;
}

sub obj_name {
    $_  = shift(@_);
    local ($name) =  /^name (.+)$/;			# object's name
    local ($arch) =  /^arch (\S+)$/;
    if (!defined ($name) && $arches{$arch} =~ /^name (.+)$/) {
	$name = $1;					# archetype's name
    }
    return defined ($name) ? $name : $arch;		# archetype or name
}

sub examine_exit {
    $_  = shift(@_);

    local ($x) = (/^hp (\d+)$/)?$1:0;
    local ($y) = (/^sp (\d+)$/)?$1:0;
    local ($x1) = (/^x (\d+)$/)?$1:0;
    local ($y1) = (/^y (\d+)$/)?$1:0;
    local ($to) = /^slaying (\S+)$/;

    if (/^food (-?\d+)$/) {
	# old style exits, doesn't work with crossfire 0.90-1
	print  " Error: ", &obj_name($_), " ($x1,$y1) -> ", 
	      "Old style level [$1] ($x,$y)\n";
    } elsif (! defined ($to)) {
#	print "  Closed: ", &obj_name($_), " ($x1,$y1)\n";
    } else {
	# These are currently used be crossfire
	if ($to =~ m!^/!) {
	    $cdir = "$MAPS";
	} else {
	    ($cdir) = $file =~ m!(.*/)!;
	}
	if (! -f "$cdir$to") {
	    print "  Missing: ", &obj_name($_), " ($x1,$y1) -> $to ($x,$y)\n";
	} else {
#	    print "  OK: ", &obj_name($_), " ($x1,$y1) -> $to ($x,$y)\n";
	}
    }
}

# @maps contains all filenames
sub maplist {
    local ($dir, $file, @dirs) = shift;

    opendir (DIR , $dir) || die "Can't open directory : $dir\n";
    while ($file = readdir (DIR)) {
	next if ($file eq "." || $file eq "..");
	$file = "$dir/$file";
	push (@dirs, $file) if (-d $file);
	push (@maps, $file) if (-f $file);
    }
    closedir (DIR);

    # recurcive handle sub-dirs too
    while ($_ = shift @dirs) {
	&maplist ($_);
    }
}

# collect all objects matching with reg.expr.
sub collect {
    local ($expr,$a, %col) = shift;

    foreach $a (keys %arches) {
	$_ = $arches{$a};
	if (/$expr/) {
	    $col{$a}++;
	}
    }
    return %col;
}

# collect all archetypes into associative array %arches
sub archetypes {
    open (IN, $ARCH) || die "Can't open archetype file $ARCH.\n";
    $/ = "\nend\n";
    while (<IN>) {
	while (/^Object (\S+)\s*$/g) {
	    $arches{$1} = $_;
	}
    }
    close (IN);
}

sub faces {
    open(IN, $FACES) || die ("Can't open faces file $FACES\n");
    while (<IN>) {
	if (/^face (\S+)\s*$/) {
	    $faces{$1} = $1;
	}
    }
    close(IN);
}

			     
sub animations {
    open(IN, $ANIM) || die ("Can't open animations file $ANIM\n");
    while (<IN>) {
	if (/^anim (\S+)\s*$/) {
	    $anim{$1} = $1;
	}
    }
    close(IN);
}

			     
