http://www.purebasic.fr/english/viewtop ... sc&start=0
Took a while to clean out all the functions that weren't used any more but I got rid of a thousand lines of unused code. The only change from the uploaded version is that this has one bug fix for preventing playing on an occupied piece. A lot of it was kind of rushed so some explanations are slim, I've put a flow section in the top so you can see how things are called. Theres lots of other versions that work differently that are similar strength so if I are interested in seeing something modified, ask as I may have it already
Maybe with some collaboration and ideas, PureGM can kick ass next year
This version is already stonger than the version submitted in April but it has a long way to go and some parts need to be re written.Anyway, here's what it looks like... (edit, the pb forums chopped it, so I've cut it in half and posted a reply with the rest, just appened the bits together again )
Code: Select all
;Program Flow
;Play()
; MostInARow()
; GapCheck()
; CalcCounters()
; ScoreBlackCount()
; GetBestRnd()
; RecursePlay()
; GenMoves3()
; MostInARowlowsev()
; Minimax()
; GenMoves3()
; EvalFive()
; GetFive()
; Minimax() <- Recursion
; GenMoves3()
; MostInARowlowsev()
; EvalFive()
; GetFive()
; Minimax() <- Recursion
;bugs
;play topright makes AI play on point 21,0
EnableExplicit
Enumeration
#Frm_Main
#Img_Board
#Ctrl_Board
#Cmd_Clear
#Cmd_Check
#CBO_Difficulty
EndEnumeration
#BoardOffset = 50
#LineSpacing = 20
#LineCount = 20
#V_Offset = 30
Enumeration
#Frm_Main
#Img_Board
#Ctrl_Board
#Cmd_Clear
#Cmd_Check
EndEnumeration
#Horizontal = 0
#Vertical = 1
#DiagSE = 2
#DiagSW = 3
#Wh = 16777215
#Bl = 65793
#Gen = 13158600
#WinCol = 1973960
#Chkd = 500 ;isopen not true or false as prechecked further up
#Wall = 1000
#min = 1
#Max = 2
#BackCol = 6343162 ;RGB(250,201,96)
;{ structures
Structure PosStatus
X.l
Y.l
LenX.l
XBothOpen.l
XBothClosed.l
XLOpen.l
XROpen.l
XOpenStatus.l
XSev.l
LenY.l
YBothOpen.l
YBothClosed.l
YTOpen.l
YBOpen.l
YOpenStatus.l
YSev.l
LenSE.l
SEBothOpen.l
SEBothClosed.l
SETLOpen.l
SEBROpen.l
SEOpenStatus.l
SESev.l
LenSW.l
SWBothOpen.l
SWBothClosed.l
SWTROpen.l
SWBLOpen.l
SWOpenStatus.l
SWSev.l
EndStructure
Structure PosPart
CurLen.l
BothOpen.l
BothClosed.l
Open1.l
Open2.l ;(right side or lower side is open) second or end side
OpenStatus.l
Sev.l
EndStructure
Structure Play
RowLen.b
X.b
Y.b
Sev.b
EndStructure
Structure pt
x.l
y.l
EndStructure
Structure pt2
x.l
y.l
Type.l ;eg gap
IsDbl.l ;bool
IsJoin.l ;bool
BlScore.l
EndStructure
Structure pt3
x.l
y.l
score.l
EndStructure
;}
; Pt2 Types
#NoGap = 1
#Gap = 2
;=================
#TypeDouble = 3
#TypeJoin = 4
#TypeNone = 0
Declare DrawBoard(Board(2))
Declare Reset()
Declare LoadForm()
Declare Reset()
Declare LoadForm()
Declare PCPlayThread(Dummy.l)
Declare.l EvalFive(TmpBoard(2))
Declare.l Minimax(*Node.pt, Player.l, Board.l(2), CurDepth.l, Alpha.l, Beta.l )
Declare.l Max(x.l, y.l)
Declare.l Min(x.l, y.l)
Declare.l MostInARow(Col.l,Board.l(2),OutMoves.pt2(1), *OutMoveCount)
Declare.l MostInARowLowSev(Col.l,Board.l(2),OutMoves.pt2(1), *OutMoveCount)
Declare.l GenMoves3(inBoard.l(2), Points.pt(1))
Declare.l GapCheck(Board.l(2),PosX.l, PosY.l, Direction.l, RowLen.l)
Declare.l GetSev(Col.l,Board.l(2))
Declare.l GetFive(Col.l,Board.l(2))
Declare.l GetFivePaint(Col.l,Board.l(2))
Declare.s Play()
Declare.s RecursePlay(RecommendX.l, RecommendY.l )
Declare.l CalcCounters(Board(2),FoundX.l, FoundY.l, founddir.l, MostInARow.l, OpenStatus.l, OutMoves.pt2(1),FoundMoveCount.l) ;return movefound count
Declare ScoreBlackCount(Board(2),*Move.pt2)
Declare.l CalcCounters(Board(2),FoundX.l, FoundY.l, founddir.l, MostInARow.l, OpenStatus.l, OutMoves.pt2(1),FoundMoveCount.l) ;return movefound count
Declare GetBestRnd(Moves.pt2(1),BestType.l, MoveCount.l,*PlayX.l, *PlayY.l) ;#TypeDouble or #TypeJoin (then check BLScore then #Gap then rnd)
Declare Logs(Logtext.s)
Global Dim MainBoard.l(#LineCount+6,#LineCount+6) ;+6 Used to avoid overflow in check algo
Global WhoseTurn.l
Global HumanPlayer.l
Global AIPlayer.l = #wh
Global WhoseTurn.l
Global HumanPlayer.l
Global AIPlayer.l = #wh
Global msTurnTime.l = 300 * 1000
Global msTurnStart.l
Global timeout_match.l= 10000000
Global GameStartTime.l
Global RecurseDepth.l = 5
Global MoveInProgress.l
Global ProgressStatus.s = "Play a piece to begin !"
RandomSeed(ElapsedMilliseconds())
;=============================================================================
LoadForm()
;=============================================================================
Procedure LoadForm()
CreateImage(#Img_Board, 499, 499,24)
OpenWindow(#Frm_Main, 0, 0, 500, 500+#V_Offset, "PureGM", #PB_Window_ScreenCentered | #PB_Window_SystemMenu | #WS_MINIMIZEBOX)
CreateGadgetList(WindowID(#Frm_Main))
ImageGadget(#Ctrl_Board, 0, #V_Offset, 0, 0, ImageID(#Img_Board))
ButtonGadget(#Cmd_Clear, 2, 2, 60, 20, "Clear")
ComboBoxGadget(#CBO_Difficulty,64, 2, 120, 180)
AddGadgetItem(#CBO_Difficulty, -1,"Easy (Fastest)")
AddGadgetItem(#CBO_Difficulty, -1,"Medium")
AddGadgetItem(#CBO_Difficulty, -1,"Hard")
AddGadgetItem(#CBO_Difficulty, -1,"Very Hard (Slowest)")
SetGadgetState(#CBO_Difficulty, 1)
Reset()
DrawBoard(MainBoard())
MoveInProgress = #False
SetClassLong_(GadgetID(#Ctrl_Board),#GCL_HCURSOR,LoadCursor_(0,#IDC_CROSS))
Protected ClickedX.l, ClickedY.l
Protected EventID.l
WhoseTurn = #Bl
Repeat
EventID = WaitWindowEvent()
Select eventID
Case #WM_USER+1
SetClassLong_(GadgetID(#Ctrl_Board),#GCL_HCURSOR,LoadCursor_(0,#IDC_WAIT))
Case #WM_SETCURSOR
SetClassLong_(GadgetID(#Ctrl_Board),#GCL_HCURSOR,LoadCursor_(0,#IDC_ARROW))
Case #PB_Event_Gadget
Select EventGadget()
Case #Cmd_Clear
If MoveInProgress = #False
Reset()
EndIf
Case #Cmd_Check ;test function against current board
If MoveInProgress = #True
Else
CreateThread(@PCPlayThread(),0)
EndIf
Case #Ctrl_Board
If EventType() = #PB_EventType_LeftClick
If MoveInProgress = #True
Else
Select GetGadgetText(#CBO_Difficulty)
Case "Easy (Fastest)"
RecurseDepth = 3
Case "Medium"
RecurseDepth = 5
Case "Hard"
RecurseDepth = 7
Case "Very Hard (Slowest)"
RecurseDepth = 9
EndSelect
WhoseTurn = #wh
ClickedX = (WindowMouseX(#Frm_Main) - #LineSpacing) / #LineSpacing
Clickedy = (WindowMouseY(#Frm_Main) - #LineSpacing - #V_Offset) / #LineSpacing
If ClickedX > #LineCount Or ClickedY > #LineCount Or ClickedX < 0 Or ClickedY < 0
;outside range
Else
If mainBoard(ClickedX,ClickedY) <> 0
MessageRequester("PureGM","Position is occupied!")
Else
MainBoard(ClickedX,ClickedY) = WhoseTurn
If GetFivePaint(#Wh,MainBoard()) = #True
DrawBoard(MainBoard())
MessageRequester("PureGM", "Human Player (White) Wins !")
Else
DrawBoard(MainBoard())
CreateThread(@PCPlayThread(),0)
EndIf
EndIf
EndIf
EndIf
EndIf
EndSelect
EndSelect
Until EventID = #PB_Event_CloseWindow
EndProcedure
;=============================================================================
Procedure PCPlayThread(Dummy.l)
MoveInProgress = #True
PostMessage_(WindowID(#Frm_Main),#WM_USER+1,0,#HTCLIENT)
msTurnStart = ElapsedMilliseconds()
play()
If GetFivePaint(#BL,MainBoard()) = #True
DrawBoard(MainBoard())
MessageRequester("PureGM", "Computer (Black) Wins !")
EndIf
PostMessage_(WindowID(#Frm_Main),#WM_SETCURSOR,0,#HTCLIENT)
DrawBoard(MainBoard())
MoveInProgress = #False
EndProcedure
;=============================================================================
Procedure Reset()
;***************************************************
;Resets board at start and between games
;
;***************************************************
Protected i.l, j.l
For i = 1 To #LineCount
For j = 1 To #LineCount
MainBoard(i,j) = 0
Next
;Add Walls
MainBoard(i,0) = #wall
MainBoard(i,#LineCount + 1) = #wall
MainBoard(0,i) = #wall
MainBoard(#LineCount+1,i) = #wall
MainBoard(0,0) = #Wall
Next
DrawBoard(MainBoard())
EndProcedure
;=============================================================================
Procedure DrawBoard(Board(2))
Protected BoardFont.l, x.l, y.l, i.l
BoardFont.l = LoadFont(#PB_Any, "Arial", 8,#PB_Font_Bold)
If StartDrawing(ImageOutput(#Img_Board))
DrawingFont(FontID(BoardFont))
Box(1, 1, 500, 500 , #BackCol) ;backfill RGB(250,201,96)
For i = 0 To #LineCount -1
LineXY(#BoardOffset + i*#LineSpacing, #BoardOffset,#BoardOffset + i*#LineSpacing, #LineCount * #LineSpacing + #BoardOffset -#LineSpacing ,RGB(0,0,0))
LineXY(#BoardOffset, #BoardOffset + i * #LineSpacing, #LineCount*#LineSpacing + #BoardOffset - #LineSpacing , #BoardOffset + i*#LineSpacing ,RGB(0,0,0))
Next
For x = 1 To #LineCount
For y = 1 To #LineCount
If Board(x,y) > 0
Circle(x * #LineSpacing + (1.5*#LineSpacing), y * #LineSpacing + (1.5 * #LineSpacing),#LineSpacing /2,Board(x,y))
EndIf
Next
; Draw Numbers
DrawText(x * 20 + 25, 25, Str(x), 0, #BackCol)
DrawText(30, x * 20 + 22, Str(x), 0, #BackCol)
Next
DrawText(30,450,ProgressStatus,0,#BackCol)
StopDrawing()
SetGadgetState(#Ctrl_Board, ImageID(#Img_Board))
EndIf
EndProcedure
;=============================================================================
;=============================================================================
Procedure Logs(Logtext.s)
;***************************************************
;logs output to a file
;comment this block to stop logging
;
;***************************************************
; OpenFile(1,"c:\Log272.txt")
; FileSeek(1, Lof(1))
; WriteString(1, LogText + #CRLF$)
; CloseFile(1)
EndProcedure
;=============================================================================
Procedure.s Play()
;***************************************************
;Called proc for the AI to play a piece,
;Uses the strategy engine to generate a move (used for backup and a comparison
;then calls RecursePlay() where the minimax is initiated
;String return is for the Tornament soft and needs to be 0 aligned (-1)
;***************************************************
Dim WhPlayPts.pt2(0)
Dim BlPlayPts.pt2(0)
Protected BlMvCount.l = 0
Protected WhMvCount.l = 0
Protected Found.l = #False, UseRecursePlay.l
Protected PlayX.l, PlayY.l, BlackSev.l, WhiteSev.l
Protected i.l, j.l
BlackSev.l = MostInARow(#bl,MainBoard(),BlPlayPts(),@BlMvCount)
WhiteSev.l = MostInARow(#wh,MainBoard(),WhPlayPts(),@WhMvCount)
Debug "White Moves: " + Str(WhMvCount)
Debug "White Sev: " + Str(WhiteSev)
For i = 1 To WhMvCount
Debug "Play (" + Str(WhPlayPts(i)\x) + "," + Str(WhPlayPts(i)\y) + ") " + Str(WhPlayPts(i)\type)
Next
Debug "Black Moves: " + Str(BlMvCount)
Debug "Black Sev: " + Str(BlackSev)
For i = 1 To BlMvCount
Debug "Play (" + Str(BlPlayPts(i)\x) + "," + Str(BlPlayPts(i)\y) + ") " + Str(BlPlayPts(i)\type)
Next
;recurse
If BlackSev < 11 And whitesev < 11
UseRecursePlay = #True
Else
UseRecursePlay = #False
;Logs("FORCED")
EndIf
;or not
If BlackSev > WhiteSev Or (WhiteSev < 8 And whitesev <> 4) Or blacksev > 8 ;catch first move
;is black twice
For i = 1 To BlMvCount
For j = 1 To BlMvCount
If BlPlayPts(i)\x = BlPlayPts(j)\x And BlPlayPts(i)\y = BlPlayPts(j)\y And i <> j
Debug "Black Double Play (" + Str(blPlayPts(j)\x) + "," + Str(blPlayPts(j)\y) + ")"
Found = #True
blPlayPts(j)\IsDbl = #True
EndIf
Next
ScoreBlackCount(MainBoard(),@BlPlayPts(i))
Next
If found = #True
GetBestRnd(blPlayPts(),#TypeDouble, BlMvCount.l,@PlayX, @PlayY) ;#TypeDouble or #TypeJoin
Else
;is black also in white
For i = 1 To BlMvCount
For j = 1 To WhMvCount
If BlPlayPts(i)\x = WhPlayPts(j)\x And BlPlayPts(i)\y = WhPlayPts(j)\y
Debug "Double Play (" + Str(WhPlayPts(j)\x) + "," + Str(WhPlayPts(j)\y) + ")"
If found = #False
Found = #True
blPlayPts(i)\IsJoin = #True
EndIf
EndIf
Next
Next
If found = #True
GetBestRnd(blPlayPts(),#TypeJoin, BlMvCount.l,@PlayX, @PlayY) ;#TypeDouble or #TypeJoin
Else
GetBestRnd(blPlayPts(),#TypeNone, BlMvCount.l,@PlayX, @PlayY)
EndIf
EndIf
ElseIf WhiteSev > BlackSev
;is whiteplay twice
For i = 1 To WhMvCount
For j = 1 To WhMvCount
If WhPlayPts(i)\x = WhPlayPts(j)\x And WhPlayPts(i)\y = WhPlayPts(j)\y And i <> j
Debug "white Double Play (" + Str(WhPlayPts(j)\x) + "," + Str(WhPlayPts(j)\y) + ")"
Found = #True
WhPlayPts(j)\IsDbl = #True
EndIf
Next
ScoreBlackCount(MainBoard(),@WhPlayPts(i))
Next
If found = #True
GetBestRnd(WhPlayPts(),#TypeDouble, WhMvCount.l,@PlayX, @PlayY) ;#TypeDouble or #TypeJoin
Else
;is white in black
For i = 1 To BlMvCount
For j = 1 To WhMvCount
If BlPlayPts(i)\x = WhPlayPts(j)\x And BlPlayPts(i)\y = WhPlayPts(j)\y
Debug "Double Play (" + Str(WhPlayPts(j)\x) + "," + Str(WhPlayPts(j)\y) + ")"
If found = #False
Found = #True
whPlayPts(j)\IsJoin = #True
EndIf
EndIf
Next
Next
If found = #True
GetBestRnd(WhPlayPts(),#TypeJoin, WhMvCount.l,@PlayX, @PlayY) ;#TypeDouble or #TypeJoin
Else
GetBestRnd(WhPlayPts(),#TypeNone, WhMvCount.l,@PlayX, @PlayY)
EndIf
EndIf
Else ;same
;is black twice
For i = 1 To BlMvCount
For j = 1 To BlMvCount
If BlPlayPts(i)\x = BlPlayPts(j)\x And BlPlayPts(i)\y = BlPlayPts(j)\y And i <> j
Debug "Black Double Play (" + Str(blPlayPts(j)\x) + "," + Str(blPlayPts(j)\y) + ")"
Found = #True
blPlayPts(j)\IsDbl = #True
EndIf
Next
ScoreBlackCount(MainBoard(),@BlPlayPts(i))
Next
If found = #True
GetBestRnd(blPlayPts(),#TypeDouble, BlMvCount.l,@PlayX, @PlayY) ;#TypeDouble or #TypeJoin
Else
;is black also in white
For i = 1 To BlMvCount
For j = 1 To WhMvCount
If BlPlayPts(i)\x = WhPlayPts(j)\x And BlPlayPts(i)\y = WhPlayPts(j)\y
Debug "Double Play (" + Str(WhPlayPts(j)\x) + "," + Str(WhPlayPts(j)\y) + ")"
If found = #False
Found = #True
blPlayPts(i)\IsJoin = #True
EndIf
EndIf
Next
Next
If found = #True
GetBestRnd(blPlayPts(),#TypeJoin, BlMvCount.l,@PlayX, @PlayY) ;#TypeDouble or #TypeJoin
Else
GetBestRnd(blPlayPts(),#TypeNone, BlMvCount.l,@PlayX, @PlayY)
EndIf
EndIf
EndIf
If useRecursePlay = #True
ProcedureReturn RecursePlay(playx,playy)
EndIf
MainBoard(playx,playy) = #bl
ProcedureReturn Str(PlayX-1) + "," + Str(PlayY-1)
EndProcedure
;=============================================================================
Procedure.s RecursePlay(RecommendX.l, RecommendY.l )
Protected StartTime.d = ElapsedMilliseconds()
Dim Points.pt(0)
Protected MaxPoint.l = -130
Protected MaxX.l, MaxY.l
Protected NodeLoop.l
Protected PointCount.l, Tmpcount.l, RndIdx.l, i.l
Protected AllSameFlag.l = 0
Protected CalcLoop.f, CalcCount.f
AllSameFlag.l = 0
PointCount = GenMoves3(MainBoard(), Points())
Dim PointScores.l(PointCount)
For NodeLoop = 1 To PointCount
PointScores(nodeloop) = Minimax(@points(NodeLoop),#Bl,MainBoard(),0,-1000,1000)
logs("- " + Str(points(NodeLoop)\x) + "," + Str(points(NodeLoop)\y) + " " + Str(PointScores(nodeloop)))
If PointScores(nodeloop) > Maxpoint
Maxpoint = PointScores(nodeloop)
MaxX = points(NodeLoop)\x
Maxy = points(NodeLoop)\y
EndIf
;update board
CalcLoop.f = NodeLoop
CalcCount.f = PointCount
ProgressStatus = "Thinking Progress: " + Str((CalcLoop/CalcCount)*100) + "%"
DrawBoard(MainBoard()) ;this needs to come out of the thread!
Debug Str(PointScores(nodeloop)) + " " + Str(points(NodeLoop)\x) + " " + Str(points(NodeLoop)\y)
Next
logs("TIME: " + Str(ElapsedMilliseconds() - StartTime))
Tmpcount.l
Dim TmpMoves.pt(0)
For i = 1 To PointCount
If PointScores(i) = Maxpoint
Tmpcount = Tmpcount + 1
ReDim TmpMoves.pt(Tmpcount)
CopyMemory(@points(i),@TmpMoves(Tmpcount),SizeOf(Pt))
EndIf
Next
If Tmpcount = PointCount And AllSameFlag = #True;pointcount > 5 ;any number seems like it's too random
Logs("Same- recomended= " + Str(RecommendX) + "," + Str(RecommendY))
MainBoard(RecommendX,RecommendY) = #bl
ProgressStatus = "Black plays: " + Str(RecommendX) + "," + Str(RecommendY)
ProcedureReturn Str(RecommendX-1) + "," + Str(RecommendY-1)
Else
For i = 1 To Tmpcount
If RecommendX = TmpMoves(i)\x And RecommendY = TmpMoves(i)\y
;like minds! Bail
;makes no sense does it? a gen move match?
MainBoard(RecommendX,RecommendY) = #bl
Logs("Matched " + Str(RecommendX) + "," + Str(RecommendY))
ProgressStatus = "Black plays: " + Str(RecommendX) + "," + Str(RecommendY)
ProcedureReturn Str(RecommendX-1) + "," + Str(RecommendY-1)
EndIf
Next
RndIdx = Random(Tmpcount - 1) + 1
MaxX = TmpMoves(RndIdx)\x
MaxY = TmpMoves(RndIdx)\y
Logs("Recursed " + Str(MaxX) + "," + Str(Maxy) + " " + Str(Tmpcount) + " " + Str(rndidx))
MainBoard(MaxX,MaxY) = #bl
ProgressStatus = "Black plays: " + Str(MaxX) + "," + Str(MaxY)
ProcedureReturn Str(MaxX-1) + "," + Str(Maxy-1)
EndIf
EndProcedure
;=============================================================================
Procedure ScoreBlackCount(Board(2),*Move.pt2)
;***************************************************
;Used by the strategy engine (GetBestRnd)
;gives a score of how many surrounding pieces are the same colour
;
;***************************************************
Protected BlTotal.l = 0
If Board(*Move\x+1,*Move\y+1) = #bl: BlTotal = BlTotal + 1 : EndIf
If Board(*Move\x+1,*Move\y) = #bl: BlTotal = BlTotal + 1 : EndIf
If Board(*Move\x+1,*Move\y-1) = #bl: BlTotal = BlTotal + 1 : EndIf
If Board(*Move\x,*Move\y+1) = #bl: BlTotal = BlTotal + 1 : EndIf
If Board(*Move\x,*Move\y-1) = #bl: BlTotal = BlTotal + 1 : EndIf
If Board(*Move\x-1,*Move\y+1) = #bl: BlTotal = BlTotal + 1 : EndIf
If Board(*Move\x-1,*Move\y) = #bl: BlTotal = BlTotal + 1 : EndIf
If Board(*Move\x-1,*Move\y-1) = #bl: BlTotal = BlTotal + 1 : EndIf
Debug "BlScore " + Str(BlTotal)
*Move\BlScore = BLTotal
EndProcedure
;=============================================================================
Procedure GetBestRnd(Moves.pt2(1),BestType.l, MoveCount.l,*PlayX.l, *PlayY.l) ;#TypeDouble or #TypeJoin (then check BLScore then #Gap then rnd)
;***************************************************
;Part of the strategy engine
;Once Play() calls the MostInARow() to get the sev and play points
;this function processes them to find the best amongst them
;***************************************************
Dim TmpMoves.Pt2(0)
Protected TmpMvCount.l = 0
Dim BLScore.Pt2(0)
Protected BLScoreCount.l = 0
Protected BLTopScore.l = 0
Dim GapMoves.Pt2(0)
Protected GapMoveCount.l = 0
Protected GapsExist.l = #False
Protected TmpGapsExist.l = #False
Protected OnlyGapsExist.l = #False
Protected i.l, j.l, RndIdx.l
If MoveCount = 1
PokeL(*PlayX,Moves(i)\x)
PokeL(*PlayY,Moves(i)\y)
EndIf
;temp list based on type
For i = 1 To MoveCount
If BestType = #TypeDouble
If Moves(i)\IsDbl = #True
TmpMvCount = TmpMvCount + 1
ReDim TmpMoves.pt2(TmpMvCount)
CopyMemory(@Moves(i),@TmpMoves(TmpMvCount),SizeOf(Pt2))
If Moves(i)\Blscore > BLTopScore
BLTopScore = Moves(i)\Blscore
EndIf
If Moves(i)\Type = #Gap
TmpGapsExist = #True
EndIf
EndIf
ElseIf BestType = #TypeJoin
If Moves(i)\IsJoin = #True
TmpMvCount = TmpMvCount + 1
ReDim TmpMoves.pt2(TmpMvCount)
CopyMemory(@Moves(i),@TmpMoves(TmpMvCount),SizeOf(Pt2))
If Moves(i)\Blscore > BLTopScore
BLTopScore = Moves(i)\Blscore
EndIf
If Moves(i)\Type = #Gap
TmpGapsExist = #True
EndIf
EndIf
ElseIf besttype = #TypeNone
If Moves(i)\type = #gap
OnlyGapsExist = #True
EndIf
EndIf
Next
;take top bl scores
For i = 1 To TmpMvCount
If TmpMoves(i)\BlScore = BLTopScore
BLScoreCount = BLScoreCount + 1
ReDim BLScore.pt2(BLScoreCount)
CopyMemory(@TmpMoves(i), @BLScore(BLScoreCount),SizeOf(Pt2))
If TmpMoves(i)\Type = #Gap
GapsExist = #True
EndIf
EndIf
Next
If BLScoreCount > 0
;Get gaps from blcount
If GapsExist = #True
For i = 1 To BLScoreCount
If BLScore(i)\Type = #Gap
GapMoveCount = GapMoveCount + 1
ReDim GapMoves.pt2(GapMoveCount)
CopyMemory(@BLScore(i), @GapMoves(GapMoveCount),SizeOf(Pt2))
EndIf
Next
RndIdx = Random(GapMoveCount - 1) + 1
PokeL(*PlayX,GapMoves(RndIdx)\x)
PokeL(*PlayY,GapMoves(RndIdx)\y)
Else
RndIdx = Random(BLScoreCount - 1) + 1
PokeL(*PlayX,BLScore(RndIdx)\x)
PokeL(*PlayY,BLScore(RndIdx)\y)
EndIf
Else ;get gaps from tmp moves
If TmpGapsExist = #True
For i = 1 To TmpMvCount
If TmpMoves(i)\Type = #Gap
GapMoveCount = GapMoveCount + 1
ReDim GapMoves.pt2(GapMoveCount)
CopyMemory(@TmpMoves(i), @GapMoves(GapMoveCount),SizeOf(Pt2))
EndIf
Next
RndIdx = Random(GapMoveCount - 1) + 1
PokeL(*PlayX,GapMoves(RndIdx)\x)
PokeL(*PlayY,GapMoves(RndIdx)\y)
ElseIf OnlyGapsExist = #True
For i = 1 To MoveCount
If Moves(i)\type = #gap
PokeL(*PlayX,Moves(i)\x)
PokeL(*PlayY,Moves(i)\y)
EndIf
Next
Else ; rnd only
RndIdx = Random(MoveCount - 1) + 1
PokeL(*PlayX,Moves(RndIdx)\x)
PokeL(*PlayY,Moves(RndIdx)\y)
EndIf
EndIf
EndProcedure
;=============================================================================
Procedure.l MostInARow(Col.l,Board.l(2),OutMoves.pt2(1), *OutMoveCount)
;***************************************************
;Recieves the colour to check and the board layout
;Returns the highest sev found
;Via pointers passes back a list of move positions that match that sev
;***************************************************
Protected MaxLen = 0
Protected CheckDepth = 4
Protected i.l, j.l, OtherCol.l, Checkloop.l
Protected CurrentLenx.l, CurrentLeny.l, CurrentLenSE.l, CurrentLenSW.l
If Col = #BL
OtherCol = #WH
Else
OtherCol = #BL
EndIf
Dim Pos.PosStatus(0)
Protected PosCount = 0
For i = 1 To #LineCount
For j = 1 To #LineCount
If Board(i,j) = Col
PosCount = PosCount +1
ReDim Pos.PosStatus(PosCount)
Pos(PosCount)\X = i
Pos(PosCount)\Y = j
CurrentLenx = 1
For Checkloop = 1 To checkdepth
If Board(i+Checkloop,j) = Col
CurrentLenx = CurrentLenx + 1
ElseIf (Board(i+Checkloop,j) = OtherCol And Board(i+Checkloop-1,j) <> 0) Or Board(i+Checkloop,j) = #Wall
Pos(PosCount)\XROpen = #False
Break ;jump out of FOR as we hit an end
ElseIf Board(i+Checkloop,j) = 0
Pos(PosCount)\XROpen = #True
EndIf
Next
Pos(PosCount)\LenX = CurrentLenx
If Board(i-1,j) = OtherCol Or Board(i-1,j) = #Wall
Pos(PosCount)\XLOpen = #False
ElseIf Board(i-1,j) = 0
Pos(PosCount)\XLOpen = #True
ElseIf Board(i-1,j) = col
Pos(PosCount)\XLOpen = #Chkd
EndIf
If Pos(PosCount)\XLOpen = #True And Pos(PosCount)\XROpen = #True
Pos(PosCount)\XBothOpen = #True
ElseIf Pos(PosCount)\XLOpen = #Chkd
Pos(PosCount)\XBothOpen = #Chkd
Else
Pos(PosCount)\XBothOpen = #False
EndIf
If Pos(PosCount)\XLOpen = #False And Pos(PosCount)\XROpen = #False
Pos(PosCount)\XBothClosed = #True
EndIf
CurrentLeny = 1
For Checkloop = 1 To checkdepth
If Board(i,j+Checkloop) = Col
CurrentLeny = CurrentLeny + 1
ElseIf (Board(i,j+Checkloop) = OtherCol And Board(i,j+Checkloop-1) <> 0) Or Board(i,j+Checkloop) = #Wall
Pos(PosCount)\YBOpen = #False
Break ;jump out of FOR as we hit an end
ElseIf Board(i,j+Checkloop) = 0
Pos(PosCount)\YBOpen = #True
EndIf
Next
Pos(PosCount)\LenY = CurrentLenY
If Board(i,j-1) = OtherCol Or Board(i,j-1) = #Wall
Pos(PosCount)\YTOpen = #False
ElseIf Board(i,j-1) = 0
Pos(PosCount)\YTOpen = #True
ElseIf Board(i,j-1) = col
Pos(PosCount)\YTOpen = #Chkd
EndIf
If Pos(PosCount)\YTOpen = #True And Pos(PosCount)\YBOpen = #True
Pos(PosCount)\YBothOpen = #True
ElseIf Pos(PosCount)\YTOpen = #Chkd
Pos(PosCount)\YBothOpen = #Chkd
Else
Pos(PosCount)\YBothOpen = #False
EndIf
If Pos(PosCount)\YTOpen = #False And Pos(PosCount)\YBOpen = #False
Pos(PosCount)\YBothClosed = #True
EndIf
CurrentLenSE = 1
For Checkloop = 1 To checkdepth
If Board(i+Checkloop,j+Checkloop) = Col
CurrentLenSE = CurrentLenSE + 1
ElseIf (Board(i+Checkloop,j+Checkloop) = OtherCol And Board(i+Checkloop-1,j+Checkloop-1) <> 0) Or Board(i+Checkloop,j+Checkloop) = #Wall
Pos(PosCount)\SEBROpen = #False
Break ;jump out of FOR as we hit an end
ElseIf Board(i+Checkloop,j+Checkloop) = 0
Pos(PosCount)\SEBROpen = #True
EndIf
Next
Pos(PosCount)\LenSE = CurrentLenSE
If Board(i-1,j-1) = OtherCol Or Board(i-1,j-1) = #Wall
Pos(PosCount)\SETLOpen = #False
ElseIf Board(i-1,j-1) = 0
Pos(PosCount)\SETLOpen = #True
ElseIf Board(i-1,j-1) = col
Pos(PosCount)\SETLOpen = #Chkd
EndIf
If Pos(PosCount)\SETLOpen = #True And Pos(PosCount)\SEBROpen = #True
Pos(PosCount)\SEBothOpen = #True
ElseIf Pos(PosCount)\SETLOpen = #Chkd
Pos(PosCount)\SEBothOpen = #Chkd
Else
Pos(PosCount)\SEBothOpen = #False
EndIf
If Pos(PosCount)\SETLOpen = #False And Pos(PosCount)\SEBROpen = #False
Pos(PosCount)\SEBothClosed = #True
EndIf
CurrentLenSW = 1
For Checkloop = 1 To checkdepth
If i-Checkloop > 0 ;avoid array bound overflow
If Board(i-Checkloop,j+Checkloop) = Col
CurrentLenSW = CurrentLenSW + 1
ElseIf (Board(i-Checkloop,j+Checkloop) = OtherCol And Board(i-Checkloop+1,j+Checkloop-1) <> 0) Or Board(i-Checkloop,j+Checkloop) = #Wall
Pos(PosCount)\SWBLOpen = #False
Break ;jump out of FOR as we hit an end
ElseIf Board(i-Checkloop,j+Checkloop) = 0
Pos(PosCount)\SWBLOpen = #True
EndIf
EndIf
Next
Pos(PosCount)\LenSW = CurrentLenSW
If Board(i+1,j-1) = OtherCol Or Board(i+1,j-1) = #Wall ;reversed the sign (bug?)
Pos(PosCount)\SWTROpen = #False
ElseIf Board(i+1,j-1) = 0 ;reversed the sign (bug?)
Pos(PosCount)\SWTROpen = #True
ElseIf Board(i+1,j-1) = col ;reversed the sign (bug?)
Pos(PosCount)\SWTROpen = #Chkd
EndIf
If Pos(PosCount)\SWTROpen = #True And Pos(PosCount)\SWBLOpen = #True
Pos(PosCount)\SWBothOpen = #True
ElseIf Pos(PosCount)\SWTROpen = #Chkd
Pos(PosCount)\SWBothOpen = #Chkd
Else
Pos(PosCount)\SWBothOpen = #False
EndIf
If Pos(PosCount)\SWTROpen = #False And Pos(PosCount)\SWBLOpen = #False
Pos(PosCount)\SWBothClosed = #True
EndIf
EndIf
Next
Next
Protected MostInARow.l
Protected OpenStatus.l ;(1,2,3 (both))
Protected FoundX.l ;Best X Position so far
Protected FoundY.l ;Best Y position so far
Protected FoundDir.l ;direction of best position so far
Protected PlayX.l ;Position to play (currently blank space)
Protected PlayY.l
Protected PlaySev.l ;bothopen = 2, 1 open = 1 (+ len * 2)
Protected HighestSev.l
Protected HighestType.l ;(1 Or 2 (both)
Protected TypeLoop.l, *PosPart.PosPart, FoundMoveCount.l
For i = 1 To PosCount
For TypeLoop = 0 To 3
*PosPart.PosPart = @Pos(i) + 8 + (28 * TypeLoop)
If GapCheck(Board(), Pos(i)\x, Pos(i)\y, TypeLoop, *PosPart\CurLen) = 0 And *PosPart\CurLen > 4
;Debug "Game Over , WINNER"
PlaySev = *PosPart\CurLen + *PosPart\CurLen
*PosPart\Sev = PlaySev
EndIf
If *PosPart\Bothopen = #Chkd Or *PosPart\BothClosed = #True
;Skip (checked, or closed)
Else
If *PosPart\CurLen > MostInARow ;longer than any found so far
MostInARow = *PosPart\CurLen
If *PosPart\Bothopen = #True
HighestSev = MostInARow + MostInARow + 2
HighestType = 2
ElseIf *PosPart\Open1 = #True Or *PosPart\Open2 = #True
HighestSev = MostInARow + MostInARow + 1
HighestType = 1
EndIf
ElseIf *PosPart\CurLen = MostInARow
If *PosPart\Bothopen = #True And HighestType ;same len but higher type
HighestSev = MostInARow + MostInARow + 2
HighestType = 2
;else same as existing
EndIf
EndIf
FoundX = Pos(i)\x
FoundY = Pos(i)\y
FoundDir = TypeLoop
If *PosPart\Bothopen = #True
OpenStatus = 3
*PosPart\OpenStatus = OpenStatus
PlaySev = *PosPart\CurLen + *PosPart\CurLen + 2
*PosPart\Sev = PlaySev
ElseIf *PosPart\Open1 = #True
OpenStatus = 1
*PosPart\OpenStatus = OpenStatus
PlaySev = *PosPart\CurLen + *PosPart\CurLen + 1
*PosPart\Sev = PlaySev
ElseIf *PosPart\Open2 = #True
OpenStatus = 2
*PosPart\OpenStatus = OpenStatus
PlaySev = *PosPart\CurLen + *PosPart\CurLen + 1
*PosPart\Sev = PlaySev
Else
;closed has already been chopped by here
Debug "find me 4"
EndIf
EndIf
Next
Next
;loop poistions, pass PlaySev equiv vals to: CalcCounters to get all moves
;Dim OutMoves.pt(0)
FoundMoveCount.l = 0
For i = 1 To PosCount
For TypeLoop = 0 To 3
*PosPart.PosPart = @Pos(i) + 8 + (28 * TypeLoop)
If *PosPart\Sev = HighestSev ;position is equal to highest, will always be atleast 1
FoundMoveCount = CalcCounters(Board(),Pos(i)\X, Pos(i)\Y, TypeLoop, *PosPart\CurLen, *PosPart\OpenStatus, OutMoves.pt(),FoundMoveCount.l)
EndIf
Next
Next
PokeL(*OutMoveCount,FoundMoveCount)
;
ProcedureReturn HighestSev
EndProcedure
;=============================================================================
Procedure.l MostInARowLowSev(Col.l,Board.l(2),OutMoves.pt2(1), *OutMoveCount)
;***************************************************
;Same as MostInARow() but returns more points as it includes the second highest Sev too
;Recieves the colour to check and the board layout
;Returns the highest sev found
;Via pointers passes back a list of move positions that match that sev
;***************************************************
Protected MaxLen = 0
Protected CheckDepth = 4
Protected i.l, j.l, OtherCol.l, Checkloop.l
Protected CurrentLenx.l, CurrentLeny.l, CurrentLenSE.l, CurrentLenSW.l
If Col = #BL
OtherCol = #WH
Else
OtherCol = #BL
EndIf
Dim Pos.PosStatus(0)
Protected PosCount = 0
For i = 1 To #LineCount
For j = 1 To #LineCount
If Board(i,j) = Col
PosCount = PosCount +1
ReDim Pos.PosStatus(PosCount)
Pos(PosCount)\X = i
Pos(PosCount)\Y = j
CurrentLenx = 1
For Checkloop = 1 To checkdepth
If Board(i+Checkloop,j) = Col
CurrentLenx = CurrentLenx + 1
ElseIf (Board(i+Checkloop,j) = OtherCol And Board(i+Checkloop-1,j) <> 0) Or Board(i+Checkloop,j) = #Wall
Pos(PosCount)\XROpen = #False
Break ;jump out of FOR as we hit an end
ElseIf Board(i+Checkloop,j) = 0
Pos(PosCount)\XROpen = #True
EndIf
Next
Pos(PosCount)\LenX = CurrentLenx
If Board(i-1,j) = OtherCol Or Board(i-1,j) = #Wall
Pos(PosCount)\XLOpen = #False
ElseIf Board(i-1,j) = 0
Pos(PosCount)\XLOpen = #True
ElseIf Board(i-1,j) = col
Pos(PosCount)\XLOpen = #Chkd
EndIf
If Pos(PosCount)\XLOpen = #True And Pos(PosCount)\XROpen = #True
Pos(PosCount)\XBothOpen = #True
ElseIf Pos(PosCount)\XLOpen = #Chkd
Pos(PosCount)\XBothOpen = #Chkd
Else
Pos(PosCount)\XBothOpen = #False
EndIf
If Pos(PosCount)\XLOpen = #False And Pos(PosCount)\XROpen = #False
Pos(PosCount)\XBothClosed = #True
EndIf
CurrentLeny = 1
For Checkloop = 1 To checkdepth
If Board(i,j+Checkloop) = Col
CurrentLeny = CurrentLeny + 1
ElseIf (Board(i,j+Checkloop) = OtherCol And Board(i,j+Checkloop-1) <> 0) Or Board(i,j+Checkloop) = #Wall
Pos(PosCount)\YBOpen = #False
Break ;jump out of FOR as we hit an end
ElseIf Board(i,j+Checkloop) = 0
Pos(PosCount)\YBOpen = #True
EndIf
Next
Pos(PosCount)\LenY = CurrentLenY
If Board(i,j-1) = OtherCol Or Board(i,j-1) = #Wall
Pos(PosCount)\YTOpen = #False
ElseIf Board(i,j-1) = 0
Pos(PosCount)\YTOpen = #True
ElseIf Board(i,j-1) = col
Pos(PosCount)\YTOpen = #Chkd
EndIf
If Pos(PosCount)\YTOpen = #True And Pos(PosCount)\YBOpen = #True
Pos(PosCount)\YBothOpen = #True
ElseIf Pos(PosCount)\YTOpen = #Chkd
Pos(PosCount)\YBothOpen = #Chkd
Else
Pos(PosCount)\YBothOpen = #False
EndIf
If Pos(PosCount)\YTOpen = #False And Pos(PosCount)\YBOpen = #False
Pos(PosCount)\YBothClosed = #True
EndIf
CurrentLenSE = 1
For Checkloop = 1 To checkdepth
If Board(i+Checkloop,j+Checkloop) = Col
CurrentLenSE = CurrentLenSE + 1
ElseIf (Board(i+Checkloop,j+Checkloop) = OtherCol And Board(i+Checkloop-1,j+Checkloop-1) <> 0) Or Board(i+Checkloop,j+Checkloop) = #Wall
Pos(PosCount)\SEBROpen = #False
Break ;jump out of FOR as we hit an end
ElseIf Board(i+Checkloop,j+Checkloop) = 0
Pos(PosCount)\SEBROpen = #True
EndIf
Next
Pos(PosCount)\LenSE = CurrentLenSE
If Board(i-1,j-1) = OtherCol Or Board(i-1,j-1) = #Wall
Pos(PosCount)\SETLOpen = #False
ElseIf Board(i-1,j-1) = 0
Pos(PosCount)\SETLOpen = #True
ElseIf Board(i-1,j-1) = col
Pos(PosCount)\SETLOpen = #Chkd
EndIf
If Pos(PosCount)\SETLOpen = #True And Pos(PosCount)\SEBROpen = #True
Pos(PosCount)\SEBothOpen = #True
ElseIf Pos(PosCount)\SETLOpen = #Chkd
Pos(PosCount)\SEBothOpen = #Chkd
Else
Pos(PosCount)\SEBothOpen = #False
EndIf
If Pos(PosCount)\SETLOpen = #False And Pos(PosCount)\SEBROpen = #False
Pos(PosCount)\SEBothClosed = #True
EndIf
CurrentLenSW = 1
For Checkloop = 1 To checkdepth
If i-Checkloop > 0 ;avoid array bound overflow
If Board(i-Checkloop,j+Checkloop) = Col
CurrentLenSW = CurrentLenSW + 1
ElseIf (Board(i-Checkloop,j+Checkloop) = OtherCol And Board(i-Checkloop+1,j+Checkloop-1) <> 0) Or Board(i-Checkloop,j+Checkloop) = #Wall
Pos(PosCount)\SWBLOpen = #False
Break ;jump out of FOR as we hit an end
ElseIf Board(i-Checkloop,j+Checkloop) = 0
Pos(PosCount)\SWBLOpen = #True
EndIf
EndIf
Next
Pos(PosCount)\LenSW = CurrentLenSW
If Board(i+1,j-1) = OtherCol Or Board(i+1,j-1) = #Wall ;reversed the sign (bug?)
Pos(PosCount)\SWTROpen = #False
ElseIf Board(i+1,j-1) = 0 ;reversed the sign (bug?)
Pos(PosCount)\SWTROpen = #True
ElseIf Board(i+1,j-1) = col ;reversed the sign (bug?)
Pos(PosCount)\SWTROpen = #Chkd
EndIf
If Pos(PosCount)\SWTROpen = #True And Pos(PosCount)\SWBLOpen = #True
Pos(PosCount)\SWBothOpen = #True
ElseIf Pos(PosCount)\SWTROpen = #Chkd
Pos(PosCount)\SWBothOpen = #Chkd
Else
Pos(PosCount)\SWBothOpen = #False
EndIf
If Pos(PosCount)\SWTROpen = #False And Pos(PosCount)\SWBLOpen = #False
Pos(PosCount)\SWBothClosed = #True
EndIf
EndIf
Next
Next
Protected MostInARow.l
Protected OpenStatus.l ;(1,2,3 (both))
Protected FoundX.l ;Best X Position so far
Protected FoundY.l ;Best Y position so far
Protected FoundDir.l ;direction of best position so far
Protected PlayX.l ;Position to play (currently blank space)
Protected PlayY.l
Protected PlaySev.l ;bothopen = 2, 1 open = 1 (+ len * 2)
Protected HighestSev.l
Protected HighestType.l ;(1 Or 2 (both)
Protected TypeLoop.l, *PosPart.PosPart, FoundMoveCount.l
For i = 1 To PosCount
For TypeLoop = 0 To 3
*PosPart.PosPart = @Pos(i) + 8 + (28 * TypeLoop)
If GapCheck(Board(), Pos(i)\x, Pos(i)\y, TypeLoop, *PosPart\CurLen) = 0 And *PosPart\CurLen > 4
;Debug "Game Over , WINNER"
PlaySev = *PosPart\CurLen + *PosPart\CurLen
*PosPart\Sev = PlaySev
EndIf
If *PosPart\Bothopen = #Chkd Or *PosPart\BothClosed = #True
;Skip (checked, or closed)
Else
If *PosPart\CurLen > MostInARow ;longer than any found so far
MostInARow = *PosPart\CurLen
If *PosPart\Bothopen = #True
HighestSev = MostInARow + MostInARow + 2
HighestType = 2
ElseIf *PosPart\Open1 = #True Or *PosPart\Open2 = #True
HighestSev = MostInARow + MostInARow + 1
HighestType = 1
EndIf
ElseIf *PosPart\CurLen = MostInARow
If *PosPart\Bothopen = #True And HighestType ;same len but higher type
HighestSev = MostInARow + MostInARow + 2
HighestType = 2
;else same as existing
EndIf
EndIf
FoundX = Pos(i)\x
FoundY = Pos(i)\y
FoundDir = TypeLoop
If *PosPart\Bothopen = #True
OpenStatus = 3
*PosPart\OpenStatus = OpenStatus
PlaySev = *PosPart\CurLen + *PosPart\CurLen + 2
*PosPart\Sev = PlaySev
ElseIf *PosPart\Open1 = #True
OpenStatus = 1
*PosPart\OpenStatus = OpenStatus
PlaySev = *PosPart\CurLen + *PosPart\CurLen + 1
*PosPart\Sev = PlaySev
ElseIf *PosPart\Open2 = #True
OpenStatus = 2
*PosPart\OpenStatus = OpenStatus
PlaySev = *PosPart\CurLen + *PosPart\CurLen + 1
*PosPart\Sev = PlaySev
Else
;closed has already been chopped by here
Debug "find me 4"
EndIf
EndIf
Next
Next
;loop poistions, pass PlaySev equiv vals to: CalcCounters to get all moves
;Dim OutMoves.pt(0)
FoundMoveCount.l = 0
For i = 1 To PosCount
For TypeLoop = 0 To 3
*PosPart.PosPart = @Pos(i) + 8 + (28 * TypeLoop)
If *PosPart\Sev = HighestSev Or *PosPart\Sev = HighestSev - 1 ;position is equal to highest, will always be atleast 1
FoundMoveCount = CalcCounters(Board(),Pos(i)\X, Pos(i)\Y, TypeLoop, *PosPart\CurLen, *PosPart\OpenStatus, OutMoves.pt(),FoundMoveCount.l)
EndIf
Next
Next
PokeL(*OutMoveCount,FoundMoveCount)
;
ProcedureReturn HighestSev
EndProcedure
;=====================================================================
(same source file, just append)
