#!/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'