;Balls in a line
;with A-Star panth find
;2023.6
EnableExplicit
#wd=65 ;width
#Xc=20
#Yc=20
#obstruct = 1
#channel = 0
#BallsCount=10
DeclareModule LinearlySpacedValue
Declare.f Float(IncrementID.l, IncrementMax.l, MinValue.f, MaxValue.f)
EndDeclareModule
Module LinearlySpacedValue
Procedure.f Float(IncrementID.l, IncrementMax.l, MinValue.f, MaxValue.f)
ProcedureReturn ((MinValue) + ((MaxValue) - (MinValue)) * ((IncrementID) / (IncrementMax)))
EndProcedure
EndModule
Structure AStarNode
pos.Point ;该节点的坐标
father.Point
G.i
H.i
style.i ;类型，是否可行走
EndStructure
Declare.i AStar()
Declare AddOpenList(*pos.AStarNode)
Declare DelOpenList(*pos.AStarNode)
Declare AddCloseList(*pos.AStarNode)
Declare Neighbor_Search(*minFP.AStarNode,offsetX.i, offsetY.i)
Declare.i CheckCloseNode(*node.AStarNode)
Declare.i CheckNode(*node.AStarNode)
Declare CreateAStarMap(Array maps.i(2),*endP.AStarNode)
Declare CreateNew()
Declare showScore()
Declare endGame()
Declare MakeBalls(ImagesID)
Declare OnBtLeftClick()
Declare OnBtCPLeftClick()
Declare OnBtCMLeftClick()
Declare DrawMap()
Global OpenNum.i ;开启列表中的总结点数-1
Global CloseNum.i ;关闭列表中的总结点数-1
Define ArrLength.l ;数组长度
Global minX.i,minY.i,maxX.i,maxY.i,soundon.b,quit.b
;计算出来的地图尺寸
minX=1
minY=1
maxX=10;#Xc
maxY=10;#Yc
soundon=#True
Global Dim balls(10,10),Score.i,TotalBall.i
Global Dim MColor(4),PenColor,Choise.i,starts.i=0,ends.i=0
Global Dim TotalB.i(4),c.i,txtFile$="line.ini"
Global Dim AdressX.i(4,10) ,Dim AdressY.i(4,10),Undo.b
Global Dim Dx.i(8),Dim Dy.i(8),Midiv.i,Exitit.b, OrignX.i,OrignY.i
Global Dim name.s(10),Dim scores.w(10)
Dx(1)=1:Dy(1)=1
Dx(2)=1:Dy(2)=0
Dx(3)=1:Dy(3)=-1
Dx(4)=0:Dy(4)=-1
Dx(5)=-1:Dy(5)=-1
Dx(6)=-1:Dy(6)=0
Dx(7)=-1:Dy(7)=1
Dx(8)=0:Dy(8)=1
MColor(1)=$00A000 ;green
MColor(2)=$F00000 ;blue
MColor(3)=$0000F0 ;red
MColor(4)=$00CCFF ;yellow
PenColor=MColor(1)
Choise=1
quit=#False
ArrLength = (maxX - minX) * (maxY - minY) - 1
Global Dim OpenList.AStarNode(ArrLength) ;开启表
Global Dim CloseList.AStarNode(ArrLength) ;关闭表
Global Dim AStarMap.AStarNode(maxX,maxY) ;地图
Global Dim maps.i(maxX,maxY)
Global AstartP.AStarNode ;起点
Global AendP.AStarNode ;终点
;参数：要寻路的二维地图,寻路起点,寻路终点
;返回值：1找到路径，路径存在AStarPath中 0未找到路径
Global Dim AStarPath.Point(ArrLength) ;路径
Global PathLength.i ;路径长度
Define k.i,Event,t.i,i.i,j.i,li.w
Define X.i,Y.i,XN.i,YN.i,oldSX,oldSY
UsePNGImageDecoder()
For i=1 To #BallsCount
MakeBalls(i)
Next i
If InitSound() = 0
MessageRequester("Error", "Sound card is not available", 0)
End
EndIf
LoadSound(0, "dianji.wav")
LoadSound(1, "piked.wav")
LoadSound(2, "xiaochu.wav")
LoadSound(3, "shibai.wav")
LoadFont (0, "Courier", 32)
PlaySound(2,0)
If OpenWindow(0, 100, 100, 1024, 768, "PureBasic - Balls in a line", #PB_Window_SystemMenu|#PB_Window_ScreenCentered|#PB_Window_MinimizeGadget)
FrameGadget(11, 35, 15,95, 50, "选项")
CheckBoxGadget(12,50,40,40,20,"声音")
SetGadgetState(12, 1) ; set active one
ButtonGadget(13,40,85,80,30,"Quit")
ButtonGadget(14,40,145,80,30,"New Game")
FrameGadget(15, 855, 15,160,200, "Billbord")
EditorGadget(16,860,30,155,180)
TextGadget(20,180,20,100,20,"")
TextGadget(21,310,10,400,40,"")
BindGadgetEvent(12, @OnBtLeftClick(),#PB_EventType_LeftClick) ; Bind left click
BindGadgetEvent(13, @OnBtCPLeftClick(),#PB_EventType_LeftClick)
BindGadgetEvent(14, @OnBtCMLeftClick(),#PB_EventType_LeftClick)
CanvasGadget(0, 180, 70, 651, 651);plant
OnBtCMLeftClick()
Repeat
Event = WaitWindowEvent()
If Event = #PB_Event_Gadget And EventGadget() = 0
If EventType() = #PB_EventType_LeftButtonDown Or (EventType() = #PB_EventType_MouseMove And GetGadgetAttribute(0, #PB_Canvas_Buttons) & #PB_Canvas_LeftButton)
x = GetGadgetAttribute(0, #PB_Canvas_MouseX)
y = GetGadgetAttribute(0, #PB_Canvas_MouseY)
showScore()
If (x<650 And x>0) And (y<3650 And y>0)
XN=Int(x/#wd)+1
YN=Int(y/#wd)+1
SetGadgetText(20,Str(XN)+" - " +Str(YN) + " * "+Str(balls(XN,YN)))
;c=0
If balls(xN,yN)<>0
If soundon
PlaySound(0,0)
EndIf
If c=0 ;first pick
StartDrawing(CanvasOutput(0))
Circle(xn*#wd-#wd/2,yn*#wd-#wd/2,31)
DrawingMode(#PB_2DDrawing_AllChannels)
DrawAlphaImage(ImageID(balls(xn,yn)),(xn-1)*#wd+3,(yn-1)*#wd+3)
StopDrawing()
oldSX=xn
oldSY=yn
c=1
Else
StartDrawing(CanvasOutput(0))
Box(oldSX*#wd-#wd+1,oldSY*#wd-#wd+1,64,64,MColor(1))
Circle(xn*#wd-#wd/2,yn*#wd-#wd/2,31)
DrawingMode(#PB_2DDrawing_AllChannels)
DrawAlphaImage(ImageID(balls(xn,yn)),(xn-1)*#wd+3,(yn-1)*#wd+3)
DrawAlphaImage(ImageID(balls(oldSX,oldSY)),oldSX*#wd-#wd+3,oldSY*#wd-#wd+3)
StopDrawing()
oldSX=xn
oldSY=yn
c=1
EndIf
EndIf
If balls(XN,YN)=0 And c=1
AstartP\pos\x=XN
AstartP\pos\y=YN
AendP\pos\x=oldSX
AendP\pos\y=oldSY
For i=1 To 10
For j=1 To 10
maps(i,j)=balls(i,j)
Next j
Next i
maps(oldSX,oldSY)=#channel
maps(XN,YN)=#channel
If AStar()
balls(Xn,Yn)=balls(oldSX,oldSY)
balls(oldSX,oldSY)=0
For i=1 To PathLength-1
StartDrawing(CanvasOutput(0))
DrawingMode(#PB_2DDrawing_AllChannels)
DrawAlphaImage(ImageID(balls(Xn,Yn)),AStarPath(i)\x*#WD-#WD+1,AStarPath(i)\y*#WD-#WD+1)
StopDrawing()
Delay(40)
StartDrawing(CanvasOutput(0))
Box(AStarPath(i)\x*#WD-#WD+1,AStarPath(i)\y*#WD-#WD+1,64,64,MColor(1))
StopDrawing()
Next i
StartDrawing(CanvasOutput(0))
Box(oldSX*#wd-#wd+1,oldSY*#wd-#wd+1,64,64,MColor(1))
;DrawingMode(#PB_2DDrawing_AlphaBlend)
DrawAlphaImage(ImageID(balls(xn,yn)),xn*#wd-#wd+3,yn*#wd-#wd+3)
StopDrawing()
If soundon
PlaySound(1,0)
EndIf
oldSX=xn
oldSY=yn
Undo=#True
Gosub Isaline
If Undo
For i=1 To 3
If TotalBall<100
createnew()
TotalBall+1
Gosub Isaline
EndIf
Next i
EndIf
c=0
showScore()
Else
If soundon
PlaySound(3,0)
EndIf
EndIf
EndIf
If TotalBall=100
EndGame()
EndIf
EndIf
EndIf
If quit
Break
EndIf
EndIf
Until Event = #PB_Event_CloseWindow ; If the user has pressed on the close button
EndIf
End
Procedure.i AStar()
Protected p.Point ;指针
Protected minFP.AStarNode ;最小F值的节点
Protected i.i ;找最小F值For循环的循环变量
Protected Result=0
;初始化
OpenNum = -1: CloseNum = -1
PathLength = 0
Protected t.i=1
CreateAStarMap(maps(),@AendP) ;根据游戏地图创建本次寻路的A星地图
AddOpenList(@AstartP) ;将起点加入开启表
Repeat
If OpenNum = -1
Result = 0
Break ;当开启列表为空时，退出循环（没有找到路径）
EndIf
;把开启列表中G H值最小的点找出来（有多个相同最小值的话，找出靠前的那个）
minFP = OpenList(0)
For i = 0 To OpenNum
If minFP\G + minFP\H > OpenList(i)\G + OpenList(i)\H ;找数组中最小数
minFP = OpenList(i)
EndIf
Next i
;把这个点从开启列表中删除，加入到关闭列表
DelOpenList(@minFP)
AddCloseList(@minFP)
;搜索该点的邻居
Neighbor_Search(@minFP,0,-1) ;上
Neighbor_Search(@minFP, 0, 1) ;下
Neighbor_Search(@minFP,-1, 0) ;左
Neighbor_Search(@minFP, 1, 0) ;右
If CheckCloseNode(@AendP) = #True ;如果终点在关闭列表中，就说明找到了通路，用回溯的方法记录路径
Result = 1
;寻找回路
p = AendP\pos
Repeat
AStarPath(PathLength) = p
PathLength = PathLength + 1
p = AStarMap(p\x,p\y)\father ;指针移动
If p\X = AstartP\pos\x And p\Y = AstartP\pos\y
Break
EndIf
Until t=0
Break
EndIf
Until OpenNum=-1
ProcedureReturn Result
;Debug.Print AStarMap(0, 0).H: Debug.Print AStarMap(1, 1).H
EndProcedure
;根据游戏地图创建AStar的寻路地图
Procedure CreateAStarMap(Array maps.i(2), *endP.AStarNode)
Protected x.i, y.i
;ReDim AStarMap(maxX - minX, maxY - minY) '根据游戏地图确定寻路地图尺寸
;生成寻路地图
For X = minX To maxX
For Y = minY To maxY
If Maps(X, Y) > 0
AStarMap(X, Y)\style = #obstruct
AStarMap(X, Y)\G = 0 ;初始化成0，到需要的时候再重新计算
AStarMap(X, Y)\H = (Abs(X - *endP\pos\X) + Abs(Y - *endP\pos\Y)) * 10 ;对于相同的起点和终点，H为定值，我们需要在这里一次性计算好(曼哈顿距离)
AStarMap(X, Y)\pos\X = X
AStarMap(X, Y)\pos\Y = Y
ElseIf Maps(X, Y) =0
AStarMap(X, Y)\style = #channel
AStarMap(X, Y)\G = 0
AStarMap(X, Y)\H = (Abs(X - *endP\pos\X) + Abs(Y - *endP\pos\Y)) * 10
AStarMap(X, Y)\pos\X = X
AStarMap(X, Y)\pos\Y = Y
EndIf
Next Y
Next X
EndProcedure
;参数：需要添加进来的节点（添加在线性表的尾部）
Procedure AddOpenList(*pos.AStarNode)
;Debug OpenNum
OpenNum = OpenNum + 1 ;总节点数 1
;OpenList(OpenNum)=*pos;添加节点
OpenList(OpenNum)\father=*pos\father
OpenList(OpenNum)\G=*pos\G
OpenList(OpenNum)\H=*pos\H
OpenList(OpenNum)\pos=*pos\pos
OpenList(OpenNum)\style=*pos\style
EndProcedure
;参数：需要删除的节点（删除后，将线性表尾部节点补充到删除后的空缺位置，为了减小时间复杂度）
Procedure DelOpenList(*pos.AStarNode)
Protected t.AStarNode ;临时节点，用于做变量交换
Protected c.AStarNode ;临时节点，用于清空对象
Protected i.i
For i = 0 To OpenNum
If OpenList(i)\pos\X =*pos\pos\X And OpenList(i)\pos\Y =*pos\pos\Y ;找到要删除的节点（目标节点）
t = OpenList(OpenNum) ;t指向开启表中最后一个节点
OpenList(OpenNum) = c ;删除最后一个节点
OpenList(i) = t ;把最后一个节点覆盖到目标节点
OpenNum = OpenNum - 1 ;开启表长度-1
Break ;结束不必要的循环
EndIf
Next i
EndProcedure
;参数：需要添加进来的节点（添加在线性表的尾部）
Procedure.i AddCloseList(*pos.AStarNode)
CloseNum = CloseNum + 1 ;总节点数 1
;CloseList(CloseNum) =*pos ;添加节点
CloseList(CloseNum)\father=*pos\father
CloseList(CloseNum)\G=*pos\G
CloseList(CloseNum)\H=*pos\H
CloseList(CloseNum)\pos=*pos\pos
CloseList(CloseNum)\style=*pos\style
EndProcedure
;确认传入节点是否存在于开启表中
Procedure.i CheckNode(*node.AStarNode)
Protected i.i
Protected Result=#False
For i = 0 To OpenNum
If OpenList(i)\pos\X =*node\pos\X And OpenList(i)\pos\Y =*node\pos\Y ;找到了
Result = #True
Break
EndIf
Next i
If i>OpenNum
Result = #False
EndIf
ProcedureReturn Result
EndProcedure
;确认是否在关闭表里
Procedure CheckCloseNode(*node.AStarNode)
Protected i.i
Protected Result=#False
For i = 0 To CloseNum
If CloseList(i)\pos\X =*node\pos\X And CloseList(i)\pos\Y =*node\pos\Y ;找到了
Result =#True
Break
EndIf
Next i
If i>CloseNum
Result = #False
EndIf
ProcedureReturn Result
EndProcedure
;功能：
;更新开启表中的G值
Procedure UpdataG()
Protected i.i
For i = 0 To OpenNum
If OpenList(i)\G <> AStarMap(OpenList(i)\pos\X, OpenList(i)\pos\Y)\G
OpenList(i)\G = AStarMap(OpenList(i)\pos\X, OpenList(i)\pos\Y)\G
EndIf
Next i
EndProcedure
Procedure Neighbor_Search(*minFP.AStarNode,offsetX.i, offsetY.i)
Protected AStep.i
;越界检测
If *minFP\pos\X + offsetX >maxX Or *minFP\pos\X + offsetX < 1 Or *minFP\pos\Y + offsetY >maxY Or *minFP\pos\Y + offsetY < 1
Goto exit1
EndIf
If offsetX = 0 Or offsetY = 0 ;设置单位花费
AStep = 10
Else
AStep = 14
EndIf
;如果该邻居不是障碍并且不在关闭表中
If AStarMap(*minFP\pos\X + offsetX, *minFP\pos\Y + offsetY)\style <>#obstruct And CheckCloseNode(AStarMap(*minFP\pos\X + offsetX,*minFP\pos\Y + offsetY)) =#False
;AStarMap(minFP.pos.x offsetX, minFP.pos.y offsetY).G = minFP.G AStep '给G赋值
If CheckNode(AStarMap(*minFP\pos\X + offsetX,*minFP\pos\Y + offsetY)) = #True ;存在于开启表中
If *minFP\G + AStep < AStarMap(*minFP\pos\X + offsetX,*minFP\pos\Y + offsetY)\G ;如果走新路径更短就更换父节点
AStarMap(*minFP\pos\X + offsetX,*minFP\pos\Y + offsetY)\G =*minFP\G + AStep
AStarMap(*minFP\pos\X + offsetX,*minFP\pos\Y + offsetY)\father =*minFP\pos
UpdataG() ;更新Openlist中的G值
EndIf
Else ;不存在于开启表中
AStarMap(*minFP\pos\X + offsetX,*minFP\pos\Y + offsetY)\father =*minFP\pos ;设置该邻居的父节点为我们上面找到的最小节点（minFP）
AStarMap(*minFP\pos\X + offsetX,*minFP\pos\Y + offsetY)\G =*minFP\G + AStep ;计算该点（邻居）的G值
AddOpenList(@AStarMap(*minFP\pos\X + offsetX,*minFP\pos\Y + offsetY)) ;把该点加入开启表中
EndIf
EndIf
exit1:
EndProcedure
Procedure OnBtLeftClick()
If GetGadgetState(12)=1
soundon=#True
Else
soundon=#False
EndIf
EndProcedure
Procedure OnBtCPLeftClick()
End
EndProcedure
Procedure OnBtCMLeftClick()
Define i.i,j.i,s.s
For i=1 To maxX
For j=1 To maxY
maps(i,j)=#channel
Next j
Next i
For i=1 To 10
For j=1 To 10
balls(i,j)=0
Next j
Next i
starts=0
ends=0
DrawMap()
For i=1 To 3
createnew()
;Debug Str(x)+"-"+Str(y)
Next i
TotalBall=3
c=0
Score=0
If ReadFile(0, txtFile$,#PB_Ascii)
For i=1 To 10
name(i)=Trim(ReadString(0))
s=Trim(ReadString(0))
scores(i)=Val(s)
Next i
CloseFile(0)
ClearGadgetItems(16)
For i=1 To 10
AddGadgetItem(16,-1,Left(name(i)+"---------------",15)+Str(scores(i)))
Next i
EndIf
EndProcedure
Procedure DrawMap()
Define k.i,Font1.i
LoadFont(0, "Arial" , 28, #PB_Font_Bold)
If StartDrawing(CanvasOutput(0))
Box(0,0,650,650,MColor(1))
For k=0 To 650 Step #wd
Line(0, k, 650, 1,RGB(0,0,0))
Line(k,0,1,650,RGB(0,0,0))
Next k
DrawingMode(#PB_2DDrawing_Transparent)
FrontColor(RGB(200,200,255)) ; print the text to white !
DrawingFont(FontID(0))
DrawText(120, 80, "The Balls")
DrawText(60,160,"In A Line Game !",RGB(220,120,160))
StopDrawing() ; This is absolutely needed when the drawing operations are finished !!! Never forget it !
EndIf
EndProcedure
Procedure CreateNew()
Protected t.i,x.i,y.i
t=0
Repeat
x=Random(10,1)
y=Random(10,1)
If balls(x,y)=0
balls(x,y)=Random(#BallsCount,1)
StartDrawing(CanvasOutput(0))
DrawingMode(#PB_2DDrawing_AllChannels)
;Box(oldSX*#wd+1,oldSY*#wd+1,13,13,MColor(1))
DrawAlphaImage(ImageID(balls(x,y)),(x-1)*#wd+3,(y-1)*#wd+3)
StopDrawing()
t=1
EndIf
showScore()
Until t=1
EndProcedure
Procedure showScore()
SetGadgetFont(21, FontID(0))
SetGadgetText(21," Left: "+Str(100-TotalBall)+" Score: "+Str(Score))
EndProcedure
Procedure endGame()
Define i.i,j.i,input$
If scores(10)<Score
Input$ = InputRequester("Congratulation!", "Please input your name:", "SomeOne")
name(10)=Input$
scores(10)=Score
For i=1 To 10
For j=i+1 To 10
If scores(i)<scores(j)
Swap scores(i),scores(j)
Swap name(i),name(j)
EndIf
Next j
Next i
EndIf
If OpenFile(0,txtFile$,#PB_Ascii)
For i=1 To 10
WriteStringN(0,name(i))
WriteStringN(0,Trim(Str(scores(i))))
Next i
CloseFile(0)
EndIf
OnBtCMLeftClick()
EndProcedure
IsAline:
;判断是否4个以上一条线
For li=1 To 8
Midiv=li
If li<5
TotalB(li)=1
Else
Midiv=li-4
EndIf
Exitit=#False
OrignX=XN
OrignY=YN
Repeat
OrignX=OrignX+Dx(li)
OrignY=OrignY+Dy(li)
If (OrignY<=10) And (OrignY>0) And (OrignX>0) And (OrignX<=10)
If balls(OrignX,OrignY)=balls(XN,YN)
TotalB(Midiv)=TotalB(Midiv)+1
AdressX(Midiv,TotalB(Midiv))=OrignX
AdressY(Midiv,TotalB(Midiv))=OrignY
Else
Exitit=#True
EndIf
Else
Exitit=#True
EndIf
Until Exitit=#True
Next li
For li=1 To 4
If TotalB(li)>=5
For j=1 To ToTalB(li)
If balls(AdressX(li,j),AdressY(li,j))<>0
StartDrawing(CanvasOutput(0))
Box(AdressX(li,j)*#wd-#wd+1,AdressY(li,j)*#wd-#wd+1,64,64,MColor(1))
;DrawingMode(#PB_2DDrawing_AlphaBlend)
;DrawImage(ImageID(balls(xn,yn)),xn*#wd-#wd+1,yn*#wd-#wd+1)
StopDrawing()
EndIf
balls(AdressX(li,j),AdressY(li,j))=0
Next j
balls(xn,yn)=0
StartDrawing(CanvasOutput(0))
Box(XN*#wd-#wd+1,YN*#wd-#wd+1,64,64,MColor(1))
StopDrawing()
;'ShowBalls
Score=TotalB(li)+Score
Undo=#False
If soundon
PlaySound(2,0)
EndIf
EndIf
Next li
TotalBall=0
For li=1 To 10
For j=1 To 10
If balls(li,j)<>0
totalball+1
EndIf
Next j
Next li
Return
Procedure MakeBalls(ImagesID)
Define PS.i,Size.i,COLORV.i,Cxy.i,Radius.i,Color.i
PS = 30
Size = PS << 1
COLORV = 0
If CreateImage(ImagesID, Size, Size,32,#PB_Image_Transparent)
If StartVectorDrawing(ImageVectorOutput(ImagesID))
Cxy = PS
For Radius = 0 To PS
Select ImagesID
; Case 0
; Color = RGB(COLORV >> 1, COLORV >> 1, COLORV)
Case 1
Color = RGBA(COLORV>>1, COLORV >> 1, COLORV,255)
Case 2
Color = RGBA(000, 000, COLORV,255)
Case 3
Color = RGBA(COLORV >> 1, COLORV, COLORV,255);
Case 4
Color = RGBA(COLORV, COLORV >> 1, COLORV,255)
Case 5
Color = RGBA(COLORV, COLORV, COLORV >> 1,255)
Case 6
Color = RGBA(COLORV, COLORV, COLORV,255)
Case 7
Color = RGBA(COLORV, COLORV >> 1, 000,255)
Case 8
Color = RGBA(000, COLORV >> 1, COLORV >> 1,255)
Case 9
Color = RGBA(COLORV, COLORV >> 2, COLORV >> 2,255)
Case 10
Color = RGBA(COLORV >> 2, COLORV, COLORV >> 2,255)
;
; Case 11
; Color = RGBA(COLORV, COLORV >> 1, COLORV >> 1,255)
;
; Case 12
; Color = RGB(COLORV >> 1, COLORV, COLORV >> 1)
;
; Case 13
; Color = RGB(000, COLORV, 000)
;
; Case 14
; Color = RGB(COLORV, 000, 000)
;
; Case 15
; Color = RGB(COLORV, COLORV, 000)
;
; Case 16
; Color = RGB(000, COLORV, COLORV)
;
; Case 17
; Color = RGB(COLORV, 000, COLORV)
;
; Case 18
; Color = RGB(COLORV >> 2, COLORV >> 2, COLORV >> 2)
;
; Case 19
; Color = RGB(COLORV, COLORV >> 1, 000)
;
EndSelect
AddPathCircle(Cxy, Cxy, PS - Radius)
;AddPathCircle(Cxy, Cxy, PS)
VectorSourceColor(Color)
FillPath()
COLORV = Int(LinearlySpacedValue::Float(Radius, PS, 0, 255))
Next
StopVectorDrawing()
EndIf
EndIf
EndProcedure
