mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-09-04 18:50:37 +02:00
New fpcgame, MAZE
This commit is contained in:
marco
parent
78befc7ec6
commit
2bd8c56263
481
install/demo/maze.pas
Normal file
481
install/demo/maze.pas
Normal file
@ -0,0 +1,481 @@
|
||||
{A demo with some interesting algoritms, and for Graph.
|
||||
|
||||
The sources for this game was found on a site that claims to only have
|
||||
PD stuff with the below header(which was only reindented), and the webmaster
|
||||
said that everything he published was sent to him with that purpose. We tried
|
||||
to contact the authors mentioned below via mail over internet, but that
|
||||
failed. If there is somebody that claims authorship of these programs,
|
||||
please mail marco@freepascal.org, and the sources will be removed from our
|
||||
websites.
|
||||
|
||||
------------------------------------------------------------------------
|
||||
|
||||
ORIGINAL Header:
|
||||
|
||||
created by Randy Ding July 16,1983 <April 21,1992>
|
||||
|
||||
Very small FPC fixes by Marco van de Voort (EgaHi to vgahi), and tried
|
||||
setting the maze dimensions maxx and maxy to a bigger size.
|
||||
Won't work, you'll have to update all vars to al least word to increase the
|
||||
complexity of the grid further. I didn't do it, since 200x200 is already
|
||||
unreadable to me.
|
||||
|
||||
Don't forget the BGIPATH of InitGraph.
|
||||
}
|
||||
|
||||
{$R-} { range checking }
|
||||
|
||||
program makemaze;
|
||||
|
||||
uses
|
||||
crt, graph;
|
||||
|
||||
const
|
||||
screenwidth = 640;
|
||||
screenheight = 480;
|
||||
minblockwidth = 2;
|
||||
maxx = 200; { BP: [3 * maxx * maxy] must be less than 65520 (memory segment) }
|
||||
{ FPC: Normally no problem. ( even if you'd use 1600x1200x3< 6MB)}
|
||||
maxy = 200; { here maxx/maxy about equil to screenwidth/screenheight }
|
||||
flistsize = maxx*maxy DIV 2; { 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 := vga;
|
||||
grmode := vgahi;
|
||||
initgraph(grdriver, grmode, 'd:\pp\bp\bgi');
|
||||
errcode:= graphresult;
|
||||
if errcode <> grok then
|
||||
begin
|
||||
CloseGraph;
|
||||
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.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user