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.