home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / MADTRB28.ZIP / MAZE.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1985-12-31  |  10.3 KB  |  308 lines
  1. PROGRAM Maze;
  2.     {adapted from "Advanced Pascal Programming Techniques"
  3.     by  Paul A. Sand
  4.     }
  5.  
  6.   CONST
  7.     MAZECOLS = 79;
  8.     MazeRows = 22;
  9.     MaxCRTCol = 80;
  10.     MaxCRTRow = 25;
  11.     (* =====  MONO attributes A ==== *)
  12. (*    NewPath = LightGray;     { Maze is "LowVideo" color.  Path out }
  13.     BadPath = black;         {  is "HighVideo".  Reject paths are  }
  14.     OutPath = white;         {  simply erased from the screen.     }
  15.     BakGrnd = black;*)
  16.     (* =====  MONO attributes B ==== *)
  17. (*    NewPath = White;         { Maze is "HighVideo" color.  Path out  }
  18.     BadPath = lightGray;     {  is reverse video -- kind of ugly.    }
  19.     OutPath = black;         {  Rejected paths are set to "LowVideo".}
  20.     BakGrnd = lightGray;*)
  21.     (* =====  COLOR attributes  ==== *)
  22.     NewPath = LightCyan;    { In color, it works fine.}
  23.     OutPath = LightBlue;
  24.     BadPath = Cyan;
  25.     BakGrnd = white;
  26.   TYPE
  27.     direction = (Up, Down, Left, Right, Out);
  28.     dirset    = set of direction;
  29.     MazeArray = ARRAY[0..MazeRows, 0..MazeCols] OF DirSet;
  30.  
  31.   VAR
  32.     Maze : mazeArray;
  33.     Got_Out : Boolean;
  34.     CH : Char;
  35.  
  36.  
  37.   function num_of(VAR D): byte;
  38.     { This function takes advantage of the fact that the elements
  39.       of a set are represented by setting BITS within the SET
  40.       variable.  If the first item is present in the set, the
  41.       first bit will be a 1.  }
  42.     var
  43.       X : byte absolute D;
  44.     begin
  45.       num_of := X;
  46.     end;
  47.  
  48.  
  49.   PROCEDURE Mark_Square(CH : Char; row, col : Integer);
  50.     BEGIN
  51.       GoToXY(col+1, row+1);
  52.       Write(CH);
  53.     END;                      { procedure Mark_Square(CH : char; row,col : integer) }
  54.  
  55.   PROCEDURE SetSquare(row, col : Integer; wp : DirSet);
  56.     BEGIN
  57.       maze[row, col] := wp;
  58.       if out in WP then
  59.         TextColor(Yellow + Blink);
  60.       CASE (Num_Of(wp) and $F) OF
  61.         0: Mark_Square(' ', row, col);
  62.         1: IF col = 0 THEN
  63.              Mark_Square('S', row, col)
  64.            ELSE
  65.              Mark_Square('=', row, col);
  66.         2: IF col = 0 THEN
  67.              Mark_Square('V', row, col)
  68.            ELSE
  69.              Mark_Square('7', row, col);
  70.         3: Mark_Square(':', row, col);
  71.         4: IF row = 0 THEN
  72.              Mark_Square('8', row, col)
  73.            ELSE
  74.              Mark_Square('>', row, col);
  75.         5: Mark_Square('<', row, col);
  76.         6: Mark_Square(';', row, col);
  77.         7: Mark_Square('9', row, col);
  78.         8: IF row = 0 THEN
  79.              Mark_Square('U', row, col)
  80.            ELSE
  81.              Mark_Square('T', row, col);
  82.         9: Mark_Square('H', row, col);
  83.        10: Mark_Square('I', row, col);
  84.        11: Mark_Square('L', row, col);
  85.        12: Mark_Square('M', row, col);
  86.        13: Mark_Square('J', row, col);
  87.        14: Mark_Square('K', row, col);
  88.        15: Mark_Square('N', row, col);
  89.       END;
  90.       TextColor(NewPath);
  91.     END;                    { procedure SetSquare() }
  92.  
  93.  
  94.  
  95.   PROCEDURE CreateMaze(VAR Maze : MazeArray);
  96.       {CREATED:  11/24/1985}
  97.     VAR
  98.       row, col : Integer;
  99.       dir : direction;
  100.  
  101.     FUNCTION randdir : direction;
  102.       BEGIN
  103.         CASE Random(4) OF
  104.           0 : randdir := Up;
  105.           1 : randdir := Down;
  106.           2 : randdir := Left;
  107.           3 : randdir := Right;
  108.         END;
  109.       END;                    { function randdir }
  110.  
  111.     FUNCTION legalPath(row, col : Integer; dir : direction) : Boolean;
  112.     (* ============================================================ *)
  113.     (* It's legal to extend the path in a given direction IFF that  *)
  114.     (* extension would NOT intersect an already-created path.       *)
  115.     (* ============================================================ *)
  116.       VAR
  117.         legal : Boolean;
  118.       BEGIN
  119.         legal := False;
  120.         CASE dir OF
  121.           Up : IF row > 0 THEN
  122.                  Legal := (maze[row-1, col] = []);
  123.           Down : IF row < MazeRows THEN
  124.                    Legal := (maze[row+1, col] = []);
  125.           Left : IF col > 0 THEN
  126.                    Legal := (maze[row, col-1] = []);
  127.           Right : IF col < MazeCols THEN
  128.                     Legal := (maze[row, col+1] = []);
  129.         END;
  130.         legalPath := legal;
  131.       END;                    { function legalPath(row,col : integer; dir : direction) }
  132.  
  133.  
  134.     PROCEDURE BuildPath(row, col : Integer; dir : direction);
  135.     (* ============================================================ *)
  136.     (*  BuildPath is first called with a starting location and a    *)
  137.     (*  direction.  If it's legal to go in that direction, it does  *)
  138.     (*  so.  Then it attempts to BuildPath from the new location    *)
  139.     (*  in each of the four directions.  Highly recursive!          *)
  140.     (* ============================================================ *)
  141.       VAR
  142.         unused : dirset;
  143.       BEGIN
  144.         CASE dir OF
  145.           Up : BEGIN
  146.                  SetSquare(row, col, Maze[row,col] + [up]);
  147.                  SetSquare(row-1, col, Maze[row-1,col] + [down]);
  148.                  row := row-1;
  149.                END;
  150.           Down : BEGIN
  151.                    SetSquare(row, col, Maze[row,col] + [down]);
  152.                    SetSquare(row+1, col, Maze[row+1,col] + [up]);
  153.                    row := row+1;
  154.                  END;
  155.           Left : BEGIN
  156.                    SetSquare(row, col, Maze[row,col] + [left] );
  157.                    SetSquare(row, col-1, Maze[row,col-1] + [right]);
  158.                    col := col-1;
  159.                  END;
  160.           Right : BEGIN
  161.                     SetSquare(row, col, Maze[row,col] + [right]);
  162.                     SetSquare(row, col+1, Maze[row,col+1] + [left]);
  163.                     col := col+1;
  164.                   END;
  165.         END;
  166.         Unused := [Up..Right];
  167.  
  168.         REPEAT
  169.           dir := randdir;
  170.           IF Dir IN unused THEN
  171.             BEGIN
  172.               unused := unused-[dir];
  173.               IF LegalPath(row, col, dir) THEN
  174.                 BuildPath(row, col, dir);    {<< note the recursive call!}
  175.             END;
  176.         UNTIL unused = [];
  177.       END;                    { procedure BuildPath(row,col : integer; dir : direction) }
  178.  
  179.  
  180.     BEGIN
  181.       FillChar(Maze, SizeOf(Maze),0);
  182.       col := random(MazeCols);
  183.       row := random(MazeRows);
  184.       REPEAT
  185.         dir := randdir
  186.       UNTIL LegalPath(row, col, dir);
  187.       buildPath(row, col, dir);
  188.       {Now make an exit -- or don't!}
  189.       case random(17) of
  190.           0..3: begin {UP exit}
  191.                   col := Random(MazeCols);
  192.                   SetSquare(0, col, Maze[0,col] + [out,up]);
  193.                 end;
  194.           4..7: begin {DOWN exit}
  195.                   col := random(MazeCols);
  196.                   SetSquare(MazeRows,col, Maze[MazeRows,col] + [out,down]);
  197.                 end;
  198.          8..11: begin {LEFT exit}
  199.                   row := random(MazeRows);
  200.                   SetSquare(row,0, Maze[row,0] + [out,left]);
  201.                 end;
  202.         12..15: begin {RIGHT exit}
  203.                   row := random(MazeRows);
  204.                   SetSquare(row,MazeCols, Maze[row,MazeCols] + [out,right]);
  205.                 end;
  206.             16:; {no exit}
  207.       end;
  208.     END;                      { procedure CreateMaze(VAR Maze : MazeArray) }
  209.  
  210.   FUNCTION SolveMaze(VAR Maze : MazeArray) : Boolean;
  211.     VAR
  212.       Solved : Boolean;
  213.       row, col : Integer;
  214.       tried : ARRAY[0..MazeRows, 0..mazeCols] OF Boolean;
  215.  
  216.     FUNCTION try(row, col : Integer; dir : direction) : Boolean;
  217.       VAR ok : Boolean;
  218.  
  219.       PROCEDURE Mark_Forward(row, col : Integer);
  220.         BEGIN
  221.           TextColor(OutPath);
  222.           SetSquare(row,col,Maze[row,col]);
  223.         END;                  { procedure Mark_Forward(row,col : integer; dir : direction) }
  224.  
  225.       PROCEDURE Mark_Backward(row, col : Integer);
  226.         BEGIN
  227.           TextColor(BadPath);
  228.           SetSquare(row,col,Maze[row,col]);
  229.         END;                  { procedure Mark_Backward(row,col : integer); }
  230.  
  231.       BEGIN
  232. (*        delay(20);*)
  233.         ok := (dir in maze[row, col]);
  234.         IF OK THEN
  235.           BEGIN
  236.             tried[row, col] := True;
  237.             CASE dir OF
  238.               Up    : row := row-1;
  239.               Down  : row := row+1;
  240.               Left  : col := col-1;
  241.               Right : col := col+1;
  242.             END;
  243.             OK :=  (NOT tried[row, col]);
  244.             IF OK THEN
  245.               BEGIN
  246.                 Mark_Forward(row, col);
  247.                 OK := out in maze[row,col];
  248.                 IF NOT OK THEN
  249.                   OK := try(row, col, Left);
  250.                 IF NOT OK THEN
  251.                   OK := try(row, col, down);
  252.                 IF NOT OK THEN
  253.                   OK := try(row, col, right);
  254.                 IF NOT OK THEN
  255.                   OK := try(row, col, up);
  256.                 IF NOT OK THEN
  257.                   Mark_Backward(row, col);
  258.               END;
  259.           END;
  260.         try := ok;
  261.       END;                    { function try(row,col:integer; dir : direction) }
  262.  
  263.  
  264.     BEGIN
  265.       FOR row := 0 TO MazeRows DO
  266.         FOR col := 0 TO MazeCols DO
  267.           tried[row, col] := False;
  268.       col := 2*(Random((MazeCols DIV 2)-1))+1;
  269.       row := 2*(Random((MazeRows DIV 2)-1))+1;
  270.       TextColor(Yellow + Blink);
  271.       SetSquare(row,col,Maze[row,col]);
  272.       TextColor(NewPath);
  273.       GoToXY(1, MaxCRTRow);
  274.       Write('Press a key to find the way out from the blinking yellow spot');
  275.       REPEAT UNTIL KeyPressed; Read(Kbd);
  276.       TextColor(OutPath);
  277.       solved := out in Maze[row,col];
  278.       if not solved then
  279.         solved := try(row, col, RIGHT);
  280.       if not solved then
  281.         solved := try(row,col,left);
  282.       if not solved then
  283.         solved := try(row,col,up);
  284.       if not solved then
  285.         solved := try(row,col,down);
  286.       SolveMaze := solved;
  287.     END;                      { function SolveMaze(VAR Maze:MazeArray) }
  288.  
  289.  
  290.   BEGIN
  291.     Randomize;
  292.     REPEAT
  293.       TextBackground(bakGrnd);
  294.       TextColor(NewPath);
  295.       ClrScr;
  296.       CreateMaze(Maze);
  297.       Got_Out := SolveMaze(Maze);
  298.       GoToXY(1, MaxCRTRow); ClrEOL;
  299.       IF Got_Out THEN Write('SUCCEEDED!  ')
  300.       ELSE Write('FAILED . . .');
  301.       Write('<C> to continue, <Q> to quit');
  302.       REPEAT UNTIL KeyPressed;
  303.       Read(Kbd, CH);
  304.     UNTIL UpCase(CH) = 'Q';
  305.     ClrScr;
  306.   END.
  307.  
  308.