Login

Dav · 09-04-2023, 01:00 AM

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

bplus · 09-04-2023, 01:45 AM

Wow @Dav I like! Smile

mrbcx · 09-05-2023, 03:22 AM

Really cool!

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

bplus · 09-05-2023, 12:35 PM

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

***grymmjack*** · 09-06-2023, 12:14 AM

(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

Math is so pretty sometimes.

Well done!

bplus · (This post was last modified: 09-08-2023, 10:26 PM by bplus.)

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

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

Dav · 09-09-2023, 12:43 AM

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

- Dav

bplus · (This post was last modified: 09-21-2023, 06:44 PM by bplus.)

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

bplus · 09-27-2023, 03:16 AM

Lissajous Ball

Inspired by ZXDunny's here: https://friends-of-basic.freeforums.net/...mited-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/...mited-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

Filename: Lissajous Ball.PNG Size: 662.88 KB 09-27-2023, 03:15 AM

Image and code again in zip

Dav · 10-05-2023, 08:24 PM

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

Login
Username/Email:
Password:	Lost Password?
	Remember me