Option _Explicit ' Connect 4 NumRows X NumCols 2020_12_16.bas update bplus

DefLng A-Z

Const SQ = 60 '      square or grid cell

Const NumCols = 7 '  number of columns  7 across 6 down is standard for board game

Const NumRows = 6 '  you guessed it

Const NCM1 = NumCols - 1 ' NumCols minus 1

Const NRM1 = NumRows - 1 ' you can guess surely

Const SW = SQ * (NumCols + 2) '  screen width

Const SH = SQ * (NumRows + 3) '  screen height

Const P = 1 '      Player is 1 on grid

Const AI = -1 '    AI is -1 on grid

Const XO = SQ '    x offset for grid

Const YO = 2 * SQ ' y offset for grid



ReDim Shared Grid(NCM1, NRM1) ' 0 = empty  P=1 for Player,  AI=-1  for AI so -4 is win for AI..

ReDim Shared DX(7), DY(7) ' Directions

DX(0) = 1: DY(0) = 0 ': DString$(0) = "East"

DX(1) = 1: DY(1) = 1 ': DString$(1) = "South East"

DX(2) = 0: DY(2) = 1 ': DString$(2) = "South"

DX(3) = -1: DY(3) = 1 ': DString$(3) = "South West"

DX(4) = -1: DY(4) = 0 ': DString$(4) = "West"

DX(5) = -1: DY(5) = -1 ': DString$(5) = "North West"

DX(6) = 0: DY(6) = -1 ': DString$(6) = "North"

DX(7) = 1: DY(7) = -1 ' : DString$(7) = "North East"

ReDim Shared Scores(NCM1) ' rating column for AI and displaying them

ReDim Shared AIX, AIY ' last move of AI for highlighting in display

ReDim Shared WinX, WinY, WinD ' display Winning Connect 4

ReDim Shared GameOn, Turn, GoFirst, PlayerLastMoveCol, PlayerLastMoveRow, MoveNum ' game tracking

ReDim Shared Record$(NCM1, NRM1)



Screen _NewImage(SW, SH, 32)

_ScreenMove 360, 60

Dim mb, mx, my, row, col, r

_Title "Connect 4: " + _Trim$(Str$(NumCols)) + "x" + _Trim$(Str$(NumRows)) + " with AI"

GameOn = -1: GoFirst = AI: Turn = AI: MoveNum = 0

ShowGrid

While GameOn

    If Turn = P Then

        While _MouseInput: Wend

        mb = _MouseButton(1): mx = _MouseX: my = _MouseY

        If mb Then 'get last place mouse button was down

            _Delay .25 'for mouse release

            row = ((my - YO) / SQ - .5): col = ((mx - XO) / SQ - .5)

            If col >= 0 And col <= NCM1 And row >= 0 And row < 8 Then

                r = GetOpenRow(col)

                If r <> NumRows Then

                    Grid(col, r) = P: Turn = AI: PlayerLastMoveCol = col: PlayerLastMoveRow = r: MoveNum = MoveNum + 1

                End If

            Else

                Beep

            End If

        End If

    Else

        AIMove

        Turn = P: MoveNum = MoveNum + 1

    End If

    ShowGrid

    _PrintString (10, 10), Space$(50)

    _PrintString (10, 10), Str$(AIX) + Str$(AIY)

    _Display

    _Limit 60

Wend



Sub AIMove

    ' What this sub does in English:

    ' This sub assigns the value to playing each column, then plays the best value with following caveats:

    ' + If it finds a winning move, it will play that immediately.

    ' + If it finds a spoiler move, it will play that if no winning move was found.

    ' + It will poisen the column's scoring, if opponent can play a winning move if AI plays this column,

    '  but it might be the only legal move left.  We will have to play it if no better score was found.



    Dim c, r, d, cntA, cntP, bestScore, startR, startC, iStep, test, goodF, i

    Dim openRow(NCM1) ' find open rows once

    ReDim Scores(NCM1) ' evaluate each column's potential

    AIX = -1: AIY = -1 ' set these when AI makes move, they are signal to display procedure AI's move.

    For c = 0 To NCM1

        openRow(c) = GetOpenRow(c)

        r = openRow(c)

        If r <> NumRows Then

            For d = 0 To 3 ' 4 directions to build connect 4's that use cell c, r

                startC = c + -3 * DX(d): startR = r + -3 * DY(d)

                For i = 0 To 3 ' here we backup from the potential connect 4 in opposite build direction of c, r

                    cntA = 0: cntP = 0: goodF = -1 ' reset counts and flag for good connect 4

                    'from this start position run 4 steps forward to count all connects involving cell c, r

                    For iStep = 0 To 3 ' process a potential connect 4

                        test = GR(startC + i * DX(d) + iStep * DX(d), startR + i * DY(d) + iStep * DY(d))

                        If test = NumRows Then goodF = 0: Exit For 'cant get connect4 from here

                        If test = AI Then cntA = cntA + 1

                        If test = P Then cntP = cntP + 1

                    Next iStep

                    If goodF Then 'evaluate the Legal Connect4 we could build with c, r

                        If cntA = 3 Then ' we are done!  winner!

                            AIX = c: AIY = r ' <<< this is the needed 4th cell to win tell ShowGrid last cell

                            Grid(c, r) = AI '  <<< this is the needed 4th cell to win, add to grid this is AI move

                            Scores(c) = Scores(c) + 1000

                            Exit Sub

                        ElseIf cntP = 3 Then 'next best move spoiler!

                            AIX = c: AIY = r 'set the move but don't exit there might be a winner

                            Scores(c) = Scores(c) + 900

                        ElseIf cntA = 0 And cntP = 2 Then

                            Scores(c) = Scores(c) + 8

                        ElseIf cntA = 2 And cntP = 0 Then ' very good offense or defense

                            Scores(c) = Scores(c) + 4 'play this to connect 3 or prevent player from Connect 3

                        ElseIf cntA = 0 And cntP = 1 Then

                            Scores(c) = Scores(c) + 4

                        ElseIf (cntA = 1 And cntP = 0) Then 'good offense or defense

                            Scores(c) = Scores(c) + 2 ' play this to connect 2 or prevent player from Connect 2

                        ElseIf (cntA = 0 And cntP = 0) Then ' OK it's not a wasted move as it has potential for connect4

                            Scores(c) = Scores(c) + 1 ' this is good move because this can still be a Connect 4

                        End If

                    End If ' in the board

                Next i

            Next d

            If Stupid(c, r) Then Scores(c) = -1000 + Scores(c) ' poison because if played the human can win

        End If

    Next

    If AIX <> -1 Then ' we found a spoiler so move there since we haven't found a winner

        Grid(AIX, AIY) = AI ' make move on grid and done!

        Exit Sub

    Else

        If GetOpenRow(PlayerLastMoveCol) < NumRows Then 'all things being equal play on top of player's last move

            bestScore = Scores(PlayerLastMoveCol): AIY = PlayerLastMoveRow - 1: AIX = PlayerLastMoveCol

        Else

            bestScore = -1000 ' a negative score indicates that the player can beat AI with their next move

        End If

        For c = 0 To NCM1

            r = openRow(c)

            If r <> NumRows Then

                If Scores(c) > bestScore Then bestScore = Scores(c): AIY = r: AIX = c

            End If

        Next

        If AIX <> -1 Then

            Grid(AIX, AIY) = AI ' make first best score move we found

        Else 'We have trouble!  Oh but it could be there are no moves!!!

            ' checkWin is run after every move by AI or Player if there were no legal moves left it should have caught that.

            ' Just in case it didn't here is an error stop!

            Beep: Locate 4, 2: Print "AI has failed to find a proper move, press any to end..."

            Sleep ' <<< pause until user presses a key

            End

        End If

    End If

End Sub



Function GetOpenRow (forCol)

    Dim i

    GetOpenRow = NumRows 'assume none open

    If forCol < 0 Or forCol > NCM1 Then Exit Function

    For i = NRM1 To 0 Step -1

        If Grid(forCol, i) = 0 Then GetOpenRow = i: Exit Function

    Next

End Function



Function Stupid (c, r)

    Dim pr

    Grid(c, r) = AI

    pr = GetOpenRow(c)

    If pr <> NumRows Then

        Grid(c, pr) = P

        If CheckWin = 4 Then Stupid = -1

        Grid(c, pr) = 0

    End If

    Grid(c, r) = 0

End Function



Function GR (c, r) ' if c, r are out of bounds returns N else returns grid(c, r)

    ' need to check the grid(c, r) but only if c, r is on the board

    If c < 0 Or c > NCM1 Or r < 0 Or r > NRM1 Then GR = NumRows Else GR = Grid(c, r)

End Function



Sub ShowGrid

    Static lastMoveNum

    Dim i, r, c, check, s$, k$

    If MoveNum <> lastMoveNum Then ' file newest move

        If MoveNum = 1 Then ReDim Record$(NCM1, NRM1)

        If Turn = -1 Then

            Record$(PlayerLastMoveCol, PlayerLastMoveRow) = _Trim$(Str$(MoveNum)) + " " + "P"

        Else

            Record$(AIX, AIY) = _Trim$(Str$(MoveNum)) + " " + "A"

        End If

        lastMoveNum = MoveNum

    End If

    Cls

    Line (XO, YO)-Step(NumCols * SQ, NumRows * SQ), &HFF004400, BF

    For i = 0 To NumCols 'grid

        Line (SQ * i + XO, YO)-Step(0, NumRows * SQ), &HFFFFFFFF

    Next

    For i = 0 To NumRows

        Line (XO, SQ * i + YO)-Step(NumCols * SQ, 0), &HFFFFFFFF

    Next

    For r = NRM1 To 0 Step -1 ''in grid rows are reversed 0 is top row

        For c = 0 To NCM1

            If Grid(c, r) = P Then

                Line (c * SQ + XO + 3, r * SQ + YO + 3)-Step(SQ - 6, SQ - 6), &HFFFF2200, BF

            ElseIf Grid(c, r) = AI Then

                If c = AIX And r = AIY Then 'highlite last AI move

                    Line (c * SQ + XO + 3, r * SQ + YO + 3)-Step(SQ - 6, SQ - 6), &HFF680044, BF

                Else

                    Line (c * SQ + XO + 3, r * SQ + YO + 3)-Step(SQ - 6, SQ - 6), &HFF390027, BF

                End If

            End If

            s$ = _Trim$(Str$(Scores(c)))

            _PrintString (XO + c * SQ + (60 - Len(s$) * 8) / 2, YO + SQ * NumRows + 22), s$

        Next

    Next

    _Display

    check = CheckWin

    If check Then 'report end of round ad see if want to play again

        If check = 4 Or check = -4 Then

            For i = 0 To 3

                Line ((WinX + i * DX(WinD)) * SQ + XO + 5, (WinY + i * DY(WinD)) * SQ + YO + 5)-Step(SQ - 10, SQ - 10), &HFFFFFF00, B

            Next

        End If

        For r = 0 To NRM1

            For c = 0 To NCM1

                If Record$(c, r) <> "" Then

                    s$ = Mid$(Record$(c, r), 1, InStr(Record$(c, r), " ") - 1)

                    If Right$(Record$(c, r), 1) = "A" Then Color , &HFF390027 Else Color , &HFFFF2200

                    _PrintString (SQ * c + XO + (SQ - Len(s$) * 8) / 2, SQ * r + YO + 22), s$

                End If

            Next

            Color , &HFF000000

        Next

        If check = -4 Then

            s$ = " AI is Winner!"

        ElseIf check = 4 Then

            s$ = " Human is Winner!"

        ElseIf check = NumRows Then

            s$ = " Board is full, no winner." ' keep Turn the same

        End If

        Locate 2, ((SW - Len(s$) * 8) / 2) / 8: Print s$

        s$ = " Play again? press spacebar, any other to quit... "

        Locate 4, ((SW - Len(s$) * 8) / 2) / 8: Print s$

        _Display

        While Len(k$) = 0

            k$ = InKey$

            _Limit 200

        Wend

        If k$ = " " Then

            ReDim Grid(NCM1, NRM1), Scores(NCM1)

            If GoFirst = P Then GoFirst = AI Else GoFirst = P

            Turn = GoFirst: MoveNum = 0

        Else

            GameOn = 0

        End If

    End If

End Sub



Function CheckWin ' return WinX, WinY, WinD along with +/- 4, returns NumRows if grid full, 0 if no win and grid not full

    Dim gridFull, r, c, s, i

    gridFull = NumRows

    For r = NRM1 To 0 Step -1 'bottom to top

        For c = 0 To NCM1

            If Grid(c, r) Then ' check if c starts a row

                If c < NCM1 - 2 Then

                    s = 0

                    For i = 0 To 3 ' east

                        s = s + Grid(c + i, r)

                    Next

                    If s = 4 Or s = -4 Then WinX = c: WinY = r: WinD = 0: CheckWin = s: Exit Function

                End If

                If r > 2 Then ' check if c starts a col

                    s = 0

                    For i = 0 To 3 ' north

                        s = s + Grid(c, r - i)

                    Next

                    If s = 4 Or s = -4 Then WinX = c: WinY = r: WinD = 6: CheckWin = s: Exit Function

                End If

                If r > 2 And c < NCM1 - 2 Then 'check if c starts diagonal up to right

                    s = 0

                    For i = 0 To 3 ' north  east

                        s = s + Grid(c + i, r - i)

                    Next

                    If s = 4 Or s = -4 Then WinX = c: WinY = r: WinD = 7: CheckWin = s: Exit Function

                End If

                If r > 2 And c > 2 Then 'check if c starts a diagonal up to left

                    s = 0

                    For i = 0 To 3 ' north west

                        s = s + Grid(c - i, r - i)

                    Next

                    If s = 4 Or s = -4 Then WinX = c: WinY = r: WinD = 5: CheckWin = s: Exit Function

                End If

            Else

                gridFull = 0 ' at least one enpty cell left

            End If 'grid is something

        Next

    Next

    CheckWin = gridFull

End Function