view release on metacpan or  search on metacpan

lib/Game/Xomb.pm  view on Meta::CPAN

        } else {
            # KLUGE avoid busy-wait on "tail" of an active savegame
            sleep(0.2);
        }
    }
    print $Save_FH $key if defined $Save_FH;
    return $key;
}

sub report_position {
    log_message('Transponder reports ['
          . join(',', $Animates[HERO][LMC][WHERE]->@[ PCOL, PROW ])
          . ']');
    return MOVE_FAILED, 0;
}

sub report_version {
    log_message('Xomb v' . $VERSION . ' seed ' . $Seed . ' turn ' . $Turn_Count);
    return MOVE_FAILED, 0;
}

sub restore_term {
    ReadMode 'restore';
    print TERM_NORM, SHOW_CURSOR, UNALT_SCREEN;
}

sub rubble_delay {
    my ($ani, $cost) = @_;
    if (coinflip()) {
        if ($ani->[SPECIES] == HERO) {
            # Ultima IV does this. too annoying?
            $Violent_Sleep_Of_Reason = 1;
            log_message('Slow progress!');
        }
        return ($cost >> 1) + 2 + irand(4);
    } else {
        return 2 + irand(4);
    }
}

{
    my $energy = '00';

    sub sb_update_energy {
        $energy = sprintf "%02d", $Animates[HERO][STASH][ECOST];
    }

    sub show_status_bar {
        print at_row(STATUS_ROW),
          sprintf('Level %02d t', $Level), $energy, TERM_NORM,
          display_hitpoints(), display_cellobjs(), display_shieldup();
    }
}

sub score {
    my ($won) = @_;
    my $score = loot_value() + ($won ? 10000 : 0) + 10 * int exp $Level_Max;
    return "Score: $score in $Turn_Count turns (v$VERSION:$Seed)";
}

sub update_gameover {
    state $count = 0;
    raycast_fov(1);
    tcflush(STDIN_FILENO, TCIFLUSH);
    my $key = $RKFN->(\%Key_Commands);
    if ($count == 4) {
        has_lost();
    } elsif ($count >= 2) {
        print AT_MSG_ROW, CLEAR_RIGHT, '-- press Esc to continue --';
        has_lost() if $key eq "\033" or $key eq 'q';
    } elsif ($count == 1) {
        log_message('Communication lost with remote unit.');
    }
    $count++;
    return MOVE_OKAY, DEFAULT_COST;
}

sub update_fungi {
    my ($self) = @_;
    my ($mcol, $mrow) = $self->[LMC][WHERE]->@[ PCOL, PROW ];
    my ($tcol, $trow) = $Animates[HERO][LMC][WHERE]->@[ PCOL, PROW ];
    my $weap = $self->[STASH][WEAPON];

    my ($hits, $cost) = does_hit(distance($mcol, $mrow, $tcol, $trow), $weap);
    return MOVE_OKAY, $cost if $hits == -1;

    my (@burned, @path);
    $hits = 0;
    walkcb(
        sub {
            my ($col, $row, $iters) = @_;
            my $lmc = $LMap[$row][$col];
            push @path, [ $col, $row ];
            if (defined $lmc->[ANIMAL]) {
                push @burned, $lmc->[ANIMAL], $iters;
                $hits = 1 if $lmc->[ANIMAL][SPECIES] == HERO;
            } elsif ($lmc->[MINERAL][SPECIES] == WALL) {
                reduce($lmc) if onein(20);
                return -1;
            }
            # NOTE distance() and $iters give different numbers for diagonals
            return $iters > $weap->[W_RANGE] ? -1 : 0;
        },
        $mcol,
        $mrow,
        $tcol,
        $trow
    );
    return MOVE_OKAY, $cost unless $hits;

    bypair(
        sub {
            my ($ani, $iters) = @_;
            apply_damage($ani, 'plburn', $self, $iters) if coinflip();
        },
        @burned
    );

    my $loc = $mcol . ',' . $mrow;
    print at(map { MAP_DOFF + $_ } $mcol, $mrow), 'X'
      if exists $Visible_Cell{$loc};
    my %seen = ($loc => 1);

    for my $point (@path) {
        my ($col, $row) = $point->@[ PCOL, PROW ];
        my $loc = $col . ',' . $row;
        $seen{$loc} = 1;
        if (exists $Visible_Cell{$loc}) {
            print at(map { MAP_DOFF + $_ } $col, $row), coinflip() ? 'X' : 'x';
            $Violent_Sleep_Of_Reason = 1;
        }
    }

    my @spread;
    with_adjacent(
        $mcol, $mrow,
        sub {
            my $loc = join ',', $_[0]->@[ PCOL, PROW ];
            return if $seen{$loc}++ or !exists $Visible_Cell{$loc} or irand(10) < 8;
            print at(map { MAP_DOFF + $_ } $_[0]->@[ PCOL, PROW ]), 'X'
              if exists $Visible_Cell{$loc};
            push @spread, $_[0];
        }
    );
    if (@spread) {
        my $max = 3;
        $max += 2 if onein(40);
        $max += 3 if onein(250);
        # mostly it just looks impressive
        plasma_annihilator($self, \%seen, \@spread, 1, $max);
    }

    return MOVE_OKAY, $cost;
}

sub update_ghast {
    my ($self) = @_;
    my ($mcol, $mrow) = $self->[LMC][WHERE]->@[ PCOL, PROW ];
    my ($tcol, $trow) = $Animates[HERO][LMC][WHERE]->@[ PCOL, PROW ];
    my $weap = $self->[STASH][WEAPON];

    my ($hits, $cost) = does_hit(distance($mcol, $mrow, $tcol, $trow), $weap);
    return MOVE_OKAY, $cost if $hits == -1;

    # but a gatling gun is often trigger happy ...
    if ($hits == 0) {
        return MOVE_OKAY, $cost if onein(8);
        my @nearby;
        with_adjacent($tcol, $trow, sub { push @nearby, $_[0] });
        ($tcol, $trow) = pick(\@nearby)->@[ PCOL, PROW ];
    }

    my @path;
    linecb(
        sub {
            my ($col, $row) = @_;
            push @path, [ $col, $row ];
            if (defined $LMap[$row][$col][ANIMAL]
                and $LMap[$row][$col][ANIMAL][SPECIES] != HERO) {
                ($tcol, $trow) = ($col, $row) if $hits == 0 and coinflip();
                return -1;
            }
            my $cell = $LMap[$row][$col][MINERAL];
            if ($cell->[SPECIES] == WALL) {
                # they're not trigger happy enough to shoot a wall
                # (moreso that letting the wall be shot would reveal
                # where something is to the player)
                @path = ();
                return -1;
            } elsif ($cell->[SPECIES] == RUBBLE) {
                if (onein(10)) {
                    $hits = 0;
                    return -1;
                }
            }
            return 0;
        },
        $mcol,
        $mrow,
        $tcol,
        $trow
    );
    return MOVE_OKAY, $cost unless @path;

    for my $point (@path) {
        my $loc = join ',', $point->@[ PCOL, PROW ];
        if (exists $Visible_Cell{$loc}) {
            print at(map { MAP_DOFF + $_ } $point->@[ PCOL, PROW ]), '-';
            $Violent_Sleep_Of_Reason = 1;
        }
    }
    my $loc = $tcol . ',' . $trow;
    my $lmc = $LMap[$trow][$tcol];
    if ($hits == 0) {
        my $buddy = $LMap[$trow][$tcol][ANIMAL];
        apply_damage($buddy, 'attackby', $self) if defined $buddy;
    } else {
        apply_damage($Animates[HERO], 'attackby', $self);
        $Violent_Sleep_Of_Reason = 1;
    }

    return MOVE_OKAY, $cost;
}

sub update_mimic {
    my ($self) = @_;
    my ($mcol, $mrow) = $self->[LMC][WHERE]->@[ PCOL, PROW ];
    my ($tcol, $trow) = $Animates[HERO][LMC][WHERE]->@[ PCOL, PROW ];
    my $weap = $self->[STASH][WEAPON];

    my ($hits, $cost) = does_hit(distance($mcol, $mrow, $tcol, $trow), $weap);
    return MOVE_OKAY, $cost if $hits == -1;

    my @nearby;
    if ($hits == 0) {
        # maybe they're taking a break
        return MOVE_OKAY, $cost if onein(10);
        with_adjacent($tcol, $trow, sub { push @nearby, $_[0] });
    }

    # Mortars could, in theory, lob shells over walls but that would
    # allow Mortars to abuse things like ### that the player could
    # not get into.                      #M# so require LOS.
    linecb(
        sub {
            my ($col, $row) = @_;
            my $cell = $LMap[$row][$col][MINERAL];
            if ($cell->[SPECIES] == WALL) {
                $hits = 0;
                return -1;
            }
            return 0;
        },
        $mcol,
        $mrow,
        $tcol,
        $trow
    );
    return MOVE_OKAY, $cost if $hits < 1;

    if (@nearby) {
        log_message('A mortar shell explodes nearby!');
        my ($ncol, $nrow) = pick(\@nearby)->@[ PCOL, PROW ];
        my $lmc   = $LMap[$nrow][$ncol];
        my $buddy = $lmc->[ANIMAL];
        if (defined $buddy) {
            apply_damage($buddy, 'attackby', $self);
        } elsif ($lmc->[SPECIES] == WALL and onein(20)) {
            reduce($lmc);
        }
    } else {
        log_message('A mortar shell strikes you!');
        apply_damage($Animates[HERO], 'attackby', $self);
    }

    $Violent_Sleep_Of_Reason = 1;

    return MOVE_OKAY, $cost;
}

sub update_player {
    my ($self) = @_;
    my ($cost, $ret);

    # pre-move tasks
    sb_update_energy();
    if ($Violent_Sleep_Of_Reason == 1) {
        sleep($Draw_Delay);
        $Violent_Sleep_Of_Reason = 0;
    }
    raycast_fov(1);
    show_top_message();
    log_dim();
    show_status_bar();

    tcflush(STDIN_FILENO, TCIFLUSH);
    while (1) {
        my $key = defined $Sticky ? $Sticky : $RKFN->(\%Key_Commands);
        ($ret, $cost, my $code) = $Key_Commands{$key}->($self);
        pkc_log_code($code) if defined $code;
        last                if $ret != MOVE_FAILED;
    }

    if (defined $Sticky) {
        undef $Sticky if --$Sticky_Max <= 0;
        sleep($Draw_Delay) unless $Sticky eq '.';
    }

    my $hp = $self->[STASH][HITPOINTS];
    if (defined $self->[STASH][SHIELDUP] and $hp < START_HP) {
        my $need  = START_HP - $self->[STASH][HITPOINTS];
        my $offer = between(
            0,
            int($cost / $self->[STASH][SHIELDUP][STASH][GEM_REGEN]),
            $self->[STASH][SHIELDUP][STASH][GEM_VALUE]
        );

        my $heal = between(0, $need, $offer);
        $self->[STASH][SHIELDUP][STASH][GEM_VALUE] -= $heal;
        $hp = $self->[STASH][HITPOINTS] += $heal;
        undef $Sticky if $hp == START_HP;

        if ($self->[STASH][SHIELDUP][STASH][GEM_VALUE] <= 0) {
            pkc_log_code('0113');
            log_message(
                'The ' . $self->[STASH][SHIELDUP][STASH][GEM_NAME] . ' chips and shatters!');
            undef $self->[STASH][SHIELDUP];
            undef $Sticky;
            print display_shieldup();
        }
    }

    $Energy_Spent += $cost;
    $Turn_Count++;
    return $ret, $cost;
}

# when player is in range try to shoot them
sub update_troll {
    my ($self) = @_;
    my ($mcol, $mrow) = $self->[LMC][WHERE]->@[ PCOL, PROW ];
    my ($tcol, $trow) = $Animates[HERO][LMC][WHERE]->@[ PCOL, PROW ];
    my $weap = $self->[STASH][WEAPON];

    my ($hits, $cost) = does_hit(distance($mcol, $mrow, $tcol, $trow), $weap);
    return MOVE_OKAY, $cost if $hits == -1;

    my @path;
    my $property_damage = 0;
    walkcb(
        sub {
            my ($col, $row, $iters) = @_;
            push @path, [ $col, $row ];
            if ($iters > $weap->[W_RANGE]) {
                ($tcol, $trow) = ($col, $row) if $hits == 0;
                return -1;
            }
            if (defined $LMap[$row][$col][ANIMAL]
                and $LMap[$row][$col][ANIMAL][SPECIES] != HERO) {
                ($tcol, $trow) = ($col, $row) if $hits == 0;
                return -1;
            }
            my $cell = $LMap[$row][$col][MINERAL];
            if ($cell->[SPECIES] == WALL) {
                $hits = 0;
                if (onein(4)) {
                    ($tcol, $trow) = ($col, $row);
                    $property_damage = 1;
                } else {
                    # wall not getting blow'd up, do not (maybe) reveal
                    # to player that something is trying to do so
                    @path = ();
                }
                return -1;
            } elsif ($cell->[SPECIES] == RUBBLE) {
                # similar FOV problem as for player, see raycast. also
                # should mean that rubble is good cover for the hero
                if (onein(20)) {
                    $hits = 0;
                    ($tcol, $trow) = ($col, $row);
                    $property_damage = 1;
                    return -1;
                }
            }
            return 0;
        },
        $mcol,
        $mrow,
        $tcol,
        $trow
    );
    return MOVE_OKAY, $cost unless @path;

    for my $point (@path) {
        my $loc = join ',', $point->@[ PCOL, PROW ];
        if (exists $Visible_Cell{$loc}) {
            print at(map { MAP_DOFF + $_ } $point->@[ PCOL, PROW ]), '-';
            $Violent_Sleep_Of_Reason = 1;
        }
    }
    my $loc = $tcol . ',' . $trow;
    my $lmc = $LMap[$trow][$tcol];
    if ($property_damage) {
        reduce($lmc);
    } else {
        if ($hits == 0) {
            my $buddy = $LMap[$trow][$tcol][ANIMAL];
            apply_damage($buddy, 'attackby', $self) if defined $buddy;
        } else {
            apply_damage($Animates[HERO], 'attackby', $self);
            $Violent_Sleep_Of_Reason = 1;
        }
    }

    return MOVE_OKAY, $cost;
}

# like shooter but can only fire across totally open ground. advanced
# targetting arrays prevent friendly fire and property damage
sub update_stalker {
    my ($self) = @_;
    my ($mcol, $mrow) = $self->[LMC][WHERE]->@[ PCOL, PROW ];
    my ($tcol, $trow) = $Animates[HERO][LMC][WHERE]->@[ PCOL, PROW ];
    my $weap = $self->[STASH][WEAPON];

    my ($hits, $cost) = does_hit(distance($mcol, $mrow, $tcol, $trow), $weap);
    return MOVE_OKAY, $cost if $hits < 1;

    my @path;
    linecb(
        sub {
            my ($col, $row) = @_;
            if ($col == $tcol and $row == $trow) {    # gotcha
                push @path, [ $col, $row ];
                return 0;
            }
            # stalker needs a really clear shot (to offset for
            # their range)
            my $cell = $LMap[$row][$col][MINERAL];
            if (   defined $LMap[$row][$col][ANIMAL]
                or $cell->[SPECIES] == WALL
                or $cell->[SPECIES] == RUBBLE
                or ($cell->[SPECIES] == ACID and onein(3))) {
                $hits = 0;
                return -1;
            }
            push @path, [ $col, $row ];
        },
        $mcol,
        $mrow,
        $tcol,
        $trow
    );
    return MOVE_OKAY, $cost if $hits < 1 or !@path;

    for my $point (@path) {
        my $loc = join ',', $point->@[ PCOL, PROW ];
        print at(map { MAP_DOFF + $_ } $point->@[ PCOL, PROW ]), '='
          if exists $Visible_Cell{$loc};
    }
    apply_damage($Animates[HERO], 'attackby', $self);

    $Violent_Sleep_Of_Reason = 1;

    return MOVE_OKAY, $weap->[W_COST];
}

sub use_item {
    my ($loot, $i, $stash) = @_;
    if (!($loot->[$i][SPECIES] == GEM or $loot->[$i][SPECIES] == AMULET)) {
        pkc_log_code('0111');
        return 0;
    }
    if (defined $stash->[SHIELDUP]) {
        ($stash->[SHIELDUP], $loot->[$i]) = ($loot->[$i], $stash->[SHIELDUP]);
    } else {
        $stash->[SHIELDUP] = splice $loot->@*, $i, 1;
    }
    return 1;
}