QB64.org Forum

Active Forums => Programs => Topic started by: bplus on October 19, 2021, 08:09:18 pm

Title: One Key Connect 4 (8x8) Halloween Style
Post by: bplus on October 19, 2021, 08:09:18 pm

I was curious how long this would take to convert and modify:

Code: QB64: [Select]

1. Option _Explicit ' One Key Connect 4 (8x8) Halloween Style - bplus 2021-10-19
2. Const SQ = 60 '       square or grid cell
3. Const NumCols = 8 '   number of columns
4. Const NumRows = 8 '   you guessed it
5. Const NCM1 = NumCols - 1 ' NumCols minus 1
6. Const NRM1 = NumRows - 1 ' you can guess surely
7. Const SW = SQ * (NumCols + 2) '  screen width
8. Const SH = SQ * (NumRows + 3) '  screen height
9. Const P = 1 '       Player is 1 on grid
10. Const AI = -1 '     AI is -1 on grid
11. Const XO = SQ '     x offset for grid
12. Const YO = 2 * SQ ' y offset for grid
13.  
14. ReDim Shared Grid(NCM1, NRM1) ' 0 = empty  P=1 for Player,  AI=-1  for AI so -4 is win for AI..
15. ReDim Shared DX(7), DY(7) ' Directions
16. DX(0) = 1: DY(0) = 0 ': DString$(0) = "East"
17. DX(1) = 1: DY(1) = 1 ': DString$(1) = "South East"
18. DX(2) = 0: DY(2) = 1 ': DString$(2) = "South"
19. DX(3) = -1: DY(3) = 1 ': DString$(3) = "South West"
20. DX(4) = -1: DY(4) = 0 ': DString$(4) = "West"
21. DX(5) = -1: DY(5) = -1 ': DString$(5) = "North West"
22. DX(6) = 0: DY(6) = -1 ': DString$(6) = "North"
23. DX(7) = 1: DY(7) = -1 ' : DString$(7) = "North East"
24. ReDim Shared Scores(NCM1) ' rating column for AI and displaying them
25. ReDim Shared AIX, AIY ' last move of AI for highlighting in display
26. ReDim Shared WinX, WinY, WinD ' display Winning Connect 4
27. ReDim Shared GameOn, Turn, GoFirst, PlayerLastMoveCol, PlayerLastMoveRow, MoveNum ' game tracking
28. ReDim Shared Record$(NCM1, NRM1)
29. Dim Shared sx ' for pumpkin recursion shifty eyes
30. Dim place, k$, t, r, s$, pr, d
31.  
32. Screen _NewImage(SW, SH, 32)
33. _ScreenMove 360, 60
34.  
35. _Title "One Key Connect 4 (8x8) Halloween Style"
36. d = 1
37. While _KeyDown(32) = 0
38.     Cls
39.     pumpkin 0, _Width / 2, _Height / 2, _Height / 2.3, 3
40.     sx = sx + d
41.     If sx > 10 Then d = -d: sx = 10
42.     If sx < -10 Then d = -d: sx = -10
43.     Color &HFFFFFFFF, &HFF000000:
44.     Locate 40, 33: Print "Spacebar Only"
45.     _Display
46.     _Limit 20
47. Wend
48. _KeyClear
49. GameOn = -1: GoFirst = AI: Turn = AI: MoveNum = 0
50. ShowGrid
51. place = -1
52. t = Timer
53. pr = (SQ - 6) / 2
54. While GameOn
55.     Cls
56.     If Turn = P Then
57.         k$ = InKey$
58.         If k$ = Chr$(27) Then System ' emergency exit
59.  
60.         If k$ = " " Then
61.             t = Timer: place = place + 1
62.             If place >= NumCols Then place = -1
63.         Else ' watch out for midnight!
64.             If Timer - t > 4 And place <> -1 Then ' col selected
65.                 r = GetOpenRow(place)
66.                 If r <> NumRows Then
67.                     Grid(place, r) = P: Turn = AI: PlayerLastMoveCol = place: PlayerLastMoveRow = r: MoveNum = MoveNum + 1
68.                     place = -1 ' reset back to hold area
69.                 End If
70.             End If
71.         End If
72.     Else
73.         AIMove
74.         Turn = P: MoveNum = MoveNum + 1: t = Timer
75.     End If
76.     ShowGrid
77.     If Turn = P Then
78.         If place = -1 Then
79.             s$ = "Holding area, press spacebar until over column to play."
80.         Else
81.             s$ = "Press Spacebar, if don't want to play" + Str$(place) + " column."
82.         End If
83.         Color &HFFFFFFFF, 0
84.         _PrintString (XO, YO - SQ - 16), s$
85.     End If
86.     pumpkin 0, place * SQ + XO + SQ / 2, SQ + SQ / 2, pr, 2
87.     sx = Rnd * 6 - 3
88.     _Display
89.     _Limit 15
90. Wend
91.  
92. Sub AIMove
93.     ' What this sub does in English:
94.     ' This sub assigns the value to playing each column, then plays the best value with following caveats:
95.     ' + If it finds a winning move, it will play that immediately.
96.     ' + If it finds a spoiler move, it will play that if no winning move was found.
97.     ' + It will poisen the column's scoring, if opponent can play a winning move if AI plays this column,
98.     '   but it might be the only legal move left.  We will have to play it if no better score was found.
99.  
100.     Dim c, r, d, cntA, cntP, bestScore, startR, startC, iStep, test, goodF, i
101.     Dim openRow(NCM1) ' find open rows once
102.     ReDim Scores(NCM1) ' evaluate each column's potential
103.     AIX = -1: AIY = -1 ' set these when AI makes move, they are signal to display procedure AI's move.
104.     For c = 0 To NCM1
105.         openRow(c) = GetOpenRow(c)
106.         r = openRow(c)
107.         If r <> NumRows Then
108.             For d = 0 To 3 ' 4 directions to build connect 4's that use cell c, r
109.                 startC = c + -3 * DX(d): startR = r + -3 * DY(d)
110.                 For i = 0 To 3 ' here we backup from the potential connect 4 in opposite build direction of c, r
111.                     cntA = 0: cntP = 0: goodF = -1 ' reset counts and flag for good connect 4
112.                     'from this start position run 4 steps forward to count all connects involving cell c, r
113.                     For iStep = 0 To 3 ' process a potential connect 4
114.                         test = GR(startC + i * DX(d) + iStep * DX(d), startR + i * DY(d) + iStep * DY(d))
115.                         If test = NumRows Then goodF = 0: Exit For 'cant get connect4 from here
116.                         If test = AI Then cntA = cntA + 1
117.                         If test = P Then cntP = cntP + 1
118.                     Next iStep
119.                     If goodF Then 'evaluate the Legal Connect4 we could build with c, r
120.                         If cntA = 3 Then ' we are done!  winner!
121.                             AIX = c: AIY = r ' <<< this is the needed 4th cell to win tell ShowGrid last cell
122.                             Grid(c, r) = AI '  <<< this is the needed 4th cell to win, add to grid this is AI move
123.                             Scores(c) = 1000
124.                             Exit Sub
125.                         ElseIf cntP = 3 Then 'next best move spoiler!
126.                             AIX = c: AIY = r 'set the move but don't exit there might be a winner
127.                             Scores(c) = 900
128.                         ElseIf cntA = 0 And cntP = 2 Then
129.                             Scores(c) = Scores(c) + 8
130.                         ElseIf cntA = 2 And cntP = 0 Then ' very good offense or defense
131.                             Scores(c) = Scores(c) + 4 'play this to connect 3 or prevent player from Connect 3
132.                         ElseIf cntA = 0 And cntP = 1 Then
133.                             Scores(c) = Scores(c) + 4
134.                         ElseIf (cntA = 1 And cntP = 0) Then 'good offense or defense
135.                             Scores(c) = Scores(c) + 2 ' play this to connect 2 or prevent player from Connect 2
136.                         ElseIf (cntA = 0 And cntP = 0) Then ' OK it's not a wasted move as it has potential for connect4
137.                             Scores(c) = Scores(c) + 1 ' this is good move because this can still be a Connect 4
138.                         End If
139.                     End If ' in the board
140.                 Next i
141.             Next d
142.             If Stupid(c, r) Then Scores(c) = -1000 + Scores(c) ' poison because if played the human can win
143.         End If
144.     Next
145.     If AIX <> -1 Then ' we found a spoiler so move there since we haven't found a winner
146.         Grid(AIX, AIY) = AI ' make move on grid and done!
147.         Exit Sub
148.     Else
149.         If GetOpenRow(PlayerLastMoveCol) < NumRows Then 'all things being equal play on top of player's last move
150.             bestScore = Scores(PlayerLastMoveCol): AIY = PlayerLastMoveRow - 1: AIX = PlayerLastMoveCol
151.         Else
152.             bestScore = -1000 ' a negative score indicates that the player can beat AI with their next move
153.         End If
154.         For c = 0 To NCM1
155.             r = openRow(c)
156.             If r <> NumRows Then
157.                 If Scores(c) > bestScore Then bestScore = Scores(c): AIY = r: AIX = c
158.             End If
159.         Next
160.         If AIX <> -1 Then
161.             Grid(AIX, AIY) = AI ' make first best score move we found
162.         Else 'We have trouble!  Oh but it could be there are no moves!!!
163.             ' checkWin is run after every move by AI or Player if there were no legal moves left it should have caught that.
164.             ' Just in case it didn't here is an error stop!
165.             Beep: Locate 4, 2: Print "AI has failed to find a proper move, press any to end..."
166.             Sleep ' <<< pause until user presses a key
167.             End
168.         End If
169.     End If
170. End Sub
171.  
172. Function GetOpenRow (forCol)
173.     Dim i
174.     GetOpenRow = NumRows 'assume none open
175.     If forCol < 0 Or forCol > NCM1 Then Exit Function
176.     For i = NRM1 To 0 Step -1
177.         If Grid(forCol, i) = 0 Then GetOpenRow = i: Exit Function
178.     Next
179. End Function
180.  
181. Function Stupid (c, r)
182.     Dim pr
183.     Grid(c, r) = AI
184.     pr = GetOpenRow(c)
185.     If pr <> NumRows Then
186.         Grid(c, pr) = P
187.         If CheckWin = 4 Then Stupid = -1
188.         Grid(c, pr) = 0
189.     End If
190.     Grid(c, r) = 0
191. End Function
192.  
193. Function GR (c, r) ' if c, r are out of bounds returns N else returns grid(c, r)
194.     ' need to check the grid(c, r) but only if c, r is on the board
195.     If c < 0 Or c > NCM1 Or r < 0 Or r > NRM1 Then GR = NumRows Else GR = Grid(c, r)
196. End Function
197.  
198. Sub ShowGrid
199.     Static lastMoveNum
200.     Dim i, r, c, check, s$, k$
201.     If MoveNum <> lastMoveNum Then ' file newest move
202.         If MoveNum = 1 Then ReDim Record$(NCM1, NRM1)
203.         If Turn = -1 Then
204.             Record$(PlayerLastMoveCol, PlayerLastMoveRow) = _Trim$(Str$(MoveNum)) + " " + "P"
205.         Else
206.             Record$(AIX, AIY) = _Trim$(Str$(MoveNum)) + " " + "A"
207.         End If
208.         lastMoveNum = MoveNum
209.     End If
210.     'cls
211.     Line (XO, YO)-Step(NumCols * SQ, NumRows * SQ), &HFF004400, BF
212.     For i = 0 To NumCols 'grid
213.         Line (SQ * i + XO, YO)-Step(0, NumRows * SQ), &HFFFFFFFF
214.     Next
215.     For i = 0 To NumRows
216.         Line (XO, SQ * i + YO)-Step(NumCols * SQ, 0), &HFFFFFFFF
217.     Next
218.     For r = NRM1 To 0 Step -1 ''in grid rows are reversed 0 is top row
219.         For c = 0 To NCM1
220.             If Grid(c, r) = P Then
221.                 Line (c * SQ + XO + 3, r * SQ + YO + 3)-Step(SQ - 6, SQ - 6), &HFF000000, BF
222.                 pumpkin 0, c * SQ + XO + SQ / 2, r * SQ + YO + SQ / 2, (SQ - 6) / 2, 2
223.  
224.             ElseIf Grid(c, r) = AI Then
225.                 If c = AIX And r = AIY Then 'highlite last AI move
226.                     Line (c * SQ + XO + 3, r * SQ + YO + 3)-Step(SQ - 6, SQ - 6), &HFF8888FF, BF
227.                 Else
228.                     Line (c * SQ + XO + 3, r * SQ + YO + 3)-Step(SQ - 6, SQ - 6), &HFF4444FF, BF
229.                 End If
230.                 drawSpinner c * SQ + XO + SQ / 2, r * SQ + YO + SQ / 2, .5, _Pi(-c / 8), _RGB32(Rnd * 30 + 40, Rnd * 15 + 20, Rnd * 6 + 10)
231.             End If
232.             s$ = _Trim$(Str$(Scores(c)))
233.             _PrintString (XO + c * SQ + (60 - Len(s$) * 8) / 2, YO + SQ * NumRows + 22), s$
234.         Next
235.     Next
236.     '_Display
237.     check = CheckWin
238.     If check Then 'report end of round ad see if want to play again
239.         If check = 4 Or check = -4 Then
240.             For i = 0 To 3
241.                 Line ((WinX + i * DX(WinD)) * SQ + XO + 5, (WinY + i * DY(WinD)) * SQ + YO + 5)-Step(SQ - 10, SQ - 10), &HFFFFFF00, B
242.             Next
243.         End If
244.         For r = 0 To NRM1
245.             For c = 0 To NCM1
246.                 If Record$(c, r) <> "" Then
247.                     s$ = Mid$(Record$(c, r), 1, InStr(Record$(c, r), " ") - 1)
248.                     If Right$(Record$(c, r), 1) = "A" Then Color &HFFFFFFFF, &HFF000000 Else Color &HFFFFFFFF, &HFF000000
249.                     _PrintString (SQ * c + XO + (SQ - Len(s$) * 8) / 2, SQ * r + YO + 22), s$
250.                 End If
251.             Next
252.             Color , &HFF000000
253.         Next
254.         If check = -4 Then
255.             s$ = " AI is Winner!"
256.         ElseIf check = 4 Then
257.             s$ = " Human is Winner!"
258.         ElseIf check = NumRows Then
259.             s$ = " Board is full, no winner." ' keep Turn the same
260.         End If
261.         Locate 2, ((SW - Len(s$) * 8) / 2) / 8: Print s$
262.         s$ = " Play again? press spacebar, escape to quit... "
263.         Locate 4, ((SW - Len(s$) * 8) / 2) / 8: Print s$
264.         _Display
265.         keywait:
266.         While Len(k$) = 0
267.             k$ = InKey$
268.             _Limit 200
269.         Wend
270.         If k$ = " " Then
271.             ReDim Grid(NCM1, NRM1), Scores(NCM1)
272.             If GoFirst = P Then GoFirst = AI Else GoFirst = P
273.             Turn = GoFirst: MoveNum = 0
274.         ElseIf Asc(k$) = 27 Then
275.             System
276.         Else
277.             k$ = "": GoTo keywait:
278.         End If
279.     End If
280. End Sub
281.  
282. Function CheckWin ' return WinX, WinY, WinD along with +/- 4, returns NumRows if grid full, 0 if no win and grid not full
283.     Dim gridFull, r, c, s, i
284.     gridFull = NumRows
285.     For r = NRM1 To 0 Step -1 'bottom to top
286.         For c = 0 To NCM1
287.             If Grid(c, r) Then ' check if c starts a row
288.                 If c < NCM1 - 2 Then
289.                     s = 0
290.                     For i = 0 To 3 ' east
291.                         s = s + Grid(c + i, r)
292.                     Next
293.                     If s = 4 Or s = -4 Then WinX = c: WinY = r: WinD = 0: CheckWin = s: Exit Function
294.                 End If
295.                 If r > 2 Then ' check if c starts a col
296.                     s = 0
297.                     For i = 0 To 3 ' north
298.                         s = s + Grid(c, r - i)
299.                     Next
300.                     If s = 4 Or s = -4 Then WinX = c: WinY = r: WinD = 6: CheckWin = s: Exit Function
301.                 End If
302.                 If r > 2 And c < NCM1 - 2 Then 'check if c starts diagonal up to right
303.                     s = 0
304.                     For i = 0 To 3 ' north  east
305.                         s = s + Grid(c + i, r - i)
306.                     Next
307.                     If s = 4 Or s = -4 Then WinX = c: WinY = r: WinD = 7: CheckWin = s: Exit Function
308.                 End If
309.                 If r > 2 And c > 2 Then 'check if c starts a diagonal up to left
310.                     s = 0
311.                     For i = 0 To 3 ' north west
312.                         s = s + Grid(c - i, r - i)
313.                     Next
314.                     If s = 4 Or s = -4 Then WinX = c: WinY = r: WinD = 5: CheckWin = s: Exit Function
315.                 End If
316.             Else
317.                 gridFull = 0 ' at least one enpty cell left
318.             End If 'grid is something
319.         Next
320.     Next
321.     CheckWin = gridFull
322. End Function
323.  
324.  
325. Sub pumpkin (dh&, cx, cy, pr, limit)
326.     Dim lastr, u, dx, i, tx1, tx2, tx3, ty1, ty2, ty3, ty22, sxs
327.     'carve this!
328.     Color &HFFFF0000
329.     fEllipse cx, cy, pr, 29 / 35 * pr
330.     Color &HFF000000
331.     lastr = 2 / 7 * pr
332.     Do
333.         ellipse cx, cy, lastr, 29 / 35 * pr
334.         lastr = .5 * (pr - lastr) + lastr + 1 / 35 * pr
335.         If pr - lastr < 1 / 80 * pr Then Exit Do
336.     Loop
337.  
338.     ' 'flickering candle light
339.     'Color _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
340.  
341.     ' eye sockets
342.     ftri2 dh&, cx - 9 * pr / 12, cy - 2 * pr / 12, cx - 7 * pr / 12, cy - 6 * pr / 12, cx - 3 * pr / 12, cy - 0 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
343.     ftri2 dh&, cx - 7 * pr / 12, cy - 6 * pr / 12, cx - 3 * pr / 12, cy - 0 * pr / 12, cx - 2 * pr / 12, cy - 3 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
344.     ftri2 dh&, cx + 9 * pr / 12, cy - 2 * pr / 12, cx + 7 * pr / 12, cy - 6 * pr / 12, cx + 3 * pr / 12, cy - 0 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
345.     ftri2 dh&, cx + 7 * pr / 12, cy - 6 * pr / 12, cx + 3 * pr / 12, cy - 0 * pr / 12, cx + 2 * pr / 12, cy - 3 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
346.  
347.     ' nose
348.     ftri2 dh&, cx, cy - rand%(2, 5) * pr / 12, cx - 2 * pr / 12, cy + 2 * pr / 12, cx + rand%(1, 2) * pr / 12, cy + 2 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
349.  
350.     ' evil grin
351.     ftri2 dh&, cx - 9 * pr / 12, cy + 1 * pr / 12, cx - 7 * pr / 12, cy + 7 * pr / 12, cx - 6 * pr / 12, cy + 5 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
352.     ftri2 dh&, cx + 9 * pr / 12, cy + 1 * pr / 12, cx + 7 * pr / 12, cy + 7 * pr / 12, cx + 6 * pr / 12, cy + 5 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
353.  
354.     ' moving teeth/talk/grrrr..
355.     u = rand%(4, 8)
356.     dx = pr / u
357.     For i = 1 To u
358.         tx1 = cx - 6 * pr / 12 + (i - 1) * dx
359.         tx2 = tx1 + .5 * dx
360.         tx3 = tx1 + dx
361.         ty1 = cy + 5 * pr / 12
362.         ty3 = cy + 5 * pr / 12
363.         ty2 = cy + (4 - Rnd) * pr / 12
364.         ty22 = cy + (6 + Rnd) * pr / 12
365.         ftri2 dh&, tx1, ty1, tx2, ty2, tx3, ty3, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
366.         ftri2 dh&, tx1 + .5 * dx, ty1, tx2 + .5 * dx, ty22, tx3 + .5 * dx, ty3, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
367.     Next
368.     If limit Then
369.         'shifty eyes
370.         If limit = 3 Then sxs = sx Else sxs = .1 * limit * sx
371.         pumpkin dh&, sxs + cx - 5 * pr / 12, cy - 2.5 * pr / 12, .15 * pr, Int(limit - 1)
372.         pumpkin dh&, sxs + cx + 5 * pr / 12, cy - 2.5 * pr / 12, .15 * pr, Int(limit - 1)
373.     End If
374. End Sub
375.  
376. Sub fEllipse (CX As Long, CY As Long, xRadius As Long, yRadius As Long)
377.     Dim scale As Single, x As Long, y As Long
378.     scale = yRadius / xRadius
379.     Line (CX, CY - yRadius)-(CX, CY + yRadius), , BF
380.     For x = 1 To xRadius
381.         y = scale * Sqr(xRadius * xRadius - x * x)
382.         Line (CX + x, CY - y)-(CX + x, CY + y), , BF
383.         Line (CX - x, CY - y)-(CX - x, CY + y), , BF
384.     Next
385. End Sub
386.  
387. Sub ellipse (CX As Long, CY As Long, xRadius As Long, yRadius As Long)
388.     Dim scale As Single, xs As Long, x As Long, y As Long
389.     Dim lastx As Long, lasty As Long
390.     scale = yRadius / xRadius: xs = xRadius * xRadius
391.     PSet (CX, CY - yRadius): PSet (CX, CY + yRadius)
392.     lastx = 0: lasty = yRadius
393.     For x = 1 To xRadius
394.         y = scale * Sqr(xs - x * x)
395.         Line (CX + lastx, CY - lasty)-(CX + x, CY - y)
396.         Line (CX + lastx, CY + lasty)-(CX + x, CY + y)
397.         Line (CX - lastx, CY - lasty)-(CX - x, CY - y)
398.         Line (CX - lastx, CY + lasty)-(CX - x, CY + y)
399.         lastx = x: lasty = y
400.     Next
401. End Sub
402.  
403. Sub ftri2 (returnDest&, x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
404.     Dim a&
405.     a& = _NewImage(1, 1, 32)
406.     _Dest a&
407.     PSet (0, 0), K
408.     _Dest returnDest&
409.     _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
410.     _FreeImage a& '<<< this is important!
411. End Sub
412.  
413. Function rand% (lo%, hi%)
414.     rand% = Int(Rnd * (hi% - lo% + 1)) + lo%
415. End Function
416.  
417.  
418.  
419. Sub drawLink (x1, y1, r1, x2, y2, r2, c As _Unsigned Long)
420.     Dim a, a1, a2, x3, x4, x5, x6, y3, y4, y5, y6
421.     a = _Atan2(y2 - y1, x2 - x1)
422.     a1 = a + _Pi(1 / 2)
423.     a2 = a - _Pi(1 / 2)
424.     x3 = x1 + r1 * Cos(a1): y3 = y1 + r1 * Sin(a1)
425.     x4 = x1 + r1 * Cos(a2): y4 = y1 + r1 * Sin(a2)
426.     x5 = x2 + r2 * Cos(a1): y5 = y2 + r2 * Sin(a1)
427.     x6 = x2 + r2 * Cos(a2): y6 = y2 + r2 * Sin(a2)
428.     fquad x3, y3, x4, y4, x5, y5, x6, y6, c
429.     Fcirc x1, y1, r1, c
430.     Fcirc x2, y2, r2, c
431. End Sub
432.  
433. 'need 4 non linear points (not all on 1 line) list them clockwise so x2, y2 is opposite of x4, y4
434. 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)
435.     ftri x1, y1, x2, y2, x4, y4, c
436.     ftri x3, y3, x4, y4, x1, y1, c
437. End Sub
438.  
439. Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
440.     Dim a&
441.     a& = _NewImage(1, 1, 32)
442.     _Dest a&
443.     PSet (0, 0), K
444.     _Dest 0
445.     _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
446.     _FreeImage a& '<<< this is important!
447. End Sub
448.  
449. Sub TiltedEllipseFill (destHandle&, x0, y0, a, b, ang, c As _Unsigned Long)
450.     Dim max As Integer, mx2 As Integer, i As Integer, j As Integer, k As Single, lasti As Single, lastj As Single
451.     Dim prc As _Unsigned Long, tef As Long
452.     prc = _RGB32(255, 255, 255, 255)
453.     If a > b Then max = a + 1 Else max = b + 1
454.     mx2 = max + max
455.     tef = _NewImage(mx2, mx2)
456.     _Dest tef
457.     _Source tef 'point wont read without this!
458.     For k = 0 To 6.2832 + .05 Step .1
459.         i = max + a * Cos(k) * Cos(ang) + b * Sin(k) * Sin(ang)
460.         j = max + a * Cos(k) * Sin(ang) - b * Sin(k) * Cos(ang)
461.         If k <> 0 Then
462.             Line (lasti, lastj)-(i, j), prc
463.         Else
464.             PSet (i, j), prc
465.         End If
466.         lasti = i: lastj = j
467.     Next
468.     Dim xleft(mx2) As Integer, xright(mx2) As Integer, x As Integer, y As Integer
469.     For y = 0 To mx2
470.         x = 0
471.         While Point(x, y) <> prc And x < mx2
472.             x = x + 1
473.         Wend
474.         xleft(y) = x
475.         While Point(x, y) = prc And x < mx2
476.             x = x + 1
477.         Wend
478.         While Point(x, y) <> prc And x < mx2
479.             x = x + 1
480.         Wend
481.         If x = mx2 Then xright(y) = xleft(y) Else xright(y) = x
482.     Next
483.     _Dest destHandle&
484.     For y = 0 To mx2
485.         If xleft(y) <> mx2 Then Line (xleft(y) + x0 - max, y + y0 - max)-(xright(y) + x0 - max, y + y0 - max), c, BF
486.     Next
487.     _FreeImage tef
488. End Sub
489.  
490. Sub Fcirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
491.     Dim Radius As Long, RadiusError As Long
492.     Dim X As Long, Y As Long
493.     Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
494.     If Radius = 0 Then PSet (CX, CY), C: Exit Sub
495.     Line (CX - X, CY)-(CX + X, CY), C, BF
496.     While X > Y
497.         RadiusError = RadiusError + Y * 2 + 1
498.         If RadiusError >= 0 Then
499.             If X <> Y + 1 Then
500.                 Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
501.                 Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
502.             End If
503.             X = X - 1
504.             RadiusError = RadiusError - X * 2
505.         End If
506.         Y = Y + 1
507.         Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
508.         Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
509.     Wend
510. End Sub
511.  
512. Sub drawSpinner (x As Integer, y As Integer, scale As Single, heading As Single, c As _Unsigned Long)
513.     Dim x1, x2, x3, x4, y1, y2, y3, y4, r, a, a1, a2, lg, d, rd
514.     Dim rred, bblue, ggreen
515.     Static switch As Integer
516.     switch = switch + 2
517.     switch = switch Mod 16 + 1
518.     rred = _Red32(c): ggreen = _Green32(c): bblue = _Blue32(c)
519.     r = 10 * scale
520.     x1 = x + r * Cos(heading): y1 = y + r * Sin(heading)
521.     r = 2 * r 'lg lengths
522.     For lg = 1 To 8
523.         If lg < 5 Then
524.             a = heading + .9 * lg * _Pi(1 / 5) + (lg = switch) * _Pi(1 / 10)
525.         Else
526.             a = heading - .9 * (lg - 4) * _Pi(1 / 5) - (lg = switch) * _Pi(1 / 10)
527.         End If
528.         x2 = x1 + r * Cos(a): y2 = y1 + r * Sin(a)
529.         drawLink x1, y1, 3 * scale, x2, y2, 2 * scale, _RGB32(rred + 20, ggreen + 10, bblue + 5)
530.         If lg = 1 Or lg = 2 Or lg = 7 Or lg = 8 Then d = -1 Else d = 1
531.         a1 = a + d * _Pi(1 / 12)
532.         x3 = x2 + r * 1.5 * Cos(a1): y3 = y2 + r * 1.5 * Sin(a1)
533.         drawLink x2, y2, 2 * scale, x3, y3, scale, _RGB32(rred + 35, ggreen + 17, bblue + 8)
534.         rd = Int(Rnd * 8) + 1
535.         a2 = a1 + d * _Pi(1 / 8) * rd / 8
536.         x4 = x3 + r * 1.5 * Cos(a2): y4 = y3 + r * 1.5 * Sin(a2)
537.         drawLink x3, y3, scale, x4, y4, scale, _RGB32(rred + 50, ggreen + 25, bblue + 12)
538.     Next
539.     r = r * .5
540.     Fcirc x1, y1, r, _RGB32(rred - 20, ggreen - 10, bblue - 5)
541.     x2 = x1 + (r + 1) * Cos(heading - _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading - _Pi(1 / 12))
542.     Fcirc x2, y2, r * .2, &HFF000000
543.     x2 = x1 + (r + 1) * Cos(heading + _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading + _Pi(1 / 12))
544.     Fcirc x2, y2, r * .2, &HFF000000
545.     r = r * 2
546.     x1 = x + r * .9 * Cos(heading + _Pi): y1 = y + r * .9 * Sin(heading + _Pi)
547.     TiltedEllipseFill 0, x1, y1, r, .7 * r, heading + _Pi, _RGB32(rred, ggreen, bblue)
548. End Sub
549.  
550.  

Attached is Source and .exe for Windows (no assets program)
  [ This attachment cannot be displayed inline in 'Print Page' view ]  

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: Cobalt on October 19, 2021, 08:18:38 pm

Not bad. The drop delay was a bit slow for my taste though.
Would have been a neat addition to have the pieces drop down the board rather than just pop in place, and using an overlay you could even "simulate" round pieces!

and Yes I LOST! nearly had the whole board filled though.

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: jack on October 19, 2021, 08:19:04 pm

hi bplus
the game play would be better if you could also select the row

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: bplus on October 19, 2021, 08:29:47 pm

@Cobalt nice suggestions thanks!

@jack what? AI pieces have to be in next available slot in column just like yours, maybe AI makes it's move too fast? It's last move is the lighter blue square. It goes first in first game but you go first in next, it alternates.

The human player (you) must keep pressing spacebar until the pumpkin piece is over the column you want then just wait or wait in holding area or spacebar back to holding area until you are sure of your column.

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: bplus on October 19, 2021, 08:33:47 pm

Quote from: jack on October 19, 2021, 08:19:04 pm

hi bplus
the game play would be better if you could also select the row

Ah! you haven't played Connect 4 before. OK

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: Pete on October 19, 2021, 09:05:10 pm

The game would be better if you could blow stuff up. I played 4 times. I lost 4 times. I had to go in the backyard and blow up the barbecue. Oh well, it's the neighbors. Sorry Cobalt, it was getting rusty, anyway.

Pete

5 of 5: 🎃🎃🎃🎃🎃 

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: bplus on October 19, 2021, 09:25:27 pm

Here is Cobalt's suggestion about dropping the pumpkin piece down as you would see it on a real game board:
Luv it!

Code: QB64: [Select]

1. Option _Explicit ' One Key Connect 4 (8x8) Halloween Style - bplus 2021-10-19
2. Const SQ = 60 '       square or grid cell
3. Const NumCols = 8 '   number of columns
4. Const NumRows = 8 '   you guessed it
5. Const NCM1 = NumCols - 1 ' NumCols minus 1
6. Const NRM1 = NumRows - 1 ' you can guess surely
7. Const SW = SQ * (NumCols + 2) '  screen width
8. Const SH = SQ * (NumRows + 3) '  screen height
9. Const P = 1 '       Player is 1 on grid
10. Const AI = -1 '     AI is -1 on grid
11. Const XO = SQ '     x offset for grid
12. Const YO = 2 * SQ ' y offset for grid
13.  
14. ReDim Shared Grid(NCM1, NRM1) ' 0 = empty  P=1 for Player,  AI=-1  for AI so -4 is win for AI..
15. ReDim Shared DX(7), DY(7) ' Directions
16. DX(0) = 1: DY(0) = 0 ': DString$(0) = "East"
17. DX(1) = 1: DY(1) = 1 ': DString$(1) = "South East"
18. DX(2) = 0: DY(2) = 1 ': DString$(2) = "South"
19. DX(3) = -1: DY(3) = 1 ': DString$(3) = "South West"
20. DX(4) = -1: DY(4) = 0 ': DString$(4) = "West"
21. DX(5) = -1: DY(5) = -1 ': DString$(5) = "North West"
22. DX(6) = 0: DY(6) = -1 ': DString$(6) = "North"
23. DX(7) = 1: DY(7) = -1 ' : DString$(7) = "North East"
24. ReDim Shared Scores(NCM1) ' rating column for AI and displaying them
25. ReDim Shared AIX, AIY ' last move of AI for highlighting in display
26. ReDim Shared WinX, WinY, WinD ' display Winning Connect 4
27. ReDim Shared GameOn, Turn, GoFirst, PlayerLastMoveCol, PlayerLastMoveRow, MoveNum ' game tracking
28. ReDim Shared Record$(NCM1, NRM1)
29. Dim Shared sx ' for pumpkin recursion shifty eyes
30. Dim place, k$, t, r, s$, pr, d, temp&, target, y, delaid
31.  
32. Screen _NewImage(SW, SH, 32)
33. _ScreenMove 360, 60
34.  
35. _Title "One Key Connect 4 (8x8) Halloween Style"
36. d = 1
37. While _KeyDown(32) = 0
38.     Cls
39.     pumpkin 0, _Width / 2, _Height / 2, _Height / 2.3, 3
40.     sx = sx + d
41.     If sx > 10 Then d = -d: sx = 10
42.     If sx < -10 Then d = -d: sx = -10
43.     Color &HFFFFFFFF, &HFF000000:
44.     Locate 40, 33: Print "Spacebar Only"
45.     _Display
46.     _Limit 20
47. Wend
48. _KeyClear
49. GameOn = -1: GoFirst = AI: Turn = AI: MoveNum = 0
50. ShowGrid
51. place = -1
52. t = Timer
53. pr = (SQ - 6) / 2
54. While GameOn
55.     Cls
56.     If Turn = P Then
57.         k$ = InKey$
58.         If k$ = Chr$(27) Then System ' emergency exit
59.  
60.         If k$ = " " Then
61.             t = Timer: place = place + 1
62.             If place >= NumCols Then place = -1
63.         Else ' watch out for midnight!
64.             If Timer - t < 0 Then 'midnight problem
65.                 t = Timer ' wait a little longer
66.             Else
67.                 If Timer - t > 3 And place <> -1 Then ' col selected
68.                     r = GetOpenRow(place)
69.                     If r <> NumRows Then
70.                         Cls
71.                         ShowGrid
72.                         _Display
73.                         temp& = _NewImage(_Width, _Height, 32)
74.                         _PutImage , 0, temp& 'snapshot
75.                         y = SQ + SQ / 2
76.                         target = r * SQ + YO + SQ / 2
77.                         delaid = 6
78.                         While y < target
79.                             y = y + 1
80.                             Cls
81.                             _PutImage , temp&, 0
82.                             pumpkin 0, place * SQ + XO + SQ / 2, y, pr, 3
83.                             sx = Rnd * 6 - 3
84.                             _Display
85.                             _Limit delaid
86.                             delaid = delaid + 2
87.                         Wend
88.                         _FreeImage temp&
89.                         Grid(place, r) = P: Turn = AI: PlayerLastMoveCol = place: PlayerLastMoveRow = r: MoveNum = MoveNum + 1
90.                         place = -1 ' reset back to hold area
91.                     Else
92.                         Beep
93.                     End If
94.                 End If
95.             End If
96.         End If
97.     Else
98.         AIMove
99.         Turn = P: MoveNum = MoveNum + 1: t = Timer
100.     End If
101.     ShowGrid
102.     If Turn = P Then
103.         If place = -1 Then
104.             s$ = "Holding area, press spacebar until over column to play."
105.         Else
106.             s$ = "Press Spacebar, if don't want to play" + Str$(place) + " column."
107.         End If
108.         Color &HFFFFFFFF, 0
109.         _PrintString (XO, YO - SQ - 16), s$
110.     End If
111.     pumpkin 0, place * SQ + XO + SQ / 2, SQ + SQ / 2, pr, 3
112.     sx = Rnd * 6 - 3
113.     _Display
114.     _Limit 15
115. Wend
116.  
117. Sub AIMove
118.     ' What this sub does in English:
119.     ' This sub assigns the value to playing each column, then plays the best value with following caveats:
120.     ' + If it finds a winning move, it will play that immediately.
121.     ' + If it finds a spoiler move, it will play that if no winning move was found.
122.     ' + It will poisen the column's scoring, if opponent can play a winning move if AI plays this column,
123.     '   but it might be the only legal move left.  We will have to play it if no better score was found.
124.  
125.     Dim c, r, d, cntA, cntP, bestScore, startR, startC, iStep, test, goodF, i
126.     Dim openRow(NCM1) ' find open rows once
127.     ReDim Scores(NCM1) ' evaluate each column's potential
128.     AIX = -1: AIY = -1 ' set these when AI makes move, they are signal to display procedure AI's move.
129.     For c = 0 To NCM1
130.         openRow(c) = GetOpenRow(c)
131.         r = openRow(c)
132.         If r <> NumRows Then
133.             For d = 0 To 3 ' 4 directions to build connect 4's that use cell c, r
134.                 startC = c + -3 * DX(d): startR = r + -3 * DY(d)
135.                 For i = 0 To 3 ' here we backup from the potential connect 4 in opposite build direction of c, r
136.                     cntA = 0: cntP = 0: goodF = -1 ' reset counts and flag for good connect 4
137.                     'from this start position run 4 steps forward to count all connects involving cell c, r
138.                     For iStep = 0 To 3 ' process a potential connect 4
139.                         test = GR(startC + i * DX(d) + iStep * DX(d), startR + i * DY(d) + iStep * DY(d))
140.                         If test = NumRows Then goodF = 0: Exit For 'cant get connect4 from here
141.                         If test = AI Then cntA = cntA + 1
142.                         If test = P Then cntP = cntP + 1
143.                     Next iStep
144.                     If goodF Then 'evaluate the Legal Connect4 we could build with c, r
145.                         If cntA = 3 Then ' we are done!  winner!
146.                             AIX = c: AIY = r ' <<< this is the needed 4th cell to win tell ShowGrid last cell
147.                             Grid(c, r) = AI '  <<< this is the needed 4th cell to win, add to grid this is AI move
148.                             Scores(c) = 1000
149.                             Exit Sub
150.                         ElseIf cntP = 3 Then 'next best move spoiler!
151.                             AIX = c: AIY = r 'set the move but don't exit there might be a winner
152.                             Scores(c) = 900
153.                         ElseIf cntA = 0 And cntP = 2 Then
154.                             Scores(c) = Scores(c) + 8
155.                         ElseIf cntA = 2 And cntP = 0 Then ' very good offense or defense
156.                             Scores(c) = Scores(c) + 4 'play this to connect 3 or prevent player from Connect 3
157.                         ElseIf cntA = 0 And cntP = 1 Then
158.                             Scores(c) = Scores(c) + 4
159.                         ElseIf (cntA = 1 And cntP = 0) Then 'good offense or defense
160.                             Scores(c) = Scores(c) + 2 ' play this to connect 2 or prevent player from Connect 2
161.                         ElseIf (cntA = 0 And cntP = 0) Then ' OK it's not a wasted move as it has potential for connect4
162.                             Scores(c) = Scores(c) + 1 ' this is good move because this can still be a Connect 4
163.                         End If
164.                     End If ' in the board
165.                 Next i
166.             Next d
167.             If Stupid(c, r) Then Scores(c) = -1000 + Scores(c) ' poison because if played the human can win
168.         End If
169.     Next
170.     If AIX <> -1 Then ' we found a spoiler so move there since we haven't found a winner
171.         Grid(AIX, AIY) = AI ' make move on grid and done!
172.         Exit Sub
173.     Else
174.         If GetOpenRow(PlayerLastMoveCol) < NumRows Then 'all things being equal play on top of player's last move
175.             bestScore = Scores(PlayerLastMoveCol): AIY = PlayerLastMoveRow - 1: AIX = PlayerLastMoveCol
176.         Else
177.             bestScore = -1000 ' a negative score indicates that the player can beat AI with their next move
178.         End If
179.         For c = 0 To NCM1
180.             r = openRow(c)
181.             If r <> NumRows Then
182.                 If Scores(c) > bestScore Then bestScore = Scores(c): AIY = r: AIX = c
183.             End If
184.         Next
185.         If AIX <> -1 Then
186.             Grid(AIX, AIY) = AI ' make first best score move we found
187.         Else 'We have trouble!  Oh but it could be there are no moves!!!
188.             ' checkWin is run after every move by AI or Player if there were no legal moves left it should have caught that.
189.             ' Just in case it didn't here is an error stop!
190.             Beep: Locate 4, 2: Print "AI has failed to find a proper move, press any to end..."
191.             Sleep ' <<< pause until user presses a key
192.             End
193.         End If
194.     End If
195. End Sub
196.  
197. Function GetOpenRow (forCol)
198.     Dim i
199.     GetOpenRow = NumRows 'assume none open
200.     If forCol < 0 Or forCol > NCM1 Then Exit Function
201.     For i = NRM1 To 0 Step -1
202.         If Grid(forCol, i) = 0 Then GetOpenRow = i: Exit Function
203.     Next
204. End Function
205.  
206. Function Stupid (c, r)
207.     Dim pr
208.     Grid(c, r) = AI
209.     pr = GetOpenRow(c)
210.     If pr <> NumRows Then
211.         Grid(c, pr) = P
212.         If CheckWin = 4 Then Stupid = -1
213.         Grid(c, pr) = 0
214.     End If
215.     Grid(c, r) = 0
216. End Function
217.  
218. Function GR (c, r) ' if c, r are out of bounds returns N else returns grid(c, r)
219.     ' need to check the grid(c, r) but only if c, r is on the board
220.     If c < 0 Or c > NCM1 Or r < 0 Or r > NRM1 Then GR = NumRows Else GR = Grid(c, r)
221. End Function
222.  
223. Sub ShowGrid
224.     Static lastMoveNum
225.     Dim i, r, c, check, s$, k$
226.     If MoveNum <> lastMoveNum Then ' file newest move
227.         If MoveNum = 1 Then ReDim Record$(NCM1, NRM1)
228.         If Turn = -1 Then
229.             Record$(PlayerLastMoveCol, PlayerLastMoveRow) = _Trim$(Str$(MoveNum)) + " " + "P"
230.         Else
231.             Record$(AIX, AIY) = _Trim$(Str$(MoveNum)) + " " + "A"
232.         End If
233.         lastMoveNum = MoveNum
234.     End If
235.     'cls
236.     Line (XO, YO)-Step(NumCols * SQ, NumRows * SQ), &HFF004400, BF
237.     For i = 0 To NumCols 'grid
238.         Line (SQ * i + XO, YO)-Step(0, NumRows * SQ), &HFFFFFFFF
239.     Next
240.     For i = 0 To NumRows
241.         Line (XO, SQ * i + YO)-Step(NumCols * SQ, 0), &HFFFFFFFF
242.     Next
243.     For r = NRM1 To 0 Step -1 ''in grid rows are reversed 0 is top row
244.         For c = 0 To NCM1
245.             If Grid(c, r) = P Then
246.                 Line (c * SQ + XO + 3, r * SQ + YO + 3)-Step(SQ - 6, SQ - 6), &HFF000000, BF
247.                 pumpkin 0, c * SQ + XO + SQ / 2, r * SQ + YO + SQ / 2, (SQ - 6) / 2, 2
248.  
249.             ElseIf Grid(c, r) = AI Then
250.                 If c = AIX And r = AIY Then 'highlite last AI move
251.                     Line (c * SQ + XO + 3, r * SQ + YO + 3)-Step(SQ - 6, SQ - 6), &HFF8888FF, BF
252.                 Else
253.                     Line (c * SQ + XO + 3, r * SQ + YO + 3)-Step(SQ - 6, SQ - 6), &HFF4444FF, BF
254.                 End If
255.                 drawSpinner c * SQ + XO + SQ / 2, r * SQ + YO + SQ / 2, .5, _Pi(-c / 8), _RGB32(Rnd * 30 + 40, Rnd * 15 + 20, Rnd * 6 + 10)
256.             End If
257.             s$ = _Trim$(Str$(Scores(c)))
258.             _PrintString (XO + c * SQ + (60 - Len(s$) * 8) / 2, YO + SQ * NumRows + 22), s$
259.         Next
260.     Next
261.     '_Display
262.     check = CheckWin
263.     If check Then 'report end of round ad see if want to play again
264.         If check = 4 Or check = -4 Then
265.             For i = 0 To 3
266.                 Line ((WinX + i * DX(WinD)) * SQ + XO + 5, (WinY + i * DY(WinD)) * SQ + YO + 5)-Step(SQ - 10, SQ - 10), &HFFFFFF00, B
267.             Next
268.         End If
269.         For r = 0 To NRM1
270.             For c = 0 To NCM1
271.                 If Record$(c, r) <> "" Then
272.                     s$ = Mid$(Record$(c, r), 1, InStr(Record$(c, r), " ") - 1)
273.                     If Right$(Record$(c, r), 1) = "A" Then Color &HFFFFFFFF, &HFF000000 Else Color &HFFFFFFFF, &HFF000000
274.                     _PrintString (SQ * c + XO + (SQ - Len(s$) * 8) / 2, SQ * r + YO + 22), s$
275.                 End If
276.             Next
277.             Color , &HFF000000
278.         Next
279.         If check = -4 Then
280.             s$ = " AI is Winner!"
281.         ElseIf check = 4 Then
282.             s$ = " Human is Winner!"
283.         ElseIf check = NumRows Then
284.             s$ = " Board is full, no winner." ' keep Turn the same
285.         End If
286.         Locate 2, ((SW - Len(s$) * 8) / 2) / 8: Print s$
287.         s$ = " Play again? press spacebar, escape to quit... "
288.         Locate 4, ((SW - Len(s$) * 8) / 2) / 8: Print s$
289.         _Display
290.         keywait:
291.         While Len(k$) = 0
292.             k$ = InKey$
293.             _Limit 200
294.         Wend
295.         If k$ = " " Then
296.             ReDim Grid(NCM1, NRM1), Scores(NCM1)
297.             If GoFirst = P Then GoFirst = AI Else GoFirst = P
298.             Turn = GoFirst: MoveNum = 0
299.         ElseIf Asc(k$) = 27 Then
300.             System
301.         Else
302.             k$ = "": GoTo keywait:
303.         End If
304.     End If
305. End Sub
306.  
307. Function CheckWin ' return WinX, WinY, WinD along with +/- 4, returns NumRows if grid full, 0 if no win and grid not full
308.     Dim gridFull, r, c, s, i
309.     gridFull = NumRows
310.     For r = NRM1 To 0 Step -1 'bottom to top
311.         For c = 0 To NCM1
312.             If Grid(c, r) Then ' check if c starts a row
313.                 If c < NCM1 - 2 Then
314.                     s = 0
315.                     For i = 0 To 3 ' east
316.                         s = s + Grid(c + i, r)
317.                     Next
318.                     If s = 4 Or s = -4 Then WinX = c: WinY = r: WinD = 0: CheckWin = s: Exit Function
319.                 End If
320.                 If r > 2 Then ' check if c starts a col
321.                     s = 0
322.                     For i = 0 To 3 ' north
323.                         s = s + Grid(c, r - i)
324.                     Next
325.                     If s = 4 Or s = -4 Then WinX = c: WinY = r: WinD = 6: CheckWin = s: Exit Function
326.                 End If
327.                 If r > 2 And c < NCM1 - 2 Then 'check if c starts diagonal up to right
328.                     s = 0
329.                     For i = 0 To 3 ' north  east
330.                         s = s + Grid(c + i, r - i)
331.                     Next
332.                     If s = 4 Or s = -4 Then WinX = c: WinY = r: WinD = 7: CheckWin = s: Exit Function
333.                 End If
334.                 If r > 2 And c > 2 Then 'check if c starts a diagonal up to left
335.                     s = 0
336.                     For i = 0 To 3 ' north west
337.                         s = s + Grid(c - i, r - i)
338.                     Next
339.                     If s = 4 Or s = -4 Then WinX = c: WinY = r: WinD = 5: CheckWin = s: Exit Function
340.                 End If
341.             Else
342.                 gridFull = 0 ' at least one enpty cell left
343.             End If 'grid is something
344.         Next
345.     Next
346.     CheckWin = gridFull
347. End Function
348.  
349.  
350. Sub pumpkin (dh&, cx, cy, pr, limit)
351.     Dim lastr, u, dx, i, tx1, tx2, tx3, ty1, ty2, ty3, ty22, sxs
352.     'carve this!
353.     Color &HFFFF0000
354.     fEllipse cx, cy, pr, 29 / 35 * pr
355.     Color &HFF000000
356.     lastr = 2 / 7 * pr
357.     Do
358.         ellipse cx, cy, lastr, 29 / 35 * pr
359.         lastr = .5 * (pr - lastr) + lastr + 1 / 35 * pr
360.         If pr - lastr < 1 / 80 * pr Then Exit Do
361.     Loop
362.  
363.     ' 'flickering candle light
364.     'Color _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
365.  
366.     ' eye sockets
367.     ftri2 dh&, cx - 9 * pr / 12, cy - 2 * pr / 12, cx - 7 * pr / 12, cy - 6 * pr / 12, cx - 3 * pr / 12, cy - 0 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
368.     ftri2 dh&, cx - 7 * pr / 12, cy - 6 * pr / 12, cx - 3 * pr / 12, cy - 0 * pr / 12, cx - 2 * pr / 12, cy - 3 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
369.     ftri2 dh&, cx + 9 * pr / 12, cy - 2 * pr / 12, cx + 7 * pr / 12, cy - 6 * pr / 12, cx + 3 * pr / 12, cy - 0 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
370.     ftri2 dh&, cx + 7 * pr / 12, cy - 6 * pr / 12, cx + 3 * pr / 12, cy - 0 * pr / 12, cx + 2 * pr / 12, cy - 3 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
371.  
372.     ' nose
373.     ftri2 dh&, cx, cy - rand%(2, 5) * pr / 12, cx - 2 * pr / 12, cy + 2 * pr / 12, cx + rand%(1, 2) * pr / 12, cy + 2 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
374.  
375.     ' evil grin
376.     ftri2 dh&, cx - 9 * pr / 12, cy + 1 * pr / 12, cx - 7 * pr / 12, cy + 7 * pr / 12, cx - 6 * pr / 12, cy + 5 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
377.     ftri2 dh&, cx + 9 * pr / 12, cy + 1 * pr / 12, cx + 7 * pr / 12, cy + 7 * pr / 12, cx + 6 * pr / 12, cy + 5 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
378.  
379.     ' moving teeth/talk/grrrr..
380.     u = rand%(4, 8)
381.     dx = pr / u
382.     For i = 1 To u
383.         tx1 = cx - 6 * pr / 12 + (i - 1) * dx
384.         tx2 = tx1 + .5 * dx
385.         tx3 = tx1 + dx
386.         ty1 = cy + 5 * pr / 12
387.         ty3 = cy + 5 * pr / 12
388.         ty2 = cy + (4 - Rnd) * pr / 12
389.         ty22 = cy + (6 + Rnd) * pr / 12
390.         ftri2 dh&, tx1, ty1, tx2, ty2, tx3, ty3, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
391.         ftri2 dh&, tx1 + .5 * dx, ty1, tx2 + .5 * dx, ty22, tx3 + .5 * dx, ty3, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
392.     Next
393.     If limit Then
394.         'shifty eyes
395.         If limit = 3 Then sxs = sx Else sxs = .1 * limit * sx
396.         pumpkin dh&, sxs + cx - 5 * pr / 12, cy - 2.5 * pr / 12, .15 * pr, Int(limit - 1)
397.         pumpkin dh&, sxs + cx + 5 * pr / 12, cy - 2.5 * pr / 12, .15 * pr, Int(limit - 1)
398.     End If
399. End Sub
400.  
401. Sub fEllipse (CX As Long, CY As Long, xRadius As Long, yRadius As Long)
402.     Dim scale As Single, x As Long, y As Long
403.     scale = yRadius / xRadius
404.     Line (CX, CY - yRadius)-(CX, CY + yRadius), , BF
405.     For x = 1 To xRadius
406.         y = scale * Sqr(xRadius * xRadius - x * x)
407.         Line (CX + x, CY - y)-(CX + x, CY + y), , BF
408.         Line (CX - x, CY - y)-(CX - x, CY + y), , BF
409.     Next
410. End Sub
411.  
412. Sub ellipse (CX As Long, CY As Long, xRadius As Long, yRadius As Long)
413.     Dim scale As Single, xs As Long, x As Long, y As Long
414.     Dim lastx As Long, lasty As Long
415.     scale = yRadius / xRadius: xs = xRadius * xRadius
416.     PSet (CX, CY - yRadius): PSet (CX, CY + yRadius)
417.     lastx = 0: lasty = yRadius
418.     For x = 1 To xRadius
419.         y = scale * Sqr(xs - x * x)
420.         Line (CX + lastx, CY - lasty)-(CX + x, CY - y)
421.         Line (CX + lastx, CY + lasty)-(CX + x, CY + y)
422.         Line (CX - lastx, CY - lasty)-(CX - x, CY - y)
423.         Line (CX - lastx, CY + lasty)-(CX - x, CY + y)
424.         lastx = x: lasty = y
425.     Next
426. End Sub
427.  
428. Sub ftri2 (returnDest&, x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
429.     Dim a&
430.     a& = _NewImage(1, 1, 32)
431.     _Dest a&
432.     PSet (0, 0), K
433.     _Dest returnDest&
434.     _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
435.     _FreeImage a& '<<< this is important!
436. End Sub
437.  
438. Function rand% (lo%, hi%)
439.     rand% = Int(Rnd * (hi% - lo% + 1)) + lo%
440. End Function
441.  
442.  
443.  
444. Sub drawLink (x1, y1, r1, x2, y2, r2, c As _Unsigned Long)
445.     Dim a, a1, a2, x3, x4, x5, x6, y3, y4, y5, y6
446.     a = _Atan2(y2 - y1, x2 - x1)
447.     a1 = a + _Pi(1 / 2)
448.     a2 = a - _Pi(1 / 2)
449.     x3 = x1 + r1 * Cos(a1): y3 = y1 + r1 * Sin(a1)
450.     x4 = x1 + r1 * Cos(a2): y4 = y1 + r1 * Sin(a2)
451.     x5 = x2 + r2 * Cos(a1): y5 = y2 + r2 * Sin(a1)
452.     x6 = x2 + r2 * Cos(a2): y6 = y2 + r2 * Sin(a2)
453.     fquad x3, y3, x4, y4, x5, y5, x6, y6, c
454.     Fcirc x1, y1, r1, c
455.     Fcirc x2, y2, r2, c
456. End Sub
457.  
458. 'need 4 non linear points (not all on 1 line) list them clockwise so x2, y2 is opposite of x4, y4
459. 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)
460.     ftri x1, y1, x2, y2, x4, y4, c
461.     ftri x3, y3, x4, y4, x1, y1, c
462. End Sub
463.  
464. Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
465.     Dim a&
466.     a& = _NewImage(1, 1, 32)
467.     _Dest a&
468.     PSet (0, 0), K
469.     _Dest 0
470.     _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
471.     _FreeImage a& '<<< this is important!
472. End Sub
473.  
474. Sub TiltedEllipseFill (destHandle&, x0, y0, a, b, ang, c As _Unsigned Long)
475.     Dim max As Integer, mx2 As Integer, i As Integer, j As Integer, k As Single, lasti As Single, lastj As Single
476.     Dim prc As _Unsigned Long, tef As Long
477.     prc = _RGB32(255, 255, 255, 255)
478.     If a > b Then max = a + 1 Else max = b + 1
479.     mx2 = max + max
480.     tef = _NewImage(mx2, mx2)
481.     _Dest tef
482.     _Source tef 'point wont read without this!
483.     For k = 0 To 6.2832 + .05 Step .1
484.         i = max + a * Cos(k) * Cos(ang) + b * Sin(k) * Sin(ang)
485.         j = max + a * Cos(k) * Sin(ang) - b * Sin(k) * Cos(ang)
486.         If k <> 0 Then
487.             Line (lasti, lastj)-(i, j), prc
488.         Else
489.             PSet (i, j), prc
490.         End If
491.         lasti = i: lastj = j
492.     Next
493.     Dim xleft(mx2) As Integer, xright(mx2) As Integer, x As Integer, y As Integer
494.     For y = 0 To mx2
495.         x = 0
496.         While Point(x, y) <> prc And x < mx2
497.             x = x + 1
498.         Wend
499.         xleft(y) = x
500.         While Point(x, y) = prc And x < mx2
501.             x = x + 1
502.         Wend
503.         While Point(x, y) <> prc And x < mx2
504.             x = x + 1
505.         Wend
506.         If x = mx2 Then xright(y) = xleft(y) Else xright(y) = x
507.     Next
508.     _Dest destHandle&
509.     For y = 0 To mx2
510.         If xleft(y) <> mx2 Then Line (xleft(y) + x0 - max, y + y0 - max)-(xright(y) + x0 - max, y + y0 - max), c, BF
511.     Next
512.     _FreeImage tef
513. End Sub
514.  
515. Sub Fcirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
516.     Dim Radius As Long, RadiusError As Long
517.     Dim X As Long, Y As Long
518.     Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
519.     If Radius = 0 Then PSet (CX, CY), C: Exit Sub
520.     Line (CX - X, CY)-(CX + X, CY), C, BF
521.     While X > Y
522.         RadiusError = RadiusError + Y * 2 + 1
523.         If RadiusError >= 0 Then
524.             If X <> Y + 1 Then
525.                 Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
526.                 Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
527.             End If
528.             X = X - 1
529.             RadiusError = RadiusError - X * 2
530.         End If
531.         Y = Y + 1
532.         Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
533.         Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
534.     Wend
535. End Sub
536.  
537. Sub drawSpinner (x As Integer, y As Integer, scale As Single, heading As Single, c As _Unsigned Long)
538.     Dim x1, x2, x3, x4, y1, y2, y3, y4, r, a, a1, a2, lg, d, rd
539.     Dim rred, bblue, ggreen
540.     Static switch As Integer
541.     switch = switch + 2
542.     switch = switch Mod 16 + 1
543.     rred = _Red32(c): ggreen = _Green32(c): bblue = _Blue32(c)
544.     r = 10 * scale
545.     x1 = x + r * Cos(heading): y1 = y + r * Sin(heading)
546.     r = 2 * r 'lg lengths
547.     For lg = 1 To 8
548.         If lg < 5 Then
549.             a = heading + .9 * lg * _Pi(1 / 5) + (lg = switch) * _Pi(1 / 10)
550.         Else
551.             a = heading - .9 * (lg - 4) * _Pi(1 / 5) - (lg = switch) * _Pi(1 / 10)
552.         End If
553.         x2 = x1 + r * Cos(a): y2 = y1 + r * Sin(a)
554.         drawLink x1, y1, 3 * scale, x2, y2, 2 * scale, _RGB32(rred + 20, ggreen + 10, bblue + 5)
555.         If lg = 1 Or lg = 2 Or lg = 7 Or lg = 8 Then d = -1 Else d = 1
556.         a1 = a + d * _Pi(1 / 12)
557.         x3 = x2 + r * 1.5 * Cos(a1): y3 = y2 + r * 1.5 * Sin(a1)
558.         drawLink x2, y2, 2 * scale, x3, y3, scale, _RGB32(rred + 35, ggreen + 17, bblue + 8)
559.         rd = Int(Rnd * 8) + 1
560.         a2 = a1 + d * _Pi(1 / 8) * rd / 8
561.         x4 = x3 + r * 1.5 * Cos(a2): y4 = y3 + r * 1.5 * Sin(a2)
562.         drawLink x3, y3, scale, x4, y4, scale, _RGB32(rred + 50, ggreen + 25, bblue + 12)
563.     Next
564.     r = r * .5
565.     Fcirc x1, y1, r, _RGB32(rred - 20, ggreen - 10, bblue - 5)
566.     x2 = x1 + (r + 1) * Cos(heading - _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading - _Pi(1 / 12))
567.     Fcirc x2, y2, r * .2, &HFF000000
568.     x2 = x1 + (r + 1) * Cos(heading + _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading + _Pi(1 / 12))
569.     Fcirc x2, y2, r * .2, &HFF000000
570.     r = r * 2
571.     x1 = x + r * .9 * Cos(heading + _Pi): y1 = y + r * .9 * Sin(heading + _Pi)
572.     TiltedEllipseFill 0, x1, y1, r, .7 * r, heading + _Pi, _RGB32(rred, ggreen, bblue)
573. End Sub
574.  
575.  

For Pete:
 

For friends at Syntax Bomb the Windows compiled version and source:
(Updated just before midnight, only one download before update)

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: Pete on October 19, 2021, 10:01:23 pm

I like the original version better, but then I'm impatient. I see my avatar stomping that pumpkin into place with his tiny Western boots.

If I had one suggestion to make this version better, it would be to add a gravity factor, so the pumpkin picks up speed as it falls.

I thought you might make it shake a bit as it falls, although the last time I played this game, I was 8.

Pete

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: bplus on October 19, 2021, 11:15:17 pm

delaid variable in _Limit increases allowing more loop updates per second.
Not just gravity, frictional force works against complete freefall of piece. I thought it noticeable specially at the beginning.

Code: QB64: [Select]

1.                         While y < target
2.                             y = y + 1
3.                             Cls
4.                             _PutImage , temp&, 0
5.                             pumpkin 0, place * SQ + XO + SQ / 2, y, pr, 3
6.                             sx = Rnd * 6 - 3
7.                             _Display
8.                             _Limit delaid
9.                             delaid = delaid + 2
10.                         Wend
11.  

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: bplus on October 19, 2021, 11:57:17 pm

OK I sped up the drop, decreased the Timer difference from 4 to 2 secs and it turns out the screen update sub ShowGrid is fast enough that I don't have to take a screen snapshot so the pumpkins and spiders remain quite active as the pumpkin piece drops down the column.

Modified to this section in code:

Code: QB64: [Select]

1.                 If Timer - t > 2 And place <> -1 Then ' col selected
2.                     r = GetOpenRow(place)
3.                     If r <> NumRows Then
4.                         y = SQ + SQ / 2
5.                         target = r * SQ + YO + SQ / 2
6.                         delaid = 6
7.                         While y < target
8.                             y = y + 1
9.                             Cls
10.                             ShowGrid
11.                             pumpkin 0, place * SQ + XO + SQ / 2, y, pr, 3
12.                             sx = Rnd * 6 - 3
13.                             _Display
14.                             _Limit delaid
15.                             delaid = delaid * 2
16.                         Wend
17.                         Grid(place, r) = P: Turn = AI: PlayerLastMoveCol = place: PlayerLastMoveRow = r: MoveNum = MoveNum + 1
18.                         place = -1 ' reset back to hold area
19.                     Else
20.                         Beep
21.                     End If
22.                 End If
23.  

I have changed out the old zip file in Best Answer with the new code source and Windows compiled .exe, so it is still Best Answer and spiders and pumpkins all move while piece falls into place.

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: Pete on October 20, 2021, 12:36:54 am

Better. Either that, or I'm just in a better mood because after 7 games, I finally beat the A.I.

Pete 👠 Woooohoooo!

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: Cobalt on October 22, 2021, 11:14:26 am

I added that board overlay I was talking about.

Code: QB64: [Select]

1. 'OPTION _EXPLICIT ' One Key Connect 4 (8x8) Halloween Style - bplus 2021-10-19
2. CONST SQ = 60 '       square or grid cell
3. CONST NumCols = 8 '   number of columns
4. CONST NumRows = 8 '   you guessed it
5. CONST NCM1 = NumCols - 1 ' NumCols minus 1
6. CONST NRM1 = NumRows - 1 ' you can guess surely
7. CONST SW = SQ * (NumCols + 2) '  screen width
8. CONST SH = SQ * (NumRows + 3) '  screen height
9. CONST P = 1 '       Player is 1 on grid
10. CONST AI = -1 '     AI is -1 on grid
11. CONST XO = SQ '     x offset for grid
12. CONST YO = 2 * SQ ' y offset for grid
13.  
14. REDIM SHARED Grid(NCM1, NRM1) ' 0 = empty  P=1 for Player,  AI=-1  for AI so -4 is win for AI..
15. REDIM SHARED DX(7), DY(7) ' Directions
16. DX(0) = 1: DY(0) = 0 ': DString$(0) = "East"
17. DX(1) = 1: DY(1) = 1 ': DString$(1) = "South East"
18. DX(2) = 0: DY(2) = 1 ': DString$(2) = "South"
19. DX(3) = -1: DY(3) = 1 ': DString$(3) = "South West"
20. DX(4) = -1: DY(4) = 0 ': DString$(4) = "West"
21. DX(5) = -1: DY(5) = -1 ': DString$(5) = "North West"
22. DX(6) = 0: DY(6) = -1 ': DString$(6) = "North"
23. DX(7) = 1: DY(7) = -1 ' : DString$(7) = "North East"
24. REDIM SHARED Scores(NCM1) ' rating column for AI and displaying them
25. REDIM SHARED AIX, AIY ' last move of AI for highlighting in display
26. REDIM SHARED WinX, WinY, WinD ' display Winning Connect 4
27. REDIM SHARED GameOn, Turn, GoFirst, PlayerLastMoveCol, PlayerLastMoveRow, MoveNum ' game tracking
28. REDIM SHARED Record$(NCM1, NRM1)
29. DIM SHARED sx ' for pumpkin recursion shifty eyes
30. DIM place, k$, t, r, s$, pr, d, temp&, target, y, delaid
31. DIM SHARED Overlay& 'the board overlay
32.  
33. SCREEN _NEWIMAGE(SW, SH, 32)
34. _SCREENMOVE 360, 60
35. Overlay& = _NEWIMAGE(SW, SH, 32)
36. Create_Board
37.  
38. _TITLE "One Key Connect 4 (8x8) Halloween Style"
39. d = 1
40. WHILE _KEYDOWN(32) = 0
41.  CLS
42.  pumpkin 0, _WIDTH / 2, _HEIGHT / 2, _HEIGHT / 2.3, 3
43.  sx = sx + d
44.  IF sx > 10 THEN d = -d: sx = 10
45.  IF sx < -10 THEN d = -d: sx = -10
46.  COLOR &HFFFFFFFF, &HFF000000:
47.  LOCATE 40, 33: PRINT "Spacebar Only"
48.  _DISPLAY
49.  _LIMIT 20
50. WEND
51. _KEYCLEAR
52. GameOn = -1: GoFirst = AI: Turn = AI: MoveNum = 0
53. ShowGrid
54. place = -1
55. t = TIMER
56. pr = (SQ - 6) / 2
57. WHILE GameOn
58.  CLS
59.  IF Turn = P THEN
60.   k$ = INKEY$
61.   IF k$ = CHR$(27) THEN SYSTEM ' emergency exit
62.   IF k$ = " " THEN
63.    t = TIMER: place = place + 1
64.    IF place >= NumCols THEN place = -1
65.   ELSE ' watch out for midnight!
66.    IF TIMER - t < 0 THEN 'midnight problem
67.     t = TIMER ' wait a little longer
68.    ELSE
69.     IF TIMER - t > 2 AND place <> -1 THEN ' col selected
70.      r = GetOpenRow(place)
71.      IF r <> NumRows THEN
72.       y = SQ + SQ / 2
73.       target = r * SQ + YO + SQ / 2
74.       delaid = 6
75.       WHILE y < target
76.        y = y + 1
77.        CLS
78.        ShowGrid
79.        pumpkin 0, place * SQ + XO + SQ / 2, y, pr, 3
80.        sx = RND * 6 - 3
81.        _PUTIMAGE , Overlay&, _DISPLAY
82.        _DISPLAY
83.        _LIMIT delaid
84.        delaid = delaid * 2
85.       WEND
86.       Grid(place, r) = P: Turn = AI: PlayerLastMoveCol = place: PlayerLastMoveRow = r: MoveNum = MoveNum + 1
87.       place = -1 ' reset back to hold area
88.      ELSE
89.       BEEP
90.      END IF
91.     END IF
92.    END IF
93.   END IF
94.  ELSE
95.   AIMove
96.   Turn = P: MoveNum = MoveNum + 1: t = TIMER
97.  END IF
98.  ShowGrid
99.  IF Turn = P THEN
100.   IF place = -1 THEN
101.    s$ = "Holding area, press spacebar until over column to play."
102.   ELSE
103.    s$ = "Press Spacebar, if don't want to play" + STR$(place) + " column."
104.   END IF
105.   COLOR &HFFFFFFFF, 0
106.   _PRINTSTRING (XO, YO - SQ - 16), s$
107.  END IF
108.  pumpkin 0, place * SQ + XO + SQ / 2, SQ + SQ / 2, pr, 3
109.  sx = RND * 6 - 3
110.  _PUTIMAGE , Overlay&, _DISPLAY
111.  _DISPLAY
112.  _LIMIT 15
113. WEND
114.  
115. SUB AIMove
116.  ' What this sub does in English:
117.  ' This sub assigns the value to playing each column, then plays the best value with following caveats:
118.  ' + If it finds a winning move, it will play that immediately.
119.  ' + If it finds a spoiler move, it will play that if no winning move was found.
120.  ' + It will poisen the column's scoring, if opponent can play a winning move if AI plays this column,
121.  '   but it might be the only legal move left.  We will have to play it if no better score was found.
122.  
123.  DIM c, r, d, cntA, cntP, bestScore, startR, startC, iStep, test, goodF, i
124.  DIM openRow(NCM1) ' find open rows once
125.  REDIM Scores(NCM1) ' evaluate each column's potential
126.  AIX = -1: AIY = -1 ' set these when AI makes move, they are signal to display procedure AI's move.
127.  FOR c = 0 TO NCM1
128.   openRow(c) = GetOpenRow(c)
129.   r = openRow(c)
130.   IF r <> NumRows THEN
131.    FOR d = 0 TO 3 ' 4 directions to build connect 4's that use cell c, r
132.     startC = c + -3 * DX(d): startR = r + -3 * DY(d)
133.     FOR i = 0 TO 3 ' here we backup from the potential connect 4 in opposite build direction of c, r
134.      cntA = 0: cntP = 0: goodF = -1 ' reset counts and flag for good connect 4
135.      'from this start position run 4 steps forward to count all connects involving cell c, r
136.      FOR iStep = 0 TO 3 ' process a potential connect 4
137.       test = GR(startC + i * DX(d) + iStep * DX(d), startR + i * DY(d) + iStep * DY(d))
138.       IF test = NumRows THEN goodF = 0: EXIT FOR 'cant get connect4 from here
139.       IF test = AI THEN cntA = cntA + 1
140.       IF test = P THEN cntP = cntP + 1
141.      NEXT iStep
142.      IF goodF THEN 'evaluate the Legal Connect4 we could build with c, r
143.       IF cntA = 3 THEN ' we are done!  winner!
144.        AIX = c: AIY = r ' <<< this is the needed 4th cell to win tell ShowGrid last cell
145.        Grid(c, r) = AI '  <<< this is the needed 4th cell to win, add to grid this is AI move
146.        Scores(c) = 1000
147.        EXIT SUB
148.       ELSEIF cntP = 3 THEN 'next best move spoiler!
149.        AIX = c: AIY = r 'set the move but don't exit there might be a winner
150.        Scores(c) = 900
151.       ELSEIF cntA = 0 AND cntP = 2 THEN
152.        Scores(c) = Scores(c) + 8
153.       ELSEIF cntA = 2 AND cntP = 0 THEN ' very good offense or defense
154.        Scores(c) = Scores(c) + 4 'play this to connect 3 or prevent player from Connect 3
155.       ELSEIF cntA = 0 AND cntP = 1 THEN
156.        Scores(c) = Scores(c) + 4
157.       ELSEIF (cntA = 1 AND cntP = 0) THEN 'good offense or defense
158.        Scores(c) = Scores(c) + 2 ' play this to connect 2 or prevent player from Connect 2
159.       ELSEIF (cntA = 0 AND cntP = 0) THEN ' OK it's not a wasted move as it has potential for connect4
160.        Scores(c) = Scores(c) + 1 ' this is good move because this can still be a Connect 4
161.       END IF
162.      END IF ' in the board
163.     NEXT i
164.    NEXT d
165.    IF Stupid(c, r) THEN Scores(c) = -1000 + Scores(c) ' poison because if played the human can win
166.   END IF
167.  NEXT
168.  IF AIX <> -1 THEN ' we found a spoiler so move there since we haven't found a winner
169.   Grid(AIX, AIY) = AI ' make move on grid and done!
170.   EXIT SUB
171.  ELSE
172.   IF GetOpenRow(PlayerLastMoveCol) < NumRows THEN 'all things being equal play on top of player's last move
173.    bestScore = Scores(PlayerLastMoveCol): AIY = PlayerLastMoveRow - 1: AIX = PlayerLastMoveCol
174.   ELSE
175.    bestScore = -1000 ' a negative score indicates that the player can beat AI with their next move
176.   END IF
177.   FOR c = 0 TO NCM1
178.    r = openRow(c)
179.    IF r <> NumRows THEN
180.     IF Scores(c) > bestScore THEN bestScore = Scores(c): AIY = r: AIX = c
181.    END IF
182.   NEXT
183.   IF AIX <> -1 THEN
184.    Grid(AIX, AIY) = AI ' make first best score move we found
185.   ELSE 'We have trouble!  Oh but it could be there are no moves!!!
186.    ' checkWin is run after every move by AI or Player if there were no legal moves left it should have caught that.
187.    ' Just in case it didn't here is an error stop!
188.    BEEP: LOCATE 4, 2: PRINT "AI has failed to find a proper move, press any to end..."
189.    SLEEP ' <<< pause until user presses a key
190.    END
191.   END IF
192.  END IF
193. END SUB
194.  
195. FUNCTION GetOpenRow (forCol)
196.  DIM i
197.  GetOpenRow = NumRows 'assume none open
198.  IF forCol < 0 OR forCol > NCM1 THEN EXIT FUNCTION
199.  FOR i = NRM1 TO 0 STEP -1
200.   IF Grid(forCol, i) = 0 THEN GetOpenRow = i: EXIT FUNCTION
201.  NEXT
202. END FUNCTION
203.  
204. FUNCTION Stupid (c, r)
205.  DIM pr
206.  Grid(c, r) = AI
207.  pr = GetOpenRow(c)
208.  IF pr <> NumRows THEN
209.   Grid(c, pr) = P
210.   IF CheckWin = 4 THEN Stupid = -1
211.   Grid(c, pr) = 0
212.  END IF
213.  Grid(c, r) = 0
214. END FUNCTION
215.  
216. FUNCTION GR (c, r) ' if c, r are out of bounds returns N else returns grid(c, r)
217.  ' need to check the grid(c, r) but only if c, r is on the board
218.  IF c < 0 OR c > NCM1 OR r < 0 OR r > NRM1 THEN GR = NumRows ELSE GR = Grid(c, r)
219. END FUNCTION
220.  
221. SUB ShowGrid
222.  STATIC lastMoveNum
223.  DIM i, r, c, check, s$, k$
224.  IF MoveNum <> lastMoveNum THEN ' file newest move
225.   IF MoveNum = 1 THEN REDIM Record$(NCM1, NRM1)
226.   IF Turn = -1 THEN
227.    Record$(PlayerLastMoveCol, PlayerLastMoveRow) = _TRIM$(STR$(MoveNum)) + " " + "P"
228.   ELSE
229.    Record$(AIX, AIY) = _TRIM$(STR$(MoveNum)) + " " + "A"
230.   END IF
231.   lastMoveNum = MoveNum
232.  END IF
233.  'cls
234.  LINE (XO, YO)-STEP(NumCols * SQ, NumRows * SQ), &HFF004400, BF
235.  FOR i = 0 TO NumCols 'grid
236.   LINE (SQ * i + XO, YO)-STEP(0, NumRows * SQ), &HFFFFFFFF
237.  NEXT
238.  FOR i = 0 TO NumRows
239.   LINE (XO, SQ * i + YO)-STEP(NumCols * SQ, 0), &HFFFFFFFF
240.  NEXT
241.  FOR r = NRM1 TO 0 STEP -1 ''in grid rows are reversed 0 is top row
242.   FOR c = 0 TO NCM1
243.    IF Grid(c, r) = P THEN
244.     LINE (c * SQ + XO + 3, r * SQ + YO + 3)-STEP(SQ - 6, SQ - 6), &HFF000000, BF
245.     pumpkin 0, c * SQ + XO + SQ / 2, r * SQ + YO + SQ / 2, (SQ - 6) / 2, 2
246.  
247.    ELSEIF Grid(c, r) = AI THEN
248.     IF c = AIX AND r = AIY THEN 'highlite last AI move
249.      LINE (c * SQ + XO + 3, r * SQ + YO + 3)-STEP(SQ - 6, SQ - 6), &HFF8888FF, BF
250.     ELSE
251.      LINE (c * SQ + XO + 3, r * SQ + YO + 3)-STEP(SQ - 6, SQ - 6), &HFF4444FF, BF
252.     END IF
253.     drawSpinner c * SQ + XO + SQ / 2, r * SQ + YO + SQ / 2, .5, _PI(-c / 8), _RGB32(RND * 30 + 40, RND * 15 + 20, RND * 6 + 10)
254.    END IF
255.    s$ = _TRIM$(STR$(Scores(c)))
256.    _PRINTSTRING (XO + c * SQ + (60 - LEN(s$) * 8) / 2, YO + SQ * NumRows + 22), s$
257.   NEXT
258.  NEXT
259.  '_Display
260.  check = CheckWin
261.  IF check THEN 'report end of round ad see if want to play again
262.   IF check = 4 OR check = -4 THEN
263.    FOR i = 0 TO 3
264.     LINE ((WinX + i * DX(WinD)) * SQ + XO + 5, (WinY + i * DY(WinD)) * SQ + YO + 5)-STEP(SQ - 10, SQ - 10), &HFFFFFF00, B
265.    NEXT
266.   END IF
267.   FOR r = 0 TO NRM1
268.    FOR c = 0 TO NCM1
269.     IF Record$(c, r) <> "" THEN
270.      s$ = MID$(Record$(c, r), 1, INSTR(Record$(c, r), " ") - 1)
271.      IF RIGHT$(Record$(c, r), 1) = "A" THEN COLOR &HFFFFFFFF, &HFF000000 ELSE COLOR &HFFFFFFFF, &HFF000000
272.      _PRINTSTRING (SQ * c + XO + (SQ - LEN(s$) * 8) / 2, SQ * r + YO + 22), s$
273.     END IF
274.    NEXT
275.    COLOR , &HFF000000
276.   NEXT
277.   IF check = -4 THEN
278.    s$ = " AI is Winner!"
279.   ELSEIF check = 4 THEN
280.    s$ = " Human is Winner!"
281.   ELSEIF check = NumRows THEN
282.    s$ = " Board is full, no winner." ' keep Turn the same
283.   END IF
284.   LOCATE 2, ((SW - LEN(s$) * 8) / 2) / 8: PRINT s$
285.   s$ = " Play again? press spacebar, escape to quit... "
286.   LOCATE 4, ((SW - LEN(s$) * 8) / 2) / 8: PRINT s$
287.   _PUTIMAGE , Overlay&, _DISPLAY
288.   _DISPLAY
289.   keywait:
290.   WHILE LEN(k$) = 0
291.    k$ = INKEY$
292.    _LIMIT 200
293.   WEND
294.   IF k$ = " " THEN
295.    REDIM Grid(NCM1, NRM1), Scores(NCM1)
296.    IF GoFirst = P THEN GoFirst = AI ELSE GoFirst = P
297.    Turn = GoFirst: MoveNum = 0
298.   ELSEIF ASC(k$) = 27 THEN
299.    SYSTEM
300.   ELSE
301.    k$ = "": GOTO keywait:
302.   END IF
303.  END IF
304. END SUB
305.  
306. FUNCTION CheckWin ' return WinX, WinY, WinD along with +/- 4, returns NumRows if grid full, 0 if no win and grid not full
307.  DIM gridFull, r, c, s, i
308.  gridFull = NumRows
309.  FOR r = NRM1 TO 0 STEP -1 'bottom to top
310.   FOR c = 0 TO NCM1
311.    IF Grid(c, r) THEN ' check if c starts a row
312.     IF c < NCM1 - 2 THEN
313.      s = 0
314.      FOR i = 0 TO 3 ' east
315.       s = s + Grid(c + i, r)
316.      NEXT
317.      IF s = 4 OR s = -4 THEN WinX = c: WinY = r: WinD = 0: CheckWin = s: EXIT FUNCTION
318.     END IF
319.     IF r > 2 THEN ' check if c starts a col
320.      s = 0
321.      FOR i = 0 TO 3 ' north
322.       s = s + Grid(c, r - i)
323.      NEXT
324.      IF s = 4 OR s = -4 THEN WinX = c: WinY = r: WinD = 6: CheckWin = s: EXIT FUNCTION
325.     END IF
326.     IF r > 2 AND c < NCM1 - 2 THEN 'check if c starts diagonal up to right
327.      s = 0
328.      FOR i = 0 TO 3 ' north  east
329.       s = s + Grid(c + i, r - i)
330.      NEXT
331.      IF s = 4 OR s = -4 THEN WinX = c: WinY = r: WinD = 7: CheckWin = s: EXIT FUNCTION
332.     END IF
333.     IF r > 2 AND c > 2 THEN 'check if c starts a diagonal up to left
334.      s = 0
335.      FOR i = 0 TO 3 ' north west
336.       s = s + Grid(c - i, r - i)
337.      NEXT
338.      IF s = 4 OR s = -4 THEN WinX = c: WinY = r: WinD = 5: CheckWin = s: EXIT FUNCTION
339.     END IF
340.    ELSE
341.     gridFull = 0 ' at least one enpty cell left
342.    END IF 'grid is something
343.   NEXT
344.  NEXT
345.  CheckWin = gridFull
346. END FUNCTION
347.  
348.  
349. SUB pumpkin (dh&, cx, cy, pr, limit)
350.  DIM lastr, u, dx, i, tx1, tx2, tx3, ty1, ty2, ty3, ty22, sxs
351.  'carve this!
352.  COLOR &HFFFF0000
353.  fEllipse cx, cy, pr, 29 / 35 * pr
354.  COLOR &HFF000000
355.  lastr = 2 / 7 * pr
356.  DO
357.   ellipse cx, cy, lastr, 29 / 35 * pr
358.   lastr = .5 * (pr - lastr) + lastr + 1 / 35 * pr
359.   IF pr - lastr < 1 / 80 * pr THEN EXIT DO
360.  LOOP
361.  
362.  ' 'flickering candle light
363.  'Color _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
364.  
365.  ' eye sockets
366.  ftri2 dh&, cx - 9 * pr / 12, cy - 2 * pr / 12, cx - 7 * pr / 12, cy - 6 * pr / 12, cx - 3 * pr / 12, cy - 0 * pr / 12, _RGB(RND * 55 + 200, RND * 55 + 200, 120)
367.  ftri2 dh&, cx - 7 * pr / 12, cy - 6 * pr / 12, cx - 3 * pr / 12, cy - 0 * pr / 12, cx - 2 * pr / 12, cy - 3 * pr / 12, _RGB(RND * 55 + 200, RND * 55 + 200, 120)
368.  ftri2 dh&, cx + 9 * pr / 12, cy - 2 * pr / 12, cx + 7 * pr / 12, cy - 6 * pr / 12, cx + 3 * pr / 12, cy - 0 * pr / 12, _RGB(RND * 55 + 200, RND * 55 + 200, 120)
369.  ftri2 dh&, cx + 7 * pr / 12, cy - 6 * pr / 12, cx + 3 * pr / 12, cy - 0 * pr / 12, cx + 2 * pr / 12, cy - 3 * pr / 12, _RGB(RND * 55 + 200, RND * 55 + 200, 120)
370.  
371.  ' nose
372.  ftri2 dh&, cx, cy - rand%(2, 5) * pr / 12, cx - 2 * pr / 12, cy + 2 * pr / 12, cx + rand%(1, 2) * pr / 12, cy + 2 * pr / 12, _RGB(RND * 55 + 200, RND * 55 + 200, 120)
373.  
374.  ' evil grin
375.  ftri2 dh&, cx - 9 * pr / 12, cy + 1 * pr / 12, cx - 7 * pr / 12, cy + 7 * pr / 12, cx - 6 * pr / 12, cy + 5 * pr / 12, _RGB(RND * 55 + 200, RND * 55 + 200, 120)
376.  ftri2 dh&, cx + 9 * pr / 12, cy + 1 * pr / 12, cx + 7 * pr / 12, cy + 7 * pr / 12, cx + 6 * pr / 12, cy + 5 * pr / 12, _RGB(RND * 55 + 200, RND * 55 + 200, 120)
377.  
378.  ' moving teeth/talk/grrrr..
379.  u = rand%(4, 8)
380.  dx = pr / u
381.  FOR i = 1 TO u
382.   tx1 = cx - 6 * pr / 12 + (i - 1) * dx
383.   tx2 = tx1 + .5 * dx
384.   tx3 = tx1 + dx
385.   ty1 = cy + 5 * pr / 12
386.   ty3 = cy + 5 * pr / 12
387.   ty2 = cy + (4 - RND) * pr / 12
388.   ty22 = cy + (6 + RND) * pr / 12
389.   ftri2 dh&, tx1, ty1, tx2, ty2, tx3, ty3, _RGB(RND * 55 + 200, RND * 55 + 200, 120)
390.   ftri2 dh&, tx1 + .5 * dx, ty1, tx2 + .5 * dx, ty22, tx3 + .5 * dx, ty3, _RGB(RND * 55 + 200, RND * 55 + 200, 120)
391.  NEXT
392.  IF limit THEN
393.   'shifty eyes
394.   IF limit = 3 THEN sxs = sx ELSE sxs = .1 * limit * sx
395.   pumpkin dh&, sxs + cx - 5 * pr / 12, cy - 2.5 * pr / 12, .15 * pr, INT(limit - 1)
396.   pumpkin dh&, sxs + cx + 5 * pr / 12, cy - 2.5 * pr / 12, .15 * pr, INT(limit - 1)
397.  END IF
398. END SUB
399.  
400. SUB fEllipse (CX AS LONG, CY AS LONG, xRadius AS LONG, yRadius AS LONG)
401.  DIM scale AS SINGLE, x AS LONG, y AS LONG
402.  scale = yRadius / xRadius
403.  LINE (CX, CY - yRadius)-(CX, CY + yRadius), , BF
404.  FOR x = 1 TO xRadius
405.   y = scale * SQR(xRadius * xRadius - x * x)
406.   LINE (CX + x, CY - y)-(CX + x, CY + y), , BF
407.   LINE (CX - x, CY - y)-(CX - x, CY + y), , BF
408.  NEXT
409. END SUB
410.  
411. SUB ellipse (CX AS LONG, CY AS LONG, xRadius AS LONG, yRadius AS LONG)
412.  DIM scale AS SINGLE, xs AS LONG, x AS LONG, y AS LONG
413.  DIM lastx AS LONG, lasty AS LONG
414.  scale = yRadius / xRadius: xs = xRadius * xRadius
415.  PSET (CX, CY - yRadius): PSET (CX, CY + yRadius)
416.  lastx = 0: lasty = yRadius
417.  FOR x = 1 TO xRadius
418.   y = scale * SQR(xs - x * x)
419.   LINE (CX + lastx, CY - lasty)-(CX + x, CY - y)
420.   LINE (CX + lastx, CY + lasty)-(CX + x, CY + y)
421.   LINE (CX - lastx, CY - lasty)-(CX - x, CY - y)
422.   LINE (CX - lastx, CY + lasty)-(CX - x, CY + y)
423.   lastx = x: lasty = y
424.  NEXT
425. END SUB
426.  
427. SUB ftri2 (returnDest&, x1, y1, x2, y2, x3, y3, K AS _UNSIGNED LONG)
428.  DIM a&
429.  a& = _NEWIMAGE(1, 1, 32)
430.  _DEST a&
431.  PSET (0, 0), K
432.  _DEST returnDest&
433.  _MAPTRIANGLE _SEAMLESS(0, 0)-(0, 0)-(0, 0), a& TO(x1, y1)-(x2, y2)-(x3, y3)
434.  _FREEIMAGE a& '<<< this is important!
435. END SUB
436.  
437. FUNCTION rand% (lo%, hi%)
438.  rand% = INT(RND * (hi% - lo% + 1)) + lo%
439. END FUNCTION
440.  
441.  
442.  
443. SUB drawLink (x1, y1, r1, x2, y2, r2, c AS _UNSIGNED LONG)
444.  DIM a, a1, a2, x3, x4, x5, x6, y3, y4, y5, y6
445.  a = _ATAN2(y2 - y1, x2 - x1)
446.  a1 = a + _PI(1 / 2)
447.  a2 = a - _PI(1 / 2)
448.  x3 = x1 + r1 * COS(a1): y3 = y1 + r1 * SIN(a1)
449.  x4 = x1 + r1 * COS(a2): y4 = y1 + r1 * SIN(a2)
450.  x5 = x2 + r2 * COS(a1): y5 = y2 + r2 * SIN(a1)
451.  x6 = x2 + r2 * COS(a2): y6 = y2 + r2 * SIN(a2)
452.  fquad x3, y3, x4, y4, x5, y5, x6, y6, c
453.  Fcirc x1, y1, r1, c
454.  Fcirc x2, y2, r2, c
455. END SUB
456.  
457. 'need 4 non linear points (not all on 1 line) list them clockwise so x2, y2 is opposite of x4, y4
458. 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)
459.  ftri x1, y1, x2, y2, x4, y4, c
460.  ftri x3, y3, x4, y4, x1, y1, c
461. END SUB
462.  
463. SUB ftri (x1, y1, x2, y2, x3, y3, K AS _UNSIGNED LONG)
464.  DIM a&
465.  a& = _NEWIMAGE(1, 1, 32)
466.  _DEST a&
467.  PSET (0, 0), K
468.  _DEST 0
469.  _MAPTRIANGLE _SEAMLESS(0, 0)-(0, 0)-(0, 0), a& TO(x1, y1)-(x2, y2)-(x3, y3)
470.  _FREEIMAGE a& '<<< this is important!
471. END SUB
472.  
473. SUB TiltedEllipseFill (destHandle&, x0, y0, a, b, ang, c AS _UNSIGNED LONG)
474.  DIM max AS INTEGER, mx2 AS INTEGER, i AS INTEGER, j AS INTEGER, k AS SINGLE, lasti AS SINGLE, lastj AS SINGLE
475.  DIM prc AS _UNSIGNED LONG, tef AS LONG
476.  prc = _RGB32(255, 255, 255, 255)
477.  IF a > b THEN max = a + 1 ELSE max = b + 1
478.  mx2 = max + max
479.  tef = _NEWIMAGE(mx2, mx2)
480.  _DEST tef
481.  _SOURCE tef 'point wont read without this!
482.  FOR k = 0 TO 6.2832 + .05 STEP .1
483.   i = max + a * COS(k) * COS(ang) + b * SIN(k) * SIN(ang)
484.   j = max + a * COS(k) * SIN(ang) - b * SIN(k) * COS(ang)
485.   IF k <> 0 THEN
486.    LINE (lasti, lastj)-(i, j), prc
487.   ELSE
488.    PSET (i, j), prc
489.   END IF
490.   lasti = i: lastj = j
491.  NEXT
492.  DIM xleft(mx2) AS INTEGER, xright(mx2) AS INTEGER, x AS INTEGER, y AS INTEGER
493.  FOR y = 0 TO mx2
494.   x = 0
495.   WHILE POINT(x, y) <> prc AND x < mx2
496.    x = x + 1
497.   WEND
498.   xleft(y) = x
499.   WHILE POINT(x, y) = prc AND x < mx2
500.    x = x + 1
501.   WEND
502.   WHILE POINT(x, y) <> prc AND x < mx2
503.    x = x + 1
504.   WEND
505.   IF x = mx2 THEN xright(y) = xleft(y) ELSE xright(y) = x
506.  NEXT
507.  _DEST destHandle&
508.  FOR y = 0 TO mx2
509.   IF xleft(y) <> mx2 THEN LINE (xleft(y) + x0 - max, y + y0 - max)-(xright(y) + x0 - max, y + y0 - max), c, BF
510.  NEXT
511.  _FREEIMAGE tef
512. END SUB
513.  
514. SUB Fcirc (CX AS LONG, CY AS LONG, R AS LONG, C AS _UNSIGNED LONG)
515.  DIM Radius AS LONG, RadiusError AS LONG
516.  DIM X AS LONG, Y AS LONG
517.  Radius = ABS(R): RadiusError = -Radius: X = Radius: Y = 0
518.  IF Radius = 0 THEN PSET (CX, CY), C: EXIT SUB
519.  LINE (CX - X, CY)-(CX + X, CY), C, BF
520.  WHILE X > Y
521.   RadiusError = RadiusError + Y * 2 + 1
522.   IF RadiusError >= 0 THEN
523.    IF X <> Y + 1 THEN
524.     LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
525.     LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
526.    END IF
527.    X = X - 1
528.    RadiusError = RadiusError - X * 2
529.   END IF
530.   Y = Y + 1
531.   LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
532.   LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
533.  WEND
534. END SUB
535.  
536. SUB drawSpinner (x AS INTEGER, y AS INTEGER, scale AS SINGLE, heading AS SINGLE, c AS _UNSIGNED LONG)
537.  DIM x1, x2, x3, x4, y1, y2, y3, y4, r, a, a1, a2, lg, d, rd
538.  DIM rred, bblue, ggreen
539.  STATIC switch AS INTEGER
540.  switch = switch + 2
541.  switch = switch MOD 16 + 1
542.  rred = _RED32(c): ggreen = _GREEN32(c): bblue = _BLUE32(c)
543.  r = 10 * scale
544.  x1 = x + r * COS(heading): y1 = y + r * SIN(heading)
545.  r = 2 * r 'lg lengths
546.  FOR lg = 1 TO 8
547.   IF lg < 5 THEN
548.    a = heading + .9 * lg * _PI(1 / 5) + (lg = switch) * _PI(1 / 10)
549.   ELSE
550.    a = heading - .9 * (lg - 4) * _PI(1 / 5) - (lg = switch) * _PI(1 / 10)
551.   END IF
552.   x2 = x1 + r * COS(a): y2 = y1 + r * SIN(a)
553.   drawLink x1, y1, 3 * scale, x2, y2, 2 * scale, _RGB32(rred + 20, ggreen + 10, bblue + 5)
554.   IF lg = 1 OR lg = 2 OR lg = 7 OR lg = 8 THEN d = -1 ELSE d = 1
555.   a1 = a + d * _PI(1 / 12)
556.   x3 = x2 + r * 1.5 * COS(a1): y3 = y2 + r * 1.5 * SIN(a1)
557.   drawLink x2, y2, 2 * scale, x3, y3, scale, _RGB32(rred + 35, ggreen + 17, bblue + 8)
558.   rd = INT(RND * 8) + 1
559.   a2 = a1 + d * _PI(1 / 8) * rd / 8
560.   x4 = x3 + r * 1.5 * COS(a2): y4 = y3 + r * 1.5 * SIN(a2)
561.   drawLink x3, y3, scale, x4, y4, scale, _RGB32(rred + 50, ggreen + 25, bblue + 12)
562.  NEXT
563.  r = r * .5
564.  Fcirc x1, y1, r, _RGB32(rred - 20, ggreen - 10, bblue - 5)
565.  x2 = x1 + (r + 1) * COS(heading - _PI(1 / 12)): y2 = y1 + (r + 1) * SIN(heading - _PI(1 / 12))
566.  Fcirc x2, y2, r * .2, &HFF000000
567.  x2 = x1 + (r + 1) * COS(heading + _PI(1 / 12)): y2 = y1 + (r + 1) * SIN(heading + _PI(1 / 12))
568.  Fcirc x2, y2, r * .2, &HFF000000
569.  r = r * 2
570.  x1 = x + r * .9 * COS(heading + _PI): y1 = y + r * .9 * SIN(heading + _PI)
571.  TiltedEllipseFill 0, x1, y1, r, .7 * r, heading + _PI, _RGB32(rred, ggreen, bblue)
572. END SUB
573.  
574. SUB Create_Board
575.  _DEST Overlay&
576.  LINE (60, 120)-STEP(480, 480), _RGB32(180, 180, 16), BF
577.  FOR y% = 0 TO 7
578.   FOR x% = 0 TO 7
579.    Fcirc 90 + 60 * x%, 150 + 60 * y%, 25, _RGB32(0)
580.  NEXT x%, y%
581.  _CLEARCOLOR _RGB32(0), Overlay&
582.  _DEST _DISPLAY
583. END SUB
584.  

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: Pete on October 22, 2021, 11:41:26 am

@Cobalt Big fan of overlays! Color scheme of yellow on green? Um, not a big fan. Version also needs the pumpkin fall acceleration. It definitely reminded me of the old game apparatus, which was indeed, yellow. Overall, a really nice addition with the Connect 4 board look.

@bplus You might want to consider a space bar toggle for AI or two-player version. Wow, I was just thinking that it's been 20 years since I did networking routines for home networks. I mean it certainly could be used by two people on one computer, but over home network would be cool.

Pete

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: bplus on October 22, 2021, 12:59:07 pm

OK with overlay, but I changed color scheme so that background shows through empty holes, tiny adjustments in sizes of things and colors so the winning 4 is displayed.

Code: QB64: [Select]

1. Option _Explicit ' One Key Connect 4 (8x8) Halloween Style - bplus 2021-10-19
2. Const SQ = 60 '       square or grid cell
3. Const NumCols = 8 '   number of columns
4. Const NumRows = 8 '   you guessed it
5. Const NCM1 = NumCols - 1 ' NumCols minus 1
6. Const NRM1 = NumRows - 1 ' you can guess surely
7. Const SW = SQ * (NumCols + 2) '  screen width
8. Const SH = SQ * (NumRows + 3) '  screen height
9. Const P = 1 '       Player is 1 on grid
10. Const AI = -1 '     AI is -1 on grid
11. Const XO = SQ '     x offset for grid
12. Const YO = 2 * SQ ' y offset for grid
13.  
14. ReDim Shared Grid(NCM1, NRM1) ' 0 = empty  P=1 for Player,  AI=-1  for AI so -4 is win for AI..
15. ReDim Shared DX(7), DY(7) ' Directions
16. DX(0) = 1: DY(0) = 0 ': DString$(0) = "East"
17. DX(1) = 1: DY(1) = 1 ': DString$(1) = "South East"
18. DX(2) = 0: DY(2) = 1 ': DString$(2) = "South"
19. DX(3) = -1: DY(3) = 1 ': DString$(3) = "South West"
20. DX(4) = -1: DY(4) = 0 ': DString$(4) = "West"
21. DX(5) = -1: DY(5) = -1 ': DString$(5) = "North West"
22. DX(6) = 0: DY(6) = -1 ': DString$(6) = "North"
23. DX(7) = 1: DY(7) = -1 ' : DString$(7) = "North East"
24. ReDim Shared Scores(NCM1) ' rating column for AI and displaying them
25. ReDim Shared AIX, AIY ' last move of AI for highlighting in display
26. ReDim Shared WinX, WinY, WinD ' display Winning Connect 4
27. ReDim Shared GameOn, Turn, GoFirst, PlayerLastMoveCol, PlayerLastMoveRow, MoveNum ' game tracking
28. ReDim Shared Record$(NCM1, NRM1)
29. Dim Shared sx, pr ' for pumpkin recursion shifty eyes and pumkin radius
30. Dim place, k$, t, r, s$, d, temp&, target, y, delaid
31. Dim Shared Overlay& 'the board overlay
32.  
33. Screen _NewImage(SW, SH, 32)
34. _ScreenMove 360, 60
35. Overlay& = _NewImage(SW, SH, 32)
36. Create_Board
37.  
38. _Title "One Key Connect 4 (8x8) Halloween Style"
39. d = 1
40. While _KeyDown(32) = 0
41.     Cls
42.     pumpkin 0, _Width / 2, _Height / 2, _Height / 2.3, 3
43.     sx = sx + d
44.     If sx > 10 Then d = -d: sx = 10
45.     If sx < -10 Then d = -d: sx = -10
46.     Color &HFFFFFFFF
47.     Locate 40, 33: Print "Spacebar Only"
48.     _Display
49.     _Limit 20
50. Wend
51. _KeyClear
52. GameOn = -1: GoFirst = AI: Turn = AI: MoveNum = 0
53. ShowGrid
54. place = -1
55. t = Timer
56. pr = (SQ - 2) / 2
57. While GameOn
58.     Cls
59.     If Turn = P Then
60.         k$ = InKey$
61.         If k$ = Chr$(27) Then System ' emergency exit
62.         If k$ = " " Then
63.             t = Timer: place = place + 1
64.             If place >= NumCols Then place = -1
65.         Else ' watch out for midnight!
66.             If Timer - t < 0 Then 'midnight problem
67.                 t = Timer ' wait a little longer
68.             Else
69.                 If Timer - t > 2 And place <> -1 Then ' col selected
70.                     r = GetOpenRow(place)
71.                     If r <> NumRows Then
72.                         y = SQ + SQ / 2
73.                         target = r * SQ + YO + SQ / 2
74.                         delaid = 6
75.                         While y < target
76.                             y = y + 1
77.                             Cls
78.                             ShowGrid
79.                             pumpkin 0, place * SQ + XO + SQ / 2, y, pr, 2
80.                             sx = Rnd * 6 - 3
81.                             _PutImage , Overlay&, _Display
82.                             _Display
83.                             _Limit delaid
84.                             delaid = delaid * 2
85.                         Wend
86.                         Grid(place, r) = P: Turn = AI: PlayerLastMoveCol = place: PlayerLastMoveRow = r: MoveNum = MoveNum + 1
87.                         place = -1 ' reset back to hold area
88.                     Else
89.                         Beep
90.                     End If
91.                 End If
92.             End If
93.         End If
94.     Else
95.         AIMove
96.         Turn = P: MoveNum = MoveNum + 1: t = Timer
97.     End If
98.     ShowGrid
99.     If Turn = P Then
100.         If place = -1 Then
101.             s$ = "Holding area, press spacebar until over column to play."
102.         Else
103.             s$ = "Press Spacebar, if don't want to play" + Str$(place) + " column."
104.         End If
105.         Color &HFFFFFFFF
106.         _PrintString (XO, YO - SQ - 16), s$
107.     End If
108.     pumpkin 0, place * SQ + XO + SQ / 2, SQ + SQ / 2, pr, 2
109.     sx = Rnd * 6 - 3
110.     _PutImage , Overlay&, _Display
111.     _Display
112.     _Limit 15
113. Wend
114.  
115. Sub AIMove
116.     ' What this sub does in English:
117.     ' This sub assigns the value to playing each column, then plays the best value with following caveats:
118.     ' + If it finds a winning move, it will play that immediately.
119.     ' + If it finds a spoiler move, it will play that if no winning move was found.
120.     ' + It will poisen the column's scoring, if opponent can play a winning move if AI plays this column,
121.     '   but it might be the only legal move left.  We will have to play it if no better score was found.
122.  
123.     Dim c, r, d, cntA, cntP, bestScore, startR, startC, iStep, test, goodF, i
124.     Dim openRow(NCM1) ' find open rows once
125.     ReDim Scores(NCM1) ' evaluate each column's potential
126.     AIX = -1: AIY = -1 ' set these when AI makes move, they are signal to display procedure AI's move.
127.     For c = 0 To NCM1
128.         openRow(c) = GetOpenRow(c)
129.         r = openRow(c)
130.         If r <> NumRows Then
131.             For d = 0 To 3 ' 4 directions to build connect 4's that use cell c, r
132.                 startC = c + -3 * DX(d): startR = r + -3 * DY(d)
133.                 For i = 0 To 3 ' here we backup from the potential connect 4 in opposite build direction of c, r
134.                     cntA = 0: cntP = 0: goodF = -1 ' reset counts and flag for good connect 4
135.                     'from this start position run 4 steps forward to count all connects involving cell c, r
136.                     For iStep = 0 To 3 ' process a potential connect 4
137.                         test = GR(startC + i * DX(d) + iStep * DX(d), startR + i * DY(d) + iStep * DY(d))
138.                         If test = NumRows Then goodF = 0: Exit For 'cant get connect4 from here
139.                         If test = AI Then cntA = cntA + 1
140.                         If test = P Then cntP = cntP + 1
141.                     Next iStep
142.                     If goodF Then 'evaluate the Legal Connect4 we could build with c, r
143.                         If cntA = 3 Then ' we are done!  winner!
144.                             AIX = c: AIY = r ' <<< this is the needed 4th cell to win tell ShowGrid last cell
145.                             Grid(c, r) = AI '  <<< this is the needed 4th cell to win, add to grid this is AI move
146.                             Scores(c) = 1000
147.                             Exit Sub
148.                         ElseIf cntP = 3 Then 'next best move spoiler!
149.                             AIX = c: AIY = r 'set the move but don't exit there might be a winner
150.                             Scores(c) = 900
151.                         ElseIf cntA = 0 And cntP = 2 Then
152.                             Scores(c) = Scores(c) + 8
153.                         ElseIf cntA = 2 And cntP = 0 Then ' very good offense or defense
154.                             Scores(c) = Scores(c) + 4 'play this to connect 3 or prevent player from Connect 3
155.                         ElseIf cntA = 0 And cntP = 1 Then
156.                             Scores(c) = Scores(c) + 4
157.                         ElseIf (cntA = 1 And cntP = 0) Then 'good offense or defense
158.                             Scores(c) = Scores(c) + 2 ' play this to connect 2 or prevent player from Connect 2
159.                         ElseIf (cntA = 0 And cntP = 0) Then ' OK it's not a wasted move as it has potential for connect4
160.                             Scores(c) = Scores(c) + 1 ' this is good move because this can still be a Connect 4
161.                         End If
162.                     End If ' in the board
163.                 Next i
164.             Next d
165.             If Stupid(c, r) Then Scores(c) = -1000 + Scores(c) ' poison because if played the human can win
166.         End If
167.     Next
168.     If AIX <> -1 Then ' we found a spoiler so move there since we haven't found a winner
169.         Grid(AIX, AIY) = AI ' make move on grid and done!
170.         Exit Sub
171.     Else
172.         If GetOpenRow(PlayerLastMoveCol) < NumRows Then 'all things being equal play on top of player's last move
173.             bestScore = Scores(PlayerLastMoveCol): AIY = PlayerLastMoveRow - 1: AIX = PlayerLastMoveCol
174.         Else
175.             bestScore = -1000 ' a negative score indicates that the player can beat AI with their next move
176.         End If
177.         For c = 0 To NCM1
178.             r = openRow(c)
179.             If r <> NumRows Then
180.                 If Scores(c) > bestScore Then bestScore = Scores(c): AIY = r: AIX = c
181.             End If
182.         Next
183.         If AIX <> -1 Then
184.             Grid(AIX, AIY) = AI ' make first best score move we found
185.         Else 'We have trouble!  Oh but it could be there are no moves!!!
186.             ' checkWin is run after every move by AI or Player if there were no legal moves left it should have caught that.
187.             ' Just in case it didn't here is an error stop!
188.             Color &HFFFFFFFF
189.             Beep: Locate 4, 2: Print "AI has failed to find a proper move, press any to end..."
190.             Sleep ' <<< pause until user presses a key
191.             End
192.         End If
193.     End If
194. End Sub
195.  
196. Function GetOpenRow (forCol)
197.     Dim i
198.     GetOpenRow = NumRows 'assume none open
199.     If forCol < 0 Or forCol > NCM1 Then Exit Function
200.     For i = NRM1 To 0 Step -1
201.         If Grid(forCol, i) = 0 Then GetOpenRow = i: Exit Function
202.     Next
203. End Function
204.  
205. Function Stupid (c, r)
206.     Dim ppr
207.     Grid(c, r) = AI
208.     ppr = GetOpenRow(c)
209.     If ppr <> NumRows Then
210.         Grid(c, ppr) = P
211.         If CheckWin = 4 Then Stupid = -1
212.         Grid(c, ppr) = 0
213.     End If
214.     Grid(c, r) = 0
215. End Function
216.  
217. Function GR (c, r) ' if c, r are out of bounds returns N else returns grid(c, r)
218.     ' need to check the grid(c, r) but only if c, r is on the board
219.     If c < 0 Or c > NCM1 Or r < 0 Or r > NRM1 Then GR = NumRows Else GR = Grid(c, r)
220. End Function
221.  
222. Sub ShowGrid
223.     Static lastMoveNum
224.     Dim i, r, c, check, s$, k$
225.     If MoveNum <> lastMoveNum Then ' file newest move
226.         If MoveNum = 1 Then ReDim Record$(NCM1, NRM1)
227.         If Turn = -1 Then
228.             Record$(PlayerLastMoveCol, PlayerLastMoveRow) = _Trim$(Str$(MoveNum)) + " " + "P"
229.         Else
230.             Record$(AIX, AIY) = _Trim$(Str$(MoveNum)) + " " + "A"
231.         End If
232.         lastMoveNum = MoveNum
233.     End If
234.     Color _RGB32(255, 255, 255), _RGB32(64, 64, 255): Cls
235.     'Line (XO, YO)-Step(NumCols * SQ, NumRows * SQ), &HFF004400, BF
236.     For i = 0 To NumCols 'grid
237.         Line (SQ * i + XO, YO)-Step(0, NumRows * SQ), &HFFFFFFFF
238.     Next
239.     For i = 0 To NumRows
240.         Line (XO, SQ * i + YO)-Step(NumCols * SQ, 0), &HFFFFFFFF
241.     Next
242.     Color
243.     For r = NRM1 To 0 Step -1 ''in grid rows are reversed 0 is top row
244.         For c = 0 To NCM1
245.             If Grid(c, r) = P Then
246.                 'Line (c * SQ + XO + 3, r * SQ + YO + 3)-Step(SQ - 6, SQ - 6), &HFF000000, BF
247.                 pumpkin 0, c * SQ + XO + SQ / 2, r * SQ + YO + SQ / 2, pr, 2
248.  
249.             ElseIf Grid(c, r) = AI Then
250.                 If c = AIX And r = AIY Then 'highlite last AI move
251.                     'Line (c * SQ + XO + 3, r * SQ + YO + 3)-Step(SQ - 6, SQ - 6), &HFF8888FF, BF  ' no overlay
252.                     Line (c * SQ + XO, r * SQ + YO)-Step(SQ, SQ), &HFF8888FF, BF
253.                     'Else
254.                     'Line (c * SQ + XO + 3, r * SQ + YO + 3)-Step(SQ - 6, SQ - 6), &HFF4444FF, BF  ' no overlay
255.                     'Line (c * SQ + XO, r * SQ + YO)-Step(SQ, SQ), &HFF4444FF, BF
256.                 End If
257.                 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)
258.             End If
259.             s$ = _Trim$(Str$(Scores(c)))
260.             Color &HFFFFFFFF
261.             _PrintString (XO + c * SQ + (60 - Len(s$) * 8) / 2, YO + SQ * NumRows + 22), s$
262.         Next
263.     Next
264.     '_Display
265.     check = CheckWin
266.     If check Then 'report end of round ad see if want to play again
267.         If check = 4 Or check = -4 Then
268.             For i = 0 To 3
269.                 Line ((WinX + i * DX(WinD)) * SQ + XO + 10, (WinY + i * DY(WinD)) * SQ + YO + 10)-Step(SQ - 20, SQ - 20), &HFFFFFF00, B
270.             Next
271.         End If
272.         Color &HFFFFFFFF
273.         For r = 0 To NRM1
274.             For c = 0 To NCM1
275.                 If Record$(c, r) <> "" Then
276.                     s$ = Mid$(Record$(c, r), 1, InStr(Record$(c, r), " ") - 1)
277.                     _PrintString (SQ * c + XO + (SQ - Len(s$) * 8) / 2, SQ * r + YO + 22), s$
278.                 End If
279.             Next
280.         Next
281.         If check = -4 Then
282.             s$ = " AI is Winner!"
283.         ElseIf check = 4 Then
284.             s$ = " Human is Winner!"
285.         ElseIf check = NumRows Then
286.             s$ = " Board is full, no winner." ' keep Turn the same
287.         End If
288.         Locate 2, ((SW - Len(s$) * 8) / 2) / 8: Print s$
289.         s$ = " Play again? press spacebar, escape to quit... "
290.         Locate 4, ((SW - Len(s$) * 8) / 2) / 8: Print s$
291.         _PutImage , Overlay&, _Display
292.         _Display
293.         keywait:
294.         While Len(k$) = 0
295.             k$ = InKey$
296.             _Limit 200
297.         Wend
298.         If k$ = " " Then
299.             ReDim Grid(NCM1, NRM1), Scores(NCM1)
300.             If GoFirst = P Then GoFirst = AI Else GoFirst = P
301.             Turn = GoFirst: MoveNum = 0
302.         ElseIf Asc(k$) = 27 Then
303.             System
304.         Else
305.             k$ = "": GoTo keywait:
306.         End If
307.     End If
308. End Sub
309.  
310. Function CheckWin ' return WinX, WinY, WinD along with +/- 4, returns NumRows if grid full, 0 if no win and grid not full
311.     Dim gridFull, r, c, s, i
312.     gridFull = NumRows
313.     For r = NRM1 To 0 Step -1 'bottom to top
314.         For c = 0 To NCM1
315.             If Grid(c, r) Then ' check if c starts a row
316.                 If c < NCM1 - 2 Then
317.                     s = 0
318.                     For i = 0 To 3 ' east
319.                         s = s + Grid(c + i, r)
320.                     Next
321.                     If s = 4 Or s = -4 Then WinX = c: WinY = r: WinD = 0: CheckWin = s: Exit Function
322.                 End If
323.                 If r > 2 Then ' check if c starts a col
324.                     s = 0
325.                     For i = 0 To 3 ' north
326.                         s = s + Grid(c, r - i)
327.                     Next
328.                     If s = 4 Or s = -4 Then WinX = c: WinY = r: WinD = 6: CheckWin = s: Exit Function
329.                 End If
330.                 If r > 2 And c < NCM1 - 2 Then 'check if c starts diagonal up to right
331.                     s = 0
332.                     For i = 0 To 3 ' north  east
333.                         s = s + Grid(c + i, r - i)
334.                     Next
335.                     If s = 4 Or s = -4 Then WinX = c: WinY = r: WinD = 7: CheckWin = s: Exit Function
336.                 End If
337.                 If r > 2 And c > 2 Then 'check if c starts a diagonal up to left
338.                     s = 0
339.                     For i = 0 To 3 ' north west
340.                         s = s + Grid(c - i, r - i)
341.                     Next
342.                     If s = 4 Or s = -4 Then WinX = c: WinY = r: WinD = 5: CheckWin = s: Exit Function
343.                 End If
344.             Else
345.                 gridFull = 0 ' at least one enpty cell left
346.             End If 'grid is something
347.         Next
348.     Next
349.     CheckWin = gridFull
350. End Function
351.  
352.  
353. Sub pumpkin (dh&, cx, cy, pr, limit)
354.     Dim lastr, u, dx, i, tx1, tx2, tx3, ty1, ty2, ty3, ty22, sxs
355.     'carve this!
356.     Color &HFFFF0000
357.     fEllipse cx, cy, pr, 29 / 35 * pr
358.     Color &HFF000000
359.     lastr = 2 / 7 * pr
360.     Do
361.         ellipse cx, cy, lastr, 29 / 35 * pr
362.         lastr = .5 * (pr - lastr) + lastr + 1 / 35 * pr
363.         If pr - lastr < 1 / 80 * pr Then Exit Do
364.     Loop
365.  
366.     ' 'flickering candle light
367.     'Color _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
368.  
369.     ' eye sockets
370.     ftri2 dh&, cx - 9 * pr / 12, cy - 2 * pr / 12, cx - 7 * pr / 12, cy - 6 * pr / 12, cx - 3 * pr / 12, cy - 0 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
371.     ftri2 dh&, cx - 7 * pr / 12, cy - 6 * pr / 12, cx - 3 * pr / 12, cy - 0 * pr / 12, cx - 2 * pr / 12, cy - 3 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
372.     ftri2 dh&, cx + 9 * pr / 12, cy - 2 * pr / 12, cx + 7 * pr / 12, cy - 6 * pr / 12, cx + 3 * pr / 12, cy - 0 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
373.     ftri2 dh&, cx + 7 * pr / 12, cy - 6 * pr / 12, cx + 3 * pr / 12, cy - 0 * pr / 12, cx + 2 * pr / 12, cy - 3 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
374.  
375.     ' nose
376.     ftri2 dh&, cx, cy - rand%(2, 5) * pr / 12, cx - 2 * pr / 12, cy + 2 * pr / 12, cx + rand%(1, 2) * pr / 12, cy + 2 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
377.  
378.     ' evil grin
379.     ftri2 dh&, cx - 9 * pr / 12, cy + 1 * pr / 12, cx - 7 * pr / 12, cy + 7 * pr / 12, cx - 6 * pr / 12, cy + 5 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
380.     ftri2 dh&, cx + 9 * pr / 12, cy + 1 * pr / 12, cx + 7 * pr / 12, cy + 7 * pr / 12, cx + 6 * pr / 12, cy + 5 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
381.  
382.     ' moving teeth/talk/grrrr..
383.     u = rand%(4, 8)
384.     dx = pr / u
385.     For i = 1 To u
386.         tx1 = cx - 6 * pr / 12 + (i - 1) * dx
387.         tx2 = tx1 + .5 * dx
388.         tx3 = tx1 + dx
389.         ty1 = cy + 5 * pr / 12
390.         ty3 = cy + 5 * pr / 12
391.         ty2 = cy + (4 - Rnd) * pr / 12
392.         ty22 = cy + (6 + Rnd) * pr / 12
393.         ftri2 dh&, tx1, ty1, tx2, ty2, tx3, ty3, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
394.         ftri2 dh&, tx1 + .5 * dx, ty1, tx2 + .5 * dx, ty22, tx3 + .5 * dx, ty3, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
395.     Next
396.     If limit Then
397.         'shifty eyes
398.         If limit = 3 Then sxs = sx Else sxs = .1 * limit * sx
399.         pumpkin dh&, sxs + cx - 5 * pr / 12, cy - 2.5 * pr / 12, .15 * pr, Int(limit - 1)
400.         pumpkin dh&, sxs + cx + 5 * pr / 12, cy - 2.5 * pr / 12, .15 * pr, Int(limit - 1)
401.     End If
402. End Sub
403.  
404. Sub fEllipse (CX As Long, CY As Long, xRadius As Long, yRadius As Long)
405.     Dim scale As Single, x As Long, y As Long
406.     scale = yRadius / xRadius
407.     Line (CX, CY - yRadius)-(CX, CY + yRadius), , BF
408.     For x = 1 To xRadius
409.         y = scale * Sqr(xRadius * xRadius - x * x)
410.         Line (CX + x, CY - y)-(CX + x, CY + y), , BF
411.         Line (CX - x, CY - y)-(CX - x, CY + y), , BF
412.     Next
413. End Sub
414.  
415. Sub ellipse (CX As Long, CY As Long, xRadius As Long, yRadius As Long)
416.     Dim scale As Single, xs As Long, x As Long, y As Long
417.     Dim lastx As Long, lasty As Long
418.     scale = yRadius / xRadius: xs = xRadius * xRadius
419.     PSet (CX, CY - yRadius): PSet (CX, CY + yRadius)
420.     lastx = 0: lasty = yRadius
421.     For x = 1 To xRadius
422.         y = scale * Sqr(xs - x * x)
423.         Line (CX + lastx, CY - lasty)-(CX + x, CY - y)
424.         Line (CX + lastx, CY + lasty)-(CX + x, CY + y)
425.         Line (CX - lastx, CY - lasty)-(CX - x, CY - y)
426.         Line (CX - lastx, CY + lasty)-(CX - x, CY + y)
427.         lastx = x: lasty = y
428.     Next
429. End Sub
430.  
431. Sub ftri2 (returnDest&, x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
432.     Dim a&
433.     a& = _NewImage(1, 1, 32)
434.     _Dest a&
435.     PSet (0, 0), K
436.     _Dest returnDest&
437.     _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
438.     _FreeImage a& '<<< this is important!
439. End Sub
440.  
441. Function rand% (lo%, hi%)
442.     rand% = Int(Rnd * (hi% - lo% + 1)) + lo%
443. End Function
444.  
445.  
446.  
447. Sub drawLink (x1, y1, r1, x2, y2, r2, c As _Unsigned Long)
448.     Dim a, a1, a2, x3, x4, x5, x6, y3, y4, y5, y6
449.     a = _Atan2(y2 - y1, x2 - x1)
450.     a1 = a + _Pi(1 / 2)
451.     a2 = a - _Pi(1 / 2)
452.     x3 = x1 + r1 * Cos(a1): y3 = y1 + r1 * Sin(a1)
453.     x4 = x1 + r1 * Cos(a2): y4 = y1 + r1 * Sin(a2)
454.     x5 = x2 + r2 * Cos(a1): y5 = y2 + r2 * Sin(a1)
455.     x6 = x2 + r2 * Cos(a2): y6 = y2 + r2 * Sin(a2)
456.     fquad x3, y3, x4, y4, x5, y5, x6, y6, c
457.     Fcirc x1, y1, r1, c
458.     Fcirc x2, y2, r2, c
459. End Sub
460.  
461. 'need 4 non linear points (not all on 1 line) list them clockwise so x2, y2 is opposite of x4, y4
462. 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)
463.     ftri x1, y1, x2, y2, x4, y4, c
464.     ftri x3, y3, x4, y4, x1, y1, c
465. End Sub
466.  
467. Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
468.     Dim a&
469.     a& = _NewImage(1, 1, 32)
470.     _Dest a&
471.     PSet (0, 0), K
472.     _Dest 0
473.     _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
474.     _FreeImage a& '<<< this is important!
475. End Sub
476.  
477. Sub TiltedEllipseFill (destHandle&, x0, y0, a, b, ang, c As _Unsigned Long)
478.     Dim max As Integer, mx2 As Integer, i As Integer, j As Integer, k As Single, lasti As Single, lastj As Single
479.     Dim prc As _Unsigned Long, tef As Long
480.     prc = _RGB32(255, 255, 255, 255)
481.     If a > b Then max = a + 1 Else max = b + 1
482.     mx2 = max + max
483.     tef = _NewImage(mx2, mx2)
484.     _Dest tef
485.     _Source tef 'point wont read without this!
486.     For k = 0 To 6.2832 + .05 Step .1
487.         i = max + a * Cos(k) * Cos(ang) + b * Sin(k) * Sin(ang)
488.         j = max + a * Cos(k) * Sin(ang) - b * Sin(k) * Cos(ang)
489.         If k <> 0 Then
490.             Line (lasti, lastj)-(i, j), prc
491.         Else
492.             PSet (i, j), prc
493.         End If
494.         lasti = i: lastj = j
495.     Next
496.     Dim xleft(mx2) As Integer, xright(mx2) As Integer, x As Integer, y As Integer
497.     For y = 0 To mx2
498.         x = 0
499.         While Point(x, y) <> prc And x < mx2
500.             x = x + 1
501.         Wend
502.         xleft(y) = x
503.         While Point(x, y) = prc And x < mx2
504.             x = x + 1
505.         Wend
506.         While Point(x, y) <> prc And x < mx2
507.             x = x + 1
508.         Wend
509.         If x = mx2 Then xright(y) = xleft(y) Else xright(y) = x
510.     Next
511.     _Dest destHandle&
512.     For y = 0 To mx2
513.         If xleft(y) <> mx2 Then Line (xleft(y) + x0 - max, y + y0 - max)-(xright(y) + x0 - max, y + y0 - max), c, BF
514.     Next
515.     _FreeImage tef
516. End Sub
517.  
518. Sub Fcirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
519.     Dim Radius As Long, RadiusError As Long
520.     Dim X As Long, Y As Long
521.     Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
522.     If Radius = 0 Then PSet (CX, CY), C: Exit Sub
523.     Line (CX - X, CY)-(CX + X, CY), C, BF
524.     While X > Y
525.         RadiusError = RadiusError + Y * 2 + 1
526.         If RadiusError >= 0 Then
527.             If X <> Y + 1 Then
528.                 Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
529.                 Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
530.             End If
531.             X = X - 1
532.             RadiusError = RadiusError - X * 2
533.         End If
534.         Y = Y + 1
535.         Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
536.         Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
537.     Wend
538. End Sub
539.  
540. Sub drawSpinner (x As Integer, y As Integer, scale As Single, heading As Single, c As _Unsigned Long)
541.     Dim x1, x2, x3, x4, y1, y2, y3, y4, r, a, a1, a2, lg, d, rd
542.     Dim rred, bblue, ggreen
543.     Static switch As Integer
544.     switch = switch + 2
545.     switch = switch Mod 16 + 1
546.     rred = _Red32(c): ggreen = _Green32(c): bblue = _Blue32(c)
547.     r = 10 * scale
548.     x1 = x + r * Cos(heading): y1 = y + r * Sin(heading)
549.     r = 2 * r 'lg lengths
550.     For lg = 1 To 8
551.         If lg < 5 Then
552.             a = heading + .9 * lg * _Pi(1 / 5) + (lg = switch) * _Pi(1 / 10)
553.         Else
554.             a = heading - .9 * (lg - 4) * _Pi(1 / 5) - (lg = switch) * _Pi(1 / 10)
555.         End If
556.         x2 = x1 + r * Cos(a): y2 = y1 + r * Sin(a)
557.         drawLink x1, y1, 3 * scale, x2, y2, 2 * scale, _RGB32(rred + 20, ggreen + 10, bblue + 5)
558.         If lg = 1 Or lg = 2 Or lg = 7 Or lg = 8 Then d = -1 Else d = 1
559.         a1 = a + d * _Pi(1 / 12)
560.         x3 = x2 + r * 1.5 * Cos(a1): y3 = y2 + r * 1.5 * Sin(a1)
561.         drawLink x2, y2, 2 * scale, x3, y3, scale, _RGB32(rred + 35, ggreen + 17, bblue + 8)
562.         rd = Int(Rnd * 8) + 1
563.         a2 = a1 + d * _Pi(1 / 8) * rd / 8
564.         x4 = x3 + r * 1.5 * Cos(a2): y4 = y3 + r * 1.5 * Sin(a2)
565.         drawLink x3, y3, scale, x4, y4, scale, _RGB32(rred + 50, ggreen + 25, bblue + 12)
566.     Next
567.     r = r * .5
568.     Fcirc x1, y1, r, _RGB32(rred - 20, ggreen - 10, bblue - 5)
569.     x2 = x1 + (r + 1) * Cos(heading - _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading - _Pi(1 / 12))
570.     Fcirc x2, y2, r * .2, &HFF000000
571.     x2 = x1 + (r + 1) * Cos(heading + _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading + _Pi(1 / 12))
572.     Fcirc x2, y2, r * .2, &HFF000000
573.     r = r * 2
574.     x1 = x + r * .9 * Cos(heading + _Pi): y1 = y + r * .9 * Sin(heading + _Pi)
575.     TiltedEllipseFill 0, x1, y1, r, .7 * r, heading + _Pi, _RGB32(rred, ggreen, bblue)
576. End Sub
577.  
578. Sub Create_Board
579.     Dim As Integer x, y
580.     _Dest Overlay&
581.     Line (60, 120)-Step(480, 480), _RGB32(80, 40, 20), BF
582.     For y = 0 To 7
583.         For x = 0 To 7
584.             Fcirc 90 + 60 * x, 150 + 60 * y, 28, _RGB32(0)
585.     Next x, y
586.     _ClearColor _RGB32(0), Overlay&
587.     _Dest _Display
588. End Sub
589.  
590.  
591.  

Zip contains Windows exe for Syntax Bomb friends and Source code for compiling in other OS.
Making this #2 for Overlay mod, thanks!

 

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: bplus on October 22, 2021, 01:11:00 pm

Quote

@bplus You might want to consider a space bar toggle for AI or two-player version. Wow, I was just thinking that it's been 20 years since I did networking routines for home networks. I mean it certainly could be used by two people on one computer, but over home network would be cool.

Over Internet might be cool, at home, I just have AI to play.

PS I have real Wheel of Fortune Game I made last year but did not work too well with family members, no AI for that one!

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: bplus on October 22, 2021, 01:16:26 pm

Oh I just had interesting idea, since the board is now see through, you should be able to see your opponent!

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: Dav on October 22, 2021, 01:17:36 pm

Good halloween game!  Plays strong too.  Still trying to beat it...

- Dav

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: bplus on October 22, 2021, 02:25:00 pm

Rats that overlay screwed up the timing for the drop, sorry Pete I just noticed.

PS well it was slowing down the more pieces you put on the board anyway.

Back to the drawing board. ;(

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: Pete on October 22, 2021, 02:54:46 pm

Ironic. Hardware acceleration creates pumpkin deceleration. Maybe Steve can help. Oh wait, he only raises pumpkins, he doesn't drop them.

Pete

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: bplus on October 22, 2021, 03:12:28 pm

Naw, no wonder here. I was re-drawing all the pieces live, to keep them moving. That's pretty intense processing time. Should be able to fix with static pieces with solid backgrounds as pieces would appear in real game, if I want to fool around with this.

I do have an image of the opponent the human sees (and sees through overlay) that I'd love to use with this!

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: Pete on October 22, 2021, 03:31:55 pm

Yeah, but what ya doesn't haz is my permyission ta use it!

 - Sam :D

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: Cobalt on October 22, 2021, 08:06:48 pm

Quote from: bplus on October 22, 2021, 03:12:28 pm

Naw, no wonder here. I was re-drawing all the pieces live, to keep them moving. That's pretty intense processing time. Should be able to fix with static pieces with solid backgrounds as pieces would appear in real game, if I want to fool around with this.

I do have an image of the opponent the human sees (and sees through overlay) that I'd love to use with this!

Yeah, time to add layering

putimage opponent
putimage tiles
putimage overlay
show the tile and text on top of the screen
display to screen

the problem with that though is the animation on the tiles, what you could do though is pre-render the animations on still more layers and just use putimage to place them to the tile layer. I think the Fill routines are a bit slower than just putimage? Then you could use a timer to cycle the frames.

I just wish your variable naming convention was a bit more descriptive. ¯\_(ツ)_/¯

Although this is one reason I don't use _DISPLAY in that manner. if the program window hits the edge of the screen this happens.

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: Pete on October 22, 2021, 08:18:31 pm

It looks like your CPU may be running a bit too hot @ melting effect. Wow, I never imagined a situation like that could happen, but then I don't get out of SCREEN 0, much.

Pete

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: Dav on October 22, 2021, 08:31:08 pm

Getting a sticky spider image on the screen once in a while.  My pumpkin falls right through it when it happens.

Still haven't won yet.  :(

- Dav

  [ This attachment cannot be displayed inline in 'Print Page' view ]  

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: Pete on October 22, 2021, 08:42:49 pm

You're probably playing it while on the web!

Mark put together a really good AI algorithm. I played about 8 times and only one once.

Pete

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: bplus on October 22, 2021, 09:27:23 pm

I was hoping to get something like this going. It's nice to be able to see your opponent.
  [ This attachment cannot be displayed inline in 'Print Page' view ]  

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: Pete on October 22, 2021, 09:37:31 pm

Doesn't Steve have a more recent photo? Anyway, I'd prefer Marvin.

Pete

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: bplus on October 22, 2021, 09:56:46 pm

@Cobalt Did you insert resizable in code?

I tried dragging and banging title bar around and don't have a melting problem on my system. Other apps do stick and expand to fill side of screen but not my QB64.

@Dav I've never seen the spider stick like that in my games.

@Pete where we are playing Connect 4 there is hardly any gravity, so maybe it's OK if pieces float down.

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: Dav on October 22, 2021, 10:12:30 pm

@bplus:  when it happened, it was when a new game has started, and the leftover spider was from the previous game but didnt erase off the screen.  Only happened a couple times.

EDIT: Finally won one!  Now my wife can stop laughing at me.  I agree @Pete, the AI algo is really great (or I just really bad).  Good job @bplus.

- Dav

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: bplus on October 22, 2021, 11:05:46 pm

@Dav you had it figured out some time ago, my guess your memory getting like mine. This is old Connect 4 posted almost year ago but now we see our opponent!

 

Just can't see it's pieces as well ;-))

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: Pete on October 23, 2021, 01:17:00 am

Ah, you did find a more recent picture of Steve. Thanks!

Pete

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: Cobalt on October 23, 2021, 12:33:40 pm

Quote from: bplus on October 22, 2021, 09:56:46 pm

@Cobalt Did you insert resizable in code?

@bplus nope just the code straight from the zip, course the one where I added the  overlay.

not just the sides of the screen, but anything showing up on top of the game window too.

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: bplus on October 23, 2021, 12:45:31 pm

Hi Cobalt, is that Windows or Linux? If Windows what version? Those icons look different (top right corner).

I image that would mess up with any QB64 window.

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: bplus on October 23, 2021, 12:54:39 pm

Here is version #3, here you can play any opponent you want by using a 600 X 680 pixel (or same ratio width X height for least distortion when stretching over screen)  .png file and naming it "Opponent.png". I have 3 sample scary faces in zip, just add digit to current Opponent and remove digit from 1 of the others to try it.

Code: QB64: [Select]

1. Option _Explicit ' One Key Connect 4 (8x8) Halloween Style - bplus 2021-10-19
2. Const SQ = 60 '       square or grid cell
3. Const NumCols = 8 '   number of columns
4. Const NumRows = 8 '   you guessed it
5. Const NCM1 = NumCols - 1 ' NumCols minus 1
6. Const NRM1 = NumRows - 1 ' you can guess surely
7. Const SW = SQ * (NumCols + 2) '  screen width
8. Const SH = SQ * (NumRows + 3) '  screen height
9. Const P = 1 '       Player is 1 on grid
10. Const AI = -1 '     AI is -1 on grid
11. Const XO = SQ '     x offset for grid
12. Const YO = 3 * SQ ' y offset for grid
13.  
14. ReDim Shared Grid(NCM1, NRM1) ' 0 = empty  P=1 for Player,  AI=-1  for AI so -4 is win for AI..
15. ReDim Shared DX(7), DY(7) ' Directions
16. DX(0) = 1: DY(0) = 0 ': DString$(0) = "East"
17. DX(1) = 1: DY(1) = 1 ': DString$(1) = "South East"
18. DX(2) = 0: DY(2) = 1 ': DString$(2) = "South"
19. DX(3) = -1: DY(3) = 1 ': DString$(3) = "South West"
20. DX(4) = -1: DY(4) = 0 ': DString$(4) = "West"
21. DX(5) = -1: DY(5) = -1 ': DString$(5) = "North West"
22. DX(6) = 0: DY(6) = -1 ': DString$(6) = "North"
23. DX(7) = 1: DY(7) = -1 ' : DString$(7) = "North East"
24. ReDim Shared Scores(NCM1) ' rating column for AI and displaying them
25. ReDim Shared AIX, AIY ' last move of AI for highlighting in display
26. ReDim Shared WinX, WinY, WinD ' display Winning Connect 4
27. ReDim Shared GameOn, Turn, GoFirst, PlayerLastMoveCol, PlayerLastMoveRow, MoveNum ' game tracking
28. ReDim Shared Record$(NCM1, NRM1)
29. Dim Shared sx, pr ' for pumpkin recursion shifty eyes and pumkin radius
30. Dim place, k$, t, r, s$, d, temp&, target, y, delaid
31. Dim Shared Overlay& 'the board overlay
32. Dim Shared BF& 'opponent's face
33. Screen _NewImage(SW, SH, 32)
34. _Delay .25
35. _ScreenMove 360, 60
36. Overlay& = _NewImage(SW, SH, 32)
37. BF& = _LoadImage("Opponent.png")
38. Create_Board
39. _Title "One Key Connect 4 (8x8) Halloween Style #3"
40. d = 1
41. While _KeyDown(32) = 0
42.     Cls
43.     pumpkin 0, _Width / 2, _Height / 2, _Height / 2.3, 3
44.     sx = sx + d
45.     If sx > 10 Then d = -d: sx = 10
46.     If sx < -10 Then d = -d: sx = -10
47.     Color &HFFFFFFFF
48.     Locate 40, 33: Print "Spacebar Only"
49.     _Display
50.     _Limit 20
51. Wend
52. _KeyClear
53. GameOn = -1: GoFirst = AI: Turn = AI: MoveNum = 0
54. _PrintMode _KeepBackground
55. ShowGrid
56. place = -1
57. t = Timer
58. pr = (SQ - 2) / 2
59. While GameOn
60.     Cls
61.     If Turn = P Then
62.         k$ = InKey$
63.         If k$ = Chr$(27) Then System ' emergency exit
64.         If k$ = " " Then
65.             t = Timer: place = place + 1
66.             If place >= NumCols Then place = -1
67.         Else ' watch out for midnight!
68.             If Timer - t < 0 Then 'midnight problem
69.                 t = Timer ' wait a little longer
70.             Else
71.                 If Timer - t > 2 And place <> -1 Then ' col selected
72.                     r = GetOpenRow(place)
73.                     If r <> NumRows Then
74.                         y = 2 * SQ + SQ / 2
75.                         target = r * SQ + YO + SQ / 2
76.                         delaid = 6
77.                         While y < target
78.                             y = y + 1
79.                             Cls
80.                             ShowGrid
81.                             pumpkin 0, place * SQ + XO + SQ / 2, y, pr, 2
82.                             sx = Rnd * 6 - 3
83.                             _PutImage , Overlay&, _Display
84.                             _Display
85.                             _Limit delaid
86.                             delaid = delaid * 2
87.                         Wend
88.                         Grid(place, r) = P: Turn = AI: PlayerLastMoveCol = place: PlayerLastMoveRow = r: MoveNum = MoveNum + 1
89.                         place = -1 ' reset back to hold area
90.                     Else
91.                         Beep
92.                     End If
93.                 End If
94.             End If
95.         End If
96.     Else
97.         AIMove
98.         Turn = P: MoveNum = MoveNum + 1: t = Timer
99.     End If
100.     ShowGrid
101.     If Turn = P Then
102.         If place = -1 Then
103.             s$ = "Holding area, press spacebar until over column to play."
104.         Else
105.             s$ = "Press Spacebar, if don't want to play" + Str$(place) + " column."
106.         End If
107.         dp XO + 1, YO - SQ - 16 + 1, s$
108.     End If
109.     pumpkin 0, place * SQ + XO + SQ / 2, 2 * SQ + SQ / 2, pr, 2
110.     sx = Rnd * 6 - 3
111.     _PutImage , Overlay&, _Display
112.     _Display
113.     _Limit 15
114. Wend
115.  
116. Sub AIMove
117.     ' What this sub does in English:
118.     ' This sub assigns the value to playing each column, then plays the best value with following caveats:
119.     ' + If it finds a winning move, it will play that immediately.
120.     ' + If it finds a spoiler move, it will play that if no winning move was found.
121.     ' + It will poisen the column's scoring, if opponent can play a winning move if AI plays this column,
122.     '   but it might be the only legal move left.  We will have to play it if no better score was found.
123.  
124.     Dim c, r, d, cntA, cntP, bestScore, startR, startC, iStep, test, goodF, i
125.     Dim openRow(NCM1) ' find open rows once
126.     ReDim Scores(NCM1) ' evaluate each column's potential
127.     AIX = -1: AIY = -1 ' set these when AI makes move, they are signal to display procedure AI's move.
128.     For c = 0 To NCM1
129.         openRow(c) = GetOpenRow(c)
130.         r = openRow(c)
131.         If r <> NumRows Then
132.             For d = 0 To 3 ' 4 directions to build connect 4's that use cell c, r
133.                 startC = c + -3 * DX(d): startR = r + -3 * DY(d)
134.                 For i = 0 To 3 ' here we backup from the potential connect 4 in opposite build direction of c, r
135.                     cntA = 0: cntP = 0: goodF = -1 ' reset counts and flag for good connect 4
136.                     'from this start position run 4 steps forward to count all connects involving cell c, r
137.                     For iStep = 0 To 3 ' process a potential connect 4
138.                         test = GR(startC + i * DX(d) + iStep * DX(d), startR + i * DY(d) + iStep * DY(d))
139.                         If test = NumRows Then goodF = 0: Exit For 'cant get connect4 from here
140.                         If test = AI Then cntA = cntA + 1
141.                         If test = P Then cntP = cntP + 1
142.                     Next iStep
143.                     If goodF Then 'evaluate the Legal Connect4 we could build with c, r
144.                         If cntA = 3 Then ' we are done!  winner!
145.                             AIX = c: AIY = r ' <<< this is the needed 4th cell to win tell ShowGrid last cell
146.                             Grid(c, r) = AI '  <<< this is the needed 4th cell to win, add to grid this is AI move
147.                             Scores(c) = 1000
148.                             Exit Sub
149.                         ElseIf cntP = 3 Then 'next best move spoiler!
150.                             AIX = c: AIY = r 'set the move but don't exit there might be a winner
151.                             Scores(c) = 900
152.                         ElseIf cntA = 0 And cntP = 2 Then
153.                             Scores(c) = Scores(c) + 8
154.                         ElseIf cntA = 2 And cntP = 0 Then ' very good offense or defense
155.                             Scores(c) = Scores(c) + 4 'play this to connect 3 or prevent player from Connect 3
156.                         ElseIf cntA = 0 And cntP = 1 Then
157.                             Scores(c) = Scores(c) + 4
158.                         ElseIf (cntA = 1 And cntP = 0) Then 'good offense or defense
159.                             Scores(c) = Scores(c) + 2 ' play this to connect 2 or prevent player from Connect 2
160.                         ElseIf (cntA = 0 And cntP = 0) Then ' OK it's not a wasted move as it has potential for connect4
161.                             Scores(c) = Scores(c) + 1 ' this is good move because this can still be a Connect 4
162.                         End If
163.                     End If ' in the board
164.                 Next i
165.             Next d
166.             If Stupid(c, r) Then Scores(c) = -1000 + Scores(c) ' poison because if played the human can win
167.         End If
168.     Next
169.     If AIX <> -1 Then ' we found a spoiler so move there since we haven't found a winner
170.         Grid(AIX, AIY) = AI ' make move on grid and done!
171.         Exit Sub
172.     Else
173.         If GetOpenRow(PlayerLastMoveCol) < NumRows Then 'all things being equal play on top of player's last move
174.             bestScore = Scores(PlayerLastMoveCol): AIY = PlayerLastMoveRow - 1: AIX = PlayerLastMoveCol
175.         Else
176.             bestScore = -1000 ' a negative score indicates that the player can beat AI with their next move
177.         End If
178.         For c = 0 To NCM1
179.             r = openRow(c)
180.             If r <> NumRows Then
181.                 If Scores(c) > bestScore Then bestScore = Scores(c): AIY = r: AIX = c
182.             End If
183.         Next
184.         If AIX <> -1 Then
185.             Grid(AIX, AIY) = AI ' make first best score move we found
186.         Else 'We have trouble!  Oh but it could be there are no moves!!!
187.             ' checkWin is run after every move by AI or Player if there were no legal moves left it should have caught that.
188.             ' Just in case it didn't here is an error stop!
189.             Beep
190.             dp 2 * 8, 4 * 16, "AI has failed to find a proper move, press any to end..."
191.             Sleep ' <<< pause until user presses a key
192.             End
193.         End If
194.     End If
195. End Sub
196.  
197. Function GetOpenRow (forCol)
198.     Dim i
199.     GetOpenRow = NumRows 'assume none open
200.     If forCol < 0 Or forCol > NCM1 Then Exit Function
201.     For i = NRM1 To 0 Step -1
202.         If Grid(forCol, i) = 0 Then GetOpenRow = i: Exit Function
203.     Next
204. End Function
205.  
206. Function Stupid (c, r)
207.     Dim ppr
208.     Grid(c, r) = AI
209.     ppr = GetOpenRow(c)
210.     If ppr <> NumRows Then
211.         Grid(c, ppr) = P
212.         If CheckWin = 4 Then Stupid = -1
213.         Grid(c, ppr) = 0
214.     End If
215.     Grid(c, r) = 0
216. End Function
217.  
218. Function GR (c, r) ' if c, r are out of bounds returns N else returns grid(c, r)
219.     ' need to check the grid(c, r) but only if c, r is on the board
220.     If c < 0 Or c > NCM1 Or r < 0 Or r > NRM1 Then GR = NumRows Else GR = Grid(c, r)
221. End Function
222.  
223. Sub ShowGrid
224.     Static lastMoveNum
225.     Dim i, r, c, check, s$, k$
226.     If MoveNum <> lastMoveNum Then ' file newest move
227.         If MoveNum = 1 Then ReDim Record$(NCM1, NRM1)
228.         If Turn = -1 Then
229.             Record$(PlayerLastMoveCol, PlayerLastMoveRow) = _Trim$(Str$(MoveNum)) + " " + "P"
230.         Else
231.             Record$(AIX, AIY) = _Trim$(Str$(MoveNum)) + " " + "A"
232.         End If
233.         lastMoveNum = MoveNum
234.     End If
235.     Color _RGB32(255, 255, 255), _RGB32(0): Cls
236.     _PutImage , BF&, 0, (10, 10)-(_Width(BF&) - 20, _Height(BF&) - 50)
237.     'Line (XO, YO)-Step(NumCols * SQ, NumRows * SQ), &HFF004400, BF
238.     For i = 0 To NumCols 'grid
239.         Line (SQ * i + XO, YO)-Step(0, NumRows * SQ), &HFFFFFFFF
240.     Next
241.     For i = 0 To NumRows
242.         Line (XO, SQ * i + YO)-Step(NumCols * SQ, 0), &HFFFFFFFF
243.     Next
244.     Color
245.     For r = NRM1 To 0 Step -1 ''in grid rows are reversed 0 is top row
246.         For c = 0 To NCM1
247.             If Grid(c, r) = P Then
248.                 'Line (c * SQ + XO + 3, r * SQ + YO + 3)-Step(SQ - 6, SQ - 6), &HFF000000, BF
249.                 pumpkin 0, c * SQ + XO + SQ / 2, r * SQ + YO + SQ / 2, pr, 2
250.  
251.             ElseIf Grid(c, r) = AI Then
252.                 If c = AIX And r = AIY Then 'highlite last AI move
253.                     'Line (c * SQ + XO + 3, r * SQ + YO + 3)-Step(SQ - 6, SQ - 6), &HFF8888FF, BF  ' no overlay
254.                     Line (c * SQ + XO, r * SQ + YO)-Step(SQ, SQ), &HFF8888FF, BF
255.                 Else
256.                     'Line (c * SQ + XO + 3, r * SQ + YO + 3)-Step(SQ - 6, SQ - 6), &HFF4444FF, BF  ' no overlay
257.                     Line (c * SQ + XO, r * SQ + YO)-Step(SQ, SQ), &HFF4444FF, BF
258.                 End If
259.                 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)
260.             End If
261.             s$ = _Trim$(Str$(Scores(c)))
262.             dp XO + c * SQ + (60 - Len(s$) * 8) / 2, YO + SQ * NumRows + 22, s$
263.         Next
264.     Next
265.     '_Display
266.     check = CheckWin
267.     If check Then 'report end of round ad see if want to play again
268.         If check = 4 Or check = -4 Then
269.             For i = 0 To 3
270.                 Line ((WinX + i * DX(WinD)) * SQ + XO + 10, (WinY + i * DY(WinD)) * SQ + YO + 10)-Step(SQ - 20, SQ - 20), &HFFFFFF00, B
271.             Next
272.         End If
273.         For r = 0 To NRM1
274.             For c = 0 To NCM1
275.                 If Record$(c, r) <> "" Then
276.                     s$ = Mid$(Record$(c, r), 1, InStr(Record$(c, r), " ") - 1)
277.                     dp SQ * c + XO + (SQ - Len(s$) * 8) / 2, SQ * r + YO + 22, s$
278.                 End If
279.             Next
280.         Next
281.         If check = -4 Then
282.             s$ = " AI is Winner!"
283.         ElseIf check = 4 Then
284.             s$ = " Human is Winner!"
285.         ElseIf check = NumRows Then
286.             s$ = " Board is full, no winner." ' keep Turn the same
287.         End If
288.         dp (SW - Len(s$) * 8) / 2, 2 * 16, s$
289.         s$ = " Play again? press spacebar, escape to quit... "
290.         dp (SW - Len(s$) * 8) / 2, 4 * 16, s$
291.         _PutImage , Overlay&, _Display
292.         _Display
293.         keywait:
294.         While Len(k$) = 0
295.             k$ = InKey$
296.             _Limit 200
297.         Wend
298.         If k$ = " " Then
299.             ReDim Grid(NCM1, NRM1), Scores(NCM1)
300.             If GoFirst = P Then GoFirst = AI Else GoFirst = P
301.             Turn = GoFirst: MoveNum = 0
302.         ElseIf Asc(k$) = 27 Then
303.             System
304.         Else
305.             k$ = "": GoTo keywait:
306.         End If
307.     End If
308. End Sub
309.  
310. Function CheckWin ' return WinX, WinY, WinD along with +/- 4, returns NumRows if grid full, 0 if no win and grid not full
311.     Dim gridFull, r, c, s, i
312.     gridFull = NumRows
313.     For r = NRM1 To 0 Step -1 'bottom to top
314.         For c = 0 To NCM1
315.             If Grid(c, r) Then ' check if c starts a row
316.                 If c < NCM1 - 2 Then
317.                     s = 0
318.                     For i = 0 To 3 ' east
319.                         s = s + Grid(c + i, r)
320.                     Next
321.                     If s = 4 Or s = -4 Then WinX = c: WinY = r: WinD = 0: CheckWin = s: Exit Function
322.                 End If
323.                 If r > 2 Then ' check if c starts a col
324.                     s = 0
325.                     For i = 0 To 3 ' north
326.                         s = s + Grid(c, r - i)
327.                     Next
328.                     If s = 4 Or s = -4 Then WinX = c: WinY = r: WinD = 6: CheckWin = s: Exit Function
329.                 End If
330.                 If r > 2 And c < NCM1 - 2 Then 'check if c starts diagonal up to right
331.                     s = 0
332.                     For i = 0 To 3 ' north  east
333.                         s = s + Grid(c + i, r - i)
334.                     Next
335.                     If s = 4 Or s = -4 Then WinX = c: WinY = r: WinD = 7: CheckWin = s: Exit Function
336.                 End If
337.                 If r > 2 And c > 2 Then 'check if c starts a diagonal up to left
338.                     s = 0
339.                     For i = 0 To 3 ' north west
340.                         s = s + Grid(c - i, r - i)
341.                     Next
342.                     If s = 4 Or s = -4 Then WinX = c: WinY = r: WinD = 5: CheckWin = s: Exit Function
343.                 End If
344.             Else
345.                 gridFull = 0 ' at least one enpty cell left
346.             End If 'grid is something
347.         Next
348.     Next
349.     CheckWin = gridFull
350. End Function
351.  
352.  
353. Sub pumpkin (dh&, cx, cy, pr, limit)
354.     Dim lastr, u, dx, i, tx1, tx2, tx3, ty1, ty2, ty3, ty22, sxs
355.     'carve this!
356.     Color &HFFFF0000
357.     fEllipse cx, cy, pr, 29 / 35 * pr
358.     Color &HFF000000
359.     lastr = 2 / 7 * pr
360.     Do
361.         ellipse cx, cy, lastr, 29 / 35 * pr
362.         lastr = .5 * (pr - lastr) + lastr + 1 / 35 * pr
363.         If pr - lastr < 1 / 80 * pr Then Exit Do
364.     Loop
365.  
366.     ' 'flickering candle light
367.     'Color _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
368.  
369.     ' eye sockets
370.     ftri2 dh&, cx - 9 * pr / 12, cy - 2 * pr / 12, cx - 7 * pr / 12, cy - 6 * pr / 12, cx - 3 * pr / 12, cy - 0 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
371.     ftri2 dh&, cx - 7 * pr / 12, cy - 6 * pr / 12, cx - 3 * pr / 12, cy - 0 * pr / 12, cx - 2 * pr / 12, cy - 3 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
372.     ftri2 dh&, cx + 9 * pr / 12, cy - 2 * pr / 12, cx + 7 * pr / 12, cy - 6 * pr / 12, cx + 3 * pr / 12, cy - 0 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
373.     ftri2 dh&, cx + 7 * pr / 12, cy - 6 * pr / 12, cx + 3 * pr / 12, cy - 0 * pr / 12, cx + 2 * pr / 12, cy - 3 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
374.  
375.     ' nose
376.     ftri2 dh&, cx, cy - rand%(2, 5) * pr / 12, cx - 2 * pr / 12, cy + 2 * pr / 12, cx + rand%(1, 2) * pr / 12, cy + 2 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
377.  
378.     ' evil grin
379.     ftri2 dh&, cx - 9 * pr / 12, cy + 1 * pr / 12, cx - 7 * pr / 12, cy + 7 * pr / 12, cx - 6 * pr / 12, cy + 5 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
380.     ftri2 dh&, cx + 9 * pr / 12, cy + 1 * pr / 12, cx + 7 * pr / 12, cy + 7 * pr / 12, cx + 6 * pr / 12, cy + 5 * pr / 12, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
381.  
382.     ' moving teeth/talk/grrrr..
383.     u = rand%(4, 8)
384.     dx = pr / u
385.     For i = 1 To u
386.         tx1 = cx - 6 * pr / 12 + (i - 1) * dx
387.         tx2 = tx1 + .5 * dx
388.         tx3 = tx1 + dx
389.         ty1 = cy + 5 * pr / 12
390.         ty3 = cy + 5 * pr / 12
391.         ty2 = cy + (4 - Rnd) * pr / 12
392.         ty22 = cy + (6 + Rnd) * pr / 12
393.         ftri2 dh&, tx1, ty1, tx2, ty2, tx3, ty3, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
394.         ftri2 dh&, tx1 + .5 * dx, ty1, tx2 + .5 * dx, ty22, tx3 + .5 * dx, ty3, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
395.     Next
396.     If limit Then
397.         'shifty eyes
398.         If limit = 3 Then sxs = sx Else sxs = .1 * limit * sx
399.         pumpkin dh&, sxs + cx - 5 * pr / 12, cy - 2.5 * pr / 12, .15 * pr, Int(limit - 1)
400.         pumpkin dh&, sxs + cx + 5 * pr / 12, cy - 2.5 * pr / 12, .15 * pr, Int(limit - 1)
401.     End If
402. End Sub
403.  
404. Sub fEllipse (CX As Long, CY As Long, xRadius As Long, yRadius As Long)
405.     Dim scale As Single, x As Long, y As Long
406.     scale = yRadius / xRadius
407.     Line (CX, CY - yRadius)-(CX, CY + yRadius), , BF
408.     For x = 1 To xRadius
409.         y = scale * Sqr(xRadius * xRadius - x * x)
410.         Line (CX + x, CY - y)-(CX + x, CY + y), , BF
411.         Line (CX - x, CY - y)-(CX - x, CY + y), , BF
412.     Next
413. End Sub
414.  
415. Sub ellipse (CX As Long, CY As Long, xRadius As Long, yRadius As Long)
416.     Dim scale As Single, xs As Long, x As Long, y As Long
417.     Dim lastx As Long, lasty As Long
418.     scale = yRadius / xRadius: xs = xRadius * xRadius
419.     PSet (CX, CY - yRadius): PSet (CX, CY + yRadius)
420.     lastx = 0: lasty = yRadius
421.     For x = 1 To xRadius
422.         y = scale * Sqr(xs - x * x)
423.         Line (CX + lastx, CY - lasty)-(CX + x, CY - y)
424.         Line (CX + lastx, CY + lasty)-(CX + x, CY + y)
425.         Line (CX - lastx, CY - lasty)-(CX - x, CY - y)
426.         Line (CX - lastx, CY + lasty)-(CX - x, CY + y)
427.         lastx = x: lasty = y
428.     Next
429. End Sub
430.  
431. Sub ftri2 (returnDest&, x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
432.     Dim a&
433.     a& = _NewImage(1, 1, 32)
434.     _Dest a&
435.     PSet (0, 0), K
436.     _Dest returnDest&
437.     _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
438.     _FreeImage a& '<<< this is important!
439. End Sub
440.  
441. Function rand% (lo%, hi%)
442.     rand% = Int(Rnd * (hi% - lo% + 1)) + lo%
443. End Function
444.  
445.  
446.  
447. Sub drawLink (x1, y1, r1, x2, y2, r2, c As _Unsigned Long)
448.     Dim a, a1, a2, x3, x4, x5, x6, y3, y4, y5, y6
449.     a = _Atan2(y2 - y1, x2 - x1)
450.     a1 = a + _Pi(1 / 2)
451.     a2 = a - _Pi(1 / 2)
452.     x3 = x1 + r1 * Cos(a1): y3 = y1 + r1 * Sin(a1)
453.     x4 = x1 + r1 * Cos(a2): y4 = y1 + r1 * Sin(a2)
454.     x5 = x2 + r2 * Cos(a1): y5 = y2 + r2 * Sin(a1)
455.     x6 = x2 + r2 * Cos(a2): y6 = y2 + r2 * Sin(a2)
456.     fquad x3, y3, x4, y4, x5, y5, x6, y6, c
457.     Fcirc x1, y1, r1, c
458.     Fcirc x2, y2, r2, c
459. End Sub
460.  
461. 'need 4 non linear points (not all on 1 line) list them clockwise so x2, y2 is opposite of x4, y4
462. 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)
463.     ftri x1, y1, x2, y2, x4, y4, c
464.     ftri x3, y3, x4, y4, x1, y1, c
465. End Sub
466.  
467. Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
468.     Dim a&
469.     a& = _NewImage(1, 1, 32)
470.     _Dest a&
471.     PSet (0, 0), K
472.     _Dest 0
473.     _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
474.     _FreeImage a& '<<< this is important!
475. End Sub
476.  
477. Sub TiltedEllipseFill (destHandle&, x0, y0, a, b, ang, c As _Unsigned Long)
478.     Dim max As Integer, mx2 As Integer, i As Integer, j As Integer, k As Single, lasti As Single, lastj As Single
479.     Dim prc As _Unsigned Long, tef As Long
480.     prc = _RGB32(255, 255, 255, 255)
481.     If a > b Then max = a + 1 Else max = b + 1
482.     mx2 = max + max
483.     tef = _NewImage(mx2, mx2)
484.     _Dest tef
485.     _Source tef 'point wont read without this!
486.     For k = 0 To 6.2832 + .05 Step .1
487.         i = max + a * Cos(k) * Cos(ang) + b * Sin(k) * Sin(ang)
488.         j = max + a * Cos(k) * Sin(ang) - b * Sin(k) * Cos(ang)
489.         If k <> 0 Then
490.             Line (lasti, lastj)-(i, j), prc
491.         Else
492.             PSet (i, j), prc
493.         End If
494.         lasti = i: lastj = j
495.     Next
496.     Dim xleft(mx2) As Integer, xright(mx2) As Integer, x As Integer, y As Integer
497.     For y = 0 To mx2
498.         x = 0
499.         While Point(x, y) <> prc And x < mx2
500.             x = x + 1
501.         Wend
502.         xleft(y) = x
503.         While Point(x, y) = prc And x < mx2
504.             x = x + 1
505.         Wend
506.         While Point(x, y) <> prc And x < mx2
507.             x = x + 1
508.         Wend
509.         If x = mx2 Then xright(y) = xleft(y) Else xright(y) = x
510.     Next
511.     _Dest destHandle&
512.     For y = 0 To mx2
513.         If xleft(y) <> mx2 Then Line (xleft(y) + x0 - max, y + y0 - max)-(xright(y) + x0 - max, y + y0 - max), c, BF
514.     Next
515.     _FreeImage tef
516. End Sub
517.  
518. Sub Fcirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
519.     Dim Radius As Long, RadiusError As Long
520.     Dim X As Long, Y As Long
521.     Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
522.     If Radius = 0 Then PSet (CX, CY), C: Exit Sub
523.     Line (CX - X, CY)-(CX + X, CY), C, BF
524.     While X > Y
525.         RadiusError = RadiusError + Y * 2 + 1
526.         If RadiusError >= 0 Then
527.             If X <> Y + 1 Then
528.                 Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
529.                 Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
530.             End If
531.             X = X - 1
532.             RadiusError = RadiusError - X * 2
533.         End If
534.         Y = Y + 1
535.         Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
536.         Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
537.     Wend
538. End Sub
539.  
540. Sub drawSpinner (x As Integer, y As Integer, scale As Single, heading As Single, c As _Unsigned Long)
541.     Dim x1, x2, x3, x4, y1, y2, y3, y4, r, a, a1, a2, lg, d, rd
542.     Dim rred, bblue, ggreen
543.     Static switch As Integer
544.     switch = switch + 2
545.     switch = switch Mod 16 + 1
546.     rred = _Red32(c): ggreen = _Green32(c): bblue = _Blue32(c)
547.     r = 10 * scale
548.     x1 = x + r * Cos(heading): y1 = y + r * Sin(heading)
549.     r = 2 * r 'lg lengths
550.     For lg = 1 To 8
551.         If lg < 5 Then
552.             a = heading + .9 * lg * _Pi(1 / 5) + (lg = switch) * _Pi(1 / 10)
553.         Else
554.             a = heading - .9 * (lg - 4) * _Pi(1 / 5) - (lg = switch) * _Pi(1 / 10)
555.         End If
556.         x2 = x1 + r * Cos(a): y2 = y1 + r * Sin(a)
557.         drawLink x1, y1, 3 * scale, x2, y2, 2 * scale, _RGB32(rred + 20, ggreen + 10, bblue + 5)
558.         If lg = 1 Or lg = 2 Or lg = 7 Or lg = 8 Then d = -1 Else d = 1
559.         a1 = a + d * _Pi(1 / 12)
560.         x3 = x2 + r * 1.5 * Cos(a1): y3 = y2 + r * 1.5 * Sin(a1)
561.         drawLink x2, y2, 2 * scale, x3, y3, scale, _RGB32(rred + 35, ggreen + 17, bblue + 8)
562.         rd = Int(Rnd * 8) + 1
563.         a2 = a1 + d * _Pi(1 / 8) * rd / 8
564.         x4 = x3 + r * 1.5 * Cos(a2): y4 = y3 + r * 1.5 * Sin(a2)
565.         drawLink x3, y3, scale, x4, y4, scale, _RGB32(rred + 50, ggreen + 25, bblue + 12)
566.     Next
567.     r = r * .5
568.     Fcirc x1, y1, r, _RGB32(rred - 20, ggreen - 10, bblue - 5)
569.     x2 = x1 + (r + 1) * Cos(heading - _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading - _Pi(1 / 12))
570.     Fcirc x2, y2, r * .2, &HFF000000
571.     x2 = x1 + (r + 1) * Cos(heading + _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading + _Pi(1 / 12))
572.     Fcirc x2, y2, r * .2, &HFF000000
573.     r = r * 2
574.     x1 = x + r * .9 * Cos(heading + _Pi): y1 = y + r * .9 * Sin(heading + _Pi)
575.     TiltedEllipseFill 0, x1, y1, r, .7 * r, heading + _Pi, _RGB32(rred, ggreen, bblue)
576. End Sub
577.  
578. Sub Create_Board
579.     Dim As Integer x, y
580.     _Dest Overlay&
581.     Line (XO, YO)-Step(SQ * NumCols, SQ * NumRows), _RGB32(40, 20, 10), BF
582.     For y = 0 To NRM1
583.         For x = 0 To NCM1
584.             Fcirc SQ * x + XO + SQ / 2, SQ * y + YO + SQ / 2, (SQ - 2) / 2, _RGB32(0)
585.     Next x, y
586.     _ClearColor _RGB32(0), Overlay&
587.     _Dest _Display
588. End Sub
589.  
590. Sub dp (x, y, s$) ' double print white over black to stand out over images
591.     Color &HFF000000
592.     _PrintString (x + 1, y + 1), s$
593.     Color &HFFFFFFFF
594.     _PrintString (x, y), s$
595. End Sub
596.  
597.  

I have given spiders solid background so they may be seen wiggling better.

  [ This attachment cannot be displayed inline in 'Print Page' view ]  

That's probably my final version.

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: Pete on October 23, 2021, 01:01:07 pm

@bplus and @Cobalt

I'm using Windows 10, and I don't get the distortion effect when dragging the game to the edges, as depicted in the video. BTW @Cobalt What type of screen recorder are you using to produce the vids?

Pete

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: Cobalt on October 23, 2021, 01:17:29 pm

Quote from: bplus on October 23, 2021, 12:45:31 pm

Hi Cobalt, is that Windows or Linux? If Windows what version? Those icons look different (top right corner).

I image that would mess up with any QB64 window.

Windows.
Typically only does that on programs using the _DISPLAY keyword. And on random occasion with the IDE.

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: Cobalt on October 23, 2021, 01:18:41 pm

Quote from: Pete on October 23, 2021, 01:01:07 pm

I'm using Windows 10, and I don't get the distortion effect when dragging the game to the edges, as depicted in the video. BTW @Cobalt What type of screen recorder are you using to produce the vids?

Pete

@Pete its called Active Presenter.

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: Pete on October 23, 2021, 01:32:08 pm

@Cobalt. Thanks, I bookmarked the download site.

@bplus

I combined Halloween with Easter and can someone tell me what month they celebrate gay pride?

  [ This attachment cannot be displayed inline in 'Print Page' view ]  

Kidding aside, I did try it with a "straight" black background, and I really liked that rendition.
 
Pete

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: Dav on October 25, 2021, 09:59:15 am

Quote from: bplus on October 22, 2021, 11:05:46 pm

@Dav you had it figured out some time ago, my guess your memory getting like mine. This is old Connect 4 posted almost year ago but now we see our opponent!

I remember playing it before, but couldn't remember a technique that worked, but I think I found it again.  I've found if I mirror the AI play, and divide the playing field, it's easier to out think it.  Like this image shows, it drops on one side, I drop one on the opposite side. I drew boxes around the pieces to show how I matched the pieces.  This way I can beat it pretty often.

Had fun playing this.

- Dav

  [ This attachment cannot be displayed inline in 'Print Page' view ]  

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: bplus on October 25, 2021, 12:26:46 pm

@Dav you might be onto how to play a perfect game! Supposedly it's been proved that for 8x8 Connect 4 Boards the 2nd player always wins in perfect game.

DaiHard at Syntax Bomb pointed me to a link about proof
https://tromp.github.io/c4/c4.html

and code for 8x8 game, I think? :)
https://github.com/tromp/fhourstones88/commit/8378b3256e9dcb79d90b856820cbcc7cef31e66f

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: Pete on October 25, 2021, 01:38:12 pm

Nice work, Dav!

I noticed the A.I. would almost always stack on top. I figured this was a vulnerability that could be exploited, but I wasn't willing to investigate it further. I also "felt" there was a distinct advantage to going second.

So if we use your strategy, maybe Mark should code in a "Screw you, I quit!" message from the A.I.? Hey, he already uses a variable named "Stupid" to track our mistakes. :D

Pete

Title: Re: One Key Connect 4 (8x8) Halloween Style
Post by: bplus on October 25, 2021, 03:16:59 pm

Or the Board could suddenly be overrun by spiders!

The Stupid subroutine is to avoid making a stupid move ie putting a piece upon which the opponent may place his piece and win, sometimes stupid moves can't be avoided, that's when board should be overrun by spiders LOL!

I wish the human could use the Stupid sub too, hey maybe another mod! ;-))

Text Only | Text with Attachments