CP/M/CPM_CDROM.iso/simtel/sigm/vols000/vol021/wumpus.pas

Pascal/Delphi Source File | 1984-04-29 | 12KB | 504 lines

{*
 *  Program Title:    Wumpus
 *  Written by:        Gregory Yob
 *            More BASIC Computer Games
 *            Edited by David H. Ahl
 *
 * Translated into Pascal by Paul H. Gilliam from the
 * BASIC programs 'WUMPUS 1' and 'WUMPUS 2'
 *
 * This game will teach you how to play it.
 * Happy wumpus hunting!
 *
 *   29 June 1980    -corrected minor logic bugs.
 *   29 June 1980    -Modified for Pascal/Z v3.0
 *             Pascal/Z does not allow jumps out
 *             of Procedures/Functions [A practice
 *             I fully agree with!]
 *  Donated July, 1980
 *}
Program  Wumpus;
LABEL    99;        { Fatal error }
CONST
  default = 80;
  {---   define your screen parameters   ---}
  s_beglin =  1;    { first line }      (* ADM-3A Screen parameters *)
  s_endlin = 23;    { last  line }
  s_begcol =  1;    { first column }
  s_endcol = 80;    { last column  }

TYPE
  alfa    = STRING 10;        { just the right size }
  Dstring = STRING default;
  str0    = STRING 0;
  str255  = STRING 255;
  room     = 1 .. 20;
  tunnel   = 1 .. 3;

VAR
 arrowcount    : integer;
 bell        : char;
 cave        : array[room, tunnel] of room;
 cursorhome,        { cursor controls }
 cursorup,
 cursordown,
 cursorleft,
 cursorright,
 clearscreen,
 escape        : char;
 fatal_error    : boolean;
 i, j        : integer;    { global indexers }
 initlocate    : array[1..6] of room;

Procedure KEYIN(VAR cix: char); external;
(*---Direct Keyboard input of a single char---*)

Function RANDOM(limit: integer): real; external;
(*---returns a real number from 0.0 to limit---*)

Function length(x: str255): integer; external;

Procedure gotoxy( col, row : integer );
(*         X-coord, Y-coord    *)
begin
  WRITE( chr(27), '=', chr(row+32), chr(col+32))
end;

Procedure terminit;
begin
 bell := chr(7);
 escape        := chr(27);
 cursorhome := chr(30);
 cursorup   := chr(11);;
 cursordown := chr(10);
 cursorleft := chr(8);
 cursorright := chr(12);
 clearscreen := chr(26);    { ASCII control-Z }
end{of terminit};

Procedure CLEAR;
begin
  Write(clearscreen);
end;

Procedure clearline( row: integer );
begin
  gotoxy( s_begcol, row);
  WRITE( ' ':(s_endcol-s_begcol+1) );
  gotoxy( s_begcol, row);
end;

Function  randroom : room; { 1..20 }
begin
  randroom := trunc(random(20)) + 1
end  { randroom };

Function  randtunnel : tunnel; { 1..3 }
begin
 randtunnel := trunc(random(3)) + 1
end  { randtunnel };

Function  wumpmove : integer;
var    i : integer;
begin
  i := trunc(random(4)) + 1;
  If i > 3 then
    wumpmove := -1
  Else
    wumpmove := i;
end  { wumpmove };

Function QUIRY(sign: Dstring): boolean;
var    ch: char;
begin
  writeln;
  Repeat
    write(sign);
    KEYIN(ch);writeln(ch);
    writeln;
  Until ch IN ['Y', 'y', 'N', 'n'];
  QUIRY := ch in ['n', 'N'];
end;

Procedure Instruct;
{*
 *   Attempts to read in an external file to instruct the player
 *   as to how to play the game.
 *   Instruct will pause for console input whenever it finds the
 *   string "$pause" in the first position of a line in the line.
 *}
var    line : Dstring;
    Ifile : text;
    ch : char;

    Procedure ShowInstructions;
    begin
      CLEAR;
      Readln(Ifile,line);
      while  not eof(Ifile) do
        begin
          If (line = '$pause') or (line = '$PAUSE') then
        begin
        Clearline(s_endlin);
        write('Press <sp> to continue.');KEYIN(ch);
        CLEAR;
        end
          Else
        writeln(line);
          readln(Ifile,line);
       end;{ While }
    End{ShowInstructions};

begin  { instruct }
  CLEAR;
  write('Do you want instructions on how to play? ');
  KEYIN(ch);Writeln(ch);
  writeln;
  If (ch='y') or (ch='Y') then
    begin
      RESET('WUMPUS.DOC',Ifile);
      If not EOF(Ifile) then
    ShowInstructions
      Else
    begin
    writeln;
    writeln('Sorry,  instructions not availiable yet.');
    end;
    end
End{of instruct};

Procedure  getacave;
LABEL    9;{ABORT}
var
  i : room;    { 1..20 }
  j : tunnel;    { 1..3 }
  k : integer;
  CAVENAME : STRING 5;
  LINE : Dstring;
  cavein : text;
  ch : char;
begin
 cavename := 'CAVE ';
 Repeat
   Writeln;
   write(bell, 'Enter cave #(0-5) ');
   KEYIN(ch);Writeln(ch);
 Until  ch in ['0'..'5'];
 cavename[5] := ch;
 (* OPEN file "cavename" for Read assign cavein *)
 RESET(cavename,cavein);
 fatal_error := EOF(cavein);
 If fatal_error then {ABORT}
   begin
     writeln;
     writeln('Fatal error - file not found');
     {ABORT}goto 9;
   end;
 writeln('reading ',cavename);
 readln(cavein, line);
 for  i := 1 to 20 do
   for j := 1 to 3 do read(cavein,cave[i,j]);
  writeln;
  writeln('You are in ',line);
  writeln;
9:{ABORT}
End{ of getacave }{ CLOSE(cavein) };

Procedure  initsetup;
var    locatesunique : boolean;
    i, j : integer;
begin
 Repeat
   for  i := 1 to 6 do initlocate[i] := randroom;
   locatesunique := true;
   i := 1;
   while  locatesunique and (i <= 6) do
     begin
     j := 1;
     while  locatesunique and (j <= 6) do
       begin
       If (initlocate[i] = initlocate[j]) and (j <> i) then
     locatesunique := false
       Else
     j := j + 1;
       end;
     i := i + 1
     end
 Until  locatesunique
End  { initsetup };

Procedure  HuntTheWumpus;
CONST    Title = 'Hunt the Wumpus';
TYPE    long = real;
VAR    i    : integer;
    game    : (inprogress, youlost, youwon);
    locate    : array[1..6] of room;

    Procedure  warnings;
    var    location, i, j: integer;
    begin
      writeln;
      location := locate[1];
      for  i := 2 to 6 do
        begin
        for  j := 1 to 3 do
          begin
          If cave[location,j] = locate[i] then
         case  i  of
              2:  writeln('I smell a Wumpus!');
           3, 4:  writeln('I feel a draft!');
           5, 6:  writeln('Bats nearby!');
         End{case};
          end{ for j };
        end{ for i };
      writeln('You are in Room ',location:2);
      write('Tunnels lead to ');
      for  i := 1 to 3 do write(cave[location,i]:3);
      writeln;
    End  { warnings };

    Function  WantToShoot : boolean;
    LABEL 4;{EXIT}
    var    ch : char;
    begin
      Repeat
        writeln;
        write('Shoot or move (s-m) <esc>');
        KEYIN(ch);writeln;
        If ch = escape then
          begin
          game := youlost;
          { EXIT(HuntTheWumpus) } goto 4;
          end;
        If ch = 'l' then
          begin
          write('you = ',locate[1]:3, ' ':8);
          write(' wumpus = ',locate[2]:3);
          writeln(' pits = ',locate[3]:3,',',locate[4]:3);
          writeln(' bats = ',locate[5]:3,',',locate[6]:3);
          writeln
          end;
      Until  ch in ['m', 'M', 's', 'S'];
      WantToShoot := ch in ['S', 's'];
    4:{EXIT}
    End  { WantToShoot };

    Procedure  movewumpus;
    var    i : integer;
    begin
      i := wumpmove;
      If i > 0 then  locate[2] := cave[locate[2],i];
      If locate[1] = locate[2] then
        begin
        writeln('Tsk Tsk Tsk - Wumpus got you!');
        game := youlost
        end;
    End  { movewumpus };

    Function  lint(    s : alfa;
               var l : long) : integer;
    LABEL 3;{EXIT}
    var
      i, j : integer;
      negitive : boolean;
      ch : char;
    begin
      j := 0;
      l := 0;
      lint := -1;
      negitive := false;
      for  i := 1 to length(s) do
        begin
        ch := s[i];
        If ch in ['0'..'9'] then
          begin
          j := j + 1;
          If j > 36 then
            begin lint := -2; {EXIT(lint)}goto 3 end;
          l := l * 10 + (ord(ch) - ord('0'))
          end
        Else
          If ch = '-' then
        begin If negitive then {EXIT(lint)}goto 3 end
          Else  {EXIT(lint)}goto 3;
        end;{ FOR }
      If l > maxint then
        lint := j
      Else
        lint := 0;
      If negitive then  l := -l;
      3:{EXIT}
    end{lint};

Procedure doshot;
var
  path : array[1..5] of integer;
  rooms, i, j, arrow : integer;
  roomok, targethit : boolean;
  l : long;
  ans : alfa;
begin
 { program the arrow }
  Repeat
    write('No. of rooms (1-5) ');
    readln(ans);
    i := lint(ans, l);
    rooms := trunc(l);
  Until  (i = 0) and (rooms >= 1) and (rooms <= 5);
  for  i := 1 to rooms do
    begin
    Repeat
      roomok := true;
      write('Room # ');
      readln(ans);
      j := lint(ans, l);
      roomok := (j = 0) and (l > 0) and (l < 21);
      path[i] := trunc(l);
      If i > 2 then
    If path[i] = path[i-2] then
      begin
      writeln('Arrows aren''t that crooked - try another room');
      roomok := false;
      end;
      If not roomok then  write(bell);
    Until  roomok;
    end;
    { shoot the arrow }
  arrowcount := arrowcount - 1;
  I := 1;
  arrow := locate[1];
  Repeat
    roomok := false;
    for  j := 1 to 3 do
      If cave[arrow,j] = path[i] then  roomok := true;
    If roomok then
      arrow := path[i]
    Else
      arrow := randroom;
    If arrow = locate[1] then
    begin
    writeln('OUCH! Arrow got YOU!');
    game := youlost
    end
    Else
      If arrow = locate[2] then
    begin
    writeln('Aha! You got the Wumpus!');
    game := youwon
    end;
    i := i + 1;
  Until  (i > rooms) or (game <> inprogress);
  Case game of
    inprogress:    begin
        If arrowcount=0 then
          begin
          writeln('Out of arrows!!');
          game := youlost;
          end
        Else
          writeln('missed');
        MoveWumpus;
        end;
   youwon:    {dummy};
   youlost:    MoveWumpus
   end{of Case};
end  { doshot };

Procedure domove;
var
  room, i, location : integer;
  roomok, movefinished : boolean;
  l : long;
  ans : alfa;
begin
  location := locate[1];
  Repeat
    write('Where to? ');
    readln(ans);
    roomok := false;
    i := lint(ans, l);
    room := trunc(l);
    If i = 0 then
      begin
      for  i := 1 to 3 do
    If room = cave[location,i] then  roomok := true;
      If room = location then  roomok := true;
      end;{ If i=0 }
    If not roomok then  writeln('Not possible');
  Until  roomok;
  location := room;
  Repeat
    locate[1] := location;
    movefinished := true;
    If location = locate[2] then
      begin
      writeln('... OOPS!  Bumped a Wumpus');
      movewumpus
      end;
    If game = inprogress then
      If (location = locate[3]) or (location = locate[4]) then
    begin
    writeln('YYYIIEEEE . . . Fell in a pit!');
    game := youlost
    end
      Else
    If (location = locate[5]) or (location = locate[6]) then
      begin
      writeln('ZAP -- Super bat snatch! Elsewhereville for you!');
      movefinished := false;
      location := randroom
      end;
  Until  movefinished;
end  { do move };

begin { HuntTheWumpus }
  arrowcount := 5;
  for  i := 1 to 6 do locate[i] := initlocate[i];
  game := inprogress;
  writeln;
  writeln(Title);
  writeln;
{}  REPEAT
      warnings;
      Case WantToShoot of
    TRUE:    If game<>youlost then Doshot;
    FALSE:    If game<>youlost then DoMove
      End{of case};
{}  Until game<>inprogress;
  If game = youwon then
    writeln('Hee Hee Hee - The Wumpus''ll getcha next time.')
  Else
    writeln('Ha Ha Ha - You lose!');
end{ huntthewumpus };

Function newsetup: boolean;
begin
  newsetup := QUIRY('Same setup (y-n) ');
end;

Function newcave: boolean;
begin
  newcave := QUIRY('Same cave (y-n) ');
end;

Function  alldone : boolean;
begin
  alldone := Quiry('Play again (y-n) ');
end;

begin{ Main Program Wumpus }
  terminit;
  Instruct;
  Repeat
     getacave;
     If fatal_error then{ABORT}goto 99;
     Repeat
       initsetup;
       Repeat
     HuntTheWumpus;
       Until  newsetup;
     Until  newcave
  Until  alldone;
99:{ABORT}
End{of Wumpus}.