Spork -- nethack or zork mode Curses game

Here's my latest piece of insanity -- a Curses-based game that lets one wander through the dread dungeons of Spork in either a first-person, zork-like mode ("You are in a room...") or in top-down, roguelike mode (that funny @-sign moves around). It's still got a tiny bug or two, but I'm too lazy to track it down.

As stated above, the game needs the Curses library off of CPAN in order to work. The worst part of this, by far, is the map-generating algorithm, which generates maps "on the fly." It's also rather kludgy, partially to allow zork-like mode to work, and partially because I planned to add rooms (it's just hallways right now).

There isn't any help feature, so I'll just list the keys here:

Arrow keys move the guy around. Note that Curses doesn't like the number pad on most terminals.
` (backtick) toggles between first-person (descriptive), and overhead (maplike). This was sortof the main point of this exercise.
m generates a new level.
c turns on the cheat mode, if you'd like to see the level and live without fear of the grue..
q quits.

So prepare for hours of fun for the whole family! You might want to watch out for that grue, though..

Update: I took out the v5.6.0 dependant parts, replacing "our" variables by globals.

#!/usr/bin/perl -w
use strict;
use Curses;#, foiled again!
my $VERSION = (qw$Revision: 1.5 $)[-1];

use constant ROGUELIKE => 0;
use constant ZORKLIKE  => 1;
use constant STATSIZE  => 10;
use vars qw/$or %edges @HALL_DESCS/;
my $resize_executable = "/usr/X11R6/bin/resize";

$SIG{__WARN__} = sub{die shift;};

#create and display screen
use vars qw/%display/;
%display  = &setup(ROGUELIKE);
$SIG{WINCH} = sub {%display = &setup($display{type});&update;$display{
+main}->refresh;$display{stats}->refresh;};
#create level
$or = &create_level;
my %player = (location=>[20,20],cheat=>0);
my $key = '';
&update;
do {
  $display{stats}->refresh; $display{main}->refresh;
  $key = $display{main}->getch;
  $display{stats}->clrtoeol(1,0);
  if ($key eq '`') {
    if ($display{type} == ZORKLIKE) {
      $display{main}->addstr("Going to roguelike..\n");
      %display = &setup(ROGUELIKE);
      $display{main}->addstr("Now in roguelike mode..\n");
    } else {
      $display{main}->addstr("Going to Zork-like..\n");
      %display = &setup(ZORKLIKE);
      $display{main}->addstr("Now in Zork-like mode..\n");
    }
    &update;
  } elsif ($key eq 'm') {
    $or = &create_level;
    $player{location} = [20,20];
    $player{seen} = {};
    &update;
  } elsif ($key eq 'c') {
    $player{cheat} = 1 - $player{cheat};
    &update;
  } elsif (($key eq 259 or $key eq 274) and &can_go(&occupied(@{$playe
+r{location}}),&occupied($player{location}[0],$player{location}[1]-1))
+) {
    $player{location}[1]--; &update;
  } elsif (($key eq 258 or $key eq 350) and &can_go(&occupied(@{$playe
+r{location}}),&occupied($player{location}[0],$player{location}[1]+1))
+) {
    $player{location}[1]++; &update;
  } elsif (($key eq 260 or $key eq 269) and &can_go(&occupied(@{$playe
+r{location}}),&occupied($player{location}[0]-1,$player{location}[1]))
+) {
    $player{location}[0]--; &update;
  } elsif (($key eq 261 or $key eq 271) and &can_go(&occupied(@{$playe
+r{location}}),&occupied($player{location}[0]+1,$player{location}[1]))
+) {
    $player{location}[0]++; &update;
  } elsif ($key =~ /\d+/ and $key >= 258 and $key <= 350){
    $display{stats}->addstr(1,0,"You can't go that way!");
  } elsif ($key ne -1) {
    $display{stats}->addstr(1,0,"I don't understand that! (What does '
+$key' mean?)");
  }
  if (occupied(@{$player{location}})->{description} =~ /\bgrue\b/i and
+ rand(1) < 0.1) {
    $display{stats}->clrtoeol(9,0);
    if ($player{cheat}) {
      $display{stats}->addstr(9,0,"You were eaten by a grue; strangely
+, this doesn't affect you.");
      $display{stats}->refresh;
    } else {
      $display{stats}->addstr(9,0,"You were eaten by a grue.");
      $display{stats}->refresh;
      endwin;
      exit;
    }
  }
} until lc($key) eq 'q';

END {
  endwin;
}

sub can_go {
  my ($s,$e) = @_;
  return 0 if ref $s ne "HASH" or ref $e ne "HASH";
  return 1 if $s == $e;
  return 1 if grep {$_ == $e->{id} and @{$s->{exits}{$_}} == @{$player
+{location}}} keys %{$s->{exits}};
  return 0;
}

sub update {
  for my $q ($player{location}[0]-1..$player{location}[0]+1) {
    for my $r ($player{location}[1]-1..$player{location}[1]+1) {
      $player{seen}{"$q,$r"}=1;
    }
  }
  if ($display{type} == ROGUELIKE) {
    $display{main}->clrtobot(1,0);
    for my $room (@{$or->{contents}}) {
      for my $x ($room->{location}[0][0]..$room->{location}[1][0]) {
    for my $y ($room->{location}[0][1]..$room->{location}[1][1]) {
      $display{main}->addstr($y+1,$x+1,'#') if $player{cheat} or defin
+ed $player{seen}{"$x,$y"};
    }
      }
    }
    $display{main}->addstr($player{location}[1]+1,$player{location}[0]
++1,'@');
    $display{stats}->clrtobot(3,0);
    $display{stats}->addstr(3,0,&occupied(@{$player{location}})->{desc
+ription});
    $display{main}->move(1,0);
  } else {
    my (@exits,@cont,%dir); @dir{"0-1","01","10","-10"} = qw/North Sou
+th East West/;
    for ([0,-1],[0,1],[1,0],[-1,0]) {
      my ($s,$e) = (&occupied(@{$player{location}}),&occupied($player{
+location}[0]+$_->[0],$player{location}[1]+$_->[1]));
      if ($s == $e) {
    push @cont,$dir{$_->[0].$_->[1]};
      } elsif (&can_go($s,$e)) {
    push @exits,$dir{$_->[0].$_->[1]}
      }
    }
    $display{main}->addstr("\n".&occupied(@{$player{location}})->{desc
+ription}."\n");
    $display{main}->addstr("The hallway continues to the ".join(' and 
+',@cont).".\n") if @cont;
    $display{main}->addstr("Exits: @exits\n") if @exits;
  }
}

sub setup {
  my $type = shift @_;
  if (defined $display{type}) {
    $display{stats}->delwin;
    $display{main}->delwin;
    endwin;
  }
  for (qx"$resize_executable") {
    next unless /^(\w+)=(.*);/;
    $ENV{$1} = $2;
  }
  refresh if defined $display{type};
  my $main = new Curses $ENV{LINES}-(STATSIZE+1), $ENV{COLUMNS}, 0, 0;
  $main->clear;
  $main->leaveok;
  $main->keypad(1);
  noecho;
  if ($type == ZORKLIKE) {
    $main->idlok;
    $main->scrollok(1);
    $main->setscrreg(1, $ENV{LINES}-(STATSIZE+2));
  }
  $main->addstr(&center(' Spork! ',fill=>'*'));

  my $stats= new Curses STATSIZE, $ENV{COLUMNS}, $ENV{LINES}-(STATSIZE
++1), 0 or die "Can't make stats window!";
  $stats->clear;
  $stats->leaveok;
  $stats->addstr(&center(' Info ',fill=>'-'));
  $stats->addstr(0,5,$type==ZORKLIKE?"(Zork )":"(Rogue)");

  return (type=>$type,stats=>$stats,main=>$main);
}

sub center {
  my %args = (fill=>' ',width=>$ENV{COLUMNS},'string',@_?@_:'');
  $args{string} .= $args{fill} unless ($args{width}-length($args{strin
+g})) % 2 == 0;
  $args{string} = "$args{fill}$args{string}$args{fill}" while length $
+args{string} < $args{width};
  return $args{string};
}

sub create_level {
  $display{main}->clrtobot(1,0);
  $or = {contents=>[],
             type=>"room",
         location=>[[0,0],[40,40]],
        };
  @edges{qw/01 10 0-1 -10 void/} = ([],[],[],[],[]);
  make_hallway(20,20,1,0);
  while (@{$or->{contents}} < 40) {
    my @directions = grep {@{$edges{$_}} and /\d/} keys %edges;
    my ($dx,$dy) = $directions[rand @directions] =~ /(-?\d)(-?\d)/;
    my (@edge) = @{$edges{"$dx$dy"}[rand @{$edges{"$dx$dy"}}]};

    make_hallway($edge[0],$edge[1],$dx,$dy);
    %edges = &del_dups;
  }
  $or->{edges} = {%edges};
  return $or;
}

sub del_dups {
  my %used;
  for my $edge (keys %edges) {
    for (@{$edges{$edge}}) {
      $used{$_->[0].",".$_->[1]} += $edge=~/\d/?1:2;

      if ($edge =~ /\d/ and ref (my $exit_to = &occupied($_->[0],$_->[
+1])) eq "HASH") {
    $or->{contents}[$exit_to->{id}]{'exits'}{$_->[2]} = [$_->[0],$_->[
+1]];
      }
    }
  }
  for (keys %used) {
    if (my $target = &occupied(split/,/)) {
      $used{$_}++;
    }
  }
  for (keys %edges) {
    next unless /\d/;
    $edges{$_} = [grep {$used{$_->[0].",".$_->[1]} == 1} @{$edges{$_}}
+]
  }
  $edges{void} = [map {[split/,/]} grep {$used{$_} > 1} keys %used];
  return %edges;
}

sub occupied {
  my ($x,$y) = @_;
  return -1 if $x < $or->{location}[0][0] or $x > $or->{location}[1][0
+];  # X max and min from OverRoom
  return -1 if $y < $or->{location}[0][1] or $y > $or->{location}[1][1
+];  # Y max and min from OverRoom
  for (@{$or->{contents}}) {
    return $_ if ($x >= $_->{location}[0][0] and $x <= $_->{location}[
+1][0])
             and ($y >= $_->{location}[0][1] and $y <= $_->{location}[
+1][1]);
  }
  return 0;
}

sub edge {
  my ($x,$y) = @_;
  for (keys %edges) {
    return 1 if grep {$_->[0] == $x and $_->[1] == $y} @{$edges{$_}};
  }
  return 0;
}

sub make_hallway {
  my ($x,$y,$dx,$dy) = @_;
  my ($ml,$l,$ec) = (int rand(4)+4,0,0);
  $l++ while (!occupied($x+$l*$dx,$y+$l*$dy) and ($l <= 1 or !edge($x+
+($l-1)*$dx,$y+($l-1)*$dy)) and $l < $ml);
  my $ex = $x+($l-1)*$dx; my $ey = $y+($l-1)*$dy;
  return undef if $l < 3;
  my $id = @{$or->{contents}};
  ($x,$ex) = ($ex,$x) if ($ex < $x);
  ($y,$ey) = ($ey,$y) if ($ey < $y);
  push @{$or->{contents}}, {type=>"hallway",
                location=>[[$x,$y],[$ex,$ey]],
                exits=>{},
                id=>$id,
                description=>$HALL_DESCS[rand @HALL_DESCS]
               };
  for my $d ($x..$ex) {
    push @{$edges{'01'}}, [$d,$ey+1,$id];
    push @{$edges{'0-1'}},[$d,$y-1,$id];
  }
  for my $d ($y..$ey) {
    push @{$edges{'10'}}, [$ex+1,$d,$id];
    push @{$edges{'-10'}},[$x-1,$d,$id];
  }
  return $id;
}

BEGIN {
  @HALL_DESCS   =   ("  You are in a poorly-lit hallway.  Dim light is
+ given off by\n".
             "widely-spaced sputtering torches.  The gloom seems to pr
+ess in\n".
             "on you.",

             "  You stand in a cramped sewer pipe.  Dim light filters 
+down\n".
             "from overhead grates, shining off of substances which yo
+u would\n".
             "rather not recognize.  The smell is oppressive.",

             "  The rough-hewn walls and low ceiling signal that you h
+ave\n".
             "entered a section of abandoned mineshaft.  The wind whis
+tles\n".
             "eerily past your head, filling the tunnel with a low moa
+ning.",

             "  The proud race that carved these tunnels knew its ston
+emasonry;\n".
             "the walls are square and well-decorated with elaborate c
+arvings,\n".
             "while concealing the incredible strength of the stone.",

             "  It is dark.  You move carefully to avoid being eaten b
+y a grue.",

             "  You stride through hallways whose walls crawl with str
+ange green\n".
             "scribbles.  You have a strange urge to wear sunglasses w
+hile\n".
             "inside and request 'guns, lots of guns.'",

             "  The passageway is awash in cheese.  You are forced to 
+swim\n".
             "through it to get past.  As you do so, you spy an elusiv
+e babelfish\n".
             "between a wheel of Brie and some Cheddar.",

             "  You are in a maze of twisty passages, all alike.",

             "  The hallway is lined with glowing images of sporks.  T
+hey brighten\n".
             "as you approach and dim after you have passed.  You are 
+in awe of\n".
             "the intensity of the sporkishness of this place.",

             "  The passage is lined with mumbling boulders.  They sho
+ut\n".
             "obscenities at you as you step on them.",

             "  You're wandering through a maze of manpages.  All of t
+hem ignore\n".
             "you, assume you already know what they tell you, don't p
+rovide good\n".
             "instructions, and have bad breath.  Curse you, curses!",
            );
}
[download]

perl -e 'print "I love $^X$\"$]!$/"#$&V"+@( NO CARRIER'

Comment on Spork -- nethack or zork mode Curses game Download Code

Back to Cool Uses for Perl