Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/MADTRB38.ZIP/SNAKEPC.PAS

Pascal/Delphi Source File | 1986-02-07 | 10.0 KB | 373 lines

Program Snake;
{
    This insidious game of greed was adapted for Turbo Pascal Bruce
    McKinney.  It's source is a collection of game programs for Apple
    Pascal.  It's written for the IBM PC and compatibles, but you can
    easily adapt it for other computers by changing the constants.
    The border characters (NW thru EW) can be replaced if I's and
    dashes if you don't have access to the upper 128 graphics
    characters used on the IBM.  Same with the player characters.

    If you don't have a numeric keypad, replace the command characters
    with any diamond of characters.  For example, E,S,D,X.  Procedure
    NumsOn and NumsOff are for the IBM.  Delete them if you don't have
    an IBM or similar computer. }

Const

  PlayerChar = #2;
  SnakeChar  = #4;
  MoneyChar  = #15;
  DoorChar   = #219;

  NW = #201;
  NE = #187;
  SW = #200;
  SE = #188;
  NS = #186;
  EW = #205;

  Quit = 'q';

  UpCommand = '8';
  DownCommand = '2';
  LeftCommand = '4';
  RightCommand = '6';

  SnakeLength = 5;
  Height = 24;
  Width = 80;
  ClearScreen = 12;
  MoneyWorth = 25;

Type
  Coordinate = record
                 X : Integer;
                 Y : Integer;
               end;
  SnakeType = Array[1..SnakeLength] of Coordinate;
  Thing = (PlayerThing,SnakeThing,MoneyThing,DoorThing,EmptyThing,ScoreThing);

Var
  Snake : SnakeType;
  Player, Money, Door : Coordinate;
  Score, TopScore : Integer;
  Left, Eaten, DoneRead, PlayAgain : Boolean;
  Screen : Array[1..Width] of Array[1..Height] of Thing;
  LooksLike : Array[Thing] of Char;
  ch : char;
  ScoreFile : File of integer;

Label 1;

{$U+}

Procedure NumsOn;
begin
  mem[0:1047] := mem[0:1047] or 32;
end;

Procedure NumsOff;
begin
  mem[0:1047] := mem[0:1047] and 223;
end;

Procedure ReadScore;
begin
  Assign(ScoreFile,'Snakscor.dta');
  {$I-}Reset(ScoreFile) {$I+};
  if (IOresult <> 0) then TopScore := 1
    else Read(ScoreFile,TopScore);
  Close(ScoreFile)
end;

Procedure SaveScore;
begin
  Assign(ScoreFile,'Snakscor.dta');
  ReWrite(ScoreFile);
  Write(ScoreFile,TopScore);
  Close(ScoreFile)
end;

Procedure Border;
Var
  Col : Integer;
  Row : Integer;

begin
  gotoxy(1,1);write(nw);
  for Col := 2 to (width-1) do write(ew);write(ne);
  for Row := 2 to (Height-1) do
  begin
    gotoxy(1,row);write(ns);
    for Col := 2 to (width-1) do write(' ');write(ns);
  end;
  gotoxy(1,height);write(sw);
  for Col := 2 to (width-1) do write(ew);write(se);
end;

Procedure Instruction;
Var
  Answer : Char;

begin
  ReadScore;
  writeln('You are about to enter the mysterious land of the Serpent');
  writeln('of Kalajan.  But before you go in, consider these choices: ');
  writeln;
  writeln('1.  I''d like to meet this reptile before my adventure.');
  writeln('2.  I already know the serpent.  Just let me in.');
  writeln('3.  Reset the treasure level to the minimum amount.');
  writeln;
  write('So?  What''s it going to be? ');
  Repeat
    Read(Kbd,Answer);
  Until Answer in ['1','2','3'];
  if Answer = '3' then
  begin
    TopScore := 101;
    SaveScore;
    Writeln;writeln;
    DoneRead := True;
    Write('Now choose from the first two options above:');
    Repeat
      Read(Kbd,Answer);
    Until Answer in ['1','2'];
  end;
  if Answer = '1' then
  begin
   ClrScr;
   writeln('   Welcome to the Forest of Kalajan.  Please don''t be');
   writeln('frightened by my hideous appearance.  Within the fearsome');
   writeln('body of a serpent rests a peaceful and generous spirit.');
   writeln('If you are master of your own passions, you will have a');
   writeln('pleasant and profitable stay in this paradise. ');
   writeln('   However, the forest is not without dangers.  Soon you''ll');
   writeln('see a glittering gold coin.  There are many of them here.');
   writeln('They look like this ',MoneyChar,'.  You may take as many as you like');
   writeln('as souvenirs.  But I must warn you that greed for these coins');
   writeln('has been the downfall of many of your predecessors.  You see,');
   writeln('despite my gentle nature, a display of avarice drives me ');
   writeln('into a blind, uncontrollable rage.');
   writeln('   I''m sorry to say that during these fits I''ve sometimes');
   writeln('devoured my guests.  As a matter of fact no one has ever ');
   writeln('left here alive with more than $',TopScore-1,' worth of treasure.');
   writeln('So take a reasonable amount.  Don''t be greedy.  There''s a ');
   writeln('door that looks like this █ through which you can leave ');
   writeln('when you''re ready.');
   writeln('   So enjoy your stay.  Use the arrow keys to move through');
   writeln('the wood and view its beauty at your leisure.  Press any key');
   writeln('when you''re ready to enter the wondrous Forest of Kalajan.');
   repeat
     read(Kbd,Answer)
   Until Answer <> '';
  end;
end; {Instructions}

Procedure Initialize;
Var
  X,Y : Integer;

begin    {Initialize}
  ClrScr;
  Border;
  For X := 2 to Width-1 do
    For Y := 2 to Height-1 do
      Screen[X,Y] := EmptyThing;
  Randomize;
  LooksLike[SnakeThing] := SnakeChar;
  LooksLike[PlayerThing] := PlayerChar;
  LooksLike[MoneyThing] := MoneyChar;
  LooksLike[EmptyThing] := ' ';
  LooksLike[DoorThing] := DoorChar;
  Left := False;
  Eaten := False;
  Score := 1;
  gotoxy(1,25);write('Your treasure is $',Score - 1,'.');
  gotoxy(45,25);Write('No one has ever got more than $',TopScore - 1,'!');
end; {Initialize}

Function FreeSpot(Pos : Coordinate) : Boolean;
begin
  If (Pos.x in [2..Width-1]) and (Pos.Y in [2..Height-1]) then
     FreeSpot := Screen[Pos.X,Pos.Y] = EmptyThing
  else
     FreeSpot := False
end; {FreeSpot}

Procedure MakeSpace(var NewPos : Coordinate; ForWhat : Thing);
begin
  With NewPos do
  begin
    Repeat
      X := Random(Width-2)+2;
      Y := Random(Height-2)+2;
    Until FreeSpot(NewPos);
    Gotoxy(X,Y);
    Write(LooksLike[ForWhat]);
    Screen[X,Y] := ForWhat
  end
end; {MakeSpace}

Procedure PlaceNearby(Var Near, Coord : Coordinate);
var
  DeltaX, DeltaY : Integer;

begin {PlaceNearby}
  Repeat
    Repeat
      DeltaX := Random(3)-1;
      DeltaY := Random(3)-1;
    Until (DeltaX <> 0) or (DeltaY <> 0);
    Near.X := Coord.X + DeltaX;
    Near.Y := Coord.Y + DeltaY;
  Until (FreeSpot(Near) or ((Near.x = Player.x) and (Near.y = Player.y)));
  GotoXY(Near.X,Near.Y);
  Screen[Near.X,Near.Y] := SnakeThing;
  Write(LooksLike[SnakeThing])
end; {PlaceNearby}

Procedure Remove(Pos : Coordinate);
begin
  GotoXY(Pos.X,Pos.Y);
  Write(' ');
  Screen[Pos.X,Pos.Y] := EmptyThing
end; {Remove}

Procedure PlaceObjects;
var
  SnakeBody : Integer;

begin  {PlaceObjects}
  MakeSpace(Snake[1],SnakeThing);
  For SnakeBody := 2 to SnakeLength do
    PlaceNearby(Snake[SnakeBody],Snake[SnakeBody-1]);
  MakeSpace(Money,MoneyThing);
  MakeSpace(Door,DoorThing);
  MakeSpace(Player,PlayerThing);
  gotoxy(player.x,player.y);
end; {PlaceObjects}

Procedure TakeGold;
begin
  Score := Score + MoneyWorth;
  GotoXY(19,25);
  Write(Score-1);
  Screen[Money.X,Money.Y] := EmptyThing;
  MakeSpace(Money,MoneyThing)
end; {TakeGold}

Procedure PlayerMove;
Var
  Command : Char;
  OldPos : Coordinate;

begin
  OldPos := Player;
  Repeat
    Read(Kbd,Command);
  until Command in [UpCommand,DownCommand,LeftCommand,RightCommand,quit];
  if Command = quit then begin ClrScr;NumsOff;halt end;
  With Player do
  begin
    Case Command of
      UpCommand    : If Y > 2 then Y := Y - 1;
      DownCommand  : If Y < Height-1 then Y := Y + 1;
      LeftCommand  : If X > 2 then X := X - 1;
      RightCommand : If X < Width-1 then X := X + 1;
    end; {Case}
    If Screen[X,Y] = ScoreThing then Player := OldPos
    else
    begin
      Remove(OldPos);
      If ((Player.x = Money.x) and (player.y = money.y)) then TakeGold                  {*}
      else if ((Player.x = Door.x) and (Player.y = Door.y)) then Left := True;
      GotoXY(X,Y);
      Write(PlayerChar);
      Screen[X,Y] := PlayerThing
    end
  end
end; {PlayerMove}

Function Sign(X : Integer) : Integer;
begin
  If X = 0 then Sign := 0
  else if X > 0 then Sign := 1
  else Sign := -1
end; {Sign}

Procedure SnakeMove;
Var
  NewPos : Coordinate;
  BodyPart : Integer;

begin {PlayerMove}
  If Random(Score+1) <= 100 then PlaceNearby(NewPos,Snake[1])
  else
  begin
    NewPos.X := Snake[1].X + Sign(Player.X - Snake[1].X);
    NewPos.y := Snake[1].Y + Sign(Player.Y - Snake[1].Y);
    If (Screen[NewPos.X, NewPos.Y] = EmptyThing) or
       ((NewPos.x = Player.x) and (NewPos.y = Player.Y)) then
    begin
      GotoXY(NewPos.X,NewPos.Y);
      Write(SnakeChar);
      Screen[NewPos.X,NewPos.Y] := SnakeThing;
    end
    else
      PlaceNearby(NewPos,Snake[1]);
  end;
  Remove(Snake[SnakeLength]);
  If ((NewPos.x = Player.x) and (NewPos.y = Player.y)) then Eaten := True;
  For BodyPart := SnakeLength Downto 2 do
   begin
    Snake[BodyPart] := Snake[BodyPart - 1];
    If ((Snake[BodyPart].x = Player.x) and (Snake[BodyPart].y = Player.y))
    then Eaten := True
  end;
  Snake[1] := NewPos;
  gotoxy(Player.x,player.y)
end; {SnakeMove}

Procedure FinalScore;
begin
  If Left then
  begin
    If TopScore < Score then
    begin
      TopScore := Score;
      SaveScore;
    end;
    gotoXY(1,25);
    write('You have escaped with $',score-1,'.');
  end
  else write('The snake has eaten you!');
  gotoxy(30,25);write('                                                  ');
  gotoxy(30,25);write('Do you want to play again? ');
  repeat
    read(kbd,ch)
  until ch in ['y','n'];
  if ch = 'y' then PlayAgain := True else PlayAgain := False;
  ClrScr;
end;

begin  {Main}
  NumsOn;
  Instruction;
  1 : Initialize;
  PlaceObjects;
  Repeat
    PlayerMove;
    If not Left then SnakeMove
  Until Left or Eaten;
  GotoXY(1,Height);
  writeln;
  FinalScore;
  If PlayAgain then goto 1;
  NumsOff;
end.
keMove
  Until Left or Eaten;
  GotoXY(1,Height);
  writeln;