QB64 Phoenix Edition
Proggies - Printable Version

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

Pages: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21

RE: Proggies - James D Jarvis - 09-21-2022

Does every path get followed every time in the meandering circuits? Looked like it does but I haven't dug in to confirm in the code and just curious if that is the intent.

RE: Proggies - bplus - 09-21-2022

As I recall, everything is connected so the lightning could strike anywhere and eventually burn out the whole circuit.

I haven't looked at this code for awhile but just watching the spark paths, a new path is started at every fork and when sparks collide that line is out. Fun to watch the unexpected straight lines of fire.

RE: Proggies - mnrvovrfc - 09-24-2022

(09-21-2022, 02:39 PM)bplus Wrote: Thanks to James D Jarvis, your poly solids gave me idea for improvement to "Even Better Stars"

Even More Better Stars
I can't stand screensavers on Linux, but in case I should need one, this one gets the nod. Only I wish Linux could be like WindowsXP, just rename an EXE file so the OS is convinced it's a screensaver... or a bit more involved. Nice work you two!

RE: Proggies - bplus - 10-09-2022

(09-24-2022, 03:25 AM)mnrvovrfc Wrote:
(09-21-2022, 02:39 PM)bplus Wrote: Thanks to James D Jarvis, your poly solids gave me idea for improvement to "Even Better Stars"

Even More Better Stars
I can't stand screensavers on Linux, but in case I should need one, this one gets the nod. Only I wish Linux could be like WindowsXP, just rename an EXE file so the OS is convinced it's a screensaver... or a bit more involved. Nice work you two!

Screen savers are Art in Motion (usually animated).

Anyway, I was reloading lost files in JB not backed up when I lost drives again! So I am going through JB forum collecting my little gems and ran across the swizzle series that you folks might like:

Swizzle Series

Code: (Select All)
_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


Code: (Select All)
_Title "Swizzle 2" ' b+ 2021-05-30  Make use of 2D Arrays
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 * .25: g = Rnd * Rnd * .25: b = Rnd * Rnd * .25
For x = 0 To .5 * Xmax
    Line (x, x)-(Xmax - x, Ymax - x), _RGB32(128 + 128 * Sin(r * x), 128 + 128 * Sin(g * x), 128 + 128 * Sin(b * x)), B
    For y = x To Ymax - x
        vScreenR(x, y) = 128 + 128 * Sin(r * x)
        vScreenG(x, y) = 128 + 128 * Sin(g * x)
        vScreenB(x, y) = 128 + 128 * Sin(b * x)
        vScreenR(Xmax - x, y) = 128 + 128 * Sin(r * x)
        vScreenG(Xmax - x, y) = 128 + 128 * Sin(g * x)
        vScreenB(Xmax - x, y) = 128 + 128 * Sin(b * x)
    Next
    For y = x To Xmax - x
        vScreenR(y, x) = 128 + 128 * Sin(r * x)
        vScreenG(y, x) = 128 + 128 * Sin(g * x)
        vScreenB(y, x) = 128 + 128 * Sin(b * x)
        vScreenR(Xmax - y, Ymax - x) = 128 + 128 * Sin(r * x)
        vScreenG(Xmax - y, Ymax - x) = 128 + 128 * Sin(g * x)
        vScreenB(Xmax - y, Ymax - x) = 128 + 128 * Sin(b * x)
    Next
Next
_Delay 1
swizzle = Rnd * .2 + .9
_Title "Swizzle @" + _Trim$(Str$(swizzle))
For radius = 1 To 300
    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


Code: (Select All)
_Title "Swizzle YY" ' 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)

For x = 0 To Xmax
    If x < (.5 * Xmax) Then
        r = 0: g = 0: b = 0
    Else
        r = 255: g = 255: b = 255
    End If
    Line (x, 0)-(x, Ymax), _RGB32(r, g, b)
    For y = 0 To Ymax
        vScreenR(x, y) = r
        vScreenG(x, y) = g
        vScreenB(x, y) = b
    Next
Next
swizzle = 1.
_Title "Swizzle @" + _Trim$(Str$(swizzle))
For radius = 1 To 180
    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

Code: (Select All)
_Title "Swizzle Spin" ' b+ 2021-05-29
Const Xmax = 600, Ymax = 600, cxy = 300, Pi = _Pi
Screen _NewImage(Xmax, Ymax, 32)
_Delay .25
_ScreenMove _Middle
Randomize Timer
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

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
s& = _NewImage(Xmax * 2.2, Ymax * 2.2, 32)
_PutImage , 0, s&
Do
    RotoZoom cxy, cxy, s&, 1, a
    a = a - 3: If a < -360 Then a = 0: _FreeImage s&: GoTo restart
    _Display: _Limit 30
Loop Until InKey$ <> ""


Sub RotoZoom (X As Long, Y As Long, Image As Long, Scale As Single, Rotation As Single)
    Dim px(3) As Single: Dim py(3) As Single
    W& = _Width(Image&): H& = _Height(Image&)
    px(0) = -W& / 2: py(0) = -H& / 2: px(1) = -W& / 2: py(1) = H& / 2
    px(2) = W& / 2: py(2) = H& / 2: px(3) = W& / 2: py(3) = -H& / 2
    sinr! = Sin(-Rotation / 57.2957795131): cosr! = Cos(-Rotation / 57.2957795131)
    For i& = 0 To 3
        x2& = (px(i&) * cosr! + sinr! * py(i&)) * Scale + X: y2& = (py(i&) * cosr! - px(i&) * sinr!) * Scale + Y
        px(i&) = x2&: py(i&) = y2&
    Next
    _MapTriangle _Seamless(0, 0)-(0, H& - 1)-(W& - 1, H& - 1), Image& To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
    _MapTriangle _Seamless(0, 0)-(W& - 1, 0)-(W& - 1, H& - 1), Image& To(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
End Sub


   

RE: Proggies - vince - 10-09-2022

nice, this is the swirl from tolja's swirl effect page. It's never a bad time to revisit JB forums

(on a side note, I discovered that having a JB forum account allows you to browse a bunch of other forums with minimal registration)

RE: Proggies - bplus - 10-10-2022

(10-09-2022, 09:20 PM)vince Wrote: nice, this is the swirl from tolja's swirl effect page.  It's never a bad time to revisit JB forums

(on a side note, I discovered that having a JB forum account allows you to browse a bunch of other forums with minimal registration)

Who is tolja?

RE: Proggies - vince - 10-10-2022

that might be from another forum, my mistake

RE: Proggies - bplus - 10-18-2022

Donut with Code Sprinkles
Code: (Select All)
_Title "Donut with code sprinkles by bplus 2018-03-09"
Const xmax = 700
Const ymax = 700
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 360, 0
Const cx = xmax / 2
Const cy = ymax / 2
Const tw = 8
Const th = 16
Open "donut code.bas" For Input As #1
While EOF(1) = 0
    Line Input #1, fline$
    f$ = f$ + LTrim$(fline$) + " : "
Wend
Close #1
f$ = Left$(f$, Len(f$) - 3)
lenF = Len(f$)
tArea = tw * th * lenF / 2
r = Sqr(9 / 4 * tArea / _Pi)
For y = 0 To ymax
    For x = 0 To xmax
        d = ((x - cx) ^ 2 + (y - cy) ^ 2) ^ .5
        If r / 3 < d + 20 And d - 20 < r Then
            midInk 180, 90, 55, 80, 40, 20, 1 - Abs(2 / 3 * r - d) / (.335 * r), 0
            PSet (x + 5, y + 10)
        End If
    Next
Next
idx = 0
For y = 0 To ymax Step th
    For x = 0 To xmax Step tw
        d = ((x - cx) ^ 2 + (y - cy) ^ 2) ^ .5
        If r / 3 < d And d < r Then
            idx = idx + 1
            midInk 180, 90, 55, 80, 40, 20, Abs(2 / 3 * r - d) / (.335 * r), 1
            If idx <= lenF Then this$ = Mid$(f$, idx, 1) Else this$ = " "
            Color , 0
            _PrintString (x, y), this$
        End If
    Next
Next
Print
Sleep
Function rand% (lo%, hi%)
    rand% = Int(Rnd * (hi% - lo% + 1)) + lo%
End Function
Function rclr&&
    rclr&& = _RGB32(rand%(64, 255), rand%(64, 255), rand%(64, 255))
End Function
Sub midInk (r1, g1, b1, r2, g2, b2, fr, tf)
    If tf Then
        fc&& = rclr&&
    Else
        fc&& = _RGB32(r1 + (r2 - r1) * (1 - fr), g1 + (g2 - g1) * (1 - fr), b1 + (b2 - b1) * (1 - fr))
    End If
    bc&& = _RGB32(r1 + (r2 - r1) * fr, g1 + (g2 - g1) * fr, b1 + (b2 - b1) * fr)
    Color fc&&, bc&&
End Sub
'XOXOXOXO
   

RE: Proggies - bplus - 01-16-2023

ChatGPT inspired Sphere Spiral


Code: (Select All)
_Title "sb spiral of chatGPT - fixed by kay63 trans and mod by me, b+ 2023-01-04"
Const xmax = 600, ymax = 600
Dim Shared pi
pi = _Pi
Dim clr As _Unsigned Long
Screen _NewImage(xmax, ymax, 32)

' Set the starting position and radius of the spiral
x = ymax / 2 - .5 * ymax / pi
y = ymax / 2 - .5 * ymax / pi
r = 1

' Set the angle increment for each loop iteration
angle_inc = 5

' Set the maximum radius of the spiral
max_r = ymax / 2

' Set the maximum number of loops
max_loops = ymax

' Set the spiral rotation direction
direction = 1

' Draw the spiral
For i = 1 To max_loops
    ' Set the color for this loop iteration
    'Color i Mod 14
    ' Draw the spiral segment
    Select Case i Mod 3
        Case 0: clr = _RGB32(0, 255 * (i / 600), 128 - (i * 127 / 600))
        Case 1: clr = _RGB32(0, 100 * i / 600 + 55, 100 * i / 600 + 55)
        Case 2: clr = _RGB32(0, 255 * (i / 600), 128 - (i * 127 / 600))
    End Select
    arc x, y, r, angle_inc * i / 180 * pi, angle_inc * (i + 30) / 180 * pi, clr
    ' Increase the radius for the next loop iteration
    r = r + direction
    cnt = cnt + 1
    ' Check if the radius has reached the maximum
    If r > max_r Then
        ' Reverse the growing of the spiral
        direction = -direction
        ' Reset the radius
        r = max_r
    End If
    ' move the spiral:
    x = x + 1 / pi
    y = y + 1 / pi
    _Limit 60
Next
Sleep


Sub arc (x, y, r, raStart, raStop, c As _Unsigned Long) ' this does not check raStart and raStop like arcC does
    Dim al, a
    'x, y origin, r = radius, c = color

    'raStart is first angle clockwise from due East = 0 degrees
    ' arc will start drawing there and clockwise until raStop angle reached

    If raStop < raStart Then
        arc x, y, r, raStart, _Pi(2), c
        arc x, y, r, 0, raStop, c
    Else
        ' modified to easier way suggested by Steve
        'Why was the line method not good? I forgot.
        al = _Pi * r * r * (raStop - raStart) / _Pi(2)
        For a = raStart To raStop Step 1 / al
            PSet (x + r * Cos(a), y + r * Sin(a)), c
        Next
    End If
End Sub


   

RE: Proggies - bplus - 01-16-2023

Bilateral Symmetric Kaleidoscope
Code: (Select All)
_Title "Bilateral Kaleidoscope 2 - shape shifter" ' 2023-01-02 NOT May 2022 version by b+
Const sh = 600, sw = 800: linelimit = 400
Type lion
    As Single x1, y1, x2, y2
    As _Unsigned Long c
End Type
Dim Shared l(linelimit) As lion, li As Long
Screen _NewImage(sw, sh, 32)
'_ScreenMove 200, 100
_FullScreen
Randomize Timer
Do
    If lc = 0 Then
        dx1 = 0: dx2 = 0: dy1 = 0: dy2 = 0: dr = 0: dg = 0: db = 0
        x1 = sw * Rnd: y1 = sh * Rnd: x2 = sw * Rnd: y2 = sh * Rnd: r = Rnd * 255: g = Rnd * 255: b = Rnd * 255
        While dx1 = 0: dx1 = Rnd * 6 - 3: Wend
        While dx2 = 0: dx2 = Rnd * 6 - 3: Wend
        While dy1 = 0: dy1 = Rnd * 6 - 3: Wend
        While dy2 = 0: dy2 = Rnd * 6 - 3: Wend
        While dr = 0: dr = Rnd * 4 - 2: Wend
        While dg = 0: dg = Rnd * 4 - 2: Wend
        While db = 0: db = Rnd * 4 - 2: Wend
    End If
    Cls
    For i = 0 To li
        Line (l(i).x1, l(i).y1)-(l(i).x2, l(i).y2), l(i).c
        Line (sw - l(i).x1, l(i).y1)-(sw - l(i).x2, l(i).y2), l(i).c
        Line (l(i).x1, sh - l(i).y1)-(l(i).x2, sh - l(i).y2), l(i).c
        Line (sw - l(i).x1, sh - l(i).y1)-(sw - l(i).x2, sh - l(i).y2), l(i).c
    Next
    x1 = Remainder(x1 + dx1, sw)
    x2 = Remainder(x2 + dx2, sw)
    y1 = Remainder(y1 + dy1, sh)
    y2 = Remainder(y2 + dy2, sh)
    r = Remainder(r + dr, 255)
    g = Remainder(g + dr, 255)
    b = Remainder(b + db, 255)
    If li < linelimit Then
        li = li + 1
        l(li).x1 = x1: l(li).y1 = y1: l(li).x2 = x2: l(li).y2 = y2: l(li).c = _RGB32(r, g, b, 100)
    Else
        For i = 0 To linelimit - 1
            l(i) = l(i + 1)
        Next
        l(linelimit).x1 = x1: l(linelimit).y1 = y1: l(linelimit).x2 = x2: l(linelimit).y2 = y2: l(linelimit).c = _RGB32(r, g, b, 100)
    End If
    lc = lc + 1
    If lc > 4000 Then Sleep 1: Cls: lc = 0: li = 0
    _Display
    _Limit 100
Loop Until _KeyDown(27)

Function Remainder (n, d)
    If d = 0 Then Exit Function
    Remainder = n - (d) * Int(n / (d))
End Function