mixster

Oct 24th, 2009

224

Never

Add comment

Not a member of Pastebin yet? Sign Up, it unlocks many cool features!

Delphi 10.35 KB | None | 0 0

raw download clone embed print report

// nielsie's maze solver
// pasted by mixster for the Leage of Scripters competition on Villavu
const
xGridLo = 0;
xGridHi = 25;
yGridLo = 0;
yGridHi = 12;
sMap =
'00000000000000000000000002' +
'03011111011111100010001102' +
'01010101010000111111101002' +
'01111101010110101000101002' +
'01000111010100101110111112' +
'01010100010110100000100012' +
'01110111010011101100101012' +
'00101101010110001011101012' +
'01111001010100101010011012' +
'01001011110111111110010012' +
'01111010010000000111110012' +
'00100111111111111000000042' +
'0000000000000000000000000';
type
TGrid = array[xGridLo..xGridHi] of array[yGridLo..yGridHi] of Boolean;
TPossibles = array[xGridLo..xGridHi] of array[yGridLo..yGridHi] of record
Count: Byte;
L, R, U, D: Boolean;
end;
TMap = record
Grid: TGrid;
Possibles: TPossibles;
sp, ep: TPoint;
end;
TNode = record
Path, Possibles: TPointArray;
PosLen: Integer;
Grid: TGrid;
end;
TNodeArray = array of TNode;
function QueryPerformanceFrequency(out Frequency: Int64): LongBool; external '[email protected] stdcall';
function QueryPerformanceCounter(out Counter: Int64): LongBool; external '[email protected] stdcall';
procedure MarkTime(var Time: Int64);
var
Freq: Int64;
begin
if QueryPerformanceFrequency(Freq) then
QueryPerformanceCounter(Time)
else
Time := GetTickCount;
end;
function TimeFromMark(Mark: Int64): Double;
var
Freq, Now: Int64;
begin
if QueryPerformanceFrequency(Freq) then
begin
QueryPerformanceCounter(Now);
Result := ((Now - Mark) / Freq) * 1000;
end
else
Result := (GetTickCount - Mark);
end;
function GetPossiblesForPoint(s: TPoint; var Grid: TGrid; Possibles: TPossibles): TPointArray;
var
Len: Integer;
begin
with Possibles[s.x][s.y] do
begin
SetLength(Result, Count);
if (Count < 1) then
Exit;
Len := 0;
if U then
if Grid[s.x][s.y - 1] then
begin
Grid[s.x][s.y - 1] := False;
Result[Len] := Point(s.x, s.y - 1);
Inc(Len);
end;
if D then
if Grid[s.x][s.y + 1] then
begin
Grid[s.x][s.y + 1] := False;
Result[Len] := Point(s.x, s.y + 1);
Inc(Len);
end;
if L then
if Grid[s.x - 1][s.y] then
begin
Grid[s.x - 1][s.y] := False;
Result[Len] := Point(s.x - 1, s.y);
Inc(Len);
end;
if R then
if Grid[s.x + 1][s.y] then
begin
Grid[s.x + 1][s.y] := False;
Result[Len] := Point(s.x + 1, s.y);
Inc(Len);
end;
if (Len <> Count) then
SetLength(Result, Len);
end;
end;
function Node(const aPath, aPossibles: TPointArray; const aGrid: TGrid): TNode;
begin
with Result do
begin
Path := aPath;
Possibles := aPossibles;
PosLen := Length(aPossibles);
Grid := aGrid;
end;
end;
procedure AddNodeToArray(var a: TNodeArray; n: TNode);
begin
SetLength(a, Length(a) + 1);
a[High(a)] := n;
end;
procedure AddPointToArrayProc(var a: TPointArray; p: TPoint);
begin
SetLength(a, Length(a) + 1);
a[High(a)] := p;
end;
function AddPointToArrayFunc(const a: TPointArray; p: TPoint): TPointArray;
begin
Result := a;
SetLength(Result, Length(Result) + 1);
Result[High(Result)] := p;
//AddPointToArrayProc(Result, p);
end;
function GetPaths(const Map: TMap): T2DPointArray;
var
tp: TPoint;
p: TPointArray;
i, c, t: Integer;
Nodes: TNodeArray;
begin
SetLength(Result, 0);
p := GetPossiblesForPoint(Map.sp, Map.Grid, Map.Possibles);
AddNodeToArray(Nodes, Node([Map.sp], p, Map.Grid));
c := 0;
while (c < Length(Nodes)) do
begin
//repeat
for i := 0 to Nodes[c].PosLen - 1 do
with Nodes[c] do
begin
if (Possibles[i].y = Map.ep.y) and
(Possibles[i].x = Map.ep.x) then
begin
SetLength(Result, Length(Result) + 1);
Result[High(Result)] := AddPointToArrayFunc(Path, Possibles[i]);
Break;
end;
p := GetPossiblesForPoint(Possibles[i], Grid, Map.Possibles);
t := Length(p);
if (t = 1) and (PosLen = 1) then
begin
AddPointToArrayProc(Path, Possibles[i]);
repeat
tp := p[0];
if (tp.y = Map.ep.y) and (tp.x = Map.ep.x) then
begin
SetLength(Result, Length(Result) + 1);
Result[High(Result)] := AddPointToArrayFunc(Path, tp);
t := -123;
Break;
end;
p := GetPossiblesForPoint(tp, Grid, Map.Possibles);
t := Length(p);
if (t = 1) then
AddPointToArrayProc(Path, tp);
until (t <> 1);
if (t = -123) then
Continue;
end
else
tp := Possibles[i];
if (t > 0) then
AddNodeToArray(Nodes, Node(AddPointToArrayFunc(Path, tp), p, Grid))
{else if (Map.Possibles[tp.x][tp.y].Count > 0) then
begin
Map.Possibles[tp.x][tp.y].Count := 0;
with Map do
for t := High(Path) downto 0 do
if (Possibles[Path[t].x][Path[t].y].Count <= 2) then
Possibles[Path[t].x][Path[t].y].Count := 0
else
Break;
end};
end;
{t := Length(Nodes) - 1;
for i := 0 to t - 1 do
Nodes[i] := Nodes[i + 1];
SetLength(Nodes, t);}
Inc(c);
//until (t < 1);
end;
end;
procedure LoadStringMap(sMap: string; var Grid: TGrid; out sp, ep: TPoint);
var
x, y, t: Integer;
begin
x := -1;
y := 0;
t := 1;
for t := 1 to Length(sMap) do
begin
case sMap[t] of
'0', '1', '3', '4':
begin
Inc(x);
if (sMap[t] = '0') then
Grid[x][y] := False
else
begin
Grid[x][y] := True;
case sMap[t] of
'3': sp := Point(x, y);
'4': ep := Point(x, y);
end;
end;
end;
'2':
begin
Inc(y);
x := -1;
end;
end;
end;
end;
procedure PrepareMap(var Map: TMap);
var
x, y: Integer;
begin
for x := xGridLo to xGridHi do
for y := yGridLo to yGridHi do
with Map, Map.Possibles[x][y] do
begin
if (y > yGridLo) then
if Grid[x][y - 1] then
begin
U := True;
Inc(Count);
end;
if (y < yGridHi) then
if Grid[x][y + 1] then
begin
D := True;
Inc(Count);
end;
if (x > xGridLo) then
if Grid[x - 1][y] then
begin
L := True;
Inc(Count);
end;
if (x < xGridHi) then
if Grid[x + 1][y] then
begin
R := True;
Inc(Count);
end;
end;
end;
function CreateMapFromBoolArray(BoolMap: array of array of Boolean; s, e: TPoint): TMap;
var
x, y: Integer;
begin
if (Length(BoolMap) <> (yGridHi - yGridLo + 1)) or (Length(BoolMap[0]) <> (xGridHi - xGridLo + 1)) then
begin
WriteLn('Oops! Range error in BoolMap!');
Exit;
end;
with Result do
begin
sp := s;
ep := e;
for x := xGridHi - xGridLo downto 0 do
for y := yGridHi - yGridLo downto 0 do
Grid[x + xGridLo][y + yGridLo] := Boolmap[y][x];
end;
PrepareMap(Result);
end;
function CreateMapFromString(sMap: string): TMap;
begin
LoadStringMap(sMap, Result.Grid, Result.sp, Result.ep);
PrepareMap(Result);
end;
procedure JackJill(out Jacks_Path: TPointArray; out Jills_RouteCount: Integer; Input: array of array of Boolean; Start, Finish: TPoint);
var
Map: TMap;
p: T2DPointArray;
i, mi, ml: Integer;
begin
Map := CreateMapFromBoolArray(Input, Start, Finish);
p := GetPaths(Map);
ml := -1;
mi := -1;
Jills_RouteCount := Length(p) - 1;
for i := 0 to Jills_RouteCount do
if (Length(p[i]) > ml) then
mi := i;
if (mi > -1) then
Jacks_Path := p[mi];
end;
{$IFNDEF SCAR320_UP}
type
TBooleanArray = array of Boolean;
{$ENDIF}
var
bmp: Integer;
Canvas: TCanvas;
var
Map: TMap;
x, y, w, h: Integer;
p: T2DPointArray;
pt: TPoint;
var
t: Int64;
begin
w := ((xGridHi - xGridLo) + 1) * 12;
h := ((yGridHi - yGridLo) + 1) * 12;
bmp := BitmapFromString(w, h, '');
Canvas := GetBitmapCanvas(bmp);
FastDrawClear(bmp, clLightSteelBlue);
DisplayDebugImgWindow(w, h);
Map := CreateMapFromString(sMap);
{Map := CreateMapFromBoolArray
(
[
TBooleanArray([False, False, False, False, False]),
TBooleanArray([False, True, False, True, False]),
TBooleanArray([False, True, True, True, False]),
TBooleanArray([False, False, False, False, False])
],
Point(1, 1),
Point(3, 1)
);}
MarkTime(t);
p := GetPaths(Map);
WriteLn('Time: '+FloatToStr(TimeFromMark(t))+'ms - '+IntToStr(Length(p)));
Canvas.Brush.Color := clBlack;
Canvas.Pen.Color := clBlack;
for x := xGridLo to xGridHi do
for y := yGridLo to yGridHi do
if (not Map.Grid[x][y]) then
begin
pt := Point(x * 12, y * 12);
Canvas.Rectangle(pt.x, pt.y, pt.x + 12, pt.y + 12);
end;
t := Length(p);
for y := t - 1 downto 0 do
begin
case y mod 5 of
3: Canvas.Brush.Color := RGBtoColor(85 * (y mod 3), 255 - ((255 / t) * y), ((255 / t) * y));
0: Canvas.Brush.Color := RGBtoColor(255 - ((255 / t) * y), 85 * (y mod 3), ((255 / t) * y));
4: Canvas.Brush.Color := RGBtoColor(255 - ((255 / t) * y), ((255 / t) * y), 85 * (y mod 3));
2: Canvas.Brush.Color := RGBtoColor(((255 / t) * y), 255 - ((255 / t) * y), 85 * (y mod 3));
1: Canvas.Brush.Color := RGBtoColor(((255 / t) * y), 85 * (y mod 3), 255 - ((255 / t) * y));
end;
Canvas.Pen.Color := Canvas.Brush.Color;
for x := 0 to High(p[y]) do
begin
pt := Point(p[y][x].x * 12, p[y][x].y * 12);
Canvas.Rectangle(pt.x, pt.y, pt.x + 12, pt.y + 12);
end;
SafeDrawBitmap(bmp, GetDebugCanvas, 0, 0);
Wait(2500);
end;
SafeDrawBitmap(bmp, GetDebugCanvas, 0, 0);
FreeBitmap(bmp);
end.

Add Comment

Please, Sign In to add comment