_Title "One Key Connect 4 (8x8) Halloween Style #2"
d = 1
While _KeyDown(32) = 0
Cls
pumpkin 0, _Width / 2, _Height / 2, _Height / 2.3, 3
sx = sx + d
If sx > 10 Then d = -d: sx = 10
If sx < -10 Then d = -d: sx = -10
Color &HFFFFFFFF
Locate 40, 33: Print "Spacebar Only"
_Display
_Limit 20
Wend
_KeyClear
GameOn = -1: GoFirst = AI: Turn = AI: MoveNum = 0
ShowGrid
place = -1
t = Timer
pr = (SQ - 2) / 2
While GameOn
Cls
If Turn = P Then
k$ = InKey$
If k$ = Chr$(27) Then System ' emergency exit
If k$ = " " Then
t = Timer: place = place + 1
If place >= NumCols Then place = -1
Else ' watch out for midnight!
If Timer - t < 0 Then 'midnight problem
t = Timer ' wait a little longer
Else
If Timer - t > 2 And place <> -1 Then ' col selected
r = GetOpenRow(place)
If r <> NumRows Then
y = SQ + SQ / 2
target = r * SQ + YO + SQ / 2
delaid = 6
While y < target
y = y + 1
Cls
ShowGrid
pumpkin 0, place * SQ + XO + SQ / 2, y, pr, 2
sx = Rnd * 6 - 3
_PutImage , Overlay&, _Display
_Display
_Limit delaid
delaid = delaid * 2
Wend
Grid(place, r) = P: Turn = AI: PlayerLastMoveCol = place: PlayerLastMoveRow = r: MoveNum = MoveNum + 1
place = -1 ' reset back to hold area
Else
Beep
End If
End If
End If
End If
Else
AIMove
Turn = P: MoveNum = MoveNum + 1: t = Timer
End If
ShowGrid
If Turn = P Then
If place = -1 Then
s$ = "Holding area, press spacebar until over column to play."
Else
s$ = "Press Spacebar, if don't want to play" + Str$(place) + " column."
End If
Color &HFFFFFFFF
_PrintString (XO, YO - SQ - 16), s$
End If
pumpkin 0, place * SQ + XO + SQ / 2, SQ + SQ / 2, pr, 2
sx = Rnd * 6 - 3
_PutImage , Overlay&, _Display
_Display
_Limit 15
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) = 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) = 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!
Color &HFFFFFFFF
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 ppr
Grid(c, r) = AI
ppr = GetOpenRow(c)
If ppr <> NumRows Then
Grid(c, ppr) = P
If CheckWin = 4 Then Stupid = -1
Grid(c, ppr) = 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
Color _RGB32(255, 255, 255), _RGB32(64, 64, 255): 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
Color
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), &HFF000000, BF
pumpkin 0, c * SQ + XO + SQ / 2, r * SQ + YO + SQ / 2, pr, 2
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), &HFF8888FF, BF ' no overlay
Line (c * SQ + XO, r * SQ + YO)-Step(SQ, SQ), &HFF8888FF, BF
'Else
'Line (c * SQ + XO + 3, r * SQ + YO + 3)-Step(SQ - 6, SQ - 6), &HFF4444FF, BF ' no overlay
'Line (c * SQ + XO, r * SQ + YO)-Step(SQ, SQ), &HFF4444FF, BF
End If
drawSpinner c * SQ + XO + SQ / 2, r * SQ + YO + SQ / 2, .4, _Pi(-c / 8), _RGB32(Rnd * 30 + 40, Rnd * 15 + 20, Rnd * 6 + 10)
End If
s$ = _Trim$(Str$(Scores(c)))
Color &HFFFFFFFF
_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 + 10, (WinY + i * DY(WinD)) * SQ + YO + 10)-Step(SQ - 20, SQ - 20), &HFFFFFF00, B
Next
End If
Color &HFFFFFFFF
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)
_PrintString (SQ * c + XO + (SQ - Len(s$) * 8) / 2, SQ * r + YO + 22), s$
End If
Next
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, escape to quit... "
Locate 4, ((SW - Len(s$) * 8) / 2) / 8: Print s$
_PutImage , Overlay&, _Display
_Display
keywait:
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
ElseIf Asc(k$) = 27 Then
System
Else
k$ = "": GoTo keywait:
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
Sub pumpkin (dh&, cx, cy, pr, limit)
Dim lastr, u, dx, i, tx1, tx2, tx3, ty1, ty2, ty3, ty22, sxs
'carve this!
Color &HFFFF0000
fEllipse cx, cy, pr, 29 / 35 * pr
Color &HFF000000
lastr = 2 / 7 * pr
Do
ellipse cx, cy, lastr, 29 / 35 * pr
lastr = .5 * (pr - lastr) + lastr + 1 / 35 * pr
If pr - lastr < 1 / 80 * pr Then Exit Do
Loop
Sub fEllipse (CX As Long, CY As Long, xRadius As Long, yRadius As Long)
Dim scale As Single, x As Long, y As Long
scale = yRadius / xRadius
Line (CX, CY - yRadius)-(CX, CY + yRadius), , BF
For x = 1 To xRadius
y = scale * Sqr(xRadius * xRadius - x * x)
Line (CX + x, CY - y)-(CX + x, CY + y), , BF
Line (CX - x, CY - y)-(CX - x, CY + y), , BF
Next
End Sub
Sub ellipse (CX As Long, CY As Long, xRadius As Long, yRadius As Long)
Dim scale As Single, xs As Long, x As Long, y As Long
Dim lastx As Long, lasty As Long
scale = yRadius / xRadius: xs = xRadius * xRadius
PSet (CX, CY - yRadius): PSet (CX, CY + yRadius)
lastx = 0: lasty = yRadius
For x = 1 To xRadius
y = scale * Sqr(xs - x * x)
Line (CX + lastx, CY - lasty)-(CX + x, CY - y)
Line (CX + lastx, CY + lasty)-(CX + x, CY + y)
Line (CX - lastx, CY - lasty)-(CX - x, CY - y)
Line (CX - lastx, CY + lasty)-(CX - x, CY + y)
lastx = x: lasty = y
Next
End Sub
Sub ftri2 (returnDest&, x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim a&
a& = _NewImage(1, 1, 32)
_Dest a&
PSet (0, 0), K
_Dest returnDest&
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
_FreeImage a& '<<< this is important!
End Sub
Function rand% (lo%, hi%)
rand% = Int(Rnd * (hi% - lo% + 1)) + lo%
End Function
Sub drawLink (x1, y1, r1, x2, y2, r2, c As _Unsigned Long)
Dim a, a1, a2, x3, x4, x5, x6, y3, y4, y5, y6
a = _Atan2(y2 - y1, x2 - x1)
a1 = a + _Pi(1 / 2)
a2 = a - _Pi(1 / 2)
x3 = x1 + r1 * Cos(a1): y3 = y1 + r1 * Sin(a1)
x4 = x1 + r1 * Cos(a2): y4 = y1 + r1 * Sin(a2)
x5 = x2 + r2 * Cos(a1): y5 = y2 + r2 * Sin(a1)
x6 = x2 + r2 * Cos(a2): y6 = y2 + r2 * Sin(a2)
fquad x3, y3, x4, y4, x5, y5, x6, y6, c
Fcirc x1, y1, r1, c
Fcirc x2, y2, r2, c
End Sub
'need 4 non linear points (not all on 1 line) list them clockwise so x2, y2 is opposite of x4, y4
Sub fquad (x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, x3 As Integer, y3 As Integer, x4 As Integer, y4 As Integer, c As _Unsigned Long)
ftri x1, y1, x2, y2, x4, y4, c
ftri x3, y3, x4, y4, x1, y1, c
End Sub
Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim a&
a& = _NewImage(1, 1, 32)
_Dest a&
PSet (0, 0), K
_Dest 0
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
_FreeImage a& '<<< this is important!
End Sub
Sub TiltedEllipseFill (destHandle&, x0, y0, a, b, ang, c As _Unsigned Long)
Dim max As Integer, mx2 As Integer, i As Integer, j As Integer, k As Single, lasti As Single, lastj As Single
Dim prc As _Unsigned Long, tef As Long
prc = _RGB32(255, 255, 255, 255)
If a > b Then max = a + 1 Else max = b + 1
mx2 = max + max
tef = _NewImage(mx2, mx2)
_Dest tef
_Source tef 'point wont read without this!
For k = 0 To 6.2832 + .05 Step .1
i = max + a * Cos(k) * Cos(ang) + b * Sin(k) * Sin(ang)
j = max + a * Cos(k) * Sin(ang) - b * Sin(k) * Cos(ang)
If k <> 0 Then
Line (lasti, lastj)-(i, j), prc
Else
PSet (i, j), prc
End If
lasti = i: lastj = j
Next
Dim xleft(mx2) As Integer, xright(mx2) As Integer, x As Integer, y As Integer
For y = 0 To mx2
x = 0
While Point(x, y) <> prc And x < mx2
x = x + 1
Wend
xleft(y) = x
While Point(x, y) = prc And x < mx2
x = x + 1
Wend
While Point(x, y) <> prc And x < mx2
x = x + 1
Wend
If x = mx2 Then xright(y) = xleft(y) Else xright(y) = x
Next
_Dest destHandle&
For y = 0 To mx2
If xleft(y) <> mx2 Then Line (xleft(y) + x0 - max, y + y0 - max)-(xright(y) + x0 - max, y + y0 - max), c, BF
Next
_FreeImage tef
End Sub
Sub Fcirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
Sub drawSpinner (x As Integer, y As Integer, scale As Single, heading As Single, c As _Unsigned Long)
Dim x1, x2, x3, x4, y1, y2, y3, y4, r, a, a1, a2, lg, d, rd
Dim rred, bblue, ggreen
Static switch As Integer
switch = switch + 2
switch = switch Mod 16 + 1
rred = _Red32(c): ggreen = _Green32(c): bblue = _Blue32(c)
r = 10 * scale
x1 = x + r * Cos(heading): y1 = y + r * Sin(heading)
r = 2 * r 'lg lengths
For lg = 1 To 8
If lg < 5 Then
a = heading + .9 * lg * _Pi(1 / 5) + (lg = switch) * _Pi(1 / 10)
Else
a = heading - .9 * (lg - 4) * _Pi(1 / 5) - (lg = switch) * _Pi(1 / 10)
End If
x2 = x1 + r * Cos(a): y2 = y1 + r * Sin(a)
drawLink x1, y1, 3 * scale, x2, y2, 2 * scale, _RGB32(rred + 20, ggreen + 10, bblue + 5)
If lg = 1 Or lg = 2 Or lg = 7 Or lg = 8 Then d = -1 Else d = 1
a1 = a + d * _Pi(1 / 12)
x3 = x2 + r * 1.5 * Cos(a1): y3 = y2 + r * 1.5 * Sin(a1)
drawLink x2, y2, 2 * scale, x3, y3, scale, _RGB32(rred + 35, ggreen + 17, bblue + 8)
rd = Int(Rnd * 8) + 1
a2 = a1 + d * _Pi(1 / 8) * rd / 8
x4 = x3 + r * 1.5 * Cos(a2): y4 = y3 + r * 1.5 * Sin(a2)
drawLink x3, y3, scale, x4, y4, scale, _RGB32(rred + 50, ggreen + 25, bblue + 12)
Next
r = r * .5
Fcirc x1, y1, r, _RGB32(rred - 20, ggreen - 10, bblue - 5)
x2 = x1 + (r + 1) * Cos(heading - _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading - _Pi(1 / 12))
Fcirc x2, y2, r * .2, &HFF000000
x2 = x1 + (r + 1) * Cos(heading + _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading + _Pi(1 / 12))
Fcirc x2, y2, r * .2, &HFF000000
r = r * 2
x1 = x + r * .9 * Cos(heading + _Pi): y1 = y + r * .9 * Sin(heading + _Pi)
TiltedEllipseFill 0, x1, y1, r, .7 * r, heading + _Pi, _RGB32(rred, ggreen, bblue)
End Sub
Sub Create_Board
Dim As Integer x, y
_Dest Overlay&
Line (60, 120)-Step(480, 480), _RGB32(80, 40, 20), BF
For y = 0 To 7
For x = 0 To 7
Fcirc 90 + 60 * x, 150 + 60 * y, 28, _RGB32(0)
Next x, y
_ClearColor _RGB32(0), Overlay&
_Dest _Display
End Sub
10-29-2023, 08:07 PM (This post was last modified: 10-29-2023, 08:14 PM by bplus.)
Crypt-O-gram Halloween Puzzle
I modified this today from the One Key Challenge that used a spacebar and timing to input the Code Letter and your guess for actual letter. Too distracting from trying to figure out puzzle so I swicthed to keying in letters or menu numbers for direct input. A number of clues and hints are given in the readme.txt file for help solving the puzzles with simple letter substitutions. Its all in the zip.
10-30-2023, 11:28 PM (This post was last modified: 10-30-2023, 11:29 PM by Dav.)
Hey I remember the connect four. Always liked playing this one. I still suck at it, but enjoying playing it again. Spiders always catching me on the diagonals. I was trying to speed up the pumpkin drop speed. Changing/commenting out the _Limit delaid didn't help at all (my laptop is slooow), so I changed the drop to y = y + 2 to speed it up a tad.
This is the game that got me inspired to do my first AI game play.
