home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / mbug / mbug165.arc / MAZE.PAS < prev    next >
Pascal/Delphi Source File  |  1979-12-31  |  7KB  |  263 lines
  1. program Maze;
  2.  
  3. {
  4.   This program origionally appeared in the book by: Paul A. Sand called
  5.   Advanced PASCAL Programming Techniques. It was entered and modified for
  6.   IBM PC version of Turbo Pascal 3.0 by: Felix M. Daske.
  7.  
  8.   The code was modified for the Microbee by Alan Laughton on 5/5/91.
  9. }
  10.  
  11. {$A-}
  12.  
  13. const
  14.   MazeCols  = 65;
  15.   MazeRows  = 22;
  16.   MaxCrtCol = 66;
  17.   MaxCrtRow = 23;
  18.   Xindent   = 1;
  19.   Yindent   = 1;
  20.  
  21. type
  22.   MazeSquare = (wall, path);
  23.   MazeArray  = array [0..MazeRows, 0..MazeCols] of MazeSquare;
  24.   CrtCommand = (home, clear, eraseol, eraseos, up, down, left, right, beep);
  25.   Direction  = up..right;
  26.  
  27. var
  28.   Maze: Mazearray;
  29.   Won : boolean;
  30.   ch  : char;
  31.  
  32. procedure dispsquare(val: Integer; row, col: integer);
  33. begin
  34.   gotoxy(col + Xindent, row + Yindent);
  35.   write(chr(val));
  36. end;
  37.  
  38. procedure SetSquare(row, col : integer; val : MazeSquare);
  39. begin
  40.   maze[row, col] := val;
  41.   case val of
  42.     path  : dispsquare( 32, row, col);
  43.     wall  : dispsquare(160, row, col);
  44.   end;
  45. end;
  46.  
  47. function rnd (low, high: Integer): integer;
  48. begin
  49.   rnd := low + random(high - low + 1);
  50. end;
  51.  
  52. function randdir: direction;
  53. begin
  54.   case rnd(1, 4) of
  55.     1 : randdir := up;
  56.     2 : randdir := down;
  57.     3 : randdir := left;
  58.     4 : randdir := right;
  59.   end;
  60. end;
  61.  
  62. function legalpath(row, col: integer; dir: direction): boolean;
  63. var
  64.   legal : boolean;
  65. begin
  66.   legal := false;
  67.   case dir of
  68.     up    : if row > 2 then
  69.               legal := (maze[row - 2, col] = wall);
  70.     down  : if row < MazeRows - 2 then
  71.               legal := (maze[row + 2, col] = wall);
  72.     left  : if col > 2 then
  73.               legal := (maze[row, col - 2] = wall);
  74.     right : if col < MazeCols - 2 then
  75.               legal := (maze[row, col + 2] = wall);
  76.   end;
  77.   legalpath := legal;
  78. end;
  79.  
  80. procedure buildpath(row, col: integer; dir : direction);
  81. var
  82.   unused: set of direction;
  83. begin
  84.   case dir of
  85.     up   : begin
  86.              setsquare(row - 1, col, path);
  87.              setsquare(row - 2, col, path);
  88.              row := row -2;
  89.            end;
  90.     down : begin
  91.              setsquare(row + 1, col, path);
  92.              setsquare(row + 2, col, path);
  93.              row := row + 2;
  94.            end;
  95.     left : begin
  96.              setsquare(row, col - 1, path);
  97.              setsquare(row, col - 2, path);
  98.              col := col - 2;
  99.            end;
  100.     right: begin
  101.              setsquare(row, col + 1, path);
  102.              setsquare(row, col + 2, path);
  103.              col := col + 2;
  104.            end;
  105.    end;
  106. unused := [up..right];
  107. repeat
  108.   dir := randdir;
  109.   if dir in unused then
  110.     begin
  111.       unused := unused - [dir];
  112.       if legalpath(row, col, dir) then
  113.         buildpath(row, col, dir);
  114.     end;
  115.   until unused = [];
  116. end;
  117.  
  118. procedure createmaze(var maze: mazearray);
  119. var
  120.   row, col : integer;
  121.   dir      : direction;
  122. begin
  123.   for row := 0 to MazeRows do
  124.     for col := 0 to MazeCols do
  125.       SetSquare(row, col, wall);
  126.   gotoxy(67,23); write(' ');
  127.   row   := 2 * rnd(0,trunc(MazeRows / 2 - 1)) + 1;
  128.   col   := 2 * rnd(0,trunc(MazeCols / 2 - 1)) + 1;
  129.   SetSquare(row, col, path);
  130.   repeat
  131.     dir := randdir;
  132.   until legalpath(row, col, dir);
  133.   buildpath(row, col, dir);
  134.   col   := 2 * rnd(0,trunc(MazeCols / 2 - 1)) + 1;
  135.   SetSquare(0, col, path);
  136.   gotoxy(col+2,1); lowvideo; write('IN'); normvideo;
  137.   col   := 2 * rnd(0,trunc(MazeCols / 2 - 1)) + 1;
  138.   SetSquare(MazeRows, col, path);
  139.   gotoxy(col+2,MazeRows+1); lowvideo; write('OUT'); normvideo;
  140. end;
  141.  
  142. function solvemaze(var  maze: mazearray) : boolean;
  143. var
  144.   solved : boolean;
  145.   row, col : integer;
  146.   tried: array [0..mazerows, 0..mazecols] of boolean;
  147.  
  148. function try(row, col: integer; dir: direction) : boolean;
  149. var
  150.   ok : boolean;
  151.  
  152. procedure showmove(row, col: integer; dir : direction);
  153. begin
  154.   case dir of
  155.     up    : dispsquare(111, row, col);
  156.     down  : dispsquare(111, row, col);
  157.     right : dispsquare(111, row, col);
  158.     left  : dispsquare(111, row, col);
  159.   end;
  160. end;
  161.  
  162. procedure erasemove(row, col : integer);
  163.   begin
  164.     dispsquare(32, row, col);
  165.   end;
  166.  
  167. begin  { try }
  168.   ok := (maze[row, col] = path);
  169.   if ok then
  170.     begin
  171.       tried[row, col] := true;
  172.       case dir of
  173.         up   : row := row - 1;
  174.         down : row := row + 1;
  175.         left : col := col - 1;
  176.         right : col := col + 1;
  177.     end;
  178.     ok := (maze[row, col] = path) and not tried[row, col];
  179.     if ok then
  180.       begin
  181.         showmove(row, col, dir);
  182.         ok := (row <= 0) or (row >= mazerows) or
  183.               (col <= 0) or (col >= mazecols);
  184.         if not ok then
  185.           ok := try(row, col, left);
  186.         if not ok then
  187.           ok := try(row, col, down);
  188.         if not ok then
  189.           ok := try(row, col, right);
  190.         if not ok then
  191.           ok := try(row, col, up);
  192.         if not ok then  { no solution from this point }
  193.           erasemove(row, col);
  194.       end;
  195.   end;
  196.   try := ok;
  197. end;
  198.  
  199. begin  { solvemaze }
  200.   for row := 0 to mazerows do
  201.     for col := 0 to mazecols do
  202.       tried[row, col] := false;
  203.   solved := false;
  204.   col := 0;
  205.   row := 1;
  206.   while not solved and (row < mazerows) do
  207.     begin
  208.       solved := try(row, col, right);
  209.       row := row + 1;
  210.     end;
  211.   col := mazecols;
  212.   row := 1;
  213.   while not solved and (row < mazerows) do
  214.     begin
  215.       solved := try(row, col, left);
  216.       row := row + 1;
  217.     end;
  218.   row := 0;
  219.   col := 1;
  220.   while not solved and (col < mazecols) do
  221.     begin
  222.       solved := try(row, col, down);
  223.       col := col + 1;
  224.     end;
  225.   row := mazerows;
  226.   col := 1;
  227.   while not solved and (col < mazecols) do
  228.     begin
  229.       solved := try(row, col, up);
  230.       col := col + 1;
  231.     end;
  232.   solvemaze := solved;
  233. end;
  234.  
  235. begin
  236.   Clrscr;
  237.   Randomize;
  238.   repeat
  239.     createmaze(maze);
  240.     lowvideo;
  241.     gotoxy(68,1);    write('Maze for');
  242.     gotoxy(68,2);    write('Microbee');
  243.     normvideo;
  244.     gotoxy(68,4);    write('Press any');
  245.     gotoxy(68,5);    write('key for');
  246.     gotoxy(68,6);    write('answer.');
  247.     gotoxy(1,26);
  248.     read(KBD,ch);
  249.     Won := solvemaze(maze);
  250.     gotoxy(68,8);    write('Press <Q>');
  251.     gotoxy(68,9);    write('to Quit or');
  252.     gotoxy(68,10);   write('any key for');
  253.     gotoxy(68,11);   write('another Maze');
  254.     gotoxy(1,26);
  255.     read(KBD,ch);
  256.     gotoxy(68,8);    write('         ');
  257.     gotoxy(68,9);    write('          ');
  258.     gotoxy(68,10);   write('           ');
  259.     gotoxy(68,11);   write('            ');
  260.   until ch in ['q','Q'];
  261.   clrscr;
  262. end.
  263.