Contributor: RANDALL ELTON DING
{
randyd@csd4.csd.uwm.edu (Randall Elton Ding)
This is really for Allen who earlier in the month asked about generating
a maze in pascal. It may not really be the fastest, but I know of
no other way which is faster. Check it out, it lets you try to move
thru the maze, when you give up it shows you the way. It has variable
difficulty and size too.
This was origionally written in Apple][ 6502 machine language, I ported
it over to pascal a few years later.
}
(* Big Mind Over Maze
maze generator and solver
created by Randy Ding
July 16,1983 *)
{$R-} { range checking }
program makemaze;
uses
crt, graph;
const
screenwidth = 640;
screenheight = 350;
minblockwidth = 2;
maxx = 200; { [3 * maxx * maxy] must be less than 65520 (memory segment) }
maxy = 109; { here maxx/maxy about equil to screenwidth/screenheight }
flistsize = 5000; { flist size (fnum max, about 1/3 of maxx * maxy) }
background = black;
gridcolor = green;
solvecolor = white;
rightdir = 01ドル;
updir = 02ドル;
leftdir = 04ドル;
downdir = 08ドル;
unused = 00ドル; { cell types used as flag bits }
frontier = 10ドル;
reserved = 20ドル;
tree = 30ドル;
type
frec = record
column, row : byte;
end;
farr = array [1..flistsize] of frec;
cellrec = record
point : word; { pointer to flist record }
flags : byte;
end;
cellarr = array [1..maxx,1..maxy] of cellrec;
{
one byte per cell, flag bits...
0: right, 1 = barrier removed
1: top "
2: left "
3: bottom "
5,4: 0,0 = unused cell type
0,1 = frontier "
1,1 = tree "
1,0 = reserved "
6: (not used)
7: solve path, 1 = this cell part of solve path
}
var
flist : farr; { list of frontier cells in random order }
cell : ^cellarr; { pointers and flags, on heap }
fnum,
width,
height,
blockwidth,
halfblock,
maxrun : word;
runset : byte;
ch : char;
procedure initbgi;
var
grdriver,
grmode,
errcode : integer;
begin
grdriver := DETECT;
grmode := EGAhi;
initgraph(grdriver, grmode, 'e:\bp\bgi');
errcode:= graphresult;
if errcode grok then
begin
writeln('Graphics error: ', grapherrormsg(errcode));
halt(1);
end;
end;
function adjust(var x, y : word; d : byte) : boolean;
begin { take x,y to next cell in direction d }
case d of { returns false if new x,y is off grid }
rightdir:
begin
inc (x);
adjust:= x <= width; end; updir: begin dec (y); adjust:= y> 0;
end;
leftdir:
begin
dec (x);
adjust:= x> 0;
end;
downdir:
begin
inc (y);
adjust:= y <= height; end; end; end; procedure remove(x, y : word); { remove a frontier cell from flist } var i : word; { done by moving last entry in flist into it's place } begin i := cell^[x,y].point; { old pointer } with flist[fnum] do cell^[column,row].point := i; { move pointer } flist[i] := flist[fnum]; { move data } dec(fnum); { one less to worry about } end; procedure add(x, y : word; d : byte); { add a frontier cell to flist } var i : byte; begin i := cell^[x,y].flags; case i and 30ドル of { check cell type } unused : begin cell^[x,y].flags := i or frontier; { change to frontier cell } inc(fnum); { have one more to worry about } if fnum> flistsize then
begin { flist overflow error! }
dispose(cell); { clean up memory }
closegraph;
writeln('flist overflow! - To correct, increase "flistsize"');
write('hit return to halt program ');
readln;
halt(1); { exit program }
end;
with flist[fnum] do
begin { copy data into last entry of flist }
column := x;
row := y;
end;
cell^[x,y].point := fnum; { make the pointer point to the new cell }
runset := runset or d; { indicate that a cell in direction d was }
end; { added to the flist }
frontier : runset := runset or d; { allready in flist }
end;
end;
procedure addfront(x, y : word); { change all unused cells around this }
var { base cell to frontier cells }
j, k : word;
d : byte;
begin
remove(x, y); { first remove base cell from flist, it is now }
runset := 0; { part of the tree }
cell^[x,y].flags := cell^[x,y].flags or tree; { change to tree cell }
d := 01ドル; { look in all four directions- 01,ドル02,ドル04,ドル08ドル }
while d <= 08ドル do begin j := x; k := y; if adjust(j, k, d) then add(j, k, d); { add only if still in bounds } d := d shl 1; { try next direction } end; end; procedure remline(x, y : word; d : byte); { erase line connecting two blocks } begin setcolor(background); x := (x - 1) * blockwidth; y := (y - 1) * blockwidth; case d of rightdir : line (x + blockwidth, y + 1, x + blockwidth, y + blockwidth - 1); updir : line (x + 1, y, x + blockwidth - 1, y); leftdir : line (x, y + 1, x, y + blockwidth - 1); downdir : line (x + 1, y + blockwidth, x + blockwidth - 1, y + blockwidth); end; end; { erase line and update flags to indicate the barrier has been removed } procedure rembar(x, y : word; d : byte); var d2 : byte; begin remline(x, y, d); { erase line } cell^[x,y].flags := cell^[x,y].flags or d; { show barrier removed dir. d } d2 := d shl 2; { shift left twice to reverse direction } if d2> 08ドル then
d2 := d2 shr 4; { wrap around }
if adjust(x, y, d) then { do again from adjacent cell back to base cell }
cell^[x,y].flags := cell^[x,y].flags or d2; { skip if out of bounds }
end;
function randomdir : byte; { get a random direction }
begin
case random(4) of
0 : randomdir := rightdir;
1 : randomdir := updir;
2 : randomdir := leftdir;
3 : randomdir := downdir;
end;
end;
procedure connect(x, y : word); { connect this new branch to the tree }
var { in a random direction }
j, k : word;
d : byte;
found : boolean;
begin
found := false;
while not found do
begin { loop until we find a tree cell to connect to }
j := x;
k := y;
d := randomdir;
if adjust(j, k, d) then
found := cell^[j,k].flags and 30ドル = tree;
end;
rembar(x, y, d); { remove barrier connecting the cells }
end;
procedure branch(x, y : word); { make a new branch of the tree }
var
runnum : word;
d : byte;
i : boolean;
begin
runnum := maxrun; { max number of tree cells to add to a branch }
connect(x, y); { first connect frontier cell to the tree }
addfront(x, y); { convert neighboring unused cells to frontier }
dec(runnum); { number of tree cells left to add to this branch }
while (runnum> 0) and (fnum> 0) and (runset> 0) do
begin
repeat
d := randomdir;
until d and runset> 0; { pick random direction to known frontier }
rembar(x, y, d); { and make it part of the tree }
i := adjust(x, y, d);
addfront(x, y); { then pick up the neighboring frontier cells }
dec(runnum);
end;
end;
procedure drawmaze;
var
x, y, i : word;
begin
setcolor(gridcolor); { draw the grid }
y := height * blockwidth;
for i := 0 to width do
begin
x := i * blockwidth;
line(x, 0, x, y);
end;
x := width * blockwidth;
for i := 0 to height do
begin
y := i * blockwidth;
line (0, y, x, y);
end;
fillchar(cell^, sizeof(cell^), chr(0)); { zero flags }
fnum := 0; { number of frontier cells in flist }
runset := 0; { directions to known frontier cells from a base cell }
randomize;
x := random(width) + 1; { pick random start cell }
y := random(height) + 1;
add(x, y, rightdir); { direction ignored }
addfront(x, y); { start with 1 tree cell and some frontier cells }
while (fnum> 0) do
with flist[random(fnum) + 1] do
branch(column, row);
end;
procedure dot(x, y, colr : word);
begin
putpixel(blockwidth * x - halfblock, blockwidth * y - halfblock, colr);
end;
procedure solve(x, y, endx, endy : word);
var
j, k : word;
d : byte;
i : boolean;
begin
d := rightdir; { starting from left side of maze going right }
while (x endx) or (y endy) do
begin
if d = 01ドル then
d := 08ドル
else
d := d shr 1; { look right, hug right wall }
while cell^[x,y].flags and d = 0 do
begin { look for an opening }
d := d shl 1; { if no opening, turn left }
if d> 08ドル then
d := d shr 4;
end;
j := x;
k := y;
i := adjust(x, y, d); { go in that direction }
with cell^[j,k] do
begin { turn on dot, off if we were here before }
flags := ((((cell^[x,y].flags xor 80ドル) xor flags) and 80ドル) xor flags);
if flags and 80ドル 0 then
dot(j, k, solvecolor)
else
dot(j, k, background);
end;
end;
dot(endx, endy, solvecolor); { dot last cell on }
end;
procedure mansolve (x,y,endx,endy: word);
var
j, k : word;
d : byte;
ch : char;
begin
ch := ' ';
while ((x endx) or (y endy)) and (ch 'X') and (ch #27) do
begin
dot(x, y, solvecolor); { dot man on, show where we are in maze }
ch := upcase(readkey);
dot(x, y, background); { dot man off after keypress }
d := 0;
case ch of
#0:
begin
ch := readkey;
case ch of
#72 : d := updir;
#75 : d := leftdir;
#77 : d := rightdir;
#80 : d := downdir;
end;
end;
'I' : d := updir;
'J' : d := leftdir;
'K' : d := rightdir;
'M' : d := downdir;
end;
if d> 0 then
begin
j := x;
k := y; { move if no wall and still in bounds }
if (cell^[x,y].flags and d> 0) and adjust(j, k, d) then
begin
x := j;
y := k;
end;
end;
end;
end;
procedure solvemaze;
var
x, y,
endx,
endy : word;
ch : char;
begin
x := 1; { pick random start on left side wall }
y := random(height) + 1;
endx := width; { pick random end on right side wall }
endy := random(height) + 1;
remline(x, y, leftdir); { show start and end by erasing line }
remline(endx, endy, rightdir);
mansolve(x, y, endx, endy); { try it manually }
solve(x, y, endx, endy); { show how when he gives up }
while keypressed do
ch := readkey;
ch := readkey;
end;
procedure getsize;
var
j, k : real;
begin
clrscr;
writeln(' Mind');
writeln(' Over');
writeln(' Maze');
writeln;
writeln(' by Randy Ding');
writeln;
writeln('Use I,J,K,M or arrow keys to walk thru maze,');
writeln('then hit X when you give up!');
repeat
writeln;
write('Maze size: ', minblockwidth, ' (hard) .. 95 (easy) ');
readln(blockwidth);
until (blockwidth>= minblockwidth) and (blockwidth < 96); writeln; write('Maximum branch length: 1 easy .. 50 harder, (0 unlimited) '); readln(maxrun); if maxrun <= 0 then maxrun := 65535; { infinite } j := screenwidth / blockwidth; k := screenheight / blockwidth; if j = int(j) then j := j - 1; if k = int(k) then k := k - 1; width := trunc(j); height := trunc(k); if (width> maxx) or (height> maxy) then
begin
width := maxx;
height := maxy;
end;
halfblock := blockwidth div 2;
end;
begin
repeat
getsize;
initbgi;
new(cell); { allocate this large array on heap }
drawmaze;
solvemaze;
dispose(cell);
closegraph;
while keypressed do
ch := readkey;
write ('another one? ');
ch := upcase (readkey);
until (ch = 'N') or (ch = #27);
end.