File Coverage

blib/lib/Game/PlatformsOfPeril.pm

Criterion	Covered	Total	%
statement	28	395	7.0
branch	0	132	0.0
condition	0	91	0.0
subroutine	10	56	17.8
pod	0	43	0.0
total	38	717	5.3

# Game::PlatformsOfPeril - this is a terminal-based game, run the
# `pperil` command that should be installed with this module to begin
#
# some details for the unwary, or brave, regarding the code:
#
# this implementation uses arrays heavily so instead of a more typical
# Player object there is an array with various slots that are used for
# various purposes. these slots are indexed using constant subs, and
# there is some overlap of these slots for animates, items, and terrain.
# the @Animates array (where the player, monsters, and items reside) and
# $LMap (level map, which has every ROW and COL and then an array (LMC)
# for what is in that cell) is where most of the game data resides.
# there can be only one terrain (GROUND), one ITEM, and one animate
# (ANI) per level map cell; any new interactions will need to support
# this. there are also four graphs per level map; these graphs dictate
# what moves are possible for animates (double benefit of providing both
# legal next moves and for pathfinding across the map). gravity pulls
# things down at the beginning of a turn (bottom up), and the player
# always moves first in the turn (low id to high), see the game_loop.
# level maps are ASCII text, and only one thing can be present in a cell
# in the map (with FLOOR being assumed present below any item or
# animate). there are some complications around killing things off; dead
# things must not interact with anything, but may still be looped to
# after their death in the apply_gravity or game_loop UPDATE calls.
# hence the BLACK_SPOT

package Game::PlatformsOfPeril;

our $VERSION = '0.11';

use 5.24.0;
use warnings;
use File::Spec::Functions qw(catfile);
use List::PriorityQueue   ();
use List::Util            qw(first);
use List::UtilsBy 0.06    qw(nsort_by rev_nsort_by);
use Term::ReadKey         qw(GetTerminalSize ReadKey ReadMode);
use Time::HiRes           qw(sleep);
use POSIX                 qw(STDIN_FILENO TCIFLUSH tcflush);

# ANSI or XTerm control sequences
sub at              { "\e[" . $_[1] . ';' . $_[0] . 'H' }
sub at_col          { "\e[" . $_[0] . 'G' }
sub alt_screen ()   { "\e[?1049h" }
sub clear_line ()   { "\e[2K" }
sub clear_right ()  { "\e[K" }
sub clear_screen () { "\e[1;1H\e[2J" }
sub hide_cursor ()  { "\e[?25l" }
sub hide_pointer () { "\e[>3p" }
sub show_cursor ()  { "\e[?25h" }
sub term_norm ()    { "\e[m" }
sub unalt_screen () { "\e[?1049l" }

# WHAT Animates and such can be
sub HERO ()   { 0 }
sub MONST ()  { 1 }
sub BOMB ()   { 2 }
sub GEM ()    { 3 }
sub FLOOR ()  { 4 }
sub WALL ()   { 5 }
sub LADDER () { 6 }
sub STAIR ()  { 7 }
sub STATUE () { 8 }

sub BOMB_COST () { 2 }
sub GEM_VALUE () { 1 }

# for the Level Map Cell (LMC)
sub WHERE ()  { 0 }
sub GROUND () { 1 }
sub ITEM ()   { 2 }
sub ANI ()    { 3 }

sub MOVE_FAILED () { 0 }
sub MOVE_OK ()     { 1 }
sub MOVE_NEWLVL () { 2 }

# for the level map
sub COLS ()         { 23 }
sub ROWS ()         { 23 }
sub MAP_DISP_OFF () { 1 }

# level map is row, col while points are [ col, row ]
sub PROW () { 1 }
sub PCOL () { 0 }

sub MSG_ROW () { 1 }
sub MSG_COL () { 25 }
# these also used to determine the minimum size for the terminal
sub MSG_MAX ()      { 24 }
sub MSG_COLS_MAX () { 70 }

# for Animates (and also some Things for the first few slots)
sub WHAT () { 0 }
sub DISP () { 1 }
# NOTE that GROUND use TYPE to distinguish between different types of
# those (FLOOR, STAIR, STATUE) which makes the graph code simpler as
# that only needs to look at WHAT for whether motion is possible in that
# cell; ANI and ITEM instead use TYPE to tell ANI apart from ITEM
sub TYPE ()       { 2 }
sub STASH ()      { 3 }
sub UPDATE ()     { 4 }
sub LMC ()        { 5 }
sub BLACK_SPOT () { 6 }

sub GEM_STASH ()  { 0 }
sub BOMB_STASH () { 1 }
sub GEM_ODDS ()   { 1 }

sub GEM_ODDS_ADJUST () { 0.05 }

sub START_GEMS ()  { 0 }
sub START_BOMBS () { 1 }

sub GRAPH_NODE ()   { 0 }
sub GRAPH_WEIGHT () { 1 }
sub GRAPH_POINT ()  { 2 }

our %CharMap = (
    'o' => BOMB,
    '.' => FLOOR,
    '*' => GEM,
    '@' => HERO,
    '=' => LADDER,
    'P' => MONST,
    '%' => STAIR,
    '&' => STATUE,
    '#' => WALL,
);

our (
    @Animates, %Explosions, @Graphs, $LMap,  $Monst_Name,
    @RedrawA,  @RedrawB,    $Hero,   $TCols, $TRows
);

our %Examine_Offsets = (
    'h' => [ -1, +0 ],    # left
    'j' => [ +0, +1 ],    # down
    'k' => [ +0, -1 ],    # up
    'l' => [ +1, +0 ],    # right
    'y' => [ -1, -1 ],
    'u' => [ +1, -1 ],
    'b' => [ -1, +1 ],
    'n' => [ +1, +1 ],
);

our $Level = 0;
our $Level_Path;

# plosive practice. these must pluralize properly
our @Menagerie = (
    'Palace Peacock',
    'Peckish Packrat',
    'Peevish Penguin',
    'Piratical Parakeet',
    'Placid Piranha',
    'Pleasant Porcupine',
    'Priggish Python',
    'Prurient Pachyderm',
    'Purposeful Plant',
    # and some not-plosives for reasons lost in the mists of time
    'Gruesome Goose',
    'Sinister Swan',
    'Xenophobic Xarci',
);
$Monst_Name = $Menagerie[ rand @Menagerie ];

our $Redraw_Delay = 0.05;
our $Rotate_Delay = 0.20;
our $Rotation     = 0;

our @Scientists = qw(Eigen Maxwell Newton);
our $Scientist  = $Scientists[ rand @Scientists ];

our $Seed;

our @Styles =
  qw(Abstract Art-Deco Brutalist Egyptian Greek Impressionist Post-Modern Roman Romantic);
our $Style = $Styles[ rand @Styles ];

our %Things = (
    BOMB,   [ BOMB,   "\e[31mo\e[0m",   ITEM ],
    FLOOR,  [ FLOOR,  "\e[33m.\e[0m",   FLOOR ],
    GEM,    [ GEM,    "\e[32m*\e[0m",   ITEM ],
    LADDER, [ LADDER, "\e[37m=\e[0m",   LADDER ],
    STAIR,  [ FLOOR,  "\e[37m%\e[0m",   STAIR ],
    STATUE, [ FLOOR,  "\e[1;33m&\e[0m", STATUE ],
    WALL,   [ WALL,   "\e[35m#\e[0m",   WALL ],
);

our %Descriptions = (
    BOMB,   'Bomb. Avoid.',
    FLOOR,  'Empty cell.',
    GEM,    'A gem. Get these.',
    HERO,   'The much suffering hero.',
    LADDER, 'A ladder.',
    MONST,  $Monst_Name . '. Wants to kill you.',
    STAIR,  'A way out of this mess.',
    STATUE, 'Empty cell with decorative statue.',
    WALL,   'A wall.',
);

$Animates[HERO]->@[ WHAT, DISP, TYPE, STASH, UPDATE ] = (
    HERO, "\e[1;33m\@\e[0m", ANI, [ START_GEMS, START_BOMBS ],
    \&update_hero
);

our %Interact_With = (
    HERO,    # the target of the mover
    sub {
        my ( $mover, $target ) = @_;
        game_over_monster() if $mover->[WHAT] == MONST;
        game_over_bomb()    if $mover->[WHAT] == BOMB;
        grab_gem( $target, $mover );
    },
    MONST,
    sub {
        my ( $mover, $target ) = @_;
        game_over_monster() if $mover->[WHAT] == HERO;
        if ( $mover->[WHAT] == BOMB ) {
            my @cells = map { kill_animate( $_, 1 ); $_->[LMC][WHERE] } $mover,
              $target;
            redraw_ref( \@cells );
            $Explosions{ join ',', $target->[LMC][WHERE]->@* } = $target;
        } elsif ( $mover->[WHAT] == GEM ) {
            grab_gem( $target, $mover );
        }
    },
    BOMB,
    sub {
        my ( $mover, $target ) = @_;
        game_over_bomb() if $mover->[WHAT] == HERO;
        if ( $mover->[WHAT] == MONST ) {
            my @cells = map { kill_animate( $_, 1 ); $_->[LMC][WHERE] } $mover,
              $target;
            redraw_ref( \@cells );
            $Explosions{ join ',', $target->[LMC][WHERE]->@* } = $target;
        }
    },
    GEM,
    sub {
        my ( $mover, $target ) = @_;
        if ( $mover->[TYPE] == ANI ) {
            relocate( $mover, $target->[LMC][WHERE] );
            grab_gem( $mover, $target );
        }
    },
);

our %Key_Commands = (
    'h' => move_player( -1, +0 ),    # left
    'j' => move_player( +0, +1 ),    # down
    'k' => move_player( +0, -1 ),    # up
    'l' => move_player( +1, +0 ),    # right
    '.' => \&move_nop,               # rest
    ' ' => \&move_nop,               # also rest
    'v' =>
      sub { post_message( 'Version ' . $VERSION ); return MOVE_FAILED },
    'x' => \&move_examine,
    '<' => sub {
        post_message( $Scientist . q{'s magic wonder left boot, activate!} );
        rotate_left();
        print draw_level();
        sleep($Rotate_Delay);
        return MOVE_OK;
    },
    '>' => sub {
        post_message( $Scientist . q{'s magic wonder right boot, activate!} );
        rotate_right();
        print draw_level();
        sleep($Rotate_Delay);
        return MOVE_OK;
    },
    '?' => sub {
        post_help();
        return MOVE_FAILED;
    },
    # for debugging, probably shouldn't be included as it shows exactly
    # where the monsters are trying to move to which may or may not be
    # where the player is
    'T' => sub {
        local $" = ',';
        post_message("T $Hero->@* R $Rotation");
        return MOVE_FAILED;
    },
    '@' => sub {
        local $" = ',';
        post_message("\@ $Animates[HERO][LMC][WHERE]->@* R $Rotation");
        return MOVE_FAILED;
    },
    '$' => sub {
        post_message( 'You have '
              . $Animates[HERO][STASH][BOMB_STASH]
              . ' bombs and '
              . $Animates[HERO][STASH][GEM_STASH]
              . ' gems.' );
        return MOVE_FAILED;
    },
    # by way of history '%' is what rogue (version 3.6) uses for stairs,
    # except the '>' (or very rarely '<') keys are used to interact with
    # that symbol
    '%' => sub {
        if ( $Animates[HERO][LMC][GROUND][TYPE] == STAIR ) {
            load_level();
            print clear_screen(), draw_level();
            post_message( 'Level '
                  . $Level
                  . ' (You have '
                  . $Animates[HERO][STASH][BOMB_STASH]
                  . ' bombs and '
                  . $Animates[HERO][STASH][GEM_STASH]
                  . ' gems.)' );
            return MOVE_NEWLVL;
        } else {
            post_message('There are no stairs here?');
            return MOVE_FAILED;
        }
    },
    'B' => sub {
        my $lmc = $Animates[HERO][LMC];
        return MOVE_FAILED, 'You have no bombs (make them from gems).'
          if $Animates[HERO][STASH][BOMB_STASH] < 1;
        return MOVE_FAILED, 'There is already an item in this cell.'
          if defined $lmc->[ITEM];
        $Animates[HERO][STASH][BOMB_STASH]--;
        make_item( $lmc->[WHERE], BOMB, 0 );
        return MOVE_OK;
    },
    'M' => sub {
        return MOVE_FAILED, 'You need more gems.'
          if $Animates[HERO][STASH][GEM_STASH] < BOMB_COST;
        $Animates[HERO][STASH][GEM_STASH] -= BOMB_COST;
        post_message(
            'You now have ' . ++$Animates[HERO][STASH][BOMB_STASH] . ' bombs' );
        return MOVE_OK;
    },
    'Q'    => sub { game_over('Be seeing you...') },
    'q'    => sub { game_over('Be seeing you...') },
    "\003" => sub {                                    #
        post_message('Enough with these silly interruptions!');
        return MOVE_FAILED;
    },
    "\014" => sub {                                    #
        redraw_level();
        return MOVE_FAILED;
    },
    "\032" => sub {                                    #
        post_message('You hear a strange noise in the background.');
        return MOVE_FAILED;
    },
    "\033" => sub {
        post_message('You cannot escape quite so easily.');
        return MOVE_FAILED;
    },
);

sub apply_gravity {
    for my $ent ( rev_nsort_by { $_->[LMC][WHERE][PROW] } @Animates ) {
        next if $ent->[BLACK_SPOT];
        my $here = $ent->[LMC][WHERE];
        next
          if $here->[PROW] == ROWS - 1
          or (  $ent->[TYPE] == ANI
            and $LMap->[ $here->[PROW] ][ $here->[PCOL] ][GROUND][WHAT] ==
            LADDER )
          or $LMap->[ $here->[PROW] + 1 ][ $here->[PCOL] ][GROUND][WHAT] ==
          WALL;
        my $dest = [ $here->[PCOL], $here->[PROW] + 1 ];
        relocate( $ent, $dest ) unless interact( $ent, $dest );
        if ( $ent->[WHAT] == HERO ) {
            if ( $ent->[LMC][GROUND][WHAT] == LADDER ) {
                post_message('You fall, but grab onto a ladder.');
            } else {
                post_message('You fall!');
            }
        }
    }
    maybe_boom_today();
}

sub bad_terminal {
    ( $TCols, $TRows ) = ( GetTerminalSize(*STDOUT) )[ 0, 1 ];
    return (
             not defined $TCols
          or $TCols < MSG_COLS_MAX
          or $TRows < MSG_MAX
    );
}

sub bail_out {
    restore_term();
    print "\n", at_col(0), clear_line;
    warn $_[0] if @_;
    game_over("Suddenly, the platforms collapse about you.");
}

sub between {
    my ( $min, $max, $value ) = @_;
    if ( $value < $min ) {
        $value = $min;
    } elsif ( $value > $max ) {
        $value = $max;
    }
    return $value;
}

sub draw_level {
    my $s = '';
    for my $rownum ( 0 .. ROWS - 1 ) {
        $s .= at( MAP_DISP_OFF, MAP_DISP_OFF + $rownum );
        for my $lmc ( $LMap->[$rownum]->@* ) {
            if ( defined $lmc->[ANI] ) {
                $s .= $lmc->[ANI][DISP];
            } elsif ( defined $lmc->[ITEM] ) {
                $s .= $lmc->[ITEM][DISP];
            } else {
                $s .= $lmc->[GROUND][DISP];
            }
        }
    }
    $s .= at( 1, ROWS + 1 ) . $Things{ WALL, }[DISP] x COLS;
    return $s;
}

sub explode {
    my ($something) = @_;
    my $lmc         = $something->[LMC];
    my $pos         = $lmc->[WHERE];
    my @colors      = ( "\e[31m", "\e[33m" );
    for ( 1 .. 7 ) {
        print at( map { MAP_DISP_OFF + $_ } $pos->@* ),
          $colors[ rand @colors ], '*',
          term_norm;
        sleep( $Redraw_Delay / 4 );
    }
    post_message('ka-boom!');
    # HEROIC DESTRUCTION
    $lmc->[GROUND] = $Things{ FLOOR, } if $lmc->[GROUND][TYPE] == STATUE;
    redraw_ref( [$pos] );
}

# cribbed from some A* article on https://www.redblobgames.com/
sub find_hero {
    my ( $ent, $mcol, $mrow ) = @_;

    my $start = $mcol . ',' . $mrow;
    my $pcol  = $Hero->[PCOL];
    my $prow  = $Hero->[PROW];
    my $end   = $pcol . ',' . $prow;

    # already waiting where the player is going to fall to
    return if $start eq $end;

    my %costs = ( $start => 0 );
    my %seen  = ( $start => undef );
    my $q     = List::PriorityQueue->new;
    $q->insert( $start, 0 );

    my $linked = 0;
    while ( my $node = $q->pop ) {
        if ( $node eq $end ) {
            $linked = 1;
            last;
        }
        for my $peer ( $Graphs[$Rotation]{$node}->@* ) {
            my $new  = $peer->[GRAPH_NODE];
            my $cost = $costs{$node} + $peer->[GRAPH_WEIGHT];
            if ( not exists $seen{$new} or $cost < $costs{$new} ) {
                $costs{$new} = $cost;
                # perhaps they drove taxicabs in Manhattan in a former life?
                my $priority =
                  $cost +
                  abs( $pcol - $peer->[GRAPH_POINT][PCOL] ) +
                  abs( $prow - $peer->[GRAPH_POINT][PROW] );
                $q->insert( $new, $priority );
                $seen{$new} = $node;
            }
        }
    }
    return unless $linked;

    my @path;
    my $node = $end;
    while ( $node ne $start ) {
        unshift @path, $node;
        $node = $seen{$node};
    }
    return [ split ',', $path[0] ];
}

sub game_loop {
    game_over(
        'Terminal must be at least ' . MSG_COLS_MAX . 'x' . MSG_MAX )
      if bad_terminal();
    ( $Level_Path, $Level, $Seed ) = @_;
    $SIG{$_} = \&bail_out
      for qw(INT HUP TERM PIPE QUIT USR1 USR2 __DIE__);
    STDOUT->autoflush(1);
    load_level();
    ReadMode 'raw';
    print term_norm, alt_screen, hide_cursor, hide_pointer, clear_screen,
      draw_level;
    post_message('The Platforms of Peril');
    post_message('');
    post_message(
        'Your constant foes, the ' . properly_plural($Monst_Name) );
    post_message('seek to destroy your way of life!');
    post_help();
    post_message('');
    post_message( 'Seed ' . $Seed . ' of version ' . $VERSION );
    $SIG{CONT}  = \&redraw_level;
    $SIG{WINCH} = sub {
        post_message('The terminal is too small!') if bad_terminal();
        redraw_level();
    };

    while (1) {
        apply_gravity();
        @Animates = grep { !$_->[BLACK_SPOT] } @Animates;
        redraw_movers() if @RedrawA;
        next            if $Animates[HERO][UPDATE]->() == MOVE_NEWLVL;
        track_hero();
        for my $ent ( @Animates[ 1 .. $#Animates ] ) {
            $ent->[UPDATE]->($ent)
              if !$ent->[BLACK_SPOT] and defined $ent->[UPDATE];
        }
        @Animates = grep { !$_->[BLACK_SPOT] } @Animates;
        redraw_movers();
    }
}

sub game_over {
    my ( $msg, $code ) = @_;
    $code //= 1;
    restore_term();
    print clear_right, $msg, ' (', $Animates[HERO][STASH][GEM_STASH],
      " gems)\n", clear_right;
    exit $code;
}

sub game_over_bomb { game_over('You gone done blowed yourself up.') }

sub game_over_monster {
    game_over( 'The ' . $Monst_Name . ' polished you off.' );
}

sub grab_gem {
    my ( $ent, $gem ) = @_;
    $ent->[STASH][GEM_STASH] += $gem->[STASH];
    kill_animate($gem);
    if ( $ent->[WHAT] == MONST ) {
        post_message( 'The ' . $Monst_Name . ' grabs a gem.' );
    } else {
        post_message( 'You now have ' . $ent->[STASH][GEM_STASH] . ' gems.' );
    }
}

sub graph_bilink {
    my ( $g, $c1, $r1, $c2, $r2 ) = @_;
    my $from = $c1 . ',' . $r1;
    my $to   = $c2 . ',' . $r2;
    push $g->{$from}->@*, [ $to,   1, [ $c2, $r2 ] ];
    push $g->{$to}->@*,   [ $from, 1, [ $c1, $r1 ] ];
}

sub graph_setup {
    my $g = {};
    for my $r ( 0 .. ROWS - 2 ) {
        for my $c ( 0 .. COLS - 1 ) {
            next if $LMap->[$r][$c][GROUND][WHAT] == WALL;
            # allow left/right, if ladder or wall below permits it
            if ($c != COLS - 1
                and (  $LMap->[$r][$c][GROUND][WHAT] == LADDER
                    or $LMap->[ $r + 1 ][$c][GROUND][WHAT] == WALL )
                and (
                    $LMap->[$r][ $c + 1 ][GROUND][WHAT] == LADDER
                    or (    $LMap->[$r][ $c + 1 ][GROUND][WHAT] != WALL
                        and $LMap->[ $r + 1 ][ $c + 1 ][GROUND][WHAT] == WALL )
                )
            ) {
                graph_bilink( $g, $c, $r, $c + 1, $r );
            }
            if ( $r > 0 ) {
                # allow motion up/down ladders
                if (    $LMap->[$r][$c][GROUND][WHAT] == LADDER
                    and $LMap->[ $r - 1 ][$c][GROUND][WHAT] == LADDER ) {
                    graph_bilink( $g, $c, $r, $c, $r - 1 );
                } elsif (
                    $LMap->[$r][$c][GROUND][WHAT] == LADDER
                    or (    $LMap->[$r][$c][GROUND][WHAT] == FLOOR
                        and $LMap->[ $r + 1 ][$c][GROUND][WHAT] == WALL )
                ) {
                    # can we fall into this cell from above?
                    graph_shaft( $g, $c, $r );
                }
            }
        }
    }
    for my $c ( 0 .. COLS - 1 ) {
        next if $LMap->[ ROWS - 1 ][$c][GROUND][WHAT] == WALL;
        if (    $LMap->[ ROWS - 1 ][$c][GROUND][WHAT] == LADDER
            and $LMap->[ ROWS - 2 ][$c][GROUND][WHAT] == LADDER ) {
            graph_bilink( $g, $c, ROWS - 1, $c, ROWS - 2 );
        } else {
            graph_shaft( $g, $c, ROWS - 1 );
        }
        if ( $c != COLS - 1 ) {
            graph_bilink( $g, $c, ROWS - 1, $c + 1, ROWS - 1 );
        }
    }
    return $g;
}

sub graph_shaft {
    my ( $g, $c, $r ) = @_;
    for my $x ( reverse 0 .. $r - 1 ) {
        last if $LMap->[$x][$c][GROUND][WHAT] == WALL;
        my $weight = $r - $x;
        if ( $LMap->[$x][$c][GROUND][WHAT] == LADDER ) {
            if ( $weight == 1 ) {
                graph_udlink( $g, $c, $x, $c, $r, 1, [ $c, $x ] );
            } else {
                graph_udlink( $g, $c, $x,     $c, $x + 1, 1,           [ $c, $x ] );
                graph_udlink( $g, $c, $x + 1, $c, $r,     $weight - 2, [ $c, $r ] );
            }
            last;
        }
        # can fall into this shaft from the left or right?
        if ($c != 0
            and (
                $LMap->[$x][ $c - 1 ][GROUND][WHAT] == LADDER
                or (    $LMap->[$x][ $c - 1 ][GROUND][WHAT] == FLOOR
                    and $LMap->[ $x + 1 ][ $c - 1 ][GROUND][WHAT] == WALL )
            )
        ) {
            graph_udlink( $g, $c - 1, $x, $c, $x, 1,           [ $c, $x ] );
            graph_udlink( $g, $c,     $x, $c, $r, $weight - 1, [ $c, $r ] );
        }
        if ($c != COLS - 1
            and (
                $LMap->[$x][ $c + 1 ][GROUND][WHAT] == LADDER
                or (    $LMap->[$x][ $c + 1 ][GROUND][WHAT] == FLOOR
                    and $LMap->[ $x + 1 ][ $c + 1 ][GROUND][WHAT] == WALL )
            )
        ) {
            graph_udlink( $g, $c + 1, $x, $c, $x, $weight,     [ $c, $x ] );
            graph_udlink( $g, $c,     $x, $c, $r, $weight - 1, [ $c, $r ] );
        }
    }
}

sub graph_udlink {
    my ( $g, $c1, $r1, $c2, $r2, $weight, $point ) = @_;
    my $from = $c1 . ',' . $r1;
    my $to   = $c2 . ',' . $r2;
    push $g->{$from}->@*, [ $to, $weight, $point ];
}

sub interact {
    my ( $mover, $dest ) = @_;
    for my $i ( ANI, ITEM ) {
        my $target = $LMap->[ $dest->[PROW] ][ $dest->[PCOL] ][$i];
        if ( defined $target ) {
            # this code is assumed to take care of everything and be the
            # final say on the interaction
            $Interact_With{ $target->[WHAT] }->( $mover, $target );
            return 1;
        }
    }
    return 0;
}

sub kill_animate {
    my ( $ent, $no_draw ) = @_;
    push @RedrawA, $ent->[LMC][WHERE] unless defined $no_draw;
    $ent->[BLACK_SPOT] = 1;
    # NOTE this only works for TYPE of ANI or ITEM, may need to rethink
    # how STATUE and STAIRS are handled if there are GROUND checks on
    # TYPE as those abuse the TYPE field for other things (see %Things)
    undef $ent->[LMC][ $ent->[TYPE] ];
}

sub load_level {
    my $file = catfile( $Level_Path, 'level' . $Level++ );
    game_over( 'You have completed all the levels.', 0 ) unless -e $file;

    open( my $fh, '<', $file ) or game_over("Failed to open '$file': $!");

    splice @Animates, 1;
    undef $Animates[HERO][LMC];
    $LMap = [];

    my $rownum = 0;
    while ( my $line = readline $fh ) {
        chomp $line;
        game_over("Wrong number of columns at $file:$.")
          if length $line != COLS;
        my $colnum = 0;
        for my $v ( split //, $line ) {
            my $c = $CharMap{$v} // game_over("Unknown character $v at $file:$.");
            my $point = [ $colnum++, $rownum ];    # PCOL, PROW (x, y)
            if ( exists $Things{$c} ) {
                if ( $c eq BOMB ) {
                    push $LMap->[$rownum]->@*, [ $point, $Things{ FLOOR, } ];
                    make_item( $point, BOMB, 0 );
                } elsif ( $c eq GEM ) {
                    push $LMap->[$rownum]->@*, [ $point, $Things{ FLOOR, } ];
                    make_item( $point, GEM, GEM_VALUE );
                } else {
                    push $LMap->[$rownum]->@*, [ $point, $Things{$c} ];
                }
            } else {
                if ( $c eq HERO ) {
                    game_over("Player placed twice in $file")
                      if defined $Animates[HERO][LMC];
                    push $LMap->[$rownum]->@*,
                      [ $point, $Things{ FLOOR, }, undef, $Animates[HERO] ];
                    $Animates[HERO][LMC] = $LMap->[$rownum][-1];
                    $Hero = $point;
                } elsif ( $c eq MONST ) {
                    push $LMap->[$rownum]->@*, [ $point, $Things{ FLOOR, } ];
                    make_monster($point);
                } else {
                    game_over("Unknown object '$v' at $file:$.");
                }
            }
        }
        last if ++$rownum == ROWS;
    }
    game_over("Too few rows in $file") if $rownum < ROWS;
    game_over("No player in $file") unless defined $Animates[HERO][LMC];

    $Rotation = 0;
    for my $rot ( 1 .. 4 ) {
        $Graphs[$Rotation] = graph_setup();
        rotate_left();
    }
}

sub make_item {
    my ( $point, $thingy, $stash, $update ) = @_;
    my $item;
    $item->@[ WHAT, DISP, TYPE, STASH, UPDATE, LMC ] = (
        $Things{$thingy}->@*,
        $stash, $update, $LMap->[ $point->[PROW] ][ $point->[PCOL] ]
    );
    push @Animates, $item;
    $LMap->[ $point->[PROW] ][ $point->[PCOL] ][ITEM] = $item;
}

sub make_monster {
    my ($point) = @_;
    my $monst;
    my $ch = substr $Monst_Name, 0, 1;
    # STASH replicates that of the HERO for simpler GEM handling code
    # though the BOMB_STASH is instead used for GEM_ODDS
    $monst->@[ WHAT, DISP, TYPE, STASH, UPDATE, LMC ] = (
        MONST, "\e[1;33m$ch\e[0m", ANI, [ 0, 0.0 ],
        \&update_monst, $LMap->[ $point->[PROW] ][ $point->[PCOL] ]
    );
    push @Animates, $monst;
    $LMap->[ $point->[PROW] ][ $point->[PCOL] ][ANI] = $monst;
}

sub maybe_boom_today {
    if ( keys %Explosions ) {
        explode($_) for values %Explosions;
        %Explosions = ();
    }
}

sub move_animate {
    my ( $ent, $cols, $rows ) = @_;
    my $lmc = $ent->[LMC];

    my $from = $lmc->[WHERE][PCOL] . ',' . $lmc->[WHERE][PROW];
    my $to =
        ( $lmc->[WHERE][PCOL] + $cols ) . ','
      . ( $lmc->[WHERE][PROW] + $rows );

    return MOVE_FAILED
      unless first { $_->[GRAPH_NODE] eq $to }
      $Graphs[$Rotation]{$from}->@*;

    my $dest =
      [ $lmc->[WHERE][PCOL] + $cols, $lmc->[WHERE][PROW] + $rows ];

    relocate( $ent, $dest ) unless interact( $ent, $dest );
    return MOVE_OK;
}

# so the player can see if there is a ladder under something; this is an
# important consideration on some levels
sub move_examine {
    my $key;
    my $row = $Animates[HERO][LMC][WHERE][PROW];
    my $col = $Animates[HERO][LMC][WHERE][PCOL];
    print at( MSG_COL, MSG_ROW + $_ ), clear_right for 1 .. MSG_MAX;
    print at( MSG_COL, MSG_ROW ), clear_right,
      'Move cursor to view a cell. Esc exits', show_cursor;
    while (1) {
        print at( MSG_COL, MSG_ROW + $_ ), clear_right for 3 .. 5;
        my $disp_row = 2;
        for my $i ( ANI, ITEM ) {
            my $x = $LMap->[$row][$col][$i];
            if ( defined $x ) {
                print at( MSG_COL, MSG_ROW + $disp_row++ ), clear_right, $x->[DISP],
                  ' - ', $Descriptions{ $x->[WHAT] };
            }
        }
        my $g = $LMap->[$row][$col][GROUND];
        print at( MSG_COL, MSG_ROW + $disp_row ), clear_right, $g->[DISP],
          ' - ', $Descriptions{ $g->[TYPE] },
          at( MAP_DISP_OFF + $col, MAP_DISP_OFF + $row );
        $key = ReadKey(0);
        last if $key eq "\033";
        my $distance = 1;
        if ( ord $key < 97 ) {    # SHIFT moves faster
            $key      = lc $key;
            $distance = 5;
        }
        my $dir = $Examine_Offsets{$key} // next;
        $row = between( 0, ROWS - 1, $row + $dir->[PROW] * $distance );
        $col = between( 0, COLS - 1, $col + $dir->[PCOL] * $distance );
    }
    print hide_cursor;
    show_messages();
    return MOVE_FAILED;
}

sub move_nop { return MOVE_OK }

sub move_player {
    my ( $cols, $rows ) = @_;
    sub { move_animate( $Animates[HERO], $cols, $rows ) }
}

sub post_help {
    my $ch = substr $Monst_Name, 0, 1;
    post_message('');
    post_message( ' '
          . $Animates[HERO][DISP]
          . ' - You   '
          . $ch . ' - a '
          . $Monst_Name );
    post_message( ' '
          . $Things{ STATUE, }[DISP]
          . ' - a large granite statue done in the' );
    post_message( '     ' . $Style . ' style' );
    post_message( ' '
          . $Things{ BOMB, }[DISP]
          . ' - Bomb  '
          . $Things{ GEM, }[DISP]
          . ' - Gem (get these)' );
    post_message('');
    post_message(' h j k l - move');
    post_message(' < >     - activate left or right boot');
    post_message(' B       - drop a Bomb');
    post_message(
        ' M       - make a Bomb (consumes ' . BOMB_COST . ' Gems)' );
    post_message( ' %       - when on '
          . $Things{ STAIR, }[DISP]
          . ' goes to the next level' );
    post_message(' . space - pass a turn (handy when falling)');
    post_message('');
    post_message(' Q q     - quit the game (no save)');
    post_message(' $       - display Bomb and Gem counts');
    post_message(' ?       - post these help messages');
    post_message('');
    post_message( 'You have '
          . $Animates[HERO][STASH][BOMB_STASH]
          . ' bombs and '
          . $Animates[HERO][STASH][GEM_STASH]
          . ' gems.' );
}

{
    my @log;

    sub post_message {
        my ($msg) = @_;
        while ( @log >= MSG_MAX ) { shift @log }
        push @log, $msg;
        show_messages();
    }
    sub clear_messages { @log = () }

    sub show_messages {
        for my $i ( 0 .. $#log ) {
            print at( MSG_COL, MSG_ROW + $i ), clear_right, $log[$i];
        }
    }
}

# fsvo properly... damnit Jim I'm a sysadmin not a linguist
sub properly_plural {
    my ($name) = @_;
    $name =~ s/oo/ee/ ? $name : $name . 's';
}

sub redraw_level { print clear_screen, draw_level; show_messages() }

sub redraw_movers {
    redraw_ref( \@RedrawA );
    sleep($Redraw_Delay);
    redraw_ref( \@RedrawB );
    maybe_boom_today();
    @RedrawA = ();
    @RedrawB = ();
}

sub redraw_ref {
  CELL: for my $point ( $_[0]->@* ) {
        for my $i ( ANI, ITEM ) {
            my $ent = $LMap->[ $point->[PROW] ][ $point->[PCOL] ][$i];
            if ( defined $ent and !$ent->[BLACK_SPOT] ) {
                print at( map { MAP_DISP_OFF + $_ } $point->@* ), $ent->[DISP];
                next CELL;
            }
        }
        print at( map { MAP_DISP_OFF + $_ } $point->@* ),
          $LMap->[ $point->[PROW] ][ $point->[PCOL] ][GROUND][DISP];
    }
}

sub relocate {
    my ( $ent, $dest ) = @_;
    my $src = $ent->[LMC][WHERE];
    push @RedrawA, $src;
    push @RedrawB, $dest;
    my $lmc = $LMap->[ $dest->[PROW] ][ $dest->[PCOL] ];
    $lmc->[ $ent->[TYPE] ] = $ent;
    undef $LMap->[ $src->[PROW] ][ $src->[PCOL] ][ $ent->[TYPE] ];
    $ent->[LMC] = $lmc;
}

sub restore_term {
    ReadMode 'restore';
    print term_norm, show_cursor, unalt_screen;
}

sub rotate_left {
    my $lm;
    for my $r ( 0 .. ROWS - 1 ) {
        for my $c ( 0 .. COLS - 1 ) {
            my $newr = COLS - 1 - $c;
            $lm->[$newr][$r] = $LMap->[$r][$c];
            $lm->[$newr][$r][WHERE] = [ $r, $newr ];
        }
    }
    $LMap     = $lm;
    $Rotation = ( $Rotation + 1 ) % 4;
}

sub rotate_right {
    my $lm;
    for my $r ( 0 .. ROWS - 1 ) {
        for my $c ( 0 .. COLS - 1 ) {
            my $newc = ROWS - 1 - $r;
            $lm->[$c][$newc] = $LMap->[$r][$c];
            $lm->[$c][$newc][WHERE] = [ $newc, $c ];
        }
    }
    $LMap     = $lm;
    $Rotation = ( $Rotation - 1 ) % 4;
}

sub track_hero {
    $Hero = $Animates[HERO][LMC][WHERE];

    # route monsters to where the player will fall to as otherwise they
    # tend to freeze or head in the wrong direction
    my $row = $Hero->[PROW];
    my $col = $Hero->[PCOL];
    return
      if $row == ROWS - 1
      or $LMap->[$row][$col][GROUND][WHAT] == LADDER;

    my $goal = $row;
    for my $r ( $row + 1 .. ROWS - 1 ) {
        last if $LMap->[$r][$col][GROUND][WHAT] == WALL;
        if ($LMap->[$r][$col][GROUND][WHAT] == LADDER
            or (    $r < ROWS - 2
                and $LMap->[$r][$col][GROUND][WHAT] == FLOOR
                and $LMap->[ $r + 1 ][$col][GROUND][WHAT] == WALL )
            or (    $r == ROWS - 1
                and $LMap->[$r][$col][GROUND][WHAT] == FLOOR )
        ) {
            $goal = $r;
            last;
        }
    }
    $Hero = [ $col, $goal ];
}

sub update_hero {
    my ( $key, $ret );
    tcflush( STDIN_FILENO, TCIFLUSH );
    while (1) {
        while (1) {
            $key = ReadKey(0);
            last if exists $Key_Commands{$key};
            #post_message(sprintf "Illegal command \\%03o", ord $key);
        }
        $ret = $Key_Commands{$key}->();
        last if $ret != MOVE_FAILED;
    }
    return $ret;
}

sub update_monst {
    my ($ent) = @_;
    my $mcol  = $ent->[LMC][WHERE][PCOL];
    my $mrow  = $ent->[LMC][WHERE][PROW];

    # prevent monster move where only gravity should apply
    # NOTE one may have the clever idea that monsters can run across the
    # heads of other monsters though that would require changes to how
    # the graph is setup to permit such moves, and additional checks to
    # see if something to tread upon is available (and then to let the
    # hero do that (like in Lode Runner) or to prevent them from such
    # head-running...)
    if (    $mrow != ROWS - 1
        and $ent->[LMC][GROUND][WHAT] == FLOOR
        and $LMap->[ $mrow + 1 ][$mcol][GROUND][WHAT] != WALL ) {
        return;
    }

    my $dest = find_hero( $ent, $mcol, $mrow );
    return unless defined $dest;

    relocate( $ent, $dest ) unless interact( $ent, $dest );

    if ( $ent->[STASH][GEM_STASH] > 0
        and !defined $ent->[LMC][ITEM] ) {
        if ( rand() < $ent->[STASH][GEM_ODDS] ) {
            post_message( 'The ' . $Monst_Name . ' drops a gem!' );
            $ent->[STASH][GEM_STASH]--;
            make_item( $ent->[LMC][WHERE], GEM, GEM_VALUE );
            $ent->[STASH][GEM_ODDS] = 0.0 - GEM_ODDS_ADJUST;
        }
        $ent->[STASH][GEM_ODDS] += GEM_ODDS_ADJUST;
    }
}

1;
__END__