File Coverage

blib/lib/Games/Roguelike/Area.pm

Criterion	Covered	Total	%
statement	505	853	59.2
branch	182	414	43.9
condition	82	207	39.6
subroutine	44	70	62.8
pod	31	49	63.2
total	844	1593	52.9

package Games::Roguelike::Area;

# puposely don't use much of the curses windowing stuff since curses doesn't port well
# purpose of library:
#
#     keep track of map/location
#     convenience for collision, line of sight, path-finding
#     assume some roguelike concepts (mobs/items)
#     allow me to make 7-day rl's in 7-days

=head1 NAME

Games::Roguelike::Area - Roguelike area map

=head1 SYNOPSIS

 package myArea;
 use base 'Games::Roguelike::Area';

 $a = myArea->new(w=>80,h=>50);     				# creates an area with specified width/height
 $a->generate('cavelike');                                         	# make a cavelike maze
 $char = Games::Roguelike::Mob->new($a, sym=>'@');              # add a mobile object with symbol '@'

=head1 DESCRIPTION

Library for loading or generating mazes, managing items/mobs

	* assumes the user will be using overridden Games::Roguelike::Mob's as characters in the game
	* provides a flexible load() function
	* contains an array of 'features', which can be named, searched for and positioned

=head2 METHODS

=over 4

=cut

use strict;
use Games::Roguelike::Utils qw(:all);
use Games::Roguelike::Mob;

use Data::Dumper;
use Carp qw(croak confess carp);

our $OKINLINEPOV;
our $AUTOLOAD;

our $VERSION = '0.5.' . [qw$Revision: 259 $]->[1];

BEGIN {
        eval('use Games::Roguelike::Utils::Pov_C;');
        $OKINLINEPOV = !$@;
}

=item new(OPT1=>VAL1, OPT2=>VAL2...)

Options can also all be set/get as class accessors:

	world => undef,			# world this area belongs to (optional container which can "addarea")
	name => '', 			# name of this level/area (required if world is specified)
	map => [] 			# double-indexed array of map symbols
	color => []			# double-indexed array of strings (used to color map symbols)
	mobs => [],			# list of mobs
	items => [],			# list of items

 # These will default to the world defaults, if world is set

        w=>80, h=>40,			# width/height of this area
        debugmap => 0, 			# turn on map coordinate display
	memcolor => 'gray',		# color drawn when an area is not in sight

 # These vars, or the world defaults (if a world is defined)
 # are used by map-making, pathfinding and field-of view, rather than using hooks
 # specifically because function calling seems to slow things down

        wsym => '#', 			# default wall symbol
        fsym => '.', 			# default floor symbol
        dsym => '+', 			# default door symbol
        noview => '#+', 		# list of symbols that block view
        nomove => '#', 			# list of symbols that block movement

=cut

sub new {
        my $pkg = shift;
	croak "usage: Games::Roguelike::Area->new()" unless $pkg;

        my $self = bless {}, $pkg;
	$self->init(@_);
	return $self;
}

sub init {
        my $self = shift;
	my %opts = @_;

	croak("need to specify a name for this area") if $opts{world} && !$opts{name};

	# set defaults

	$self->{map} = [];
	$self->{color} = [];
	$self->{mobs} = [];
	$self->{items} = [];

	if (!$opts{world}) {
		$self->{h} = 40;
		$self->{w} = 80;
		$self->{wsym} = '#';
		$self->{fsym} = '.';
		$self->{dsym} = '+';
		$self->{debugmap} = 0;
	} else {
		# really, should create functions for each one which reads from world member
		for (qw(h w noview nomove wsym fsym dsym debugmap memcolor)) {
			$self->{$_} = $opts{world}->$_;
		}
	}

	# override defaults
	for (keys(%opts)) {
		$self->{$_} = $opts{$_};
	}

	$self->{memcolor} = 'gray' unless defined $self->{memcolor};
	$self->{nomove} = $self->{wsym} unless $self->{nomove};
	$self->{noview} = $self->{wsym}.$self->{dsym} unless $self->{noview};
	if ($self->{world}) {
		$self->{world}->addarea($self);
		$self->{world}->area($self) if !$self->{world}->area;
	}
}

sub setworld {
	my $self = shift;
	my $world = shift;

	croak("need to specify a name for this area") if !$self->{name};

	if ($self->{world} != $world) {
		$self->{world}->delarea($self) if ($self->{world});
		$self->{world} = $world;
		$world->addarea($self);
                for (qw(h w noview nomove wsym fsym dsym debugmap)) {
                        $self->{$_} = $self->{world}->$_ if !defined($self->{$_});
                }
	}
}

# perl accessors are slow compared to just accessing the hash directly
# autoload is even slower
sub AUTOLOAD {
	my $self = shift;
	my $pkg = ref($self) or croak "$self is not an object";

	my $name = $AUTOLOAD;
	$name =~ s/.*://;   # strip fully-qualified portion

	$name =~ s/^set// if @_ && !exists $self->{$name};

	unless (exists $self->{$name}) {
	    croak "Can't access `$name' field in class $pkg";
	}

	if (@_) {
	    return $self->{$name} = $_[0];
	} else {
	    return $self->{$name};
	}
}

sub DESTROY {
}

=item getmapsym ($x,$y)

=item getmapcolor ($x,$y)

=item setmap ($x,$y, $sym [,$color])

Raw accessors may be subject to change in future versions, but are much faster.

 $area->{map}[$x][$y] = $sym,
 $area->{color}[$x][$y] = $color

Function accessors will always work, but are slower:

 $sym=$area->getmapsym($x,$y)
 $color=$area->getmapcolor($x,$y)
 $area->setmap($x,$y, $sym [,$color]);

If you're looping over the whole map, you can use foreachmap().

etcetera.

=cut

sub getmapsym {
        my $self = shift;
	my ($x, $y) = @_;
        return $self->{map}->[$x][$y];
}

sub setmapsym {
        my $self = shift;
	my ($x, $y, $sym) = @_;
        $self->{map}->[$x][$y] = $sym;
}

sub setmap {
        my $self = shift;
        my ($x, $y, $sym, $color) = @_;
	if (ref($sym)) {
	        $self->{map}->[$x][$y] = $sym->{sym};
        	$self->{color}->[$x][$y] = $sym->{color} if defined $sym->{color};
	} else {
	        $self->{map}->[$x][$y] = $sym;
        	$self->{color}->[$x][$y] = $color if defined $color;
	}
}

sub mapsym {
        my $self = shift;
        my ($x, $y, $s) = @_;
	if ($s) {
                return $self->{map}->[$x][$y] = $s;
	} else {
                return $self->{map}->[$x][$y];
	}
}

sub mapcolor {
        my $self = shift;
        my ($x, $y, $c) = @_;
        if ($c) {
                return $self->{color}->[$x][$y] = $c;
        } else {
                return $self->{color}->[$x][$y];
        }
}

sub map {
        my $self = shift;
	if (@_) {
        	my ($x, $y) = (shift, shift);
		return $self->{map}->[$x][$y];
	} else {
		return $self->{map};
	}
}

=item rpoint ()

Returns a random point as an X/Y array, that's within the map, and not on the edge..

=cut

sub rpoint {
	my $self = shift;
	croak unless $self;
	return (1+int(rand()*($self->{w}-2)), 1+int(rand()*($self->{h}-2)));
}

=item rpoint_empty ()

Returns a random point that's empty (eiher the symbol is ''' or is undefined)

=cut

sub rpoint_empty {
        my $self = shift;
	croak unless $self;
	# well, there's better ways to do this, but this has worked so far
	while (1) {
	        my ($x, $y) = (1+int(rand()*($self->{w}-2)), 1+int(rand()*($self->{h}-2)));
		return ($x, $y) if $self->{map}->[$x][$y] eq '';
	}
}

############ part of genmaze1 ############

sub genroom {
	# make a room around x/y with options
	# options are: minx, miny, maxx, maxy, nooverlap, withdoor

        my $self = shift;
        my ($x, $y, %opts) = @_;

	if ($x =~ /^[a-z]/i) {
		%opts = @_;
		$x = $opts{x};
		$y = $opts{y};
		if (! defined $x) {
			($x, $y) = $self->rpoint_empty();
		}
	}

	my $m = $self->{map};

	# room width/height
	my $rw = max(1,2+($self->{w}/2-2)*rand()*rand());
	my $rh = max(1,2+($self->{h}/2-2)*rand()*rand());

	$rw=$opts{minw} if $opts{minw} && $rw < $opts{minw};
	$rh=$opts{minh} if $opts{minh} && $rh < $opts{minh};
	$rw=$opts{maxw} if $opts{maxw} && $rw > $opts{maxw};
	$rh=$opts{maxh} if $opts{maxh} && $rh > $opts{maxh};

	# top left corner of room (not including walls)
	my $rx = min($x, max(1,int(rand() + $x - ($rw-1)/2)));
	my $ry = min($y, max(1,int(rand() + $y - ($rh-1)/2)));

	$rw = min($rw, $self->{w}-$rx-1);
	$rh = min($rh, $self->{h}-$ry-1);

	if (!$rh || !$rw) {
		#push @{$self->{f}}, [$rx, $ry, 'NULLROOM'];
		return 0;
	}

	if ($opts{nooverlap}) {
		my $ov = 0;
		for (my $i = -1; $i <= $rw; ++$i) {
			if ($m->[$rx+$i][int($ry+($i * $rw/$rh))]) {
				$rw = $i-1;
				$rh = int(($i * $rw/$rh)) - 1;
			}
		}
		if ($rw <= 1 || $rh <= 1) {
			return 0;
		}
	}

	intify($rx, $ry, $rw, $rh);

	if ($x > ($rx+$rw) || $y > ($ry+$rh)) {
		return 0;
	}

	for (my $i = -1; $i <= $rw; ++$i) {
		next if ($rx+$i) < 0;
		$m->[$rx+$i][$ry-1] 	= $self->{wsym} unless $m->[$rx+$i][$ry-1] || ($ry == 0);
		$m->[$rx+$i][$ry+$rh] 	= $self->{wsym} unless $m->[$rx+$i][$ry+$rh];
	}
	for (my $i = 0; $i < $rw; ++$i) {
        for (my $j = 0; $j < $rh; ++$j) {
                $m->[$rx+$i][$ry+$j] 	= $self->{fsym} unless $m->[$rx+$i][$ry+$j];
        }
	}
	for (my $i = -1; $i <= $rh; ++$i) {
		next if ($ry+$i) < 0;
		$m->[$rx-1][$ry+$i] 	= $self->{wsym} unless $m->[$rx-1][$ry+$i] || ($rx == 0);
		$m->[$rx+$rw][$ry+$i] 	= $self->{wsym} unless $m->[$rx+$rw][$ry+$i];
	}
		if ($opts{door}) {
			if (rand() > .5) {
				if (rand() > .5) {
					$m->[$rx+rand()*$rw][$ry-1] 	= $self->{dsym};
				} else {
					$m->[$rx+rand()*$rw][$ry+$rh] 	= $self->{dsym};
				}
				--$opts{door};
			} else {
				if (rand() > .5) {
					$m->[$rx-1][$ry+rand()*$rh] 	= $self->{dsym};
				} else {
					$m->[$rx+$rw][$ry+rand()*$rh] 	= $self->{dsym};
				}
				--$opts{door};
			}
		}

	if (0) {
		my $sig = chr(64 + int($rw));
		print "$sig:$rx, $ry / $rw,$rh\n";
		$m->[$x][$y] = $sig;
		$m->[$rx][$ry] = 'C';
	}

	push @{$self->{f}}, [$x, $y, 'ROOM'];

	return 1;
}

=item findpath(x1, y1, x2, y2)

Returns 1 if there is a path from x1,y2 to x2,y2.  Uses "nomove" member as the list of symbols that cannot be moved through.

=cut

sub findpath {
	# flood fill 'path exists' search

	my $self = shift;
	my ($x1, $y1, $x2, $y2) = @_;
	my $f;

	return 1 if ($x1 == $x2 && $y1 == $y2);

	my @f;
	my @bread;
	push @f, [$x1, $y1];
	while (@f) {
		my $c = pop @f;
		for (my $d=0;$d<8;++$d) {
			my $tx = $DD[$d]->[0]+$c->[0];
			my $ty = $DD[$d]->[1]+$c->[1];

			# not off edge
			next if $tx < 0 || $ty < 0;
			next if $tx >= $self->{w} || $ty >= $self->{h};

			# not thru void
			next if !defined($self->{map}->[$tx][$ty]);
			next if $self->{map}->[$tx][$ty] eq '';

			# not thru wall
			next if index($self->{nomove}, $self->{map}->[$tx][$ty]) >= 0;

			next if $bread[$tx][$ty];
			$bread[$tx][$ty] = '.'; 	#been there

			return 1 if ($tx == $x2 && $ty == $y2);

			push @f, [$tx, $ty];	#add to list;
		}
	}

	return 0;
}

=item findclose(x1, y1, x2, y2)

Returns the closest you can get to x2,y2 from x1,y2 without going through a "nomove" symbol.

Return value is (X,Y) array, or undefined if there's no path.

=cut

#if (!defined(&findclose)) {
sub findclose {
        # flood fill return closest you can get to x2/y2 without going thru a barrier
        my $self = shift;
        my ($x1, $y1, $x2, $y2) = @_;
        my $f;
        my @f;
        push @f, [$x1, $y1];
	my @bread;
	my ($cx, $cy) = ($x1, $y1);
	my $mindist = ($self->{w} + $self->{h}) * 2;

        while (@f) {
                my $c = pop @f;
                for (my $d=0;$d<8;++$d) {
                        my $tx = $DD[$d]->[0]+$c->[0];
                        my $ty = $DD[$d]->[1]+$c->[1];

                        # not off edge
                        next if $tx < 0 || $ty < 0;
                        next if $tx >= $self->{w} || $ty >= $self->{h};

                        # not thru void
                        next if !defined($self->{map}->[$tx][$ty]) || $self->{map}->[$tx][$ty] eq '';

                        # not thru wall
			next if index($self->{nomove}, $self->{map}->[$tx][$ty]) >= 0;

                        next if $bread[$tx][$ty];
                        $bread[$tx][$ty] = '.';     #been there

                        return ($tx, $ty, 0) if ($tx == $x2 && $ty == $y2);

			if ((my $tdist = distance($tx, $ty, $x2, $y2)) < $mindist) {
				$cx = $tx;
				$cy = $ty;
				$mindist = $tdist;
			}

                        push @f, [$tx, $ty];    #add to list of places can get to;
                }
        }

#	my ($ax,$ay,$ad) = findclose_c($self, $x1, $y1, $x2,$y2);
#	if ($ax!=$cx||$ay!=$cy) {
#		croak "C and perl disagree: ($ax,$ay <> $cx,$cy);"
#	}

#	$self->{color}->[$cx][$cy] = 'green';
        return ($cx, $cy, $mindist);
}#}


=item maxcardinal ()

Maximum point someone can walk from x/y in each of 4 cardinal directions, returned as an array of XY arrays.

Array is sorted n,s,e,w.

=cut

sub maxcardinal {
        my $self = shift;
        my ($x, $y) = @_;

	# maximum direction you can walk from x/y in each of the 4 directions, returned as a nsew array of points
	my @r;
        for (my $d=0;$d<4;++$d) {
		my ($cx, $cy) = ($x,$y);
		while (1) {
	                my $tx = $DD[$d]->[0]+$cx;
	                my $ty = $DD[$d]->[1]+$cy;

                        # not thru void
                        last if !defined($self->{map}->[$tx][$ty]) || $self->{map}->[$tx][$ty] eq '';

                        # not thru wall
			last if index($self->{nomove}, $self->{map}->[$tx][$ty]) >= 0;

                        # not off edge
                        last if $tx < 0 || $ty < 0;
                        last if $tx >= $self->{w} || $ty > $self->{h};

			# record
			($cx, $cy) = ($tx,$ty);
		};

		push @r, [$cx, $cy];
	}

	return @r;
}

=item digone (x, y, $ws, $fs)

"Digs" one square of the map, at position x,y - turning it into a "floor",
while also turning the surrounding areas into "walls", if they are currently
not assigned.

Optionally can specify wall & floor symbols (or uses area defaults).

Does nothing if the map symbol at x,y is not a wall or void.

Returns the number of walls that the new point is surrounded by or -1 if the point was off the map.

=cut

sub digone {
        my $self = shift;
        my ($x, $y, $ws, $fs) = @_;

	$ws = $self->{wsym} unless $ws;
	$fs = $self->{fsym} unless $fs;

	return -1 if ($x <=0 || $y <= 0);
	return -1 if ($x >=($self->{w}-1) || $y >= ($self->{h}-1));

	my $c = $self->{map}->[$x][$y];
	return unless !defined($c) || ($c eq $ws) || ($c eq '');
	$self->{map}->[$x][$y] = $fs;

      	for (my $d=0;$d<8;++$d) {
                my $tx = $DD[$d]->[0]+$x;
                my $ty = $DD[$d]->[1]+$y;
		my $c = $self->{map}->[$tx][$ty];
		next unless !defined($c) || $c eq '';
		$self->{map}->[$tx][$ty] = $ws;
       	}

	#$self->drawmap();

	return 1;
}

sub debug {
	return 1;
}


=item nexttosym(x, y, sym)

Returns a direction if x,y are adjacent to sym, otherwise returns undef.

=cut

sub nexttosym {
        my $self = shift;
	my ($x, $y, $sym) = @_;
	my $dn = 0;
	for (@DD) {
		my $tx = $x + $_->[0];
		my $ty = $y + $_->[1];
		return $DIRS[$dn] if index($sym, $self->{map}[$tx][$ty]) >= 0;
		++$dn;
	}
	return undef;
}


=item okdoor(x, y)

Looks at the clockwize adjacent symbols for an alternating pattern of walls and floors, to see if a door
would be meaningful.

Uses {nomove} as the list of "wall" symbols.

=cut

sub okdoor {
        my $self = shift;
        my ($x, $y) = @_;
        my $cnt = 0;
	my $cur;
	my $first;
	my $flip = 0;
        for (@CWDIRS) {
                my $tx = $x + $DD{$_}->[0];
                my $ty = $y + $DD{$_}->[1];
		my $sym = $self->{map}[$tx][$ty];
                my $wl = !defined($sym) || (index($self->{nomove}, $sym) >= 0) || $sym eq $self->{dsym};
		if (! defined $cur) {
			$cur = $wl;
			$first = $wl;
		} else {
			if ($cur != $wl) {
				++$flip;
				$cur = $wl;
			}
		}

        }
	if ($cur != $first) {
		++$flip;
	}

        return $flip == 4;
}

=item makepath(x1, y1, x2, y2)

Drill a right-angled corridor between 2 nonempty points using digone().

** Notably the whole auto-door upon breaking into an open area doesn't always work right, and should.

=cut

sub placedoors {
	my $self=shift;
	my @doors = @_;
        for (@doors) {
                my ($x, $y) = @$_;
                if ($self->okdoor($x, $y) && $self->{dsym}) {
                        $self->{map}->[$x][$y] = $self->{dsym};
                }
        }
}

sub makepath {
        my $self = shift;
        my ($ox, $oy, $x2, $y2) = @_;

	croak "can't make a path without floor and wall symbols set"
		unless $self->{wsym} && $self->{fsym};

#	$self->{map}->[$x][$y] = chr(64 + ++$self->{dseq}) if $self->debug;
#	$self->{map}->[$x2][$y2] = chr(64 + ++$->{dseq}) if $self->debug;

	my ($x, $y) = ($ox, $oy);

	if ($self->{map}->[$x][$y] eq '') {
		return;
	}
	if ($self->{map}->[$x2][$y2] eq '') {
		return;
	}

	my $d;
	if ($y < $y2) {
		$d = 's';
	} elsif ($y > $y2) {
		$d = 'n';
	}

	if ($x < $x2) {
		$d .= 'e';
	} elsif ($x > $x2) {
		$d .= 'w';
	}

	return if !$d;

	# 2 directions, randomly sorted

	my @d;
	$d[1] = $d;
	$d[0] = substr($d, rand()*2, 1);
	$d[1] =~ s/$d[0]//;

	# closest can get now
	($x, $y) = $self->findclose($x, $y, $x2, $y2);

#	$self->dprint "($x, $y) closest from $ox $oy to $x2, $y2";

	# choose a random square among maximum wall range from closest point
	my @mc = $self->maxcardinal($x, $y);
	$d=$d[0];
	my $len;
	if ($d =~ /^n|s$/) {
		$x = $mc[$DI{w}]->[0] + rand() * ($mc[$DI{e}]->[0] - $mc[$DI{w}]->[0]);
	} else {
		$y = $mc[$DI{n}]->[1] + rand() * ($mc[$DI{s}]->[1] - $mc[$DI{n}]->[1]);
	}
	intify($x, $y);

	my @doors;

	my $firstdig = 1;		# first dig out of an area gets a door
	for my $d (@d) {
		next unless $d;

		$self->{map}->[$x][$y] = $d if $self->debug > 1;

	        if ($d =~ /^n|s$/) {
	                $len = abs($y-$y2);
	        } else {
	                $len = abs($x-$x2);
	        }

		my $already_dug = 0;
		my $waswall = 0;

		for (my $i = 0; $i < $len; ++$i) {
			my ($px,$py) = ($x, $y);
			$x += $DD{$d}->[0];
			$y += $DD{$d}->[1];

			my $iswall = $self->{map}->[$x][$y] eq $self->{wsym};
			if ($iswall || $self->{map}->[$x][$y] eq '') {
				$self->digone($x,$y);
				if ($firstdig) {
                                	push @doors, [$x, $y];
					$firstdig = 0;
				}
			} else {
				# not a wall, already dug
				$already_dug = 1;
				if ($waswall) {
                                	push @doors, [$px, $py];
				} else {
					# 2 non walls in a row = reset firstdig
					$firstdig = 1;
				}
			}
			$waswall = $iswall;


                        if ( $already_dug ) {
                        	my ($fx, $fy, $dist) = $self->findclose($x, $y, $x2, $y2);
				if (&distance($fx, $fy, $x, $y) >= 2 ) {
					my $res = $self->makepath($fx, $fy, $x2, $y2);
                        		$self->placedoors(@doors);
					return $res;
				}
                        	last if $dist == 0;
                        }

			#$self->{world}->drawmap();
			# too close to edge
			last if $x<=1 || $y<=1 || $x>=($self->{w}-1) || $y>=($self->{h}-1);
		}
		last if ($x == $x2 && $y == $y2);
	}


	if (!$self->findpath($ox, $oy, $x2, $y2)) {
		$self->makepath2($ox, $oy, $x2, $y2);
	}

        $self->placedoors(@doors);

        return 1;
}

=item makepath2 (x1, y1, x2, y2)

Like makepath, but diagonal and with no doors.

=cut


sub makepath2 {
        my $self = shift;
        my ($ox, $oy, $x2, $y2) = @_;

        croak "can't make a path without floor and wall symbols set"
                unless $self->{wsym} && $self->{fsym};

        my ($x, $y) = ($ox, $oy);

	($x, $y) = $self->findclose($x, $y, $x2, $y2);

	while (($x != $x2) || ($y != $y2)) {
		$self->digone($x, $y);
		my $d;
        	if ($y < $y2) {
                	$d = 's';
        	} elsif ($y > $y2) {
                	$d = 'n';
        	}
		if ($x < $x2) {
			$d .= 'e';
		} elsif ($x > $x2) {
			$d .= 'w';
		}

                $x += $DD{$d}->[0];
                $y += $DD{$d}->[1];
	}
}


=item findfeature (symbol)

Searches "map feature list" for the given symbol, returns coordinates if found.

=cut

sub findfeature {
	my $self = shift;
	my ($sym) = @_;

	for (@{$self->{f}}) {
		my ($fx, $fy) = @$_;
		if ($self->{map}->[$fx][$fy] eq $sym) {
			return ($fx, $fy);
		}
	}
}

=item addfeature (symbol [, x, y])

Adds a symbol to the map (to a random open floor point if one is not specified), and also adds it to the searchable "feature list".

=cut

sub addfeature {
        my $self = shift;
        my ($sym, $x, $y) = @_;

	if (!defined($x)) {
		($x, $y) = $self->findrandmap($self->{fsym}, 0, 1);
	}
	$self->{map}->[$x][$y] = $sym;
	push @{$self->{f}}, [$x, $y];
}

=item inbound(x, y)

Returns true if x >= 0 and x < $self->{w} and y >= 0 and y < $self->{h}.

=cut

sub inbound {
        my $self = shift;
        return ($_[0]>=0)&&($_[0]<($self->{w}))&&($_[1]>=0)&&($_[1]<($self->{h}));
}


=item generate ($type [, options ... ])

This calls "$type::generate" if it is defined, perhaps in the caller's package, etc.

Predefined types are "Rooms", "Cavelike" and "Maze" (see below).

If no "::" is present, 'Games::Roguelike::Area::' is prepended, and the first character is propercased.

If &{"$type::generate"} is not defined, it will require "$type" and then try again.

Assuming there is no function named "wilderness::generate", then the following are roughly equivalent:

 $self->generate('Games::Roguelike::Area::Rooms');
or
 $self->generate('rooms');
or
 Games::Roguelike::Area::Rooms::generate($self);
or
 $self = new Games::Roguelike::Area::Rooms; $self->generate();

Additonal options are passed to the generate function.  Generate functions should support named parameters..

Common option is a "with=>[feature1, feature2]" feature list, that get added to empty floor map locations,
and appended to the map's feature list.

Height, width are taken from the area object.

=cut

sub generate {
        my $self = shift;
	my $type = shift;

	my $path = $type . '::generate';
	if (defined &$path) {
		no strict 'refs';
		return &$type($self, @_);
	}

	if ($type !~ /::/) {
		$type =~ s/^(\w)/\U$1/;
		$type = 'Games::Roguelike::Area::' . $type;
		$path = $type . '::generate';
		if (defined &$path) {
			no strict 'refs';
			return &$path($self, @_);
		}
	}
	eval "require $type";
	no strict 'refs';
	return &$path($self, @_);
}


# this is intended as *example* of making a map that i got to work in a few hours
# it is not intended as a good map
# if map-making isn't what you want to work on in the beginning, you can start here


=item generate('cavelike', [with=>[sym1[,sym2...]])

Makes a random map with a bunch of cave-like rooms connected by corridors.

Can specify a list of symbols to be added as "features" of the map.

=cut

sub diginbound {
        my $self = shift;
	return ($_[0]>0)&&($_[0]<($self->{w}-2))&&($_[1]>0)&&($_[1]<($self->{h}-2));
}

sub genmaze2 {
        my $self = shift;
        my %opts = @_;

        my ($m, $fx, $fy);

	my $digc = 0;

	do {
	my ($cx, $cy) = $self->rpoint();
	$self->digone($cx, $cy);
	if (my $feature = shift @{$opts{with}}) {
		$self->{map}->[$cx][$cy]=$feature;
		push @{$self->{f}}, [$cx, $cy, 'FEATURE'];
	} else {
		push @{$self->{f}}, [$cx, $cy, 'ROOM'];
	}
	my @v;
	$v[$cx][$cy]=1;
	my $dug = 0;
	do {
	  my $o = randi(4);
	  $dug = 0;
	  for (my $i=0;$i<4;++$i) {
		my ($tx, $ty) = ($cx+$DD[($i+$o)%4]->[0], $cy+$DD[($i+$o)%4]->[1]);
		if ((!$v[$tx][$ty]) && $self->diginbound($tx, $ty)) {
			($cx, $cy) = ($tx, $ty);
			++$digc if $self->digone($cx, $cy);
			#print "dig at $cx, $cy $v[$cx][$cy]\n";
			$v[$cx][$cy] = 1;
			$dug = 1;
			last;
		}
	  }
	} while ($dug);

	} while ($digc < (($self->{w}*$self->{h})/8));

        # dig out paths
        my ($px, $py);
        for (randsort(@{$self->{f}})) {
                my ($x, $y, $reason) = @{$_};
                if ($px) {
                        if (!$self->findpath($x, $y, $px, $py)) {
                                $self->makepath($x, $y, $px, $py);
                                #$self->drawmap();
                                #$self->getch();
                        }
                }
                ($px, $py) = ($x, $y);
        }
}

=item generate ('rooms', [with=>[sym1[,sym2...]])

Makes a random nethack-style map with a bunch of rectangle rooms connected by corridors

If you specify a "with" list, it puts those symbols on the map in random rooms, and calls "addfeature" on them.

=cut

sub genmaze1 {
	my $self = shift;
	my %opts = @_;

	my ($m, $fx, $fy);

	my $rooms = 0;

	for my $feature (@{$opts{with}}) {
		($fx, $fy) = $self->rpoint_empty();
		$self->{map}->[$fx][$fy]=$feature;
		push @{$self->{f}}, [$fx, $fy, 'FEATURE'];
		++$rooms if $self->genroom($fx, $fy);		# put rooms around features
	}

	# some extra rooms
	while($rooms < ($self->{w}*$self->{h}/600)) {
		++$rooms if $self->genroom(($fx, $fy) = $self->rpoint_empty(), nooverlap=>1);
	}

	# dig out paths
	my ($px, $py);
	for (randsort(@{$self->{f}})) {
		my ($x, $y, $reason) = @{$_};
		if ($px) {
			if (!$self->findpath($x, $y, $px, $py)) {
				$self->makepath($x, $y, $px, $py);
				if (!$self->findpath($x, $y, $px, $py)) {
					$self->{map}->[$px][$py] = '1';
					$self->{map}->[$x][$y] = '2';
					$self->dump();
					die "makepath failed!!!\n";
					$self->makepath($x, $y, $px, $py);
				}
				#$self->drawmap();
			}
		}
		($px, $py) = ($x, $y);
	}
}

=item generate('maze', rand=>number, with=>feature-list)

Generate a tight, difficult maze.  Rand defaults to 5 (higher numbers are less random).

=cut

sub genmaze3 {
        my $self = shift;
	my %opts = @_;

	$opts{w} = $self->{w} if !$opts{w};
	$opts{h} = $self->{h} if !$opts{h};

        my ($cNx,$cNy, $cSx, $cSy);
        my $intDir;
        my $intDone = 0;

        my $blnBlocked;

        use constant X => 0;
        use constant Y => 1;

        $opts{rand} = 5 if !$opts{rand};

        $opts{w} -= 1 if !($opts{w}%2);
        $opts{h} -= 1 if !($opts{h}%2);

        # stores the directions that corridors go in
        my @cDir;
        my @blnMaze;

        do {
            # this code is used to make sure the numbers are odd
            $cSx = 1 + (int((($opts{w} - 1) * rand()) / 2) * 2);
            $cSy = 1 + (int((($opts{h} - 1) * rand()) / 2) * 2);

            # first opening is free!
            $blnMaze[$cSx][$cSy] = 1 if !$intDone;

            if ($blnMaze[$cSx][$cSy]) {
                # randomize directions to start
                @cDir = &getRandomDirections();
                do {
                    # only randomisation directions, based on the constant
                    @cDir = &getRandomDirections() if !int($opts{rand} * rand());
                    $blnBlocked = 1;
                    # loop through order of directions
                    for ($intDir = 0; $intDir < 4; ++$intDir) {
                        # work out where this direction is
                        $cNx = $cSx + ($cDir[$intDir][X] * 2);
                        $cNy = $cSy + ($cDir[$intDir][Y] * 2);
                        # check if the tile can be used
                        my $isFree;
                        if ($cNx < ($opts{w}-1) && $cNx >= 1 && $cNy < ($opts{h}-1) && $cNy >= 1) {
                                # true if it hasn't been used yet
                                $isFree = !$blnMaze[$cNx][$cNy];
                        }
                        if ($isFree) {
                            # create a path
                            $blnMaze[$cNx][$cNy] = 1;
                            # and the square inbetween
                            $blnMaze[$cSx + $cDir[$intDir][X]][$cSy + $cDir[$intDir][Y]] = 1;
                            # this is now the current square
                            $cSx = $cNx;
                            $cSy = $cNy;
                            $blnBlocked = 0;
                            # increment paths created
                            $intDone = $intDone + 1;
                            last;
                        }
                    }
                # loop until a path was created
                } while (!$blnBlocked)
           }
        } while ( $intDone + 1 < ( (($opts{w} - 1) * ($opts{h} - 1)) / 4 ) );
        # create enough paths to fill the whole grid


        # this changes the direction to go from the current square, to the next available
        sub getRandomDirections {
            # clear the array
            my @a = ([-1,0],[1,0],[0,-1],[0,1]);
            my @b;
            while (@a) {
                push @b, splice(@a, rand()*scalar(@a), 1);
            }
            return @b;
        }

	$self->{map} = [];

	for (my $y = 0; $y < $opts{h}; ++$y) {
		for (my $x = 0; $x < $opts{w}; ++$x) {
			$self->{map}->[$x][$y]  = ($blnMaze[$x][$y] ? $self->{fsym} : $self->{wsym});
		}
	}


        for my $feature (@{$opts{with}}) {
                my ($fx, $fy) = $self->findrandmap('.');
                $self->{map}->[$fx][$fy]=$feature;
                push @{$self->{f}}, [$fx, $fy, 'FEATURE'];
        }
}

=item foreachmap (code-reference [,noborder=>1] [,border=>1])

Loops over each map location, and calls the code with parameters x, y and map-symbol.

Option "border" calls the code only for border (edge) squares.

Option "noborder" calls the code for everything but border (edge) squares.

=cut

sub foreachmap {
	my $self = shift;
	my $code = shift;
	my %opts = @_;

	if ($opts{border}) {
		for my $y ((0,$self->{h}-1)) {
			for (my $x = 0; $x < $self->{w}; ++$x) {
				&{$code}($x, $y, $self->{map}->[$x][$y]);
			}
		}
		for my $x ((0,$self->{w}-1)) {
			for (my $y = 0; $y < $self->{h}; ++$y) {
				&{$code}($x, $y, $self->{map}->[$x][$y]);
			}
		}
	} else {
		my ($x1, $y1, $x2, $y2) = (0, 0, $self->{w},$self->{h});

		if ($opts{nobodrder}) {
			$x1++;	$y1++;
			$x2--;	$y2--;
		}

		for (my $y = $y1; $y < $y2; ++$y) {
			for (my $x = $x1; $x < $x2; ++$x) {
				&{$code}($x, $y, $self->{map}->[$x][$y]);
			}
		}
	}
}

=item draw ({dispx=>, dispy=>, vp=>, con=>});

Draws the map using offset params dispx, dispy,disph,dispw,

Uses the perspective of $vp (viewpoint), if specified.  $vp can contain an x, y coordinate
and a "pov" integer which is the maximum sight distance.

Uses the console $con to draw the map.

Uses the algorithm provided by the "checkpov" function for field of view calculations.

Usually done after each move.

=cut

sub draw {
	my $self = shift;
	my ($opts) = @_;

	my $dispx = $opts->{dispx};
	my $dispy = $opts->{dispy};
	my $dispw = $opts->{dispw};
	my $disph = $opts->{disph};
	my $vp = $opts->{vp};
	my $con = $opts->{con};

	my $debugx = $dispx;
	my $debugy = $dispy;
	if ($self->{debugmap}) {
		$dispx += 3; $dispw -= 3;
		$dispy += 3; $disph -= 3;
	}

	my $ox = 0;
	my $oy = 0;
	if ($vp) {
	  $ox = $vp->{x}-($dispw/2);	#substract offsets from actual
	  $oy = $vp->{y}-($disph/2);
	  $ox = 0 if $ox < 0;
	  $oy = 0 if $oy < 0;
	  $ox = $self->{w}-$dispw if ($ox+$dispw) > $self->{w};
	  $oy = $self->{h}-$disph if ($oy+$disph) > $self->{h};
	}
	intify($ox, $oy);

	if ($self->{debugmap}) {
		# show labels to help debuggin map routines
		$con->addstr($debugy,$debugx," " x 3);
		for (my $x = $ox; $x < $dispw+$ox; ++$x) {
			$con->addstr(substr(sprintf("%03.0d", $x),-2,1));
		}
		$con->addstr($debugy+1,$debugx," " x 3);
		for (my $x = $ox; $x < $dispw+$ox; ++$x) {
			$con->addstr(substr(sprintf("%03.0d", $x),-1,1));
		}
		$con->addstr($debugy+2,$debugx," " x 3);
		for (my $x = $ox; $x < $dispw+$ox; ++$x) {
			$con->addstr("-");
		}
	}

	#$self->dprint("OXY: $ox, $oy DXY: $dispx,$dispy");

	#actual map drawn at user-requested location/virtual window
	for (my $y = $oy; $y < ($disph+$oy); ++$y) {
		# x/y is the game map-coord, not drawn location
		if ($self->{debugmap}) {
			$con->addstr($y-$oy+$dispy, $debugx, sprintf("%02.0d|", $y));
		}
		for (my $x = $ox; $x < $dispw+$ox; ++$x) {
			if (my $memtyp = $self->checkmap($vp, $x, $y, $self->{map}->[$x][$y])) {
				my ($color) = $self->{color}->[$x][$y];
				my $sym = ($memtyp == 2) ? $vp->{memory}->{$self->{name}}->[$x][$y] : $self->{map}->[$x][$y] ? $self->{map}->[$x][$y] : ' ';
				$color = $self->{memcolor} if $memtyp == 2 && $self->{memcolor};		# if the area is memorized, then draw as gray
				$con->attrch($color, $y-$oy+$dispy,$x-$ox+$dispx,$sym);
			} else {
				$con->addch($y-$oy+$dispy,$x-$ox+$dispx,' ');
			}
		}
	}

	# drawitems
        for my $i (@{$self->{items}}) {
		$self->drawob($i, $opts, $ox, $oy, $dispx, $dispy);
        }

	# drawmobs on top
        for my $m (@{$self->{mobs}}) {
		$self->drawob($m, $opts, $ox, $oy, $dispx, $dispy);
        }

	$con->refresh();
}

#
# This draws a thing that has a symbol, a color, an x and a y
# It is called by draw() above
#

sub drawob {
	my $self = shift;
        my ($ob, $opts, $ox, $oy, $xoff, $yoff) = @_;

        my $vp = $opts->{vp};
        my $con = $opts->{con};

        # $ox, $oy must be subtracted to get display coords (relative to display box, don't draw if outside box)
        # $xoff, $yoff musy be ADDED to get absolute coords (relative to console box)

        if ($self->checkpov($vp, $ob->{x}, $ob->{y})) {
            if ( (($ob->{y}-$oy) >= 0) && (($ob->{x}-$ox) >= 0) && (($ob->{x}-$ox) < $opts->{dispw}) && (($ob->{y}-$oy) < $opts->{disph}) ) {
                $con->attrch($ob->{color},$ob->{y}-$oy+$yoff, $ob->{x}-$ox+$xoff, $ob->{sym});
            }
	    #if the object is not the char, and the object is novel then memorize it and set the "saw something new this turn" flag
	    if ($vp && $ob != $vp && !($vp->{memory}->{$self->{name}}->[$ob->{x}][$ob->{y}] eq $ob->{sym})) {
		    $vp->{memory}->{$self->{name}}->[$ob->{x}][$ob->{y}] = $ob->{sym};
		    $vp->{sawnew} = 1;
	    }
	    return 1;
        }
}


# These can be easily optimized also storing items/mobs at {m-items}[x][y] and {m-mobs}[x][y]
# But a list approach is simpler for now, and reduces some overhead on sets

=item mobat (x, y)

Returns a single mob located at x/y, or undef if none is there.

=cut

sub mobat {
	my $self = shift;
	my ($x, $y) = @_;
	#$self->dprint("mobat $x, $y");
	my @r;
        for my $m (@{$self->{mobs}}) {
        	return $m if ($m->{x} == $x) && ($m->{y} == $y);
        }
}

=item items ([x, y])

Returns reference to array of items located at x/y, or reference to array of all items if no x/y is supplied.

=cut

sub items {
	my $self = shift;
	if (!@_) {
		return $self->{items}
	} else {
		my ($x, $y) = @_;
		my @r;
		for my $i (@{$self->{items}}) {
			push @r, $i if ($i->{x} == $x) && ($i->{y} == $y);
		}
		return \@r;
	}
}

=item mobs ([x, y])

Returns reference to array of all mobs located at x/y, or all mobs if no x/y is supplied.

=cut

sub mobs {
	my $self = shift;
	if (!@_) {
		return $self->{mobs}
	} else {
		my ($x, $y) = @_;
		my @r;
		for my $m (@{$self->{mobs}}) {
			push @r, $m if ($m->{x} == $x) && ($m->{y} == $y);
		}
		return \@r;
	}
}

=item checkpov (vp, x, y)

Returns 1 if the $vp object (something that has an x, a y and a pov) can see x/y.

Uses the "noview" area variable to determine what can be seen through.

=cut

# this is used to show monster at the current location
sub checkpov {
	my $self = shift;
	my ($vp, $x, $y) = @_;
	return 1 if (!$vp);	# no viewpoint, draw everything
	return 1 if ($vp->{pov}<0 || !defined($vp->{pov}));	# see all
	return 0 if ($vp->{pov}==0);	# blind
	my $vx = $vp->{x};
	my $vy = $vp->{y};

	my $dist = distance($vx, $vy, $x, $y);

	return 0 unless $dist <= $vp->{pov};

	return 1 if $dist <= 1;		# always see close

        print "---FOV2: $vx, $vy, $x, $y D:$dist\n" if $self->{debugfov};
	if ($OKINLINEPOV) {
		print "using inline pov\n" if $self->{debugfov};
		return checkpov_c($vx, $vy, $x, $y, $self->{map}, $self->{noview}, $self->{debugfov} ? 1 : 0);
	}

# here's where we need to actually do some field of view calculations

        my $dx = $x-$vx;
        my $dy = $y-$vy;

	# trace 4 parallel rays from corner to corner
	# without cosines!
	# this code allows diagonal blocking pillars

        my @ok = (1,1,1,1);
	for (my $i = 1; $i <= $dist; $i+=0.5) {
		my $tx = $vx+($i/$dist)*$dx;	# delta-fraction of distance
		my $ty = $vy+($i/$dist)*$dy;

		my (@x, @y);
                $x[0] = (0.1+$tx);		# not quite the corners
                $y[0] = (0.1+$ty);
                $x[1] = (0.9+$tx);
                $y[1] = (0.9+$ty);
                $x[2] = (0.9+$tx);
                $y[2] = (0.1+$ty);
                $x[3] = (0.1+$tx);
                $y[3] = (0.9+$ty);

		my $ok = 0;
		for (my $j = 0; $j < 4; ++$j) {
                        next if !$ok[$j];
			if (int($x[$j]) eq $x && int($y[$j]) eq $y) {
                        	print "$i: sub $j: $x[$j],$y[$j] SAME ($self->{map}->[$x[$j]][$y[$j]])\n" if $self->{debugfov};
				next;
			}
			if ($dx != 0 && $dy != 0 && (abs($dx/$dy) > 0.1) && (abs($dy/$dx) > 0.1)) {
				# allow peeking around corners if target is near the edge
				if (round($x[$j]) eq $x && round($y[$j]) eq $y && $i >= ($dist -1)) {
                        		print "$i: sub $j: $x[$j],$y[$j] PEEK ($self->{map}->[$x[$j]][$y[$j]])\n" if $self->{debugfov};
					next;
				}
			}
			if (($self->{map}->[$x[$j]][$y[$j]] =~ /^(#|\+)$/)) {
				$ok[$j] = 0;
                                print "$i: sub $j: $x[$j],$y[$j] WALL ($self->{map}->[$x[$j]][$y[$j]])\n" if $self->{debugfov};
			} else {
                                print "$i: sub $j: $x[$j],$y[$j] OK ($self->{map}->[$x[$j]][$y[$j]])\n" if $self->{debugfov};
			}
		}
		return 0 if !$ok[0] && !$ok[1] && !$ok[2] && !$ok[3];
	}
	return 1;
}

=item checkmap (vp, x, y, sym)

Returns 1 if the $vp mob can see x/y, 2 if $vp has a memory of x/y,
and also memorizes x/y if it can be seen by adding it to the vp's "memory" variable..

Uses the "noview" area variable to determine what can be seen through.

=cut

# this is used to show the map
sub checkmap {
        my $self = shift;
        my ($vp, $x, $y, $sym) = @_;
	if ($vp && $vp->{hasmem}) {
		if ($self->checkpov($vp, $x, $y)) {
	        	$vp->{memory}->{$self->{name}}->[$x][$y]=$sym;
			return 1;
		}
	        # $self->dprint("mem $self->{name}: $x,$y") if $vp->{memory}->{$self->{name}}->[$x][$y];
	        return 2 if $vp->{memory}->{$self->{name}}->[$x][$y];
		return 0;
	} else {
	        return $self->checkpov($vp, $x, $y);
	}
}

=item addmob (mob)

Adds a mob to the area, unless it's already in it.

=cut

sub addmob {
	my $self = shift;
	my $m = shift;
	for (@{$self->{mobs}}) {
		return 0 if $_ eq $m;
	}
	push @{$self->{mobs}}, $m;
	return $m;
}

=item delmob (mob)

Removes mob from the area.

=cut

sub delmob {
        my $self = shift;
        my $m = shift;
	my $i = 0;
        for (@{$self->{mobs}}) {
                splice @{$self->{mobs}}, $i, 1 if $_ == $m;
		++$i;
        }
}

=item findrandmap (symbol[, mobok=0])

Finds a random map location containing symbol (if mobok is not set, then it won't returns locations that have mobs).

=cut

sub findrandmap {
    my $self = shift;
    my $sym = shift;
    my $mobok = shift;

    my $index = [];

    for (my $x = 0; $x < $self->{w}; ++$x) {
	for (my $y = 0; $y < $self->{h}; ++$y) {
		push @{$index}, [$x, $y]
			if defined($self->{map}->[$x][$y])
			&& ($self->{map}->[$x][$y] eq $sym && ($mobok || !$self->mobat($x,$y)));
	}
	}
    $self->{index}->{$sym} = $index;

    my $i = int(rand() * scalar(@{$index}));

    return $index->[$i]->[0], $index->[$i]->[1];
}

=item dump

Prints map to stdout, without mobs and items.   For a more flexible approach, create a ::Console::Dump object and call draw() using it.

=cut

sub dump {
	my $self = shift;

        my $ox = 0;
        my $oy = 0;

	my ($xx, $xy, $mx, $my) = (0, 0, $self->{w}, $self->{h});
        for (my $y = 0; $y < $self->{h}; ++$y) {
                for (my $x = 0; $x < $self->{w}; ++$x) {
			if ($self->{map}->[$x][$y]) {
                                $mx = $x if ($x < $mx);
                                $my = $y if ($y < $my);
                                $xx = $x if ($x > $xx);
                                $xy = $y if ($y > $xy);
                        }
                }
        }

	$ox=max($ox, $mx);
	$oy=max($oy, $my);

        #actual map drawn at user-requested location/virtual window
        for (my $y = $oy; $y < $self->{h} && $y <= $xy; ++$y) {
                for (my $x = $ox; $x < $self->{w} && $x <= $xx; ++$x) {
                        print $self->{map}->[$x][$y] ? $self->{map}->[$x][$y] : ' ';
                }
                print "\n";
        }
}

=item additem (item)

Adds item to floor.  Override this to add floor full messages, etc.

Return value 0 		= can't add, too full
Return value 1 		= add ok
Return value -1 	= move occured, but not added

If the item doesn't have an {x} and {y} value then the item is added to a random location.

=cut

sub additem {
	my $self = shift;
	my $item = shift;
	if ($item->setcont($self)) {
		if (!defined($item->{x})) {
			($item->{x}, $item->{y}) = $self->findrandmap($self->{fsym}, 0, 1);
		}
	}
	return 1;			# i'm never full
}

=item delitem (item)

Removes item from the area.

=cut

sub delitem {
        my $self = shift;
        my $ob = shift;
        my $i = 0;
        for (@{$self->{items}}) {
                splice @{$self->{items}}, $i, 1 if $_ == $ob;
                ++$i;
        }
}

=item load (file | options)

Loads an area from a file, which is a perl program that sets these vars:

 $map 		: 2d map as one big string
 or $yxarray	: 2d map as y then x indexed array
 %key		: for each symbol in the map *optionally* provide:
	color	- color of that symbol
	sym	- real symbol to use
	feature - name of feature for feature table, don't specify with class!
	class	- optional package to use for "new", passed the area itself as the first argument to new
	lib	- look up item or mob from library

 %lib		: hash of hashes, used to populate items or monsters - as needed

Alternatively, these can be passed as named options to the load function.

The map system knows very little about game semantics.   It's merely a way of loading maps
 made of symbols - some of which may correlate to perl objects.  The tictactoe example script
uses the map load system.

'>', and '<' are assumed to be "stair features" unless otherwise specified.

Objects can be looked up by name from the item library instead of specified in full.

At a minimum, classes must add themselves, somehow, to the area object when new is called.

  The example below loads a standard map, with blue doors, 2 mobs and 1 item

  One mob is loaded via a package "mymonster", and is passed "hd" & "name" parameters,
  in addition to the "x", "y" and "sym" parameters which are derived from its location.

  The other mob is loaded from the library named "blue dragon", and has it's "name" and "hp"
  parameters modified.

About lib entries:

If a key entry has a "lib", it's assumed to the be the name of an entry in the lib hash.

The lib hash is then looked up and has its values copied into the key entry before using the key entry.

"lib" entries can be recursive.

The "lib" can be loaded from an external shared file, so multiple maps can use the same "lib".

About items:

The "items" member of an object (mob or backpack), if it is an array reference, will be auto-expanded
by creating an item object for each array member with the parent object set as the first, unnamed, argument to new.

If a member of the items array is a hash ref, it's treated like a key entry.  If it's a scalar string, it's
equivalent to {lib=>'string'}.

If there's no class set within an item, a warning is emitted.

EXAMPLE 1:

 $map = '
 ##########
 #k <+  ! #
 ######## #
 #>  D    #
 ##########
 ';

 %key = (
	'k'=>{class=>'mymonster', type='kobold', name=>'Harvey', hd=>12,
	      items=>['potion of healing',
		      {class=>'myweapon', name=>'Blue Sword', hd=>9, dd=>4, drain=>1, glow=>1}
		     ]
	     },
	'!'=>{lib=>'potion of speed'},
	'D'=>{lib=>'blue dragon', name=>'Charlie', hp=>209},
	'+'=>{color=>'blue'}
       );

 %lib = (
	'potion of speed'=>{class=>'myitem', type=>'potion', effect=>'speed', power=>1},
	'blue dragon'=>{class=>'mymob', type=>'dragon', breath=>'lightning', hp=>180, hd=>12, at=>[10,5], dm=>[5,10], speed=>5, loot=>4},
       );

  $area->load(map=>$map, key=>%key, lib=>\%lib);

EXAMPLE 2:

 use Games::Roguelike::Caves;
 my $yx = generate_cave($r->{w},$r->{h}, 12, .46, '#', '.');
 $area->load(yxarray=>$yx);

=cut

sub load {
        my $self = shift;

        confess("cannot call load without a filename or a map/key and lib")
		if (!@_);

	my $map;
	my %key;
	my %lib;

        my ($fn);
	my %opts;

	if (@_ == 1) {
        	($fn) = @_;
	} else {
		%opts = @_;
		$fn = $opts{file};
	}

	if ($fn) {
    		eval {
		use Safe;
		my $in = new Safe;
		$in->permit_only(':base_core');
		$in->rdo($fn);
		$map = $in->reval('$map');
		%key = $in->reval('%key');
		%lib = $in->reval('%lib');
		};
	} else {
		$map = $opts{map};
		%key = %{$opts{key}} if $opts{key};
		%lib = %{$opts{lib}} if $opts{lib};
	}

	my $mapyx;

	if ($opts{yxarray} && ref($opts{yxarray})) {
		$mapyx = $opts{yxarray};
	} else {
		if (!$map) {
			cluck("no 'map' or 'xyarray' found in parameters");
			return 0;
		}
		$map =~ s/^[\r\n]+//;
		$map =~ s/[\r\n]+$//;
		my @ylines = split(/[\r\n]/,$map);
		my $y = 0;
		for (@ylines) {
                        my @l = split(//, $_);
                        $mapyx->[$y++]= \@l;
		}
	}

	$self->{map} = [];
	$self->{color} = [];

	my $y = 0;
	for (@{$mapyx}) {
		my $x = 0;
		for (@{$mapyx->[$y]}) {
			my $sym = $mapyx->[$y][$x];
			expandkey($sym, \%key, \%lib);
			my $opt = $key{$sym};
			if ($opt) {
				if ($opt->{sym}) {
					$sym = $self->{map}->[$x][$y] = $opt->{sym};
				}
				if ($opt->{class}) {
					$self->{map}->[$x][$y] = $self->{fsym};
					my $ob;
					my ($cpack) = caller;
					eval {$ob = $opt->{class}->new($self, x=>$x, y=>$y, sym=>$sym, %{$opt});};
					carp "failed to create $opt->{class}: $@" if !$ob;
					if (ref($opt->{items}) eq 'ARRAY') {
						for(@{$opt->{items}}) {
							if (!ref($_)) {
								expandkey($_, \%lib, \%lib);
								$_ = $lib{$_};
							} else {
								expandhash($_, \%lib);
							}
							my $it;
							eval {$it = $_->{class}->new($ob, %{$_});};
							carp "failed to create $_->{class}: $@" if !$ob;
						}
					}
				} else {
					if ($opt->{feature}) {
						push @{$self->{f}}, [$x, $y];
					}
					$self->{map}->[$x][$y] = $sym;
					$self->{color}->[$x][$y] = $opt->{color};
				}
			} else {
				$self->{map}->[$x][$y] = $mapyx->[$y][$x];
			}
			$x++;
		}
		$y++;
	}

	$self->{w} = @{$self->{map}};
	$self->{h} = @{$self->{map}->[0]};
}

# this looks in the hash "key" for an entry called "lib", which should be a string
# it then looks in the hash "lib" for that string
# finally it copied the keys from "lib" to the hash "key"
# really no reason for 2 hashes... 1 would suffice (for map keys and lib entries),
# but i think it's easier to keep track of for the users that way

sub expandhash {
	my ($hash, $lib) = @_;

        return if !$hash;
        return if $hash->{__lib__};
        return if !(my $libname = $hash->{lib});

        croak "no entry for '$libname'"
                if !$lib->{$libname};

        # allow recursion
        expandhash($lib, $lib);

        for (keys(%{$lib->{$libname}})) {
                next if $_ eq 'lib';
                $hash->{$_}=$lib->{$libname}->{$_};
        }

}

sub expandkey {
	my ($index, $key, $lib) = @_;
	return if !$key->{$index};
	expandhash($key->{$index}, $lib);
}


sub dprint {
	my $self=shift;
	if ($self->{world}) {
		$self->{world}->dprint(@_)
	} else {
		print @_, "\n";
	}
}

=back

=cut

# this allows the "generate" function to work and support the old interface

package Games::Roguelike::Area::Rooms;
use base 'Games::Roguelike::Area';

sub generate {
	Games::Roguelike::Area::genmaze1(@_);
}

package Games::Roguelike::Area::Cavelike;
use base 'Games::Roguelike::Area';

sub generate {
        Games::Roguelike::Area::genmaze2(@_);
}

package Games::Roguelike::Area::Maze;
use base 'Games::Roguelike::Area';

sub generate {
        Games::Roguelike::Area::genmaze3(@_);
}

=head1 SEE ALSO

L, L, L

=head1 AUTHOR

Erik Aronesty C

=head1 LICENSE

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

See L or the included LICENSE file.

=cut

1;