【讨论】xsokoban共90题

kexin_xiao

function   CanReach(State:StateType;   Position:integer):boolean;   
  用BFS判断在状态State中，搬运工是否可以到达Position   
  var   
      Direction:integer;   
      Pos,NewPos:integer;   
      Get,Put:integer;   
      Queue:array[0..Maxx*Maxy]   of   integer;   
      Reached:Array[0..Maxx*Maxy]   of   boolean;   
  begin   
      fillchar(Reached,sizeof(Reached),0);   
      Pos:=State.ManPosition;   
      Get:=0;   Put:=1;   
      Queue[0]:=Pos;   
      Reached[Pos]:=true;   
      CanReach:=true;   
      while   Get<>Put   do   
      begin   
          Pos:=Queue[Get];   
          inc(Get);   
          if   Pos=Position   then   
              exit;   
          for   Direction:=0   to   3   do   
          begin   
              NewPos:=Pos+DeltaPos[Direction];   
              if   Reached[NewPos]   then   continue;   
              if   GetBit(State.Boxes,NewPos)>0   then   continue;   
              if   GetBit(SokoMaze.Walls,NewPos)>0   then   continue;   
              Reached[NewPos]:=true;   
              Queue[Put]:=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[0..Maxx*Maxy]   of   integer;   
      Distance:Array[0..Maxx*Maxy]   of   integer;   
  begin   
      for   i:=0   to   Maxx*Maxy   do   
          Distance:=Infinite;   
      Pos:=BoxPosition;   
      Get:=0;   Put:=1;   
      Queue[0]:=Pos;   
      Distance[Pos]:=0;   
      while   Get<>Put   do   
      begin   
          Pos:=Queue[Get];   
          inc(Get);   
          if   Pos=GoalPosition   then   
          begin   
              MinPush:=Distance[Pos];   
              exit;   
          end;   
          for   Direction:=0   to   3   do   
          begin   
              NewPos:=Pos+DeltaPos[Direction];   
              ManPos:=Pos+DeltaPos[Opposite[Direction]];   
              人应该站在后面   
  if   Distance[NewPos]<Infinite   then   continue;   
              if   GetBit(SokoMaze.Walls,NewPos)>0   then   continue;   
              推不动   
              if   GetBit(SokoMaze.Walls,ManPos)>0   then   continue;   
              人没有站的地方   
              Distance[NewPos]:=Distance[Pos]+1;   
              Queue[Put]:=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[Direction];   
      NewState.ManPosition:=Position;   
      SetBit(NewState.Boxes,NewPos);   
      ClearBit(NewState.Boxes,Position);   
  end;   
  function   MinMatch(BoxCount:integer;Gr:BiGraph):integer;

kexin_xiao

这个是标准算法，抄的书上的程序，不用看了。   
  var   
      VeryBig:integer;   
      TempGr:BiGraph;   
      L:array[1..MaxBox*2]   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[x,i]<>0)   then   
          begin   
              SetY:=SetY+;   
              if   not   (i   in   MatchedY)   then   
              begin   
                  Gr[x,i]:=-Gr[x,i];   
                  MatchedY:=MatchedY+;   
                  Path:=true;   
                  exit;   
              end;   
              j:=1;   
              while   (j<=m)and   not   (j   in   SetX)   and   (Gr[j,i]>=0)   do   inc(j);   
              if   j<=m   then   
              begin   
                  SetX:=SetX+[j];   
                  if   Path(j)   then   
                  begin   
                      Gr[x,i]:=-Gr[x,i];   
                      Gr[j,i]:=-Gr[j,i];   
                      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[i,j]   then   
                  L:=Gr[i,j];   
      u:=1;   MatchedX:=[];   MatchedY:=[];   
      for   i:=1   to   n   do   
          for   j:=1   to   m   do   
              if   L+L[n+j]=TempGr[i,j]   then   
                  Gr[i,j]:=1   
              else   
                  Gr[i,j]:=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[n+j]-TempGr[i,j]<al   
  )   then   
                              al:=L+L[n+j]-TempGr[i,j];   
                  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[n+i]:=l[n+i]+al;   
                  for   i:=1   to   n   do   
                      for   j:=1   to   m   do   
                          if   l+l[n+j]=TempGr[i,j]   then   
                              Gr[i,j]:=1   
                          else   
                              Gr[i,j]:=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[i,j]<Infinite)and(Gr[i,j]>VeryBig)   then   
                  VeryBig:=Gr[i,j];   
      inc(VeryBig);   
      for   i:=1   to   BoxCount   do   
          for   j:=1   to   BoxCount   do   
              if   Gr[i,j]<Infinite   then   
                  Gr[i,j]:=VeryBig-Gr[i,j]   
              else   
                  Gr[i,j]:=0;   
      这些语句是进行补集转化。   
      MaxMatch(BoxCount,BoxCount);   
      Tot:=0;   
      for   i:=1   to   BoxCount   do   
      begin   
          for   j:=1   to   BoxCount   do   
              if   Gr[i,j]<0   then   
              begin   
                  Tot:=Tot+VeryBig-TempGr[i,j];   
                  break;   
              end;   
          if   Gr[i,j]>=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[1..MaxBox]   of   integer;   
      Distance:BiGraph;   
  begin   
      p:=0;   
      for   i:=1   to   MaxPosition   do   
          if   GetBit(State.Boxes,i)>0   then   
          begin   
              inc(p);   
              BoxPos[p]:=i;   
          end;   
      for   i:=1   to   p   do   
          for   j:=1   to   p   do   
              Distance[i,j]:=MinPush(BoxPos,SokoMaze.GoalPosition[j]);   
      BoxCount:=SokoMaze.BoxCount;   
      H:=0;   
      for   i:=1   to   BoxCount   do   
      begin   
          Count:=0;   
          for   j:=1   to   BoxCount   do   
              if   Distance[i,j]<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;

kexin_xiao

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[State.MoveCount].Position+   
                          DeltaPos[State.Move[State.MoveCount].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[IDA.Top]:=State;   
      end;   
      procedure   IDA_Pop(var   State:StateType);   
      begin   
          State:=IDA.Stack[IDA.Top];   
          dec(IDA.Top);   
      end;   
      function   IDA_Empty:boolean;   
      begin   
          IDA_Empty:=(IDA.Top=0);   
      end;   
  上面的是栈操作   
      procedure   IDA_AddToHashTable(State:StateType);   
      var   
          h:integer;   
          pHashTableEntry;   
      begin   
          h:=HashFunction(State);   
          if   HashTable^.Count[h]<MaxSubEntry   then   
          begin   
              new(p);   
              p^.State:=State;   
              p^.Next:=HashTable^.FirstEntry[h];   
              HashTable^.FirstEntry[h]:=p;   
              inc(HashTable^.Count[h]);   
          end   
          else   begin   
              p:=HashTable^.FirstEntry[h];   
              while   p^.Next^.Next<>nil   do   
                  p:=p^.Next;   
              p^.Next^.State:=State;   
              p^.Next^.Next:=HashTable^.FirstEntry[h];   
              HashTable^.FirstEntry[h]:=p^.Next;   
              p^.Next:=nil;   
          end;   
      end;   
  function   IDA_InHashTable(State:StateType):boolean;   
      var   
          h:integer;   
          pHashTableEntry;   
      begin   
          h:=HashFunction(State);   
          p:=HashTable^.FirstEntry[h];   
          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;

kexin_xiao

如果找到的表项深度要大些，并不代表这一次深度小点的也无解。本来应该动态更新下界   
  的，这里作为没有找到处理，后面的章节会改进这个地方的。   
                  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[1..Maxx*Maxy*4]   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[Direction];   
                      NewManPos:=i+DeltaPos[Opposite[Direction]];   
                      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[MoveCount].Position:=i;   
                          MoveList[MoveCount].Direction:=Direction;   
                      end;   
                  end;   
          for   i:=1   to   MoveCount   do   
              for   j:=i+1   to   MoveCount   do   
                  if   Prior(State,MoveList,MoveList[j])   then   
                  调整推法次序   
                  begin   
                      t:=MoveList[j];   
                      MoveList[j]:=MoveList;   
                      MoveList:=t;   
                  end;   
          for   i:=1   to   MoveCount   do   
          依次考虑所有移动方案   
          begin   
              DoMove(State,MoveList.Position,MoveList.Direction,NewState);   
              inc(NewState.MoveCount);   
              NewState.Move[NewState.MoveCount].Position:=MoveList.Position;   
              NewState.Move[NewState.MoveCount].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[State.Move.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.

tonylmd

欣然大哥可以拉出去单独开个贴嘛~
还有链接

kexin_xiao

给大家参考一下吧

[ 本帖最后由 kexin_xiao 于 2009-4-30 17:26 编辑 ]

↖____約啶。

研究研究```````````

鬼手L

这么强啊   有点晕了

Atato

又见金优大师的好帖了.

crazy88me

这也是贴？    都是一口气发的那么多的~~~~~~~~~~~~~~晕了都