Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/MADTRB28.ZIP/MAZE1LVL.PAS

Pascal/Delphi Source File | 1986-03-23 | 14.3 KB | 554 lines

PROGRAM Maze;
    {adapted from "Advanced Pascal Programming Techniques"
    by  Paul A. Sand
    }

  CONST
    MAXMAZECOLS = 79;
    MaxMazeRows = 22;
    MaxCRTCol = 80;
    MaxCRTRow = 25;
    (* =====  MONO attributes A ==== *)
(*    NewPath = LightGray;     { Maze is "LowVideo" color.  Path out }
    BadPath = black;         {  is "HighVideo".  Reject paths are  }
    OutPath = white;         {  simply erased from the screen.     }
    BakGrnd = black;*)
    (* =====  MONO attributes B ==== *)
(*    NewPath = White;         { Maze is "HighVideo" color.  Path out  }
    BadPath = lightGray;     {  is reverse video -- kind of ugly.    }
    OutPath = black;         {  Rejected paths are set to "LowVideo".}
    BakGrnd = lightGray;*)
    (* =====  COLOR attributes  ==== *)
    NewPath = Brown;      { In color, it works fine.}
    OutPath = LightRed;
    BadPath = DarkGray;
    BakGrnd = Black;
  TYPE
    direction = (North, South, West, East, Out);
    dirset    = set of direction;
    MazeArray = ARRAY[0..MaxMazeRows, 0..MaxMazeCols] OF DirSet;
    register = record
      ax, bx, cx, dx, bp, si, ds, es, flags: Integer;
      end;

  VAR
    Maze : mazeArray;
    Got_Out : Boolean;
    CH : Char;
    MazeRows,
    MazeCols : Integer;
    DisplayPaths : Boolean;


{.cp 32}
PROCEDURE GetParameters(Var MazeRows : Integer;
                        Var MazeCols : Integer;
                    Var DisplayPaths : Boolean);
{
     Obtains the parameters for the dimensions of the current maze and
     whether or not to display the paths while creating it.
}
VAR
  InString : String[4];
  ch : Char;
  ErrorCode : Integer;

BEGIN  { GetParameters }
ClrScr;
Repeat
  Write('Number of Rows [5..23]: ');
  Readln(InString);
  Val(InString, MazeRows, ErrorCode);
Until (ErrorCode = 0) and (MazeRows in [5..23]);
MazeRows := MazeRows - 1;
Repeat
  Write('Number of Columns [5..80]: ');
  Readln(InString);
  Val(InString, MazeCols, ErrorCode);
Until (ErrorCode = 0) and (MazeCols in [5..80]);
MazeCols := MazeCols - 1;
Repeat
  Write('Display Paths? ');
  Readln(Ch);
  DisplayPaths := Ch in ['y', 'Y'];
Until ch in ['y', 'Y', 'n', 'N'];
END;  { GetParameters }


{.cp 14}
PROCEDURE RemoveCursor;
{
     Removes the distracting cursor from the screen during drawing activity.
}
VAR
  regs : register;

BEGIN  { RemoveCursor }
with regs do begin
  ax := $0100;
  cx := (32 shl 8) or 32;              { Don't know why these numbers work   }
  Intr($10, regs);                     {   but they do                       }
  end;
END;  { RemoveCursor }


{.cp 14}
PROCEDURE RestoreCursor;
{
     Returns the cursor to the screen.
}
VAR
  regs : register;

BEGIN  { RestoreCursor }
with regs do begin
  ax := $0100;
  cx := (6 shl 8) or 7;
  Intr($10, regs);
  end;
END;  { RestoreCursor }


{.cp 13}
FUNCTION num_of(VAR D): byte;
{
      This function takes advantage of the fact that the elements
      of a set are represented by setting BITS within the SET
      variable.  If the first item is present in the set, the
      first bit will be a 1.
}
VAR
  X : byte absolute D;

BEGIN  { Num_of }
num_of := X;
END;


{.cp 7}
PROCEDURE Mark_Square(CH: Char;
                     row,
                     col: Integer);
BEGIN  { Mark_Square }
GoToXY(col+1, row+1);
Write(CH);
END;           { procedure Mark_Square(CH : char; row,col : integer) }


{.cp 28}
PROCEDURE SetSquare(row,
                    col: Integer;
                     wp: DirSet);
BEGIN  { Set_Square }
maze[row, col] := wp;
if out in WP then
  TextColor(Yellow + Blink);
if (out in wp) or (DisplayPaths) then
  CASE (Num_Of(wp) and $F) OF
    0 : Mark_Square(' ', row, col);
    1 : Mark_Square(chr(223), row, col);
    2 : Mark_Square(chr(220), row, col);
    3 : Mark_Square(chr(186), row, col);
    4 : Mark_Square(chr(221), row, col);
    5 : Mark_Square(chr(188), row, col);
    6 : Mark_Square(chr(187), row, col);
    7 : Mark_Square(chr(185), row, col);
    8 : Mark_Square(chr(222), row, col);
    9 : Mark_Square(chr(200), row, col);
    10: Mark_Square(chr(201), row, col);
    11: Mark_Square(chr(204), row, col);
    12: Mark_Square(chr(205), row, col);
    13: Mark_Square(chr(202), row, col);
    14: Mark_Square(chr(203), row, col);
    15: Mark_Square(chr(206), row, col);
    END;
TextColor(NewPath);
END;                    { procedure SetSquare() }


{.pa}
PROCEDURE CreateMaze(VAR Maze : MazeArray);
      {CREATED:  11/24/1985}
VAR
     row, col : Integer;
          dir : direction;
SquareCounter : Integer;
NestLevel     : Integer;
MaxLevel      : Integer;
InitialHeap   : Integer;
MinHeap       : Integer;


FUNCTION randdir : direction;
BEGIN
CASE Random(4) OF
  0 : randdir := North;
  1 : randdir := South;
  2 : randdir := West;
  3 : randdir := East;
  END;
END;                    { function randdir }


{.cp 26}
FUNCTION legalPath(row, col : Integer; dir : direction) : Boolean;
    (* ============================================================ *)
    (* It's legal to extend the path in a given direction IFF that  *)
    (* extension would NOT intersect an already-created path.       *)
    (* ============================================================ *)
VAR
  legal : Boolean;

BEGIN  { LegalPath }
legal := False;
CASE dir OF
  North :
    IF row > 0 THEN
      Legal := (maze[row-1, col] = []);
  South :
    IF row < MazeRows THEN
      Legal := (maze[row+1, col] = []);
  West  :
    IF col > 0 THEN
      Legal := (maze[row, col-1] = []);
  East  :
    IF col < MazeCols THEN
      Legal := (maze[row, col+1] = []);
  END;
legalPath := legal;
END;                    { function legalPath(row,col : integer; dir : direction) }


{.cp 66}
PROCEDURE BuildPath(row, col : Integer; dir : direction);
    (* ============================================================ *)
    (*  BuildPath is first called with a starting location and a    *)
    (*  direction.  If it's legal to go in that direction, it does  *)
    (*  so.  Then it attempts to BuildPath from the new location    *)
    (*  in each of the four directions.  Highly recursive!          *)
    (* ============================================================ *)
VAR
  unused : dirset;
  ch     : char;

BEGIN  { BuildPath }
NestLevel := NestLevel + 1;            { Keeps track of Recursion Level      }
If NestLevel > MaxLevel then Begin
  MaxLevel := NestLevel;
  Gotoxy(28, 24);
  Write(MaxLevel:4);
  end;
Gotoxy(18, 24);
write(NestLevel:4);
CASE dir OF
  North : BEGIN
    SetSquare(row, col, Maze[row,col] + [North]);
    SetSquare(row-1, col, Maze[row-1,col] + [South]);
    row := row-1;
    END;
  South : BEGIN
    SetSquare(row, col, Maze[row,col] + [South]);
    SetSquare(row+1, col, Maze[row+1,col] + [North]);
    row := row+1;
    END;
  West : BEGIN
    SetSquare(row, col, Maze[row,col] + [West] );
    SetSquare(row, col-1, Maze[row,col-1] + [East]);
    col := col-1;
    END;
  East : BEGIN
    SetSquare(row, col, Maze[row,col] + [East]);
    SetSquare(row, col+1, Maze[row,col+1] + [West]);
    col := col+1;
    END;
  END;
Unused := [North..East];
SquareCounter := SquareCounter + 1;
If (SquareCounter Mod 10) = 0 then BEGIN
  Gotoxy(18, 25);
  Write(SquareCounter:4);
  END;

REPEAT
  dir := randdir;
  IF Dir IN unused THEN BEGIN
    unused := unused-[dir];
    IF LegalPath(row, col, dir) THEN
      BuildPath(row, col, dir);    {<< note the recursive call!}
  END;
UNTIL unused = [];
NestLevel := NestLevel - 1;
Gotoxy(18, 24);
write(NestLevel:4);
If MemAvail < MinHeap then Begin
  MinHeap := MemAvail;
  Gotoxy(75, 24);
  write(MinHeap:5);
  end;
END;                    { procedure BuildPath(row,col : integer; dir : direction) }


{.cp 45}
BEGIN  { CreateMaze }
Nestlevel := 0;
MaxLevel := 0;
Gotoxy(1, 24);
write('Recursion Level:      Max:');
Gotoxy(36, 24);
Write('Available Heap - Initial:       Min:');
Gotoxy(62, 24);
InitialHeap := MemAvail;
MinHeap := InitialHeap;
write(InitialHeap:5);
SquareCounter := 0;
FillChar(Maze, SizeOf(Maze),0);
RemoveCursor;
gotoxy(1,25);
Write('Creating maze... ', SquareCounter:4, ' of ');
Write((MazeRows+1) * (MazeCols+1):4, ' Squares defined.');
col := random(MazeCols);
row := random(MazeRows);
REPEAT
  dir := randdir
UNTIL LegalPath(row, col, dir);
buildPath(row, col, dir);
{Now make an exit -- or don't!}
case random(16) of
  0..3: begin {North exit}
    col := Random(MazeCols);
    SetSquare(0, col, Maze[0,col] + [out,North]);
    end;
  4..7: begin {South exit}
    col := random(MazeCols);
    SetSquare(MazeRows,col, Maze[MazeRows,col] + [out,South]);
    end;
  8..11: begin {West exit}
    row := random(MazeRows);
    SetSquare(row,0, Maze[row,0] + [out,West]);
    end;
  12..15: begin {East exit}
    row := random(MazeRows);
    SetSquare(row,MazeCols, Maze[row,MazeCols] + [out,East]);
    end;
(*  16:; {no exit} *)                  { Eliminated no exit option }
  end;
RestoreCursor;
END;                      { procedure CreateMaze(VAR Maze : MazeArray) }


{.pa}
FUNCTION SolveMaze(VAR Maze : MazeArray) : Boolean;

VAR
  Solved    : Boolean;
  row, col  : Integer;
  tried     : ARRAY[0..MaxMazeRows, 0..MaxmazeCols] OF Boolean;
  AutoSolve : Boolean;
  Ch        : Char;


FUNCTION try(row, col : Integer;
                  dir : direction) : Boolean;

VAR
  ok : Boolean;


PROCEDURE Mark_Forward(row, col : Integer);
BEGIN
TextColor(OutPath);
SetSquare(row,col,Maze[row,col]);
END;       { procedure Mark_Forward(row,col : integer; dir : direction) }


PROCEDURE Mark_Backward(row, col : Integer);
BEGIN
TextColor(BadPath);
SetSquare(row,col,Maze[row,col]);
END;                  { procedure Mark_Backward(row,col : integer); }

{.cp 30}
BEGIN  { Try }
(*        delay(20); *)
ok := (dir in maze[row, col]);
IF OK THEN BEGIN
  tried[row, col] := True;
  CASE dir OF
    North : row := row-1;
    South : row := row+1;
    West  : col := col-1;
    East  : col := col+1;
    END;
  OK :=  (NOT tried[row, col]);
  IF OK THEN BEGIN
    Mark_Forward(row, col);
    OK := out in maze[row,col];
    IF NOT OK THEN
      OK := try(row, col, West);
    IF NOT OK THEN
      OK := try(row, col, South);
    IF NOT OK THEN
      OK := try(row, col, East);
    IF NOT OK THEN
      OK := try(row, col, North);
    IF NOT OK THEN
      Mark_Backward(row, col);
    END;
  END;
try := ok;
END;                { function try(row,col:integer; dir : direction) }

{.pa}
FUNCTION SolvedItMyself: Boolean;
{
     Allows the more adventurous among you to solve the maze yourself
     using the arrow keys to move around.  For all you cowards, 'Q' allows
     you to quit early.
}
VAR
  Success   : Boolean;                 { Have you done it or not ?           }
  NewDir    : Direction;               { Direction selected by adventurer    }
  ScanCode  : Byte;                    { Code of keystroke                   }


{.cp 21}
FUNCTION KeyStroke: Byte;
{
     Calls DOS Interrupt 16 to get the scan code of the keystroke.  The
     returned value is used to determine the legality of the key struck and
     the direction it selects.
}

VAR
  regs : register;

BEGIN  { KeyStroke }
with regs do begin
  ax := $0000;
  Intr($16, regs);
  KeyStroke := Hi(ax);
  end;
END;  { KeyStroke }


{.cp 39}
BEGIN  { SolvedItMyself }
GoToxy(1, MaxCrtRow);
ClrEol;
Write('Use arrow keys to solve maze or "Q" to quit.');
success := false;
TextColor(Yellow);
REPEAT
  ScanCode := KeyStroke;
  If not (ScanCode in [16, 72, 75, 77, 80]) then
    write(chr(7))
  else begin
    case ScanCode of
      16 :  begin
        SolvedItMyself := false;
        exit;
        end;
      72 :  NewDir := North;
      75 :  NewDir := West;
      77 :  NewDir := East;
      80 :  NewDir := South;
      end;
    if (NewDir in Maze[row, col]) then begin
      SetSquare(row, col, Maze[row, col]);
      case NewDir of
        North : row := row - 1;
        West  : col := col - 1;
        East  : col := col + 1;
        South : row := row + 1;
        end;
      TextColor(NewPath + Blink);
      SetSquare(row, col, Maze[row, col]);
      success := out in Maze[row, col];
      end
    else
      write(chr(7));
    end;
UNTIL success;
SolvedItMyself := success;
END;  { SolvedItMyself }


{.cp 39}
BEGIN  { SolveMaze }
Displaypaths := true;
FOR row := 0 TO MazeRows DO
  FOR col := 0 TO MazeCols DO
    tried[row, col] := False;
col := 2 * (Random((MazeCols DIV 2) - 1)) + 1;
row := 2 * (Random((MazeRows DIV 2) - 1)) + 1;
TextColor(Yellow);
SetSquare(row, col, Maze[row,col]);
TextColor(NewPath);
REPEAT
  GoToXY(1, MaxCRTRow);
  ClrEol;
  Write('Print maze [P] or Continue [C]? ');
  Read(kbd, ch);
  If ch in ['p','P'] then
  begin
    Write(Lst,chr(27),chr(37),chr(1),chr(0));
    Write(Lst,chr(27),chr(65),chr(8));
    GoToXY(1,MaxCRTRow);
    ClrEol;
    Write('Press the PrtSc key and then press Return.');
    Read(kbd,ch);
    write(Lst,chr(27),chr(37),chr(0),chr(0));
    write(Lst,chr(27),Chr(50));
  end;
UNTIL (Ch in ['c', 'C']);
REPEAT
  GoToXY(1, MaxCRTRow);
  ClrEol;
  Write('Solve Manually [M] or Automatically [A]? ');
  Read(kbd, ch);
  AutoSolve := (Ch in ['a', 'A']);
UNTIL (Ch in ['a', 'A', 'm', 'M']);
write(ch);
RemoveCursor;
solved := out in Maze[row,col];
If not solved then
  if AutoSolve then begin
    GoToXY(1, MaxCRTRow);
    ClrEol;
    Write('Press a Key to begin AutoSolve Mode...');
    REPEAT UNTIL KeyPressed; Read(Kbd);
    if not solved then
      solved := try(row, col, East);
    if not solved then
      solved := try(row,col,West);
    if not solved then
      solved := try(row,col,North);
    if not solved then
      solved := try(row,col,South);
    end else
      solved := SolvedItMyself;
SolveMaze := solved;
RestoreCursor;
END;                      { function SolveMaze(VAR Maze:MazeArray) }

{.pa}
BEGIN  { Main Program }
Randomize;
REPEAT
  TextBackground(bakGrnd);
  TextColor(NewPath);
  GetParameters(MazeRows, MazeCols, DisplayPaths);
  ClrScr;
  CreateMaze(Maze);
  Got_Out := SolveMaze(Maze);
  GoToXY(1, MaxCRTRow); ClrEOL;
  IF Got_Out THEN Write('SUCCEEDED!  ')
  ELSE Write('FAILED . . .');
  Write('<C> to continue, <Q> to quit');
  REPEAT UNTIL KeyPressed;
  Read(Kbd, CH);
UNTIL UpCase(CH) = 'Q';
ClrScr;
END.