智能控制作业.docx

智能控制作业.docx

《智能控制作业.docx》由会员分享，可在线阅读，更多相关《智能控制作业.docx（16页珍藏版）》请在冰豆网上搜索。

智能控制作业

一、A*寻路算法

AttributeVB_Name="mFindPath"

OptionExplicit

DimarrBap（）AsbPoint'地图状态

DimarrOpen（）AsfsPoint'开放列表

DimlOpenSizeAsLong'开放列表元素个数

DimTCountAsLong'目标序号

'※※※※　A*寻路函数※※※※※※※※※

'输入参数

'arrMap（）asfsPoint地图障碍物数据

'arrPath（）aslong路径列表

'lPathCountaslong路径长度

'pStartPointasfsPoint起始点

'pGotoPointasfsPoint目标点

'lWidthaslong地图宽度

'lHeightaslong地图高度

'输出参数

'类型:

long寻路结果

'3地图格式不正确

'2目标为障碍点

'1寻路成功

'0寻路失败无法到达

'4已经到达终点

'5目标被占

'6寻路过程中发生错误

'※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※

PublicFunctionfPath（arrMap（）AsfsPoint,arrPath（）AsLong,lPathCountAsLong,pStartPointAsfsPoint,pGotoPointAsfsPoint,lWidthAsLong,lHeightAsLong）AsLong'寻路

DimiAsLong'循环用变量

DimCountAsLong'点的序号或者总数

DimpCurrentPointAsfsPoint

DimpSearchPointAsfsPoint

DimpSearchXAsLong,pSearchYAsLong

DimtmpXAsLong,tmpYAsLong

DimarrXofs（8）AsLong,arrYofs（8）AsLong'XY变化常量数组

DimarrIofs（8）AsLong'序号变化常量数组

DimtmpOfsAsLong'序号变化量

OnErrorGoToPathErr:

'判断地图

IflWidth<1OrlHeight<1Then

fPath=3'地图数据不正确

ExitFunction

EndIf

'TCount=pGotoPoint.Y*lWidth+pGotoPoint.X'目标序号

TCount=pGotoPoint.Index

'判断是否为障碍物

IfpGotoPoint.Y>lHeight-1OrpGotoPoint.X>lWidth-1Then

fPath=2

ExitFunction

EndIf

IfarrMap（TCount）.BOrarrMap（TCount）.DThen

'可以通过或者是门点

fPath=0

Else'否则退出寻路

fPath=2

ExitFunction

EndIf

IfarrMap（TCount）.lNpcId<>0Then

fPath=5

ExitFunction

EndIf

IfpGotoPoint.Y=pStartPoint.YAndpGotoPoint.X=pStartPoint.XThen

fPath=4

ExitFunction

EndIf

'设置常数数组该数组决定了寻路的优先顺序

arrXofs（0）=-1

arrXofs

（1）=1

arrXofs

（2）=-1

arrXofs（3）=1

arrXofs（4）=-1

arrXofs（5）=1

arrXofs（6）=0

arrXofs（7）=0

arrYofs（0）=-1

arrYofs

（1）=1

arrYofs

（2）=1

arrYofs（3）=-1

arrYofs（4）=0

arrYofs（5）=0

arrYofs（6）=-1

arrYofs（7）=1

tmpOfs=0-lWidth

arrIofs（0）=tmpOfs-1

arrIofs

（1）=lWidth+1

arrIofs

（2）=lWidth-1

arrIofs（3）=tmpOfs+1

arrIofs（4）=-1

arrIofs（5）=1

arrIofs（6）=tmpOfs

arrIofs（7）=lWidth

'初始化数据

Count=lWidth*lHeight'地图总点数

ReDimarrBap（Count）

'清空所有需要用到的列表

ReDimarrOpen（Count）

'起始点进入开放列表

Count=pStartPoint.Y*lWidth+pStartPoint.X

pStartPoint.Index=Count

tmpX=Abs（pStartPoint.X-pGotoPoint.X）

tmpY=Abs（pStartPoint.Y-pGotoPoint.Y）

pStartPoint.G=0

IftmpX>tmpYThen

pStartPoint.H=tmpX

Else

pStartPoint.H=tmpY

EndIf

pStartPoint.F=pStartPoint.G+pStartPoint.H

arrBap（Count）.Parent=0

arrBap（Count）.aIndex=1

arrOpen

（1）=pStartPoint

lOpenSize=1

DoWhilelOpenSize>0

pCurrentPoint=pBinaryHeapDelete（）

Count=pCurrentPoint.Index

arrBap（Count）.bClose=True

arrBap（Count）.aIndex=0

Fori=0To7

pSearchPoint.X=pCurrentPoint.X+arrXofs（i）

pSearchPoint.Y=pCurrentPoint.Y+arrYofs（i）

Count=pCurrentPoint.Index+arrIofs（i）

pSearchPoint.Index=Count

IfCount=TCountThen'就是终点

arrBap（Count）.Parent=pCurrentPoint.Index

'保存路径

lPathCount=-1

DoWhilearrBap（Count）.Parent<>0

lPathCount=lPathCount+1

arrPath（lPathCount）=Count

Count=arrBap（Count）.Parent

Loop

'起始点放入最后

arrPath（lPathCount+1）=Count

fPath=1

ExitFunction

Else

IfarrMap（Count）.BAndarrMap（Count）.lNpcId=0Then'不是障碍点

IfNotarrBap（Count）.bCloseThen'不在关闭列表

pSearchPoint.G=pCurrentPoint.G+1

tmpX=Abs（pSearchPoint.X-pGotoPoint.X）

tmpY=Abs（pSearchPoint.Y-pGotoPoint.Y）

pStartPoint.G=0

IftmpX>tmpYThen

pSearchPoint.H=tmpX

Else

pSearchPoint.H=tmpY

EndIf

pSearchPoint.F=pSearchPoint.G+pSearchPoint.H

IfarrBap（Count）.aIndex<>0Then

IfpSearchPoint.F

'更新开放列表

arrBap（Count）.Parent=pCurrentPoint.Index

pBinaryHeapUpdatearrBap（Count）.aIndex

EndIf

Else'加入到开放列表

pBinaryHeapAddpSearchPoint

arrBap（Count）.Parent=pCurrentPoint.Index

EndIf

EndIf

EndIf

EndIf

Next

Loop

ExitFunction

PathErr:

fPath=6

EndFunction

'增加一个值到末尾并重新排序

PrivateSubpBinaryHeapAdd（pAddPointAsfsPoint）

DimlParentIndexAsLong

DimlSelectIndexAsLong

DimtmpPointAsfsPoint

lOpenSize=lOpenSize+1

arrOpen（lOpenSize）=pAddPoint

arrBap（arrOpen（lOpenSize）.Index）.aIndex=lOpenSize

lSelectIndex=lOpenSize

DoWhileTrue

lParentIndex=Int（lSelectIndex/2）

IflParentIndex>0Then

IfarrOpen（lSelectIndex）.F<=arrOpen（lParentIndex）.FThen

'比父节点F值小交换

tmpPoint=arrOpen（lSelectIndex）

arrOpen（lSelectIndex）=arrOpen（lParentIndex）

arrOpen（lParentIndex）=tmpPoint

arrBap（arrOpen（lSelectIndex）.Index）.aIndex=lParentIndex

arrBap（arrOpen（lParentIndex）.Index）.aIndex=lSelectIndex

lSelectIndex=lParentIndex

Else'比父节点F值大不处理

ExitDo

EndIf

Else'无父节点走人

ExitDo

EndIf

Loop

EndSub

'取出第一个值并重新排序

PrivateFunctionpBinaryHeapDelete（）AsfsPoint

DimtmpResultAsfsPoint

DimtmpPointAsfsPoint

DimlSelectIndexAsLong

DimlLeftChildIndexAsLong

DimlRightChildIndexAsLong

tmpResult=arrOpen

（1）

lOpenSize=lOpenSize-1

'把最后一个点移动到最前面

IflOpenSize>0Then

arrOpen

（1）=arrOpen（lOpenSize+1）

lSelectIndex=1

arrBap（arrOpen（lSelectIndex）.Index）.aIndex=lSelectIndex

'比较子节点

DoWhileTrue

lLeftChildIndex=lSelectIndex*2

lRightChildIndex=lLeftChildIndex+1

IflLeftChildIndex>lOpenSizeThen

'没有左子节点则结束

ExitDo

Else

IflLeftChildIndex=lOpenSizeThen'只有左子节点

IfarrOpen（lSelectIndex）.F>arrOpen（lLeftChildIndex）.FThen'父节点F值大则交换

tmpPoint=arrOpen（lSelectIndex）

arrOpen（lSelectIndex）=arrOpen（lLeftChildIndex）

arrOpen（lLeftChildIndex）=tmpPoint

arrBap（arrOpen（lSelectIndex）.Index）.aIndex=lLeftChildIndex

arrBap（arrOpen（lLeftChildIndex）.Index）.aIndex=lSelectIndex

lSelectIndex=lLeftChildIndex

Else'父节点比子节点F值小则结束

ExitDo

EndIf

Else

IflRightChildIndex<=lOpenSizeThen

IfarrOpen（lLeftChildIndex）.F<=arrOpen（lRightChildIndex）.FThen'左边F值小

IfarrOpen（lSelectIndex）.F>arrOpen（lLeftChildIndex）.FThen'父节点F值大则交换

tmpPoint=arrOpen（lSelectIndex）

arrOpen（lSelectIndex）=arrOpen（lLeftChildIndex）

arrOpen（lLeftChildIndex）=tmpPoint

arrBap（arrOpen（lSelectIndex）.Index）.aIndex=lLeftChildIndex

arrBap（arrOpen（lLeftChildIndex）.Index）.aIndex=lSelectIndex

lSelectIndex=lLeftChildIndex

Else'父节点比子节点F值小则结束

ExitDo

EndIf

Else

IfarrOpen（lSelectIndex）.F>arrOpen（lRightChildIndex）.FThen'父节点F值大则交换

tmpPoint=arrOpen（lSelectIndex）

arrOpen（lSelectIndex）=arrOpen（lRightChildIndex）

arrOpen（lRightChildIndex）=tmpPoint

arrBap（arrOpen（lSelectIndex）.Index）.aIndex=lRightChildIndex

arrBap（arrOpen（lRightChildIndex）.Index）.aIndex=lSelectIndex

lSelectIndex=lRightChildIndex

Else'父节点比子节点F值小则结束

ExitDo

EndIf

EndIf

EndIf

EndIf

EndIf

Loop

EndIf

pBinaryHeapDelete=tmpResult

EndFunction

'更新一个点并重新排序

PrivateSubpBinaryHeapUpdate（IndexAsLong）

DimlParentIndexAsLong

DimlSelectIndexAsLong

DimtmpPointAsfsPoint

lSelectIndex=Index

DoWhileTrue

lParentIndex=Int（lSelectIndex/2）

IflParentIndex>0Then

IfarrOpen（lSelectIndex）.F

'比父节点F值小交换

tmpPoint=arrOpen（lSelectIndex）

arrOpen（lSelectIndex）=arrOpen（lParentIndex）

arrOpen（lParentIndex）=tmpPoint

arrBap（arrOpen（lSelectIndex）.Index）.aIndex=lParentIndex

arrBap（arrOpen（lParentIndex）.Index）.aIndex=lSelectIndex

lSelectIndex=lParentIndex

Else'比父节点F值大不处理

ExitDo

EndIf

Else'无父节点走人

ExitDo

EndIf

Loop

EndSub

'加载地图数据

PublicSubpAddMapData（lMapDataIDAsLong,strMsgAsString）

DimbytChar（）AsByte

DimMapFileAsString

DimiLenAsLong

DimiAsLong,jAsLong

DimmAsLong,iCountAsLong

DimiMapWidthAsLong

DimiMapHeightAsLong

MapFile=App.Path&"\Data\cMap\"&strMsg&".dat"

OpenMapFileForBinaryAs#2

iLen=LOF

（2）

IfiLen>0Then

ReDimbytChar（iLen-1）

Get#2,1,bytChar（）

Close#2

iMapHeight=Val（GetValue（"Index_"&strMsg,"Height",fMapSet））

iMapWidth=Val（GetValue（"Index_"&strMsg,"Width",fMapSet））

nMap（lMapDataID）.lWidth=iMapWidth

nMap（lMapDataID）.lHeight=iMapHeight

nMap（lMapDataID）.lDataSize=iMapWidth*iMapHeight

IfnMap（lMapDataID）.lDataSize<>iLenThenExitSub'地图数据不正确

ReDimnMap（lMapDataID）.cMapData（nMap（lMapDataID）.lDataSize-1）

iCount=-1

Fori=0ToiMapHeight-1

Forj=0ToiMapWidth-1

iCount=iCount+1

nMap（lMapDataID）.cMapData（iCount）.X=j

nMap（lMapDataID）.cMapData（iCount）.Y=i

IfbytChar（iCount）=0Then

nMap（lMapDataID）.cMapData（iCount）.B=False

Else

nMap（lMapDataID）.cMapData（iCount）.B=True

EndIf

Next

Next

nMap（lMapDataID）.bData=True

'读取固定门点

DimarrData（）AsString

DimbrrData（）AsString

strMsg=GetValue（"bDoor",CStr（lMapDataID）,fMapSet）

arrData=Split（strMsg,"_"）

Form=0ToUBound（arrData）

brrData=Split（arrData（m）,","）

IfUBound（brrData）>0Then

i=CLng（brrData

（1））

j=CLng（brrData（0））

iCount=iMapWidth*i+j

nMap（lMapDataID）.cMapData（iCount）.B=False

nMap（lMapDataID）.cMapData（iCount）.D=True

EndIf

Next

'读取死点

strMsg=GetValue（"bFault",CStr（lMapDataID）,fMapSet）

arrData=Split（strMsg,"_"）

Form=0ToUBound（arrData）

brrData=Split（arrData（m）,","）

IfUBound（brrData）>0Then

i=CLng（brrData

（1））

j=CLng（brrData（0））

iCount=iMapWidth*i+j

nMap（lMapDataID）.cMapData（iCount）.B=False

EndIf

Next

'读取活点

strMsg=GetValue（"bThrough",CStr（lMapDataID）,fMapSet）

arrData=Split（strMsg,"_"）

Form=0ToUBound（arrData）

brrData=Split（arrData（m）,","）

IfUBound（brrData）>0Then

i=CLng（brrData

（1））

j=CLng（brrData（0））

iCount=iMapWidth*i+j

nMap（lMapDataID）.cMapData（iCount）.B=True

EndIf

Next

Else

Close#2

ExitSub