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 - Dav - 09-04-2023

Fun little code to play with!   Please forgive me for butting in, but I couldn't resist modding it too!

- Dav

Code: (Select All)


Dim w, h

w = 640

h = 640

Screen _NewImage(w, h, 32)

_ScreenMove 340, 60

Dim i, t, x, y

Do

    t = t + 0.01

    Line (0, 0)-(w, h), _RGBA(0, 0, 0, 25), BF

    For i = 1 To 8

        Color _RGBA(i * 32, i * 32 * .7, 0, i * 32)

        For x = 0 To w

            y = 100 * Sin(_Pi * x / w) * Sin(1 * _Pi * x / w + t + i * t * _Pi * 0.1)

            Circle (x, h / 2 + y), i

            Circle (w / 2 + y, x), i

        Next

    Next

    _Display

    _Limit 30

Loop


RE: Proggies - bplus - 09-04-2023

Wow @Dav I like! Smile

RE: Proggies - mrbcx - 09-05-2023

Really cool!   

It's surprising when so little code does so much work.

RE: Proggies - bplus - 09-05-2023

(09-05-2023, 03:22 AM)mrbcx Wrote: Really cool!   

It's surprising when so little code does so much work.

Yes that is sort of the theme to Proggies = little programs that animate usually.

RE: Proggies - grymmjack - 09-06-2023

(09-04-2023, 01:00 AM)Dav Wrote: Fun little code to play with!   Please forgive me for butting in, but I couldn't resist modding it too!

- Dav

Code: (Select All)


Dim w, h

w = 640

h = 640

Screen _NewImage(w, h, 32)

_ScreenMove 340, 60

Dim i, t, x, y

Do

    t = t + 0.01

    Line (0, 0)-(w, h), _RGBA(0, 0, 0, 25), BF

    For i = 1 To 8

        Color _RGBA(i * 32, i * 32 * .7, 0, i * 32)

        For x = 0 To w

            y = 100 * Sin(_Pi * x / w) * Sin(1 * _Pi * x / w + t + i * t * _Pi * 0.1)

            Circle (x, h / 2 + y), i

            Circle (w / 2 + y, x), i

        Next

    Next

    _Display

    _Limit 30

Loop

Awesome Smile Math is so pretty sometimes.

Well done!

RE: Proggies - bplus - 09-08-2023

Since we're trading explosions here's one that a search says I haven't posted yet:

le bombe

le bombe

Code: (Select All)
'Option _Explicit  'edit for QBJS 2023-09-08
_Title "le bombe"
'QB64 X 64 version 1.2 20180228/86  from git b301f92

'2018-07-28 translated from
'bomb.bas for SmallBASIC 0.12.2 [B+=MGA] 2016-05-09
'from explosion study

Const xmax = 800
Const ymax = 600
Screen _NewImage(xmax, ymax, 32)
'_ScreenMove 360, 60
Const max_particles = 1000
Const gravity = .25
Const air_resistance = .95
Type particle
    x As Single
    y As Single
    dx As Single
    dy As Single
    size As Single
    kolor As Long
    tf As Integer
End Type
Dim Shared dots(max_particles) As particle
Dim As Long i, rounds, loop_count
'main
While Not _KeyDown(27)
    For i = 1 To 100
        NewDot i
    Next
    rounds = 100
    For i = 12 To 0 Step -1
        If _KeyDown(27) Then End
        Cls
        DrawSky
        DrawGround
        DrawBomb
        DrawFuse i
        _Display
        If i = 0 Then _Delay Rnd * 3 Else _Delay .100
    Next
    Line (0, 0)-(xmax, ymax), _RGB32(255, 255, 255), BF
    _Display
    _Delay .02
    For loop_count = 0 To 150
        If _KeyDown(27) Then End
        DrawSky
        DrawGround
        If loop_count < 4 Then
            Color _RGB(64 - 8 * loop_count, 40 - 4 * loop_count, 32 - 4 * loop_count)
            If loop_count < 8 Then fcirc xmax / 2, ymax / 2, 30 * (1 - loop_count * .25)
        End If
        For i = 1 To rounds
            dots(i).x = dots(i).x + dots(i).dx
            dots(i).y = dots(i).y + dots(i).dy
            If Rnd < .2 And rounds > 10 And dots(i).y > ymax / 2 Then dots(i).dx = 0: dots(i).dy = 0
            dots(i).dx = dots(i).dx * air_resistance
            If dots(i).dy <> 0 Then dots(i).dy = air_resistance * dots(i).dy + .4 'air resistance and gravity
            If dots(i).tf Then
                Line (dots(i).x, dots(i).y)-Step(dots(i).size, dots(i).size), dots(i).kolor, BF
            Else
                Color dots(i).kolor
                fcirc dots(i).x, dots(i).y, dots(i).size / 2
            End If
        Next
        If rounds < max_particles Then
            For i = 1 To 100
                NewDot (rounds + i)
            Next
            rounds = rounds + 100
        End If
        Color _RGB32(255, 255, 255), _RGB32(0, 0, 255)
        Locate 1, 1: Print loop_count
        _Display
        _Limit 60
    Next
Wend

Sub NewDot (i)
    Dim angle, r
    angle = _Pi(Rnd * 2)
    dots(i).x = xmax / 2 + Rnd * 30 * Cos(angle)
    dots(i).y = ymax / 2 + Rnd * 30 * Sin(angle)
    r = Rnd 'STxAxTIC recommended for rounder spreads
    dots(i).dx = r * 45 * Cos(angle)
    dots(i).dy = r * 45 * Sin(angle)
    dots(i).size = Rnd * 7
    dots(i).kolor = _RGB32(10 + Rnd * 100, 5 + Rnd * 50, 3 + Rnd * 25)
    dots(i).tf = (Rnd * 2) \ 1
End Sub

Sub DrawSky
    Dim i
    For i = 0 To ymax / 2
        Line (0, i)-Step(xmax, 0), _RGB32(0, 0, 95 * i \ (ymax / 2) + 160)
    Next
End Sub

Sub DrawBomb
    Dim cx, cy, radius, angle, rad_angle, x1, y1
    Dim As Long i
    cx = xmax / 2: cy = ymax / 2 - 70: radius = 10
    For i = 60 To 0 Step -1 'main body
        Color _RGB32(240 - 4 * i, 180 - 3 * i, 120 - 2 * i)
        fcirc cx, ymax / 2, i
    Next

    For angle = 0 To 180 'fuse shaft
        rad_angle = _D2R(angle)
        x1 = cx + radius * Cos(rad_angle)
        y1 = cy + radius * .25 * Sin(rad_angle)
        Line (x1, y1)-Step(0, 20), _RGB32(127 + 127 * Cos(rad_angle), 127 + 127 * Cos(rad_angle), 127 + 127 * Cos(rad_angle))
    Next
    Color _RGB32(0, 0, 0)
    fEllipse cx, cy, radius, .25 * radius
End Sub

Sub DrawFuse (length)
    Dim cx, cy, rn, rad_angle, x1, y1, x2, y2
    Dim As Long i
    cx = xmax / 2: cy = ymax / 2 - 70
    If length <= 0 Then Exit Sub
    Color _RGB32(255, 255, 0)
    Line (cx, cy - (5 + 2 * length))-Step(2, 5), , BF
    fcirc cx, cy - (1 + 2 * length), 2
    rn = (Rnd * 5) \ 1 + 3
    For i = 1 To rn
        rad_angle = _Pi(Rnd) + _Pi
        x1 = cx + 7 * Cos(rad_angle): x2 = cx + 14 * Cos(rad_angle)
        y1 = cy - (1 + 2 * length) + 9 * Sin(rad_angle): y2 = cy - (1 + 2 * length) + (Rnd * 13 + 9) * Sin(rad_angle)
        Line (x1, y1)-(x2, y2), _RGB32(255, 255, 255)
    Next
    For i = 1 To length
        rad_angle = _Pi(Rnd * 2)
        x1 = 3 * Cos(rad_angle)
        y1 = 3 * .25 * Sin(rad_angle)
        Line (cx, cy - 2 * i)-Step(x1, y1), _RGB32(Rnd * 65 + 190, Rnd * 65 + 190, Rnd * 20 + 235), BF
    Next
End Sub

Sub DrawGround
    Dim As Long i
    For i = ymax / 2 To ymax
        Line (0, i)-Step(xmax, 0), _RGB32(0, 160 - 96 * (i - ymax / 2) \ (ymax / 2), 0)
    Next
End Sub

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

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


RE: Proggies - Dav - 09-09-2023

That’s a good one. I don’t think I’ve ever seen it before. Will be studying it.

- Dav

RE: Proggies - bplus - 09-21-2023

Plasma Laser Canon Pointer

Plasma Laser Canon Pointer

Code: (Select All)
'Option _Explicit
'_Title "Plasma Laser Cannon Pointer" ' for QBJS b+ 2023-09-21
' start mod from Plasma Laser Canon demo prep for GUI 2020-11-11

Screen _NewImage(1200, 600, 32)
Randomize Timer
Dim Shared As Long ShipLights
Dim Shared As _Unsigned Long ShipColor
Dim As Long cx, cy, mx, my, mb, sx, sy
Dim As Single ma, md, dx, dy
cy = _Height / 2: cx = _Width / 2
ShipColor = &HFF3366AA
'  _MouseHide '??? not supported and bad idea anyway
Do
    Cls
    While _MouseInput: Wend
    mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
    dx = mx - cx ' ship avoids collision with mouse
    dy = my - cy
    ma = _Atan2(dy, dx)
    md = Sqr(dy * dy + dx * dx)
    If md < 80 Then md = 80
    sx = cx + md * Cos(ma + 3.1415)
    sy = cy + md * Sin(ma + 3.1415)
    drawShip sx, sy, ShipColor
    If mb Then
        PLC sx, sy, mx, my, 10 ' Fire!
        ShipColor = _RGB32(Int(Rnd * 256), Int(Rnd * 136) + 120, Int(Rnd * 156) + 100)
    End If
    _Display
    _Limit 60
Loop Until _KeyDown(27)

Sub PLC (baseX, baseY, targetX, targetY, targetR) ' PLC for PlasmaLaserCannon
    Dim r, g, b, hp, ta, dist, dr, x, y, c, rr
    r = Rnd ^ 2 * Rnd: g = Rnd ^ 2 * Rnd: b = Rnd ^ 2 * Rnd: hp = _Pi(.5) ' red, green, blue, half pi
    ta = _Atan2(targetY - baseY, targetX - baseX) ' angle of target to cannon base
    dist = _Hypot(targetY - baseY, targetX - baseX) ' distance cannon to target
    dr = targetR / dist
    For r = 0 To dist Step .25
        x = baseX + r * Cos(ta)
        y = baseY + r * Sin(ta)
        c = c + .3
        Color _RGB32(128 + 127 * Sin(r * c), 128 + 127 * Sin(g * c), 128 + 127 * Sin(b * c))
        fcirc x, y, dr * r
    Next
    For rr = dr * r To 0 Step -.5
        c = c + 1
        Color _RGB32(128 + 127 * Sin(r * c), 128 + 127 * Sin(g * c), 128 + 127 * Sin(b * c))
        fcirc x, y, rr
    Next
End Sub

Sub drawShip (x, y, colr As _Unsigned Long) 'shipType     collisions same as circle x, y radius = 30
    ' shared here ShipLights

    Dim light As Long, r As Long, g As Long, b As Long
    r = _Red32(colr): g = _Green32(colr): b = _Blue32(colr)
    Color _RGB32(r, g - 120, b - 100)
    fEllipse x, y, 6, 15
    Color _RGB32(r, g - 60, b - 50)
    fEllipse x, y, 18, 11
    Color _RGB32(r, g, b)
    fEllipse x, y, 30, 7
    For light = 0 To 5
        Color _RGB32(ShipLights * 50, ShipLights * 50, ShipLights * 50)
        fcirc x - 30 + 11 * light + ShipLights, y, 1
    Next
    ShipLights = ShipLights + 1
    If ShipLights > 5 Then ShipLights = 0
End Sub

' these do work in QBJS without mod see le bombe
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

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


RE: Proggies - bplus - 09-27-2023

Lissajous Ball

Inspired by ZXDunny's here: https://friends-of-basic.freeforums.net/thread/277/specbas-unlimited-bobs

Code: (Select All)
_Title "Lissajous Ball" ' b+ 2023-09-26

' Electric Lissajous.bas for SmallBASIC 0.12.8 [B+=MGA] 2017-02-22

' port to QB64 trans 2017-10-31 by bplus"



' 2023-09-26 This, Inspired once again by ZXDunny

' ref https://friends-of-basic.freeforums.net/thread/277/specbas-unlimited-bobs



Const xmax = 1024

Const ymax = 700

Screen _NewImage(xmax, ymax, 32)

_ScreenMove 120, 20

ball& = _LoadImage("ball.png")

Color , &HFF000099

Cls

sc = ymax / 3

xc = xmax / 2

yc = ymax / 2

Dim bx(400), by(400)

While 1

    m = 3: n = 2: p = 4: q = 11

    For s = 0 To sc * .75 Step .05 * sc

        Cls

        Erase bx

        Erase by

        bx(1) = xc: by(1) = sc + yc: cnt = 0: rot = 0

        For t = 0 To _Pi(4) * (1 + _Pi(1 / 360)) Step _Pi(1 / 90)

            cnt = cnt + 1

            Cls

            Locate 1, 1: Print cnt

            rotsave = rot

            For i = 1 To cnt

                RotoZoom23r bx(i), by(i), ball&, .2, .2, rot

                rot = rot + _Pi(1 / 30)

            Next

            _Display

            _Limit 30

            rot = rotsave + _Pi(1 / 30)

            bx(cnt + 1) = 1.1 * (sc - s) * Sin(m * t) + 1.1 * 2 * s * Sin(p * t) + xc

            by(cnt + 1) = (sc - s) * Cos(n * t) + s * Cos(q * t) + yc

        Next

        _Display

        _Limit 10

    Next

    _Delay .8

Wend



' best  rev 2023-01-20 Jarvis with Steve change for eff  might need _Seamless next to _MapTriangle calls

Sub RotoZoom23r (centerX As Long, centerY As Long, Image As Long, xScale As Single, yScale As Single, radRotation As Single)

    'uses radians

    Dim As Long W, H, Wp, Hp, i, x2, y2

    Dim sinr!, cosr!

    Dim px(3) As Single: Dim py(3) As Single

    W& = _Width(Image&): H& = _Height(Image&)

    Wp& = W& / 2 * xScale

    Hp& = H& / 2 * yScale

    px(0) = -Wp&: py(0) = -Hp&: px(1) = -Wp&: py(1) = Hp&

    px(2) = Wp&: py(2) = Hp&: px(3) = Wp&: py(3) = -Hp&

    sinr! = Sin(-radRotation): cosr! = Cos(radRotation)

    For i& = 0 To 3

        ' x2& = (px(i&) * cosr! + sinr! * py(i&)) * xScale + centerX: y2& = (py(i&) * cosr! - px(i&) * sinr!) * yScale + centerY

        x2& = (px(i&) * cosr! + sinr! * py(i&)) + centerX: y2& = (py(i&) * cosr! - px(i&) * sinr!) + centerY

        px(i&) = x2&: py(i&) = y2&

    Next ' _Seamless? below

    _MapTriangle (0, 0)-(0, H& - 1)-(W& - 1, H& - 1), Image& To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))

    _MapTriangle (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

   

Image and code again in zip

RE: Proggies - Dav - 10-05-2023

Hey, @bplus!  Here's a little proggie for you.  Don't know what to call it, a hyptno-mezmerizing-thingamajig.  Too much time on my hands today...

- Dav