Волновой алгоритм -> Форум на Исходниках.Ру

	Наши проекты: Журнал · Discuz!ML · Wiki · DRKB · Помощь проекту

Здравствуйте, Гость ! [18.219.22.169]

правила раздела Алгоритмы

1. Помните, что название темы должно хоть как-то отражать ее содержимое (не создавайте темы с заголовком ПОМОГИТЕ, HELP и т.д.). Злоупотребление заглавными буквами в заголовках тем ЗАПРЕЩЕНО.
2. При создании темы постарайтесь, как можно более точно описать проблему, а не ограничиваться общими понятиями и определениями.
3. Приводимые фрагменты исходного кода старайтесь выделять тегами code.../code
4. Помните, чем подробнее Вы опишете свою проблему, тем быстрее получите вразумительный совет
5. Запрещено поднимать неактуальные темы (ПРИМЕР: запрещено отвечать на вопрос из серии "срочно надо", заданный в 2003 году)
6. И не забывайте о кнопочках TRANSLIT и РУССКАЯ КЛАВИАТУРА, если не можете писать в русской раскладке

Модераторы: Akina, shadeofgray

Новое голосование

Волновой алгоритм

J_S

Сообщ. #1 , 10.07.03, 14:48

Unregistered

Нужно разработать алгоритм для обхода препятствий, причем припятствия бывают только прямоугольной формы и не могут "пересекаться", а путь может состоять только из горизонтальных и вертикальных линий.
Я конечно пыталась придумать что-то, но никакого обьективного алгоритма не получилось.

P.S. Путь, конечно, должен быть наиболее краток.

Jin X

Сообщ. #2 , 10.07.03, 18:09

Законченный оптимист

Профиль · PM

Поощрения: 23 Dgm

Рейтинг (т): 117

Ничего, если на паскале?

Uses Crt; Const Wall = #254; Move = #250; Nk = 250; Var R: array [0..79, 0..49] of Byte; Ni: Byte; FX, FY: Byte; i, j: Word; Procedure Init; Begin For j := 0 to 49 do For i := 0 to 79 do If (i in [0, 79]) or (j in [0, 49]) then R[i, j] := 255 else Case Mem[$B800:j*160+i*2] of 32: R[i, j] := 254; Ord('X'): R[i, j] := 0; 1: R[i, j] := 253; else R[i, j] := 255 End; Ni := 0 End; Procedure Clear; Begin For j := 1 to 48 do For i := 1 to 78 do Case Mem[$B800:j*160+i*2] of Ord(Move): Begin GotoXY(i, j); Write(' '#8) End; 2: Begin GotoXY(i, j); Write(#1#8) End End End; Procedure Start; Var Ok: Boolean; X, Y, N, X1, Y1: Byte; Procedure Check(X, Y: Byte); Begin Case R[X, Y] of 253: Ok := True; 254: R[X, Y] := Ni+1 End End; Procedure Find(X, Y: Byte); Begin If R[X, Y] < N then Begin N := R[X, Y]; X1 := X; Y1 := Y End End; Begin Init; Ok := False; Repeat For j := 1 to 48 do For i := 1 to 78 do Begin If Ok then Break; If R[i, j] = Ni then Begin Check(i, j-1); Check(i+1, j); Check(i, j+1); Check(i-1, j) End End; Inc(Ni) Until Ok or (Ni > Nk); If Ok then Begin X := FX; Y := FY; TextAttr := $93; Repeat N := 255; Find(X, Y-1); Find(X+1, Y); Find(X, Y+1); Find(X-1, Y); If R[X1, Y1] = 0 then Break; GotoXY(X1, Y1); Write(Move); X := X1; Y := Y1 Until False End else Begin TextAttr := $9E; GotoXY(FX, FY); Write(#2) End; TextAttr := $4F; Window(1, 1, 80, 50); GotoXY(3, 1); Write('Итераций - ', Ni, '/250 '#8#8); If ReadKey = #0 then ReadKey; TextAttr := $1F; Window(2, 2, 80, 49); Clear; GotoXY(FX, FY) End; Begin TextMode(Co80+Font8x8); TextAttr := $4E; ClrScr; GotoXY(3, 50); Write(#27#26#24#25' - Move; Space,Del,PgDn,Home,End,Tab - Wall; Insert - Man; PgUp - Target'); GotoXY(54, 1); Write('ENTER - Start; ESC - Exit'); Window(2, 2, 79, 49); TextAttr := $1F; ClrScr; Window(2, 2, 80, 49); Repeat Case ReadKey of #00: Case ReadKey of #72: If WhereY > 1 then GotoXY(WhereX, WhereY-1); #75: If WhereX > 1 then GotoXY(WhereX-1, WhereY); #77: If WhereX < 78 then GotoXY(WhereX+1, WhereY); #80: If WhereY < 48 then GotoXY(WhereX, WhereY+1); #71: {Home} Begin If WhereY > 1 then GotoXY(WhereX, WhereY-1); If Mem[$B800:WhereY*160+WhereX*2] = 32 then Write(Wall+#8) else Write(' '#8); If (FX = WhereX) and (FY = WhereY) then FX := 0 End; #83: {Del} Begin If WhereX > 1 then GotoXY(WhereX-1, WhereY); If Mem[$B800:WhereY*160+WhereX*2] = 32 then Write(Wall+#8) else Write(' '#8); If (FX = WhereX) and (FY = WhereY) then FX := 0 End; #81: {PgDn} Begin If WhereX < 78 then GotoXY(WhereX+1, WhereY); If Mem[$B800:WhereY*160+WhereX*2] = 32 then Write(Wall+#8) else Write(' '#8); If (FX = WhereX) and (FY = WhereY) then FX := 0 End; #79: {End} Begin If WhereY < 48 then GotoXY(WhereX, WhereY+1); If Mem[$B800:WhereY*160+WhereX*2] = 32 then Write(Wall+#8) else Write(' '#8); If (FX = WhereX) and (FY = WhereY) then FX := 0 End; #59: {F1 - Clr} Begin For j := 1 to 48 do For i := 1 to 78 do Begin GotoXY(i, j); Write(' '#8) End; FX := 0 End; #60: {F2 - Fill} Begin For j := 1 to 48 do For i := 1 to 78 do Begin GotoXY(i, j); Write(Wall+#8) End; FX := 0 End; #73: {PgUp} Write('X'#8); #82: {Ins} Begin i:= WhereX; j := WhereY; GotoXY(FX, FY); Write(' '); GotoXY(i, j); Write(#1#8); FX := i; FY := j End End; #09: {Tab} For Ni := 1 to 100 do Begin i := Random(78)+1; j := Random(48)+1; If Mem[$B800:j*160+i*2] <> 1 then Begin GotoXY(i, j); Write(Wall+#8) End End; #32: {Space} Begin If Mem[$B800:WhereY*160+WhereX*2] = 32 then Write(Wall+#8) else Write(' '#8); If (FX = WhereX) and (FY = WhereY) then FX := 0 End; #13: {Enter} If FX <> 0 then Start; #27: {Esc} Break End Until False; TextMode(Co80); TextAttr := 7; ClrScr End.

Shiru_Otaku	Сообщ. #3 , 10.07.03, 23:29
Unregistered	Я не понимаю вопроса. Сказано - надо разработать алгоритм. В сабже стоит название алгоритма, который замечательным образом решает поставленную задачу. В чём проблема? Реализовать?

Antipich	Сообщ. #4 , 12.07.03, 09:34
Profi Профиль · PM Рейтинг (т): 9	А причём тут дельфя вообще, тему ИМХО в алгоритмы надо.

Danaris

Сообщ. #5 , 12.07.03, 13:57

Unregistered

Волновой алгоритм:

Program Voln; Uses Crt; Const Map : array [1..10, 1..10] of Byte = ( (0, 0, 1, 0, 0, 0, 0, 0, 0, 0), (1, 0, 0, 0, 0, 1, 0, 0, 1, 0), (0, 0, 0, 1, 1, 1, 0, 0, 1, 1), (0, 1, 0, 0, 0, 1, 0, 0, 1, 0), (0, 0, 0, 0, 1, 1, 1, 0, 1, 0), (0, 0, 1, 1, 1, 0, 1, 0, 0, 0), (0, 0, 0, 1, 0, 0, 1, 0, 0, 0), (1, 1, 0, 1, 0, 0, 1, 1, 1, 0), (0, 1, 0, 0, 0, 0, 1, 0, 0, 0), (0, 1, 0, 0, 0, 0, 1, 0, 0, 0) ); var XS, YS, XE, YE : Byte; X, Y, I : Byte; MapM : array [1..10, 1..10] of Byte; Moves : Byte; MovesX : array [1..100] of Byte; MovesY : array [1..100] of Byte; Procedure Next(Var X, Y : Byte); Begin If (X <10) and (MapM[X, Y] - MapM[X + 1, Y] = 1) then Begin X := X + 1; Exit; End; If (X >1) and (MapM[X, Y] - MapM[X - 1, Y] = 1) then Begin X := X - 1; Exit; End; If (Y <10) and (MapM[X, Y] - MapM[X, Y + 1] = 1) then Begin Y := Y + 1; Exit; End; If (Y >1) and (MapM[X, Y] - MapM[X, Y - 1] = 1) then Begin Y := Y - 1; Exit; End; End; Begin ClrScr; For Y := 1 to 10 do Begin For X := 1 to 10 do Write(Map[X, Y], ' '); WriteLn; End; WriteLn('Please enter X and Y of the start: '); ReadLn(XS, YS); WriteLn('Please enter X and Y of the end: '); ReadLn(XE, YE); If (Map[XS, YS] = 1) or (Map[XE, YE] = 1) then Begin WriteLn('Error!!!'); ReadLn; Halt; End; MapM[XS, YS] := 1; I := 1; Repeat I := I + 1; For Y := 1 to 10 do For X := 1 to 10 do If MapM[X, Y] = I - 1 then Begin If (Y <10) and (MapM[X, Y + 1] = 0) and (Map[X, Y+1] = 0) Then MapM[X, Y+1] := I; If (Y >1) and (MapM[X, Y-1] = 0) and (Map[X, Y-1] = 0) Then MapM[X, Y-1] := I; If (X <10) and (MapM[X+1, Y] = 0) and (Map[X+1, Y] = 0) Then MapM[X+1, Y] := I; If (X >1) and (MapM[X-1, Y] = 0) and (Map[X-1, Y] = 0) Then MapM[X-1, Y] := I; End; If I = 100 then Begin WriteLn('You can''t go there!!!'); ReadLn; Halt; End; Until MapM[XE, YE] >0; Moves := I - 1; X := XE; Y := YE; I := Moves; Map[XE, YE] := 4; Repeat MovesX[I] := X; MovesY[I] := Y; Next(X, Y); Map[X, Y] := 3; I := I - 1; Until (X = XS) and (Y = YS); Map[XS, YS] := 2; For I := 1 to Moves do WriteLn('X = ', MovesX[I],', Y = ', MovesY[I]); WriteLn('Total: ', Moves, ' moves'); ReadLn; For Y := 1 to 10 do Begin For X := 1 to 10 do Write(Map[X, Y], ' '); WriteLn; End; ReadLn; End.

Arsenal

Сообщ. #6 , 16.11.03, 14:18

Unregistered

QUOTE (Jin X @ 10.07.03, 21:09)

Ничего, если на паскале?

На Паскале очень даже ничего...

Я захотел посмотреть, что тут делается, запустил под ХР найденый в сети ТР 7.0, а он на эту программу (впрочем и на нижнюю тоже) ругается давно не виданным сообщением: Деление на нуль, ошибка 200. При этом родные туториалы компилит и исполняет нормально, то есть сам Пасик не битый. В чем моя ошибка? Откуда "груз 200"?

Black Star	Сообщ. #7 , 21.11.03, 22:48
Master Профиль · PM Поощрения: 14 Dgm Рейтинг (т): 99	Алгоритм см тут

Shiru_Otaku	Сообщ. #8 , 22.11.03, 03:23
Unregistered	А дату создания темы ты см. ?;) Не понимаю, зачем надо давать ответ на вопрос, заданный хз когда, да ещё и при наличии нескольких полных ответов в теме;)

Black Star	Сообщ. #9 , 23.11.03, 00:57
Master Профиль · PM Поощрения: 14 Dgm Рейтинг (т): 99	А кто на дату создания смотрит? Смотрят по последней дате. Последняя 16.11.03. Алгоритма нету? Нету. Вот и привел ссылку. Ссылку кстати еще ты мне подкинул дааавненько... Вот и пригодилась.

0 пользователей читают эту тему (0 гостей и 0 скрытых пользователей)

0 пользователей:

[ Script execution time: 0,0353 ] [ 15 queries used ] [ Generated: 3.05.24, 12:15 GMT ]