File Coverage

blib/lib/Game/Xomb.pm
Criterion Covered Total %
statement 232 950 24.4
branch 71 442 16.0
condition 41 169 24.2
subroutine 35 108 32.4
pod 79 80 98.7
total 458 1749 26.1


line stmt bran cond sub pod time code
1             # -*- Perl -*-
2             #
3             # Game::Xomb - this is a terminal-based roguelike. run the xomb(1)
4             # command that is installed with this module to start a game
5              
6             package Game::Xomb;
7              
8             our $VERSION = '1.03';
9              
10 6     6   87393 use 5.24.0;
  6         51  
11 6     6   29 use warnings;
  6         12  
  6         270  
12 6     6   38 use List::Util qw(min max);
  6         11  
  6         832  
13 6     6   3230 use List::UtilsBy qw(min_by nsort_by);
  6         12172  
  6         430  
14 6     6   3252 use POSIX qw(STDIN_FILENO TCIFLUSH tcflush);
  6         47711  
  6         33  
15 6     6   11603 use Term::ReadKey qw(GetTerminalSize ReadKey ReadMode);
  6         11983  
  6         428  
16 6     6   3327 use Time::HiRes qw(sleep);
  6         7919  
  6         25  
17             require XSLoader;
18             XSLoader::load('Game::Xomb', $VERSION); # distance, line drawing, RNG
19              
20             ########################################################################
21             #
22             # CONSTANTS
23              
24             sub NEED_ROWS () { 24 }
25             sub NEED_COLS () { 80 }
26              
27             # ANSI or XTerm Control Sequences - https://invisible-island.net/xterm/
28             sub ALT_SCREEN () { "\e[?1049h" }
29             sub CLEAR_LINE () { "\e[2K" }
30             sub CLEAR_RIGHT () { "\e[K" }
31             sub CLEAR_SCREEN () { "\e[1;1H\e[2J" }
32             sub HIDE_CURSOR () { "\e[?25l" } # this gets toggled on/off
33             sub HIDE_POINTER () { "\e[>2p" } # hide screen gnat
34             sub SHOW_CURSOR () { "\e[?25h" }
35             sub TERM_NORM () { "\e[m" }
36             sub UNALT_SCREEN () { "\e[?1049l" }
37              
38             # these not-CONSTANTs move the cursor around. points are col,row (x,y)
39             # while terminal uses row,col hence the reverse argument order here.
40             # some at(...) calls have been made into AT_* constants for frequently
41             # used locations
42 1     1 1 928 sub at { "\e[" . $_[1] . ';' . $_[0] . 'H' }
43 1     1 1 5 sub at_row { "\e[" . $_[0] . ';1H' }
44 1     1 1 6 sub at_col { "\e[" . $_[0] . 'G' }
45              
46             # where the message (top) and status (bottom) lines are
47             sub MSG_ROW () { 1 }
48             sub AT_MSG_ROW () { "\e[1;1H" }
49             sub MSG_MAX () { NEED_ROWS - 2 }
50             sub STATUS_ROW () { 24 }
51             sub AT_STATUS_ROW () { "\e[24;1H" }
52             sub AT_ECOST () { "\e[24;10H" }
53             sub AT_HPBAR () { "\e[24;14H" }
54             sub AT_CELLOBJS () { "\e[24;68H" }
55             sub AT_SHIELDUP () { "\e[24;72H" }
56             sub AT_PKC_CODE () { "\e[24;76H" }
57              
58             # NOTE also set in Xomb.xs for map-aware functions
59             sub MAP_COLS () { 78 }
60             sub MAP_ROWS () { 22 }
61             sub MAP_SIZE () { MAP_COLS * MAP_ROWS }
62             sub MAP_DOFF () { 2 } # display offset for map on screen
63              
64             # NOTE level map is row, col while points are [ col, row ]
65             sub PROW () { 1 }
66             sub PCOL () { 0 }
67              
68             # a point in the LMC so Animates can find where they are at
69             sub WHERE () { 0 }
70             # GENUS is involved with interactions between thingies and where the
71             # thing is slotted under the LMC
72             sub MINERAL () { 1 } # floor, walls, etc
73             sub VEGGIE () { 2 } # amulet, gems, etc
74             sub ANIMAL () { 3 } # Animates
75              
76             # SPECIES
77             sub HERO () { 0 } # NOTE also used for @Animates slot
78             sub FUNGI () { 1 }
79             sub GHAST () { 2 }
80             sub MIMIC () { 3 }
81             sub STALKER () { 4 }
82             sub TROLL () { 5 }
83             sub AMULET () { 6 }
84             sub GEM () { 7 }
85             sub HOLE () { 8 }
86             sub FLOOR () { 9 }
87             sub GATE () { 10 }
88             sub ACID () { 11 }
89             sub RUBBLE () { 12 }
90             sub WALL () { 13 }
91              
92             sub AMULET_NAME () { 'Dragonstone' }
93             sub AMULET_REGEN () { 6 } # slow so less likely to burn out
94             sub AMULET_VALUE () { 1000 }
95              
96             # for ANIMALS (shared with VEGGIES and MINERALS for the first few slots)
97             sub GENUS () { 0 }
98             sub SPECIES () { 1 }
99             sub DISPLAY () { 2 } # how to show 'em on the screen
100             sub UPDATE () { 3 } # what happens when their turn comes up
101             sub STASH () { 4 } # kitchen drawer
102             sub LMC () { 5 } # link back to the level map
103             sub ENERGY () { 6 } # how long until their next update call
104             sub BLACK_SPOT () { 7 } # marked for death
105              
106             # Animates stash slots
107             sub HITPOINTS () { 0 } # player, monsters
108             sub ECOST () { 1 } # cost of previous move
109             sub WEAPON () { 2 } # mostly only for monsters
110             sub LOOT () { 3 } # player inventory
111             sub SHIELDUP () { 4 } # player shield recharge gem
112             # GEM stash slots
113             sub GEM_NAME () { 0 }
114             sub GEM_VALUE () { 1 }
115             sub GEM_REGEN () { 2 }
116              
117             sub START_HP () { 100 } # player start (and max) HP
118             sub LOOT_MAX () { NEED_ROWS - 2 } # avoids scrolling, status bar wipeout
119              
120             sub WEAP_DMG () { 0 } # for WEAPON stash slot (mostly for monsters)
121             sub W_RANGE () { 1 } # max shooting range
122             sub W_COST () { 2 } # recharge time after shot
123             sub W_TOHIT () { 3 } # to-hit values ...
124              
125             sub MOVE_LVLUP () { -1 } # NOTE tied to level change math
126             sub MOVE_FAILED () { 0 } # for zero-cost player moves
127             sub MOVE_LVLDOWN () { 1 } # NOTE tied to level change math
128             sub MOVE_OKAY () { 2 } # non-level-change costly moves
129              
130             # energy constants, see game_loop for the system
131             sub CAN_MOVE () { 0 }
132             sub DEFAULT_COST () { 10 }
133             sub DIAG_COST () { 14 }
134             sub NLVL_COST () { 15 } # time to gate to next level
135              
136             sub RUN_MAX () { 4 }
137              
138             ########################################################################
139             #
140             # VARIABLES
141              
142             our $Violent_Sleep_Of_Reason = 0;
143              
144             our @Animates; # things with energy, HERO always in first slot
145             our @LMap; # level map. array of array of array of ...
146              
147             our $Draw_Delay = 0.15;
148             our $Energy_Spent = 0;
149             our $Level = 1; # current level
150             our $Level_Max = 1;
151             our $RKFN; # function handling key reads
152             our $Replay_Delay = 0.2;
153             our $Replay_FH;
154             our $Save_FH;
155             our $Seed; # cached value, jsf.c internalizes this
156             our $Sticky; # for runner/running support
157             our $Sticky_Max = 0;
158             our $Turn_Count = 0;
159             our %Visible_Cell; # x,y => [x,y] of cells visible in FOV
160             our @Visible_Monst; # [x,y] of visible monsters
161             our %Warned_About; # limit annoying messages
162              
163             our %Damage_From = (
164             acidburn => sub {
165             my ($src, $duration) = @_;
166             my $max = $duration >> 1;
167             my $damage = 0;
168             for (1 .. $duration) {
169             $damage += coinflip();
170             $damage-- if onein(3);
171             if ($damage > $max) {
172             $damage = $max;
173             last;
174             }
175             }
176             return max(1, $damage);
177             },
178              
179             # monster damages (by species, below) get routed through here
180             attackby => sub {
181             my ($ani) = @_;
182             goto $ani->[STASH][WEAPON][WEAP_DMG]->&*;
183             },
184              
185             falling => sub {
186             my $dice = 1;
187             my $damage = 0;
188             while (1) {
189             my $roll = roll($dice, 4);
190             $damage += $roll;
191             last if $roll <= 2 or $dice >= 4;
192             $dice++;
193             }
194             return $damage;
195             },
196              
197             # custom FUNGI damage is based on range (ideal attack pattern for
198             # the player is probably similar to using a rapier in Brogue)
199             plburn => sub {
200             my (undef, $range) = @_;
201             return coinflip() if $range > 3;
202             my $dice = 4 - $range;
203             my $damage;
204             do { $damage = roll($dice, 6) } until ($damage <= 18);
205             return $damage;
206             },
207             # pretty sure this is only fungus friendly fire
208             plsplash => sub { roll(2, 8) },
209              
210             # listed here for reference but get called to through 'attackby'.
211             GHAST,
212             sub { roll(3, 2) - 1 },
213             HERO,
214             sub { roll(4, 3) + 2 },
215             MIMIC,
216             sub { roll(2, 4) },
217             STALKER,
218             sub { roll(4, 2) },
219             TROLL,
220             sub { roll(3, 6) + 2 },
221             );
222              
223             our %Hit_Points = (FUNGI, 42, GHAST, 28, MIMIC, 24, STALKER, 36, TROLL, 48,);
224              
225             # NOTE these MUST be kept in sync with the W_RANGE max
226             our %To_Hit = (
227             FUNGI, [ 100, 100, 100, 50 ],
228             GHAST, [ 65, 50, 35, 25, 10 ],
229             MIMIC, [ 10, 20, 35, 50, 50, 35, 20, 10 ],
230             STALKER, [ 80, 75, 70, 65, 60, 55, 50, 45, 45, 30, 25, 10 ],
231             TROLL, [ 70, 60, 50, 40, 25, 15, 5 ],
232             );
233             # W_RANGE how far the monster will shoot; W_COST is how long the weapon
234             # takes to recharge after a successful shot
235             #
236             # W_RANGE W_COST
237             our %Weap_Stats = (
238             FUNGI, [ 4, 31 ], GHAST, [ 5, 6 ], MIMIC, [ 8, 13 ],
239             STALKER, [ 12, 21 ], TROLL, [ 7, 29 ],
240             );
241              
242             # these are "class objects"; see reify and the make_* routines
243             # GENUS SPECIES DISPLAY UPDATE (passive effects)
244             our %Thingy = (
245             FUNGI, [ ANIMAL, FUNGI, 'F', \&update_fungi ],
246             GHAST, [ ANIMAL, GHAST, 'G', \&update_ghast ],
247             HERO, [ ANIMAL, HERO, '@', \&update_player ],
248             MIMIC, [ ANIMAL, MIMIC, 'M', \&update_mimic ],
249             STALKER, [ ANIMAL, STALKER, 'Q', \&update_stalker ],
250             TROLL, [ ANIMAL, TROLL, 'T', \&update_troll ],
251             AMULET, [ VEGGIE, AMULET, "\e[1m," . TERM_NORM ],
252             GEM, [ VEGGIE, GEM, '*' ],
253             ACID, [ MINERAL, ACID, '~', \&passive_burn ],
254             FLOOR, [ MINERAL, FLOOR, '.' ],
255             GATE, [ MINERAL, GATE, '%' ], # stair, rogue 3.6 style
256             HOLE, [ MINERAL, HOLE, ' ' ], # shaft
257             RUBBLE, [ MINERAL, RUBBLE, '^' ],
258             WALL, [ MINERAL, WALL, '#' ],
259             );
260              
261             # NOTE these may need to be fairly short, see move_examine
262             our %Descript = (
263             ACID, 'Acid pool', AMULET, AMULET_NAME,
264             FLOOR, 'Floor', FUNGI, 'Plasma Tower',
265             GATE, 'Gate', GEM, 'gemstone',
266             GHAST, 'Gatling Gun', HERO, 'Hero',
267             HOLE, 'Crevasse', MIMIC, 'Mortar',
268             RUBBLE, 'bunch of rubble', STALKER, 'Quad-laser Array',
269             TROLL, 'Railgun Tower', WALL, 'wall',
270             );
271              
272             # for looking around with, see move_examine
273             our %Examine_Offsets = (
274             'h' => [ -1, +0 ],
275             'j' => [ +0, +1 ],
276             'k' => [ +0, -1 ],
277             'l' => [ +1, +0 ],
278             'y' => [ -1, -1 ],
279             'u' => [ +1, -1 ],
280             'b' => [ -1, +1 ],
281             'n' => [ +1, +1 ],
282             );
283              
284             # these define what happens when various keys are mashed
285             our %Key_Commands = (
286             'h' => move_player_maker(-1, +0, DEFAULT_COST),
287             'j' => move_player_maker(+0, +1, DEFAULT_COST),
288             'k' => move_player_maker(+0, -1, DEFAULT_COST),
289             'l' => move_player_maker(+1, +0, DEFAULT_COST),
290             'y' => move_player_maker(-1, -1, DIAG_COST),
291             'u' => move_player_maker(+1, -1, DIAG_COST),
292             'b' => move_player_maker(-1, +1, DIAG_COST),
293             'n' => move_player_maker(+1, +1, DIAG_COST),
294             ' ' => \&move_nop,
295             ',' => \&move_pickup,
296             '.' => \&move_nop,
297             '<' => \&move_gate_up,
298             '>' => \&move_gate_down,
299             '?' => sub { help_screen(); return MOVE_FAILED, 0 },
300             '@' => \&report_position,
301             'E' => \&move_equip,
302             'G' => sub { hide_screen(); return MOVE_FAILED, 0 },
303             'M' => sub { show_messages(); return MOVE_FAILED, 0 },
304             'Q' => \&move_quit,
305             'R' => \&move_remove,
306             'd' => \&move_drop,
307             'g' => \&move_pickup,
308             'i' => \&manage_inventory,
309             'p' => sub { pkc_clear(); return MOVE_FAILED, 0 },
310             'v' => \&report_version,
311             'x' => \&move_examine,
312             '~' => \&report_version,
313             "\003" => sub { return MOVE_FAILED, 0, '1203' }, #
314             "\011" => sub { @_ = "\011"; goto &move_examine }, # TAB
315             "\014" => sub { log_dim(); refresh_board(); MOVE_FAILED, 0 }, #
316             "\032" => sub { return MOVE_FAILED, 0, '1220' }, #
317             "\033" => sub { return MOVE_FAILED, 0, '121B' },
318             );
319             # weak effort at numpad support (not supported for running nor for leaps
320             # in examine mode)
321             @Key_Commands{qw/1 2 3 4 5 6 7 8 9/} = @Key_Commands{qw/b j n h . l y k u/};
322              
323             # limited duration run because the raycast does not stop for unseen gems
324             # or gates that the player may wish to take note of
325             $Key_Commands{'H'} = move_player_runner('h', RUN_MAX);
326             $Key_Commands{'J'} = move_player_runner('j', RUN_MAX);
327             $Key_Commands{'K'} = move_player_runner('k', RUN_MAX);
328             $Key_Commands{'L'} = move_player_runner('l', RUN_MAX);
329             $Key_Commands{'Y'} = move_player_runner('y', RUN_MAX);
330             $Key_Commands{'U'} = move_player_runner('u', RUN_MAX);
331             $Key_Commands{'B'} = move_player_runner('b', RUN_MAX);
332             $Key_Commands{'N'} = move_player_runner('n', RUN_MAX);
333              
334             $Key_Commands{'S'} = move_player_snooze('.');
335              
336             my @Level_Features = (
337             { ACID, 50, GATE, 2, HOLE, 200, RUBBLE, 400, WALL, 100,
338             xarci => [ GHAST, GHAST, MIMIC ],
339             },
340             { ACID, 100, GATE, 2, HOLE, 100, RUBBLE, 100, WALL, 200,
341             xarci => [ GHAST, GHAST, MIMIC, MIMIC, STALKER, TROLL ],
342             },
343             { ACID, 400, GATE, 2, RUBBLE, 50, WALL, 50,
344             xarci => [ FUNGI, GHAST, GHAST, STALKER, TROLL, TROLL ],
345             },
346             { ACID, 100, AMULET, 1, GATE, 2, RUBBLE, 0, WALL, 300,
347             xarci => [ FUNGI, GHAST, GHAST, STALKER, TROLL, TROLL ],
348             },
349             { ACID, 200, AMULET, 1, GATE, 1, RUBBLE, 200, WALL, 50,
350             xarci => [ GHAST, STALKER, STALKER, TROLL, TROLL ],
351             },
352             );
353              
354             ########################################################################
355             #
356             # SUBROUTINES
357              
358             sub abort_run {
359 0     0 1 0 my ($col, $row, $dcol, $drow) = @_;
360 0 0 0     0 return 1
      0        
361             if defined $LMap[$row][$col][VEGGIE]
362             or defined $LMap[$drow][$dcol][ANIMAL]
363             or $LMap[$row][$col][MINERAL][SPECIES] == GATE;
364 0         0 my $dftype = $LMap[$drow][$dcol][MINERAL][SPECIES];
365 0 0 0     0 return 1 unless $dftype == FLOOR or $dftype == GATE;
366 0         0 return 0;
367             }
368              
369             sub apply_damage {
370 0     0 1 0 my ($ani, $cause, @rest) = @_;
371 0         0 my $damage = $Damage_From{$cause}->(@rest);
372 0         0 $ani->[STASH][HITPOINTS] -= $damage;
373 0 0       0 if ($ani->[STASH][HITPOINTS] <= 0) {
374 0 0       0 if ($ani->[SPECIES] == HERO) {
375 0         0 $ani->[DISPLAY] = '&'; # the @ got unravelled
376 0         0 $ani->[UPDATE] = \&update_gameover;
377 0 0       0 log_message('Shield module failure.') unless $Warned_About{shieldfail}++;
378             } else {
379             log_message($Descript{ $ani->[SPECIES] }
380             . ' destroyed by '
381 0         0 . $Descript{ $rest[0]->[SPECIES] });
382 0 0 0     0 if ($ani->[SPECIES] == FUNGI and $ani->[LMC][MINERAL] != GATE and onein(20)) {
      0        
383 0         0 reify($ani->[LMC],
384             passive_msg_maker('Broken rainbow conduits jut up from the regolith.'));
385             }
386 0         0 $ani->[BLACK_SPOT] = 1;
387 0         0 undef $ani->[LMC][ANIMAL];
388             }
389             } else {
390             log_message($Descript{ $rest[0]->[SPECIES] }
391             . ' does '
392             . $damage
393             . ' damage to '
394 0         0 . $Descript{ $ani->[SPECIES] });
395             }
396 0 0       0 if ($ani->[SPECIES] == HERO) {
397 0         0 undef $Sticky;
398 0         0 print display_hitpoints();
399             }
400             }
401              
402             # this used to pass along more information to the passive_* calls
403             sub apply_passives {
404 0     0 1 0 my ($ani, $duration, $isnewcell) = @_;
405 0   0     0 my $fn = $ani->[LMC][MINERAL][UPDATE] // return;
406 0         0 push @_, $ani->[LMC][MINERAL];
407 0         0 goto $fn->&*;
408             }
409              
410 0     0 1 0 sub await_quit { $RKFN->({ "\033" => 1, 'q' => 1 }) }
411              
412             sub bad_terminal {
413 0 0   0 1 0 return 0 unless -t *STDOUT;
414 0         0 my ($cols, $rows) = (GetTerminalSize(*STDOUT))[ 0, 1 ];
415 0 0 0     0 !defined $cols or $cols < NEED_COLS or $rows < NEED_ROWS;
416             }
417              
418             sub bail_out {
419 0     0 1 0 restore_term();
420 0         0 print at_col(0), CLEAR_LINE;
421 0 0       0 warn $_[0] if @_;
422 0         0 game_over('Minos III was unexpectedly hit by a rogue planet, the end.');
423             }
424              
425             sub between {
426 7     7 1 96 my ($min, $max, $value) = @_;
427 7 100       24 if ($value < $min) {
    100          
428 1         2 $value = $min;
429             } elsif ($value > $max) {
430 1         2 $value = $max;
431             }
432 7         23 return $value;
433             }
434              
435             sub display_cellobjs {
436 0     0 1 0 my $s = AT_CELLOBJS . '[';
437 0         0 for my $i (VEGGIE, MINERAL) {
438 0         0 my $obj = $Animates[HERO][LMC][$i];
439 0 0 0     0 $s .= (defined $obj and $obj->@*) ? $obj->[DISPLAY] : ' ';
440             }
441 0         0 return $s . ']';
442             }
443              
444             sub display_hitpoints {
445 0     0 1 0 my $hp = $Animates[HERO][STASH][HITPOINTS];
446 0 0       0 $hp = 0 if $hp < 0;
447 0         0 my $ticks = $hp >> 1;
448 0         0 my $hpbar = '=' x $ticks;
449 0 0       0 $hpbar .= '-' if $hp & 1;
450 0         0 my $len = length $hpbar;
451 0 0       0 $hpbar .= ' ' x (50 - $len) if $len < 50;
452 0         0 return AT_HPBAR . "SP[\e[1m" . $hpbar . TERM_NORM . ']';
453             }
454              
455             sub display_shieldup {
456 0     0 1 0 my $ch = ' ';
457 0 0       0 if (defined $Animates[HERO][STASH][SHIELDUP]) {
458 0 0       0 if ($Animates[HERO][STASH][SHIELDUP][STASH][GEM_NAME] eq AMULET_NAME) {
459 0         0 $ch = $Thingy{ AMULET, }->[DISPLAY];
460             } else {
461 0         0 $ch = $Thingy{ GEM, }->[DISPLAY];
462             }
463             }
464 0         0 AT_SHIELDUP . '[' . $ch . ']';
465             }
466              
467             # does a monster hit? -1 for out of range, 0 for miss, 1 for hit
468             sub does_hit {
469 3     3 1 827 my ($dist, $weap) = @_;
470 3 100       10 if ($dist > $weap->[W_RANGE]) {
471             # snooze monster for minimum time for player to be in range
472 1         3 my $away = $dist - $weap->[W_RANGE];
473 1         7 return -1, DEFAULT_COST * $away;
474             }
475 2         16 return (irand(100) < $weap->[ W_TOHIT + $dist - 1 ]), $weap->[W_COST];
476             }
477              
478             sub fisher_yates_shuffle {
479 4     4 1 2014 my ($array) = @_;
480 4         8 my $i = @$array;
481 4 100       16 return if $i < 2;
482 2         7 while (--$i) {
483 6         12 my $j = irand($i + 1);
484 6 100       14 next if $i == $j;
485 4         28 @$array[ $i, $j ] = @$array[ $j, $i ];
486             }
487             }
488              
489             sub game_loop {
490 0 0   0 1 0 game_over('Terminal must be at least ' . NEED_COLS . 'x' . NEED_ROWS)
491             if bad_terminal();
492 0         0 ReadMode 'raw';
493 0         0 $SIG{$_} = \&bail_out for qw(INT HUP TERM PIPE QUIT USR1 USR2 __DIE__);
494 0         0 $SIG{CONT} = \&refresh_board;
495             $SIG{WINCH} = sub {
496 0 0   0   0 log_message('The terminal is too small!') if bad_terminal();
497 0         0 refresh_board();
498 0         0 };
499 0         0 STDOUT->autoflush(1);
500              
501 0         0 init_jsf($Seed);
502 0         0 init_map();
503 0         0 make_player();
504 0         0 generate_map();
505 0         0 print ALT_SCREEN, HIDE_CURSOR, HIDE_POINTER, CLEAR_SCREEN, TERM_NORM;
506 0         0 show_status_bar();
507              
508 0         0 GLOOP: while (1) {
509 0         0 my $min_cost = min(map { $_->[ENERGY] } @Animates);
  0         0  
510 0         0 my @movers;
511 0         0 for my $ani (@Animates) {
512 0         0 $ani->[ENERGY] -= $min_cost;
513 0 0       0 push @movers, $ani if $ani->[ENERGY] <= CAN_MOVE;
514             }
515             # simultaneous move shuffle, all movers "get a go" though there
516             # can be edge cases related to LOS and wall destruction and who
517             # goes when
518 0         0 fisher_yates_shuffle(\@movers);
519              
520 0         0 my $new_level = 0;
521 0         0 for my $ani (@movers) {
522 0         0 my ($status, $cost) = $ani->[UPDATE]->($ani);
523 0         0 $ani->[ENERGY] += $ani->[STASH][ECOST] = $cost;
524 0 0 0     0 $new_level = $status
525             if $status == MOVE_LVLDOWN or $status == MOVE_LVLUP;
526             }
527 0 0       0 if ($new_level != 0) {
528 0         0 $Level += $new_level;
529 0         0 $Level_Max = max($Level, $Level_Max);
530 0 0       0 has_won() if $Level <= 0;
531 0         0 my $ammie = (generate_map())[0];
532 0         0 $Violent_Sleep_Of_Reason = 1;
533             # NOTE other half of this is applied in the Bump-into-HOLE
534             # logic, elsewhere. this last half happens here as the new
535             # level is not yet available prior to the fall
536 0         0 apply_passives($Animates[HERO], $Animates[HERO][STASH][ECOST] >> 1, 1);
537 0         0 show_status_bar();
538 0 0       0 log_message('Proximal ' . AMULET_NAME . ' readings detected.') if $ammie;
539 0         0 next GLOOP;
540             }
541 0         0 @Animates = grep { !$_->[BLACK_SPOT] } @Animates;
  0         0  
542             }
543             }
544              
545             sub game_over {
546 0     0 1 0 my ($message) = @_;
547 0         0 restore_term();
548 0         0 print at_col(0), CLEAR_LINE, $message, "\n", CLEAR_LINE;
549 0         0 exit(1);
550             }
551              
552             sub generate_map {
553 5     5 1 3095 my $findex = min($Level, scalar @Level_Features) - 1;
554 5         16 my $has_ammie = has_amulet();
555              
556 5         18 splice @Animates, 1;
557 5         10 my $herop = $Animates[HERO][LMC][WHERE];
558 5         11 my ($col, $row) = $herop->@[ PCOL, PROW ];
559              
560             # reset to bare ground plus some white noise seed points
561 5         9 my @seeds;
562 5         6 my $left = 80; # hopefully overkill
563 5         7 my $total = MAP_SIZE;
564 5         8 for my $r (0 .. MAP_ROWS - 1) {
565 110         141 for my $c (0 .. MAP_COLS - 1) {
566 8580         10460 $LMap[$r][$c]->@[ MINERAL, VEGGIE ] = ($Thingy{ FLOOR, }, undef);
567 8580 100 100     11861 unless ($r == $row and $c == $col) {
568 8575         9008 undef $LMap[$r][$c]->@[ANIMAL];
569 8575 100       11814 if (irand($total) < $left) {
570 400         593 push @seeds, [ $c, $r ];
571 400         410 $left--;
572             }
573             }
574 8580         8562 $total--;
575             }
576             }
577              
578 5         8 my %floored; # have we put some custom floor here?
579              
580             # brown noise for these features to make them clump together-ish
581 5         14 for my $floor (RUBBLE, ACID, HOLE, WALL) {
582 20   100     87 my $want = $Level_Features[$findex]{$floor} // 0;
583             # ... and a few more than called for, for variety
584 20 100       53 $want += irand(2 + ($want >> 1)) if $want > 0;
585 20         36 while ($want > 0) {
586 77         253 my $goal = max($want, min(20, int($want / 10)));
587 77         157 my $seed = extract(\@seeds);
588 77         358 $want -= place_floortype(
589             $seed->@[ PCOL, PROW ],
590             $floor, $goal, 60,
591             [ [ -1, 0 ], [ -1, 1 ], [ 0, -1 ], [ 0, 1 ], [ 1, -1 ], [ 1, 0 ],
592             [ 1, 1 ], [ -2, 0 ], [ -2, 2 ], [ 0, -2 ], [ 0, 2 ], [ 2, -2 ],
593             [ 2, 0 ], [ 2, 2 ], [ 3, 0 ],
594             ],
595             \%floored
596             );
597             }
598 20 50       57 bail_out("Conditions on Minos III proved too harsh.") unless @seeds;
599             }
600              
601             # points that have gems or gates; these MUST be pathable and may
602             # have monsters lurking near them
603 5         8 my @goodp;
604              
605 5         19 for (1 .. $Level_Features[$findex]{ GATE, }) {
606 9         17 my $point = extract(\@seeds);
607 9         16 ($col, $row) = $point->@[ PCOL, PROW ];
608 9         14 push @goodp, $point;
609 9         20 $LMap[$row][$col][MINERAL] = $Thingy{ GATE, };
610 9 50       20 bail_out("Conditions on Minos III proved too harsh.") unless @seeds;
611             }
612              
613 5         8 my $put_ammie = 0;
614 5 100 66     27 if (exists $Level_Features[$findex]{ AMULET, } and !$has_ammie) {
615 2         10 my $gem = (make_amulet())[0];
616 2         7 my $point = extract(\@seeds);
617 2         7 ($col, $row) = $point->@[ PCOL, PROW ];
618 2         3 push @goodp, $point;
619 2         6 $LMap[$row][$col][VEGGIE] = $gem;
620 2         4 $put_ammie = 1;
621             }
622              
623             # gems no longer generate during the climb out
624 5         9 my $gmax = 200;
625 5         6 my $GGV = 0;
626 5         6 my $gcount = 0;
627 5         15 while (!$has_ammie) {
628 18         28 my ($gem, $value, $bonus) = make_gem();
629 18         33 my $point = extract(\@seeds);
630 18         29 ($col, $row) = $point->@[ PCOL, PROW ];
631 18         21 push @goodp, $point;
632 18         29 $LMap[$row][$col][VEGGIE] = $gem;
633             # influences max score and how much shield repair is possible
634 18         18 $GGV += $value;
635 18         24 $gmax += $bonus;
636 18         17 $gcount++;
637 18 100       57 last if $GGV > $gmax;
638             }
639              
640             # ensure that the good points (gems, gates) and the hero are all
641             # connected. this may provide some hints on the final level due to
642             # the lack of rubble
643 5         24 ($col, $row) = extract(\@seeds)->@[ PCOL, PROW ];
644 5 50       41 $LMap[$row][$col][MINERAL] = $Thingy{ onein(100) ? RUBBLE : FLOOR };
645 5 100       20 if (onein(4)) {
646 2         10 reify($LMap[$row][$col],
647             passive_msg_maker("Something was written here, but you can't make it out.", 1));
648             }
649 5         19 pathable($col, $row, $herop, @goodp);
650              
651             # and now an assortment of monsters
652 5         21 for (1 .. $Level + roll(3, 3) + $has_ammie * 4) {
653 49 50       66 my $energy = $has_ammie ? CAN_MOVE : DEFAULT_COST;
654 49         82 place_monster($Level_Features[$findex]{xarci}, $energy, \@seeds);
655             }
656              
657             # fungi camping -- fungi are not useful in the normal rotation as
658             # it's too easy to simply ignore them. so sometimes they camp a good
659             # spot. and since players are pretty good pattern detectors, allow
660             # other monster types to camp spots as well
661 5         18 my @campers = (FUNGI, FUNGI, FUNGI, FUNGI, TROLL, TROLL, STALKER, GHAST);
662 5         7 my $camping = 0;
663 5 50       33 my $codds = ($has_ammie ? 31 : 0) + int exp $Level;
664 5         11 for my $gp (@goodp) {
665 29 100       50 next if irand(100) > $codds;
666             # MUST check here that we're not clobbering some other Animate
667 6         9 my @free;
668 6 50       23 push @free, ($gp) x 7
669             unless defined $LMap[ $gp->[PROW] ][ $gp->[PCOL] ][ANIMAL];
670             with_adjacent(
671             $gp->@[ PCOL, PROW ],
672             sub {
673 48     48   56 my ($adj) = @_;
674 48 100       129 push @free, $adj unless defined $LMap[ $adj->[PROW] ][ $adj->[PCOL] ][ANIMAL];
675             }
676 6         34 );
677 6 50       50 place_monster(\@campers, DEFAULT_COST, \@free) if @free;
678 6         16 $camping++;
679             }
680              
681             # be nice and put a gem close (but not too close) to the player when
682             # they start the game
683 5 100 66     17 if ($Level == 1 and !$has_ammie) {
684 1         3 my $mindist = 2 + roll(3, 2);
685 1         4 my $gem = (make_gem())[0];
686             my $point = min_by sub {
687 45     45   220 my $d =
688             distance($Animates[HERO][LMC][WHERE]->@[ PCOL, PROW ], $_->@[ PCOL, PROW ]);
689 45 100       59 $d < $mindist ? ~0 : $d;
690 1         23 }, @seeds;
691             # ... and that they can actually get to said gem
692 1         10 ($col, $row) = $point->@[ PCOL, PROW ];
693 1         2 $LMap[$row][$col][VEGGIE] = $gem;
694 1 50       5 $LMap[$row][$col][MINERAL] = $Thingy{ onein(10) ? RUBBLE : FLOOR };
695 1         4 pathable($col, $row, $herop);
696             }
697              
698 5         397 return $put_ammie, $gcount, $GGV, scalar(@seeds), $camping;
699             }
700              
701             sub getkey {
702 0     0 1 0 my ($expect) = @_;
703 0         0 my $key;
704 0         0 while (1) {
705 0         0 $key = ReadKey(0);
706 0 0       0 last if exists $expect->{$key};
707             }
708 0 0       0 print $Save_FH $key if defined $Save_FH;
709 0         0 return $key;
710             }
711              
712             sub has_amulet {
713 3     3 1 12 for my $item ($Animates[HERO][STASH][LOOT]->@*) {
714 1 50       7 return 1 if $item->[SPECIES] == AMULET;
715             }
716             # also must check shield regen slot; could set a flag but then they
717             # could drop the damn thing or burn it up in the shield module argh
718             # so complicated
719 2 100 66     26 return 1
720             if defined $Animates[HERO][STASH][SHIELDUP]
721             and $Animates[HERO][STASH][SHIELDUP][STASH][GEM_NAME] eq AMULET_NAME;
722 1         6 return 0;
723             }
724              
725             sub has_lost {
726 0     0 1 0 restore_term();
727 0         0 my $score = score(0);
728 0         0 print CLEAR_SCREEN, "Alas, victory was not to be yours.\n\n$score\n";
729 0         0 exit(1);
730             }
731              
732             sub has_won {
733 0     0 1 0 restore_term();
734 0         0 my $score = score(1);
735             # some of this is borrowed from rogue 3.6.3
736 0         0 print CLEAR_SCREEN, <<"WIN_SCREEN";
737              
738             @ @ @ @ @ @@@ @ @
739             @ @ @@ @@ @ @ @ @
740             @ @ @@@ @ @ @ @ @ @@@ @@@@ @@@ @ @@@ @
741             @@@@ @ @ @ @ @ @ @ @ @ @ @ @ @ @
742             @ @ @ @ @ @ @ @@@@ @ @ @@@@@ @ @ @
743             @ @ @ @ @ @@ @ @ @ @ @ @ @ @ @ @
744             @@@ @@@ @@ @ @ @ @@@@ @@@@ @@@ @@@ @@ @
745              
746             Congratulations. Victory is yours.
747              
748             $score
749             WIN_SCREEN
750 0         0 exit(0);
751             }
752              
753             sub help_screen {
754 0     0 1 0 print CLEAR_SCREEN, at(1, 1), <<'HELP_SCREEN', "\n:", SHOW_CURSOR;
755             Xomb Commands Reference Manual
756              
757             y k u Motion is traditional to rogue(6) as shown in the
758             \ | / compass to the left. Other commands, of which some
759             h - @ - l take time to complete, include:
760             / | \
761             b j n . - wait a turn x - examine board
762             g , - pick up item i - show inventory
763             M - show messages < > - activate gate E - equip a gem
764             p - clear PKC code C-l - redraw screen R - remove a gem
765             ? - show help v - show version d - drop a gem
766             @ - show location Q - quit the game TAB - examine monster
767             S - snooze until healed HJKLYUBN run in that direction
768              
769             Esc or q will exit from sub-displays such as this one. Prompts
770             must be answered with Y to carry out the action; N or n or Esc
771             will reject the action. Map symbols include:
772              
773             @ you % gate * gemstone . empty cell
774             # wall ~ acid ^ rubble crevasse
775              
776             Consult xomb(1) or `perldoc xomb` for additional documentation.
777             HELP_SCREEN
778 0         0 await_quit();
779 0         0 print HIDE_CURSOR;
780 0         0 log_dim();
781 0         0 refresh_board();
782             }
783              
784             sub hide_screen {
785 0     0 0 0 print CLEAR_SCREEN, at(1, 2), <<"BOSS_SCREEN", "\n:", SHOW_CURSOR;
786             LS(1) BSD General Commands Manual LS(1)
787              
788             \e[1mNAME\e[m
789             \e[1mls\e[m -- list directory contents
790              
791             SYNOPSIS
792             \e[1mls\e[m [-\e[1mABCFGHLOPRSTUW\@abcdefghiklmnopqrstuwx1\e[m] [\e[4mfile\e[m \e[4m...\e[m]
793              
794             \e[1mDESCRIPTION\e[m
795             For each operand that names a \e[4mfile\e[m of a type other than directory, ls
796             displays its name as well as any requested, associated information. For
797             each operand that names a \e[4mfile\e[m of type directory, \e[1mls\e[m displays the names
798             of files contained within that directory, as well as any requested, asso-
799             ciated information.
800              
801             If no operands are given, the contents of the current directory are dis-
802             played. If more than one operand is given, non-directory operands are
803             displayed first; directory and non-directory operands are sorted sepa-
804             rately and in lexicographical order.
805              
806             The following options are available:
807             BOSS_SCREEN
808 0         0 await_quit();
809 0         0 print HIDE_CURSOR;
810 0         0 log_dim();
811 0         0 refresh_board();
812             }
813              
814             sub init_map {
815 1     1 1 483 for my $r (0 .. MAP_ROWS - 1) {
816 22         35 for my $c (0 .. MAP_COLS - 1) {
817 1716         2213 my $point = [ $c, $r ];
818 1716         2857 push $LMap[$r]->@*, [$point]; # setup WHERE
819             }
820             }
821             }
822              
823             {
824             my $lc = 1;
825             my @log = ('Welcome to Xomb.');
826              
827 0 0   0 1 0 sub log_dim { return if $lc == 2; $lc = $lc == 0 ? 2 : 0 }
  0 0       0  
828              
829             sub log_message {
830 0     0 1 0 my ($message) = @_;
831 0         0 while (@log >= MSG_MAX) { shift @log }
  0         0  
832 0         0 push @log, $message;
833 0         0 $lc = 1;
834 0         0 show_top_message();
835             }
836              
837             sub show_messages {
838 0     0 1 0 my $s = SHOW_CURSOR;
839 0         0 while (my ($i, $message) = each @log) {
840 0         0 $s .= at_row(MSG_ROW + $i) . CLEAR_RIGHT . $message;
841             }
842 0         0 print $s, at_row(MSG_ROW + @log), CLEAR_RIGHT, "-- press Esc to continue --";
843 0         0 await_quit();
844 0         0 print HIDE_CURSOR;
845 0         0 log_dim();
846 0         0 refresh_board();
847             }
848              
849             sub show_top_message {
850 0     0 1 0 print AT_MSG_ROW, CLEAR_RIGHT, "\e[", $lc, 'm', $log[-1], TERM_NORM;
851             }
852             }
853              
854             sub loot_value {
855 4     4 1 570 my $value = 0;
856 4         12 for my $item ($Animates[HERO][STASH][LOOT]->@*) {
857             # AMULET considered as gem as they might have burned it up a bit
858 3         7 $value += $item->[STASH][GEM_VALUE];
859             }
860             # they probably won't need to charge their shield after the game
861             # is over?
862 4 100       19 $value += $Animates[HERO][STASH][SHIELDUP][STASH][GEM_VALUE]
863             if defined $Animates[HERO][STASH][SHIELDUP];
864 4         16 return $value;
865             }
866              
867             # expensive gem (vegetable) that speciated
868             sub make_amulet {
869 3     3 1 5 my $gem;
870 3         16 $gem->@[ GENUS, SPECIES, DISPLAY ] = $Thingy{ AMULET, }->@*;
871 3         17 $gem->[STASH]->@[ GEM_NAME, GEM_VALUE, GEM_REGEN ] =
872             (AMULET_NAME, AMULET_VALUE, AMULET_REGEN);
873 3         8 return $gem, AMULET_VALUE;
874             }
875              
876             sub make_gem {
877 20     20 1 36 my ($name, $value, $regen);
878             # lower regen is better and thus more rare. higher value makes for a
879             # higher score, or more shield that can be repaired
880 20 50       68 if (onein(100)) {
    50          
881 0         0 $name = "Bloodstone";
882 0         0 $value = 90 + roll(2, 10);
883 0         0 $regen = 3;
884             } elsif (onein(20)) {
885 0         0 $name = "Sunstone";
886 0         0 $value = 60 + roll(2, 10);
887 0         0 $regen = 4;
888             } else {
889 20         24 $name = "Moonstone";
890 20         37 $value = 40 + roll(2, 10);
891 20         21 $regen = 4;
892             }
893             # flavor text makes things better
894 20         24 my $bonus = 0;
895 20 50       56 if (onein(1000)) {
    100          
896 0         0 $name = 'Pearl ' . $name;
897 0         0 $value += 90 + roll(2, 10);
898 0         0 $regen = 2;
899 0         0 $bonus = 100;
900             } elsif (onein(3)) {
901 6         14 my @adj = qw/Imperial Mystic Rose Smoky Warped/;
902 6         19 $name = pick(\@adj) . ' ' . $name;
903 6         10 $value += 40 + roll(2, 10);
904 6         11 $bonus = irand(30);
905             }
906 20         23 my $gem;
907 20         49 $gem->@[ GENUS, SPECIES, DISPLAY ] = $Thingy{ GEM, }->@*;
908 20         59 $gem->[STASH]->@[ GEM_NAME, GEM_VALUE, GEM_REGEN ] =
909             ($name, $value, $regen);
910 20         45 return $gem, $value, $bonus;
911             }
912              
913             sub make_monster {
914 55     55 1 109 my (%params) = @_;
915 55         57 my $monst;
916             $monst->@[ GENUS, SPECIES, DISPLAY, UPDATE, ENERGY ] =
917 55         182 ($Thingy{ $params{species} }->@*, $params{energy});
918             $monst->[STASH]->@[ HITPOINTS, ECOST ] =
919 55         103 ($Hit_Points{ $params{species} }, CAN_MOVE);
920             $monst->[STASH][WEAPON]->@[ WEAP_DMG, W_RANGE, W_COST ] =
921 55         114 ($Damage_From{ $params{species} }, $Weap_Stats{ $params{species} }->@*,);
922 55         138 push $monst->[STASH][WEAPON]->@*, $To_Hit{ $params{species} }->@*;
923 55         97 return $monst;
924             }
925              
926             sub make_player {
927 3     3 1 5526 my $hero;
928              
929             $hero->@[ GENUS, SPECIES, DISPLAY, UPDATE, ENERGY ] =
930 3         25 ($Thingy{ HERO, }->@*, CAN_MOVE,);
931 3         12 $hero->[STASH]->@[ HITPOINTS, ECOST, LOOT ] = (START_HP, CAN_MOVE, []);
932              
933             # bascially a bulldozer, unlike the other weapons
934 3         9 $hero->[STASH][WEAPON][WEAP_DMG] = $Damage_From{ HERO, };
935              
936 3         14 my $col = irand(MAP_COLS);
937 3         9 my $row = irand(MAP_ROWS);
938 3         8 $LMap[$row][$col][ANIMAL] = $hero;
939 3         7 $hero->[LMC] = $LMap[$row][$col];
940              
941 3         8 $Animates[HERO] = $hero;
942              
943 3         9 return $col, $row;
944             }
945              
946             sub manage_inventory {
947 0     0 1 0 my ($command, $message) = @_;
948 0         0 print SHOW_CURSOR;
949 0         0 my $loot = $Animates[HERO][STASH][LOOT];
950 0         0 my $offset;
951 0         0 my $s = '';
952 0         0 my $has_loot = 0;
953 0 0       0 if ($loot->@*) {
954 0         0 $has_loot = 1;
955 0         0 my $label = 'A';
956 0         0 while (my ($i, $item) = each $loot->@*) {
957 0         0 $s .=
958             at_row(MSG_ROW + $i)
959             . CLEAR_RIGHT
960             . $label++ . ') '
961             . $item->[DISPLAY] . ' '
962             . veggie_name($item);
963             }
964 0         0 $offset = $loot->@*;
965             } else {
966 0         0 $s .= AT_MSG_ROW . CLEAR_RIGHT . "Inventory is empty.";
967 0         0 $offset = 1;
968             }
969 0         0 $s .= at_row(MSG_ROW + $offset) . CLEAR_RIGHT . '-- ';
970 0 0       0 if ($message) {
971 0         0 $s .= $message;
972             } else {
973 0         0 $s .= 'press Esc to continue';
974 0 0       0 $s .= ' or (d)rop, (E)quip' if $has_loot;
975             }
976 0         0 print $s, ' --';
977              
978 0         0 my %choices = ("\033" => 1, 'q' => 1);
979 0         0 CMD: while (1) {
980 0   0     0 my $key = $command // $RKFN->({ "\033" => 1, 'q' => 1, 'd' => 1, 'E' => 1 });
981 0 0 0     0 last if $key eq "\033" or $key eq 'q';
982 0         0 undef $command;
983 0 0       0 next unless $has_loot;
984 0 0       0 if ($key eq 'd') {
    0          
985 0 0       0 if (!defined $message) {
986 0         0 print at_row(MSG_ROW + $offset), CLEAR_RIGHT,
987             "-- drop item L)able or Esc to exit --";
988             }
989 0 0       0 if (defined $Animates[HERO][LMC][VEGGIE]) {
990 0         0 pkc_log_code('0104');
991 0         0 last CMD;
992             }
993 0         0 while (1) {
994 0         0 @choices{ map { chr 65 + $_ } 0 .. $loot->$#* } = ();
  0         0  
995 0         0 my $drop = $RKFN->(\%choices);
996 0 0 0     0 last CMD if $drop eq "\033" or $drop eq 'q';
997 0         0 my $i = ord($drop) - 65;
998 0 0       0 if ($i < $loot->@*) {
999 0         0 $Animates[HERO][LMC][VEGGIE] = splice $loot->@*, $i, 1;
1000 0         0 print display_cellobjs();
1001 0         0 last CMD;
1002             }
1003             }
1004             } elsif ($key eq 'E') {
1005 0 0       0 if (!defined $message) {
1006 0         0 print at_row(MSG_ROW + $offset), CLEAR_RIGHT,
1007             "-- Equip item L)able or Esc to exit --";
1008             }
1009 0         0 while (1) {
1010 0         0 @choices{ map { chr 65 + $_ } 0 .. $loot->$#* } = ();
  0         0  
1011 0         0 my $use = $RKFN->(\%choices);
1012 0 0 0     0 last CMD if $use eq "\033" or $use eq 'q';
1013 0         0 my $i = ord($use) - 65;
1014 0 0       0 if ($i < $loot->@*) {
1015 0 0       0 use_item($loot, $i, $Animates[HERO][STASH]) and print display_shieldup();
1016 0         0 last CMD;
1017             }
1018             }
1019             }
1020             }
1021 0         0 print HIDE_CURSOR;
1022 0         0 log_dim();
1023 0         0 refresh_board();
1024 0         0 return MOVE_FAILED, 0;
1025             }
1026              
1027             # only the player can move in this game so this is not as generic as it
1028             # should be
1029             sub move_animate {
1030 0     0 1 0 my ($ani, $cols, $rows, $cost) = @_;
1031 0         0 my $lmc = $ani->[LMC];
1032 0         0 my $dcol = $lmc->[WHERE][PCOL] + $cols;
1033 0         0 my $drow = $lmc->[WHERE][PROW] + $rows;
1034 0 0 0     0 if ( $dcol < 0
      0        
      0        
1035             or $dcol >= MAP_COLS
1036             or $drow < 0
1037             or $drow >= MAP_ROWS) {
1038 0         0 undef $Sticky;
1039 0         0 return MOVE_FAILED, 0, '0001';
1040             }
1041 0 0       0 if (defined $Sticky) {
1042 0 0 0     0 if (@Visible_Monst or abort_run($lmc->[WHERE]->@[ PCOL, PROW ], $dcol, $drow)) {
1043 0         0 undef $Sticky;
1044 0         0 return MOVE_FAILED, 0, '0065';
1045             }
1046             }
1047             # Bump combat, as is traditional
1048 0         0 my $target = $LMap[$drow][$dcol][ANIMAL];
1049 0 0       0 if (defined $target) {
1050 0 0       0 if (irand(100) < 90) {
1051 0         0 apply_damage($target, 'attackby', $ani);
1052             } else {
1053 0         0 pkc_log_code('0302');
1054             }
1055 0 0       0 $cost += rubble_delay($ani, $cost) if $lmc->[MINERAL][SPECIES] == RUBBLE;
1056 0         0 apply_passives($ani, $cost, 0);
1057 0         0 return MOVE_OKAY, $cost;
1058             }
1059 0         0 $target = $LMap[$drow][$dcol][MINERAL];
1060 0 0       0 return MOVE_FAILED, 0, '0002' if $target->[SPECIES] == WALL;
1061             # NOTE the rubble delay is applied *before* they can move out of
1062             # that acid pond that they are in:
1063             # "Yes, we really hate players, damn their guts."
1064             # -- Dungeon Crawl Stone Soup, cloud.cc
1065 0 0       0 $cost += rubble_delay($ani, $cost) if $target->[SPECIES] == RUBBLE;
1066 0 0       0 if ($target->[SPECIES] == HOLE) {
1067 0 0       0 return MOVE_FAILED, 0
1068             if nope_regarding('Falling may cause damage', undef,
1069             'You decide against it.');
1070 0         0 apply_passives($ani, $cost >> 1, 0);
1071 0         0 log_message('You plunge down into the crevasse.');
1072 0         0 relocate($ani, $dcol, $drow);
1073 0         0 pkc_log_code('0099');
1074             # KLUGE fake the source of damage as from the floor
1075 0         0 my $src;
1076 0         0 $src->[SPECIES] = FLOOR;
1077 0         0 apply_damage($ani, 'falling', $src);
1078 0         0 return MOVE_LVLDOWN, $cost;
1079             } else {
1080 0         0 apply_passives($ani, $cost >> 1, 0);
1081 0         0 relocate($ani, $dcol, $drow);
1082 0         0 apply_passives($ani, $cost >> 1, 1);
1083 0         0 return MOVE_OKAY, $cost;
1084             }
1085             }
1086              
1087             sub move_drop {
1088 0 0   0 1 0 return MOVE_FAILED, 0, '0104'
1089             if defined $Animates[HERO][LMC][VEGGIE];
1090 0 0       0 return MOVE_FAILED, 0, '0112'
1091             unless $Animates[HERO][STASH][LOOT]->@*;
1092 0         0 @_ = ('d', 'drop item L)abel or Esc to exit');
1093 0         0 goto &manage_inventory;
1094             }
1095              
1096             sub move_equip {
1097 0 0   0 1 0 return MOVE_FAILED, 0, '0112'
1098             unless $Animates[HERO][STASH][LOOT]->@*;
1099 0         0 @_ = ('E', 'Equip item L)abel or Esc to exit');
1100 0         0 goto &manage_inventory;
1101             }
1102              
1103             sub move_examine {
1104 0     0 1 0 my ($command) = @_;
1105 0         0 my ($col, $row) = $Animates[HERO][LMC][WHERE]->@[ PCOL, PROW ];
1106 0         0 my ($pcol, $prow) = ($col, $row);
1107 0         0 print AT_MSG_ROW, CLEAR_RIGHT, SHOW_CURSOR,
1108             "-- move cursor, SHIFT moves faster. TAB for monsters. Esc to exit --";
1109 0         0 my $monst = 0;
1110 0         0 while (1) {
1111 0         0 my $loc = $col . ',' . $row;
1112 0         0 my $s = '[' . $loc . '] ';
1113 0 0       0 if (exists $Visible_Cell{$loc}) {
1114 0         0 for my $i (ANIMAL, VEGGIE) {
1115 0         0 my $x = $LMap[$row][$col][$i];
1116 0 0       0 $s .= $x->[DISPLAY] . ' ' . $Descript{ $x->[SPECIES] } . ' '
1117             if defined $x;
1118             }
1119 0         0 my $g = $LMap[$row][$col][MINERAL];
1120 0 0       0 if (defined $g) {
1121 0 0       0 if ($g->[SPECIES] == HOLE) {
1122 0         0 $s .= $Descript{ $g->[SPECIES] };
1123             } else {
1124 0         0 $s .= $g->[DISPLAY] . ' ' . $Descript{ $g->[SPECIES] };
1125             }
1126             }
1127             } else {
1128 0         0 $s .= '-- negative return on FOV scanner query --';
1129             }
1130 0         0 print at_row(STATUS_ROW), CLEAR_RIGHT, $s, at(map { MAP_DOFF + $_ } $col, $row);
  0         0  
1131             # this would need to be a bit more complicated to support numpad
1132 0   0     0 my $key = $command // $RKFN->(
1133             { "\033" => 1,
1134             'q' => 1,
1135             "\011" => 1,
1136             'h' => 1,
1137             'j' => 1,
1138             'k' => 1,
1139             'l' => 1,
1140             'y' => 1,
1141             'u' => 1,
1142             'b' => 1,
1143             'n' => 1,
1144             'H' => 1,
1145             'J' => 1,
1146             'K' => 1,
1147             'L' => 1,
1148             'Y' => 1,
1149             'U' => 1,
1150             'B' => 1,
1151             'N' => 1,
1152             }
1153             );
1154 0 0 0     0 last if $key eq "\033" or $key eq 'q';
1155 0         0 undef $command;
1156 0 0       0 if ($key eq "\011") {
1157 0         0 ($col, $row) = $Visible_Monst[ $monst++ ]->@[ PCOL, PROW ];
1158 0         0 $monst %= @Visible_Monst;
1159             } else {
1160 0         0 my $distance = 1;
1161 0 0       0 if (ord $key < 97) { # SHIFT moves faster
1162 0         0 $key = lc $key;
1163 0         0 $distance = RUN_MAX;
1164             }
1165 0         0 my $dir = $Examine_Offsets{$key};
1166 0         0 $col = between(0, MAP_COLS - 1, $col + $dir->[PCOL] * $distance);
1167 0         0 $row = between(0, MAP_ROWS - 1, $row + $dir->[PROW] * $distance);
1168             }
1169             }
1170 0         0 print HIDE_CURSOR, at_row(STATUS_ROW), CLEAR_RIGHT;
1171 0         0 log_dim();
1172 0         0 show_top_message();
1173 0         0 show_status_bar();
1174 0 0       0 return MOVE_FAILED, 0, onein(5000) ? '1202' : ();
1175             }
1176              
1177             sub move_gate_down {
1178 0 0   0 1 0 return MOVE_FAILED, 0, '0004'
1179             if $Animates[HERO][LMC][MINERAL][SPECIES] != GATE;
1180 0 0       0 if ($Level > @Level_Features) {
1181 0         0 log_message('The gate appears to be inactive.');
1182 0         0 return MOVE_FAILED, 0, '0014';
1183             }
1184 0         0 log_message('Gate activated.');
1185 0         0 $Violent_Sleep_Of_Reason = 1;
1186 0         0 return MOVE_LVLDOWN, NLVL_COST;
1187             }
1188              
1189             sub move_gate_up {
1190 0 0   0 1 0 return MOVE_FAILED, 0, '0004'
1191             if $Animates[HERO][LMC][MINERAL][SPECIES] != GATE;
1192 0 0       0 unless (has_amulet()) {
1193 0         0 log_message('You need the ' . AMULET_NAME . ' to ascend.');
1194 0         0 return MOVE_FAILED, 0, '0010';
1195             }
1196 0         0 log_message('Gate activated.');
1197 0         0 $Violent_Sleep_Of_Reason = 1;
1198 0         0 return MOVE_LVLUP, NLVL_COST;
1199             }
1200              
1201             sub move_nop {
1202 0 0 0 0 1 0 if (defined $Sticky
      0        
1203             and (@Visible_Monst or $Animates[HERO][LMC][MINERAL][SPECIES] == ACID)) {
1204 0         0 undef $Sticky;
1205 0         0 return MOVE_FAILED, 0;
1206             }
1207 0         0 apply_passives($Animates[HERO], DEFAULT_COST, 0);
1208             # NOTE constant amount of time even if they idle in rubble
1209 0         0 return MOVE_OKAY, DEFAULT_COST;
1210             }
1211              
1212             sub move_pickup {
1213 0     0 1 0 my $lmc = $Animates[HERO][LMC];
1214 0 0       0 return MOVE_FAILED, 0, '0101' unless defined $lmc->[VEGGIE];
1215 0         0 my $loot = $Animates[HERO][STASH][LOOT];
1216 0 0       0 return MOVE_FAILED, 0, '0102' if $loot->@* >= LOOT_MAX;
1217 0         0 my $cost = DEFAULT_COST;
1218 0 0       0 $cost += rubble_delay($Animates[HERO], $cost)
1219             if $lmc->[MINERAL][SPECIES] == RUBBLE;
1220 0 0       0 if ($lmc->[VEGGIE][SPECIES] == AMULET) {
1221 0         0 log_message('Obtained ' . AMULET_NAME . '! Ascend to win!');
1222 0         0 $Violent_Sleep_Of_Reason = 1;
1223             } else {
1224 0         0 log_message('Obtained ' . veggie_name($lmc->[VEGGIE]));
1225             }
1226 0         0 push $loot->@*, $lmc->[VEGGIE];
1227 0         0 print display_cellobjs();
1228 0         0 $lmc->[VEGGIE] = undef;
1229 0         0 return MOVE_OKAY, $cost;
1230             }
1231              
1232             sub move_player_maker {
1233 48     48 1 90 my ($cols, $rows, $mvcost) = @_;
1234             sub {
1235 0     0   0 my @ret = move_animate($Animates[HERO], $cols, $rows, $mvcost);
1236 0         0 print display_cellobjs();
1237 0         0 return @ret;
1238             }
1239 48         452 }
1240              
1241             sub move_player_runner {
1242 48     48 1 93 my ($key, $count) = @_;
1243             sub {
1244 0     0   0 $Sticky = $key;
1245 0         0 $Sticky_Max = $count;
1246 0         0 goto $Key_Commands{$key}->&*;
1247             }
1248 48         247 }
1249              
1250             sub move_player_snooze {
1251 6     6 1 14 my ($key) = @_;
1252             sub {
1253             # no long snooze unless something to charge from
1254 0 0   0   0 return MOVE_FAILED, 0, '0063' unless defined $Animates[HERO][STASH][SHIELDUP];
1255 0         0 $Sticky = $key;
1256 0         0 $Sticky_Max = START_HP * 5;
1257 0         0 goto $Key_Commands{$key}->&*;
1258             }
1259 6         116 }
1260              
1261             sub move_quit {
1262 0 0   0 1 0 return MOVE_FAILED, 0
1263             if nope_regarding('Really quit game?', undef, 'You decide against it.');
1264 0         0 has_lost();
1265             }
1266              
1267             sub move_remove {
1268 0 0   0 1 0 return MOVE_FAILED, 0, '0113'
1269             unless defined $Animates[HERO][STASH][SHIELDUP];
1270 0         0 my $loot = $Animates[HERO][STASH][LOOT];
1271 0 0       0 return MOVE_FAILED, 0, '0102' if $loot->@* >= LOOT_MAX;
1272 0         0 push $loot->@*, $Animates[HERO][STASH][SHIELDUP];
1273 0         0 undef $Animates[HERO][STASH][SHIELDUP];
1274 0         0 print display_shieldup();
1275 0         0 return MOVE_FAILED, 0;
1276             }
1277              
1278             sub nope_regarding {
1279 0     0 1 0 my ($message, $yes, $no) = @_;
1280 0         0 print AT_MSG_ROW, CLEAR_RIGHT, '/!\ ', $message, ' (Y/N)';
1281 0         0 my $key = $RKFN->({ 'Y' => 1, 'N' => 1, 'n' => 1, "\033" => 1 });
1282 0         0 my $ret;
1283 0 0       0 if ($key eq 'Y') {
1284 0 0       0 log_message($yes) if defined $yes;
1285 0         0 $ret = 0;
1286             } else {
1287 0 0       0 log_message($no) if defined $no;
1288 0         0 $ret = 1;
1289             }
1290 0         0 return $ret;
1291             }
1292              
1293             # only to the hero; map generation must place rubble/floor under monsters
1294             sub passive_burn {
1295 0     0 1 0 my ($ani, $duration, $isnewcell, $obj) = @_;
1296 0         0 pkc_log_code('007E');
1297             log_message('Acid intrusion reported by shield module.')
1298 0 0       0 unless $Warned_About{acidburn}++;
1299 0         0 apply_damage($ani, 'acidburn', $obj, $duration);
1300             }
1301              
1302             sub passive_msg_maker {
1303 2     2 1 6 my ($message, $oneshot) = @_;
1304             sub {
1305 0     0   0 my ($ani, $duration, $isnewcell, $obj) = @_;
1306 0 0       0 if ($isnewcell) {
1307 0         0 log_message($message);
1308 0 0       0 undef $obj->[UPDATE] if $oneshot;
1309             }
1310             }
1311 2         21 }
1312              
1313             sub pathable {
1314 6     6 1 15 my ($col, $row, @rest) = @_;
1315 6         10 for my $point (@rest) {
1316             linecb(
1317             sub {
1318 660     660   838 my ($c, $r) = @_;
1319 660         800 my $cell = $LMap[$r][$c][MINERAL];
1320 660 100 100     2252 if ( $cell->[SPECIES] == WALL
      100        
      100        
1321             or $cell->[SPECIES] == HOLE
1322             or ($cell->[SPECIES] == ACID and onein(4))) {
1323 110 100       366 $LMap[$r][$c][MINERAL] = $Thingy{ onein(7) ? RUBBLE : FLOOR };
1324             }
1325             },
1326 35         153 $col,
1327             $row,
1328             $point->@[ PCOL, PROW ]
1329             );
1330             }
1331             }
1332              
1333             # the PKC display unit - mostly useless error reporting (see xomb(1))
1334 0     0 1 0 sub pkc_clear { print AT_PKC_CODE, CLEAR_RIGHT }
1335 0     0 1 0 sub pkc_log_code { print AT_PKC_CODE, $_[0] }
1336              
1337             sub place_floortype {
1338 77     77 1 124 my ($col, $row, $species, $count, $odds, $offsets, $used) = @_;
1339 77         81 my $placed = 0;
1340 77         129 while ($count-- > 0) {
1341 6378         9326 my ($ncol, $nrow) = pick($offsets)->@[ PCOL, PROW ];
1342 6378         6052 $ncol += $col;
1343 6378         6063 $nrow += $row;
1344             next
1345 6378 100 100     21812 if $ncol < 0
      100        
      100        
1346             or $ncol >= MAP_COLS
1347             or $nrow < 0
1348             or $nrow >= MAP_ROWS;
1349 5480         6764 my $loc = $ncol . ',' . $nrow;
1350             # slightly different pattern for rubble: ignore the "have we put
1351             # something there" check
1352 5480 100       7018 if ($species != RUBBLE) {
1353 4464 100       8604 next if $used->{$loc}++;
1354             }
1355 3283         4193 $LMap[$nrow][$ncol][MINERAL] = $Thingy{$species};
1356 3283         3188 $placed++;
1357             # focus on a new starting point, sometimes
1358 3283 100       5754 if (irand(100) < $odds) { ($col, $row) = ($ncol, $nrow) }
  1944         3220  
1359             }
1360 77         333 return $placed;
1361             }
1362              
1363             sub place_monster {
1364 55     55 1 71 my ($species, $energy, $seeds) = @_;
1365              
1366 55         84 my $point = extract($seeds);
1367 55         86 my ($col, $row) = $point->@[ PCOL, PROW ];
1368              
1369 55         87 my $monst = make_monster(
1370             species => pick($species),
1371             energy => $energy,
1372             );
1373              
1374 55 100       173 $LMap[$row][$col][MINERAL] = $Thingy{ onein(10) ? RUBBLE : FLOOR }
    100          
1375             unless $LMap[$row][$col][MINERAL][SPECIES] == GATE;
1376              
1377 55         58 $LMap[$row][$col][ANIMAL] = $monst;
1378 55         59 $monst->[LMC] = $LMap[$row][$col];
1379              
1380 55         72 push @Animates, $monst;
1381              
1382 55         87 return $point;
1383             }
1384              
1385             sub plasma_annihilator {
1386 0     0 1 0 my ($self, $seen, $spread, $depth, $max) = @_;
1387              
1388 0 0 0     0 return if $depth >= $max or !$spread->@*;
1389              
1390 0         0 my ($col, $row) = pick($spread)->@[ PCOL, PROW ];
1391 0         0 my $loc = $col . ',' . $row;
1392 0         0 $seen->{$loc} = 1;
1393              
1394 0         0 my $lmc = $LMap[$row][$col];
1395 0 0       0 if (defined $lmc->[ANIMAL]) {
    0          
1396 0 0       0 apply_damage($lmc->[ANIMAL], 'plsplash', $self) if coinflip();
1397             } elsif ($lmc->[MINERAL][SPECIES] == WALL) {
1398 0 0       0 reduce($lmc) if onein(40);
1399 0         0 return;
1400             }
1401 0 0       0 if (exists $Visible_Cell{$loc}) {
1402 0         0 print at(map { MAP_DOFF + $_ } $col, $row),
1403 0 0       0 onein(1000) ? $Thingy{ AMULET, }->[DISPLAY] : 'x';
1404             }
1405              
1406             with_adjacent(
1407             $col, $row,
1408             sub {
1409 0     0   0 my ($point) = @_;
1410 0         0 my $adj = join ',', $point->@[ PCOL, PROW ];
1411 0 0 0     0 return if $seen->{$adj} or !exists $Visible_Cell{$loc};
1412 0         0 push $spread->@*, $point;
1413 0         0 @_ = ($self, $seen, $spread, $depth + 1, $max);
1414 0         0 goto &plasma_annihilator;
1415             }
1416 0         0 );
1417             }
1418              
1419             sub raycast_fov {
1420 0     0 1 0 my ($refresh) = @_;
1421 0         0 state $FOV;
1422 0 0 0     0 if (!$refresh and defined $FOV) {
1423 0         0 print $FOV;
1424 0         0 return;
1425             }
1426              
1427 0         0 my (%blocked, %byrow, %seen);
1428 0         0 my ($cx, $cy) = $Animates[HERO][LMC][WHERE]->@[ PCOL, PROW ];
1429 0         0 %Visible_Cell = ($cx . ',' . $cy => [ $cx, $cy ]);
1430 0         0 @Visible_Monst = ();
1431              
1432             # radius 7 points taken from Game:RaycastFOV cache
1433 0         0 for my $ep (
1434             [ -2, -7 ], [ -1, -7 ], [ 0, -7 ], [ 1, -7 ], [ 2, -7 ], [ -4, -6 ],
1435             [ -3, -6 ], [ -2, -6 ], [ 2, -6 ], [ 3, -6 ], [ 4, -6 ], [ -5, -5 ],
1436             [ -4, -5 ], [ 4, -5 ], [ 5, -5 ], [ -6, -4 ], [ -5, -4 ], [ 5, -4 ],
1437             [ 6, -4 ], [ -6, -3 ], [ 6, -3 ], [ -7, -2 ], [ -6, -2 ], [ 6, -2 ],
1438             [ 7, -2 ], [ -7, -1 ], [ 7, -1 ], [ -7, 0 ], [ 7, 0 ], [ -7, 1 ],
1439             [ 7, 1 ], [ -7, 2 ], [ -6, 2 ], [ 6, 2 ], [ 7, 2 ], [ -6, 3 ],
1440             [ 6, 3 ], [ -6, 4 ], [ -5, 4 ], [ 5, 4 ], [ 6, 4 ], [ -5, 5 ],
1441             [ -4, 5 ], [ 4, 5 ], [ 5, 5 ], [ -4, 6 ], [ -3, 6 ], [ -2, 6 ],
1442             [ 2, 6 ], [ 3, 6 ], [ 4, 6 ], [ -2, 7 ], [ -1, 7 ], [ 0, 7 ],
1443             [ 1, 7 ], [ 2, 7 ]
1444             ) {
1445             linecb(
1446             sub {
1447 0     0   0 my ($col, $row, $iters) = @_;
1448              
1449             # "the moon is a harsh mistress" -- FOV degrades at range
1450 0 0       0 return -1 if $iters - 4 > irand(7);
1451              
1452 0         0 my $loc = $col . ',' . $row;
1453 0 0       0 return -1 if exists $blocked{$loc};
1454              
1455 0         0 my $point = [ $col, $row ];
1456             push @Visible_Monst, $point
1457 0 0 0     0 if !$seen{$loc}++ and defined $LMap[$row][$col][ANIMAL];
1458              
1459             # walls MUST block, other features may due to the "harsh
1460             # environment" (vim on the 2009 MacBook, at the moment).
1461             # similar restrictions are applied to monster LOS walks
1462             # to the player (see update_*). hopefully.
1463 0         0 my $cell = $LMap[$row][$col][MINERAL];
1464 0 0       0 if ($cell->[SPECIES] == WALL) {
    0          
    0          
1465 0         0 $blocked{$loc} = 1;
1466 0         0 push $byrow{$row}->@*, [ $col, $cell->[DISPLAY] ];
1467 0         0 $Visible_Cell{$loc} = $point;
1468 0         0 return -1;
1469             } elsif ($cell->[SPECIES] == RUBBLE) {
1470 0 0       0 $blocked{$loc} = 1 if onein(20);
1471             } elsif ($cell->[SPECIES] == ACID) {
1472 0 0       0 $blocked{$loc} = 1 if onein(100);
1473             }
1474              
1475 0 0       0 return 0 if exists $Visible_Cell{$loc};
1476 0         0 $Visible_Cell{$loc} = [ $col, $row ];
1477 0         0 for my $i (ANIMAL, VEGGIE) {
1478 0 0       0 if (defined $LMap[$row][$col][$i]) {
1479 0         0 push $byrow{$row}->@*, [ $col, $LMap[$row][$col][$i][DISPLAY] ];
1480 0         0 return 0;
1481             }
1482             }
1483 0         0 push $byrow{$row}->@*, [ $col, $cell->[DISPLAY] ];
1484 0         0 return 0;
1485             },
1486 0         0 $cx,
1487             $cy,
1488             $cx + $ep->[0],
1489             $cy + $ep->[1]
1490             );
1491             }
1492              
1493 0         0 my $s = '';
1494 0         0 for my $r (0 .. MAP_ROWS - 1) {
1495 0         0 $s .= at_row(MAP_DOFF + $r) . CLEAR_RIGHT;
1496             }
1497 0     0   0 for my $r (nsort_by { $byrow{$_} } keys %byrow) {
  0         0  
1498 0         0 $s .= at_row(MAP_DOFF + $r);
1499 0     0   0 for my $ref (nsort_by { $_->[0] } $byrow{$r}->@*) {
  0         0  
1500 0         0 $s .= at_col(MAP_DOFF + $ref->[0]) . $ref->[1];
1501             }
1502             }
1503              
1504             # ensure @ is shown as FOV should not touch that cell
1505             print $FOV =
1506 0         0 $s . at(map { MAP_DOFF + $_ } $cx, $cy) . $LMap[$cy][$cx][ANIMAL][DISPLAY];
  0         0  
1507             }
1508              
1509             sub reduce {
1510 0     0 1 0 my ($lmc) = @_;
1511 0 0       0 if (exists $Visible_Cell{ join ',', $lmc->[WHERE]->@[ PCOL, PROW ] }) {
1512             log_message('A '
1513 0         0 . $Descript{ $lmc->[MINERAL][SPECIES] }
1514             . ' explodes in a shower of fragments!');
1515             }
1516             # rubble reification
1517 0         0 $lmc->[MINERAL] = [ $lmc->[MINERAL]->@* ];
1518             $lmc->[MINERAL]->@[ SPECIES, DISPLAY ] =
1519 0         0 $Thingy{ RUBBLE, }->@[ SPECIES, DISPLAY ];
1520             }
1521              
1522             sub refresh_board {
1523 0     0 1 0 print CLEAR_SCREEN;
1524 0         0 raycast_fov(0);
1525 0         0 show_top_message();
1526 0         0 show_status_bar();
1527             }
1528              
1529             # similar to tu'a in Lojban
1530             sub reify {
1531 2     2 1 5 my ($lmc, $update) = @_;
1532 2         7 $lmc->[MINERAL] = [ $lmc->[MINERAL]->@* ];
1533 2 50       8 $lmc->[MINERAL][UPDATE] = $update if defined $update;
1534             }
1535              
1536             sub relocate {
1537 0     0 1 0 my ($ani, $col, $row) = @_;
1538 0         0 my $lmc = $ani->[LMC];
1539              
1540 0         0 my $src = $lmc->[WHERE];
1541              
1542 0         0 my $dest_lmc = $LMap[$row][$col];
1543 0         0 $dest_lmc->[ANIMAL] = $ani;
1544 0         0 undef $LMap[ $src->[PROW] ][ $src->[PCOL] ][ANIMAL];
1545              
1546 0         0 $ani->[LMC] = $dest_lmc;
1547              
1548 0   0     0 my $cell = $lmc->[VEGGIE] // $lmc->[MINERAL];
1549 0         0 print at(map { MAP_DOFF + $_ } $src->@[ PCOL, PROW ]), $cell->[DISPLAY],
1550 0         0 at(map { MAP_DOFF + $_ } $col, $row),
  0         0  
1551             $ani->[DISPLAY];
1552             }
1553              
1554             sub replay {
1555 0     0 1 0 my ($expect) = @_;
1556 0         0 my $key;
1557 0         0 sleep($Replay_Delay);
1558 0         0 local $/ = \1;
1559 0         0 while (1) {
1560 0         0 my $esc = ReadKey(-1);
1561 0 0 0     0 if (defined $esc and $esc eq "\033") {
1562 0         0 $RKFN = \&Game::Xomb::getkey;
1563 0         0 goto &Game::Xomb::getkey;
1564             }
1565 0         0 $key = readline $Replay_FH;
1566 0 0       0 if (defined $key) {
1567 0 0       0 last if exists $expect->{$key};
1568             } else {
1569             # KLUGE avoid busy-wait on "tail" of an active savegame
1570 0         0 sleep(0.2);
1571             }
1572             }
1573 0 0       0 print $Save_FH $key if defined $Save_FH;
1574 0         0 return $key;
1575             }
1576              
1577             sub report_position {
1578 0     0 1 0 log_message('Transponder reports ['
1579             . join(',', $Animates[HERO][LMC][WHERE]->@[ PCOL, PROW ])
1580             . ']');
1581 0         0 return MOVE_FAILED, 0;
1582             }
1583              
1584             sub report_version {
1585 0     0 1 0 log_message('Xomb v' . $VERSION . ' seed ' . $Seed . ' turn ' . $Turn_Count);
1586 0         0 return MOVE_FAILED, 0;
1587             }
1588              
1589             sub restore_term {
1590 0     0 1 0 ReadMode 'restore';
1591 0         0 print TERM_NORM, SHOW_CURSOR, UNALT_SCREEN;
1592             }
1593              
1594             sub rubble_delay {
1595 0     0 1 0 my ($ani, $cost) = @_;
1596 0 0       0 if (coinflip()) {
1597 0 0       0 if ($ani->[SPECIES] == HERO) {
1598             # Ultima IV does this. too annoying?
1599 0         0 $Violent_Sleep_Of_Reason = 1;
1600 0         0 log_message('Slow progress!');
1601             }
1602 0         0 return ($cost >> 1) + 2 + irand(4);
1603             } else {
1604 0         0 return 2 + irand(4);
1605             }
1606             }
1607              
1608             {
1609             my $energy = '00';
1610              
1611             sub sb_update_energy {
1612 0     0 1 0 $energy = sprintf "%02d", $Animates[HERO][STASH][ECOST];
1613             }
1614              
1615             sub show_status_bar {
1616 0     0 1 0 print at_row(STATUS_ROW),
1617             sprintf('Level %02d t', $Level), $energy, TERM_NORM,
1618             display_hitpoints(), display_cellobjs(), display_shieldup();
1619             }
1620             }
1621              
1622             sub score {
1623 0     0 1 0 my ($won) = @_;
1624 0 0       0 my $score = loot_value() + ($won ? 10000 : 0) + 10 * int exp $Level_Max;
1625 0         0 return "Score: $score in $Turn_Count turns (v$VERSION:$Seed)";
1626             }
1627              
1628             sub update_gameover {
1629 0     0 1 0 state $count = 0;
1630 0         0 raycast_fov(1);
1631 0         0 tcflush(STDIN_FILENO, TCIFLUSH);
1632 0         0 my $key = $RKFN->(\%Key_Commands);
1633 0 0       0 if ($count == 4) {
    0          
    0          
1634 0         0 has_lost();
1635             } elsif ($count >= 2) {
1636 0         0 print AT_MSG_ROW, CLEAR_RIGHT, '-- press Esc to continue --';
1637 0 0 0     0 has_lost() if $key eq "\033" or $key eq 'q';
1638             } elsif ($count == 1) {
1639 0         0 log_message('Communication lost with remote unit.');
1640             }
1641 0         0 $count++;
1642 0         0 return MOVE_OKAY, DEFAULT_COST;
1643             }
1644              
1645             sub update_fungi {
1646 0     0 1 0 my ($self) = @_;
1647 0         0 my ($mcol, $mrow) = $self->[LMC][WHERE]->@[ PCOL, PROW ];
1648 0         0 my ($tcol, $trow) = $Animates[HERO][LMC][WHERE]->@[ PCOL, PROW ];
1649 0         0 my $weap = $self->[STASH][WEAPON];
1650              
1651 0         0 my ($hits, $cost) = does_hit(distance($mcol, $mrow, $tcol, $trow), $weap);
1652 0 0       0 return MOVE_OKAY, $cost if $hits == -1;
1653              
1654 0         0 my (@burned, @path);
1655 0         0 $hits = 0;
1656             walkcb(
1657             sub {
1658 0     0   0 my ($col, $row, $iters) = @_;
1659 0         0 my $lmc = $LMap[$row][$col];
1660 0         0 push @path, [ $col, $row ];
1661 0 0       0 if (defined $lmc->[ANIMAL]) {
    0          
1662 0         0 push @burned, $lmc->[ANIMAL], $iters;
1663 0 0       0 $hits = 1 if $lmc->[ANIMAL][SPECIES] == HERO;
1664             } elsif ($lmc->[MINERAL][SPECIES] == WALL) {
1665 0 0       0 reduce($lmc) if onein(20);
1666 0         0 return -1;
1667             }
1668             # NOTE distance() and $iters give different numbers for diagonals
1669 0 0       0 return $iters > $weap->[W_RANGE] ? -1 : 0;
1670             },
1671 0         0 $mcol,
1672             $mrow,
1673             $tcol,
1674             $trow
1675             );
1676 0 0       0 return MOVE_OKAY, $cost unless $hits;
1677              
1678             bypair(
1679             sub {
1680 0     0   0 my ($ani, $iters) = @_;
1681 0 0       0 apply_damage($ani, 'plburn', $self, $iters) if coinflip();
1682             },
1683             @burned
1684 0         0 );
1685              
1686 0         0 my $loc = $mcol . ',' . $mrow;
1687 0         0 print at(map { MAP_DOFF + $_ } $mcol, $mrow), 'X'
1688 0 0       0 if exists $Visible_Cell{$loc};
1689 0         0 my %seen = ($loc => 1);
1690              
1691 0         0 for my $point (@path) {
1692 0         0 my ($col, $row) = $point->@[ PCOL, PROW ];
1693 0         0 my $loc = $col . ',' . $row;
1694 0         0 $seen{$loc} = 1;
1695 0 0       0 if (exists $Visible_Cell{$loc}) {
1696 0 0       0 print at(map { MAP_DOFF + $_ } $col, $row), coinflip() ? 'X' : 'x';
  0         0  
1697 0         0 $Violent_Sleep_Of_Reason = 1;
1698             }
1699             }
1700              
1701 0         0 my @spread;
1702             with_adjacent(
1703             $mcol, $mrow,
1704             sub {
1705 0     0   0 my $loc = join ',', $_[0]->@[ PCOL, PROW ];
1706 0 0 0     0 return if $seen{$loc}++ or !exists $Visible_Cell{$loc} or irand(10) < 8;
      0        
1707 0         0 print at(map { MAP_DOFF + $_ } $_[0]->@[ PCOL, PROW ]), 'X'
1708 0 0       0 if exists $Visible_Cell{$loc};
1709 0         0 push @spread, $_[0];
1710             }
1711 0         0 );
1712 0 0       0 if (@spread) {
1713 0         0 my $max = 3;
1714 0 0       0 $max += 2 if onein(40);
1715 0 0       0 $max += 3 if onein(250);
1716             # mostly it just looks impressive
1717 0         0 plasma_annihilator($self, \%seen, \@spread, 1, $max);
1718             }
1719              
1720 0         0 return MOVE_OKAY, $cost;
1721             }
1722              
1723             sub update_ghast {
1724 0     0 1 0 my ($self) = @_;
1725 0         0 my ($mcol, $mrow) = $self->[LMC][WHERE]->@[ PCOL, PROW ];
1726 0         0 my ($tcol, $trow) = $Animates[HERO][LMC][WHERE]->@[ PCOL, PROW ];
1727 0         0 my $weap = $self->[STASH][WEAPON];
1728              
1729 0         0 my ($hits, $cost) = does_hit(distance($mcol, $mrow, $tcol, $trow), $weap);
1730 0 0       0 return MOVE_OKAY, $cost if $hits == -1;
1731              
1732             # but a gatling gun is often trigger happy ...
1733 0 0       0 if ($hits == 0) {
1734 0 0       0 return MOVE_OKAY, $cost if onein(8);
1735 0         0 my @nearby;
1736 0     0   0 with_adjacent($tcol, $trow, sub { push @nearby, $_[0] });
  0         0  
1737 0         0 ($tcol, $trow) = pick(\@nearby)->@[ PCOL, PROW ];
1738             }
1739              
1740 0         0 my @path;
1741             linecb(
1742             sub {
1743 0     0   0 my ($col, $row) = @_;
1744 0         0 push @path, [ $col, $row ];
1745 0 0 0     0 if (defined $LMap[$row][$col][ANIMAL]
1746             and $LMap[$row][$col][ANIMAL][SPECIES] != HERO) {
1747 0 0 0     0 ($tcol, $trow) = ($col, $row) if $hits == 0 and coinflip();
1748 0         0 return -1;
1749             }
1750 0         0 my $cell = $LMap[$row][$col][MINERAL];
1751 0 0       0 if ($cell->[SPECIES] == WALL) {
    0          
1752             # they're not trigger happy enough to shoot a wall
1753             # (moreso that letting the wall be shot would reveal
1754             # where something is to the player)
1755 0         0 @path = ();
1756 0         0 return -1;
1757             } elsif ($cell->[SPECIES] == RUBBLE) {
1758 0 0       0 if (onein(10)) {
1759 0         0 $hits = 0;
1760 0         0 return -1;
1761             }
1762             }
1763 0         0 return 0;
1764             },
1765 0         0 $mcol,
1766             $mrow,
1767             $tcol,
1768             $trow
1769             );
1770 0 0       0 return MOVE_OKAY, $cost unless @path;
1771              
1772 0         0 for my $point (@path) {
1773 0         0 my $loc = join ',', $point->@[ PCOL, PROW ];
1774 0 0       0 if (exists $Visible_Cell{$loc}) {
1775 0         0 print at(map { MAP_DOFF + $_ } $point->@[ PCOL, PROW ]), '-';
  0         0  
1776 0         0 $Violent_Sleep_Of_Reason = 1;
1777             }
1778             }
1779 0         0 my $loc = $tcol . ',' . $trow;
1780 0         0 my $lmc = $LMap[$trow][$tcol];
1781 0 0       0 if ($hits == 0) {
1782 0         0 my $buddy = $LMap[$trow][$tcol][ANIMAL];
1783 0 0       0 apply_damage($buddy, 'attackby', $self) if defined $buddy;
1784             } else {
1785 0         0 apply_damage($Animates[HERO], 'attackby', $self);
1786 0         0 $Violent_Sleep_Of_Reason = 1;
1787             }
1788              
1789 0         0 return MOVE_OKAY, $cost;
1790             }
1791              
1792             sub update_mimic {
1793 0     0 1 0 my ($self) = @_;
1794 0         0 my ($mcol, $mrow) = $self->[LMC][WHERE]->@[ PCOL, PROW ];
1795 0         0 my ($tcol, $trow) = $Animates[HERO][LMC][WHERE]->@[ PCOL, PROW ];
1796 0         0 my $weap = $self->[STASH][WEAPON];
1797              
1798 0         0 my ($hits, $cost) = does_hit(distance($mcol, $mrow, $tcol, $trow), $weap);
1799 0 0       0 return MOVE_OKAY, $cost if $hits == -1;
1800              
1801 0         0 my @nearby;
1802 0 0       0 if ($hits == 0) {
1803             # maybe they're taking a break
1804 0 0       0 return MOVE_OKAY, $cost if onein(10);
1805 0     0   0 with_adjacent($tcol, $trow, sub { push @nearby, $_[0] });
  0         0  
1806             }
1807              
1808             # Mortars could, in theory, lob shells over walls but that would
1809             # allow Mortars to abuse things like ### that the player could
1810             # not get into. #M# so require LOS.
1811             linecb(
1812             sub {
1813 0     0   0 my ($col, $row) = @_;
1814 0         0 my $cell = $LMap[$row][$col][MINERAL];
1815 0 0       0 if ($cell->[SPECIES] == WALL) {
1816 0         0 $hits = 0;
1817 0         0 return -1;
1818             }
1819 0         0 return 0;
1820             },
1821 0         0 $mcol,
1822             $mrow,
1823             $tcol,
1824             $trow
1825             );
1826 0 0       0 return MOVE_OKAY, $cost if $hits < 1;
1827              
1828 0 0       0 if (@nearby) {
1829 0         0 log_message('A mortar shell explodes nearby!');
1830 0         0 my ($ncol, $nrow) = pick(\@nearby)->@[ PCOL, PROW ];
1831 0         0 my $lmc = $LMap[$nrow][$ncol];
1832 0         0 my $buddy = $lmc->[ANIMAL];
1833 0 0 0     0 if (defined $buddy) {
    0          
1834 0         0 apply_damage($buddy, 'attackby', $self);
1835             } elsif ($lmc->[SPECIES] == WALL and onein(20)) {
1836 0         0 reduce($lmc);
1837             }
1838             } else {
1839 0         0 log_message('A mortar shell strikes you!');
1840 0         0 apply_damage($Animates[HERO], 'attackby', $self);
1841             }
1842              
1843 0         0 $Violent_Sleep_Of_Reason = 1;
1844              
1845 0         0 return MOVE_OKAY, $cost;
1846             }
1847              
1848             sub update_player {
1849 0     0 1 0 my ($self) = @_;
1850 0         0 my ($cost, $ret);
1851              
1852             # pre-move tasks
1853 0         0 sb_update_energy();
1854 0 0       0 if ($Violent_Sleep_Of_Reason == 1) {
1855 0         0 sleep($Draw_Delay);
1856 0         0 $Violent_Sleep_Of_Reason = 0;
1857             }
1858 0         0 raycast_fov(1);
1859 0         0 show_top_message();
1860 0         0 log_dim();
1861 0         0 show_status_bar();
1862              
1863 0         0 tcflush(STDIN_FILENO, TCIFLUSH);
1864 0         0 while (1) {
1865 0 0       0 my $key = defined $Sticky ? $Sticky : $RKFN->(\%Key_Commands);
1866 0         0 ($ret, $cost, my $code) = $Key_Commands{$key}->($self);
1867 0 0       0 pkc_log_code($code) if defined $code;
1868 0 0       0 last if $ret != MOVE_FAILED;
1869             }
1870              
1871 0 0       0 if (defined $Sticky) {
1872 0 0       0 undef $Sticky if --$Sticky_Max <= 0;
1873 0 0       0 sleep($Draw_Delay) unless $Sticky eq '.';
1874             }
1875              
1876 0         0 my $hp = $self->[STASH][HITPOINTS];
1877 0 0 0     0 if (defined $self->[STASH][SHIELDUP] and $hp < START_HP) {
1878 0         0 my $need = START_HP - $self->[STASH][HITPOINTS];
1879 0         0 my $offer = between(
1880             0,
1881             int($cost / $self->[STASH][SHIELDUP][STASH][GEM_REGEN]),
1882             $self->[STASH][SHIELDUP][STASH][GEM_VALUE]
1883             );
1884              
1885 0         0 my $heal = between(0, $need, $offer);
1886 0         0 $self->[STASH][SHIELDUP][STASH][GEM_VALUE] -= $heal;
1887 0         0 $hp = $self->[STASH][HITPOINTS] += $heal;
1888 0 0       0 undef $Sticky if $hp == START_HP;
1889              
1890 0 0       0 if ($self->[STASH][SHIELDUP][STASH][GEM_VALUE] <= 0) {
1891 0         0 pkc_log_code('0113');
1892 0         0 log_message(
1893             'The ' . $self->[STASH][SHIELDUP][STASH][GEM_NAME] . ' chips and shatters!');
1894 0         0 undef $self->[STASH][SHIELDUP];
1895 0         0 undef $Sticky;
1896 0         0 print display_shieldup();
1897             }
1898             }
1899              
1900 0         0 $Energy_Spent += $cost;
1901 0         0 $Turn_Count++;
1902 0         0 return $ret, $cost;
1903             }
1904              
1905             # when player is in range try to shoot them
1906             sub update_troll {
1907 0     0 1 0 my ($self) = @_;
1908 0         0 my ($mcol, $mrow) = $self->[LMC][WHERE]->@[ PCOL, PROW ];
1909 0         0 my ($tcol, $trow) = $Animates[HERO][LMC][WHERE]->@[ PCOL, PROW ];
1910 0         0 my $weap = $self->[STASH][WEAPON];
1911              
1912 0         0 my ($hits, $cost) = does_hit(distance($mcol, $mrow, $tcol, $trow), $weap);
1913 0 0       0 return MOVE_OKAY, $cost if $hits == -1;
1914              
1915 0         0 my @path;
1916 0         0 my $property_damage = 0;
1917             walkcb(
1918             sub {
1919 0     0   0 my ($col, $row, $iters) = @_;
1920 0         0 push @path, [ $col, $row ];
1921 0 0       0 if ($iters > $weap->[W_RANGE]) {
1922 0 0       0 ($tcol, $trow) = ($col, $row) if $hits == 0;
1923 0         0 return -1;
1924             }
1925 0 0 0     0 if (defined $LMap[$row][$col][ANIMAL]
1926             and $LMap[$row][$col][ANIMAL][SPECIES] != HERO) {
1927 0 0       0 ($tcol, $trow) = ($col, $row) if $hits == 0;
1928 0         0 return -1;
1929             }
1930 0         0 my $cell = $LMap[$row][$col][MINERAL];
1931 0 0       0 if ($cell->[SPECIES] == WALL) {
    0          
1932 0         0 $hits = 0;
1933 0 0       0 if (onein(4)) {
1934 0         0 ($tcol, $trow) = ($col, $row);
1935 0         0 $property_damage = 1;
1936             } else {
1937             # wall not getting blow'd up, do not (maybe) reveal
1938             # to player that something is trying to do so
1939 0         0 @path = ();
1940             }
1941 0         0 return -1;
1942             } elsif ($cell->[SPECIES] == RUBBLE) {
1943             # similar FOV problem as for player, see raycast. also
1944             # should mean that rubble is good cover for the hero
1945 0 0       0 if (onein(20)) {
1946 0         0 $hits = 0;
1947 0         0 ($tcol, $trow) = ($col, $row);
1948 0         0 $property_damage = 1;
1949 0         0 return -1;
1950             }
1951             }
1952 0         0 return 0;
1953             },
1954 0         0 $mcol,
1955             $mrow,
1956             $tcol,
1957             $trow
1958             );
1959 0 0       0 return MOVE_OKAY, $cost unless @path;
1960              
1961 0         0 for my $point (@path) {
1962 0         0 my $loc = join ',', $point->@[ PCOL, PROW ];
1963 0 0       0 if (exists $Visible_Cell{$loc}) {
1964 0         0 print at(map { MAP_DOFF + $_ } $point->@[ PCOL, PROW ]), '-';
  0         0  
1965 0         0 $Violent_Sleep_Of_Reason = 1;
1966             }
1967             }
1968 0         0 my $loc = $tcol . ',' . $trow;
1969 0         0 my $lmc = $LMap[$trow][$tcol];
1970 0 0       0 if ($property_damage) {
1971 0         0 reduce($lmc);
1972             } else {
1973 0 0       0 if ($hits == 0) {
1974 0         0 my $buddy = $LMap[$trow][$tcol][ANIMAL];
1975 0 0       0 apply_damage($buddy, 'attackby', $self) if defined $buddy;
1976             } else {
1977 0         0 apply_damage($Animates[HERO], 'attackby', $self);
1978 0         0 $Violent_Sleep_Of_Reason = 1;
1979             }
1980             }
1981              
1982 0         0 return MOVE_OKAY, $cost;
1983             }
1984              
1985             # like shooter but can only fire across totally open ground. advanced
1986             # targetting arrays prevent friendly fire and property damage
1987             sub update_stalker {
1988 0     0 1 0 my ($self) = @_;
1989 0         0 my ($mcol, $mrow) = $self->[LMC][WHERE]->@[ PCOL, PROW ];
1990 0         0 my ($tcol, $trow) = $Animates[HERO][LMC][WHERE]->@[ PCOL, PROW ];
1991 0         0 my $weap = $self->[STASH][WEAPON];
1992              
1993 0         0 my ($hits, $cost) = does_hit(distance($mcol, $mrow, $tcol, $trow), $weap);
1994 0 0       0 return MOVE_OKAY, $cost if $hits < 1;
1995              
1996 0         0 my @path;
1997             linecb(
1998             sub {
1999 0     0   0 my ($col, $row) = @_;
2000 0 0 0     0 if ($col == $tcol and $row == $trow) { # gotcha
2001 0         0 push @path, [ $col, $row ];
2002 0         0 return 0;
2003             }
2004             # stalker needs a really clear shot (to offset for
2005             # their range)
2006 0         0 my $cell = $LMap[$row][$col][MINERAL];
2007 0 0 0     0 if ( defined $LMap[$row][$col][ANIMAL]
      0        
      0        
      0        
2008             or $cell->[SPECIES] == WALL
2009             or $cell->[SPECIES] == RUBBLE
2010             or ($cell->[SPECIES] == ACID and onein(3))) {
2011 0         0 $hits = 0;
2012 0         0 return -1;
2013             }
2014 0         0 push @path, [ $col, $row ];
2015             },
2016 0         0 $mcol,
2017             $mrow,
2018             $tcol,
2019             $trow
2020             );
2021 0 0 0     0 return MOVE_OKAY, $cost if $hits < 1 or !@path;
2022              
2023 0         0 for my $point (@path) {
2024 0         0 my $loc = join ',', $point->@[ PCOL, PROW ];
2025 0         0 print at(map { MAP_DOFF + $_ } $point->@[ PCOL, PROW ]), '='
2026 0 0       0 if exists $Visible_Cell{$loc};
2027             }
2028 0         0 apply_damage($Animates[HERO], 'attackby', $self);
2029              
2030 0         0 $Violent_Sleep_Of_Reason = 1;
2031              
2032 0         0 return MOVE_OKAY, $weap->[W_COST];
2033             }
2034              
2035             sub use_item {
2036 2     2 1 6 my ($loot, $i, $stash) = @_;
2037 2 50 66     12 if (!($loot->[$i][SPECIES] == GEM or $loot->[$i][SPECIES] == AMULET)) {
2038 0         0 pkc_log_code('0111');
2039 0         0 return 0;
2040             }
2041 2 100       5 if (defined $stash->[SHIELDUP]) {
2042 1         4 ($stash->[SHIELDUP], $loot->[$i]) = ($loot->[$i], $stash->[SHIELDUP]);
2043             } else {
2044 1         4 $stash->[SHIELDUP] = splice $loot->@*, $i, 1;
2045             }
2046 2         7 return 1;
2047             }
2048              
2049             sub veggie_name {
2050 1     1 1 6 my ($veg) = @_;
2051 1         1 my $s;
2052 1 50 33     9 if ($veg->[SPECIES] == GEM or $veg->[SPECIES] == AMULET) {
2053 1         7 $s = sprintf "(%d) %s", $veg->[STASH]->@[ GEM_VALUE, GEM_NAME ];
2054             } else {
2055 0         0 $s = $Descript{ $veg->[SPECIES] };
2056             }
2057 1         4 return $s;
2058             }
2059              
2060             sub with_adjacent {
2061 11     11 1 9285 my ($col, $row, $callback) = @_;
2062 11         47 for my $adj (
2063             [ -1, -1 ], [ -1, 0 ], [ -1, 1 ], [ 0, -1 ],
2064             [ 0, 1 ], [ 1, -1 ], [ 1, 0 ], [ 1, 1 ]
2065             ) {
2066 88         170 my ($ac, $ar) = ($col + $adj->[PCOL], $row + $adj->[PROW]);
2067 88 100 100     364 next if $ac < 0 or $ac >= MAP_COLS or $ar < 0 or $ar >= MAP_ROWS;
      100        
      100        
2068 72         141 $callback->([ $ac, $ar ]);
2069             }
2070             }
2071              
2072             1;
2073             __END__