QB64 Phoenix Edition
Halloween Treats - Printable Version

+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Prolific Programmers (https://qb64phoenix.com/forum/forumdisplay.php?fid=26)
+---- Forum: bplus (https://qb64phoenix.com/forum/forumdisplay.php?fid=36)
+---- Thread: Halloween Treats (/showthread.php?tid=2128)



Halloween Treats - bplus - 10-29-2023

Creep Out


The is a mod of Break Out with spiders crawling out of broken blocks and lots of sound effects and special spider web font.

   


RE: Halloween Treats - bplus - 10-29-2023

One Key - Connect Four, Halloween Style!


A couple of years ago we had a One Key Challenge in that you could use only one key to play a game.

I chose the spacebar to play Connect 4 here with a Halloween Theme:
Code: (Select All)
Option _Explicit ' One Key Connect 4 (8x8) Halloween Style - bplus 2021-10-19
Const SQ = 60 '       square or grid cell
Const NumCols = 8 '   number of columns
Const NumRows = 8 '   you guessed it
Const NCM1 = NumCols - 1 ' NumCols minus 1
Const NRM1 = NumRows - 1 ' you can guess surely
Const SW = SQ * (NumCols + 2) '  screen width
Const SH = SQ * (NumRows + 3) '  screen height
Const P = 1 '       Player is 1 on grid
Const AI = -1 '     AI is -1 on grid
Const XO = SQ '     x offset for grid
Const YO = 2 * SQ ' y offset for grid

ReDim Shared Grid(NCM1, NRM1) ' 0 = empty  P=1 for Player,  AI=-1  for AI so -4 is win for AI..
ReDim Shared DX(7), DY(7) ' Directions
DX(0) = 1: DY(0) = 0 ': DString$(0) = "East"
DX(1) = 1: DY(1) = 1 ': DString$(1) = "South East"
DX(2) = 0: DY(2) = 1 ': DString$(2) = "South"
DX(3) = -1: DY(3) = 1 ': DString$(3) = "South West"
DX(4) = -1: DY(4) = 0 ': DString$(4) = "West"
DX(5) = -1: DY(5) = -1 ': DString$(5) = "North West"
DX(6) = 0: DY(6) = -1 ': DString$(6) = "North"
DX(7) = 1: DY(7) = -1 ' : DString$(7) = "North East"
ReDim Shared Scores(NCM1) ' rating column for AI and displaying them
ReDim Shared AIX, AIY ' last move of AI for highlighting in display
ReDim Shared WinX, WinY, WinD ' display Winning Connect 4
ReDim Shared GameOn, Turn, GoFirst, PlayerLastMoveCol, PlayerLastMoveRow, MoveNum ' game tracking
ReDim Shared Record$(NCM1, NRM1)
Dim Shared sx, pr ' for pumpkin recursion shifty eyes and pumkin radius
Dim place, k$, t, r, s$, d, temp&, target, y, delaid
Dim Shared Overlay& 'the board overlay

Screen _NewImage(SW, SH, 32)
_ScreenMove 360, 60
Overlay& = _NewImage(SW, SH, 32)
Create_Board

_Title "One Key Connect 4 (8x8) Halloween Style #2"
d = 1
While _KeyDown(32) = 0
    Cls
    pumpkin 0, _Width / 2, _Height / 2, _Height / 2.3, 3
    sx = sx + d
    If sx > 10 Then d = -d: sx = 10
    If sx < -10 Then d = -d: sx = -10
    Color &HFFFFFFFF
    Locate 40, 33: Print "Spacebar Only"
    _Display
    _Limit 20
Wend
_KeyClear
GameOn = -1: GoFirst = AI: Turn = AI: MoveNum = 0
ShowGrid
place = -1
t = Timer
pr = (SQ - 2) / 2
While GameOn
    Cls
    If Turn = P Then
        k$ = InKey$
        If k$ = Chr$(27) Then System ' emergency exit
        If k$ = " " Then
            t = Timer: place = place + 1
            If place >= NumCols Then place = -1
        Else ' watch out for midnight!
            If Timer - t < 0 Then 'midnight problem
                t = Timer ' wait a little longer
            Else
                If Timer - t > 2 And place <> -1 Then ' col selected
                    r = GetOpenRow(place)
                    If r <> NumRows Then
                        y = SQ + SQ / 2
                        target = r * SQ + YO + SQ / 2
                        delaid = 6
                        While y < target
                            y = y + 1
                            Cls
                            ShowGrid
                            pumpkin 0, place * SQ + XO + SQ / 2, y, pr, 2
                            sx = Rnd * 6 - 3
                            _PutImage , Overlay&, _Display
                            _Display
                            _Limit delaid
                            delaid = delaid * 2
                        Wend
                        Grid(place, r) = P: Turn = AI: PlayerLastMoveCol = place: PlayerLastMoveRow = r: MoveNum = MoveNum + 1
                        place = -1 ' reset back to hold area
                    Else
                        Beep
                    End If
                End If
            End If
        End If
    Else
        AIMove
        Turn = P: MoveNum = MoveNum + 1: t = Timer
    End If
    ShowGrid
    If Turn = P Then
        If place = -1 Then
            s$ = "Holding area, press spacebar until over column to play."
        Else
            s$ = "Press Spacebar, if don't want to play" + Str$(place) + " column."
        End If
        Color &HFFFFFFFF
        _PrintString (XO, YO - SQ - 16), s$
    End If
    pumpkin 0, place * SQ + XO + SQ / 2, SQ + SQ / 2, pr, 2
    sx = Rnd * 6 - 3
    _PutImage , Overlay&, _Display
    _Display
    _Limit 15
Wend

Sub AIMove
    ' What this sub does in English:
    ' This sub assigns the value to playing each column, then plays the best value with following caveats:
    ' + If it finds a winning move, it will play that immediately.
    ' + If it finds a spoiler move, it will play that if no winning move was found.
    ' + It will poisen the column's scoring, if opponent can play a winning move if AI plays this column,
    '   but it might be the only legal move left.  We will have to play it if no better score was found.

    Dim c, r, d, cntA, cntP, bestScore, startR, startC, iStep, test, goodF, i
    Dim openRow(NCM1) ' find open rows once
    ReDim Scores(NCM1) ' evaluate each column's potential
    AIX = -1: AIY = -1 ' set these when AI makes move, they are signal to display procedure AI's move.
    For c = 0 To NCM1
        openRow(c) = GetOpenRow(c)
        r = openRow(c)
        If r <> NumRows Then
            For d = 0 To 3 ' 4 directions to build connect 4's that use cell c, r
                startC = c + -3 * DX(d): startR = r + -3 * DY(d)
                For i = 0 To 3 ' here we backup from the potential connect 4 in opposite build direction of c, r
                    cntA = 0: cntP = 0: goodF = -1 ' reset counts and flag for good connect 4
                    'from this start position run 4 steps forward to count all connects involving cell c, r
                    For iStep = 0 To 3 ' process a potential connect 4
                        test = GR(startC + i * DX(d) + iStep * DX(d), startR + i * DY(d) + iStep * DY(d))
                        If test = NumRows Then goodF = 0: Exit For 'cant get connect4 from here
                        If test = AI Then cntA = cntA + 1
                        If test = P Then cntP = cntP + 1
                    Next iStep
                    If goodF Then 'evaluate the Legal Connect4 we could build with c, r
                        If cntA = 3 Then ' we are done!  winner!
                            AIX = c: AIY = r ' <<< this is the needed 4th cell to win tell ShowGrid last cell
                            Grid(c, r) = AI '  <<< this is the needed 4th cell to win, add to grid this is AI move
                            Scores(c) = 1000
                            Exit Sub
                        ElseIf cntP = 3 Then 'next best move spoiler!
                            AIX = c: AIY = r 'set the move but don't exit there might be a winner
                            Scores(c) = 900
                        ElseIf cntA = 0 And cntP = 2 Then
                            Scores(c) = Scores(c) + 8
                        ElseIf cntA = 2 And cntP = 0 Then ' very good offense or defense
                            Scores(c) = Scores(c) + 4 'play this to connect 3 or prevent player from Connect 3
                        ElseIf cntA = 0 And cntP = 1 Then
                            Scores(c) = Scores(c) + 4
                        ElseIf (cntA = 1 And cntP = 0) Then 'good offense or defense
                            Scores(c) = Scores(c) + 2 ' play this to connect 2 or prevent player from Connect 2
                        ElseIf (cntA = 0 And cntP = 0) Then ' OK it's not a wasted move as it has potential for connect4
                            Scores(c) = Scores(c) + 1 ' this is good move because this can still be a Connect 4
                        End If
                    End If ' in the board
                Next i
            Next d
            If Stupid(c, r) Then Scores(c) = -1000 + Scores(c) ' poison because if played the human can win
        End If
    Next
    If AIX <> -1 Then ' we found a spoiler so move there since we haven't found a winner
        Grid(AIX, AIY) = AI ' make move on grid and done!
        Exit Sub
    Else
        If GetOpenRow(PlayerLastMoveCol) < NumRows Then 'all things being equal play on top of player's last move
            bestScore = Scores(PlayerLastMoveCol): AIY = PlayerLastMoveRow - 1: AIX = PlayerLastMoveCol
        Else
            bestScore = -1000 ' a negative score indicates that the player can beat AI with their next move
        End If
        For c = 0 To NCM1
            r = openRow(c)
            If r <> NumRows Then
                If Scores(c) > bestScore Then bestScore = Scores(c): AIY = r: AIX = c
            End If
        Next
        If AIX <> -1 Then
            Grid(AIX, AIY) = AI ' make first best score move we found
        Else 'We have trouble!  Oh but it could be there are no moves!!!
            ' checkWin is run after every move by AI or Player if there were no legal moves left it should have caught that.
            ' Just in case it didn't here is an error stop!
            Color &HFFFFFFFF
            Beep: Locate 4, 2: Print "AI has failed to find a proper move, press any to end..."
            Sleep ' <<< pause until user presses a key
            End
        End If
    End If
End Sub

Function GetOpenRow (forCol)
    Dim i
    GetOpenRow = NumRows 'assume none open
    If forCol < 0 Or forCol > NCM1 Then Exit Function
    For i = NRM1 To 0 Step -1
        If Grid(forCol, i) = 0 Then GetOpenRow = i: Exit Function
    Next
End Function

Function Stupid (c, r)
    Dim ppr
    Grid(c, r) = AI
    ppr = GetOpenRow(c)
    If ppr <> NumRows Then
        Grid(c, ppr) = P
        If CheckWin = 4 Then Stupid = -1
        Grid(c, ppr) = 0
    End If
    Grid(c, r) = 0
End Function

Function GR (c, r) ' if c, r are out of bounds returns N else returns grid(c, r)
    ' need to check the grid(c, r) but only if c, r is on the board
    If c < 0 Or c > NCM1 Or r < 0 Or r > NRM1 Then GR = NumRows Else GR = Grid(c, r)
End Function

Sub ShowGrid
    Static lastMoveNum
    Dim i, r, c, check, s$, k$
    If MoveNum <> lastMoveNum Then ' file newest move
        If MoveNum = 1 Then ReDim Record$(NCM1, NRM1)
        If Turn = -1 Then
            Record$(PlayerLastMoveCol, PlayerLastMoveRow) = _Trim$(Str$(MoveNum)) + " " + "P"
        Else
            Record$(AIX, AIY) = _Trim$(Str$(MoveNum)) + " " + "A"
        End If
        lastMoveNum = MoveNum
    End If
    Color _RGB32(255, 255, 255), _RGB32(64, 64, 255): Cls
    'Line (XO, YO)-Step(NumCols * SQ, NumRows * SQ), &HFF004400, BF
    For i = 0 To NumCols 'grid
        Line (SQ * i + XO, YO)-Step(0, NumRows * SQ), &HFFFFFFFF
    Next
    For i = 0 To NumRows
        Line (XO, SQ * i + YO)-Step(NumCols * SQ, 0), &HFFFFFFFF
    Next
    Color
    For r = NRM1 To 0 Step -1 ''in grid rows are reversed 0 is top row
        For c = 0 To NCM1
            If Grid(c, r) = P Then
                'Line (c * SQ + XO + 3, r * SQ + YO + 3)-Step(SQ - 6, SQ - 6), &HFF000000, BF
                pumpkin 0, c * SQ + XO + SQ / 2, r * SQ + YO + SQ / 2, pr, 2

            ElseIf Grid(c, r) = AI Then
                If c = AIX And r = AIY Then 'highlite last AI move
                    'Line (c * SQ + XO + 3, r * SQ + YO + 3)-Step(SQ - 6, SQ - 6), &HFF8888FF, BF  ' no overlay
                    Line (c * SQ + XO, r * SQ + YO)-Step(SQ, SQ), &HFF8888FF, BF
                    'Else
                    'Line (c * SQ + XO + 3, r * SQ + YO + 3)-Step(SQ - 6, SQ - 6), &HFF4444FF, BF  ' no overlay
                    'Line (c * SQ + XO, r * SQ + YO)-Step(SQ, SQ), &HFF4444FF, BF
                End If
                drawSpinner c * SQ + XO + SQ / 2, r * SQ + YO + SQ / 2, .4, _Pi(-c / 8), _RGB32(Rnd * 30 + 40, Rnd * 15 + 20, Rnd * 6 + 10)
            End If
            s$ = _Trim$(Str$(Scores(c)))
            Color &HFFFFFFFF
            _PrintString (XO + c * SQ + (60 - Len(s$) * 8) / 2, YO + SQ * NumRows + 22), s$
        Next
    Next
    '_Display
    check = CheckWin
    If check Then 'report end of round ad see if want to play again
        If check = 4 Or check = -4 Then
            For i = 0 To 3
                Line ((WinX + i * DX(WinD)) * SQ + XO + 10, (WinY + i * DY(WinD)) * SQ + YO + 10)-Step(SQ - 20, SQ - 20), &HFFFFFF00, B
            Next
        End If
        Color &HFFFFFFFF
        For r = 0 To NRM1
            For c = 0 To NCM1
                If Record$(c, r) <> "" Then
                    s$ = Mid$(Record$(c, r), 1, InStr(Record$(c, r), " ") - 1)
                    _PrintString (SQ * c + XO + (SQ - Len(s$) * 8) / 2, SQ * r + YO + 22), s$
                End If
            Next
        Next
        If check = -4 Then
            s$ = " AI is Winner!"
        ElseIf check = 4 Then
            s$ = " Human is Winner!"
        ElseIf check = NumRows Then
            s$ = " Board is full, no winner." ' keep Turn the same
        End If
        Locate 2, ((SW - Len(s$) * 8) / 2) / 8: Print s$
        s$ = " Play again? press spacebar, escape to quit... "
        Locate 4, ((SW - Len(s$) * 8) / 2) / 8: Print s$
        _PutImage , Overlay&, _Display
        _Display
        keywait:
        While Len(k$) = 0
            k$ = InKey$
            _Limit 200
        Wend
        If k$ = " " Then
            ReDim Grid(NCM1, NRM1), Scores(NCM1)
            If GoFirst = P Then GoFirst = AI Else GoFirst = P
            Turn = GoFirst: MoveNum = 0
        ElseIf Asc(k$) = 27 Then
            System
        Else
            k$ = "": GoTo keywait:
        End If
    End If
End Sub

Function CheckWin ' return WinX, WinY, WinD along with +/- 4, returns NumRows if grid full, 0 if no win and grid not full
    Dim gridFull, r, c, s, i
    gridFull = NumRows
    For r = NRM1 To 0 Step -1 'bottom to top
        For c = 0 To NCM1
            If Grid(c, r) Then ' check if c starts a row
                If c < NCM1 - 2 Then
                    s = 0
                    For i = 0 To 3 ' east
                        s = s + Grid(c + i, r)
                    Next
                    If s = 4 Or s = -4 Then WinX = c: WinY = r: WinD = 0: CheckWin = s: Exit Function
                End If
                If r > 2 Then ' check if c starts a col
                    s = 0
                    For i = 0 To 3 ' north
                        s = s + Grid(c, r - i)
                    Next
                    If s = 4 Or s = -4 Then WinX = c: WinY = r: WinD = 6: CheckWin = s: Exit Function
                End If
                If r > 2 And c < NCM1 - 2 Then 'check if c starts diagonal up to right
                    s = 0
                    For i = 0 To 3 ' north  east
                        s = s + Grid(c + i, r - i)
                    Next
                    If s = 4 Or s = -4 Then WinX = c: WinY = r: WinD = 7: CheckWin = s: Exit Function
                End If
                If r > 2 And c > 2 Then 'check if c starts a diagonal up to left
                    s = 0
                    For i = 0 To 3 ' north west
                        s = s + Grid(c - i, r - i)
                    Next
                    If s = 4 Or s = -4 Then WinX = c: WinY = r: WinD = 5: CheckWin = s: Exit Function
                End If
            Else
                gridFull = 0 ' at least one enpty cell left
            End If 'grid is something
        Next
    Next
    CheckWin = gridFull
End Function


Sub pumpkin (dh&, cx, cy, pr, limit)
    Dim lastr, u, dx, i, tx1, tx2, tx3, ty1, ty2, ty3, ty22, sxs
    'carve this!
    Color &HFFFF0000
    fEllipse cx, cy, pr, 29 / 35 * pr
    Color &HFF000000
    lastr = 2 / 7 * pr
    Do
        ellipse cx, cy, lastr, 29 / 35 * pr
        lastr = .5 * (pr - lastr) + lastr + 1 / 35 * pr
        If pr - lastr < 1 / 80 * pr Then Exit Do
    Loop

    ' 'flickering candle light
    'Color _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)

    ' eye sockets
    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)
    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)
    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)
    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)

    ' nose
    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)

    ' evil grin
    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)
    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)

    ' moving teeth/talk/grrrr..
    u = rand%(4, 8)
    dx = pr / u
    For i = 1 To u
        tx1 = cx - 6 * pr / 12 + (i - 1) * dx
        tx2 = tx1 + .5 * dx
        tx3 = tx1 + dx
        ty1 = cy + 5 * pr / 12
        ty3 = cy + 5 * pr / 12
        ty2 = cy + (4 - Rnd) * pr / 12
        ty22 = cy + (6 + Rnd) * pr / 12
        ftri2 dh&, tx1, ty1, tx2, ty2, tx3, ty3, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
        ftri2 dh&, tx1 + .5 * dx, ty1, tx2 + .5 * dx, ty22, tx3 + .5 * dx, ty3, _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
    Next
    If limit Then
        'shifty eyes
        If limit = 3 Then sxs = sx Else sxs = .1 * limit * sx
        pumpkin dh&, sxs + cx - 5 * pr / 12, cy - 2.5 * pr / 12, .15 * pr, Int(limit - 1)
        pumpkin dh&, sxs + cx + 5 * pr / 12, cy - 2.5 * pr / 12, .15 * pr, Int(limit - 1)
    End If
End Sub

Sub fEllipse (CX As Long, CY As Long, xRadius As Long, yRadius As Long)
    Dim scale As Single, x As Long, y As Long
    scale = yRadius / xRadius
    Line (CX, CY - yRadius)-(CX, CY + yRadius), , BF
    For x = 1 To xRadius
        y = scale * Sqr(xRadius * xRadius - x * x)
        Line (CX + x, CY - y)-(CX + x, CY + y), , BF
        Line (CX - x, CY - y)-(CX - x, CY + y), , BF
    Next
End Sub

Sub ellipse (CX As Long, CY As Long, xRadius As Long, yRadius As Long)
    Dim scale As Single, xs As Long, x As Long, y As Long
    Dim lastx As Long, lasty As Long
    scale = yRadius / xRadius: xs = xRadius * xRadius
    PSet (CX, CY - yRadius): PSet (CX, CY + yRadius)
    lastx = 0: lasty = yRadius
    For x = 1 To xRadius
        y = scale * Sqr(xs - x * x)
        Line (CX + lastx, CY - lasty)-(CX + x, CY - y)
        Line (CX + lastx, CY + lasty)-(CX + x, CY + y)
        Line (CX - lastx, CY - lasty)-(CX - x, CY - y)
        Line (CX - lastx, CY + lasty)-(CX - x, CY + y)
        lastx = x: lasty = y
    Next
End Sub

Sub ftri2 (returnDest&, x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
    Dim a&
    a& = _NewImage(1, 1, 32)
    _Dest a&
    PSet (0, 0), K
    _Dest returnDest&
    _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
    _FreeImage a& '<<< this is important!
End Sub

Function rand% (lo%, hi%)
    rand% = Int(Rnd * (hi% - lo% + 1)) + lo%
End Function



Sub drawLink (x1, y1, r1, x2, y2, r2, c As _Unsigned Long)
    Dim a, a1, a2, x3, x4, x5, x6, y3, y4, y5, y6
    a = _Atan2(y2 - y1, x2 - x1)
    a1 = a + _Pi(1 / 2)
    a2 = a - _Pi(1 / 2)
    x3 = x1 + r1 * Cos(a1): y3 = y1 + r1 * Sin(a1)
    x4 = x1 + r1 * Cos(a2): y4 = y1 + r1 * Sin(a2)
    x5 = x2 + r2 * Cos(a1): y5 = y2 + r2 * Sin(a1)
    x6 = x2 + r2 * Cos(a2): y6 = y2 + r2 * Sin(a2)
    fquad x3, y3, x4, y4, x5, y5, x6, y6, c
    Fcirc x1, y1, r1, c
    Fcirc x2, y2, r2, c
End Sub

'need 4 non linear points (not all on 1 line) list them clockwise so x2, y2 is opposite of x4, y4
Sub fquad (x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, x3 As Integer, y3 As Integer, x4 As Integer, y4 As Integer, c As _Unsigned Long)
    ftri x1, y1, x2, y2, x4, y4, c
    ftri x3, y3, x4, y4, x1, y1, c
End Sub

Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
    Dim a&
    a& = _NewImage(1, 1, 32)
    _Dest a&
    PSet (0, 0), K
    _Dest 0
    _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
    _FreeImage a& '<<< this is important!
End Sub

Sub TiltedEllipseFill (destHandle&, x0, y0, a, b, ang, c As _Unsigned Long)
    Dim max As Integer, mx2 As Integer, i As Integer, j As Integer, k As Single, lasti As Single, lastj As Single
    Dim prc As _Unsigned Long, tef As Long
    prc = _RGB32(255, 255, 255, 255)
    If a > b Then max = a + 1 Else max = b + 1
    mx2 = max + max
    tef = _NewImage(mx2, mx2)
    _Dest tef
    _Source tef 'point wont read without this!
    For k = 0 To 6.2832 + .05 Step .1
        i = max + a * Cos(k) * Cos(ang) + b * Sin(k) * Sin(ang)
        j = max + a * Cos(k) * Sin(ang) - b * Sin(k) * Cos(ang)
        If k <> 0 Then
            Line (lasti, lastj)-(i, j), prc
        Else
            PSet (i, j), prc
        End If
        lasti = i: lastj = j
    Next
    Dim xleft(mx2) As Integer, xright(mx2) As Integer, x As Integer, y As Integer
    For y = 0 To mx2
        x = 0
        While Point(x, y) <> prc And x < mx2
            x = x + 1
        Wend
        xleft(y) = x
        While Point(x, y) = prc And x < mx2
            x = x + 1
        Wend
        While Point(x, y) <> prc And x < mx2
            x = x + 1
        Wend
        If x = mx2 Then xright(y) = xleft(y) Else xright(y) = x
    Next
    _Dest destHandle&
    For y = 0 To mx2
        If xleft(y) <> mx2 Then Line (xleft(y) + x0 - max, y + y0 - max)-(xright(y) + x0 - max, y + y0 - max), c, BF
    Next
    _FreeImage tef
End Sub

Sub Fcirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
    Dim Radius As Long, RadiusError As Long
    Dim X As Long, Y As Long
    Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
    If Radius = 0 Then PSet (CX, CY), C: Exit Sub
    Line (CX - X, CY)-(CX + X, CY), C, BF
    While X > Y
        RadiusError = RadiusError + Y * 2 + 1
        If RadiusError >= 0 Then
            If X <> Y + 1 Then
                Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
                Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
            End If
            X = X - 1
            RadiusError = RadiusError - X * 2
        End If
        Y = Y + 1
        Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
        Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
    Wend
End Sub

Sub drawSpinner (x As Integer, y As Integer, scale As Single, heading As Single, c As _Unsigned Long)
    Dim x1, x2, x3, x4, y1, y2, y3, y4, r, a, a1, a2, lg, d, rd
    Dim rred, bblue, ggreen
    Static switch As Integer
    switch = switch + 2
    switch = switch Mod 16 + 1
    rred = _Red32(c): ggreen = _Green32(c): bblue = _Blue32(c)
    r = 10 * scale
    x1 = x + r * Cos(heading): y1 = y + r * Sin(heading)
    r = 2 * r 'lg lengths
    For lg = 1 To 8
        If lg < 5 Then
            a = heading + .9 * lg * _Pi(1 / 5) + (lg = switch) * _Pi(1 / 10)
        Else
            a = heading - .9 * (lg - 4) * _Pi(1 / 5) - (lg = switch) * _Pi(1 / 10)
        End If
        x2 = x1 + r * Cos(a): y2 = y1 + r * Sin(a)
        drawLink x1, y1, 3 * scale, x2, y2, 2 * scale, _RGB32(rred + 20, ggreen + 10, bblue + 5)
        If lg = 1 Or lg = 2 Or lg = 7 Or lg = 8 Then d = -1 Else d = 1
        a1 = a + d * _Pi(1 / 12)
        x3 = x2 + r * 1.5 * Cos(a1): y3 = y2 + r * 1.5 * Sin(a1)
        drawLink x2, y2, 2 * scale, x3, y3, scale, _RGB32(rred + 35, ggreen + 17, bblue + 8)
        rd = Int(Rnd * 8) + 1
        a2 = a1 + d * _Pi(1 / 8) * rd / 8
        x4 = x3 + r * 1.5 * Cos(a2): y4 = y3 + r * 1.5 * Sin(a2)
        drawLink x3, y3, scale, x4, y4, scale, _RGB32(rred + 50, ggreen + 25, bblue + 12)
    Next
    r = r * .5
    Fcirc x1, y1, r, _RGB32(rred - 20, ggreen - 10, bblue - 5)
    x2 = x1 + (r + 1) * Cos(heading - _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading - _Pi(1 / 12))
    Fcirc x2, y2, r * .2, &HFF000000
    x2 = x1 + (r + 1) * Cos(heading + _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading + _Pi(1 / 12))
    Fcirc x2, y2, r * .2, &HFF000000
    r = r * 2
    x1 = x + r * .9 * Cos(heading + _Pi): y1 = y + r * .9 * Sin(heading + _Pi)
    TiltedEllipseFill 0, x1, y1, r, .7 * r, heading + _Pi, _RGB32(rred, ggreen, bblue)
End Sub

Sub Create_Board
    Dim As Integer x, y
    _Dest Overlay&
    Line (60, 120)-Step(480, 480), _RGB32(80, 40, 20), BF
    For y = 0 To 7
        For x = 0 To 7
            Fcirc 90 + 60 * x, 150 + 60 * y, 28, _RGB32(0)
    Next x, y
    _ClearColor _RGB32(0), Overlay&
    _Dest _Display
End Sub

   


RE: Halloween Treats - bplus - 10-29-2023

Crypt-O-gram Halloween Puzzle


I modified this today from the One Key Challenge that used a spacebar and timing to input the Code Letter and your guess for actual letter. Too distracting from trying to figure out puzzle so I swicthed to keying in letters or menu numbers for direct input. A number of clues and hints are given in the readme.txt file for help solving the puzzles with simple letter substitutions. Its all in the zip.

There are 3 different play screen backgrounds:
   
   
   


RE: Halloween Treats - Dav - 10-30-2023

Hey I remember the connect four.  Always liked playing this one.  I still suck at it, but enjoying playing it again. Spiders always catching me on the diagonals.  I was trying to speed up the pumpkin drop speed.  Changing/commenting out the _Limit delaid didn't help at all (my laptop is slooow), so I changed the drop to y = y + 2 to speed it up a tad. 

This is the game that got me inspired to do my first AI game play.
 
- Dav.