#!/usr/bin/perl

use strict;
use utf8;
use open ':encoding(UTF-8)';
use open ":std";
use Term::ANSIColor;
use Term::ReadKey;
use Data::Dumper; # For certain error messages.
use File::Spec::Functions;
use File::HomeDir;

my %cmdarg = @ARGV;

my $usecolor     = $cmdarg{color}     || 1;
my $COLNO        = ($cmdarg{mapwidth}  || 80) - 1; # - 1 because numbering starts at 0.
my $ROWNO        = ($cmdarg{mapheight} || 36) - 1;
my $aspect       = $cmdarg{aspect} ||  3/5;

my $walkable     = qr/ROOM|TREE|HILL|STAIR|DESERT|ALTAR/;
my $swimmable    = qr/POOL|LAKE|RIVER/;
my $flyable      = qr/ROOM|TREE|HILL|STAIR|DESERT|ALTAR|POOL|LAKE|RIVER/;

my $invwidth     = $cmdarg{invwidth} || 25; # Width of inventory sidebar, in characters, not counting frame.
warn "Inventory width too small, problems may result.\n" if $invwidth < 10;

my $errorcolor   = $cmdarg{errorcolor}  || "bold yellow on_red";
my $framecolor   = $cmdarg{framecolor}  || "magenta";
my $titlecolor   = $cmdarg{titlecolor}  || "bold magenta";
my $playercolor  = $cmdarg{playercolor} || "bold white";

my $showcoords   = $cmdarg{showcoords}  || 0;

my $autosave     = $cmdarg{autosave}    || 5;
my $homedir      = $cmdarg{homedir} || $ENV{HOME} || File::HomeDir->my_home || cwd();
my $cfgdir       = File::HomeDir->my_data || $homedir; {
  for my $dir (".config", "RogueLike", "Simple") {
    my $newdir = catfile($cfgdir, $dir);
    mkdir $newdir if not -d $newdir;
    $cfgdir = $newdir if -d $newdir;
  }}
my $savefile     = catfile($cfgdir, "savegame.dat");
my $keymapfile   = catfile($cfgdir, "keymap.cfg");
my $keymap;
if (-e $keymapfile) {
  $keymap = readconfigfile($keymapfile);
} else {
  $keymap = defaultkeymap();
  #writeconfig($keymapfile, $keymap);
}
my $reversekeymap = +{ reverse %$keymap };

my $turn         = 0;
my $playermoved  = 0;
my $messages     = [ ];
my %identified;

END { ReadMode 'restore'; } ReadMode 'cbreak'; # Don't auto-echo typed characters.

my %wdir = ( E => +{ bit => 1, dx =>  1, dy =>  0, clockwise => 'S', },
             N => +{ bit => 2, dx =>  0, dy => -1, clockwise => 'E', },
             W => +{ bit => 4, dx => -1, dy =>  0, clockwise => 'N', },
             S => +{ bit => 8, dx =>  0, dy =>  1, clockwise => 'W', },
           );
my %hungerlevel =
  ( bloated   => +{ maxnum => -1500, msg => "You are bloated.", },
    stuffed   => +{ maxnum =>  -500, msg => "You're stuffed.", },
    full      => +{ maxnum =>     0, msg => "Your stomach is full.", },
    caneat    => +{ maxnum =>   500, msg => "You are just a little peckish.", },
    hungry    => +{ maxnum =>  1500, msg => "You are hungry.", },
    famished  => +{ maxnum =>  3500, msg => "You're famished.", },
    faint     => +{ maxnum =>  5000, msg => "You feel light headed and sluggish.", },
    emaciated => +{ maxnum =>  9000, msg => "You are emaciated.", },
  );
my %attrmore = ( Str => "stronger", Dex => "more dextrous", Con => "sturdier", Int => "smarter",
                 Wis => "wiser",    Mor => "happier", );
my @dir_available = keys %wdir;
my @wallglyph = qw/! ─ │ └ ─ ─ ┘ ┴ │ ┌ │ ├ ┐ ┬ ┤ ┼/;
$wallglyph[0] = '-';
my @neighbormatrix = ([-1, -1], [0, -1], [1, -1],
                      [-1, 0],           [1, 0],
                      [-1, 1],  [0, 1],  [1, 1]);
my $maxobjid = 0;
my $maxmonid = 0;
my $maxlevid = 0;

my %terrain =
  ( field => +{ type => "ROOM",
                bg   => "on_black",
                fg   => "white",
                char => $cmdarg{floorchar} || '·',
                name => "field",
              },
    dessert => +{ type => "DESERT",
                  bg   => "on_black",
                  fg   => "bold yellow",
                  name => "desert",
                  char => $cmdarg{desertchar} || "░",
                },
    stone => +{ type => "STONE",
                bg   => "on_black",
                fg   => "white",
                name => "solid rock",
                char => " ",
              },
    mountain => +{ type => "HILL",
                   mp   => 2,
                   bg   => "on_black",
                   fg   => "bold white",
                   name => "mountain",
                   char => $cmdarg{mountainchar} || $cmdarg{hillchar} || ['Λ', 'Λ'],
                 },
    hill => +{ type => "HILL",
               bg   => "on_black",
               fg   => "yellow",
               name => "hill",
               char => $cmdarg{hillchar} || ['ʌ', '^'],
             },
    tree => +{ type => "TREE",
               bg   => "on_black",
               name => "tree",
               fg   => [("green") x 14, ("bold green") x 7, "yellow", "bold yellow", "bold black"],
               char => $cmdarg{treechar} || [('♠', '♣') x 3, '╕', '╒', '┬'],
             },
    lake => +{ type => "LAKE",
               name => "lake",
               bg   => "on_blue",
               fg   => "bold cyan",
               char => $cmdarg{waterchar} || "}",
             },
    river => +{ type => "RIVER",
                name => "river",
                bg   => "on_blue",
                fg   => "bold cyan",
                char => $cmdarg{waterchar} || "}",
              },
  );

my %monstertypeprops =
  (
   human   => +{ symbol => "h", terrain => $walkable, },
   bird    => +{ symbol => "b", terrain => qr/^(?!STONE)(?!WALL)/, moverate => 2.0, },
   rodent  => +{ symbol => "r", terrain => $walkable, },
   reptile => +{ symbol => "l", moverate => 0.75, },
  );

my %monstertype =
  (
   human => [ +{ name      => "necromancer",
                 alignment => "black",
                 color     => "bold black on_white",
                 maxhp     => 50,
                 inventory => sub {
                   my ($monster) = @_;
                   my $inv = +[];
                   for my $otype (qw(scroll spellbook)) {
                     for (1 .. int rand 3) {
                       push @$inv, instantiate_object($otype, undef, 1, +{ held => $$monster{monid}});
                     }}
                   return $inv;
                 },
               },
              +{ name      => "chaplin",
                 alignment => "white",
                 color     => "bold white",
                 maxhp     => 35,
                 inventory => sub {
                   my ($monster) = @_;
                   my $inv = +[];
                   for (1 .. int rand 3) {
                     push @$inv, instantiate_object("spellbook", undef, 1, +{ held => $$monster{monid} });
                   }
                   return $inv;
                 }},
            ],
   bird   => [
              +{ name      => "eagle",
                 alignment => "yellow",
                 color     => "bold yellow",
                 maxhp     => 10,
               },
              +{ name      => "phoenix",
                 alignment => "red",
                 color     => "bold red",
                 maxhp     => 15,
               },
             ],
   rodent => [
              +{ name        => "squirrel",
                 alignment   => "green",
                 color       => "green",
                 terrain     => $walkable,
                 faveterrain => qr/TREE/,
                 terrainmp   => +{ TREE => 0.5, },
                 maxhp       => 5,
               },
              +{ name        => "sloth",
                 alignment   => "green",
                 color       => "black on_green",
                 terrain     => $walkable,
                 faveterrain => qr/TREE/,
                 terrainmp   => +{ TREE => 0.3, },
                 maxhp       => 8,
                 moverate    => 0.1,
               },
             ],
   reptile => [
               +{ name        => "crocodile",
                  alignment   => "blue",
                  color       => "bold green on_blue",
                  terrain     => $flyable,
                  faveterrain => $swimmable,
                  maxhp       => 15,
                },
              ]
  );
my %enemyalignment = ( red => "green", green => "red", black => "white", white => "black", blue => "yellow", yellow => "blue" );

my %objtypeprops =
  ( # Individual entries in each objtype's list can override these properties.
   food      => +{ symbol => "%", ingestible => "eat", },
   scroll    => +{ symbol => "?", color "bold white", },
   potion    => +{ symbol => "!", ingestible => "drink", },
   spellbook => +{ symbol => "+", },
   treasure  => +{ symbol => '$', },
  );
my %objtype; # Will be loaded from saved game (so random appearances
             # are the same) or created fresh if starting a new game.

my ($player, $level, @level, $nextinvlet);
if (-e $savefile) {
  loadsavedgame();
} else {
  setupobjtypes();
  my $maxhp = 12 + int rand 3;
  $player = instantiate_monster("human", getmonstertemplate("human", "chaplin"),
                                +{
                                  inventory => [],
                                  attr      => +{ (map { $_ => (10 + int rand 8), } qw(Str Dex Con Int Wis Mor)), },
                                  xl        => 1,
                                  xp        => (int rand 20),
                                  hp        => (5 + int rand($maxhp - 5)),
                                  maxhp     => $maxhp,
                                  mp        => 1.00,
                                  symbol    => "@",
                                  ai        => "player",
                                  hunger    => $hungerlevel{caneat},
                                 });
  $nextinvlet = "a";
  for my $type (grep { not /treasure/ } sort keys %objtype) {
    my %seen;
    for (1 .. int rand 4) {
      my $obj = $objtype{$type}[rand @{$objtype{$type}}];
      if (not $seen{$$obj{name}}++) {
        push @{$$player{inventory}},
          instantiate_object($type, $obj, undef, +{ held => "__PLAYER__",
                                                    invlet => $nextinvlet, });
        $nextinvlet++;
      }
    }
  }

  $level = generate_overworld();
  $$player{x} = int($$level{xmax} / 2);
  $$player{y} = int($$level{ymax} / 2);
  my $maxtries = 1000;
  while ($maxtries-- and not ($$level{map}[$$player{x}][$$player{y}]{type} =~ $$player{terrain})) {
    print ".";
    $$player{x} = $$player{x} + 10 - int rand 5;
    $$player{y} = $$player{y} +  6 - int rand 3;
    $$player{x} = $$level{xmax} - int rand 5 if $$player{x} < 5;
    $$player{x} = int rand 5 if $$player{x} > $$level{xmax} - 5;
    $$player{y} = $$level{ymax} - int rand 3 if $$player{y} < 3;
    $$player{y} = int rand 3 if $$player{y} > $$level{ymax} - 3;
  }

  placemonster($level, $$player{x}, $$player{y}, $player, "force");
  push @$messages, +{ text => "You arrive at $$level{title}.", fg => "bold yellow", };
  $$level{map}[$$player{x}][$$player{y}]{visited}++;
}

cls("force");
showgame($level, $player, (-e $savefile) ? "Continue Saved Game" : "Game Start");
while ("forever") {
  my $movedany = 1;
  while ($movedany) {
    $movedany = 0;
    my $levid = $$level{levelid};
    for my $monidx (0 .. ((scalar @{$$level{monsters}}) - 1)) {
      if ($levid eq $$level{levelid}) {
        # If the level changes, the rest of the monsters miss their turn.
        # (However, they keep their movement points in that case.)
        my $monster = $$level{monsters}[$monidx];
        if ($$monster{mp} >= 1) {
          movemonster($monidx);
          $movedany++;
        }
      }
    }
    if ($movedany and $cmdarg{showmonstermoves}) {
      showgame($level, $player, "Turn $turn (monster move)");
    }
  }
  showgame($level, $player, "Turn $turn");
  $messages = [] if $playermoved;
  $playermoved = 0;
  $turn++;
  if (($autosave + 0) # Set to "disabled" to prevent autosaving.
      and not ($turn % $autosave)) {
    updatesavedgame();
  }
  for my $monidx (0 .. ((scalar @{$$level{monsters}}) - 1)) {
    $$level{monsters}[$monidx]{mp}     += $$level{monsters}[$monidx]{moverate};
    $$level{monsters}[$monidx]{hunger}++;
  }
  select undef, undef, undef, 0.1;
}

exit 0; # subroutines follow

################################################################
###                                                          ###
###           D i s p l a y   F u n c t i o n s  :           ###
###                                                          ###
################################################################

sub showgame {
  my ($level, $player, $caller) = @_;
  cls();

  my $xoffset = $$player{x} - int($COLNO / 2);
  if ($xoffset < 0) { $xoffset = 0; }
  if ($xoffset > ($$level{xmax} - $COLNO)) { $xoffset = $$level{xmax} - $COLNO; }
  my $yoffset = $$player{y} - int($ROWNO / 2);
  if ($yoffset < 0) { $yoffset = 0; }
  if ($yoffset > ($$level{ymax} - $ROWNO)) { $yoffset = $$level{ymax} - $ROWNO; }

  die "Level has no map " . Dumper(+{ level => $level, caller => $caller}) if not ref $$level{map};
  if ($showcoords) {
    print "    " . (join "", map { my $x = $_ + $xoffset; ($x % 10) ? " " : int(($x % 1000) / 100)  } 0 .. $COLNO )
      . (" " x ($invwidth + 2)) . "\n" if $showcoords >= 3;
    print "    " . (join "", map { my $x = $_ + $xoffset; ($x % 10) ? " " : int(($x % 100) / 10)  } 0 .. $COLNO )
      . (" " x ($invwidth + 2)) . "\n" if $showcoords >= 2;
    print "    " . (join "", map { my $x = $_ + $xoffset; ($x % 10) } 0 .. $COLNO) . "\n";
  }
  # Top line of frame:
  my $levtitle = $$level{title} . ($showcoords ? qq[ ($$player{x},$$player{y})] : "");
  print "" . ($showcoords ? "   " : "")
    . color($framecolor) . "╔═" . color("reset")
    . color($titlecolor) . $levtitle . color("reset")
    . color($framecolor) . ("═" x ($COLNO - length $levtitle)) . "╤═" . color("reset")
    . color($titlecolor) . "Inventory" . color("reset")
    . color($framecolor) . ("═" x ($invwidth - 10)) . "╗" . color("reset") . "\n";
  # Map and inventory:
  for my $y ($yoffset .. ($ROWNO + $yoffset)) {
    print "" . ($showcoords ? (sprintf "%03d", ($y % 1000)) : "")
    . color($framecolor) . "║" . color("reset");
    # Map:
    for my $x ($xoffset .. ($COLNO + $xoffset)) {
      # Background comes from the terrain:
      print color($$level{map}[$x][$y]{bg} || "on_black");
      if (($x == $$player{x}) and ($y == $$player{y})) {
        print color($playercolor) . "@";
      } else {

        my ($mon) = grep {
          my $m = $_;
          ($$m{x} eq $x)
            and
          ($$m{y} eq $y)
            # TODO: and check for invisibility
        } @{$$level{monsters}};

        my ($obj, @more) = grep {
          ($$_{x} == $x) and ($$_{y} == $y) and
            (not $$_{held}) and (not $$_{contained})
          } @{$$level{objects}};

        if ($mon) {
          print color($$mon{color}) . $$mon{symbol};
        } elsif ($obj) {
          # TODO: hilight the object pile if scalar @more
          print color($$obj{color}) . $$obj{symbol};
        } else {
          print color($$level{map}[$x][$y]{fg} || "white")
            . ($$level{map}[$x][$y]{char} || " ");
        }
      }
      print color "reset";
    }
    # Divider:
    print color($framecolor) . "│" . color("reset");
    # Inventory:
    die "Error: player has no inventory list in showgame() from $caller" if not ref $$player{inventory};
    if (($y - $yoffset) < scalar @{$$player{inventory}}) {
      my $obj  = $$player{inventory}[$y - $yoffset];
      my $name = objname($obj);
      $name = (substr($name, 0, ($invwidth - 5)));
      $name .= " " while (($invwidth - 5) > length($name . ""));
      print " "
        . color($$obj{color})
        . $$obj{invlet} . " " . $$obj{symbol} . " " . color("reset")
        . $name;
    } else {
      print (" " x $invwidth);
    }
    print color($framecolor) . "║" . color("reset") . "\n";
  }
  # Bottom of frame:
  print "" . ($showcoords ? "   " : "")
    . color $framecolor; print "╚" . ("═" x ($COLNO+1)) . "╧" . ("═" x $invwidth) . "╝" . color("reset") . "\n";
  if ($showcoords > 1) {
    print "    " . (join "", map { my $x = $_ + $xoffset; ($x % 10) ? " " : int(($x % 100) / 10)  } 0 .. $COLNO ) . "\n"
      if $showcoords > 2;
    print "    " . (join "", map { my $x = $_ + $xoffset; ($x % 10) } 0 .. $COLNO) . "\n";
  }
  print "" . ($showcoords ? "    " : "")
    . "HP: $$player{hp}/$$player{maxhp} XP:$$player{xp}($$player{xl}) "
    . (join " ", map { qq[$_:$$player{attr}{$_}] } sort { $a cmp $b } keys %{$$player{attr}})
    . " Turn:$turn\n";
  # Messages:
  for my $msg (@$messages) {
    print color($$msg{bg}) if $$msg{bg};
    print "" . ($showcoords ? "    " : "") . color($$msg{fg} || "white") . $$msg{text} . color("reset") . "\n";
  }
  #print "\n";
}

sub inventory {
  my $width = $cmdarg{fullinvwidth} || 35;
  my $totalwidth = $COLNO + $invwidth + 3 + ($showcoords ? 3 : 0);
  my $columns = int($totalwidth / ($width + 1));
  # The Schwartzian Transform here is because ASCII puts capital
  # letters first.  For inventory, we want lowercase first.
  my @item = map { $$_[0] } sort { $$a[1] cmp $$b[1] } map { my $item = $_;
                                                             my $let  = $$item{invlet};
                                                             $let =~ tr/a-zA-Z/A-Za-z/;
                                                             [ $item => $let ]
                                                           } @{$$player{inventory}};
  my $percolumn = (scalar @item) / $columns;
  $percolumn = int($percolumn) + 1 if $percolumn ne int $percolumn;
  cls("force");
  print color("reset") . color($titlecolor) . "Inventory:" . color("reset") . "\n";
  print color($framecolor) . (join " ", map { "═" x $width } 1 .. $columns) . color("reset") . "\n";
  for my $line (1 .. $percolumn) {
    for my $col (1 .. $columns) {
      my $index = (($col - 1) * $percolumn) + $line - 1;
      if ($index < scalar @item) {
        my $obj  = $item[$index];
        my $name = objname($obj);
        $name    = substr($name, 0, ($width - 4)) if length($name) > ($width - 4);
        $name    = $name . " " while (($width - 4) > length("".$name));
        print "" . color($$obj{color} || "white")
                 . $$obj{invlet} . " " . $$obj{symbol} . " " . color("reset") . $name;
      }
      print " " if $col < $columns;
    }
    print "\n";
  }
  print "\nPress Enter\n";
  <STDIN>;
  cls("force");
  showgame($level, $player, "inventory");
}

sub error {
  my ($msg) = @_;
  print color($errorcolor) . $msg . color("reset") . "\n";
  <STDIN> if $cmdarg{waitforenteronerror}
}

sub cls {
  my ($forceclear) = @_;
  if ($forceclear or $cmdarg{clearwhenredrawing}) {
    print "\033[2J"; # clear the screen
  } else {
    my $lnum = $ROWNO + 2 + ($cmdarg{showcoords} ? 2 : 0);
    print color("reset") . "\033[$ROWNO;0H" . join "\n", map {
      "\033[K"
    } 0 .. 10;
  }
  print "\033[0;0H"; # Jump to 0,0
}

sub domenu {
  my (%arg) = @_;
  $arg{question}  ||= "Menu:";
  my $gamestate = $arg{gamestate} ? " ($arg{gamestate})" : "";
  if ("ARRAY" ne ref $arg{options}) {
    error("domenu() called without a valid list of options");
    return; }
  cls("force");
  print $arg{question} . "\n";
  for my $item (@{$arg{options}}) {
    print "   " . $$item[0] . " - " . $$item[1] . "\n";
  }
  my $k = ReadKey 0;
  $k = undef if not grep { $$_[0] eq $k } @{$arg{options}};
  cls("force");
  showgame($level, $player, $gamestate);
}

################################################################
###                                                          ###
###            P l a y e r   F u n c t i o n s  :            ###
###                                                          ###
################################################################

sub cmd_dispatch {
  my ($command, $playeridx) = @_;
  if ($command =~ /move_(\w+)/) {
    my ($direction) = ($1);
    my %dircoord = ( northwest => [-1, -1], north => [ 0, -1], northeast => [ 1, -1],
                     west      => [-1,  0],                         east => [ 1,  0],
                     southwest => [-1,  1], south => [ 0,  1], southeast => [ 1,  1], );
    if (not ref $dircoord{$direction}) {
      error("Unrecognized direction for move command: '$direction'");
      return moveplayer($playeridx); }
    my ($dx, $dy) = @{$dircoord{$direction}};
    my $tx = $$level{monsters}[$playeridx]{x} + $dx;
    my $ty = $$level{monsters}[$playeridx]{y} + $dy;
    if (!withinmap($tx, $ty)) {
      my $edgex = ($tx < 1) ? -1 : ($tx >= $$level{xmax}) ? 1 : 0;
      my $edgey = ($ty < 1) ? -1 : ($ty >= $$level{ymax}) ? 1 : 0;
      if (($edgex or $edgey) and $$level{exit}{edge}[$edgex + 1][$edgey + 1]) {
        if ($edgex < 0) { $tx = $$level{xmax} - 1; } elsif ($edgex > 0) { $tx = 1; }
        if ($edgey < 0) { $ty = $$level{ymax} - 1; } elsif ($edgey > 0) { $ty = 1; }
        my ($newlevel) = grep { $$_{levelid} eq $$level{exit}{edge}[$edgex + 1][$edgey + 1] } @level;
        if (ref $newlevel) {
          changelevel($newlevel, $tx, $ty);
        } else {
          error("The edge of the world is broken" . ($showcoords ? " ($tx,$ty)" : "!"));
          return moveplayer($playeridx);
        }
      } else {
        error("You cannot move off the edge of the map" . ($showcoords ? " ($tx,$ty)" : "."));
        return moveplayer($playeridx);
      }
    } else {
      my @mon = map { $$level{monsters}[$_] } grep { $_ ne $playeridx } m_at($tx, $ty);
      if (@mon) {
        if (grep { is_enemy($$level{monsters}[$playeridx], $_) } @mon) {
          attack($level, $playeridx, $tx, $ty);
        } else {
          # TODO: chat with monsters
          my $msg = ucfirst thealignedmonster($mon[0])
                . ($showcoords ? " at ($mon[0]{x},$mon[0]{y})" : "")
                . " is not an enemy.";
          print color("cyan") . $msg . color("reset") . "\n";
          return;
        }
      } else {
        if (not ($$level{map}[$tx][$ty]{type} =~ $$level{monsters}[$playeridx]{terrain})) {
          error ("As a $$player{name}, you cannot traverse the $$level{map}[$tx][$ty]{name}");
          return;
        }
        if ($$level{monsters}[$playeridx]{terrainmp}{$$level{map}[$ty][$tx]{type}}) {
          $$level{monsters}[$playeridx]{mp}
            -= ($$level{monsters}[$playeridx]{terrainmp}{$$level{map}[$ty][$tx]{type}} - 1); # 1 mp is handled below.
        } elsif ($$level{map}[$tx][$ty]{mp}) {
          $$level{monsters}[$playeridx]{mp} -= ($$level{map}[$tx][$ty]{mp} - 1); # 1 mp is handled below.
        }
        $$level{map}[$tx][$ty]{visited}++;
        $$level{monsters}[$playeridx]{x} = $tx;
        $$level{monsters}[$playeridx]{y} = $ty;
      }
    }
  } elsif ($command eq "search") {
    dosearch($playeridx); # Always possible, and always uses a turn, whether it's useful or not.
  } elsif ($command eq "inventory") {
    inventory();
    return; # Inventory is a zero-time command.
  } elsif ($command eq "Ingest") {
    my ($obj, $where) = getdirectobject($playeridx, "mustbeheld", "ingestible");
    if ($obj) {
      doingest($playeridx, $obj, $where);
    } else {
      return;
    }
  } elsif ($command eq "pickup") {
    my ($x, $y) = ($$level{monsters}[$playeridx]{x}, $$level{monsters}[$playeridx]{y});
    my @obj = grep { ($$_{x} == $x) and ($$_{y} == $y) } @{$$level{objects}};
    if (not @obj) {
      error("There is nothing to pick up here.");
      return;
    }
    my ($gotanything, $didtoomuch) = (0, 0);
    for my $o (@obj) {
      my $stacked = 0;
      if (pickuptostack($o)) {
        $$level{objects} = [ grep { $$_{objid} ne $$o{objid} } @{$$level{objects}}];
        $gotanything++;
      } else {
        my $invlet = getfreeinvlet();
        if ($invlet) {
          my $name = theobject($o);
          my $up = ($$o{ontree} ? "" : " up");
          $$o{held}   = "__PLAYER__";
          $$o{ontree} = $$o{contained} = undef;
          $$o{invlet} = $invlet;
          push @$messages, +{ text => "You pick$up $name.", fg => "green" };
          $$level{objects} = [ grep { $$_{objid} ne $$o{objid} } @{$$level{objects}}];
          push @{$$player{inventory}}, $o;
          $gotanything++;
        } else {
          push @$messages, +{ text => "You are carrying as much as you can hold.", fg => "red", }
            unless $didtoomuch++;
        }
      }
    }
    return if not $gotanything;
  } else {
    error("Unrecognized command: '$command'");
    return moveplayer($playeridx);
  }
  # If no action is attempted, return early to avoid using movement points.
  $$player{mp} -= 1;
  $playermoved++;
}

sub pickuptostack {
  my ($obj, $objlist, $msg, $clr, $silent) = @_;
  $objlist ||= $$player{inventory};
  for my $stack (@$objlist) {
    if (canstack($obj, $stack)) {
      my $qtty = $$obj{qtty};
      $$stack{qtty} += $qtty;
      my $up = ($$obj{ontree} ? "" : " up");
      $msg ||= "You pick$up $$obj{qtty} more " . objname($obj) . ".";
      push @$messages, { text => $msg, fg => $clr || "green", } unless $silent;
      return $stack; # Caller is responsible for removing $o from its present location.
    }
  }
  return; # Caller must make alternate pickup arrangements.
}

sub moveplayer {
  my ($monidx) = @_;
  #$player = $$level{monsters}[$monidx];
  my $key = ReadKey 0;
  if ($$keymap{$key}) {
    cmd_dispatch($$keymap{$key}, $monidx);
  } else {
    error("Unmapped key: '$key'.");
    return;
  }
  #showgame($level, $$level{monsters}[$monidx], "Turn $turn (moveplayer)");
}

sub getfreeinvlet {
  my ($skip) = @_;
  $skip ||= +{};
  my @let = ("a" .. "z", "A" .. "Z");
  while ($nextinvlet gt $let[0]) {
    push @let, shift @let;
  }
  for my $l (@let) {
    if (not grep { $l eq $$_{invlet} } @{$$player{inventory}}) {
      $nextinvlet = $l;
      if ($nextinvlet eq "z") {
        $nextinvlet = "A";
      } elsif ($nextinvlet eq "Z") {
        $nextinvlet = "a";
      } else {
        $nextinvlet++;
      }
      return $l;
    }
  }
  return;
}

sub getdirectobject {
  my ($playeridx, $radius, @criteria) = @_;
  $radius ||= 1; # make $radius 0 but true if the item must be in inventory.
  my $player = $$level{monsters}[$playeridx];
  my @obj = map { +{ source => "(inventory)", obj => $_, } } @{$$player{inventory}};
  if ($radius > 1) {
    my %usedlet;
    for my $o (sort { $$a{dist} <=> $$b{dist}
                    } grep {
                      $$_{dist} <= $radius
                    } map {
                      my $obj = $_;
                      my $xdist = abs($$obj{x} - $$player{x});
                      my $ydist = abs($$obj{y} - $$player{y});
                      my $dist  = sqrt(($xdist * $xdist) + ($ydist * $ydist));
                      +{ obj => $obj, dist => $dist,
                         source => (($dist > 1) ? "($$obj{x},$$obj{y})" : "(here)")}
                    } @{$$level{objects}}) {
      my $invlet = getfreeinvlet( \%usedlet );
      $invlet ||= "," if not $usedlet{","}; # Can always choose the first object off the ground.
      if ($invlet) {
        $$o{obj}{invlet} = $invlet;
        push @obj, $o;
      }
    }}
  for my $criterion (@criteria) {
    @obj = grep { $$_{obj}{$criterion} } @obj;
  }
  my $invlet = domenu(question  => "What do you want to ingest?",
                      options   => [map { [$$_{obj}{invlet} => objname($$_{obj}) . " " . $$_{source} ] } @obj],
                      gamestate => "ingesting");
  if ($invlet) {
    my ($o) = grep { $$_{obj}{invlet} } @obj;
    if (ref $o) {
      return $$o{obj}, $$o{source};
    } else {
      error("objectmenu() returned invalid selection letter to getdirectobject()");
    }
  }
}

sub hungermsg {
  my ($hunger) = @_;
  my $level = (sort { $$a{maxnum} <=> $$b{maxnum} } grep { $$_{maxnum} >= $hunger } keys %hungerlevel)[0];
  return $hungerlevel{$level}{msg};
}

sub doingest {
  my ($playeridx, $obj, $where) = @_;
  my $verb = $$obj{ingestible};
  my $player = $$level{monsters}[$playeridx];
  if (($verb eq "eat") # You can drink potions regardless (though it's not guaranteed to be a good idea).
      and ($$player{hunger} <= $hungerlevel{full})) {
    error(hungermsg($$player{hunger}));
    return;
  }
  push @$messages, +{ text => "You $verb " . theobject($obj) . ".", color => "cyan", };
  if ($where =~ /inventory/) {
    $$level{monsters}[$playeridx]{inventory} = [grep { $$_{objid} ne $$obj{objid} } @{$$player{inventory}}];
  } else {
    $$level{objects} = [grep { $$_{objid} ne $$obj{objid} } @{$$level{objects}}];
  }
  if (ref $$obj{nutr}) {
    for my $nutrient (keys %{$$obj{nutr}}) {
      if ($nutrient eq "kcal") {
        $$player{hunger} -= (($$obj{nutr}{kcal} / 2) + rand($$obj{nutr}{kcal} / 2));
      } else {
        $$player{nutr}{$nutrient} += $$obj{nutr}{nutrient}; # TODO: make this relevant
      }
    }}
  if ($$obj{effect}) {
    doeffectonmonster(monster => $player, effect => $$obj{effect},
                      cause => +{ object => $obj, blame => $player },
                      playerknows => 1, isplayer => 1);
  }
}

sub doeffectonmonster {
  my (%arg) = @_;
  my $effect  = $arg{effect};
  my $monster = $arg{monster};
  if ($effect =~ /hydration/) { # TODO: make this relevant
    push @$messages, +{ text => "Your thirst is quenched.", fg => "green" } if $arg{isplayer};
    $identified{$effect} = "true" if ($arg{playerknows} || $arg{isplayer});
  }
  if ($effect =~ /health/) {
    if ($arg{isplayer} and ($$monster{hp} < $$monster{maxhp})) {
      push @$messages, ($$monster{hp} < ($$monster{maxhp} / 2))
        ? +{ text => "Your wounds are fully healed!", fg => "bold green" }
        : +{ text => "Your wounds are healed.", fg => "green" };
    } elsif ($arg{playerknows} and ($$monster{hp} < $$monster{maxhp})) {
      push @$messages, +{ text => ucfirst thepossessivemonster($monster) . " wounds are healed.",
                          fg   => (is_enemy($player, $monster) ? "red" :
                                   ($$monster{alignment} eq $$player{alignment}) ? "green" : "white"), };
    }
    $$monster{hp} = $$monster{maxhp};
    $identified{$effect} = "true" if ($arg{playerknows} || $arg{isplayer});
  }
  my %attreff = ( strength => "Str", dexterity => "Dex", constitution => "Con",
               intelligence => "Int", wisdom => "Wis", morale => "Mor" );
  for my $attrkey (keys %attreff) {
    if ($effect =~ /$attrkey/) {
      boostattribute($player, $attreff{$attrkey}, %arg);
      $identified{$effect} = "true" if ($arg{playerknows} || $arg{isplayer});
    }
  }
  # TODO: handle other effects potion: confusion, life, experience, illness, death
}

sub dosearch {
  my ($playeridx) = @_;
  my $playermon = $$level{monsters}[$playeridx];
  my $cx = $$playermon{x};
  my $cy = $$playermon{y};
  my $radius = 1.5 * ($$playermon{searchskill} || 1);
  my $foundanything;
  for my $x ($cx - $radius .. $cx + $radius) {
    for my $y ($cy - $radius .. $cy + $radius) {
      if (withinmap($x,$y) and not $$level{map}[$x][$y]{searched}) {
        $$level{map}[$x][$y]{searched}++;
        my $terrain = $$level{map}[$x][$y]{type};
        if (($terrain eq "TREE") and ((5 * ($$playermon{searchskill} || 1)) > int rand 100)) {
          if (50 > int rand 100) {
            my $fruit = instantiate_object("food", getobjecttemplate("food", "apple"), 1, +{ ontree => [$x, $y], });
            placeobject($level, $x, $y, $fruit);
            push @$messages, +{ text => "You see an apple on the tree.", fg => "green", };
            $foundanything++;
          } else {
            my $nuts = instantiate_object("food", getobjecttemplate("food", "bag of nuts"), 1);
            my $more = "";
            if (pickuptostack($nuts, undef, undef, undef, "silent")) {
              push @$messages, +{ text => "You bag up some more nuts from the ground.", fg => "green", };
            } else {
              push @$messages, +{ text => "You bag up some nuts from the ground.", fg => "green", };
              my $invlet = getfreeinvlet();
              if ($invlet) {
                $$nuts{invlet} = $invlet;
                push @{$$player{inventory}}, $nuts;
              } else {
                placeobject($level, $x, $y, $nuts);
                push @$messages, +{ text => "You are carrying as much as you can hold.", fg => "red", };
              }
            }
            $foundanything++;
          }
        }
      }
    }
  }
  if (not $foundanything) {
    push @$messages, +{ text => "You look around, but you don't find anything new.", fg => "yellow", };
  }
}

################################################################
###                                                          ###
###           M o n s t e r   F u n c t i o n s  :           ###
###                                                          ###
################################################################

sub thepossessivemonster {
  my ($monster) = @_;
  return "the " . ($$monster{possessive} || ($$monster{name} . "'s"));
}

sub themonster {
  my ($monster) = @_;
  return "the " . $$monster{name};
}

sub thealignedmonster {
  my ($monster) = @_;
  return "the " . $$monster{alignment} . " " . $$monster{name};
}

sub is_enemy {
  my ($attacker, $defender) = @_;
  if ($enemyalignment{$$attacker{alignment}} eq $$defender{alignment}) {
    return $$defender{alignment};
  } elsif ($$attacker{alignment} eq $$defender{alignment}) {
    return 0;
  } else {
    return undef;
  }
}

sub m_at { # returns a list of indices into the current level's monsters list.
  my ($x, $y) = @_;
  return (grep { my $idx = $_;
                 my $m = $$level{monsters}[$idx];
                 ($$m{x} eq $x) and ($$m{y} eq $y)
               } 0 .. ((scalar @{$$level{monsters}}) - 1));
}

sub attack {
  error("Not implemented: attack()");
}

sub boostattribute {
  my ($monster, $attribute, %arg) = @_;
  if ($$monster{attr}{$attribute} < $$monster{attrmax}{$attribute}) {
    $$monster{attr}{$attribute}++;
    if ($arg{isplayer}) {
      push @$messages, +{ text => "You feel $attrmore{$attribute}.", fg => "green", };
    } elsif ($arg{playerknows}) {
      push @$messages, +{ text => ucfirst(themonster($monster)) . "seems $attrmore{$attribute}.", fg => "white", };
    }
  }
}

sub movemonster {
  my ($monidx) = @_;
  my $monster = $$level{monsters}[$monidx];
  if ($$monster{ai} eq "player") {
    return moveplayer($monidx);
  }
  # TODO: support other alternative ai values here.

  # Proceed with the default ai:
  my @action;
  # TODO: consider using an inventory item
  # TODO: check for nearby enemies to attack
  # Consider moving to a different tile:
  my $mx = $$monster{x};
  my $my = $$monster{y};
  my @coord = grep {
    my ($x, $y) = @$_;
    $$level{map}[$x][$y]{type} =~ $$monster{terrain}
  } grep {
    withinmap(@$_)
  } map {
    my $tx = $_;
    map {
      my $ty = $_;
      [$mx + $tx, $my + $ty];
    } (-1, 0, 1);
  } (-1, 0, 1);
  error("No coords after terrain check ($$monster{terrain}) for monster $monidx") if ($cmdarg{debugcoords} and not @coord);
  @coord = grep {
    ($$_[0] ne $mx) or ($$_[1] ne $my)
  } grep {
    my ($tx, $ty) = @$_;
    not grep { ($$_{x} eq $tx) and ($$_{y} eq $ty) } @{$$level{monsters}};
  } @coord;
  for my $c (@coord) {
    my ($x, $y) = @$c;
    my $desire = 5;
    $desire = $desire * 3 / 2 if $$level{map}[$x][$y]{type} =~ $$level{monsters}[$monidx]{faveterrain};
    push @action, [$desire, "moveto", $c];
  }
  # TODO: consider other possible actions
  if (not @action) {
    error(ucfirst themonster($monster) . " (#$monidx) at ($mx,$my) has no course of action");
    return;
  }
  my $action  = $action[rand @action]; # TODO: weight the results based on the desirability number
  if ($$action[1] eq "moveto") {
    my ($tx, $ty) = @{$$action[2]};
    $$level{monsters}[$monidx]{x} = $tx;
    $$level{monsters}[$monidx]{y} = $ty;
    $$level{monsters}[$monidx]{mp} -= ($$level{monsters}[$monidx]{terrainmp}{$$level{map}[$tx][$ty]{type}} || 1);
  } else {
    error("Unsupported monster action: $$action[1]");
  }
}

sub placemonster {
  my ($level, $x, $y, $monster, $force) = @_;
  my $maxtries = 200;
  while ((not $x) or (not $y) or
         ((($maxtries > 0) and not $force) and
          m_at($x, $y))) {
    $x = 1 + int rand ($$level{xmax} - 1);
    $y = 1 + int rand ($$level{ymax} - 1);
    if (($maxtries-- > 0) and
        not ($$level{map}[$x][$y]{type} =~ $$monster{($maxtries > 50) ? "faveterrain" : "terrain"})) {
      ($x, $y) = (undef, undef);
    }
  }
  $$monster{x} = $x;
  $$monster{y} = $y;
  push @{$$level{monsters}}, $monster;
}

sub getmonstertemplate {
  my ($type, $name) = @_;
  $type ||= (keys %monstertype)[rand keys %monstertype];
  $name ||= (keys %{$monstertype{$type}})[rand keys %{$monstertype{$type}}];
  my @template = grep { $$_{name} eq $name } @{$monstertype{$type}};
  if (wantarray) {
    return @template;
  } else {
    return $template[0];
  }
}

sub instantiate_monster {
  my ($type, $monster, $set) = @_;
  $type    ||= (keys %monstertype)[rand keys %monstertype];
  $monster ||= $monstertype{$type}[rand @{$monstertype{$type}}];
  $set     ||= +{};
  $maxmonid++;
  my $m = +{ type      => $type,
             ai        => "default",
             mp        => 0,
             moverate  => 1.00, # 1.00 is "default speed"
             terrainmp => +{},
             inventory => [],
             attrmax   => +{ Str => 20, map { $_ => 18 } qw(Dex Con Int Wis Mor) },
             %{$monstertypeprops{$type}},
             %$monster,
             monid     => $maxmonid,
             %$set,
           };
  $$m{faveterrain} ||= $$m{terrain};
  for my $field (qw(inventory)) {
    if ((ref $$m{$field}) eq "CODE") {
      $$m{$field} = $$m{$field}->($m);
    }
  }
  $$m{hp} ||= $$m{maxhp};
  return $m;
}

################################################################
###                                                          ###
###            O b j e c t   F u n c t i o n s  :            ###
###                                                          ###
################################################################

sub objname {
  # This is the object's name as it appears in player inventory.
  # Plural objects have the number, but singular ones don't have an article.
  my ($obj) = @_;
  return (($$obj{qtty} > 1) ? ("$$obj{qtty}" . " " . pluralobj($obj)) : $$obj{name})
    . (($$obj{effect} and $identified{$$obj{effect}}) ? " of $$obj{effect}" : "");
}

sub anobject { # This is "a thing" or "an object" or "3 things" or whatever.
  my $obj = @_;
  my $name = (($$obj{qtty} > 1) ? pluralobj($obj) : $$obj{name});
  return ($$obj{anobj} || $name)
    . (($$obj{effect} and $identified{$$obj{effect}}) ? " of $$obj{effect}" : "");
}

sub theobject { # This is "the thing" or "6 things" or whatever.
  my ($obj) = @_;
  return "the " . (($$obj{qtty} > 1) ? pluralobj($obj) : $$obj{name})
    . (($$obj{effect} and $identified{$$obj{effect}}) ? " of $$obj{effect}" : "");
}

sub pluralobj {
  my ($obj) = @_;
  if ($$obj{plural}) {
    return $$obj{plural};
  } elsif ($$obj{name} =~ /(.+)( of .+)/) {
    my ($basename, $ofthing) = ($1, $2);
    return pluralobj(+{ name => $basename }) . $ofthing;
  } elsif ($$obj{name} =~ /[szx]$/) {
    return $$obj{name} . "es";
  } elsif ($$obj{name} =~ /[y]$/) {
    my $plural = $$obj{name};
    $plural =~ s/y$/ies/;
    return $plural;
  } elsif ($$obj{name}) {
    return $$obj{name} . "s";
  } else {
    return "things";
  }
}

sub canstack {
  my ($obj, $stack) = @_;
  for my $field (qw(symbol name effect color)) {
    if ((exists $$obj{$field}) and (exists $$stack{$field})) {
      return if $$obj{$field} ne $$stack{$field};
    }}
  return ($$stack{qtty} || 1) + ($$obj{qtty} || 1);
}

sub placeobject {
  my ($level, $x, $y, $obj) = @_;
  my $maxtries = 1000;
  while ((not $x) or (not $y)) {
    $x = 1 + int rand ($$level{xmax} - 1);
    $y = 1 + int rand ($$level{ymax} - 1);
    if ($maxtries-- and
        not ($$level{map}[$x][$y]{type} =~ $walkable)) {
      ($x, $y) = (undef, undef);
    }
  }
  $$obj{x} = $x;
  $$obj{y} = $y;
  $$obj{held} = $$obj{contained} = undef;
  push @{$$level{objects}}, $obj;
}

sub getobjecttemplate {
  my ($type, $name) = @_;
  $type ||= (keys %objtype)[rand keys %objtype];
  $name ||= (keys %{$objtype{$type}})[rand keys %{$objtype{$type}}];
  my @template = grep { $$_{name} eq $name } @{$objtype{$type}};
  if (wantarray) {
    return @template;
  } else {
    return $template[0];
  }
}

sub instantiate_object {
  my ($type, $obj, $qtty, $set) = @_;
  $type ||= (keys %objtype)[rand keys %objtype];
  $obj  ||= $objtype{$type}[rand @{$objtype{$type}}];
  $qtty ||= (int rand rand rand 10) || 1;
  $set  ||= +{};
  $maxobjid++;
  my $o = +{ type => $type,
             %{$objtypeprops{$type}},
             %$obj,
             objid  => $maxobjid,
             qtty   => $qtty,
             %$set,
           };
  return $o;
}

sub setupobjtypes {
  my @scrollappearance = shuffle("crinkled scroll", "garbled scroll", "strange scroll", "foreign scroll", "exotic scroll",
                                 "parchment scroll", "papyrus scroll", "paper scroll", "clay tablet", "pristine scroll",
                                 "simple scroll", "filigreed scroll", "fancy scroll", "narrow scroll", "wide scroll", );
  my @potionappearance = shuffle(+{ name => "dark blue potion",  color => "blue", },
                                 +{ name => "red potion",        color => "red", },
                                 +{ name => "clear potion", },
                                 +{ name => "green potion",      color => "green", },
                                 +{ name => "light blue potion", color => "cyan", },
                                 +{ name => "milky potion",      color => "bold white", },
                                 +{ name => "brown potion",      color => "yellow", },
                                 +{ name => "yellow potion",     color => "bold yellow", },
                                 +{ name => "dark potion",       color => "bold black", },
                                 +{ name => "purple potion",     color => "magenta", },
                                 +{ name => "pink potion",       color => "bold magenta", },
                                );
  %objtype =
    (
     food => [
              +{ name => "small loaf", plural => "small loaves", color => "yellow", nutr => +{ kcal => 228, prot => 7, }, },
              +{ name => "jerked meat", plural => "pieces of jerked meat", color => "red", nutr => +{ kcal => 410, prot => 33, }, },
              +{ name => "apple", color => "bold red", nutr => +{ kcal => 65, A => 65, C => 6, }, },
              +{ name => "meat pie", color => "yellow", nutr => +{ kcal => 600, prot => 20, C => 1, }, },
              +{ name => "cram wafer", color => "white", nutr => +{ kcal => 500, prot => 1, }, },
              +{ name => "tuber", color => "yellow", nutr => +{ kcal => 200, prot => 4, C => 24, }, },
              +{ name => "wedge of cheese", color => "bold yellow", nutr => +{ kcal => 530, prot => 32, A => 1323, }, },
              +{ name => "small melon", color => "bold green", nutr => +{ kcal => 125, prot => 2, A => 177, C => 64, }, },
              +{ name => "bag of nuts", anobj => "some nuts", color => "yellow", nutr => +{ kcal => 380, prot => 9, A => 12, },  },
              +{ name => "cake of figs", color => "bold black", nutr => +{ kcal => 150, prot => 2, A => 5, C => 6, }, },
              +{ name => "cake of raisins", color => "bold black", nutr => +{ kcal => 250, prot => 3, C => 2, }, },
              +{ name => "smoked fish", plural => "smoked fish", color => "white", nutr => +{ kcal => 320, prot => 70, A => 200, } },
              +{ name => "oat cake", color => "yellow",  nutr => +{ kcal => 140, prot => 6, A => 3, }, },
              +{ name => "barley cake", color => "yellow", nutr => +{ kcal => 250, prot => 7, }, },
             ],
     scroll => [
                +{ name => (scalar(shift @scrollappearance) || "scroll"), effect => "identification", },
                +{ name => (scalar(shift @scrollappearance) || "scroll"), effect => "teleportation", },
                +{ name => (scalar(shift @scrollappearance) || "scroll"), effect => "enhancement", },
                +{ name => (scalar(shift @scrollappearance) || "scroll"), effect => "recall", },
                +{ name => (scalar(shift @scrollappearance) || "scroll"), effect => "summoning", },
                +{ name => (scalar(shift @scrollappearance) || "scroll"), effect => "conflagration", },
                +{ name => (scalar(shift @scrollappearance) || "scroll"), effect => "inundation", },
                +{ name => (scalar(shift @scrollappearance) || "scroll"), effect => "forestry", },
                +{ name => (scalar(shift @scrollappearance) || "scroll"), effect => "avalanche", },
                +{ name => (scalar(shift @scrollappearance) || "scroll"), effect => "flight", },
               ],
     potion => [
                +{ name => "skin of water",    effect => "hydration", },
                +{ name => "skin of wine",     effect => "confusion", color => "bold red", nutr => +{ kcal => 400, A => 18, }, },
                +{ %{scalar(shift @potionappearance)}, effect => "health", },
                +{ %{scalar(shift @potionappearance)}, effect => "wisdom", },
                +{ %{scalar(shift @potionappearance)}, effect => "strength", },
                +{ %{scalar(shift @potionappearance)}, effect => "life", },
                +{ %{scalar(shift @potionappearance)}, effect => "dexterity", },
                +{ %{scalar(shift @potionappearance)}, effect => "constitution", },
                +{ %{scalar(shift @potionappearance)}, effect => "intelligence", },
                +{ %{scalar(shift @potionappearance)}, effect => "morale", },
                +{ %{scalar(shift @potionappearance)}, effect => "experience", },
                +{ %{scalar(shift @potionappearance)}, effect => "illness", },
                +{ %{scalar(shift @potionappearance)}, effect => "death", },
               ],
     spellbook => [
                   +{ name => "book of hymns", },
                   +{ name => "holy scripture", },
                   +{ name => "battered spellbook", },
                   +{ name => "thick spellbook", },
                   +{ name => "creased spellbook", },
                   +{ name => "papyrus spellbook", },
                   +{ name => "parchment spellbook", },
                   +{ name => "leather-bound spellbook", },
                   +{ name => "empty spellbook", },
                   +{ name => "dark spellbook", },
                   +{ name => "sinister spellbook", },
                   +{ name => "grimoire", },
                  ],
     treasure => [
                  +{ name => "bronze sheckel", color => "yellow",       value =>    0.25, },
                  +{ name => "copper farthing", color => "bold red",    value =>    1.00, },
                  +{ name => "piece of eight", color => "white",        value =>    5.00, },
                  +{ name => "gold dabloon", color => "bold yellow",    value =>   25.00, },
                  +{ name => "platinum zorkmid", color => "bold white", value =>  100.00, },
                  +{ name => "silicon blasius", color => "cyan",        value =>  500.00, plural => "blasii", },
                  +{ name => "diamond", color => "bold white",          value => 1200.00, symbol => "*", },
                  +{ name => "ruby", color => "red",                    value => 2400.00, symbol => "*", },
                 ],
    );
}

################################################################
###                                                          ###
###             L e v e l   F u n c t i o n s  :             ###
###                                                          ###
################################################################

sub changelevel {
  my ($newlevel, $newx, $newy) = @_;
  return error("changelevel() called with invalid level: $newlevel") if not ref $newlevel;
  # Remove the player from the current level:
  $$level{monsters} = +[ grep { $$_{monid} ne $$player{monid} } @{$$level{monsters}} ];
  # Mark the new level as the current one:
  $level = $newlevel;
  $$player{x} = $newx if defined $newx;
  $$player{y} = $newy if defined $newy;
  push @{$$level{monsters}}, $player;
  $$level{map}[$$player{x}][$$player{y}]{visited}++;
  push @$messages, +{ text => "You arrive at $$level{title}", fg => "bold yellow"};
  showgame($level, $player, "level change");
  return $level;
}

sub generate_overworld {
  $level = +{ xmax => 299, ymax => 199 };
  my $map;
  for my $x (0 .. $$level{xmax}) {
    for my $y (0 .. $$level{ymax}) {
      $$map[$x][$y] = maketerrain("field");
    }
  }
  for (1 .. int rand 50) {
    placeforest($map, "dessert");
  }
  for (1 .. 30 + int rand 30) {
    placelake($map, undef, undef, 2 + int rand rand 25, 20 + int rand 20);
  }
  for (1 .. int rand 50) {
    placeforest($map);
  }
  for (1 .. 5 + int rand 50) {
    placemountrange($map);
  }
  # Good, now cut it up into 100x50 chunks...
  my @section;
  my @secname = get_overland_names();
  for my $xoffset (0, 100, 200) {
    my $sectionx = $xoffset / 100;
    for my $yoffset (0, 50, 100, 150) {
      my $sectiony = $yoffset / 50;
      my $sectionmap;
      for my $x (0 .. 99) {
        for my $y (0 .. 49) {
          $$sectionmap[$x][$y] = $$map[$xoffset + $x][$yoffset + $y];
        }
      }
      $level = +{ map      => $sectionmap,
                  title    => "Wilderlands [$sectionx,$sectiony]: " . shift @secname,
                  xmax     => 99,
                  ymax     => 49,
                  monsters => [],
                  objects  => [],
                  levelid  => $maxlevid++,
                };
      for (1 .. 20 + int rand 20) {
        my $obj = instantiate_object();
        placeobject($level, undef, undef, $obj);
      }
      for (1 .. 20 + int rand 20) {
        my $mon = instantiate_monster();
        placemonster($level, undef, undef, $mon);
      }
      push @level, $level;
      $section[$sectionx][$sectiony] = $level;
    }
  }
  for my $sectionx (0 .. 2) {
    for my $sectiony (0 .. 3) {
      for my $edgex (-1, 0, 1) {
        for my $edgey (-1, 0, 1) {
          if (($sectionx + $edgex >= 0) and ($sectiony + $edgey >= 0) and
              ($sectionx + $edgex <= 2) and ($sectiony + $edgey <= 3)
              and ($edgex or $edgey)
             ) {
            print "section ($sectionx,$sectiony), id $section[$sectionx][$sectiony]{levelid}, edge($edgex,$edgey),"
              . " destid " . ($section[$sectionx + $edgex][$sectiony + $edgey]{levelid}) . "\n";
            $section[$sectionx][$sectiony]{exit}{edge}[$edgex + 1][$edgey + 1] =
              $section[$sectionx + $edgex][$sectiony + $edgey]{levelid};
          }}}}}
  #print "Press Enter.\n";<STDIN>;
  return $section[1][1 + int rand 2];
}

sub get_overland_names {
  my @base = shuffle(qw(Heartland Wasteland Purlieu Region   Township Kingdom    Country Home
                        Earldom   District  Domain  Duchy    Preserve Territory  Parish  Commonwealth
                        Homestead Heritage  Plateau Field    Province Fatherland Colony  Ward
                        Mainland  Estate    Expanse Nation   Dominion Motherland Realm   Place));
  return shuffle(("Morose " . shift @base), ("Mystical " . shift @base),  ("Meaningless " . shift @base), ((shift @base) . " of Portent"),
                 ("Empty " . shift @base),  ("Hopeless " . shift @base),  ("Legendary " . shift @base),   ((shift @base) . " of Sorrow"),
                 ("Fated " . shift @base),  ("Horrible " . shift @base),  ("Fantastic " . shift @base),   ((shift @base) . " of Terror"),
                 ("Remote " . shift @base), ("Pleasant " . shift @base),  ((shift @base) . " of Glory"),  ((shift @base) . " of Greatness"),
                 ("Sordid " . shift @base), ("Pungeant " . shift @base),  ((shift @base) . " of Shame"),  ((shift @base) . " Under the Sky"),
                 ("Lost " . shift @base),   ("Dangerous " . shift @base), ((shift @base) . " of Risk"),   ((shift @base) . " Without Walls"),
                 ("Severe " . shift @base), ("Ancient " . shift @base),   ((shift @base) . " of Hope"),   ((shift @base) . " of Idiots"),
                 ("Deadly " . shift @base), ("Deserted " . shift @base),  ((shift @base) . " of Death"),
                );
}

sub generate_roundlev {
  my ($levnum) = @_;
  my $cx = int(($COLNO - 1) / 2);
  my $cy = int(($ROWNO - 1) / 2);
  my $radius = (($cx * $aspect) > $cy) ? ($cy - 1) : (int($cx * $aspect) - 1);
  print "center: ($cx, $cy); radius: $radius\n";
  my $treefreq     = rand rand 40;  $treefreq   = 0 if $treefreq   < (1  + int rand 5);
  my $hillfreq     = rand rand 35;  $hillfreq   = 0 if $hillfreq   < (2  + int rand 7);
  my $mountfreq    = rand rand 20;  $mountfreq  = 0 if $mountfreq  < (1  + int rand 4);
  my $islefreq     = rand rand 40;  $islefreq   = 0 if $islefreq   < (1  + int rand 5);
  my $desertfreq   = rand rand 120; $desertfreq = 0 if $desertfreq < (10 + int rand 50);
  my $numlakes     = int rand 6;
  my $numforests   = int rand 10;   $numforests = 0 if $numforests < (1 + int rand 5);
  my $numranges    = (30 > int rand 100) ? (1 + int rand rand 3) : 0;

  if ($numforests and (50 > int rand 100)) { $treefreq = 0; }
  # Note that mountfreq and islefreq are conversion rates for hills.
  # desertfreq is a conversion rate for regular floor.
  print sprintf qq[C: $usecolor; ViewSize: ($COLNO,$ROWNO)
Freq: %0.3f tree, %0.3f hill, %0.3f mtn; %0.3f isl; %0.3f dsrt;
      %0.3f L; %0.3f F; %0.3f M\n],
  $treefreq, $hillfreq, $mountfreq, $islefreq, $desertfreq,
  $numlakes, $numforests, $numranges;

  $level = +{ xmax => $COLNO, ymax => $ROWNO, };

  my $map;
  for my $x (0 .. $COLNO) {
    for my $y (0 .. $ROWNO) {
      my $xdist = int(abs($x - $cx) * $aspect);
      my $ydist = abs($y - $cy);
      my $dist = sqrt(($xdist * $xdist) + ($ydist * $ydist));
      if ($dist >= $radius) {
        $$map[$x][$y] = maketerrain("stone");
      } elsif ($hillfreq > rand 100) {
        if ($mountfreq > rand 100) {
          $$map[$x][$y] = maketerrain("mountain");
        } else {
          $$map[$x][$y] = maketerrain("hill");
        }
      } elsif ($treefreq > rand 100) {
        $$map[$x][$y] = maketerrain("tree");
      } else {
        my $isdesert = ($desertfreq > rand 100) ? 1 : 0;
        $$map[$x][$y] = maketerrain($isdesert ? "dessert" : "field");
      }
    }
  }
  $map = fixupwalls($map);
  for (1 .. $numlakes) {
    placelake($map, undef, undef, undef, $islefreq);
  }
  for (1 .. $numranges) {
    placemountrange($map);
  }
  for (1 .. $numforests) {
    placeforest($map, undef, undef, undef, $islefreq, undef, undef, 1 + rand int rand int rand 12);
  }
  $level = +{ map      => $map,
              title    => "Terra Opthalia " . $levnum,
              xmax     => $COLNO,
              ymax     => $ROWNO,
              monsters => [],
              objects  => [],
              levelid  => $maxlevid++,
            };
  for (1 .. 5 + int rand 5) {
    my $obj = instantiate_object();
    placeobject($level, undef, undef, $obj);
  }
  for (1 .. 5 + int rand 10) {
    my $mon = instantiate_monster();
    placemonster($level, undef, undef, $mon);
  }
  push @level, $level;
  return $level;
}

sub placeforest { # can also be used e.g. for lakes
  my ($map, $terrain, $prob, $doislands, $islefreq, $cx, $cy, $radius) = @_;
  $terrain ||= "tree";
  $prob    ||= 95 - int rand int rand 80;
  $cx      ||= 5 + rand ($$level{xmax} - 10);
  $cy      ||= 3 + rand ($$level{ymax} - 6);
  $radius  ||= 1 + rand int rand ((($$level{xmax} > $$level{ymax}) ? $$level{ymax} : $$level{xmax}) / 4);
  my $minx = $cx - ($radius / $aspect);
  my $maxx = $cx + ($radius / $aspect);
  my $miny = $cy - $radius;
  my $maxy = $cy + $radius;
  for my $x ($minx .. $maxx) {
    for my $y ($miny .. $maxy) {
      if (withinmap($x,$y) and ($prob > rand 100)) {
        my $xdist = abs($cx - $x) * $aspect;
        my $ydist = abs($cy - $y);
        my $dist = sqrt(($xdist * $xdist) + ($ydist * $ydist));
        if (($dist <= $radius) and not ($$map[$x][$y]{type} =~ /STONE|WALL|STAIR|POOL|ALTAR|LAKE|RIVER/)) {
          if (($$map[$x][$y]{type} ne "HILL") or
              (not $doislands) or
              ($islefreq * (($$map[$x][$y]{fg} eq "bold white") ? 1.5 : 1) <= int rand 100)) {
            $$map[$x][$y] = maketerrain($terrain);
          }
        }}
    }}
}

sub maketerrain {
  my ($terrainkey) = @_;
  my $tile = +{ %{$terrain{$terrainkey}} };
  for my $field (qw(fg bg char type)) {
    if ((ref ($$tile{$field})) eq 'ARRAY') {
      $$tile{$field} = ${$$tile{$field}}[rand @{$$tile{$field}}];
    }}
  return $tile;
}

sub placemountrange { # can also be used e.g. for rivers.
  my ($map, $halfterrain, $fullterrain, $prob, $xone, $yone, $xtwo, $ytwo, $dx, $dy) = @_;
  warn "placemountrange();\n";
  $halfterrain ||= "hill";
  $fullterrain ||= "mountain";
  $prob ||= 33 + int rand 34;
  $xone ||= 2 + int rand ($$level{xmax} / 2);
  $yone ||= ($$level{ymax} / 3) + rand (($$level{ymax} + 1) / 3);
  $xtwo ||= $xone + 1 + rand 5;
  $ytwo ||= $yone;
  $dx   ||= 1 + rand rand($xtwo - $xone);
  $dy   ||= (50 > rand 100) ? 1 : -1;
  my $maxsize = $$level{ymax} / 2;
  while (withinmap($xone, $yone) and withinmap($xtwo, $ytwo) and
         (abs($dx) > 0) and (abs($dy) > 0) and ($maxsize-- > 0)) {
    for my $x ($xone .. $xtwo) {
      for my $y ($yone .. $ytwo) {
        if (($$map[$x][$y]{type} =~ /ROOM|DESERT/) and ($prob > int rand 100)) {
          $$map[$x][$y] = maketerrain(($prob > int rand 100) ? $fullterrain : $halfterrain);
          for my $field (qw(fg bg char type)) {
            if (ref ($$map[$x][$y]{$field})) {
              $$map[$x][$y]{$field} = ${$$map[$x][$y]{$field}}[rand @{$$map[$x][$y]{$field}}];
            }}
        }
      }
    }
    $xone += $dx;
    $xtwo += $dx;
    $yone += $dy;
    $ytwo += $dy;
    $dx = ($dx / abs($dx)) * (1 + abs(($dx - 1) / 3) + rand(abs(($dx - 1)) * 4 / 3));
  }
  warn "  * exiting\n";
}

sub placelake {
  my ($map, $cx, $cy, $radius, $islefreq) = @_;
  placeforest($map, "lake", 100, "doislands", $islefreq, $cx, $cy, $radius);
}

sub countadjacent {
  my ($map, $x, $y, $type, $char) = @_;
  my $count = 0;
  for my $cx (($x - 1) .. ($x + 1)) {
    for my $cy (($y - 1) .. ($y + 1)) {
      if (($x == $cx) and ($y == $cy)) {
        # The tile itself does not count.
      } elsif (!withinmap($cx,$cy)) {
        # Out of bounds, doesn't count
      } elsif ($$map[$cx][$cy]{type} =~ $type) {
        #if ((not $char) or ($char eq $$map[$cx][$cy]{char})) {
          $count++;
        #}
      }
    }
  }
  return $count;
}

sub countortho {
  my ($map, $x, $y, $type) = @_;
  my $count = 0;
  for my $dx (-1 .. 1) {
    for my $dy (-1 .. 1) {
      if ((abs($dx) xor abs($dy)) and
          ($$map[$x + $dx][$y + $dy]{type} eq $type)) {
        $count++;
      }
    }
  }
  return $count;
}

sub withinmap{
  my ($x, $y) = @_;
  if (($x >= 0) and ($x <= $$level{xmax}) and
      ($y >= 0) and ($y <= $$level{ymax})) {
    return "within map";
  } else {
    return;
  }
}

sub fixupwalls {
  my ($map) = @_;
  for my $x (0 .. $$level{xmax}) {
    for my $y (0 .. $$level{ymax}) {
      my $fg = $$map[$x][$y]{fg} || 'yellow';
      if ($$map[$x][$y]{type} =~ /STONE|WALL|UNDECIDED/) {
        if (countadjacent($map, $x, $y, $walkable)) {
          $$map[$x][$y] = +{ type => 'WALL',
                             name => "wall",
                             char => '-',
                             bg   => 'on_black',
                             fg   => $fg,
                           };
        } else {
          $$map[$x][$y] = +{ type => 'STONE',
                             name => "solid rock",
                             char => ' ',
                             bg   => 'on_black',
                             fg   => $fg,
                           };
        }
      }
    }
  }
  # ais523 wall direction algorithm.  We start by drawing a square around every
  # open floor space, then remove the parts of the square that do not connect
  # to other walls.
  my %dirbit = ( EAST   => 1,
                 NORTH  => 2,
                 WEST   => 4,
                 SOUTH  => 8,
               );
  my @wmap = map { [map { 0 } 0 .. $ROWNO ] } 0 .. $$level{xmax};
  for my $x (1 .. ($$level{xmax} - 1)) {
    for my $y (1 .. ($$level{ymax} - 1)) {
      if ($$map[$x][$y]{type} =~ $walkable) {
        $wmap[$x+1][$y]   |= $dirbit{NORTH} | $dirbit{SOUTH};
        $wmap[$x-1][$y]   |= $dirbit{NORTH} | $dirbit{SOUTH};
        $wmap[$x][$y-1]   |= $dirbit{EAST}  | $dirbit{WEST};
        $wmap[$x][$y+1]   |= $dirbit{EAST}  | $dirbit{WEST};
        $wmap[$x+1][$y+1] |= $dirbit{NORTH} | $dirbit{WEST};
        $wmap[$x-1][$y+1] |= $dirbit{NORTH} | $dirbit{EAST};
        $wmap[$x+1][$y-1] |= $dirbit{SOUTH} | $dirbit{WEST};
        $wmap[$x-1][$y-1] |= $dirbit{SOUTH} | $dirbit{EAST};
      }
    }
  }
  for my $x (0 .. $$level{xmax}) {
    for my $y (0 .. $$level{ymax}) {
      if (($x < $COLNO) and not ($$map[$x+1][$y]{type} =~ /WALL|DOOR/)) {
        $wmap[$x][$y] &= ~ $dirbit{EAST};
      }
      if (($x > 0) and not ($$map[$x-1][$y]{type} =~ /WALL|DOOR/)) {
        $wmap[$x][$y] &= ~ $dirbit{WEST};
      }
      if (($y < $ROWNO) and not ($$map[$x][$y+1]{type} =~ /WALL|DOOR/)) {
        $wmap[$x][$y] &= ~ $dirbit{SOUTH};
      }
      if (($y > 0) and not ($$map[$x][$y-1]{type} =~ /WALL|DOOR/)) {
        $wmap[$x][$y] &= ~ $dirbit{NORTH};
      }
      if ($$map[$x][$y]{type} eq 'WALL') {
        $$map[$x][$y]{char} = $wallglyph[$wmap[$x][$y]];
      }
    }
  }
  return $map;
}

################################################################
###                                                          ###
###     S e r i a l i z a t i o n   F u n c t i o n s  :     ###
###                                                          ###
################################################################

sub readscalar {
  my ($text) = @_;
  return if not $text;
  my $type;
  my %closer = ("[" => "]", "{" => "}", '"' => '"', "'" => "'");
  if ($text =~ m/^\s*([[{"'])(.*)/s) {
    ($type, $text) = ($1, $2);
    print $type;
    if ($type eq "[") {
      return readlist($text, $closer{$type});
    } elsif ($type eq "{") {
      my ($value, $remainingtext) = readlist($text, $closer{$type});
      return (+{ @$value }, $remainingtext);
    } else {
      return readstring($text, $closer{$type});
    }
  } else {
    my ($line) = $text =~ m/^(.*?)$/;
    print color("reset") . "Failed to parse scalar: $line\nPress Enter for more details\n";
    <STDIN>;
    die $text;
  }
}

sub readlist {
  my ($text, $closer) = @_;
  #my ($idx, $lastidx, $char, @list) = (0);
  #die "Invalid list closer: $closer" if length($closer) ne length(substr($closer, 0, 1));
  #$lastidx = $idx;
  #while ($char ne $closer) {
  #  $char = substr($text, $idx, 1);
  #  if ($char eq ",") {
  #    push @list, readscalar(substr($text, $lastidx, ($idx - $lastidx - 1)));
  #    $idx++; # The , is not included in any list element.
  #    $lastidx = $idx;
  #  } elsif (($char eq "=") and (substr($text, $idx + 1, 1) eq ">")) {
  #    push @list, readscalar(substr($text, $lastidx, ($idx - $lastidx - 1)));
  #    $idx += 2; # The => is not included in any list element.
  #    $lastidx = $idx;
  #  }
  #  $idx++;
  #}
  #push @list, readscalar(substr($text, $lastidx, ($idx - $lastidx - ($closer eq $char) ? 2 : 1)));
  #print $closer;
  #return (\@list, substr($text, $idx));
  my @list;
  while ($text and not $text =~ m/^\s*[$closer]/) {
    if ($text =~ m/^\s*(?:[,]|[=][>])\s*/) {
      push @list, undef;
    } else {
      my ($value, $rest) = readscalar($text);
      push @list, $value;
      $text = $rest;
    }
    $text =~ s/^\s*(?:[,]|[=][>])\s*//;
  }
  print $closer;
  $text =~ s/^\s*[$closer]\s*//;
  return (\@list, $text);
}

sub readstring {
  my ($text, $closer) = @_;
  my ($string, $idx, $lastidx, $char)  = ("", 0, 0, "");
  die "Invalid string closer: $closer" if length($closer) ne length(substr($closer, 0, 1));
  while ($char ne $closer) {
    $char = substr($text, $idx, 1);
    if ($char eq "\\") {
      $string .= substr($text, $lastidx, ($idx - $lastidx - 1));
      $lastidx = $idx;
    }
    $idx++;
  }
  $string .= substr($string, $lastidx, ($idx - $lastidx - ($closer eq $char) ? 2 : 1));
  while ((substr($text, $idx, 1) eq " ") or (substr($text, $idx, 1) eq "\n")) { $idx++; }
  return ($string, substr($text, $idx));
}

sub scalartostring {
  my ($scalar, $indentlevel) = @_;
  $indentlevel ||= "";
  if ((ref $scalar) eq "ARRAY") {
    return "\n$indentlevel" . "[" . (join ", ", map { scalartostring($_, $indentlevel . "  ") } @$scalar) . "]";
  } elsif ((ref $scalar) eq "HASH") {
    return "\n$indentlevel" . "{" . (join ", ", map { my $k = $_; scalartostring($k) . " => " . scalartostring($$scalar{$k}, $indentlevel . "  ")  } keys %$scalar) . "}";
  } elsif (not defined $scalar) {
    return "";
  } elsif (not ref $scalar) {
    my $string = "" . $scalar;
    $string =~ s/[\\]/\\\\/;
    $string =~ s/(['"])/\\$1/;
    return '"' . $string . '"';
  }
}


################################################################
###                                                          ###
###        S a v e d   G a m e   F u n c t i o n s  :        ###
###                                                          ###
################################################################

sub loadsavedgame {
  if (open GAME, "<", $savefile) {
    $|++;
    print color("reset") . "\nLoading saved game...\n(This takes a while.  I guess I should optimize it at some point.)\n";
    my $savedata = readscalar(join "\n", <GAME>);
    die color("reset") . "Failed to read $savefile" if not ref $savedata;
    cls("force");
    $turn       = $$savedata{turn};
    $messages   = $$savedata{messages};
    @level      = @{$$savedata{levels}};
    %identified = %{$$savedata{identified}};
    %objtype    = %{$$savedata{objtype}};
    $maxobjid   = $$savedata{maxid}{obj};
    $maxmonid   = $$savedata{maxid}{mon};
    $maxlevid   = $$savedata{maxid}{lev};
    $nextinvlet = $$savedata{maxid}{inv};
    ($level)  = grep { $$_{levelid} eq $$savedata{current}{level}  } @level;
    ($player) = grep { $$_{monid}   eq $$savedata{current}{player} } @{$$level{monsters}};
    push @$messages, +{ text => "Continuing from $$savedata{savetime}.  Welcome back.", fg => "yellow", };
    close GAME;
  } else {
    die color("reset") . "Cannot open save game $savefile: $!\n";
  }
}

sub updatesavedgame {
  if (open GAME, ">", $savefile) {
    print GAME "" .
      scalartostring(+{ savetime   => "" . localtime(), # purely informational
                        turn       => $turn,
                        messages   => $messages,
                        levels     => \@level,
                        identified => \%identified,
                        objtype    => \%objtype, # saved because of random appearances
                        maxid      => +{ obj => $maxobjid, mon => $maxmonid, lev => $maxlevid, inv => $nextinvlet, },
                        current    => +{ level => $$level{levelid}, player => $$player{monid}, },
                      });
    close GAME;
    push @$messages, +{ text => "Save updated: $savefile", fg => "magenta" };
  } else {
    push @$messages, +{ text => "Cannot write $savefile: $!", fg => $errorcolor };
  }
}

################################################################
###                                                          ###
###            C o n f i g   F u n c t i o n s  :            ###
###                                                          ###
################################################################

sub readconfigfile {
  my ($file) = @_;
  die "File not found: $file" if not -e $file;
  open CFG, "<", $file or die "Cannot read config file $file: $!";
  my $slurp = join "", <CFG>;
  close CFG;
  return readscalar($slurp);
}

sub defaultkeymap {
  return +{ # adxw movement
           "a" => "move_west",
           "q" => "move_northwest",
           "w" => "move_north",
           "e" => "move_northeast",
           "d" => "move_east",
           "c" => "move_southeast",
           "x" => "move_south",
           "z" => "move_southwest",
           "s" => "search",
           "," => "pickup",
           "i" => "inventory",
           "I" => "Ingest",
          };
}

################################################################
###                                                          ###
###           U t i l i t y   F u n c t i o n s  :           ###
###                                                          ###
################################################################

sub shuffle {
  # Schwartzian transform.
  return map { $$_[0] } sort { $$a[1] <=> $$b[1] } map { [$_ => rand(1000)] } @_;
}