Proggies

[bplus]

2000th post here at Phoenix:

Code: (Select All)

_Title "Flower Wheel" ' b+ 2022-04?
Screen 12
Do
    Cls
    o = o + _Pi / 180
    drawc _Width / 2, _Height / 2, _Width / 5, .25, 4, o
    _Display
    _Limit 30
Loop

Sub drawc (x, y, r, a, n, o)
    If n > 0 Then
        For t = 0 To _Pi(2) Step _Pi(1 / 3)
            xx = x + r * Cos(t + o)
            yy = y + r * Sin(t + o)
            Circle (xx, yy), r
            drawc xx, yy, a * r, a, n - 1, -o - n * _Pi / 180
        Next
    End If
End Sub

[bplus]

While we're here, here is another:

Code: (Select All)

_Title "Easy Spiral" 'b+ 2022-04? from Easy Lang site very Interesting!  https://easylang.online
' this one inspired Johnno to post at RCBasic,  https://rcbasic.freeforums.net  , also an interesting site!
Screen _NewImage(700, 700, 32)
_ScreenMove 300, 100

pi = _Pi: s = 7
Do
    Cls
    For c = 1 To 3000 '1320
        h = c + tick
        x = Sin(6 * h / pi) + Sin(3 * h)
        h = c + tick * 2
        y = Cos(6 * h / pi) + Cos(3 * h)
        fcirc s * (20 * x + 50), s * (20 * y + 50), 2, &HFFFFFFFF
    Next
    _Display
    _Limit 120
    tick = tick + .001
Loop Until _KeyDown(27)

'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

[bplus]

Code: (Select All)

_Title "Infinite Heart" ' b+ 2022-02-14 trans from 2015
Const xmax = 698, ymax = 698, pi = 3.1415926
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 300, 20

Color , &HFFFFFFFF: Cls
x = (xmax - 600) / 2 - 1: y = (ymax - 1.15 * 600) / 2: wide = 600
drawdblheart x, y, wide
drawdblheart x + wide / 2 - wide / 32, y + 1.15 * wide / 4 + wide / 8, wide / 16
Color _RGB32(255, 0, 0)
PSet (x + wide / 2, y + 1.15 * wide / 4 + wide / 8 + wide / 32 - 3)
PSet (x + wide / 2 - 1, y + 1.15 * wide / 4 + wide / 8 + wide / 32 - 3)
PSet (x + wide / 2 - 2, y + 1.15 * wide / 4 + wide / 8 + wide / 32 - 3)
PSet (x + wide / 2 - 1, y + 1.15 * wide / 4 + wide / 8 + wide / 32 - 2)
Sleep

Sub drawblade (x, y, wide)
    scale = wide / 200
    sz = wide / 4
    yax = x + wide / 2
    lasty = y
    steps = 230 * scale - sz
    For da = 0 To 180 Step 180 / steps
        Line (yax - (1 - Cos(_D2R(da))) * sz, lasty)-(yax + (1 - Cos(_D2R(da))) * sz, lasty)
        lasty = lasty + 1
    Next
    fcirc yax - sz, y + 230 * scale - sz, sz, _RGB32(255, 255, 255)
    fcirc yax + sz, y + 230 * scale - sz, sz, _RGB32(255, 255, 255)
End Sub

Sub drawdblheart (x, y, wide)
    'for this heart height=wide*1.15
    scale = wide / 200
    sz = wide / 4
    yax = x + wide / 2
    lasty = y + 230 * scale
    steps = 230 * scale - sz
    For da = 0 To 180 Step 180 / steps
        Line (yax - (1 - Cos(_D2R(da))) * sz, lasty)-(yax + (1 - Cos(_D2R(da))) * sz, lasty), _RGB32(255, 0, 0)
        lasty = lasty - 1
    Next
    fcirc yax - sz, y + sz, sz, _RGB32(255, 0, 0)
    fcirc yax + sz, y + sz, sz, _RGB32(255, 0, 0)
    drawblade x + sz + sz / 2, y + sz, wide / 4
End Sub

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

Imagined very early on and drawn in SnallBASIC first I think.

[bplus]

Man I thought I had a decent Phoenix image but I like this one allot too!

and as requested by our Super Moderator a live fire!

Code: (Select All)

_Title "Test Rainbow 3 add fire" ' b+ 2022-05-15
' 2022-05-17  New image for risen above the fire

w = _DesktopWidth: h = _DesktopHeight: hd2 = h / 2
Screen _NewImage(w, h, 32)
_FullScreen

img& = _LoadImage("clipart4468176.png") ' !!!  thanks clipartmax !!!
' ref https://www.clipartmax.com/middle/m2H7d3G6d3i8H7Z5_phoenix-clipart-firebird-phoenix-bird-transparent-background/

dt = .001058321
For x = 0 To w
    For y = 0 To h
        r = Sin(1.1 * t) * hd2 - y + hd2
        Line (x, y)-Step(1, 1), _RGB(-r, r - y, r), BF ' white , blue,  red
    Next
    t = t + dt ' <<<<<<<<<<<< put this back in so the background is shaped
Next
_PutImage ((_Width - _Width(img&)) / 2, (_Height - _Height(img&)))-Step(_Width(img&), _Height(img&)), img&, 0
back& = _NewImage(_Width, _Height, 32)
_PutImage , 0, back&

xmax = w: ymax = h
xxmax = 500: yymax = 100 'pixels too slow
xstep = xmax / xxmax: ystep = ymax / yymax
Dim p~&(300) 'pallette
For i = 1 To 100
    fr = 240 * i / 100 + 15
    p~&(i) = _RGB32(fr, 0, 0)
    p~&(i + 100) = _RGB32(255, fr, 0)
    p~&(i + 200) = _RGB32(255, 255, fr)
Next
Dim f(xxmax, yymax + 2) 'fire array and seed
For x = 0 To xxmax
    f(x, yymax + 1) = Int(Rnd * 2) * 300
    f(x, yymax + 2) = 300
Next

While _KeyDown(27) = 0 'main fire
    _PutImage , back&, 0
    For x = 1 To xxmax - 1 'shift fire seed a bit
        r = Rnd
        If r < .15 Then
            f(x, yymax + 1) = f(x - 1, yymax + 1)
        ElseIf r < .3 Then
            f(x, yymax + 1) = f(x + 1, yymax + 1)
        ElseIf r < .35 Then
            f(x, yymax + 1) = Int(Rnd * 2) * 300
        End If
    Next
    For y = 0 To yymax 'fire based literally on 4 pixels below it like cellular automata
        For x = 1 To xxmax - 1
            f(x, y) = max((f(x - 1, y + 1) + f(x, y + 1) + f(x + 1, y + 1) + f(x - 1, y + 2)) / 4 - 5, 0)
            If f(x, y) > 100 Then
                Line (x * xstep, y * ystep)-Step(xstep, ystep), p~&(f(x, y)), BF
            End If
        Next
    Next
    _Display
Wend
Function max (a, b)
    If a > b Then max = a Else max = b
End Function

[bplus]

Here is b+ mod of Cantor's Dust, a Binary Tree I did some time ago for fun, now we could call it Cantor's Tree:

Code: (Select All)

_Title "Binary Tree AKA Cantor Tree" 'b+ 2022-05-19 trans from
' binary tree.bas  SmallBASIC 0.12.6 [B+=MGA] 2016-05-20
' line method added and posted with that mod 2016-05-22

xmax = 800: ymax = 600
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 250, 60
For i = 0 To ymax
    Line (0, i)-(xmax, i), _RGB32(0, 0, 120 + 100 * i / ymax)
Next
xlength = xmax
p2 = 2
ystart = ymax
Do
    xstart = xmax / p2
    yheight = (ymax - 150) / p2
    xlength = xlength / 2
    th = .2 * yheight
    For x = xstart To xmax - .5 Step 2 * xlength
        cc = 180 - ((yheight / ymax) * 255)
        brown~& = _RGB32(cc, cc * .5, cc * .25)
        Line (x, ystart - yheight)-Step(th, yheight), brown~&, BF
    Next
    ystart = ystart - (ymax - 150) / p2
    xhozstart = xstart / 2
    For x = xhozstart To xmax - .5 Step 2 * xlength
        cc = Rnd * 140: brown = _RGB32(cc, cc * .5, cc * .25)
        Line (x, ystart)-(x + xlength, ystart), brown~&
        Line (x, ystart - th)-Step(xlength + .5 * th, th + 2), brown~&, BF
    Next
    p2 = p2 * 2
Loop Until xlength / 2 < 1 Or yheight / 2 < 1
For i = 1 To 6000
    Line (Rnd * xmax, 24 + Rnd * 123)-Step(Rnd * 5 + 1, Rnd * 5 + 1), _RGB32(Rnd * 45, 65 + Rnd * 190, Rnd * 15), BF
Next
Sleep

   

[bplus]

Code: (Select All)

_Title "So how do you like b's, move mouse wheel" 'B+ 2019-03-06
'2020-05-13 add smile
'2022-05-19 fix eye angles , smile when dist away
Const smile = 1 / 3 * _Pi
Screen 12
Dim Shared mw, dist

Color , 3
_MouseHide
While _KeyDown(27) = 0 'until esc keypress
    Cls
    drawFace
    While _MouseInput
        mw = mw + _MouseWheel
        If mw > 100 Then mw = 100
        If mw < 5 Then mw = 5
    Wend
    mx = _MouseX: my = _MouseY
    dist = _Hypot(mx - 320, my - 240)
    angle = _Atan2(my - 240, mx - 320)
    angle1 = _Atan2(my - 240, mx - (320 - 75))
    angle2 = _Atan2(my - 240, mx - (320 + 75))
    x1 = 320 - 75 + 37 / 2 * Cos(angle1)
    y1 = 240 + 37 / 2 * Sin(angle1)
    x2 = 320 + 75 + 37 / 2 * Cos(angle2)
    y2 = 240 + 37 / 2 * Sin(angle2)
    FillCircle x1, y1, 37 / 2, 0
    FillCircle x2, y2, 37 / 2, 0

    ' bee on top
    For i = 1 To 8
        If i Mod 2 Then bc = 0 Else bc = 14
        FillCircle mx + i * 3, my + i * 3, 5, bc
    Next
    FillCircle mx - 15 + 20, my + 10, 8, 7
    FillCircle mx + 8 + 20, my + 5, 8, 7

    _Display 'prevent flicker
    _Limit 60 'save CPU fan
Wend

Sub drawFace
    FillCircle 320, 240, 150, 14 '<<<<<<<<<<<<<<<<< works for qb color numbers as well as rgb
    FillCircle 320 - 75, 240, 37, 9
    FillCircle 320 + 75, 240, 37, 9
    'FillCircle 320, 240 + 80, 20, 12
    arc 320, 240, 110, _Pi / 2 - smile * (.5 * mw / 100 + .5 * dist / 360), _Pi / 2 + smile * (.5 * mw / 100 + .5 * dist / 360), 12
End Sub

'fill circle
Sub FillCircle (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
    Dim Radius As Integer, RadiusError As Integer
    Dim X As Integer, Y As Integer

    Radius = Abs(R)
    RadiusError = -Radius
    X = Radius
    Y = 0

    If Radius = 0 Then PSet (CX, CY), C: 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), 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


'use radians
Sub arc (x, y, r, raStart, raStop, c As _Unsigned Long)
    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
            Circle (x + r * Cos(a), y + r * Sin(a)), 3, c '<<< modify for smile
        Next
    End If
End Sub

b+ mod b+

         

[SierraKen]

LOL that's pretty cool B+! You could make that into a game or something. I really need to start looking at these special places on the forum, thanks for telling me.

[bplus]

Lander in 30 LOC (but some double parking)

Code: (Select All)

Screen _NewImage(800, 640, 32) ' b+ Lander 30 LOC (double parking cheat) 2020-11-13
g& = _NewImage(800, 640, 32)
ReDim g(-100 To 200)
Do
    Cls: _KeyClear
    h = 30: dx = 1: x = 3: y = 2
    For i = -10 To 110
        If Rnd < .5 Then h = h + Int(Rnd * 3) - 1 Else h = h
        If h > 39 Then h = 39
        If h < 25 Then h = 25
        Line (i * 8, h * 16)-(i * 8 + 8, _Height), _RGB32(128), BF
        g(i) = h
        _PutImage , 0, g&
    Next
    While 1
        _PutImage , g&, 0
        Circle (x * 8 + 4, y * 16 + 8), 4, &HFF00FFFF
        Circle (x * 8, y * 16 + 16), 4, &HFFFFFF00, 0, _Pi
        Circle (x * 8 + 8, y * 16 + 16), 4, &HFFFFFF00, 0, _Pi
        If y >= g(x - 1) Or y >= g(x + 1) Or y >= g(x) Or y >= 40 Or x < -5 Or x > 105 Then _PrintString (46 * 8, 2 * 16), "Crash": Exit While
        If y = g(x - 1) - 1 And y = g(x + 1) - 1 Then _PrintString (46 * 8, 2 * 16), "Landed": Exit While
        kh& = _KeyHit
        If kh& = 19200 Or kh& = 97 Then dx = dx - 1
        If kh& = 19712 Or kh& = 100 Then dx = dx + 1
        If kh& = 18432 Or kh& = 119 Then y = y - 5
        x = x + dx: y = y + 1
        _Limit 2
    Wend
    _Delay 2
Loop
' 2020-11-15 fix off-sides x, add alternate keys: a=left d=right w=up  so now arrow keys or WAD system works

   

[bplus]

Here's a nice one from Ashish:

Code: (Select All)

_Title "Arc Wave!"
Screen _NewImage(600, 600, 32)
angOffset# = 0
Do
    Cls
    For i = 1 To 30
        r = i * 8
        drawArc _Width / 2, _Height / 2, r, _Pi, _Pi + Abs(Sin(angOffset# + i / 10) * _Pi)
    Next
    angOffset# = angOffset# + .01
    _Display
    _Limit 60
Loop

Sub drawArc (xx, yy, r, s#, e#)
    px = Cos(s#) * r + xx
    py = Sin(s#) * r + yy
    For i = s# To e# Step .02
        x = Cos(i) * r + xx
        y = Sin(i) * r + yy
        Line (x, y)-(px, py)
        px = x
        py = y
    Next
End Sub

   

[Dav]

Oh man this thread has some goodies in it!  Excellent stuff. 

- Dav