Proggies

[bplus]

Update: Retitle this thread "Proggies" for very short snippets to demo some method or just a fun little ditty, from me, probably a graphics thingy.
Refining what a Proggie is, I would say 100 lines more or less and only one bas source file, images graphically drawn and sound not from a 2nd file either.

Fell free to join in if you have a mod, that's my MO! Please include: "Mod Your_Avatar_Name" in the _Title at start and a date would not be unwelcome.

_________________________________________________________________________________________________________________________

Light up your balls: Double color shifting with balls example. I modified my regular drawBall sub for this demo.

MidInk is a very, very handy Function for getting a color somewhere between two colors using a fraction between 0 = the first color and 1 the 2nd color so .5 would be halfway between them.

Code: (Select All)

_Title "Light up your balls" 'b+ 2022-04-24
Screen _NewImage(800, 600, 32)
_ScreenMove 300, 40
Randomize Timer
balls = 25
Dim r(balls), x(balls), y(balls), c~&(balls)
For i = 1 To balls
    r(i) = Rnd * 80 + 15
    x(i) = Rnd * _Width
    y(i) = Rnd * _Height
    c~&(i) = _RGB32(Rnd * 100, Rnd * 100, Rnd * 100)
Next
For f## = 0 To 1 Step .01
    Cls
    For b = 0 To balls
        rr = _Red32(c~&(b)): gg = _Green32(c~&(b)): bb = _Blue32(c~&(b))
        m~& = midInk~&(rr, gg, bb, 255, 255, 255, f##)
        drawBall x(b), y(b), r(b), m~&
    Next
    Print f##
    _Display
    _Limit 10
Next

Function midInk~& (r1%, g1%, b1%, r2%, g2%, b2%, fr##)
    midInk~& = _RGB32(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)
End Function

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 = .5 * (1 - rr / r) + .5
        fcirc x, y, rr, _RGB32(rred * f, grn * f, blu * f)
    Next
End Sub

'from Steve Gold standard
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