|
ПОМОГИТЕ срочно
|
|
нужно написать программу Turbo Pascal
движение по лабиринту
управление осуществляется с помощью клавиатуры
как можно пороще
сможете помогите и киньте ссылку на подобное
№ 1 | Автор: BadWolf |
2012-06-03, 14:49 | Изменено: BadWolf - Вс, 2012-06-03, 15:02
|
Репутация: [ + 0 ]
|
|
|
|
Есть очень хорошая ссылочка:
http://www.google.ru
)))
Вот код:
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;
Нужна помощь? Сюда: vkontakte.ru/berestovskiy
|
|
|
|
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;
Нужна помощь? Сюда: vkontakte.ru/berestovskiy
|
|
|
|
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;
Нужна помощь? Сюда: vkontakte.ru/berestovskiy
|
|
|
|
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;
Нужна помощь? Сюда: vkontakte.ru/berestovskiy
|
|
|
|
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;
Нужна помощь? Сюда: vkontakte.ru/berestovskiy
|
|
|
|
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.
Нужна помощь? Сюда: vkontakte.ru/berestovskiy
|
|
|
Нужна помощь? Сюда: vkontakte.ru/berestovskiy
|
|
|
|
спасибо за код
чувак ты круут!!!!!!!!
|
|
|
|
"Спасибо" принимается повышением репутации ( Зелёный плюсик:) ).Спасибо
ня :3
Нужна помощь? Сюда: vkontakte.ru/berestovskiy
|
|
|
|
