921 lines
22 KiB
Perl
Executable file
921 lines
22 KiB
Perl
Executable file
#!/usr/bin/env perl
|
|
# This 'game.pl' is licensed under the GPL3 as seen in LICENSE.
|
|
# if LICENSE is not available, see < https://www.gnu.org/licenses/gpl-3.0.en.html >
|
|
|
|
use strict;
|
|
use warnings;
|
|
use 5.010;
|
|
|
|
# wants, desires:
|
|
# utf8 compatible -> would require an array of the map rather
|
|
# than relying on curses knowledge of what is on the screen
|
|
# as utf8 'chars' are like 3+ bytes
|
|
# (which would make fixing the resize bug easier)
|
|
|
|
# uncomment below when 'game.pl' is default shell for a user.
|
|
#use POSIX qw(locale_h);
|
|
#use locale;
|
|
#setlocale(LC_CTYPE, "en_US.UTF-8"); # hope you have this generated :)
|
|
|
|
use Curses;
|
|
use TOML;
|
|
use File::Slurper qw(read_text write_text);
|
|
use Carp::Always;
|
|
use Smart::Comments;
|
|
|
|
my ($game_config, $game_items, $battlers, $err);
|
|
|
|
($game_config, $err) = from_toml(read_text('./game.pl.toml'));
|
|
if ($err) {
|
|
die $err;
|
|
}
|
|
($game_items, $err) = from_toml(read_text('./assets/GAME_ITEMS.toml'));
|
|
if ($err) {
|
|
die $err;
|
|
}
|
|
($battlers, $err) = from_toml(read_text('./assets/BATTLERS.toml'));
|
|
if ($err) {
|
|
die $err;
|
|
}
|
|
|
|
initscr();
|
|
cbreak();
|
|
noecho();
|
|
keypad(stdscr, 1);
|
|
start_color();
|
|
|
|
my %colors;
|
|
# init color pairs
|
|
{
|
|
my %term_colors = (
|
|
black => COLOR_BLACK,
|
|
blue => COLOR_BLUE,
|
|
cyan => COLOR_CYAN,
|
|
green => COLOR_GREEN,
|
|
magenta => COLOR_MAGENTA,
|
|
red => COLOR_RED,
|
|
white => COLOR_WHITE,
|
|
yellow => COLOR_YELLOW
|
|
);
|
|
my $i = 1;
|
|
for my $fore (sort keys %term_colors) {
|
|
for my $back (sort keys %term_colors) {
|
|
init_pair($i, $term_colors{$fore}, $term_colors{$back});
|
|
$colors{$fore . '_' . $back} = $i;
|
|
$i++;
|
|
}
|
|
}
|
|
}
|
|
|
|
attron( COLOR_PAIR( $colors{white_black} ) );
|
|
|
|
my $size_changed;
|
|
$SIG{'WINCH'} = sub { $size_changed = 1; };
|
|
|
|
my $max_y = 40; # Curses inits at top left, down is y+1, right is x+1 ( y,x NOT x,y )
|
|
my $max_x = 80;
|
|
|
|
my $grass = ' '; # ????
|
|
my $empty = '.'; # ????
|
|
|
|
my $player = $game_config->{newgame_player};
|
|
my $f_y = $game_config->{newgame_y};
|
|
my $f_x = $game_config->{newgame_x};
|
|
my $dialog_mode = 0;
|
|
my $menu_mode = 0;
|
|
my $battle_mode = 0;
|
|
my $hp = $game_config->{newgame_hp};
|
|
my $max_hp = $game_config->{newgame_max_hp};
|
|
my $atk = $game_config->{newgame_atk};
|
|
my $def = $game_config->{newgame_def};
|
|
my $lvl = $game_config->{newgame_lvl};
|
|
my $class = $game_config->{newgame_class};
|
|
my $hands = $game_config->{newgame_hands};
|
|
my $armor = $game_config->{newgame_armor};
|
|
|
|
my $curr_map = $game_config->{newgame_map};
|
|
my $scripts;
|
|
my %npcs; # coming in ( 25, 23, 'r', uid, OBJECT (in objects table), $movement_pattern, color ); actual hash uid -> %{ y, x, 'r', OBJECT, $movement_pattern, color }
|
|
my %npc_movements; # %{ 'bob1' => 0 } # 0 == array index and 'bob1' refers to $scripts->{npc_movements}->{bob1}
|
|
my %game_vars;
|
|
my @inventory = @{ $game_config->{newgame_inventory} };
|
|
my @status = ();
|
|
my %journal;
|
|
my %battle_sess;
|
|
|
|
sub draw_map {
|
|
my $map = shift;
|
|
$map = "$map.map";
|
|
open my $fh, '<', './assets/'. $map
|
|
or endwin() and die "$map not accessible";
|
|
move(0,0);
|
|
while (<$fh>) {
|
|
printw($_);
|
|
}
|
|
move($f_y, $f_x);
|
|
}
|
|
|
|
sub is_move_ok {
|
|
my ($y, $x) = @_;
|
|
move($y,$x);
|
|
my $testchar = substr instring(), 0, 1;
|
|
my %ok_movement = (
|
|
$grass => 1,
|
|
$empty => 1,
|
|
);
|
|
exists $ok_movement{$testchar} ? return 1 : return 0;
|
|
};
|
|
|
|
sub get_scripts {
|
|
my $file = shift;
|
|
$file = "$file.toml";
|
|
my $err;
|
|
($scripts, $err) = from_toml(read_text('./assets/' . $file));
|
|
if ($err) {
|
|
endwin();
|
|
die "Error parsing toml: $err";
|
|
}
|
|
create_npcs($scripts);
|
|
};
|
|
|
|
sub create_npcs {
|
|
undef %npcs;
|
|
undef %npc_movements;
|
|
my $scripts = shift;
|
|
# 0 1 2 3 4 5 6
|
|
# ( 25, 23, 'r', uid, "mr. rat", $behavior, color );
|
|
for my $npc (@{ $scripts->{npc} }) {
|
|
# key uid 0 y 1 x 2 char 3 object 4 behavior 5 color
|
|
$npcs{ $npc->[3] } = [$npc->[0], $npc->[1], $npc->[2], $npc->[4], $npc->[5], $npc->[6]];
|
|
# pain. this shit should've been oop'd away.
|
|
};
|
|
};
|
|
|
|
sub draw_npcs {
|
|
for my $npc (keys %npcs ) {
|
|
move($npcs{$npc}->[0], $npcs{$npc}->[1]);
|
|
if ($npcs{$npc}->[5] ) {
|
|
attroff( COLOR_PAIR( $colors{white_black} ));
|
|
attron( COLOR_PAIR( $colors{ $npcs{$npc}->[5] } ));
|
|
addstr($npcs{$npc}->[2]);
|
|
attroff( COLOR_PAIR( $colors{ $npcs{$npc}->[5] } ));
|
|
attron( COLOR_PAIR( $colors{white_black} ));
|
|
}
|
|
else {
|
|
addstr($npcs{$npc}->[2]);
|
|
}
|
|
}
|
|
refresh();
|
|
};
|
|
|
|
# TODO BUGFIX where NPC/Player can collide with one another and 'stack'
|
|
# a fix would be to check each npc position after thier movement
|
|
# I don't feel like doing this rn.
|
|
sub engage_npcs {
|
|
for my $npc (keys %npcs) {
|
|
if($npcs{$npc}->[4]) {
|
|
my $behavior = $npcs{$npc}->[4];
|
|
if ($behavior eq 'random_movement') {
|
|
random_movement_npc($npc);
|
|
}
|
|
elsif (exists $npc_movements{$behavior}) {
|
|
custom_movement_npc($npc, $behavior);
|
|
}
|
|
elsif (not exists $npc_movements{$behavior}) {
|
|
$npc_movements{$behavior} = 0;
|
|
custom_movement_npc($npc, $behavior);
|
|
}
|
|
}
|
|
}
|
|
draw_npcs();
|
|
};
|
|
|
|
sub random_movement_npc {
|
|
my $npc = shift;
|
|
my $move = int rand 8;
|
|
if ($move == 1) { # move up
|
|
if (is_move_ok($npcs{$npc}->[0] - 1, $npcs{$npc}->[1])) {
|
|
addch($npcs{$npc}->[0], $npcs{$npc}->[1], ' ');
|
|
$npcs{$npc}->[0] -= 1
|
|
}
|
|
} elsif ($move == 2) { # move down
|
|
if (is_move_ok($npcs{$npc}->[0] + 1, $npcs{$npc}->[1])) {
|
|
addch($npcs{$npc}->[0], $npcs{$npc}->[1], ' ');
|
|
$npcs{$npc}->[0] += 1
|
|
}
|
|
} elsif ($move == 3) { # move right
|
|
if (is_move_ok($npcs{$npc}->[0], $npcs{$npc}->[1] + 1)) {
|
|
addch($npcs{$npc}->[0], $npcs{$npc}->[1], ' ');
|
|
$npcs{$npc}->[1] += 1
|
|
}
|
|
} elsif ($move == 4) { # move left
|
|
if (is_move_ok($npcs{$npc}->[0], $npcs{$npc}->[1] - 1)) {
|
|
addch($npcs{$npc}->[0], $npcs{$npc}->[1], ' ');
|
|
$npcs{$npc}->[1] -= 1;
|
|
}
|
|
}
|
|
else { }; # don't move
|
|
}
|
|
|
|
sub custom_movement_npc {
|
|
my ($npc, $behavior) = @_;
|
|
my %movement_cmds = (
|
|
l => sub { my $npc = shift; return $npc->[0], $npc->[1] - 1; },
|
|
r => sub { my $npc = shift; return $npc->[0], $npc->[1] + 1; },
|
|
u => sub { my $npc = shift; return $npc->[0] - 1, $npc->[1]; },
|
|
d => sub { my $npc = shift; return $npc->[0] + 1, $npc->[1]; },
|
|
w => sub { return -1, -1; },
|
|
);
|
|
|
|
# enjoy, future me. :^)
|
|
# ... okok just remember:
|
|
# %npcs, %npc_movements, and $scripts are global. $scripts is the TOML file
|
|
# $behavior is a key for a value (char array) that $scripts->{npc_movements} has
|
|
# %npc_movements: %{ $behavior => 0, ... } where 0 is array index
|
|
# %movement_cmds: keys are chars that the array can return; values are code blocks
|
|
my ($y, $x) = $movement_cmds{
|
|
$scripts->{npc_movements}->{$behavior}->[ $npc_movements{$behavior} ]
|
|
}( $npcs{$npc} );
|
|
|
|
if ($y == -1 and $x == -1) {
|
|
my $new_index = ($npc_movements{$behavior} + 1) % scalar @{ $scripts->{npc_movements}->{$behavior} };
|
|
$npc_movements{$behavior} = $new_index;
|
|
return;
|
|
}
|
|
|
|
if (is_move_ok($y, $x)) {
|
|
addch($npcs{$npc}->[0], $npcs{$npc}->[1], ' '); # put whitespace on char
|
|
($npcs{$npc}->[0], $npcs{$npc}->[1]) = ($y, $x); # new coords, so it can be drawn
|
|
my $new_index = ($npc_movements{$behavior} + 1) % scalar @{ $scripts->{npc_movements}->{$behavior} };
|
|
$npc_movements{$behavior} = $new_index;
|
|
}
|
|
}
|
|
|
|
sub run_map_script {
|
|
## no critic (eval)
|
|
if ($scripts->{map_script}) {
|
|
eval $scripts->{map_script};
|
|
if ($@) {
|
|
endwin();
|
|
die $@;
|
|
}
|
|
}
|
|
};
|
|
|
|
sub interact {
|
|
# I'll just use 'dumb' logic here.
|
|
|
|
my ($y, $x) = @_;
|
|
# get list of interactables
|
|
my $object;
|
|
for my $interact_list ( @{ $scripts->{interact} } ) {
|
|
if ($interact_list->[0] == $y and $interact_list->[1] == $x + 1) { # to the right
|
|
$object = $interact_list->[2];
|
|
goto INTERACT_GOTO;
|
|
} elsif ($interact_list->[0] == $y and $interact_list->[1] == $x - 1) { # to the left
|
|
$object = $interact_list->[2];
|
|
goto INTERACT_GOTO;
|
|
} elsif (($interact_list->[0] == $y + 1) and $interact_list->[1] == $x) { # to the down
|
|
$object = $interact_list->[2];
|
|
goto INTERACT_GOTO;
|
|
} elsif (($interact_list->[0] == $y - 1) and $interact_list->[1] == $x) { # to the up
|
|
$object = $interact_list->[2];
|
|
goto INTERACT_GOTO;
|
|
} elsif ($interact_list->[0] == $y and $interact_list->[1] == $x) { # right on top of it (which is a bug but w/e)
|
|
$object = $interact_list->[2];
|
|
goto INTERACT_GOTO;
|
|
}
|
|
}
|
|
# check each and all npcs
|
|
for my $npc (keys %npcs) {
|
|
if ($npcs{$npc}->[0] == $y and $npcs{$npc}->[1] == $x + 1) { # to the right
|
|
$object = $npcs{$npc}->[3];
|
|
goto INTERACT_GOTO;
|
|
} elsif ($npcs{$npc}->[0] == $y and $npcs{$npc}->[1] == $x - 1) { # to the left
|
|
$object = $npcs{$npc}->[3];
|
|
goto INTERACT_GOTO;
|
|
} elsif (($npcs{$npc}->[0] == $y + 1) and $npcs{$npc}->[1] == $x) { # to the down
|
|
$object = $npcs{$npc}->[3];
|
|
goto INTERACT_GOTO;
|
|
} elsif (($npcs{$npc}->[0] == $y - 1) and $npcs{$npc}->[1] == $x) { # to the up
|
|
$object = $npcs{$npc}->[3];
|
|
goto INTERACT_GOTO;
|
|
} elsif ($npcs{$npc}->[0] == $y and $npcs{$npc}->[1] == $x) { # right on top of it (which is a bug but w/e)
|
|
$object = $npcs{$npc}->[3];
|
|
goto INTERACT_GOTO;
|
|
}
|
|
}
|
|
|
|
INTERACT_GOTO:
|
|
if ($object) {
|
|
# hopefully no one wrote anything naughty here
|
|
## no critic (eval)
|
|
eval $scripts->{objects}->{$object};
|
|
if ($@) {
|
|
endwin();
|
|
die $@;
|
|
}
|
|
refresh();
|
|
}
|
|
}
|
|
|
|
sub dialog {
|
|
my ($name, $dialog, $redraw) = @_;
|
|
defined $redraw or $redraw = 1; # redraw by default.
|
|
$dialog_mode = 1;
|
|
dialog_box();
|
|
dialog_wrap($name, $dialog);
|
|
|
|
#move($f_y, $f_x);
|
|
while () {
|
|
my $input = getchar();
|
|
if ($input eq ' ' or $input eq KEY_ENTER) {
|
|
if ($redraw) {
|
|
endwin();
|
|
draw_map($curr_map);
|
|
draw_npcs();
|
|
addch($f_y, $f_x, $player);
|
|
move($f_y, $f_x);
|
|
refresh();
|
|
$dialog_mode = 0;
|
|
last;
|
|
}
|
|
else {
|
|
# note that this doesn't toggle $dialog_mode
|
|
# inventory_item_menu() handles this ok
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
};
|
|
|
|
sub dialog_box {
|
|
my ($name) = @_;
|
|
hline(30, 14, ACS_HLINE, 50);
|
|
for (31..34) {
|
|
hline($_, 14, ' ', 50);
|
|
}
|
|
hline(35, 14, ACS_HLINE, 50);
|
|
vline(30,14, ACS_VLINE, 6);
|
|
vline(30,64, ACS_VLINE, 6);
|
|
addch(30,14, ACS_ULCORNER); # top left
|
|
addch(30,64, ACS_URCORNER); # top right
|
|
addch(35,14, ACS_LLCORNER); # bottom left
|
|
addch(35,64, ACS_LRCORNER); # bottom right
|
|
move(35,40);
|
|
printw("SPACE TO CONTINUE");
|
|
}
|
|
|
|
sub dialog_wrap {
|
|
my ($name, $dialog) = @_;
|
|
move(31,15);
|
|
printw($name);
|
|
# 31 -> 34 on y axis (so 3 lines of dialog)
|
|
# 14 -> 64 on x axis (but really 15 to 63 so about 48 chars per line)
|
|
my @lines = split "\n", $dialog;
|
|
my $y = 32;
|
|
for (@lines) {
|
|
move($y, 15);
|
|
printw($_);
|
|
$y++;
|
|
}
|
|
}
|
|
|
|
sub teleport {
|
|
my ($map, $y, $x) = @_;
|
|
$curr_map = $map;
|
|
endwin();
|
|
get_scripts($map);
|
|
draw_map($map);
|
|
run_map_script();
|
|
draw_npcs();
|
|
$f_y = $y;
|
|
$f_x = $x;
|
|
move($f_x, $f_x);
|
|
refresh();
|
|
}
|
|
|
|
sub game_loop {
|
|
my ($new_game) = @_;
|
|
get_scripts($curr_map) if $new_game;
|
|
draw_map($curr_map);
|
|
draw_npcs();
|
|
run_map_script();
|
|
|
|
# main gameplay loop
|
|
my $input;
|
|
while () {
|
|
if ($size_changed) {
|
|
endwin();
|
|
refresh();
|
|
draw_map($curr_map);
|
|
}
|
|
|
|
if ($dialog_mode) {
|
|
}
|
|
if ($menu_mode) {
|
|
$input = getchar();
|
|
if ($input eq 's') {
|
|
my $save = {
|
|
hp => $hp,
|
|
max_hp => $max_hp,
|
|
atk => $atk,
|
|
def => $def,
|
|
lvl => $lvl,
|
|
class => $class,
|
|
f_y => $f_y,
|
|
f_x => $f_x,
|
|
hands => $hands,
|
|
armor => $armor,
|
|
inventory => \@inventory,
|
|
status => \@status,
|
|
curr_map => $curr_map,
|
|
scripts => $scripts, # this will be awkward I suspect
|
|
};
|
|
%journal and $save->{journal} = \%journal;
|
|
%game_vars and $save->{game_vars} = \%game_vars;
|
|
%npc_movements and $save->{npc_movements} = \%npc_movements;
|
|
%npcs and $save->{npcs} = \%npcs;
|
|
|
|
write_text($game_config->{save_file}, to_toml($save));
|
|
move(1,1);
|
|
printw("saved");
|
|
} elsif ($input eq 'i') {
|
|
inventory_menu();
|
|
} elsif ($input eq 'j') {
|
|
journal_menu();
|
|
} elsif ($input eq '~') {
|
|
# quit game
|
|
endwin();
|
|
exit 0;
|
|
} elsif ($input eq 'q') {
|
|
$menu_mode = 0;
|
|
draw_map($curr_map);
|
|
draw_npcs();
|
|
}
|
|
next;
|
|
}
|
|
|
|
move($f_y, $f_x);
|
|
addstr($player);
|
|
move($f_y, $f_x);
|
|
refresh();
|
|
$input = getchar();
|
|
if ($input eq 'w' or $input eq KEY_UP) {
|
|
if ($f_y > 0 and is_move_ok($f_y-1, $f_x)) {
|
|
addch($f_y, $f_x, $empty);
|
|
$f_y = $f_y - 1;
|
|
}
|
|
} elsif ($input eq 's' or $input eq KEY_DOWN) {
|
|
if ($f_y < $max_y - 1 and is_move_ok($f_y+1, $f_x)) {
|
|
addch($f_y, $f_x, $empty);
|
|
$f_y = $f_y + 1;
|
|
}
|
|
} elsif ($input eq 'a' or $input eq KEY_LEFT) {
|
|
if ($f_x > 0 and is_move_ok($f_y, $f_x-1)) {
|
|
addch($f_y, $f_x, $empty);
|
|
$f_x = $f_x - 1;
|
|
}
|
|
} elsif ($input eq 'd' or $input eq KEY_RIGHT) {
|
|
if ($f_x < $max_x - 1 and is_move_ok($f_y, $f_x+1)) {
|
|
addch($f_y, $f_x, $empty);
|
|
$f_x = $f_x + 1;
|
|
}
|
|
} elsif ($input eq ' ' or $input eq KEY_ENTER) {
|
|
interact($f_y, $f_x);
|
|
next;
|
|
} elsif ($input eq 'm') {
|
|
$menu_mode = 1;
|
|
start_menu();
|
|
next;
|
|
}
|
|
else { };
|
|
engage_npcs();
|
|
move($f_y, $f_x);
|
|
}
|
|
}
|
|
|
|
# TODO
|
|
# curses website advises against this sort of thing but I don't feel like I
|
|
# have enough time to learn the proper way with windows and such
|
|
sub menu_box {
|
|
my ($starty, $startx, $endy, $endx) = (0,0,39,80); # roughly the size of the game
|
|
|
|
hline($starty, $startx, ACS_HLINE, $endx);
|
|
for ($starty+1..$endy) {
|
|
hline($_, $startx+1, ' ', $endx-1);
|
|
}
|
|
hline($endy, $startx, ACS_HLINE, $endx);
|
|
vline($starty,$startx, ACS_VLINE, $endy);
|
|
vline($starty,$endx, ACS_VLINE, $endy);
|
|
addch($starty,$startx, ACS_ULCORNER); # top left
|
|
addch($starty,$endx, ACS_URCORNER); # top right
|
|
addch($endy,$startx, ACS_LLCORNER); # bottom left
|
|
addch($endy,$endx, ACS_LRCORNER); # bottom right
|
|
}
|
|
|
|
sub start_menu {
|
|
menu_box();
|
|
my $r = 2; # row
|
|
my $lc = 6; # left column
|
|
my $rc = 50; # right column
|
|
move(++$r, $lc);
|
|
printw("Game Menu");
|
|
move(++$r, $lc);
|
|
printw("(s)ave");
|
|
move(++$r, $lc);
|
|
printw("(i)nventory");
|
|
move(++$r, $lc);
|
|
printw("(j)ournal");
|
|
move(++$r, $lc);
|
|
printw("~ to quit game");
|
|
move(++$r, $lc);
|
|
printw("q to leave menu");
|
|
|
|
$r = 2;
|
|
move(++$r, $rc);
|
|
printw("Fernando");
|
|
move(++$r, $rc);
|
|
printw("~~,=,^> $hp/$max_hp");
|
|
move(++$r, $rc);
|
|
printw("class: $class");
|
|
move(++$r, $rc);
|
|
printw("atk ($hands) $atk");
|
|
move(++$r, $rc);
|
|
printw("def ($armor) $def");
|
|
move(++$r, $rc);
|
|
if (scalar @status == 0) {
|
|
printw("Statuses: none");
|
|
} else {
|
|
printw("Statuses: ");
|
|
for my $status (@status) {
|
|
printw($status);
|
|
}
|
|
}
|
|
}
|
|
|
|
sub journal_menu {
|
|
while () {
|
|
menu_box();
|
|
my $r = 2; # row
|
|
move(1,1);
|
|
printw("Journal: q -> back, number -> more details"); # atm this means no more than 10 quests
|
|
my $i = 0;
|
|
for my $entry (sort keys %journal) {
|
|
move(++$r,6);
|
|
printw("$i> $journal{$entry}->[0]: $journal{$entry}->[2]");
|
|
$i++;
|
|
}
|
|
|
|
my $input = getchar();
|
|
if ($input eq 'q') {
|
|
start_menu();
|
|
last;
|
|
}
|
|
else {
|
|
# single digit
|
|
if ($input =~ m/^\d$/ and $input <= (scalar keys %journal) - 1 ) {
|
|
my @ids = sort keys %journal;
|
|
journal_entry_menu( $ids[$input] );
|
|
}
|
|
else {
|
|
next;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
sub journal_entry_menu {
|
|
my $id = shift;
|
|
menu_box();
|
|
my $r = 2; # row
|
|
move(1, 1);
|
|
printw("q -> back");
|
|
move(++$r, 1);
|
|
printw("$journal{$id}->[0]: $journal{$id}->[2] (given at $journal{$id}->[1])");
|
|
$r++;
|
|
for my $line (split "\n", $journal{$id}->[3]) {
|
|
move(++$r, 1);
|
|
printw($line);
|
|
}
|
|
|
|
while () {
|
|
my $je_input = getchar();
|
|
if ($je_input eq 'q') {
|
|
last;
|
|
}
|
|
}
|
|
|
|
}
|
|
|
|
sub quest {
|
|
my ($quest_giver, $where_given, $title, $description, $id) = @_;
|
|
$journal{$id} = [$quest_giver, $where_given, $title, $description];
|
|
}
|
|
|
|
sub quest_desc_add {
|
|
my ($desc, $id) = @_;
|
|
$journal{$id}->[3] .= "\n$desc";
|
|
}
|
|
|
|
sub main_menu {
|
|
# should contain basic instructions
|
|
# eg. arrow keys to move, space to interact, m for in game menu
|
|
# if saved game detected: {
|
|
# (l)oad
|
|
# }
|
|
# (n)ew
|
|
# load should read in a TOML file and replace the current global values
|
|
## no critic (io layer)
|
|
open my $fh, '<:utf8','./assets/main_menu'
|
|
or endwin() and die "$!";
|
|
move(0,0);
|
|
while (<$fh>) {
|
|
printw($_);
|
|
}
|
|
close $fh;
|
|
my $script = from_toml(read_text('./assets/main_menu.toml'));
|
|
## no critic (eval)
|
|
eval $script->{do_this};
|
|
if ($@) {
|
|
endwin();
|
|
die $@;
|
|
}
|
|
while () {
|
|
my $input = getchar();
|
|
if ($input eq 'n') {
|
|
game_loop(1);
|
|
last;
|
|
} elsif ($input eq 'l') {
|
|
my $save = from_toml(read_text($game_config->{save_file}));
|
|
$f_y = $save->{f_y};
|
|
$f_x = $save->{f_x};
|
|
$hp = $save->{hp};
|
|
$max_hp = $save->{max_hp};
|
|
$lvl = $save->{lvl};
|
|
$atk = $save->{atk};
|
|
$def = $save->{def};
|
|
$class = $save->{class};
|
|
$hands = $save->{hands};
|
|
$armor = $save->{armor};
|
|
$curr_map = $save->{curr_map};
|
|
$scripts = $save->{scripts};
|
|
%npcs = %{ $save->{npcs} } if $save->{npcs};
|
|
%npc_movements = %{ $save->{npc_movements} } if $save->{npc_movements};
|
|
%game_vars = %{ $save->{game_vars} } if $save->{game_vars};
|
|
%journal = %{ $save->{journal} } if $save->{journal};
|
|
@inventory = @{ $save->{inventory} };
|
|
$curr_map = $save->{curr_map};
|
|
undef $save;
|
|
game_loop();
|
|
last;
|
|
}
|
|
elsif ($input eq 'b') {
|
|
$hands = qq(Cool Sword);
|
|
$atk = 15;
|
|
item('hp potion');
|
|
battle('King J.J. Akke');
|
|
}
|
|
}
|
|
}
|
|
|
|
sub inventory_menu {
|
|
while() {
|
|
menu_box();
|
|
my $r = 2;
|
|
move(1,1);
|
|
printw("Inventory: q -> back, numb -> more details"); # atm this means no more than 10 items
|
|
my $i = 0;
|
|
for my $item (@inventory) {
|
|
move(++$r, 6);
|
|
printw("$i> $item");
|
|
$i++;
|
|
}
|
|
|
|
my $input = getchar();
|
|
if ($input eq 'q') {
|
|
start_menu();
|
|
last;
|
|
}
|
|
else {
|
|
if ($input =~ m/^\d$/ and $input <= (scalar @inventory) - 1 ) {
|
|
inventory_item_menu( $inventory[$input] );
|
|
}
|
|
else {
|
|
next;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
sub inventory_item_menu {
|
|
my ($id) = @_;
|
|
menu_box();
|
|
my $r = 2; #row
|
|
move(1,1);
|
|
printw('Inventory Item: q -> back, e -> equip/use ');
|
|
if ($hands eq $id or $armor eq $id) {
|
|
printw("(equiped)");
|
|
}
|
|
|
|
my ($type, $desc, $behavior) = @{ $game_items->{$id} };
|
|
move(++$r, 2);
|
|
printw("$id: $type ");
|
|
if ($type eq 'hands') {
|
|
printw("atk $behavior");
|
|
} elsif ($type eq 'armor') {
|
|
printw("def $behavior");
|
|
} elsif ($type eq 'potion') {
|
|
printw("(consumable)");
|
|
} elsif ($type eq 'key item') {
|
|
printw("(key item -> cannot be used)");
|
|
}
|
|
for my $line ( split "\n", $desc ) {
|
|
move(++$r, 2);
|
|
printw($line);
|
|
}
|
|
|
|
while () {
|
|
my $input = getchar();
|
|
if ($input eq 'q') {
|
|
last;
|
|
}
|
|
elsif ($input eq 'e') {
|
|
if ($type eq 'hands') {
|
|
$hands = $id;
|
|
$atk = $behavior;
|
|
# not happy with this below but it'll do for now
|
|
move(1,1);
|
|
printw('Inventory Item: q -> back, e -> equip (equiped)');
|
|
} elsif ($type eq 'armor') {
|
|
$armor = $id;
|
|
$def = $behavior;
|
|
move(1,1);
|
|
printw('Inventory Item: q -> back, e -> equip (equiped)');
|
|
} elsif ($type eq 'potion') {
|
|
## no critic (eval)
|
|
eval $behavior;
|
|
if ($@) {
|
|
endwin();
|
|
die $@;
|
|
}
|
|
if ($dialog_mode) {
|
|
$dialog_mode = 0;
|
|
last;
|
|
}
|
|
} elsif ($type eq 'key item') {
|
|
; # nothing
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
sub item {
|
|
my $item = shift;
|
|
exists $game_items->{$item}
|
|
and push (@inventory, $item)
|
|
or dialog('system', "Sorry player, this item\n`$item'\ndoesn't exist in the game system.");
|
|
}
|
|
|
|
sub item_remove {
|
|
my $item = shift;
|
|
exists $game_items->{$item}
|
|
or dialog('system', "Sorry player, this item \n`$item`\n cannot be remove as it doesn't exist in game system.")
|
|
and return;
|
|
|
|
my $i = 0;
|
|
for my $test (@inventory) {
|
|
if ($test eq $item) {
|
|
splice @inventory, $i, 1;
|
|
}
|
|
$i++;
|
|
}
|
|
}
|
|
|
|
sub item_has {
|
|
my $item = shift;
|
|
my $i = 0;
|
|
for my $test (@inventory) {
|
|
if ($test eq $item) {
|
|
return 1;
|
|
}
|
|
$i++;
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
|
|
sub status_add {
|
|
my $status = shift;
|
|
push @status, $status;
|
|
}
|
|
|
|
sub battle {
|
|
my $battler = shift;
|
|
exists $battlers->{$battler}
|
|
or return;
|
|
undef %battle_sess;
|
|
$battle_sess{hp} = $battlers->{$battler}{hp};
|
|
$battle_sess{battler} = $battler;
|
|
$battle_sess{atk} = $battlers->{$battler}{atk};
|
|
$battle_sess{hands} = $battlers->{$battler}{hands};
|
|
$battle_sess{def} = $battlers->{$battler}{def};
|
|
$battle_sess{armor} = $battlers->{$battler}{armor};
|
|
$battle_sess{art} = $battlers->{$battler}{art};
|
|
$battle_mode = 1;
|
|
while () {
|
|
battle_screen_update();
|
|
if ($hp < 0) {
|
|
dialog('', qq(You died.\nGame over.));
|
|
refresh();
|
|
sleep 5;
|
|
endwin();
|
|
exit;
|
|
}
|
|
elsif ($battle_sess{hp} <= 0) {
|
|
last;
|
|
}
|
|
|
|
my $input = getchar();
|
|
if ($input eq 'a') {
|
|
my $f_dmg = $atk - $battle_sess{def};
|
|
my $b_dmg = $battle_sess{atk} - $def;
|
|
$battle_sess{hp} -= $f_dmg;
|
|
$hp -= $b_dmg;
|
|
$battle_sess{last_event} = "Fernando dealt $f_dmg damage. $battler dealt $b_dmg.";
|
|
}
|
|
elsif ($input eq 'h') {
|
|
if (item_has('hp potion')) {
|
|
$hp = $max_hp;
|
|
my $b_dmg = $battle_sess{atk} - $def;
|
|
$hp -= $b_dmg;
|
|
$battle_sess{last_event} = "Fernando healed up!. $battler dealt $b_dmg.";
|
|
item_remove('hp potion');
|
|
}
|
|
else {
|
|
$battle_sess{last_event} = "No hp potions left.";
|
|
}
|
|
}
|
|
}
|
|
draw_map($curr_map);
|
|
draw_npcs();
|
|
return 1;
|
|
}
|
|
|
|
sub battle_screen_update {
|
|
menu_box();
|
|
my $r = 2; #row
|
|
my $lc = 6; # left column
|
|
my $rc = 46; # right column
|
|
move(++$r,$lc);
|
|
printw("Fernando");
|
|
move(++$r,$lc);
|
|
printw('~~,=,^>');
|
|
move(++$r,$lc);
|
|
printw("hp: $hp");
|
|
move(++$r,$lc);
|
|
printw("atk: $hands ($atk)");
|
|
move(++$r,$lc);
|
|
printw("def: $armor ($def)");
|
|
|
|
$r = 2;
|
|
move(++$r,$rc);
|
|
printw($battle_sess{battler});
|
|
move(++$r,$rc);
|
|
printw($battle_sess{art});
|
|
move(++$r,$rc);
|
|
printw("hp: $battle_sess{hp}");
|
|
move(++$r,$rc);
|
|
printw("atk: $battle_sess{hands} ($battle_sess{atk})");
|
|
move(++$r,$rc);
|
|
printw("def: $battle_sess{armor} ($battle_sess{def})");
|
|
|
|
$r = 10;
|
|
move(++$r,$lc);
|
|
printw("a -> attack, h -> use potion");
|
|
move(++$r,$lc);
|
|
move(++$r,$lc);
|
|
printw($battle_sess{last_event}) if $battle_sess{last_event};
|
|
}
|
|
|
|
sub goodend {
|
|
my ($lines) = @_;
|
|
menu_box();
|
|
my $r = 2; #row
|
|
my $lc = 2; #left column
|
|
for my $line (split "\n", $lines) {
|
|
move(++$r,$lc);
|
|
printw($line);
|
|
}
|
|
while () {
|
|
my $input = getchar();
|
|
if ($input == ' ') {
|
|
endwin();
|
|
exit;
|
|
}
|
|
}
|
|
}
|
|
|
|
main_menu();
|
|
|
|
endwin();
|