Show Posts

This section allows you to view all posts made by this member. Note that you can only see posts made in areas you currently have access to.

Topics - bplus

Pages: 1 2 3 [4] 5 6 ... 21

Programs / Play Offs Chart - Recursion Example

« on: November 02, 2021, 11:29:20 am »

Get ready for Play Offs:

Code: QB64: [Select]

_Title "Play Offs Chart - Recursion example" 'b+ 2021-10-27
'2021-11-02 A few mods and ready for the playoffs
 
'Recursion is a sub or function that calls itself until it's job is done
'Here is a grahics
Const pi = _Pi
Screen _NewImage(700, 700, 32)
 
recThis 700, 350, 350 / 2, 0
Sleep
 
Sub recThis (x, y, arm, level As Integer)
    'first thing to ask in recursive subroutine is are we done!!!
    If arm < 2 Then Exit Sub ' recursion is finished
    ' no not done
    If level Mod 2 Then
        x1 = x + 1.4 * arm * Cos(pi / 2): y1 = y + 1.4 * arm * Sin(pi / 2)
        x2 = x + 1.4 * arm * Cos(1.5 * pi): y2 = y + 1.4 * arm * Sin(1.5 * pi)
        Line (x1, y1)-(x2, y2)
        recThis x1, y1, .7 * arm, level + 1
        recThis x2, y2, .7 * arm, level + 1
    Else
        x1 = x: y1 = y
        x2 = x + 100 * Cos(pi): y2 = y + 100 * Sin(pi)
        Line (x1, y1)-(x2, y2)
        recThis x2, y2, .7 * arm, level + 1
    End If
End Sub
 

Programs / Recursive Vrs NonRecursive test with Quicksort

« on: November 01, 2021, 08:29:10 am »

Seeing Sanmayce Quicksort test with my recursive Quicksort I had to try my own test without using the array in the parameters/arguments call, plus in the Discussion Board Recursion topic brought up some ideas from Luke on recursion that I've been curious experimenting with for some time.

So here's my quick test:

Code: QB64: [Select]

_Title "Recursive Vrs NonRecursive test with Quicksort" 'b+ 2021-11-01
_Define A-Z As _UNSIGNED _INTEGER64
ReDim Shared As _Unsigned _Integer64 ArrayHigh
ArrayHigh = 100000000
ReDim Shared As _Unsigned _Integer64 n(1 To ArrayHigh), m(1 To ArrayHigh)
 
For i = 1 To ArrayHigh
    n(i) = i
Next
For i = ArrayHigh To 2 Step -1 ' Fisher Yates Shuffle
    Swap n(i), n(Int(Rnd * i) + 1)
    m(i) = n(i) ' copy m off n
Next
Print "Test arrays ready. Testing Recursive QuickSort first."
m(1) = n(1)
T# = Timer(.001)
QuickSort 1, ArrayHigh
QuickSortT# = Timer(.001) - T#
For i = 1 To ArrayHigh
    If n(i) <> i Then Beep: Print "Error in QuickSort array n."
Next
Print "QuickSort checked, QuickSort time was"; QuickSortT#
 
T# = Timer(.001)
Quicksort_QB64
QuicksortQB64T# = Timer(.001) - T#
For i = 1 To ArrayHigh
    If m(i) <> i Then Beep: Print "Error in Quicksort__QB64 array m."
Next
Print "Quicksort_QB64 checked, Quicksort_QB64 time was"; QuicksortQB64T#
 
' recursive
Sub QuickSort (start As _Unsigned _Integer64, finish As _Unsigned _Integer64)
    Lo = start: Hi = finish
    Middle = n((Lo + Hi) \ 2)
    Do
        Do While n(Lo) < Middle: Lo = Lo + 1: Loop
        Do While n(Hi) > Middle: Hi = Hi - 1: Loop
        If Lo <= Hi Then
            Swap n(Lo), n(Hi)
            Lo = Lo + 1: Hi = Hi - 1
        End If
    Loop Until Lo > Hi
    If Hi > start Then QuickSort start, Hi
    If Lo < finish Then QuickSort Lo, finish
End Sub
 
' non recursive
' ref:  https://rosettacode.org/wiki/Sorting_algorithms/Quicksort#QB64
Sub Quicksort_QB64
    Left = LBound(m)
    Right = UBound(m)
    LeftMargin = Left
    ReDim Stack&&(Left To Right)
    StackPtr = 0
    StackPtr = StackPtr + 1
    Stack&&(StackPtr + LeftMargin) = Left
    StackPtr = StackPtr + 1
    Stack&&(StackPtr + LeftMargin) = Right
    Do 'Until StackPtr = 0
        Right = Stack&&(StackPtr + LeftMargin)
        StackPtr = StackPtr - 1
        Left = Stack&&(StackPtr + LeftMargin)
        StackPtr = StackPtr - 1
        Do 'Until Left >= Right
            Pivot~&& = m((Left + Right) \ 2)
            Indx = Left
            Jndx = Right
            Do
                Do While (m(Indx) < Pivot~&&)
                    Indx = Indx + 1
                Loop
                Do While (m(Jndx) > Pivot~&&)
                    Jndx = Jndx - 1
                Loop
                If Indx <= Jndx Then
                    If Indx < Jndx Then Swap m(Indx), m(Jndx)
                    Indx = Indx + 1
                    Jndx = Jndx - 1
                End If
            Loop While Indx <= Jndx
            If Indx < Right Then
                StackPtr = StackPtr + 1
                Stack&&(StackPtr + LeftMargin) = Indx
                StackPtr = StackPtr + 1
                Stack&&(StackPtr + LeftMargin) = Right
            End If
            Right = Jndx
        Loop Until Left >= Right
    Loop Until StackPtr = 0
End Sub
 
 

Nice non recursion code, doing it with your own stack is interesting. I don't suppose there's a way to do a recursive quicksort without need of any parameters to call? Hmm...

EDIT: Dang it! I never use Call this is what I get for copying what I thought was my code from someone else post. :(
EDIT: Fix a labeling if error found in 2nd test.

Programs / Honeycombs _ Rosetta Code

« on: October 30, 2021, 02:33:20 pm »

ref: http://rosettacode.org/wiki/Honeycombs

Here is updated translation and overhaul I made today:

Code: QB64: [Select]

_Title "Honeycombs - Rosetta Code" ' b+ 2021-10-30 trans from
' Honeycomb Rosetta.txt for JB v2 2018-11-24 B+ finish Rosetta Challenge
' 2021-10-30 complete overhaul except for grid drawing numbers and names.
 
' ===================== Try alternate Cols and Rows for HoneyComb ===============================
 
Const Cols = 5, Rows = 4, LMax = Cols * Rows ' hex grid  <<<<<<<<<<<<<<  as Rosetta Requires
'Const Cols = 4, Rows = 5, LMax = Cols * Rows ' hex grid <<<<<<<<<<<<<< reverse
'Const Cols = 6, Rows = 5, LMax = Cols * Rows ' hex grid <<<<<<<<<<<<<< More than just Letters
'Const Cols = 13, Rows = 2, LMax = Cols * Rows ' hex grid do exactly whole alphabet!
 
 
' global   SELECTED$ ' all caps for globals
Const Pi3 = _Pi / 3, Sqr3 = Sqr(3), Side = 30 '           constants for Hexagon making
Const Xoff = 100 - 1.5 * Side, Yoff = 100 - Side * Sqr3 ' center grid with offsets on screen
Const XMax = 2 * Xoff + Cols * 1.5 * Side + 1.5 * Side '  screen display size needed
Const YMax = 2 * Yoff + (Rows + 2) * Side * Sqr3
 
Dim Shared L$(LMax), LX(LMax), LY(LMax), LSELECTED(LMax), Selected$ ' save letter and hex center positions by index
 
Randomize Timer ' get new grid when we start
For i = 1 To LMax ' get letters array loaded
    L$(i) = Chr$(64 + i)
Next
For i = LMax To 2 Step -1 ' shuffle letters Fisher - Yates
    Swap L$(i), L$(Int(Rnd * i) + 1)
Next
 
Screen _NewImage(XMax, YMax, 32) 'graphics custom size RGBA colors
_Delay .25 ' get screen loaded before trying to move
_ScreenMove _Middle ' center  screen
 
f& = _LoadFont("Consolab.ttf", 40) ' >>>>>>>>>>>> from Windows 10 Fonts
_Font f&
Color , _RGB32(200, 200, 220): Cls ' draw grid before selections
For y = 1 To Rows ' initialize screen with grid
    For x = 1 To Cols
        n = n + 1 ' index hex buttons
        If x Mod 2 = 0 Then yoff2 = .5 * Side * Sqr3 Else yoff2 = 0 ' is this column lower than first column?
        cx = x * 1.5 * Side + Xoff: cy = y * Side * Sqr3 + Yoff + yoff2 ' calc hex key centers
        LX(n) = cx: LY(n) = cy ' save hex key center positions
        drawHex n, 0 ' draw key
    Next
Next
 
While _KeyDown(27) = 0 ' allow user to select letters by key or mouse
    k$ = InKey$
    If Len(k$) Then
        For i = 1 To LMax 'if so was it selected already? or select it.
            If UCase$(k$) = L$(i) And LSELECTED(i) = 0 Then drawHex i, 1: Exit For
        Next
    End If
    While _MouseInput: Wend ' polls mouse
    mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
    If mb Then
        For i = 1 To LMax ' is distance from click within radius of non-selected button?
            If Sqr((mx - LX(i)) ^ 2 + (my - LY(i)) ^ 2) <= Side * .5 * Sqr3 And LSELECTED(i) = 0 Then drawHex i, 1
        Next
    End If
Wend
 
Sub drawHex (i, selectedTF)
    If selectedTF = 0 Then
        Color _RGB32(255, 0, 0), _RGB32(255, 255, 0)
    Else
        Color _RGB32(0, 0, 0), _RGB32(255, 0, 255)
    End If
    For a = 0 To 6
        x1 = LX(i) + Side * Cos(a * Pi3): y1 = LY(i) + Side * Sin(a * Pi3)
        If a > 0 Then Line (lastx, lasty)-(x1, y1), _RGB32(0, 0, 0)
        lastx = x1: lasty = y1
    Next
    Paint (LX(i), LY(i)), _BackgroundColor, _RGB32(0, 0, 0)
    _PrintString (LX(i) - 10, LY(i) - 13), L$(i)
    If selectedTF Then ' show the order of selection
        Color _RGB32(0, 0, 0), _RGB32(200, 200, 220)
        LSELECTED(i) = 1
        Selected$ = Selected$ + L$(i)
        centerText 0, _Width, _Height - 60, Mid$(Selected$, 1, Int(LMax / 2))
        If Len(Selected$) > 10 Then
            centerText 0, _Width, _Height - 20, Mid$(Selected$, Int(LMax / 2) + 1) 'are we done yet? are all letters selected?
            If Len(Selected$) = LMax Then Beep ' all have been selected
        End If
    End If
End Sub
 
Sub centerText (x1, x2, midy, s$) ' ' if you want to center fit a string between two goal posts x1, and x2
    _PrintString ((x1 + x2) / 2 - _PrintWidth(s$) / 2, midy - _FontHeight(_Font) / 2), s$
End Sub
 

Here's what it looked like in Just Basic 3 years ago:

Code: [Select]

'Honeycomb Rosetta.txt for JB v2 2018-11-24 B+ finish Rosetta Challenge

global XMAX, YMAX, PI3, SQR3, SIDE, LMAX, SELECTED$, ROWS, YOFF  ' all caps for globals
PI3 = acs(-1)/3 : SQR3 = sqr(3) : SIDE = 30                      ' constants for Hexagon making
cols = 5 : ROWS = 4 : LMAX = cols * ROWS                         ' hex grid size
dim L$(LMAX), LX(LMAX), LY(LMAX), LSELECTED(LMAX)                ' save letter and hex center positions by index
xoff = 100 - 1.5 * SIDE : YOFF = 100 - SIDE * SQR3               ' center grid with offsets
for i = 1 to LMAX : L$(i) = chr$(64 + i) : next                  ' get letters array loaded
for i = LMAX to 2 step -1                                        ' shuffle letters Fisher - Yates
    r = int(rnd(0) * i) + 1                                      ' random number up to i place
    t$ = L$(r) : L$(r) = L$(i) : L$(i) = t$                      ' swap
next
XMAX = 2*xoff + cols*1.5*SIDE + 1.5*SIDE                         'screen display size needed
YMAX = 2*YOFF + (ROWS + 2)*SIDE*SQR3
nomainwin                                                        ' Window prep before open
WindowWidth = XMAX + 8                                           ' size
WindowHeight = YMAX + 32
UpperLeftX = (DisplayWidth - XMAX) / 2                           ' top left corner, center window
UpperLeftY = (DisplayHeight - YMAX) / 2
open "Honeycomb - Rosetta Challenge" for graphics_nsb_nf as #gr  ' open with title
#gr "setfocus"                                                   ' catch keys and mouse
#gr "trapclose quit"                                             ' set exit code sub
#gr "when leftButtonUp lButtonUp"                                ' set mouse click up sub
#gr "when characterInput charIn"                                 ' set keppress sub
#gr "font consolus bold 20"                                      ' set font
#gr "down"                                                       ' pen ready to draw
for y = 1 to ROWS                                                ' initialize screen with grid
    for x = 1 to cols
        n = n + 1                                                ' index hex buttons
        if x mod 2 = 0 then yoff2 = .5*SIDE*SQR3 else yoff2 = 0  ' is this column lower than first column?
        cx = x*1.5*SIDE + xoff : cy = y*SIDE*SQR3 + YOFF + yoff2 ' calc hex key centers
        LX(n) = cx : LY(n) = cy                                  ' save hex key center positions
        call drawHex n, "green"                                  ' draw key
    next
next
#gr "flush"
wait
sub charIn H$, c$                                                'is c$, the key pressed, one of the letters in L$?
    for i = 1 to LMAX                                            'if so was it selected already? or select it.
        if upper$(c$) = L$(i) and LSELECTED(i) = 0 then call drawHex i, "blue" : #gr "flush" : exit sub
    next
end sub
sub lButtonUp H$, mx, my                                         ' mx, my are mouse button release locations
    for i = 1 to LMAX                                            ' is distance from click within radius of non-selected button?
        if sqr((mx-LX(i))^2+(my-LY(i))^2) <= SIDE*.5*SQR3 and LSELECTED(i) = 0 then call drawHex i, "blue" : #gr "flush" : exit sub
    next
end sub
sub drawHex i, c$
    #gr "size 1"
    #gr "backcolor ";c$                                          ' color location
    #gr "place ";LX(i) + .5;" ";LY(i);"; circlefilled ";SIDE * .5 * SQR3
    #gr "color black"                                            ' color letter and grid, thick line #10
    #gr "size 10"
    call Hex LX(i), LY(i)                                        ' draw hexagon cell
    call stext LX(i) - 10, LY(i) + 11, L$(i)                     ' draw letter
    if c$ = "blue" then                                          ' update Selection tracking and display
        LSELECTED(i) = 1
        SELECTED$ = SELECTED$ + L$(i)
        call stext 0, (ROWS + 2) * SIDE * SQR3 + YOFF, SELECTED$ 'are we done yet? are all letters selected?
        if len(SELECTED$) = LMAX then notice "All the keys have been used. Goodbye" : call quit "#gr"
    end if
end sub
sub Hex x0, y0                                                    ' draw hexagon around x0, y0 with 6 lines
    for i = 0 to 6
        x1 = x0 + SIDE * cos(i * PI3) : y1 = y0 + SIDE * sin(i * PI3)
        if i > 0 then #gr "line ";lastx;" ";lasty;" ";x1;" ";y1
        lastx = x1 : lasty = y1
    next
end sub
sub stext x, y, message$                                          ' note: y is the bottom edge not top
    #gr "place ";x;" ";y;";|";message$                            ' print message at x, y
end sub
sub quit H$                                                       ' close window ie click top right x box
    close #H$ : end
end sub

Just Basic has a very different way of doing screens and graphics.

Programs / One Key Creep Out for Halloween

« on: October 25, 2021, 11:20:29 pm »

One Key Creep Out for Halloween - takes a little practice. With the paddle moving a Spacebar press stops paddle another press, reverses direction and moves again, another press stops, another reverses direction and moves again.

Hint: overshoot paddle target a bit if off you will start going in correct direction with next spacebar press.

Code: QB64: [Select]

_Title "One Key Creep Out for Halloween" 'B+  from Creep Out started 2021-08-18  Breakout with Spiders
' 2021-08-20A more sounds for breaking bricks font to replace text sub
' 2021-10-25 fix up Menu now that I know more about Fonts, one key = Spacebar
' Spacebar toggles menu choices and moving\stopping the paddle.
 
' =============================  Paddle Play with Spacebar Only! =================================
 
' Paddle on each Spacebar press: Moves Stops Reverses Stops Reverses Stops Reverses Stops...
 
' Hint: over shoot paddle placement so if too much you will start right up again going back!
 
' ================================================================================================
 
 
Randomize Timer
Const xmax = 700 '<==== drawing area width
Const ymax = 560 '<==== drawing area height
 
'colors used
Const red = &HFFEE0033
Const orange = &HFFFF8400
Const green = &HFF008000
Const yellow = &HFFFFFF00
Const silver = &HFFD0C6C6
Const white = &HFFFFFFFF
Const black = &HFF000000
 
' wall is 50 pixels X 14 columns wide = 700 make screen width
' wall is 20 pixels X 8  rows = 160 = 1/3 screen height = 480 + 20  paddle height
' under paddle track score and lifes on one line padded by blank lines 540 = 27
' so total height 480 to paddle 500 + 60 for 3 lines = 560 (text height 20)
 
Const br = 10 ' ball radius
Const bkw = 50 ' brick width
Const bkh = 20 ' brick height
 
Const nSpinners = 112
Const air_resistance = .1
 
Type Object
    x As Single
    y As Single
    dx As Single
    dy As Single
    sz As Single
    c As _Unsigned Long
    dead As Long
End Type
 
Dim Shared As Integer nS, pOFF, dMode
Dim Shared dots(2000) As Object
 
' Sound sources mainly Sound Bible picks from both johnno56 and myself here: https://soundbible.com
' from Cobalt's advanced version of my eRATication, rar here: https://www.qb64.org/forum/index.php?topic=370.msg2677#msg2677
' from Filleppes Cloned Shades here: https://www.qb64.org/forum/index.php?topic=1262.msg104706#msg104706
 
Dim Shared As Long mush, alive, laser, whistle, crunch, pop, uh, gong
mush = _SndOpen("mush.wav") ' brick 0 breaking        johnno soundbible
alive = _SndOpen("life.wav") ' brick 1 breaking       Colbalt eRATication
laser = _SndOpen("laser.wav") ' brick 2 breaking      mark soundbible
whistle = _SndOpen("whistle.ogg") ' brick 3 fellippe  Clone-Shades master
crunch = _SndOpen("crunch.wav") ' ball over spider    johnno  soundbible
pop = _SndOpen("pop.wav") ' bouce off wall or paddle  mark soundbible
uh = _SndOpen("playerdie.mp3") ' paddle miss          Colbalt eRATication
gong = _SndOpen("gong.wav") ' complete a screen       mark soundbible
'Print mush, alive, laser, whistle 'ok
'Print crunch, pop, uh, gong 'ok
'End
 
Screen _NewImage(xmax, ymax, 32)
 
'_FullScreen
' OR   >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> You can choose Full Screen or Centered on screen 700 x 560
_Delay .25
_ScreenMove _Middle
 
_MouseHide
Color white, black
f& = _LoadFont("spiders.ttf", 64) ' License included in zip package
_Font f&
 
Dim Shared bx, by, dx, dy, px, py, pw, plf, prt, pf, score, life, hits, obk, rbk, speedups
bx = 0 ' ball x position
by = 0 ' ball y position
dx = 0 ' ball horizontal change
dy = 0 ' ball vertical change
 
restart:
px = 350 ' paddle x, y
py = 450 ' fix paddle sticking at 480
pw = 70 ' paddle width,  100 wide to start half that at certain point
plf = 0 ' paddle left side
prt = 0 ' paddle right side
pf = 1 ' paddle fraction that gets changed according menu choice easy .75, hard .5
nS = 0 ' number of spinners
score = 0
life = 5 '  (or balls left) only 3 allowed according to wiki
hits = 0 ' bricks busted
obk = 0 ' first orange brick hits bool
rbk = 0 ' first red brick hit bool, when this happens paddle width is cut in half!
speedups = 0 ' count, bump up dy when hits = 4 and 8, then with first orange, then with first red
scrn = 0
 
Dim Shared wc(13, 7), wp(13, 7) 'brick wall colors, brick wall points according to color
' get 448 points clear 1 screen/wall, perfect game is clearing 2 screens/walls
ReDim Shared s(1 To nSpinners) As Object
 
'Menu
initwall
life = 0
my = 0: t = Timer
While life = 0
    drawtable
    Line (.23 * xmax, .14 * ymax)-(.77 * xmax, .81 * ymax), &HFF0000FF, BF
    Line (.24 * xmax, .15 * ymax)-(.76 * xmax, .8 * ymax), &HFF880000, BF
    Line (.245 * xmax, .16 * ymax)-(.755 * xmax, .79 * ymax), &HFFFFFFFF, B
    Color , &HFF880000
    _PrintString (.257 * xmax, .2 * ymax), "Creep Out Menu"
    _PrintString (.44 * xmax, .2 * ymax + 110), "Easy"
    _PrintString (.44 * xmax, .2 * ymax + 180), "Hard"
    _PrintString (.44 * xmax, .2 * ymax + 250), "Quit"
    Color , &HFF000000
    'While _MouseInput: Wend
    'mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
    drawSpinner xmax * .35, .2 * ymax + 75 + my * 70, .5, 0, &HFF006600
    If InKey$ = " " Then
        t = Timer
        my = my + 1
        If my > 3 Then my = 0
    End If
    If Timer - t > 2 And my > 0 Then
        If my = 1 Then
            life = 5: pf = .75
        ElseIf my = 2 Then 'hard
            life = 3: pf = .5
        ElseIf my = 3 Then
            System 'quit
        End If
    End If
    _Limit 40
    _Display
Wend
Color , black
drawtable
initball 'set dx, dy, bx, by ball position and change
updatescore
dMode = 1
While life And _KeyDown(27) = 0
    drawtable
    drawpaddle
    drawball
    handleSpinners
    updatescore
    If hits = 112 And scrn = 0 Then 'setup new
        _SndPlay gong
        _Delay 1
        scrn = 1
        speedups = 0: obk = 0: rbk = 0: pw = 50
        nS = 0
        ReDim s(1 To nSpinners) As Object
        initwall
        drawtable
        initball
    Else
        If hits = 224 Then
            _SndPlay gong
            Color white
            'Text 65, 170, 32, white, "Congratulations on a perfect score!!!"
            _PrintString (35, 175), "Perfect Score!"
            _Delay 3
            Exit While
        End If
    End If
    _Display
    _Limit 20 '< adjust as needed for speed of your system
Wend
If _KeyDown(27) Then System
Color white
'Text 260, 290, 48, white, "Game Over"
centerText 0, xmax, ymax / 2, "Game Over"
_Display
Sleep 5
GoTo restart
 
Sub initwall
    Dim cr As _Unsigned Long
    For r = 0 To 7
        Select Case r
            Case 0, 1: cr = red: p = 7
            Case 2, 3: cr = orange: p = 5
            Case 4, 5: cr = green: p = 3
            Case 6, 7: cr = yellow: p = 1
        End Select
        For c = 0 To 13
            wc(c, r) = cr: wp(c, r) = p
        Next
    Next
End Sub
 
Sub initball 'set ball in play with location and dx, dy
    bx = 350
    by = 280
    dx = rand(1, 4)
    If rand(0, 1) Then dx = -1 * dx
    dy = (3 + speedups) * -1
    px = bx
End Sub
 
Sub drawtable ' in JB don't want to redraw this every loop
    Cls
    For r = 0 To 7
        For c = 0 To 13
            If wp(c, r) Then
                For i = 1 To 10
                    'underneath
                    Color _RGB32(120, 60, 60)
                    Line (c * bkw + i, r * bkh + bkh + i)-(c * bkw + bkw + i, r * bkh + bkh + i)
                    Color silver
                    PSet (c * bkw + i, r * bkh + bkh + i)
                    'ink(white)
                    'sidewall
                    Line (c * bkw + bkw + i, r * bkh + i)-(c * bkw + bkw + i, r * bkh + bkh + i)
                Next
                Color wc(c, r)
                Line (c * bkw, r * bkh)-(c * bkw + bkw, r * bkh + bkh), , BF
                Color white
                Line (c * bkw, r * bkh)-(c * bkw + bkw, r * bkh + bkh), , B
            End If
        Next
    Next
    'Line (0, 300)-(xmax, 490), &HFF000019, BF ' mouse paddle limit
End Sub
 
Sub drawpaddle ' update paddle to mouseY, paddle top and bottom are global
 
    'While _MouseInput: Wend
    'px = _MouseX 'update paddle location
    'If _MouseY >= 300 And _MouseY < 480 Then py = _MouseY
    py = 440
    'If InKey$ = " " Then   ' reverse every time you hit spacebar
    '    dMode = 1 - dMode
    '    _KeyClear
    'End If
    'If dMode Then px = px + 10 Else px = px - 10
    'If px < -pw Then px = -pw
    'If px > xmax + pw Then px = xmax + pw
 
    ' stop reverse stop reverse stop reverse
    If InKey$ = " " Then ' reverse every time you hit spacebar  1 0 -1 0 1 0 -1...
        dMode = dMode + 1
        If dMode = 4 Then dMode = 0
        _KeyClear
    End If
    If dMode = 1 Then px = px - 10
    If dMode = 3 Then px = px + 10
    If px < -pw Then px = -pw + 1
    If px > xmax + pw Then px = xmax + pw - 1
 
    plf = px - pw
    prt = px + pw
    For i = 1 To 10
        Color _RGB32(120, 60, 60)
        Line (px - pw + i, py + 10 + i)-(px + pw + i, py + 10 + i), _RGB32(120, 60, 60)
        Color silver
        'PSet (c * bkw + i, r * bkh + bkh + i)
        'ink(white)
        Line (px + pw + i, py + i)-(px + pw + i, py + 10 + i), silver
    Next
    Line (px - pw, py)-(px + pw, py + 10), &HFFAA5533, BF
End Sub
 
Sub drawball
    'update
    bx = bx + dx
    If bx < br Then dx = dx * -1: bx = br + 1: _SndPlay pop
    If bx > xmax - br Then dx = dx * -1: bx = xmax - br - 1: _SndPlay pop
 
    by = by + dy
    If by + br > py Then 'ball past paddle line
        by = py - br 'don't let ball go into paddle or goal
        If bx + br < plf Or bx - br > prt Then 'paddle miss
            life = life - 1
            _SndPlay uh
            ' if life = 0 then end game
            updatescore
            silverball bx, by
            _Delay 2.5 'reflect on position of ball and loss of life
            CircleFill bx, by, br, black
            initball 'get ball rolling again
        Else 'paddle hit  ' redo according to distance from paddle center
            _SndPlay pop
            dy = dy * -1
            If bx < px Then
                per = .5 * (px - bx) / pw
                dx = dx - 6 * per
            ElseIf bx > px Then
                per = .5 * (bx - px) / pw
                dx = dx + 6 * per
                'Else  dx remains same
            End If
            'dx = dx + rand(-2, 2)
            If dx > 7 Then: dx = 7:
            If dx < -7 Then dx = -7
        End If
    Else
        If by - br < 0 Then 'ball hits back border, reverse direction
            _SndPlay pop
            by = br: dy = dy * -1
        Else
            If by - br < 160 Then 'in wall area, what row and column?
                starthits = hits
                'maybe should check all 4 corners or smaller ball
                row = Int((by - br) / bkh): col = Int((bx - br) / bkw)
                handleBall row, col
                row = Int((by - br) / bkh): col = Int((bx + br) / bkw)
                handleBall row, col
                row = Int((by + br) / bkh): col = Int((bx - br) / bkw)
                handleBall row, col
                row = Int((by + br) / bkh): col = Int((bx + br) / bkw)
                handleBall row, col
                If hits <> starthits Then: dy = dy * -1: 'reverse ball direction
            End If
        End If
    End If
    silverball bx, by
End Sub
 
Sub handleBall (row, col)
    If 0 <= row And row <= 7 And 0 <= col And col <= 13 Then
        If wp(col, row) Then 'brick just hit, lot's to do before update ball
            hits = hits + 1
            sp = rand(0, 3)
            Select Case sp
                Case 0: _SndPlay mush
                Case 1: _SndPlay alive
                Case 2: _SndPlay laser
                Case 3: _SndPlay whistle
            End Select
            nS = nS + 1
            newSpinner nS, col, row
            If hits = 4 Or hits = 8 Or hits = 116 Or hits = 120 Then
                speedups = speedups + 1
                If dy < 0 Then dy = dy - .25 Else dy = dy + .25
            End If
            value = wp(col, row)
            If value = 5 Then 'first orange brick
                If obk = 0 Then 'flag first orange speed increase
                    obk = 1
                    speedups = speedups + 1
                    If dy < 0 Then: dy = dy - .25 Else dy = dy + .25
                End If
            End If
            If value = 7 Then 'flag first red, speed increase paddle decrease! ! ! !
                If rbk = 0 Then
                    rbk = 1
                    speedups = speedups + 1
                    If dy < 0 Then dy = dy - .25 Else: dy = dy + .25
                    pw = pf * pw
                End If
            End If
            score = score + wp(col, row) 'update score with point value
            wp(col, row) = 0 'no points here now
 
 
            'black out box  need this?
            'Line (col * bkw, row * bkh)-(col * bkw + bkw, row * bkh + bkh), black, BF
        End If
    End If
End Sub
 
Sub updatescore
    centerText 0, xmax / 2, 532, "Lives" + Str$(life)
    centerText xmax / 2, xmax, 532, "Score" + Str$(score)
End Sub
 
Sub silverball (x, y)
    For i = 10 To 1 Step -1
        cc = 255 - i * 20
        CircleFill x, y, i, _RGB32(cc, cc, cc)
    Next
End Sub
 
Function rand% (lo%, hi%)
    rand% = Int(Rnd * (hi% - lo% + 1)) + lo%
End Function
 
Sub CircleFill (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
    ' CX = center x coordinate
    ' CY = center y coordinate
    '  R = radius
    '  C = fill color
    Dim Radius As Integer, RadiusError As Integer
    Dim X As Integer, Y As Integer
    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 newSpinner (i As Integer, col, row) 'set Spinners dimensions start angles, color?
    Dim r
    s(i).x = col * bkw + .5 * bkw
    s(i).y = row * bkh + .5 * bkh
    s(i).sz = Rnd * .65 + .1
    If Rnd < .5 Then r = -1 Else r = 1
    s(i).dx = (s(i).sz * Rnd * 6) * r * 2
    s(i).dy = (s(i).sz * Rnd * 6) * r * 2
    r = Rnd * 255
    s(i).c = _RGB32(r, Rnd * .5 * r, Rnd * .25 * r)
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 cRed, Blue, cGreen
    Static switch As Integer
    switch = switch + 2
    switch = switch Mod 16 + 1
    cRed = _Red32(c): cGreen = _Green32(c): Blue = _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(cRed + 20, cGreen + 10, Blue + 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(cRed + 35, cGreen + 17, Blue + 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(cRed + 50, cGreen + 25, Blue + 12)
    Next
    r = r * .5
    fcirc x1, y1, r, _RGB32(cRed - 20, cGreen - 10, Blue - 5)
    x2 = x1 + (r + 1) * Cos(heading - _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading - _Pi(1 / 12))
    fcirc x2, y2, r * .2, &HFFFFAA00
    x2 = x1 + (r + 1) * Cos(heading + _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading + _Pi(1 / 12))
    fcirc x2, y2, r * .2, &HFFFFAA00
    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(cRed, cGreen, Blue)
End Sub
 
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 fcirc (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
    Dim Radius As Integer, RadiusError As Integer
    Dim X As Integer, Y As Integer
    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 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 handleSpinners
    For i = 1 To nS
        If s(i).dead Then
            If s(i).dead < 10 * s(i).sz Then
                explode s(i).x, s(i).y, 20 * s(i).sz, s(i).dead
                s(i).dead = s(i).dead + 1
            End If
        Else
            s(i).x = s(i).x + s(i).dx
            If s(i).x < 0 Or s(i).x > xmax Then s(i).dx = -s(i).dx
            s(i).y = s(i).y + s(i).dy
            If s(i).y < 0 Or s(i).y > xmax Then s(i).dy = -s(i).dy
            If Sqr((bx - s(i).x) ^ 2 + (by - s(i).y) ^ 2) < 1.5 * br Then
                s(i).dead = 1
                explode s(i).x, s(i).y, 20 * s(i).sz, s(i).dead
                _SndPlay crunch
            Else
                drawSpinner s(i).x, s(i).y, s(i).sz, _Atan2(s(i).dy, s(i).dx), s(i).c
            End If
        End If
    Next
End Sub
 
Sub explode (x, y, r, frm)
    maxParticles = r * 40
    For i = 1 To r
        NewDot i, x, y, r
    Next
    rounds = r
    For loopCount = 0 To frm
        If _KeyDown(27) Then End
        For i = 1 To rounds
            dots(i).x = dots(i).x + dots(i).dx
            dots(i).y = dots(i).y + dots(i).dy
            dots(i).dx = dots(i).dx * air_resistance
            dots(i).dy = air_resistance * dots(i).dy
            fcirc dots(i).x, dots(i).y, dots(i).sz / 2, dots(i).c
        Next
        If rounds < maxParticles Then
            For i = 1 To r
                NewDot (rounds + i), x, y, r
            Next
            rounds = rounds + r
        End If
    Next
End Sub
 
Sub NewDot (i, x, y, r)
    angle = _Pi(2 * Rnd)
    rd = Rnd * 30
    dots(i).x = x + rd * Cos(angle)
    dots(i).y = y + rd * Sin(angle)
    dots(i).sz = Rnd * r * .5
    rd = Rnd 'STxAxTIC recommended for rounder spreads
    dots(i).dx = rd * 7 * (7 - dots(i).sz) * Cos(angle)
    dots(i).dy = rd * 7 * (7 - dots(i).sz) * Sin(angle)
    dots(i).c = _RGB32(140 + rd * 80, 70 + rd * 40, 0)
End Sub
 
Sub centerText (x1, x2, midy, s$) ' ' if you want to center fit a string between two goal posts x1, and x2
    _PrintString ((x1 + x2) / 2 - _PrintWidth(s$) / 2, midy - _FontHeight(_Font) / 2), s$
End Sub
 
 

zip contaings great sound effects and Spider font with license.

QB64 Discussion / Big ugly font difference between QB64 v1.4 and QB64 1.5 (and QB64 v2.0)

« on: October 23, 2021, 09:09:18 pm »

I had a calendar making program spaced just right with Windows Font something happened when I went to make calendars for this year using QB64 v2.0, it turns out the Font change occurred in QB64 v1.5 just never caught it because was not working with fonts for awhile.

Something happened that stretches the f o n t a l o n g t h e x - a x i s ??
[ You are not allowed to view this attachment ]

The upper is the look from QB64 v 1.5 and v 2.0

The lower is the look from QB64 v 1.4 (I had changed form arial rounded bold to just arial to make sure it wasn't just the one font acting different.

I also noticed this "spread out look" trying different fonts in the Crypt-O-Gram variations and had to stick with the default because it was spreading out so wide across the screen.

Programs / One Key Screen 0 Halloween Crypt-O-Gram

« on: October 21, 2021, 01:44:45 pm »

Better get this posted before I forget I have it done. This is pure Screen 0, one key, Halloween Theme Crypt-O-Gram Puzzles, no graphics. The Crypto-O-grams are all one liner Halloween jokes. While you solve the puzzle, 2 witches play Infinite Pong with a pumpkin in ASCII Art. Nice music included in zip with other sound effects and ASCII txt files.

.bas Source

Code: QB64: [Select]

Option _Explicit
_Title "One Key Screen 0 Halloween Crypt-O-Gram" ' b+  2021-10-21
 
Const Xmax = 120 ' AKA _Width to allow jokes upto 120 chars long, longest is 110 so far.
Const Ymax = 30 ' AKA _Height some
 
Const Orange = 12
Const White = 15
Const Yellow = 14
Const Back = 8
Const Red = 4
Const Blue = 9
Const Green = 10
Const BB = 6
 
' for Cryptogram game
Dim Shared Answer$ '  beginning phrase to be guessed    '   3 stages of the Puzzle
Dim Shared Coded$ '   hidden in code
Dim Shared Working$ ' decoded and solved when working$ becomes = ucase$(answer$)
Dim Shared Letters$(1 To 26) ' for coding and highlited letters
Dim Shared LCodes$(1 To 26) '  for code and decode by number 1 to 26
Dim Shared Guesses$(1 To 26) ' track all the guess to decode
Dim Shared HighLited ' cursor over letters to guess
Dim Shared Mode ' what are we getting a coded letter =0, a guess for that letter =1, a letter to find and decode=3
Dim Shared KeyTimer ' setup for Choice$ calls
Dim Shared Place ' ditto tracks highlight location from selections
 
'txt image
Dim Shared WitchE(1 To 7) As String * 12
Dim Shared WitchW(1 To 7) As String * 12
LoadWitches
 
' main declares
Dim jokes$(1 To 100) ' load jokes one time from data statements in program
Dim As Integer i, jCount, a, test, nSplash
Dim r$, k$, c$
Dim HH&, SW&, WH&, ZB& ' sound and font
Dim As Integer pl, pr, pt, pb, px, py, pdx, pdy, weCol, wwCol ' the pumkin as a ball
Dim loopcnt As _Unsigned _Integer64
 
' load sounds
HH& = _SndOpen("happy-halloween-scary-creepy-music-1382.mp3")
SW& = _SndOpen("smich.wav")
WH& = _SndOpen("Wolves Howling.wav")
ZB& = _SndOpen("Zen Bell.wav")
 
Randomize Timer
Width Xmax, Ymax
_FullScreen 'I guess it does make it easier to tell E from F...
_PaletteColor 12, _RGB32(255, 128, 0) ' Orange
_PaletteColor 13, _RGB32(180, 90, 45) ' for rColors
For i = 1 To 100 'ready jokes
    Read r$
    If r$ <> "EOD" Then jokes$(i) = r$: jCount = jCount + 1 Else Exit For
Next
 
'set pumpkin as ball boundaries
pl = 19: pr = _Width - 18: pt = 1: pb = 16
Splash nSplash
 
restart:
px = 19: py = 8: weCol = 5: wwCol = _Width - 15: pdx = 1: pdy = -1
 
'setup Puzzle and code it
Answer$ = jokes$(Int(Rnd * jCount) + 1)
For i = 1 To 26: Guesses$(i) = "-": Next 'setup the display guesses array
For i = 1 To 26 ' use letters for display of letters to pick second and to create a code
    Letters$(i) = Chr$(i + 64)
    LCodes$(i) = Letters$(i) ' these will convert between each other by index number
Next
For i = 26 To 2 Step -1 ' shuffle the letters in LCode$()
    Swap LCodes$(i), LCodes$(Int(Rnd * i) + 1)
Next
Coded$ = "": Working$ = "" ' reset for next go around
For i = 1 To Len(Answer$) 'third: put the phrase in coded$ and hide it in working$
    a = Asc(UCase$(Answer$), i)
    If a >= 65 And a <= 90 Then
        Coded$ = Coded$ + LCodes$(a - 64)
        Working$ = Working$ + "*"
    Else
        Coded$ = Coded$ + Mid$(Answer$, i, 1)
        Working$ = Working$ + Mid$(Answer$, i, 1)
    End If
Next
 
HighLited = 1: Mode = 0: KeyTimer = Timer
_SndLoop HH& '          setup done start game
loopcnt = 0
Do
    Color Orange, Back: Cls
    DisplayInstructions
    Update
    If Rnd < .0005 Then _SndPlay WH&
    If Rnd < .0005 Then _SndPlay SW&
    If Mode = 3 Then
        k$ = Choice$(25, 33, " A B C D E F G H I J K L M N O P Q R S T U V W X Y Z ")
    Else
        k$ = Choice$(25, 29, " 1 2 3 4 A B C D E F G H I J K L M N O P Q R S T U V W X Y Z ")
    End If
    If k$ <> "" And k$ <> " " Then
        If Mode = 0 Then ' highlight a letter
            'm replaces arrows and mouse select of highlited 1 to 26 for letters
            test = InStr("ABCDEFGHIJKLMNOPQRSTUVWXYZ", k$)
            If test > 0 Then
                HighLited = test
                Mode = 1
            Else
                test = InStr("1234", k$)
                If test > 0 Then
                    Select Case test
                        Case 1: GoSub do1
                        Case 2: GoSub do2
                        Case 3: Mode = 3
                        Case 4: GoSub do4
                    End Select
                Else
                    Mode = 0
                End If
            End If
        ElseIf Mode = 1 Then
            Select Case Asc(k$)
                Case 49: GoSub do1
                Case 50: GoSub do2
                Case 51: Mode = 3
                Case 52: GoSub do4
                Case 65 TO 90
                    Guesses$(HighLited) = k$ ' for screen updates
                    For i = 1 To Len(Working$)
                        If Letters$(HighLited) = Mid$(Coded$, i, 1) Then Mid$(Working$, i, 1) = k$
                    Next
                    Mode = 0
            End Select
        ElseIf Mode = 3 Then
            Locate 25, 44: Print Space$(31); ' clear out old line
            c$ = LCodes$(Asc(k$) - 64)
            Guesses$(Asc(c$) - 64) = k$
            For i = 1 To Len(Working$)
                If c$ = Mid$(Coded$, i, 1) Then Mid$(Working$, i, 1) = k$
            Next
            Mode = 0
        End If
    End If
    loopcnt = loopcnt + 1
    If loopcnt Mod 5 = 0 Then ' move pumpkin
        If px + pdx >= pl And px + pdx <= pr Then
            px = px + pdx
        Else
            pdx = -pdx
            px = px + pdx
        End If
        If py + pdy >= pt And py + pdy <= pb Then
            py = py + pdy
        Else
            pdy = -pdy
            py = py + pdy
        End If
    End If
    DrawWitch "e", py - 4, weCol
    DrawWitch "w", py - 4, wwCol
    DrawPumpkin py, px
    _Limit 30
    _Display
Loop Until Working$ = UCase$(Answer$)
_SndStop HH&
_SndPlay ZB&
Update
Color Orange, Back
CP 19, "You got it!    5 secs to next puzzle..."
_Display
_Delay 5: Cls
nSplash = nSplash + 1
If nSplash > 10 Then nSplash = 0
Splash nSplash
GoTo restart
 
do1: ' display answer
Working$ = UCase$(Answer$) ' show the answer$ guesses correct moves to next puzzle
Mode = 0
Return
 
do2: ' get decode letter for highlighted Letter
For i = 1 To 26
    If LCodes$(i) = Letters$(HighLited) Then c$ = Chr$(i + 64): Exit For
Next
Guesses$(HighLited) = c$ ' for screen updates
For i = 1 To Len(Working$)
    If Letters$(HighLited) = Mid$(Coded$, i, 1) Then Mid$(Working$, i, 1) = c$
Next
Mode = 0
Return
 
do4: ' clear guess letter from code letter
Guesses$(HighLited) = "-"
For i = 1 To Len(Working$)
    If Letters$(HighLited) = Mid$(Coded$, i, 1) Then Mid$(Working$, i, 1) = "*" ' clear the letter
Next
Mode = 0
Return
 
'one liners
Data "Why do ghosts go on diets? So they can keep their ghoulish figures"
Data "Where does a ghost go on vacation? Mali-boo."
Data "Why did the ghost go into the bar? For the Boos."
Data "What is in a ghost's nose? Boo-gers."
Data "Why did the policeman ticket the ghost on Halloween? It didn't have a haunting license."
Data "Why do demons and ghouls hang out together? Because demons are a ghoul's best friend!"
Data "Why did the ghost starch his sheet? He wanted everyone scared stiff."
Data "What does a panda ghost eat? Bam-BOO!"
Data "What's a ghost's favorite dessert? I-Scream!"
Data "Where do ghosts buy their food? At the ghost-ery store!"
Data "How do you know when a ghost is sad? He starts boo hooing."
Data "Why don't mummies take time off? They're afraid to unwind."
Data "Why did the headless horseman go into business? He wanted to get ahead in life."
Data "What kind of music do mummies like listening to on Halloween? Wrap music."
Data "Why don't mummies have friends? Because they're too wrapped up in themselves."
Data "Why did the vampire read the newspaper? He heard it had great circulation."
Data "How do vampires get around on Halloween? On blood vessels."
Data "What's it like to be kissed by a vampire? It's a pain in the neck."
Data "What's it called when a vampire has trouble with his house? A grave problem."
Data "How can you tell when a vampire has been in a bakery? All the jelly has been sucked out of the jelly doughnuts."
Data "What do you get when you cross a vampire and a snowman? Frostbite."
Data "Why do skeletons have low self-esteem? They have no body to love."
Data "Know why skeletons are so calm? Because nothing gets under their skin."
Data "What do you call a cleaning skeleton? The grim sweeper."
Data "What do skeletons order at a restaurant? Spare ribs."
Data "What do you call a witch's garage? A broom closet."
Data "What kind of food would you find on a haunted beach? A sand-witch!"
Data "What was the witch's favorite subject in school? Spelling."
Data "What do you call two witches who live together? Broom-mates!"
Data "What's a witch's favorite makeup? Ma-scare-a."
Data "Who helps the little pumpkins cross the road safely? The crossing gourd."
Data "What treat do eye doctors give out on Halloween? Candy corneas."
Data "What type of plants do well on all Hallow's Eve? Bam-BOO!"
Data "What do birds say on Halloween? Trick or tweet!"
Data "Why don't skeletons ever go trick or treating? Because they have no-body to go with."
Data "Where do ghosts buy their Halloween candy? At the ghost-ery store!"
Data "What do owls say when they go trick or treating? 'Happy Owl-ween!'"
Data "What do ghosts give out to trick or treaters? Booberries!"
Data "Who did Frankenstein go trick or treating with? His ghoul friend."
Data "What Halloween candy is never on time for the party? Choco-LATE!"
Data "What do witches put on to go trick or treating? Mas-scare-a."
Data "What does Bigfoot say when he asks for candy?  'Trick-or-feet!'"
Data "Which type of pants do ghosts wear to trick or treat? Boo jeans."
Data "What makes trick or treating with twin witches so challenging? You never know which witch is which!"
Data "What happens when a vampire goes in the snow? Frost bite!"
Data "What do you call two witches living together? Broommates"
Data "What position does a ghost play in hockey? Ghoulie."
Data "What do mummies listen to on Halloween? Wrap music."
Data "How do you make a skeleton laugh? You tickle his funny bone!"
Data "Which Halloween monster is good at math? Count Dracula!"
Data "Why did the Cyclops give up teaching? He only had one pupil!"
Data "Why didn't the skeleton go to see a scary movie? He didn't have the guts."
Data "What did the boy ghost say to the girl ghost? 'You sure are boo-tiful!'"
Data "Where does Dracula keep his money? In a blood bank."
Data "Why are ghosts terrible liars? You can see right through them!"
Data "Why don't mummies take vacations? They're afraid to unwind."
Data "What is a vampire's favorite holiday, besides Halloween? Fangs-giving!"
Data "Where do fashionable ghosts shop? Bootiques!"
Data "What's a monster's favorite play? Romeo and Ghouliet!"
Data "What room does a ghost not need? A living room."
Data "What monster plays tricks on Halloween? Prank-enstein!"
Data "What's a ghost's favorite dessert? I scream."
Data "What does the skeleton chef say when he serves you a meal? 'Bone Appetit!'"
Data "What is a vampire's favorite fruit? A neck-tarine!"
Data "What do witches put on their bagels? Scream cheese."
Data "What do ghosts eat for dinner? Spook-ghetti!"
Data "What do skeletons order at restaurants? Spare ribs."
Data "What does a panda ghost eat? Bam-BOO!"
Data "What tops off a mummy's ice cream sundae? Whipped scream."
Data "What's a ghost's favorite yogurt flavor? Boo-berry!"
Data "What's a vampire's least favorite meal? A steak!"
Data "Why was the candy corn booed off the stage? All of his jokes were too corny!"
Data "What happened to the cannibal who showed up late to Halloween dinner? They gave him the cold shoulder."
Data "What happens if you combine a vampire and a snowman? You get frostbite."
Data "Do zombies eat popcorn with their fingers? No, they like to eat the fingers separately."
Data "What happened to the man who got behind on payments to his exorcist? He got repossessed."
Data "Where do most ghouls and goblins live in 2019? In North and South Scarolina."
Data "Why did the team of witches lose the softball game? Their bats kept flying away."
Data "What do you call six witches in a jacuzzi? A self cleaning coven."
Data "Why was the vampire in a bad mood? Too much B negative."
Data "What did the parent say to the baby ghost? Don't spook until your spoken too."
Data "What is a vampire's favorite flavor of ice cream? Veinilla."
Data "What are two freshly married spiders called? Newly-webbed."
Data "Why hasn't anyone ever seen ghost poop? Because it's invisible."
Data "You know it's bad luck to be followed by a black cat… if you are a mouse."
Data "Where do most most werewolves live in 2019? Howlywood California."
Data "Why don't witches have babies? Their husbands have crystal balls."
Data "Why can't the ghost have any children? He has a Halloweenie."
Data "EOD"
 
Sub Update ' preserve from ravages of graphics effects ;-))
    Dim As Integer i, spaces
    Dim w$, c$, a$, h$, pc$
    Color Yellow, Back
    Locate 17, (120 - Len(Answer$)) / 2: Print Coded$;
    Color White, Back
    Locate 18, (120 - Len(Answer$)) / 2
    For i = 1 To Len(Answer$)
        w$ = Mid$(Working$, i, 1): c$ = Mid$(Coded$, i, 1)
        a$ = Mid$(Answer$, i, 1): h$ = Letters$(HighLited)
        If w$ = "*" Then
            pc$ = "*": If h$ = c$ Then Color White, Green Else Color White, Back
        Else
            Color White, Back
            If w$ = UCase$(a$) Then pc$ = a$ Else pc$ = w$
        End If
        Print pc$;
    Next
    spaces = 9
    For i = 1 To 26 'blue background highlighter
        If i = HighLited Then
            Color Yellow, Green
        Else
            Color Yellow, Back
        End If
        Locate 21, spaces: Print Letters$(i);
        If i = HighLited Then
            Color Yellow, Green
        Else
            Color White, Back
        End If
        Locate 22, spaces: Print Guesses$(i);
        spaces = spaces + 4
    Next
    If Mode = 1 Then
        Color White, Back
        CP 24, "  Guess Solve Letter or Menu # "
    ElseIf Mode = 0 Then
        Color Yellow, Back
        CP 24, "  Select Code Letter or Menu # "
    ElseIf Mode = 3 Then
        Color White, Back
        CP 24, "     Select Letter to Find     "
    End If
End Sub
 
Sub DisplayInstructions
    Dim c As Integer
    Color Orange, Back
    CP 4, "*** Halloween Challenge - Crypt-O-Gram Puzzle ***"
    'Color Red
    CPRC 7, "Solve puzzle by selecting a Code letter then selecting a Guess letter for it."
    CPRC 8, "All selections are made by pressing the spacebar until you are on your choice."
    CPRC 9, "Use the escape key to quit immediately."
    'Color 2
    c = 34
    LPRC 11, c, "Select 1 to get the answer and move onto next puzzle."
    LPRC 12, c, "Select 2 to decode current highlighted letter."
    LPRC 13, c, "Select 3 to solve a letter, then select letter to find."
    LPRC 14, c, "Select 4 to clear a guess at highlighted Code letter."
End Sub
 
 
Sub CP (row, s$) ' center text on text screen
    Locate row, (_Width - Len(s$)) / 2: Print s$;
End Sub
 
Sub CPRC (row, s$) ' center text on text screen and print in random colors
    Dim As Integer i, col
    col = (_Width - Len(s$)) / 2
    For i = 1 To Len(s$)
        Color rColor, Back
        Locate row, col + i - 1: Print Mid$(s$, i, 1);
    Next
End Sub
 
Sub LP (row, col, s$) ' Locate and Print
    Locate row, col: Print s$;
End Sub
 
Sub LPRC (row, col, s$) ' Locate and print with Random colors
    Dim i As Integer
    For i = 1 To Len(s$)
        Color rColor, Back
        Locate row, col + i - 1: Print Mid$(s$, i, 1);
    Next
End Sub
 
Function Choice$ (row, col, selection$)
    Dim As _Unsigned Long fg, bg
    Dim As Integer saveRow, saveCol, i
    Dim k&
    fg~& = _DefaultColor: bg~& = _BackgroundColor
    saveRow = CsrLin: saveCol = Pos(0)
    If _KeyDown(27) Then System ' emergency exit
    GoSub show:
    k& = _KeyHit
    If k& = 32 Then KeyTimer = Timer: Place = (Place + 1) Mod Len(selection$)
    If Timer - KeyTimer >= 3 Then Choice$ = Mid$(selection$, Place + 1, 1): Place = 0
    Locate saveRow, saveCol: Exit Function
 
    show:
    Locate row, col
    For i = 1 To Len(selection$)
        If i = Place + 1 Then Color bg~&, fg~& Else Color fg~&, bg~&
        Locate row, col - 1 + i: Print Mid$(selection$, i, 1);
    Next
    '_Display will take place in loop that called Choice$
    Color fg~&, bg~&
    Return
End Function
 
Function rColor%
    Dim rc
    rc = Rnd
    If rc > .66 Then
        rColor% = 4
    ElseIf rc > .33 Then
        rColor% = 13
    ElseIf rc > .16 Then
        rColor% = 2
    ElseIf rc > .08 Then
        rColor% = 6
    Else
        rColor% = 12
    End If
End Function
 
Sub Splash (n As Integer)
    Dim As Integer i, first, last, nlines, startRow
    Dim s$
    Color 12, Back: Cls
 
    If n = 0 Then
        Open "ASCII by snd.txt" For Input As #1
        For i = 1 To 20
            Line Input #1, s$
            LP i + 5, 41, RTrim$(s$)
        Next
        Close #1
    ElseIf n > 0 Then
        Open "10 Halloweens.txt" For Input As #1
        If n = 1 Then
            first = 11: last = 32: GoSub getText
        ElseIf n = 2 Then
            first = 32: last = 46: GoSub getText
        ElseIf n = 3 Then
            first = 46: last = 57: GoSub getText
        ElseIf n = 4 Then
            first = 57: last = 75: GoSub getText
        ElseIf n = 5 Then
            first = 75: last = 100: GoSub getText
        ElseIf n = 6 Then
            first = 100: last = 111: GoSub getText
        ElseIf n = 7 Then
            first = 111: last = 130: GoSub getText
        ElseIf n = 8 Then
            first = 131: last = 159: GoSub getText
        ElseIf n = 9 Then
            first = 159: last = 180: GoSub getText
        ElseIf n = 10 Then
            first = 180: last = 193: GoSub getText
        End If
    End If
    CP 29, "... Spacebar Only! ..."
    _Display
    _KeyClear
    While _KeyHit <> 32: Wend
    Exit Sub
 
    getText:
    nlines = last - first
    startRow = Int((30 - nlines) / 2)
    For i = 1 To 193
        Line Input #1, s$
        If i >= first And i <= last Then LP i - first + startRow + 1, 25, RTrim$(s$)
        If i > last Then Exit For
    Next
    Close #1
    Return
End Sub
 
Sub LoadWitches
    Dim w, i, s$
    For w = 1 To 2
        If w = 1 Then Open "witchE.txt" For Input As #1 Else Open "witchW.txt" For Input As #1
        For i = 1 To 7
            Line Input #1, s$
            If w = 1 Then WitchE(i) = s$ Else WitchW(i) = s$
        Next
        Close #1
    Next
End Sub
 
Sub DrawWitch (WhichWitch$, row, col) ' 7 lines 12 cols  set color
    Dim r, c
    Color 5, Back
    For r = 1 To 7
        If row + r - 1 > 0 And row + r - 1 <= _Height Then
            For c = 1 To 12
                If col + c - 1 > 0 And col + c - 1 <= _Width Then
                    If UCase$(WhichWitch$) = "E" Then
                        If Mid$(WitchE(r), c, 1) <> " " Then LP row + r - 1, col + c - 1, Mid$(WitchE(r), c, 1)
                    Else
                        Color 7
                        If Mid$(WitchW(r), c, 1) <> " " Then LP row + r - 1, col + c - 1, Mid$(WitchW(r), c, 1)
                    End If
                End If
            Next
        End If
    Next
End Sub
 
Sub DrawPumpkin (row, col) ' mid pumkin
    Dim p$, r, c
    Color 12, Back
    p$ = "((|))"
    For r = -1 To 0
        If row + r > 0 And row + r <= _Height Then
            For c = -2 To 2
                If col + c > 0 And col + c <= _Width Then
                    If r = -1 And c = 0 Then
                        LP row + r, col, ","
                    ElseIf r = 0 Then
                        LP row + r, col + c, Mid$(p$, c + 3, 1)
                    End If
                End If
            Next
        End If
    Next
End Sub
 

One Key Screen 0 Halloween Crypt-O-Gram.PNG

Programs / One Key Connect 4 (8x8) Halloween Style

« on: October 19, 2021, 08:09:18 pm »

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

Code: QB64: [Select]

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 ' for pumpkin recursion shifty eyes
Dim place, k$, t, r, s$, pr, d
 
Screen _NewImage(SW, SH, 32)
_ScreenMove 360, 60
 
_Title "One Key Connect 4 (8x8) Halloween Style"
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, &HFF000000:
    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 - 6) / 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 > 4 And place <> -1 Then ' col selected
                r = GetOpenRow(place)
                If r <> NumRows Then
                    Grid(place, r) = P: Turn = AI: PlayerLastMoveCol = place: PlayerLastMoveRow = r: MoveNum = MoveNum + 1
                    place = -1 ' reset back to hold area
                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, 0
        _PrintString (XO, YO - SQ - 16), s$
    End If
    pumpkin 0, place * SQ + XO + SQ / 2, SQ + SQ / 2, pr, 2
    sx = Rnd * 6 - 3
    _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!
            Beep: Locate 4, 2: Print "AI has failed to find a proper move, press any to end..."
            Sleep ' <<< pause until user presses a key
            End
        End If
    End If
End Sub
 
Function GetOpenRow (forCol)
    Dim i
    GetOpenRow = NumRows 'assume none open
    If forCol < 0 Or forCol > NCM1 Then Exit Function
    For i = NRM1 To 0 Step -1
        If Grid(forCol, i) = 0 Then GetOpenRow = i: Exit Function
    Next
End Function
 
Function Stupid (c, r)
    Dim pr
    Grid(c, r) = AI
    pr = GetOpenRow(c)
    If pr <> NumRows Then
        Grid(c, pr) = P
        If CheckWin = 4 Then Stupid = -1
        Grid(c, pr) = 0
    End If
    Grid(c, r) = 0
End Function
 
Function GR (c, r) ' if c, r are out of bounds returns N else returns grid(c, r)
    ' need to check the grid(c, r) but only if c, r is on the board
    If c < 0 Or c > NCM1 Or r < 0 Or r > NRM1 Then GR = NumRows Else GR = Grid(c, r)
End Function
 
Sub ShowGrid
    Static lastMoveNum
    Dim i, r, c, check, s$, k$
    If MoveNum <> lastMoveNum Then ' file newest move
        If MoveNum = 1 Then ReDim Record$(NCM1, NRM1)
        If Turn = -1 Then
            Record$(PlayerLastMoveCol, PlayerLastMoveRow) = _Trim$(Str$(MoveNum)) + " " + "P"
        Else
            Record$(AIX, AIY) = _Trim$(Str$(MoveNum)) + " " + "A"
        End If
        lastMoveNum = MoveNum
    End If
    'cls
    Line (XO, YO)-Step(NumCols * SQ, NumRows * SQ), &HFF004400, BF
    For i = 0 To NumCols 'grid
        Line (SQ * i + XO, YO)-Step(0, NumRows * SQ), &HFFFFFFFF
    Next
    For i = 0 To NumRows
        Line (XO, SQ * i + YO)-Step(NumCols * SQ, 0), &HFFFFFFFF
    Next
    For r = NRM1 To 0 Step -1 ''in grid rows are reversed 0 is top row
        For c = 0 To NCM1
            If Grid(c, r) = P Then
                Line (c * SQ + XO + 3, r * SQ + YO + 3)-Step(SQ - 6, SQ - 6), &HFF000000, BF
                pumpkin 0, c * SQ + XO + SQ / 2, r * SQ + YO + SQ / 2, (SQ - 6) / 2, 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
                Else
                    Line (c * SQ + XO + 3, r * SQ + YO + 3)-Step(SQ - 6, SQ - 6), &HFF4444FF, BF
                End If
                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)
            End If
            s$ = _Trim$(Str$(Scores(c)))
            _PrintString (XO + c * SQ + (60 - Len(s$) * 8) / 2, YO + SQ * NumRows + 22), s$
        Next
    Next
    '_Display
    check = CheckWin
    If check Then 'report end of round ad see if want to play again
        If check = 4 Or check = -4 Then
            For i = 0 To 3
                Line ((WinX + i * DX(WinD)) * SQ + XO + 5, (WinY + i * DY(WinD)) * SQ + YO + 5)-Step(SQ - 10, SQ - 10), &HFFFFFF00, B
            Next
        End If
        For r = 0 To NRM1
            For c = 0 To NCM1
                If Record$(c, r) <> "" Then
                    s$ = Mid$(Record$(c, r), 1, InStr(Record$(c, r), " ") - 1)
                    If Right$(Record$(c, r), 1) = "A" Then Color &HFFFFFFFF, &HFF000000 Else Color &HFFFFFFFF, &HFF000000
                    _PrintString (SQ * c + XO + (SQ - Len(s$) * 8) / 2, SQ * r + YO + 22), s$
                End If
            Next
            Color , &HFF000000
        Next
        If check = -4 Then
            s$ = " AI is Winner!"
        ElseIf check = 4 Then
            s$ = " Human is Winner!"
        ElseIf check = NumRows Then
            s$ = " Board is full, no winner." ' keep Turn the same
        End If
        Locate 2, ((SW - Len(s$) * 8) / 2) / 8: Print s$
        s$ = " Play again? press spacebar, escape to quit... "
        Locate 4, ((SW - Len(s$) * 8) / 2) / 8: Print s$
        _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
 
 

Attached is Source and .exe for Windows (no assets program)

One Key Connect 4 (8x8) Halloween Style.PNG

QB64 Discussion / On Clearing a STATIC array

« on: October 07, 2021, 04:09:14 pm »

Should Erase work for clearing values in a STATIC array? I tried it here
https://www.qb64.org/forum/index.php?topic=4266.msg136545#msg136545

Got errors, so I ended up doing it the hard way ie, resetting each and every value back to 0 in 2 index For loops for 2D arrays. I am wondering if I just screwed up with Erase.

Programs / DrawWorms code test and demo

« on: October 07, 2021, 11:59:19 am »

This is graphics effect test and demo, I am hoping to add to Crypt-O-Gram Puzzle.

All White and Yellow colors are poison to worms, still they will nibble because where ever they go they lay down a black track on the screen.

If the program hangs just press esc, there is a problem sometimes that hangs often at start new WormYard init.

Should be fun to watch, the first test makes sure worms stay in WormYard and that White really discourages worms from proceeding further in their current direction that ran into White. ha! sometimes a white box is laid over worm and then it's trapped (but could hang program? not being able to find direction to go).

Code: QB64: [Select]

sc& = _ScreenImage
_Title "DrawWorms Test and Demo, worms should avoid Yellow and White" 'b+ 2021-10-06
' This is intended for Crypt-O-Gram Puzzle but may use else where also.
' This needs to be done in background on the side and updated with main loop in program using it.
 
' Use general Object
Type object
    x As Single
    y As Single
    w As Single
    h As Single
    dx As Single
    dy As Single
    dir As Single
    sz As Single
    c As _Unsigned Long
End Type
 
Const nWorms = 30
Const xmax = 800, ymax = 600
Dim Shared Worms(1 To nWorms) As object
Dim Shared WormYard As object
Screen _NewImage(xmax, ymax, 32)
_Delay .25
_ScreenMove _Middle
Color &HFFDDDDDD, &HFF442211
Cls 'set backcolor
NewWormYard _Width / 4, _Height / 4, _Width / 2, _Height / 2 ' for this demo the middle of the screen
init = -1
Do
    'sample main loop action
    lc = lc + 1
    If lc Mod 200 = 199 Then init = -1: Cls
    Locate 1, 1: Print lc
    If Rnd < .5 Then c~& = _RGB32(255, 255, 255) Else c~& = _RGB32(255, 0, 0)
    Line (Rnd * _Width, Rnd * _Height)-Step(Rnd * 50, Rnd * 50), c~&, BF
    DrawWorms init
    _Limit 10
Loop Until _KeyDown(27)
 
Screen _NewImage(_DesktopWidth, _DesktopHeight, 32)
_Delay .25
'_ScreenMove _Middle
_FullScreen
_PutImage , sc&, 0
' end perfect
_Delay .25 ' <<<< possible racing problem with change of screen size and _width adn Height update
NewWormYard 0, 0, _Width, _Height ' <<< update WornYard to new screen size
_PutImage , sc&, 0
init = -1 'only way to see sc& ??????????????/
Do
    DrawWorms init
    _Limit 10
Loop Until _KeyDown(27)
 
Sub DrawWorms (DrawReset) ' one frame in main loop
    Static x(1 To nWorms, 1 To 20), y(1 To nWorms, 1 To 20)
    If DrawReset Then
        For i = 1 To nWorms
            NewWorm i
            For j = 1 To 20
                x(i, j) = 0: y(i, j) = 0
            Next
        Next
        DrawReset = 0
    End If
    For i = 1 To nWorms
        If _KeyDown(27) Then Exit Sub
        For j = 1 To Worms(i).sz ' blackout old segments
            If x(i, j) And y(i, j) Then fcirc x(i, j), y(i, j), 8, &HFF000000
        Next
        tryAgain:
        If _KeyDown(27) Then Exit Sub
        If Rnd < .3 Then Worms(i).dx = Worms(i).dx + .8 * Rnd - .4 Else Worms(i).dy = Worms(i).dy + .8 * Rnd - .4
        If Abs(Worms(i).dx) > 2 Then Worms(i).dx = Worms(i).dx * .5
        If Abs(Worms(i).dy) > 2 Then Worms(i).dy = Worms(i).dy * .5
        x = Worms(i).x + Worms(i).dx * 2.0: y = Worms(i).y + Worms(i).dy * 2.0
        good = -1
        If x >= WormYard.x + 6 And x <= WormYard.x + WormYard.w - 6 Then
            If y >= WormYard.y + 6 And y <= WormYard.y + WormYard.h - 6 Then
                For yy = y - 6 To y + 6
                    For xx = x - 6 To x + 6
                        If Point(xx, yy) = _RGB32(255, 255, 255) Or Point(xx, yy) = _RGB32(255, 255, 0) Then good = 0: Exit For
                    Next
                    If good = 0 Then Exit For
                Next
            Else
                good = 0
            End If
        Else
            good = 0
        End If
        If good = 0 Then 'turn the worm
            'Beep: Locate 1, 1: Print x, y
            'Input "enter >", w$
            If Rnd > .5 Then 'change dx
                If Worms(i).dx Then
                    Worms(i).dx = -Worms(i).dx
                Else
                    If Rnd > .5 Then Worms(i).dx = 1 Else Worms(i).dx = -1
                End If
            Else
                If Worms(i).dy Then
                    Worms(i).dy = -Worms(i).dy
                Else
                    If Rnd > .5 Then Worms(i).dy = 1 Else Worms(i).dy = -1
                End If
            End If
            GoTo tryAgain
        End If
        For j = Worms(i).sz To 2 Step -1
            x(i, j) = x(i, j - 1): y(i, j) = y(i, j - 1)
            If x(i, j) And y(i, j) Then drawBall x(i, j), y(i, j), 6, Worms(i).c
        Next
        x(i, 1) = x: y(i, 1) = y
        drawBall x(i, 1), y(i, 1), 6, Worms(i).c
        Worms(i).x = x: Worms(i).y = y
    Next i 'worm index
End Sub
 
Sub NewWormYard (x, y, w, h)
    WormYard.x = x: WormYard.y = y: WormYard.w = w: WormYard.h = h
    For i = 1 To nWorms
        NewWorm i
    Next
End Sub
 
Sub NewWorm (i)
    'pick which side to enter, for dx, dy generally headed towards inner screen
    side = Int(Rnd * 4)
    Select Case side
        Case 0 ' left side
            Worms(i).x = WormYard.x + 6
            Worms(i).y = WormYard.y + 6 + (WormYard.h - 12) * Rnd
            Worms(i).dx = 1
            Worms(i).dy = 0
        Case 1 'right side
            Worms(i).x = WormYard.x + WormYard.w - 6
            Worms(i).y = WormYard.y + 6 + (WormYard.h - 12) * Rnd
            Worms(i).dx = -1
            Worms(i).dy = 0
        Case 2 ' top
            Worms(i).y = WormYard.y + 6
            Worms(i).x = WormYard.x + 6 + (WormYard.w - 12) * Rnd
            Worms(i).dx = 0
            Worms(i).dy = 1
        Case 3 'bottom
            Worms(i).y = WormYard.y + WormYard.h - 6
            Worms(i).x = WormYard.x + 6 + (WormYard.w - 12) * Rnd
            Worms(i).dx = 0
            Worms(i).dy = -1
    End Select
    Worms(i).sz = Int(Rnd * 11) + 10
    side = Int(Rnd * 4): lev = Int(Rnd * 10)
    If side = 0 Then
        Worms(i).c = _RGB32(255 - 20 * lev + 50, 180 - 15 * lev, 180 - 15 * lev)
    ElseIf side = 1 Then
        Worms(i).c = _RGB32(255 - 20 * lev, 180 - 15 * lev + 50, 180 - 15 * lev)
    ElseIf side = 2 Then
        Worms(i).c = _RGB32(255 - 20 * lev, 180 - 15 * lev, 180 - 15 * lev + 20)
    ElseIf side = 3 Then
        Worms(i).c = _RGB32(255 - 20 * lev, 180 - 15 * lev, 180 - 15 * lev)
    End If
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 drawBall (x, y, r, c As _Unsigned Long)
    Dim rred As Long, grn As Long, blu As Long, rr As Long, f
    rred = _Red32(c): grn = _Green32(c): blu = _Blue32(c)
    For rr = r To 0 Step -1
        f = 1.25 - rr / r
        fcirc x, y, rr, _RGB32(rred * f, grn * f, blu * f)
    Next
End Sub
 
 

Oh! I should lay down a black circle for first x,y of newly init worm!

Programs / Fade In & Out Tests

« on: October 05, 2021, 01:51:13 am »

I have 3 ideas I'm testing for an effect of having a background image over which I want to Fade In and then Fade Out a Loaded Image.

Here is what @Cobalt suggested, I probably did something wrong in applying the procedure but don't know what:

Code: QB64: [Select]

_Title "Fade In-Out Tests Cobalts suggestion" 'b+ 2021-10-04
' Steve suggest: _SetAlpha alphaLevel255& [, color1&][ TO color2&] [, iHdl&]
' bplus idea random fill overlapping at low to middle transparencey using Point probably very lumpy image
Screen _NewImage(120 * 8, 30 * 16, 32) ' current screen size for Halloween Crypt-O-Gram
fio& = _LoadImage("haunted heads.jpg", 32)
'_PutImage , fio&, 0 ' OK image works
 
' make sample image
snap& = _NewImage(_Width, _Height, 32)
Cls
For i = 1 To _Width * _Height * .00035
    Line (Rnd * _Width, Rnd * _Height)-Step(Rnd * 50, Rnd * 50), _RGB32(Rnd * 255, Rnd * 255, Rnd * 255, Rnd * 255), BF
Next
_PutImage , 0, snap&
_Delay 2
 
'  Test Cobalt's suggestion
Dim Shared Layer(0 To 100) As Long ' <<<< Cobalt didn't mention this
'Layer(0) = snap&  ' <<<<  un comment and just get background, comment and get back ground then only fade in of heads
Fade_In fio& ' where's my background image???
 
 
' Fade_In, Fade_Out, DarkenImage From Cobalt 2021-10-04  https://www.qb64.org/forum/index.php?topic=4254.msg136319#msg136319
Sub Fade_Out (L&)
    For n! = 1 To 0.00 Step -0.05
        i2& = _CopyImage(L&)
        DarkenImage i2&, n!
        _PutImage (0, 0), i2&, Layer(0)
        _FreeImage i2&
        _Delay .06
    Next
End Sub
 
Sub Fade_In (L&)
    For n! = 0.01 To 1 Step 0.05
        i2& = _CopyImage(L&)
        DarkenImage i2&, n!
        _PutImage (0, 0), i2&, Layer(0)
        _FreeImage i2&
        _Delay .06
    Next
End Sub
 
Sub DarkenImage (Image As Long, Value_From_0_To_1 As Single)
    If Value_From_0_To_1 <= 0 Or Value_From_0_To_1 >= 1 Or _PixelSize(Image) <> 4 Then Exit Sub
    Dim Buffer As _MEM: Buffer = _MemImage(Image) 'Get a memory reference to our image
    Dim Frac_Value As Long: Frac_Value = Value_From_0_To_1 * 65536 'Used to avoid slow floating point calculations
    Dim O As _Offset, O_Last As _Offset
    O = Buffer.OFFSET 'We start at this offset
    O_Last = Buffer.OFFSET + _Width(Image) * _Height(Image) * 4 'We stop when we get to this offset
    'use on error free code ONLY!
    $Checking:Off
    Do
        _MemPut Buffer, O, _MemGet(Buffer, O, _Unsigned _Byte) * Frac_Value \ 65536 As _UNSIGNED _BYTE
        _MemPut Buffer, O + 1, _MemGet(Buffer, O + 1, _Unsigned _Byte) * Frac_Value \ 65536 As _UNSIGNED _BYTE
        _MemPut Buffer, O + 2, _MemGet(Buffer, O + 2, _Unsigned _Byte) * Frac_Value \ 65536 As _UNSIGNED _BYTE
        O = O + 4
    Loop Until O = O_Last
    'turn checking back on when done!
    $Checking:On
    _MemFree Buffer
End Sub
 
 
 
 

I either just get all background Or all background until Fade_IN applied then ONLY image fade in very fast.

QB64 Discussion / Looking for Way to Fade In (or Out) an Image

« on: October 04, 2021, 10:16:51 am »

This question came up last night with Dav's Pipe Connecting Puzzle:

Is there a way to fade an image in or out without having to resort to a pixel at a time with Point?

That would be so nice to use for ghostly faces and other Halloween tricks.

Programs / Crypt-O-Gram Puzzle - Halloween Challenge

« on: October 04, 2021, 09:18:14 am »

The Cryptogram Puzzle I presented in Discussion Board was really sadistic in the way you had to input letters. I came up with a better algorithm yesterday morning, I call it "Binary Select".

Here is the test code you can play with to get familiar with inputting letters. It's like the computer is playing a little guessing game showing you a group of letters and you press spacebar (or any key in test demo) if your letter is in the group... just wait if it's not your letter in group, repeat... until computer knows your letter. The computer then displays letter on next line and on next line you must confirm YN (another little guessing game pressing spacebar (or any key) on the Y display to confirm, indeed, that is the intended letter or not ie, you did not confirm the Y display.

So here is the main engine for getting user input for the game:

Code: QB64: [Select]

_Title "Binary Select test demo" 'b+ 2021-10-03  Aha!
 
Do
    test$ = bChoice$(10, 5, "ABCDEFGHIJKLMNOPQRSTUVWXYZ1234")
    Cls
    Print "bChoice$ returned > "; test$
    Do
        Print: Print "Do you want to try another?"
        test$ = ""
        test$ = bChoice$(CsrLin, 1, "YNM")
    Loop Until Len(test$)
    Cls
Loop Until test$ <> "Y"
 
Function bChoice$ (row, col, select$) ' this is a wrapper function for confirming the BinarySelect$ choice since so easy to mess up
    'this function needs 3 lines from screen, starting at row parameter.
    'the first line, at row, is dedicated to the BinarySelect$ function
    'the next 2 lines confirm the select
    ' All this makes it possible to continuous poll for a selection, if the user is away from computer for awhile
    ' no problem because he wont be there to confirm the choice and so no progress is made in program using BinarySelect$
 
    'clear 3 dedicated lines
    copySelect$ = select$
    For i = 0 To 2 ' clear lines
        Locate row + i, col: Print Space$(_Width - col + 1);
    Next
    c$ = BinarySelect$(row, col, copySelect$) ' the last choice is like a cancel
    'Locate 20, 10: Print "debug print c$: "; c$;
    Locate row + 1, col: Print "Confirming your choice > " + c$;
    check$ = BinarySelect$(row + 2, col, "YN")
    If check$ = "Y" Then bChoice$ = c$
    Print "bChoice$ = "; c$
End Function
 
 
Function BinarySelect$ (row, col, select$) ' this is recursive part of Binary Select Algo
    ls = Len(select$)
    If ls = 0 Then Beep: Exit Function ' no choices
    If ls = 1 Then BinarySelect$ = select$: Exit Function ' only one choice
    hls = Int(ls / 2)
    s1$ = Mid$(select$, 1, hls): s2$ = Mid$(select$, hls + 1)
    Locate row, col: Print Space$(_Width - col + 1);
    Locate row, col: Print "Press key if you see your choice > " + s1$;
    t = Timer(.001)
    _KeyClear
    k$ = InKey$
    While Len(k$) = 0 And Timer(.001) - t < 3 + .25 * Len(s1$)
        k$ = InKey$
        _Limit 60
    Wend
    If Len(k$) Then
        If Len(s1$) = 1 Then BinarySelect$ = s1$ Else BinarySelect$ = BinarySelect$(row, col, s1$)
    Else
        BinarySelect$ = BinarySelect$(row, col, s2$)
    End If
End Function
 
 

It's still something that needs a little practice with but it is much easier to use than my first idea.

On the confirmation for trying again, it still catches me by surprise the first Y for confirming to try again.
No worries, if there is no confirmation for any letter, it will cycle around and offer the groups over and over again.

For the Game, I put an Ecs keypress in there to quit game as it was in Full Screen mode with no top right window X to close.

Programs / Marvin has a ball

« on: September 29, 2021, 09:21:11 pm »

My first use of an image sheet I think.

Here is what the SdlBasic code looked like 6 years ago!

Code: [Select]

'
'    Marvin has a ball.sdlbas 2015-05-29 j&m
'
'    needs: Marvin32x48.png  y=0 back, y=1 right, y=2 front, y=3 left
'
sub rball(x)
	for i=12 to 0 step -1
		ink(rgb(255-i*21,0,0))
		fillcircle(x,388,i)
	next
end sub
sub bball(x,y)
	for i=125 to 0 step -1
		ink(rgb(255-i*2,0,0))
		fillcircle(x,y,i)
	next
end sub
'========================================================== main
setDisplay(600,500,32,1)
autoback(-2)
loadImage("marvin32x48.png",1)
x = 0:y=0:imx=0:imy=1:marvinX=425:marvinY=352
ink(rgb(0,215,65))
bar(0,400,screenwidth, screenheight)
ink(rgb(0,185,255))
bar(0,0,screenwidth,400)
while 0=0
    ink(rgb(0,185,255))
	bar(0,0,screenwidth,400)
    blt(1,(marvinX mod 4)*32,imy*48,32,48,marvinX,marvinY)
	rball(marvinX+35)
    screenswap
    wait(50)
    marvinX = marvinX + 1
    if marvinX>600 then: exit while: end if
wend
imy=3
while 0=0
    ink(rgb(0,185,255))
	bar(0,0,screenwidth,400)
    blt(1,(marvinX mod 4)*32,imy*48,32,48,marvinX,marvinY)
	bball(marvinX+130,275)
    screenswap
    marvinX = marvinX - 21
    if marvinX<-295 then
		text(270,120,16,"wait. . .  ")
		screenswap
		wait(3000)
		exit while
	end if
wend
imy=2:marvinX=300:marvinY=400:ballY=marvinY+173
while 0=0
    ink(rgb(0,185,255))
	bar(0,0,screenwidth,400)
	bball(marvinX+16,ballY)
	blt(1,(marvinY mod 4)*32,imy*48,32,48,marvinX,marvinY)
	ink(rgb(0,215,65))
	bar(0,400,screenwidth, screenheight)
    screenswap
    marvinY = marvinY -1
	if marvinY<-80 then
		end
    elseif marvinY=0 then
		marvinY=-49
	elseif marvinY<90 then
		ballY =290 :imy=0
	else
		ballY= marvinY+173
	end if
wend

Today's tranlation and mods for QB64:

Code: QB64: [Select]

_Title "Marvin has a ball" ' b+ trans from SdlBasic 2021-09-29
' needs: Marvin32x48.png  y=0 back, y=1 right, y=2 front, y=3 left
ratio = _DesktopHeight / _DesktopWidth
Screen _NewImage(800, 800 * ratio, 32)
Do: Loop Until _ScreenExists
_FullScreen
m& = _LoadImage("marvin32x48.png")
x = 0: y = 0: imx = 0: imy = 1: marvinX = 425: marvinY = 352
Line (0, 400)-(_Width, _Height), _RGB32(0, 215, 65), BF
Line (0, 0)-(_Width, 400), _RGB32(0, 185, 255), BF
While _KeyDown(27) = 0 ' sisyphus
    Line (0, 0)-(_Width, 400), _RGB32(0, 185, 255), BF
    blt m&, (marvinX Mod 4) * 32, imy * 48, 32, 48, marvinX, marvinY
    drawBall marvinX + 35, 400 - 12, 12, &HFFFF0000
    _Display
    _Limit 40
    marvinX = marvinX + 1
    If marvinX > _Width Then Exit While
Wend
imy = 3: l = 5
While _KeyDown(27) = 0 ' run!
    Line (0, 0)-(_Width, 400), _RGB32(0, 185, 255), BF
    blt m&, (marvinX Mod 4) * 32, imy * 48, 32, 48, marvinX, marvinY
    drawBall marvinX + 130, 275, 125, &HFFFF0000
    _Display
    marvinX = marvinX - 21
    If marvinX < -295 Then
        _Display
        _Delay 3
        Exit While
    End If
    _Limit l
    l = l + .5
Wend
imy = 2: marvinX = _Width / 2 - 16: marvinY = 400: ballY = marvinY + 173
While _KeyDown(27) = 0 ' conquer
    Line (0, 0)-(_Width, 400), _RGB32(0, 185, 255), BF
    drawBall marvinX + 16, ballY, 125, &HFFFF0000
    blt m&, (marvinY Mod 4) * 32, imy * 48, 32, 48, marvinX, marvinY
    Line (0, 400)-(_Width, _Height), _RGB32(0, 215, 65), BF
    _Display
    _Limit 10
    marvinY = marvinY - 1
    If marvinY < -80 Then
        End
    ElseIf marvinY = 0 Then
        marvinY = -49
    ElseIf marvinY < 90 Then
        ballY = 280: imy = 0
    Else
        ballY = marvinY + 173
    End If
Wend
 
Sub blt (imageHandle&, sx, sy, sw, sh, dx, dy) ' for johnno to trans SdlBasic to QB64
    _PutImage (dx, dy), imageHandle&, 0, (sx, sy)-Step(sw, sh)
End Sub
 
Sub drawBall (x, y, r, c As _Unsigned Long)
    Dim rred As Long, grn As Long, blu As Long, rr As Long, f
    rred = _Red32(c): grn = _Green32(c): blu = _Blue32(c)
    For rr = r To 0 Step -1
        f = 1 - rr / r
        fcirc x, y, rr, _RGB32(rred * f, grn * f, blu * f)
    Next
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
 

@johnno56 you might be interested in the blt translation for use in QB64, after I looked up SdlBasic docs for the argument variables it was easy to translate and it worked the first time!

Attached is the zip of code with image.

Programs / Iterated digits squaring - Rosetta Code

« on: September 04, 2021, 02:28:15 pm »

ref http://rosettacode.org/wiki/Iterated_digits_squaring

Who tried this recursively?

Code: QB64: [Select]

$Checking:Off
_Title "Iterated digits squaring - Rosetta Code" ' b+ try 2021-09-04
' ref http://rosettacode.org/wiki/Iterated_digits_squaring
start = Timer(.001)
For i& = 1 To 100000000 ' 100 million
    If i& Mod 1000000 = 0 Then Print i&, c& ' progress almost 8 minutes on my system
    c& = c& + sumSQRdigitsIs89%(i&)
Next
Print c&, Timer(.001) - start
 
Function sumSQRdigitsIs89% (number&)
    n$ = _Trim$(Str$(number&))
    For i = 1 To Len(n$)
        sum& = sum& + Val(Mid$(n$, i, 1)) ^ 2
    Next
    If sum& = 89 Then
        sumSQRdigitsIs89% = 1
    ElseIf sum& <> 1 Then
        sumSQRdigitsIs89% = sumSQRdigitsIs89%(sum&)
    End If
End Function
 

Of course there must be faster ways even for QB64 ;-))

Hint get rid of the string stuff :)

Programs / Stem and leaf - Rosetta Code

« on: September 04, 2021, 12:58:28 pm »

ref: http://rosettacode.org/wiki/Stem-and-leaf_plot

Not bad for not having built in sort:

Code: QB64: [Select]

_Title "Stem and leaf - Rosetta Code" ' b+ start 2021-09-04
Screen 12: Color 2 ' ref: http://rosettacode.org/wiki/Stem-and-leaf_plot
d$ = "12 127 28 42 39 113 42 18 44 118 44 37 113 124 37 48 127 36 29 31 125 139 131 115 105 132 104"
d$ = d$ + " 123 35 113 122 42 117 119 58 109 23 105 63 27 44 105 99 41 128 121 116 125 32 61 37 127"
d$ = d$ + " 29 113 121 58 114 126 53 114 96 25 109 7 31 141 46 13 27 43 117 116 27 7 68 40 31 115 "
d$ = d$ + "124 42 128 52 71 118 117 38 27 106 33 117 116 111 40 119 47 105 57 122 109 124 115 43 "
d$ = d$ + "120 43 27 27 18 28 48 125 107 114 34 133 45 120 30 127 31 116 146 "
For stem = 0 To 14
    If stem = 0 Then s$ = "" Else s$ = _Trim$(Str$(stem))
    ReDim sort$(0): b$ = ""
    For i = 1 To Len(d$) ' read through data and pick numbers builds b$
        If Mid$(d$, i, 1) = " " Then
            If Mid$(b$, 1, Len(b$) - 1) = s$ Then loadSort Right$(b$, 1), sort$()
            b$ = ""
        Else
            b$ = b$ + Mid$(d$, i, 1)
        End If
    Next
    Print Space$(4); Right$(Str$(stem), 2); " & ";
    For i = 1 To UBound(sort$)
        Color Val(sort$(i)) + 5: Print sort$(i); " ";
    Next
    Color 2: Print
Next
 
Sub loadSort (insertN As String, dynArr() As String) '  version 2020-06-07
    'note this leaves dynArr(0) empty! so ubound of array is also number of items in list
    ub = UBound(dynArr) + 1
    ReDim _Preserve dynArr(LBound(dynArr) To ub) As String
    For j = 1 To ub - 1
        If insertN < dynArr(j) Then '  GT to LT according to descending or ascending sort
            For k = ub To j + 1 Step -1
                dynArr(k) = dynArr(k - 1)
            Next
            Exit For
        End If
    Next
    dynArr(j) = insertN
End Sub
 

Colorized

Pages: 1 2 3 [4] 5 6 ... 21

News:

Show Posts

Topics - bplus

Programs / Play Offs Chart - Recursion Example

Programs / Recursive Vrs NonRecursive test with Quicksort

Programs / Honeycombs _ Rosetta Code

Programs / One Key Creep Out for Halloween

QB64 Discussion / Big ugly font difference between QB64 v1.4 and QB64 1.5 (and QB64 v2.0)

Programs / One Key Screen 0 Halloween Crypt-O-Gram

Programs / One Key Connect 4 (8x8) Halloween Style

QB64 Discussion / On Clearing a STATIC array

Programs / DrawWorms code test and demo

Programs / Fade In & Out Tests

QB64 Discussion / Looking for Way to Fade In (or Out) an Image

Programs / Crypt-O-Gram Puzzle - Halloween Challenge

Programs / Marvin has a ball

Programs / Iterated digits squaring - Rosetta Code

Programs / Stem and leaf - Rosetta Code