#!/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();