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.
Добавлено через 1 мин. Подскажите что нужно подправить
Unconnected
16.06.2011 16:09
Хотя бы сказать, что за игра лаберинт, как в неё играют..
TarasBer
16.06.2011 16:10
Что значит не запускается? Какую ошибку выдаёт?
Изелдор
16.06.2011 16:13
Ну там есть типо заполнение сложности я прохожу ее и все игра закрывается.
IUnknown
16.06.2011 16:13
Все прекрасно запускается. Если путь к BGI-файлу в строке
initgraph(grdriver, grmode, 'e:\bp\bgi');
выставить правильно. Ничего не нужно править...
Изелдор
16.06.2011 16:14
Цитата
Хотя бы сказать, что за игра лаберинт, как в неё играют..
Ну там типа кубик или точка должна бродить по лаберинту и выходить.
Добавлено через 4 мин.
Цитата
Все прекрасно запускается. Если путь к BGI-файлу в строке initgraph(grdriver, grmode, 'e:\bp\bgi'); выставить правильно. Ничего не нужно править...
Все равно не запускается
TarasBer
16.06.2011 16:40
> Ну там есть типо заполнение сложности я прохожу ее и все игра закрывается.
Так и надо говорить. "Вылетает после заполнения сложности". А ты что сказал? Чем точнее ты будешь говорить, что происходит, тем скорее мы тебе поможем.
Дальше, если нажать альт+ф5, то что будет написано на чёрном экране?
Изелдор
16.06.2011 16:51
Вот это
Добавлено через 2 мин. ...
Unconnected
16.06.2011 17:16
O_o нестандатрный драйвер(лаберинтовый наверное)), что у тебя за паскаль?
Изелдор
16.06.2011 17:28
Turbo Pascal 7.1
Добавлено через 2 мин. Unconnected Если можеш дать полуше не откажусь
Lapp
17.06.2011 4:51
Цитата(Изелдор @ 16.06.2011 17:51)
Вот это ...
Я в шоке.. Прикрепить bmp на мегабайт со всеми виндусовыми красотами, при этом уменьшив ее так, что едва разберешь закорючки - и все это только для того, чтоб сказать, что там нет НИЧЕГО
Мегабайтовый БМП, на котором ещё и весь рабочий стол?! Я бы забанил нахрен за такое.
Пусть в бане научится: 1. Пользоваться инструментом "вырезать область" в пеинте. 2. Узначет, чем отличается просто "принтскрин" от "альт+принтскрин". 3. Узнает про назначение формата ПНГ. 4. Изучит пункты "изменить-пометить" и "изменить-копировать" в контекстном меню виндовской консоли, вызываемом при щелчке правой кнопкой по иконке в левой части заголовка.
Хотя это таки лучше, чем фотографии монитора, да.
Lapp
17.06.2011 22:35
а я прошел! с параметрами 10 и 5 ))
Изелдор
20.06.2011 14:35
У меня просто курсовая горит а я в паскале дуб дубом Мне нужно игра Лаберинт и в ней: 1.Меню 1.Игра 2.Помощь 3.Выход 2. Как минимум 2 уровня в игре И чтоб это тенула на то что это написал 1 курс
Lapp
20.06.2011 23:53
Цитата(Изелдор @ 20.06.2011 15:35)
У меня просто курсовая горит а я в паскале дуб дубом Мне нужно игра Лаберинт и в ней: 1.Меню . 1.Игра . 2.Помощь . 3.Выход 2. Как минимум 2 уровня в игре И чтоб это тенула на то что это написал 1 курс
Изелдор, извини, но писать за тебя курсовую тут никто не будет. Какой смысл вообще?? Особенно последняя фраза - еще и подделываться под первокусника? Вот честно скажи - на фига оно нам тут надо, как ты думаешь? Чтобы еще одним ничего не умеющим "программером" стало больше? Да я буду рад, если ты завалишь курсовик..
Короче, если ты проявляешь интерес, пишешь что-то САМ - мы поможем. Если нет - гуляй, вася, жуй опилки.. Без обид, просто по здравому смыслу.
Это текстовая версия — только основной контент. Для просмотра полной версии этой страницы, пожалуйста, нажмите сюда.