#!/usr/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   = "/export/home/crossfire/cf-installroot/share/crossfire";
$ARCH  = "$LIB/archetypes";
$BMAPS  = "$LIB/bmaps";
$ANIM  = "$LIB/animations";
$MAPS  = "$LIB/maps";
# Set VERBOSE=1 if you want more output
$VERBOSE=0;
$SHOW_UNUSED = 0;

if (! $ARGV[0]) {
    print "Using $MAPS are starting map directory.\n";
    $STARTING = $MAPS;
} else {
    $STARTING = $ARGV[0];
}
    

# read filenames to @maps
chdir ($STARTING);
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();

if ($SHOW_UNUSED) {
    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 {
    my ($m);
    my($last);
    my($parent);
    $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;
    }
    if ($VERBOSE) {
	    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";
	    }
	    $printmap=0;
    }
    else {
	$name=  /^name (.+)$/ ? $1 : "No mapname";
	$x=  /^x (\d+)$/ ? $1 : 16;
	$y= /^y (\d+)/ ? $1 : 16;
	$mapname="Map $file, $name, size [$x, $y]\n" ;
	$printmap=1;
    }


    while (<IN>) {
	if (($m = (@_ = /^arch \S+\s*$/g)) > 1) {
	    $parent = /^arch (\S+)\s*$/;
	    # object has inventory
	    my ($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 {
#		    if ($printmap) { print "$mapname"; $printmap=0;}
# This doesn't work right - it gets confused when objects are within
# another object
#		    print "  Error: Corrupted map file $file.\nSegment:\n$_\nLine: $.\n";
		}
	    } 
	    $parent="";
	} elsif (/^More$/ || $m == 1) {
	    &check_obj ($_);
	} else {
#	    if ($printmap) { print "$mapname"; $printmap=0;}
#	    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;
	if ($printmap) { print "$mapname"; $printmap=0;}
	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+$/) {
	    if ($printmap) { print "$mapname"; $printmap=0;}
	    print "  Error: Teleport $1 has food field.\n";
	}
	else {
	    &examine_exit ($_);
	}
    } elsif ($conn{$1} && ! /^connected -?\d+$/) {
	$last = $1;
	if ($CONNECTED) {
	    if ($printmap) { print "$mapname"; $printmap=0;}
	    print "  Warning: Object $last has not been connected, $x,$y\n"
	}
    } elsif ($players{$1} && $last ne $1 && ! /^type / ) {
	$last = $1;
	if ($printmap) { print "$mapname"; $printmap=0;}
	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;
	if ($printmap) { print "$mapname"; $printmap=0;}
	print "  Warning:  Object ".$arch." is setting color ($1), $x,$y\n";
    }
    if (/^animation (\S+)$/) {
	if (! $anim{$1}) {
	    if ($printmap) { print "$mapname"; $printmap=0;}
	    print "Error: Object $arch is using an unknown animation $1\n"
	}
    }
    if (/^face (\S+)$/) {
	if (! $faces{$1}) {
	    if ($printmap) { print "$mapname"; $printmap=0;}
	    print "Error: Object $arch is using an unknown face $1\n"
	}
    }
}

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
	if ($printmap) { print "$mapname"; $printmap=0;}
	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 eq "/!") {	# this is a random exit - if we
				# have a final map, make sure it
				# exists
	    local ($finalmap) = /^final_map (\S+)$/;
	    if ($finalmap ne "") {
		if ($finalmap =~ m!^/!) { $cdir = "$MAPS"; }
		else { ($cdir) = $file =~ m!(.*/)!; }
		if (! -f "$cdir$finalmap") {
			if ($printmap) { print "$mapname"; $printmap=0;}
			print "  Missing: ", &obj_name($_), " ($x1,$y1) -> $finalmap ($x,$y)\n";
		}
	    }
	    return;
	}
	if ($to =~ m!^/!) {
	    $cdir = "$MAPS";
	} else {
	    ($cdir) = $file =~ m!(.*/)!;
	}
	if (! -f "$cdir$to") {
	    if ($printmap) { print "$mapname"; $printmap=0;}
	    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 eq "CVS" || $file eq "unlinked" || $file eq "editor");
	$file = "$dir/$file";
	next if (-l $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, $BMAPS) || die ("Can't open faces file $BMAPS\n");
    while (<IN>) {
	chomp;
	($num, $name) = split;
	$faces{$name} = $name;
    }
    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);
}