用BFS判断在状态State中,搬运工是否可以到达Position
var
Direction:integer;
Pos,NewPos:integer;
Get,Put:integer;
Queue:array of integer;
Reached:Array of boolean;
begin
fillchar(Reached,sizeof(Reached),0);
Pos:=State.ManPosition;
Get:=0; Put:=1;
Queue:=Pos;
Reached:=true;
CanReach:=true;
while Get<>Put do
begin
Pos:=Queue;
inc(Get);
if Pos=Position then
exit;
for Direction:=0 to 3 do
begin
NewPos:=Pos+DeltaPos;
if Reached then continue;
if GetBit(State.Boxes,NewPos)>0 then continue;
if GetBit(SokoMaze.Walls,NewPos)>0 then continue;
Reached:=true;
Queue:=NewPos;
inc(Put);
end;
end;
CanReach:=false;
end;
function MinPush(BoxPosition,GoalPosition:integer):integer;
在没有其他箱子的情况下,从BoxPosition推到GoalPosition至少要多少步。
var
i:integer;
Direction:integer;
Pos,NewPos,ManPos:integer;
Get,Put:integer;
Queue:array of integer;
Distance:Array of integer;
begin
for i:=0 to Maxx*Maxy do
Distance:=Infinite;
Pos:=BoxPosition;
Get:=0; Put:=1;
Queue:=Pos;
Distance:=0;
while Get<>Put do
begin
Pos:=Queue;
inc(Get);
if Pos=GoalPosition then
begin
MinPush:=Distance;
exit;
end;
for Direction:=0 to 3 do
begin
NewPos:=Pos+DeltaPos;
ManPos:=Pos+DeltaPos];
人应该站在后面
if Distance<Infinite then continue;
if GetBit(SokoMaze.Walls,NewPos)>0 then continue;
推不动
if GetBit(SokoMaze.Walls,ManPos)>0 then continue;
人没有站的地方
Distance:=Distance+1;
Queue:=NewPos;
inc(Put);
end;
end;
MinPush:=Infinite;
end;
procedure DoMove(State:StateType; Position,Direction:integer; var NewState:Sta
teType);
var
NewPos:integer;
begin
NewState:=State;
NewPos:=Position+DeltaPos;
NewState.ManPosition:=Position;
SetBit(NewState.Boxes,NewPos);
ClearBit(NewState.Boxes,Position);
end;
function MinMatch(BoxCount:integer;Gr:BiGraph):integer; 这个是标准算法,抄的书上的程序,不用看了。
var
VeryBig:integer;
TempGr:BiGraph;
L:array of integer;
SetX,SetY,MatchedX,MatchedY:Set of 1..MaxBox;
procedure MaxMatch(n,m:integer);
function Path(x:integer):boolean;
var
i,j:integer;
begin
Path:=false;
for i:=1 to m do
if not (i in SetY)and(Gr<>0) then
begin
SetY:=SetY+;
if not (i in MatchedY) then
begin
Gr:=-Gr;
MatchedY:=MatchedY+;
Path:=true;
exit;
end;
j:=1;
while (j<=m)and not (j in SetX) and (Gr>=0) do inc(j);
if j<=m then
begin
SetX:=SetX+;
if Path(j) then
begin
Gr:=-Gr;
Gr:=-Gr;
Path:=true;
exit;
end;
end;
end;
end;
var
u,i,j,al:integer;
begin
Fillchar(L,sizeof(L),0);
TempGr:=Gr;
for i:=1 to n do
for j:=1 to m do
if L<Gr then
L:=Gr;
u:=1; MatchedX:=[]; MatchedY:=[];
for i:=1 to n do
for j:=1 to m do
if L+L=TempGr then
Gr:=1
else
Gr:=0;
while u<=n do
begin
SetX:=; SetY:=[];
if not (u in MatchedX) then
begin
if not Path(u) then
begin
al:=Infinite;
for i:=1 to n do
for j:=1 to m do
if (i in SetX) and not (j in SetY) and (L+L-TempGr<al
) then
al:=L+L-TempGr;
for i:=1 to n do if i in SetX then L:=L-al;
for i:=1 to m do if i in SetY then l:=l+al;
for i:=1 to n do
for j:=1 to m do
if l+l=TempGr then
Gr:=1
else
Gr:=0;
MatchedX:=[]; MatchedY:=[];
for i:=1 to n+m do
if l<-1000 then
exit;
end
else
MatchedX:=MatchedX+;
u:=0;
end;
inc(u);
end;
end;
var
i,j:integer;
Tot:integer;
begin
VeryBig:=0;
for i:=1 to BoxCount do
for j:=1 to BoxCount do
if (Gr<Infinite)and(Gr>VeryBig) then
VeryBig:=Gr;
inc(VeryBig);
for i:=1 to BoxCount do
for j:=1 to BoxCount do
if Gr<Infinite then
Gr:=VeryBig-Gr
else
Gr:=0;
这些语句是进行补集转化。
MaxMatch(BoxCount,BoxCount);
Tot:=0;
for i:=1 to BoxCount do
begin
for j:=1 to BoxCount do
if Gr<0 then
begin
Tot:=Tot+VeryBig-TempGr;
break;
end;
if Gr>=0 then
begin
MinMatch:=Infinite;
exit;
end;
end;
MinMatch:=Tot;
end;
function CalcHeuristicFunction(State:StateType):integer;
计算启发函数值
var
H,Min:integer;
i,j,p,Count,BoxCount,Cost:integer;
BoxPos:array of integer;
Distance:BiGraph;
begin
p:=0;
for i:=1 to MaxPosition do
if GetBit(State.Boxes,i)>0 then
begin
inc(p);
BoxPos:=i;
end;
for i:=1 to p do
for j:=1 to p do
Distance:=MinPush(BoxPos,SokoMaze.GoalPosition);
BoxCount:=SokoMaze.BoxCount;
H:=0;
for i:=1 to BoxCount do
begin
Count:=0;
for j:=1 to BoxCount do
if Distance<Infinite then
inc(Count);
if Count=0 then
有一个箱子推不到任何目的地
begin
CalcHeuristicFunction:=Infinite;
exit;
end;
end;
H:=MinMatch(BoxCount, Distance);
CalcHeuristicFunction:=H;
end;
function HashFunction(State:StateType):integer;
var
i,h,p:integer;
begin
h:=0;
p:=0;
for i:=1 to MaxPosition do
if GetBit(State.Boxes,i)>0 then
begin
inc(p);
h:=(h+p*i) mod HashMask;
你可以自己换一个
end;
HashFunction:=h;
end;
function SameState(S1,S2:StateType):boolean;
var
i:integer;
begin
SameState:=false;
for i:=1 to MaxPosition do
if GetBit(S1.Boxes,i)<>GetBit(S2.Boxes,i) then
exit;
if not CanReach(S1,S2.ManPosition) then
注意只要两个状态人的位置是相通的就应该算同一个状态
exit;
SameState:=true;
end; function Prior(State:StateType;M1,M2:MoveType):boolean;
var
NewPos:integer;
Inertia1,Inertia2:boolean;
S1,S2:StateType;
H1,H2:integer;
begin
Prior:=false;
if State.MoveCount>0 then
begin
NewPos:=State.Move.Position+
DeltaPos.Direction];
if NewPos=M1.Position then Inertia1:=true else Inertia1:=false;
连续推同一个箱子的动作优先
if NewPos=M2.Position then Inertia2:=true else Inertia2:=false;
if Inertia1 and not Inertia2 then begin Prior:=true; exit; end;
if Inertia2 and not Inertia1 then begin Prior:=false; exit; end;
end;
end;
procedure IDA_Star;
var
Sucess:boolean;
CurrentState:StateType;
H:integer;
f:Text;
procedure IDA_Push(State:StateType);
begin
if IDA.Top=MaxStack then
Exit;
inc(IDA.Top);
IDA.Stack:=State;
end;
procedure IDA_Pop(var State:StateType);
begin
State:=IDA.Stack;
dec(IDA.Top);
end;
function IDA_Empty:boolean;
begin
IDA_Empty:=(IDA.Top=0);
end;
上面的是栈操作
procedure IDA_AddToHashTable(State:StateType);
var
h:integer;
p:PHashTableEntry;
begin
h:=HashFunction(State);
if HashTable^.Count<MaxSubEntry then
begin
new(p);
p^.State:=State;
p^.Next:=HashTable^.FirstEntry;
HashTable^.FirstEntry:=p;
inc(HashTable^.Count);
end
else begin
p:=HashTable^.FirstEntry;
while p^.Next^.Next<>nil do
p:=p^.Next;
p^.Next^.State:=State;
p^.Next^.Next:=HashTable^.FirstEntry;
HashTable^.FirstEntry:=p^.Next;
p^.Next:=nil;
end;
end;
function IDA_InHashTable(State:StateType):boolean;
var
h:integer;
p:PHashTableEntry;
begin
h:=HashFunction(State);
p:=HashTable^.FirstEntry;
IDA_InHashTable:=true;
while p<>nil do
begin
if SameState(p^.State,State) then
begin
if p^.State.g>State.g then
begin
p^.State.g:=State.g;
IDA_InHashTable:=false; 如果找到的表项深度要大些,并不代表这一次深度小点的也无解。本来应该动态更新下界
的,这里作为没有找到处理,后面的章节会改进这个地方的。
end;
exit;
end;
p:=p^.Next;
end;
IDA_InHashTable:=false;
end;
这是Hash表的操作。
procedure IDA_AddNode(State:StateType);
begin
IDA_Push(State);
inc(IDA.NodeCount);
if IDA.NodeCount mod DispNode=0 then
Writeln('NodeCount=',IDA.NodeCount);
inc(IDA.TopLevelNodeCount);
IDA_AddToHashTable(State);
end;
procedure IDA_Expand(State:StateType);
var
MoveCount:integer;
MoveList:array of MoveType;
t:MoveType;
i,j,Direction:integer;
NewBoxPos, NewManPos:integer;
NewState:StateType;
begin
MoveCount:=0;
for i:=1 to MaxPosition do
if GetBit(State.Boxes,i)>0 then
for Direction:=0 to 3 do
begin
NewBoxPos:=i+DeltaPos;
NewManPos:=i+DeltaPos];
if GetBit(State.Boxes,NewBoxPos)>0 then continue;
if GetBit(SokoMaze.Walls,NewBoxPos)>0 then continue;
if GetBit(State.Boxes,NewManPos)>0 then continue;
if GetBit(SokoMaze.Walls,NewManPos)>0 then continue;
if CanReach(State,NewManPos) then
begin
DoMove(State,i,Direction,NewState);
if CalcHeuristicFunction(NewState)=Infinite then continue;
if CalcHeuristicFunction(NewState)+State.g>=IDA.PathLimit then con
tinue;
IDA*算法的核心:深度限制
if IDA_InHashTable(NewState) then continue;
inc(MoveCount);
MoveList.Position:=i;
MoveList.Direction:=Direction;
end;
end;
for i:=1 to MoveCount do
for j:=i+1 to MoveCount do
if Prior(State,MoveList,MoveList) then
调整推法次序
begin
t:=MoveList;
MoveList:=MoveList;
MoveList:=t;
end;
for i:=1 to MoveCount do
依次考虑所有移动方案
begin
DoMove(State,MoveList.Position,MoveList.Direction,NewState);
inc(NewState.MoveCount);
NewState.Move.Position:=MoveList.Position;
NewState.Move.Direction:=MoveList.Direction;
NewState.g:=State.g+1;
IDA_AddNode(NewState);
end;
end;
procedure IDA_Answer(State:StateType);
var
i:integer;
x,y:integer;
begin
Writeln(f,'Solution Found in ', State.MoveCount,' Pushes');
for i:=1 to State.Movecount do
begin
x:=State.Move.Position div SokoMaze.Y+1;
y:=State.Move.Position mod SokoMaze.Y+1;
Writeln(f, x,' ',y,' ',DirectionWords.Direction]);
end;
end;
begin
Writeln(VerStr);
Writeln(Author);
IDA.PathLimit:=CalcHeuristicFunction(IDA.StartState)-1;
Sucess:=false;
repeat
inc(IDA.PathLimit);
Writeln('Pathlimit=',IDA.PathLimit);
IDA.TopLevelNodeCount:=0;
IDA.Top:=0;
IDA.StartState.g:=0;
IDA_Push(IDA.StartState);
repeat
IDA_Pop(CurrentState);
H:=CalcHeuristicFunction(CurrentState);
if H=Infinite then continue;
if Solution(CurrentState) then
Sucess:=true
else if IDA.PathLimit>=CurrentState.g+H then
IDA_Expand(CurrentState);
until Sucess or IDA_Empty or (IDA.NodeCount>MaxNode);
Writeln('PathLimit ',IDA.PathLimit,' Finished. NodeCount=',IDA.NodeCount);
until Sucess or (IDA.PathLimit>=MaxDepth) or (IDA.NodeCount>MaxNode);
Assign(f,outfile);
ReWrite(f);
Writeln(f,VerStr);
Writeln(f,Author);
Writeln(f);
if not Sucess then
Writeln(f,'Cannot find a solution.')
else
IDA_Answer(CurrentState);
Writeln('Node Count:',IDA.NodeCount);
Writeln;
close(f);
end;
begin
Init;
IDA_Star;
end. 欣然大哥可以拉出去单独开个贴嘛~
还有链接
回复 105# 的帖子
给大家参考一下吧:handshake[ 本帖最后由 kexin_xiao 于 2009-4-30 17:26 编辑 ] 研究研究``````````` 这么强啊 有点晕了 又见金优大师的好帖了. 这也是贴? 都是一口气发的那么多的~~~~~~~~~~~~~~晕了都