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 ... 3 4 [5] 6 7 ... 21

Programs / Word ladder - Rosetta Code

« on: September 03, 2021, 08:46:12 pm »

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

Oh this was a little more tricky!

Code: QB64: [Select]

_Title "Word ladder - Rosetta Code" 'b+ start 2021-09-03 ref: http://rosettacode.org/wiki/Word_ladder
Type connectType
    connect As String
    word As String
End Type
 
Dim Shared wordList$(2 To 7)
LoadWords 'build the strings for each word length the split them for that length
Print ladder$("boy", "man") '     quick
Print ladder$("girl", "lady") '   this takes awhile
Print ladder$("john", "jane") '   quick enough
Print ladder$("alien", "drool") ' cool but takes a long long time!
Print ladder$("child", "adult") ' and this takes awhile
Print ladder$("play", "ball") '   goes quick
Print ladder$("fun", "job") '     ditto
 
Sub LoadWords
    Open "unixdict.txt" For Input As #1
    While EOF(1) = 0
        Input #1, wd$
        If Len(wd$) > 1 And Len(wd$) < 8 Then
            ok = -1
            For m = 1 To Len(wd$)
                If Asc(wd$, m) < 97 Or Asc(wd$, m) > 122 Then ok = 0: Exit For
            Next
            If ok Then
                If wordList$(Len(wd$)) = "" Then wordList$(Len(wd$)) = wd$ Else wordList$(Len(wd$)) = wordList$(Len(wd$)) + " " + wd$
            End If
        End If
    Wend
    Close #1
End Sub
 
Function ladder$ (w1$, w2$)
    If Len(w1$) <> Len(w2$) Then ladder$ = "": Exit Function
    ReDim TheList(1 To 1) As connectType, listPlace
    ReDim wl$(1 To 1)
    Split wordList$(Len(w1$)), " ", wl$()
    connect$ = w1$
 
    newConnect:
    'progress
    'Print "Connect word is "; connect$; UBound(wl$); listPlace;
    For i = 1 To UBound(wl$)
        If oneChange%(connect$, wl$(i)) Then
            If TheList(1).connect = "" Then
                TheList(1).connect = connect$
                TheList(1).word = wl$(i)
            Else ' add to list only if word isn't a connect
                found = 0
                For j = 1 To UBound(theList)
                    If wl$(i) = TheList(j).connect Then found = -1: Exit For
                Next
                If found = 0 Then
                    cAppend TheList(), connect$, wl$(i)
                End If
            End If
            If wl$(i) = w2$ Then done = -1: Exit For
        End If
    Next
    If done = 0 Then
        listPlace = listPlace + 1
        If listPlace > UBound(TheList) Then
            ladder$ = "Could NOT connect " + w1$ + " to " + w2$
        Else
            connect$ = TheList(listPlace).word
            GoTo newConnect
        End If
    Else
        'should be able to backtrack our path?
        ladder$ = "Could connect " + w1$ + " to " + w2$
        target$ = w2$: trail$ = w2$
        again:
        For i = 1 To UBound(theList)
            If TheList(i).word = target$ Then target$ = TheList(i).connect: trail$ = target$ + " > " + trail$: GoTo again
        Next
        ladder$ = ladder$ + Chr$(10) + trail$
    End If
End Function
 
Sub Split (SplitMeString As String, delim As String, loadMeArray() As String)
    Dim curpos As Long, arrpos As Long, LD As Long, dpos As Long 'fix use the Lbound the array already has
    curpos = 1: arrpos = LBound(loadMeArray): LD = Len(delim)
    dpos = InStr(curpos, SplitMeString, delim)
    Do Until dpos = 0
        loadMeArray(arrpos) = Mid$(SplitMeString, curpos, dpos - curpos)
        arrpos = arrpos + 1
        If arrpos > UBound(loadMeArray) Then ReDim _Preserve loadMeArray(LBound(loadMeArray) To UBound(loadMeArray) + 1000) As String
        curpos = dpos + LD
        dpos = InStr(curpos, SplitMeString, delim)
    Loop
    loadMeArray(arrpos) = Mid$(SplitMeString, curpos)
    ReDim _Preserve loadMeArray(LBound(loadMeArray) To arrpos) As String 'get the ubound correct
End Sub
 
Sub cAppend (arr() As connectType, cWrd$, w$)
    ReDim _Preserve arr(LBound(arr) To UBound(arr) + 1) As connectType
    arr(UBound(arr)).connect = cWrd$
    arr(UBound(arr)).word = w$
End Sub
 
Function oneChange% (last$, test$)
    For i = 1 To Len(last$)
        If Mid$(last$, i, 1) <> Mid$(test$, i, 1) Then strike = strike + 1
    Next
    If strike = 1 Then oneChange% = -1
End Function
 
 
 

Same unixdict.txt for words attached and screen shot of output.

All original in Basic!

Programs / Wordiff - Rosetta Code

« on: September 03, 2021, 12:33:54 am »

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

I think I have the game roughed out now and will go for the "Optional Stretch Goals" with the scores array tomorrow. Kind'a fun to play :)

Code: QB64: [Select]

_Title "Wordiff - Rosetta Code" 'b+ 2021-09-02 ref: http://rosettacode.org/wiki/Wordiff
Const nWords = 24819 ' precounted for  unixdict.txt word list
Dim Shared words$(1 To nWords), used$(1 To 1000), nUsed, players$(1 To 100), scores(1 To 100), nPlayers, nextPlayer
 
LoadWords
getPlayers
nextPlayer = 1
 
newRound:
lastWord$ = StartWord$
Print "Start word is "; lastWord$
bad = 0
Do
    Print players$(nextPlayer);
    Input ", please enter your try "; try$
    For i = 1 To nUsed
        If try$ = used$(i) Then Print "I'm sorry, " + players$(nextPlayer) + ", " + try$ + " was already used.": bad = -1
    Next
    If bad = 0 Then
        If wordFound%(try$) Then
            If Len(try$) = Len(lastWord$) - 1 Then
                If oneLess%(lastWord$, try$) Then Print "Good" Else Print try$ + " doesn't work.": bad = -1
            ElseIf Len(try$) = Len(lastWord$) Then
                If oneChange%(lastWord$, try$) Then Print "Good" Else Print try$ + " doesn't work.": bad = -1
            ElseIf Len(try$) = Len(lastWord$) + 1 Then
                If oneMore%(lastWord$, try$) Then Print "Good" Else Print try$ + " doesn't work.": bad = -1
            Else
                Print "I'm sorry, " + players$(nextPlayer) + ", " + try$ + " was not the correct length.": bad = -1
            End If
        Else
            Print "I'm sorry, " + players$(nextPlayer) + ", " + try$ + " was not found in dictionary.": bad = -1
        End If
    End If
    If bad = 0 Then
        nUsed = nUsed + 1
        used$(nUsed) = try$
        lastWord$ = try$
    End If
    nextPlayer = nextPlayer + 1
    If nextPlayer > nPlayers Then nextPlayer = 1
Loop Until bad
GoTo newRound
 
Sub LoadWords
    Dim wd$, i As Integer, m As Integer, ok As _Bit
    Open "unixdict.txt" For Input As #1
    While EOF(1) = 0
        Input #1, wd$
        If Len(wd$) > 2 Then
            ok = -1
            For m = 1 To Len(wd$)
                If Asc(wd$, m) < 97 Or Asc(wd$, m) > 122 Then ok = 0: Exit For
            Next
            If ok Then i = i + 1: words$(i) = wd$
        End If
    Wend
    Close #1
End Sub
 
Sub getPlayers
    nPlayers = 0
    Do
        Input "Enter a player name or nothing to finish list "; player$
        If player$ <> "" Then nPlayers = nPlayers + 1: players$(nPlayers) = player$
    Loop Until player$ = ""
    If nPlayers = 0 Then Print "No players, goodbye!"
End Sub
 
Function StartWord$
    Do
        StartWord$ = words$(Int(Rnd * nWords) + 1)
        If Len(StartWord$) > 2 And Len(StartWord$) < 5 Then
            OK = -1
            For i = 1 To nUsed ' let us at least not start with a word used in last game
                If used$(i) = StartWord$ Then OK = 0
            Next
        End If
        If OK Then Erase used$: nUsed = 1: used$(1) = StartWord$
    Loop Until OK
End Function
 
Function wordFound% (word$) ' is the word 3 or more letters in dictionary
    If Len(word$) > 2 Then
        lo = 1: hi = nWords
        Do While wordFound% = 0
            test = Int((hi + lo) / 2)
            If words$(test) = word$ Then
                wordFound% = -1: Exit Function
            ElseIf words$(test) < word$ Then
                lo = test + 1
            Else
                hi = test - 1
            End If
            If hi < lo Then Exit Function
        Loop
    End If
End Function
 
Function oneLess% (last$, test$) ' is word one letter less than last word
    If Len(test$) = Len(last$) - 1 Then
        lastfind = 1
        For i = 1 To Len(test$)
            find = InStr(lastfind, last$, Mid$(test$, i, 1))
            If find = 0 Then Exit Function Else lastfind = find + 1
        Next
        oneLess% = -1
    End If
End Function
 
Function oneMore% (last$, test$) ' is word one letter more than last word
    If Len(test$) = Len(last$) + 1 Then
        lastfind = 1
        For i = 1 To Len(last$)
            find = InStr(lastfind, test$, Mid$(lasst$, i, 1))
            If find = 0 Then Exit Function Else lastfind = find + 1
        Next
        oneMore% = -1
    End If
End Function
 
Function oneChange% (last$, test$)
    If Len(test$) = Len(last$) Then
        For i = 1 To Len(last$)
            If Mid$(last$, i, 1) <> Mid$(test$, i, 1) Then strike = strike + 1
        Next
        If strike = 1 Then oneChange% = -1
    End If
End Function
 
 

Attached is dictionary used at RC (doesn't have "has")

QB64 Discussion / Predictions, guestimates for next stable update of QB64?

« on: August 27, 2021, 12:42:47 pm »

Hello QB64 developers,

https://www.qb64.org/forum/index.php?topic=4134.msg134972#msg134972
This discussion has led me to wonder when the next stable release might occur?

I really don't want to mess with dev versions if we are close to next stable.

My guess, this is up to @FellippeHeitor and the Debug update. True?

Programs / Creep Out

« on: August 19, 2021, 03:51:19 pm »

Quote

Creepy break-out? Hmm... Interesting. I like the sound of that... Moo Ha Ha....

Here is v2021-08-19A

Programs / String Collapse Function - Rosetta Code

« on: July 28, 2021, 08:27:57 pm »

Code: QB64: [Select]

_Title "Collapse String Function - Rosetta Code" 'b+ 2021-07-28
' ref: http://rosettacode.org/wiki/Determine_if_a_string_is_collapsible
t$(1) = "" ' a null string  (length zero)
t$(2) = Chr$(34) + "If I were two-faced, would I be wearing this one?" + Chr$(34) + " --- Abraham Lincoln "
t$(3) = "..1111111111111111111111111111111111111111111111111111111111111117777888"
t$(4) = "I never give 'em hell, I just tell the truth, and they think it's hell. "
t$(5) = "                                                    --- Harry S Truman  "
For i = 1 To 5
    Print t$(i); Len(t$(i))
    Print collapse$(t$(i)); Len(collapse$(t$(i)))
Next
 
Function collapse$ (s$)
    If Len(s$) < 2 Then collapse$ = s$: Exit Function
    c$ = Mid$(s$, 1, 1)
    collapse$ = c$
    For i = 2 To Len(s$)
        If Mid$(s$, i, 1) <> c$ Then c$ = Mid$(s$, i, 1): collapse$ = collapse$ + c$
    Next
End Function
 

Hey, about 10 lines less than FreeBASIC's entry. ;-))

Programs / Sailors and Coconuts Rosetta Code

« on: July 03, 2021, 11:04:33 pm »

http://rosettacode.org/wiki/Sailors,_coconuts_and_a_monkey_problem

With the present limit on main For loop, you can do 6 sailors:

Code: QB64: [Select]

Input "Please enter number of sailors that collect coconuts "; s
For i = 1 To 250000
    n = i
    For j = 1 To s
        If n Mod s = 1 Then
            n = n - Int(n / s) - 1
        Else
            GoTo skip
        End If
    Next
    If n Mod s = 0 Then Print i: End
    skip:
Next
 

PS for once FreeBasic follows QB64, see Word Search at RC. :)

Programs / Simple Simon

« on: June 27, 2021, 04:17:45 pm »

Code: QB64: [Select]

_Title "Simple Simon"  'b+ 2021-06-27
Randomize Timer
While 1
    b$ = b$ + _Trim$(Str$(Int(Rnd * 4) + 1))
    For i = 1 To Len(b$)
        Cls
        Print Space$(i - 1); Mid$(b$, i, 1)
        _Delay 1
    Next
    Cls
    Print "Simon says repeat all that:"
    For i = 1 To Len(b$)
        k$ = InKey$
        While k$ = ""
            k$ = InKey$
        Wend
        Print k$;
        If k$ <> Mid$(b$, i, 1) Then
            Beep
            Print
            Print b$
            Exit While
        End If
    Next
Wend

No Double Parking (with colons)

Programs / Spinner

« on: June 19, 2021, 07:54:36 pm »

A subject started at JB forum by tsh73, this is the version I came up with that won't work (way too slow) there but works great here in QB64:

Code: QB64: [Select]

_Title "Spinner" 'b+ 2021-06-18
Screen _NewImage(500, 500, 32)
Const rad = _Pi / 180
While 1
    Cls
    b = b + 5
    For r = 20 To 200 Step 20 ' tsh73 suggested fix for inner most
        a = b * r / 20
        For i = r - 15 To r
            arc 250, 250, i, a, 180
        Next
    Next
    _Display
    _Limit 15
Wend
 
Sub arc (xCenter, yCenter, arcRadius, dAStart, dAMeasure)
    'notes:
    'you may want to adjust size and color for line drawing
    'using angle measures in degrees to match Just Basic ways with pie and piefilled
    'this sub assumes drawing in a CW direction if dAMeasure positive
 
    'for Just Basic angle 0 degrees is due East and angle increases clockwise towards South
 
    'dAStart is degrees to start Angle, due East is 0 degrees
 
    'dAMeasure is degrees added (Clockwise) to dAstart for end of arc
 
    rAngleStart = rad * dAStart
    rAngleEnd = rad * dAMeasure + rAngleStart
    Stepper = rad / (.1 * arcRadius) 'fixed
    lastX = xCenter + arcRadius * Cos(rAngleStart)
    lastY = yCenter + arcRadius * Sin(rAngleStart)
    PSet (lastX, lastY)
    For rAngle = rAngleStart + Stepper To rAngleEnd Step Stepper
        nextX = xCenter + arcRadius * Cos(rAngle)
        nextY = yCenter + arcRadius * Sin(rAngle)
        Line -(nextX, nextY) 'int speeds things up
    Next
End Sub

Programs / Missile Command

« on: June 11, 2021, 07:51:51 pm »

A simple little game (I just learned about at LB):

Code: QB64: [Select]

W = 800: H = 600
Screen _NewImage(800, 600, 32)
a:
Cls
a = Rnd * W: b = 0: c = Rnd * 6 - 3: d = Rnd * 3 + 3: u = 0: v = 0: x = 400: y = H
Do
    _Title "MC hits:" + Str$(t) + ", misses:" + Str$(m)
    While _MouseInput: Wend
    If _MouseButton(1) Then e = _MouseX - 400: f = _MouseY - H: z = (e ^ 2 + f ^ 2) ^ .5: u = 5 * e / z: v = 5 * f / z
    x = x + u: y = y + v: a = a + c: b = b + d
    If x < 0 Or y < 0 Or a < 0 Or b < 0 Or x > W Or a > W Or b > H Then
        If b > H Or x < 0 Or y < 0 Or x > W Then m = m + 1
        GoTo a:
    End If
    If ((x - a) ^ 2 + (y - b) ^ 2) ^ .5 < 20 Then
        For r = 1 To 20 Step 4
            Circle ((x + a) / 2, (y + b) / 2), r
            _Limit 60
        Next
        t = t + 1: GoTo a:
    Else
        PSet (x, y): PSet (a, b)
    End If
    _Limit 20
Loop
 

Your missile base is at bottom, middle of screen. When you click mouse you want your missile to strike the incoming one before it reaches the bottom of screen. If incoming is not going to reach bottom don't worry about it unless you can hit it for sure (not likely).

Programs / Swizzle

« on: May 29, 2021, 01:24:17 pm »

A quickie:

Code: QB64: [Select]

_Title "Swizzle" ' b+ 2021-05-29
Const Xmax = 600, Ymax = 600, cxy = 300, Pi = _Pi
Screen _NewImage(Xmax, Ymax, 32)
_Delay .25
_ScreenMove _Middle
Dim vScreenR(Xmax, Ymax), vScreenG(Xmax, Ymax), vScreenB(Xmax, Ymax)
restart:
r = Rnd * Rnd: g = Rnd * Rnd: b = Rnd * Rnd
For x = 0 To Xmax
    Line (x, 0)-(x, Ymax), _RGB32(128 + 128 * Sin(r * x), 128 + 128 * Sin(g * x), 128 + 128 * Sin(b * x))
    For y = 0 To Ymax
        vScreenR(x, y) = 128 + 128 * Sin(r * x)
        vScreenG(x, y) = 128 + 128 * Sin(g * x)
        vScreenB(x, y) = 128 + 128 * Sin(b * x)
    Next
Next
swizzle = Rnd * .5 + .8
_Title "Swizzle @" + _Trim$(Str$(swizzle))
For radius = 1 To 200
    For a = 0 To 2 * Pi Step 1 / (2 * Pi * radius)
        x = Int(cxy + radius * Cos(a))
        y = Int(cxy + radius * Sin(a))
        r = vScreenR(x, y)
        g = vScreenG(x, y)
        b = vScreenB(x, y)
        PSet (cxy + radius * Cos(a + radius ^ swizzle * Pi / 180), cxy + radius * Sin(a + radius ^ swizzle * Pi / 180)), _RGB32(r, g, b)
    Next
Next
_Delay 3
GoTo restart
 

QB64 Discussion / Quick Question about identifying exes compiled with QB64

« on: May 22, 2021, 03:47:28 pm »

Is it possible to tell a compiled QB64 exe from other exe's say for instance FB?

If so, then my follow up question is how?

Programs / Mouse Event Test

« on: May 17, 2021, 12:49:27 pm »

This might be interesting way to go with Mouse Button clicks?

Code: QB64: [Select]

_Title "Mouse Event test" 'b+ 2021-05-17
 
Dim Shared mx, my, mb1DownX, mb1DownY, mb1UpX, mb1UpY, oldmb1
 
t1 = _FreeTimer 'get a timer number from _FREETIMER ONLY!
On Timer(t1, .05) PollMouse
Timer(t1) On
 
' signal no button locations registered yet
mb1DownX = -1
mb1DownY = -1
mb1UpX = -1
mb1UpY = -1
 
Do
    Cls
    Print "         Mouse location at:"; mx; ","; my
    Print "  Status Left Button Down: "; oldmb1
    Print "First Mouse Button Down at:"; mb1DownX; ","; mb1DownY
    Print "   Last Mouse Button Up at:"; mb1UpX; ","; mb1UpY
    _Display
Loop Until InKey$ = Chr$(27)
Timer(t1) Off
Timer(t1) Free 'release timer
End
 
Sub PollMouse ' catch locations of mouse button 1 down and up
    While _MouseInput: Wend
    mx = _MouseX: my = _MouseY: mb1 = _MouseButton(1)
    If mb1 And oldmb1 = 0 Then
        mb1DownX = mx
        mb1DownY = my
        'mb1UpX = 0
        'mb1UpY = 0
    End If
    If mb1 = 0 And oldmb1 Then
        mb1UpX = mx
        mb1UpY = my
        'mb1DownX = 0
        'mb1DownY = 0
    End If
    oldmb1 = mb1
End Sub
 
 

Always wanted to try something like this.

BTW look at the example for On Timer Event, it is about mouse which I used to start this code test.

If MB1 then mb1DownX and mb1DownY are latest first down at locations.
If MB1 = 0 then mb1UpX, mb1UpY was location of last release of mouse button 1 which you can clear (set -1) when you have handled the Click.

Programs / A New Wrinkle with Voronoi

« on: May 10, 2021, 02:41:48 am »

Shading gives us a lovely psuedo-3D effect!

Code: QB64: [Select]

_Title "Shading Voronoi Demo" 'b+ 2019-12-11  shading 2021-05-10
Const xymax = 700, nPoints = 50
Type pType
    x As Single
    y As Single
    c As _Unsigned Long
End Type
Screen _NewImage(xymax, xymax, 32)
_ScreenMove 300, 20
Randomize Timer
Dim pts(1 To nPoints) As pType
For i = 1 To nPoints
    pts(i).x = xymax * Rnd
    pts(i).y = xymax * Rnd
    pts(i).c = _RGB32(155 * Rnd + 100, -(Rnd < .5) * 255 * Rnd, -(Rnd < .5) * 255 * Rnd)
Next
For i = 1 To nPoints
    Circle (pts(i).x, pts(i).y), 5, pts(i).c
Next
_Delay .5
For y = 0 To xymax
    For x = 0 To xymax
        minD = 49000
        For p = 1 To nPoints
            d = ((pts(p).x - x) ^ 2 + (pts(p).y - y) ^ 2) ^ .5
            If d < minD Then minD = d: saveP = p
        Next
        PSet (x, y), Ink~&(pts(saveP).c, &HFF000000, minD / 85)
    Next
Next
Sleep
 
Sub cAnalysis (c As _Unsigned Long, outRed, outGrn, outBlu, outAlp)
    outRed = _Red32(c): outGrn = _Green32(c): outBlu = _Blue32(c): outAlp = _Alpha32(c)
End Sub
 
Function Ink~& (c1 As _Unsigned Long, c2 As _Unsigned Long, fr##)
    Dim R1, G1, B1, A1, R2, G2, B2, A2
    cAnalysis c1, R1, G1, B1, A1
    cAnalysis c2, R2, G2, B2, A2
    Ink~& = _RGB32(R1 + (R2 - R1) * fr##, G1 + (G2 - G1) * fr##, B1 + (B2 - B1) * fr##, A1 + (A2 - A1) * fr##)
End Function
 
 

Programs / Collision Study #4

« on: May 09, 2021, 07:55:36 pm »

This version seems to be working better than my last:

Code: QB64: [Select]

_Title "Collision Study #4   press spacebar to toggle tracer" ' b+ 2021-05-09 by bplus
' from  "Collision Study #3 Brownian Motion 2018-03-31 by bplus (which was terrible idea of Brownian Motion)
' This time I want to bounce balls with the closest collision first (in case ball is coliidable with 2 or more others)
' PLUS this time I wont change current arrays of ball data but store into NextArray so all bounces are calc'd
'      before any new drawing takes place.  YES! I think this works better.
' All radii are const for less calc, need balls different colored
 
 
Const Xmax = 600 ' screen width
Const Ymax = 600 ' screen height
Const R = 50 '     balls radii
Const Balls = 18 ' number of balls
Type Ball
    As Long x, y, rr, gg, bb ' screen location and RGB colors
    As Double dx, dy ' dx, dy = change x, y axis
End Type
 
Randomize Timer
Screen _NewImage(Xmax, Ymax, 32)
_Delay .25
_ScreenMove _Middle
' these can be static as no balls added or subtracted in closed system
Dim As Ball b(1 To Balls), nf(1 To Balls) ' b() is current frame balls data , nf( ) is for next frame balls data
Dim As Long clrMode, i, rad, j
clrMode = 1
For i = 1 To Balls
    b(i).x = rand(R, Xmax - R)
    b(i).y = rand(R, Ymax - R)
    b(i).dx = Rnd * 4 + 1 * rdir
    b(i).dy = Rnd * 4 + 1 * rdir
    b(i).rr = rand%(180, 255)
    b(i).gg = rand%(180, 255)
    b(i).bb = rand%(180, 255)
Next
 
While 1
    k$ = InKey$
    If Len(k$) Then
        If Asc(k$) = 32 Then clrMode = -1 * clrMode
        If Asc(k$) = 27 And Len(k$) = 1 Then End
    End If
    If clrMode > 0 Then Cls
 
    For i = 1 To Balls ' draw balls then  update for next frame
 
        For rad = R To 1 Step -1
            Color _RGB32(b(i).rr - rad / R * 150, b(i).gg - rad / R * 150, b(i).bb - rad / R * 150)
            fcirc b(i).x, b(i).y, rad
        Next
 
        ' check for collision
        cd = 100000: saveJ = 0
        For j = 1 To Balls 'find deepest collision
            If i <> j Then
                dx = b(i).x - b(j).x: dy = b(i).y - b(j).y
                If dx * dx + dy * dy < (2 * R) * (2 * R) Then ' collision but is it first or deepest collision
                    If R * R - dx * dx + dy * dy < cd Then cd = (2 * R) * (2 * R) - dx * dx + dy * dy: saveJ = j
                End If
            End If
        Next
        If cd <> 100000 Then ' found collision change ball i dx, dy   calc new course for ball i
            a = _Atan2(b(i).y - b(saveJ).y, b(i).x - b(saveJ).x)
            power1 = (b(i).dx ^ 2 + b(i).dy ^ 2) ^ .5
            power2 = (b(saveJ).dx ^ 2 + b(saveJ).dy ^ 2) ^ .5
            power = (power1 + power2) / 2
            nf(i).dx = power * Cos(a)
            nf(i).dy = power * Sin(a)
        Else ' no collision
            nf(i).dx = b(i).dx
            nf(i).dy = b(i).dy
        End If
        'update location of ball next frame
        nf(i).x = b(i).x + nf(i).dx
        nf(i).y = b(i).y + nf(i).dy
 
        ' check in bounds next frame
        If nf(i).x < R Then nf(i).dx = -nf(i).dx: nf(i).x = R
        If nf(i).x > Xmax - R Then nf(i).dx = -nf(i).dx: nf(i).x = Xmax - R
        If nf(i).y < R Then nf(i).dy = -nf(i).dy: nf(i).y = R
        If nf(i).y > Ymax - R Then nf(i).dy = -nf(i).dy: nf(i).y = Ymax - R
    Next
 
    'now that we've gone through all old locations update b() with nf() data
    For i = 1 To Balls
        b(i).x = nf(i).x: b(i).y = nf(i).y
        b(i).dx = nf(i).dx: b(i).dy = nf(i).dy
    Next
    ' next frame ready to draw
    _Display
    _Limit 60
Wend
 
Function rand% (lo As Integer, hi As Integer)
    rand% = (Rnd * (hi - lo + 1)) \ 1 + lo
End Function
 
Function rdir ()
    If Rnd < .5 Then rdir = -1 Else rdir = 1
End Function
 
'Steve McNeil's  copied from his forum   note: Radius is too common a name
Sub fcirc (CX As Long, CY As Long, R As Long)
    Dim subRadius As Long, RadiusError As Long
    Dim X As Long, Y As Long
 
    subRadius = Abs(R)
    RadiusError = -subRadius
    X = subRadius
    Y = 0
 
    If subRadius = 0 Then PSet (CX, CY): Exit Sub
 
    ' Draw the middle span here so we don't draw it twice in the main loop,
    ' which would be a problem with blending turned on.
    Line (CX - X, CY)-(CX + X, CY), , 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), , BF
                Line (CX - Y, CY + X)-(CX + Y, CY + X), , BF
            End If
            X = X - 1
            RadiusError = RadiusError - X * 2
        End If
        Y = Y + 1
        Line (CX - X, CY - Y)-(CX + X, CY - Y), , BF
        Line (CX - X, CY + Y)-(CX + X, CY + Y), , BF
    Wend
End Sub
 
 

Programs / 2 Ball Collision with an itsy-bitsy-teeny-tiny little bit of trig

« on: May 09, 2021, 02:14:49 am »

Code: QB64: [Select]

'  Collision Study Mouse and Ball.bas for QB64 fork (B+=MGA) 2017-08-23
'updated from: Collision study mouse and ball.bas for QB64 fork (B+=MGA) trans 2017-08-20
'translated from "collision mouse study.bas"  SmallBASIC version 2017-01-10
'which was modify the yab version from six posts to one mouse
 
Const xmax = 800
Const ymax = 600
Screen _NewImage(xmax, ymax, 32)
_Title "Collision Study: Mouse versus Ball - bplus"
 
Const RADIUS = 30 ' radius for both ball and angle
Const SPEED = 5
ba = _Pi(1 / 6) 'ball angle in radians
bx = xmax / 2 'ball x
by = ymax / 2 'ball y
 
 
While 1
    Cls , _RGB(30, 70, 48)
    If _KeyHit = 27 Then End 'pressed escape goodbye!
 
    'paddle px, py location
    While _MouseInput: Wend  ' <<<<<<<<<< this code so old I had to fix this
    px = _MouseX: py = _MouseY
 
    pbDistance = Sqr((px - bx) ^ 2 + (py - by) ^ 2)
    'LOCATE 1, 1: PRINT px, py, pbDistance  'debug
 
    'show paddle
    For i = RADIUS To 0 Step -1
        Color _RGB(255 - i * 5, 0, 0)
        CircleFill px, py, i
    Next
 
    'update ball hit paddle
    If Sqr((px - bx) ^ 2 + (py - by) ^ 2) < RADIUS * 2 Then ba = _Atan2(by - py, bx - px)
 
    'handle ball hit border
    If bx < 0 + RADIUS Then ba = _Pi(1) - ba: bx = RADIUS
    If bx > xmax - RADIUS Then ba = _Pi(1) - ba: bx = xmax - RADIUS
    If by < 0 + RADIUS Then ba = -ba: by = RADIUS
    If by > ymax - RADIUS Then ba = -ba: by = ymax - RADIUS
 
    'ball angle adjustments to keep between 0 and 2*pi
    If ba > 2 * _Pi(1) Then ba = ba - _Pi(2)
    If ba < 0 Then ba = ba + _Pi(2)
 
    'OK the ball is here
    bx = bx + Cos(ba) * SPEED
    by = by + Sin(ba) * SPEED
 
    'show ball
    For i = RADIUS To 0 Step -1
        Color _RGB(255 - i * 6, 255 - i * 6, 255 - i * 6)
        CircleFill bx, by, i
    Next
 
    'update screen and keep loops under 61 per second
    _Display
    _Limit 60
Wend
 
'Steve McNeil's  copied from his forum
Sub CircleFill (CX As Long, CY As Long, R As Long)
    Dim subRADIUS As Long, RadiusError As Long
    Dim X As Long, Y As Long
 
    subRADIUS = Abs(R)
    RadiusError = -subRADIUS
    X = subRADIUS
    Y = 0
 
    If subRADIUS = 0 Then PSet (CX, CY): Exit Sub
 
    ' Draw the middle span here so we don't draw it twice in the main loop,
    ' which would be a problem with blending turned on.
    Line (CX - X, CY)-(CX + X, CY), , 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), , BF
                Line (CX - Y, CY + X)-(CX + Y, CY + X), , BF
            End If
            X = X - 1
            RadiusError = RadiusError - X * 2
        End If
        Y = Y + 1
        Line (CX - X, CY - Y)-(CX + X, CY - Y), , BF
        Line (CX - X, CY + Y)-(CX + X, CY + Y), , BF
    Wend
End Sub
 
 
 

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

News:

Show Posts

Topics - bplus

Programs / Word ladder - Rosetta Code

Programs / Wordiff - Rosetta Code

QB64 Discussion / Predictions, guestimates for next stable update of QB64?

Programs / Creep Out

Programs / String Collapse Function - Rosetta Code

Programs / Sailors and Coconuts Rosetta Code

Programs / Simple Simon

Programs / Spinner

Programs / Missile Command

Programs / Swizzle

QB64 Discussion / Quick Question about identifying exes compiled with QB64

Programs / Mouse Event Test

Programs / A New Wrinkle with Voronoi

Programs / Collision Study #4

Programs / 2 Ball Collision with an itsy-bitsy-teeny-tiny little bit of trig