Форум на Исходниках.RU

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 := ; 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 := E; GotoXY(FX, FY); Write(#2) End; TextAttr := F; Window(1, 1, 80, 50); GotoXY(3, 1); Write('Итераций - ', Ni, '/250 '#8#8); If ReadKey = #0 then ReadKey; TextAttr := F; Window(2, 2, 80, 49); Clear; GotoXY(FX, FY) End; Begin TextMode(Co80+Font8x8); TextAttr := E; 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 := F; 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.

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); Check(i+1, j-1); Check(i+1, j+1); Check(i-1, j+1); Check(i-1, j-1) End End; Inc(Ni) Until Ok or (Ni > Nk); If Ok then Begin X := FX; Y := FY; TextAttr := ; Repeat N := 255; Find(X, Y-1); Find(X+1, Y); Find(X, Y+1); Find(X-1, Y); Find(X+1, Y-1); Find(X+1, Y+1); Find(X-1, Y+1); Find(X-1, Y-1); If R[X1, Y1] = 0 then Break; GotoXY(X1, Y1); Write(Move); X := X1; Y := Y1 Until False End else Begin TextAttr := E; GotoXY(FX, FY); Write(#2) End; TextAttr := F; Window(1, 1, 80, 50); GotoXY(3, 1); Write('Итераций - ', Ni, '/250 '#8#8); If ReadKey = #0 then ReadKey; TextAttr := F; Window(2, 2, 80, 49); Clear; GotoXY(FX, FY) End; Begin TextMode(Co80+Font8x8); TextAttr := E; 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 := F; 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.