Proggies

[CharlieJV]

Sweet.

Here's what I had done in BAM, nothing fancy, hoping it can be easily ported to any BASIC:

• Run the program
  
• View the source code
  

[bplus]

Cardioid and Beyond

Johnno called this Animated String Art in his RCBasic mod but failed to add Plasma Coloring Effect which makes a big difference IMO.

Code: (Select All)

_Title "Cardioid and Beyond" 'B+ 2019-02-17
Const xmax = 700
Const ymax = 700
Const npoints = 200
Screen _NewImage(xmax, ymax, 32)
Dim Shared pR, pG, pB, cN
CX = xmax / 2
CY = ymax / 2
DA = _Pi(2 / npoints)
R = CX - 10

For Mult = 0 To 100 Step .01
    Cls
    Color &HFFFFFFFF
    Print "Multiple: ";
    Print Using "###.##"; Mult
    If Mult = Int(Mult) Then resetPlasma
    Circle (CX, CY), R, _RGB32(0, 128, 0)
    For i = 1 To 200
        x1 = CX + R * Cos(i * DA)
        y1 = CY + R * Sin(i * DA)
        x2 = CX + R * Cos(Mult * i * DA)
        y2 = CY + R * Sin(Mult * i * DA)
        changePlasma
        Line (x1, y1)-(x2, y2)
    Next
    _Display
    _Limit 30
Next

Sub changePlasma ()
    cN = cN + 1
    Color _RGB(127 + 127 * Sin(pR * cN), 127 + 127 * Sin(pG * cN), 127 + 127 * Sin(pB * cN))
End Sub

Sub resetPlasma ()
    pR = Rnd ^ 2: pG = Rnd ^ 2: pB = Rnd ^ 2
End Sub

[PhilOfPerth]

I never cease to be amazed at what can be achieved with a few lines of code!
Incredible! 

[bplus]

I never cease to be amazed at what can be achieved with a few lines of code!
Incredible! 

absolutely! I wonder going through this collection and other similar little gems, how many involve sin and cos and if there is some other commonalities?

[bplus]

Shamrocks!

Code: (Select All)

_Title "N Leafed Shamrocks, How many shamrocks until you get a 7 leafed one?    by bplus 2018-03-09"
' Shamrock 2018-03-09 mod to lessons learned with JB version 2018-03-09 tsh tips
' from N Leafed Shamrocks 2018-03-08
' Draw Angled Heart.bas SmallBASIC 0.12.11 (B+=MGA) 2018-03-07
Randomize Timer
Const xmax = 1280
Const ymax = 740
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 70, 0
Dim counts(7)
Cls , _RGB32(60, 30, 15)
While nLeafs < 7
    luck = Rnd
    Select Case luck
        Case Is < 1 / 625: nLeafs = 7
        Case Is < 1 / 125: nLeafs = 6
        Case Is < 1 / 25: nLeafs = 5
        Case Is < 1 / 5: nLeafs = 4
        Case Else: nLeafs = 3
    End Select
    counts(nLeafs) = counts(nLeafs) + 1
    counts(1) = counts(1) + 1
    stat$ = Str$(counts(3))
    For i = 4 To 7
        stat$ = stat$ + " :" + Str$(counts(i))
    Next
    stat$ = stat$ + " =" + Str$(counts(1))
    _Title stat$ + " N Leafed Shamrocks, How many shamrocks until you get a 7 leafed one? (1 in 625 chance)  by bplus 2018-03-09"
    cc1% = Rnd * 100 + 50
    cc2% = Rnd * 100 + 50
    While Abs(cc1% - cc2%) < 30 'for contrast of 2 colors
        cc2% = Rnd * 100 + 50
    Wend
    xp = Rnd * (xmax - 100) + 50
    yp = Rnd * (ymax - 100) + 50
    size = Int(Rnd * 40) + 10
    ang = Rnd * _Pi(2)
    Color _RGB32(0, cc1%, 0)
    drawShamrockN xp + 1, yp, size, ang, nLeafs, 1
    Color _RGB32(0, cc2%, 0)
    For r = 1 To size Step 1
        drawShamrockN xp, yp, r, ang, nLeafs, 0
    Next
    _Display
    _Limit 10
Wend
Sleep

'draws an arc with center at xCenter, yCenter, radius from center is arcRadius
Sub myArc (xCenter, yCenter, arcRadius, dAStart, dAMeasure)
    'notes:
    'you may want to adjust size and color for line drawing
    'using angle measures in degrees to match Just Basic ways with pie and piefilled
    'this sub assumes drawing in a CW direction if dAMeasure positive

    'for Just Basic angle 0 degrees is due East and angle increases clockwise towards South

    'dAStart is degrees to start Angle, due East is 0 degrees

    'dAMeasure is degrees added (Clockwise) to dAstart for end of arc

    rAngleStart = RAD(dAStart)
    rAngleEnd = RAD(dAMeasure) + rAngleStart
    Stepper = RAD(1 / (.1 * arcRadius)) 'fixed
    For rAngle = rAngleStart To rAngleEnd Step Stepper
        If rAngle = rAngleStart Then
            lastX = xCenter + arcRadius * Cos(rAngle)
            lastY = yCenter + arcRadius * Sin(rAngle)
        Else
            nextX = xCenter + arcRadius * Cos(rAngle)
            If nextX <= lastX Then useX = nextX - 1 Else useX = nextX + 1
            nextY = yCenter + arcRadius * Sin(rAngle)
            If nextY <= lastY Then useY = nextY - 1 Else useY = nextY + 1
            Line (lastX, lastY)-(nextX, nextY)
            lastX = nextX
            lastY = nextY
        End If
    Next
End Sub

Function RAD (a)
    RAD = _Pi(a / 180)
End Function

Function DEG (a)
    DEG = a * 180 / _Pi
End Function

Sub drawHeart (x, y, r, rl, a, solid)
    'local x1, x2, x3, x4, x5, x6, y1, y2, y3, y4, y5, y6
    'clockwise from due East, the V
    x1 = x + r * Cos(a)
    y1 = y + r * Sin(a)
    x2 = x + rl * Cos(a + _Pi / 2)
    y2 = y + rl * Sin(a + _Pi / 2)
    x3 = x + r * Cos(a + _Pi)
    y3 = y + r * Sin(a + _Pi)
    x4 = x + r * Cos(a + 3 * _Pi / 2)
    y4 = y + r * Sin(a + 3 * _Pi / 2)
    x5 = (x3 + x4) / 2
    y5 = (y3 + y4) / 2
    x6 = (x4 + x1) / 2
    y6 = (y4 + y1) / 2
    If solid Then
        filltri x1, y1, x2, y2, x3, y3
        filltri x2, y2, x3, y3, x4, y4
        fcirc x5, y5, .5 * r * 2 ^ .5
        fcirc x6, y6, .5 * r * 2 ^ .5
    Else
        Line (x1, y1)-(x2, y2)
        Line (x2, y2)-(x3, y3)
        'left hump
        myArc x5, y5, .5 * r * 2 ^ .5, DEG(a) + 135, 180
        'right hump
        myArc x6, y6, .5 * r * 2 ^ .5, DEG(a) + 225, 180
    End If
End Sub

Sub drawShamrockN (x, y, r, a, nLeafed, solid)
    bigR = 2.05 * r * nLeafed / (2 * _Pi) '<<<<<<<<<<<< EDIT for fuller leaves
    For leaf = 0 To nLeafed - 1
        x1 = x + bigR * Cos(a + leaf * 2 * _Pi / nLeafed + 3 * _Pi / 2)
        y1 = y + bigR * Sin(a + leaf * 2 * _Pi / nLeafed + 3 * _Pi / 2)
        drawHeart x1, y1, r, bigR, a + leaf * 2 * _Pi / nLeafed, solid
    Next
End Sub

'Steve McNeil's  copied from his forum   note: Radius is too common a name
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 filltri (xx1, yy1, xx2, yy2, xx3, yy3)
    'make copies before swapping
    x1 = xx1: y1 = yy1: x2 = xx2: y2 = yy2: x3 = xx3: y3 = yy3
    'thanks Andy Amaya!
    'triangle coordinates must be ordered: where x1 < x2 < x3
    If x2 < x1 Then Swap x1, x2: Swap y1, y2
    If x3 < x1 Then Swap x1, x3: Swap y1, y3
    If x3 < x2 Then Swap x2, x3: Swap y2, y3
    If x1 <> x3 Then slope1 = (y3 - y1) / (x3 - x1)

    'draw the first half of the triangle
    length = x2 - x1
    If length <> 0 Then
        slope2 = (y2 - y1) / (x2 - x1)
        For x = 0 To length
            Line (Int(x + x1), Int(x * slope1 + y1))-(Int(x + x1), Int(x * slope2 + y1))
            'lastx2% = lastx%
            lastx% = Int(x + x1)
        Next
    End If

    'draw the second half of the triangle
    y = length * slope1 + y1: length = x3 - x2
    If length <> 0 Then
        slope3 = (y3 - y2) / (x3 - x2)
        For x = 0 To length
            'IF INT(x + x2) <> lastx% AND INT(x + x2) <> lastx2% THEN  'works! but need 2nd? check
            If Int(x + x2) <> lastx% Then
                Line (Int(x + x2), Int(x * slope1 + y))-(Int(x + x2), Int(x * slope3 + y2))
            End If
        Next
    End If
End Sub

   

[bplus]

Flower Wheel 2

Code: (Select All)

_Title "Flower Wheel 2" ' b+ 2024-03-24
Screen _NewImage(700, 700, 32)
_ScreenMove 300, 40
Do
    Cls
    o = o + _Pi / 180
    drawc _Width / 2, _Height / 2, _Width / 4.1, .45, 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, _RGB32(t * 40 - 60, t * 40 - 60, 128, n * 63)
            Circle (xx, yy), r - 1, _RGB32(t * 30 - 60, t * 30 - 60, 128, n * 63)
            Circle (xx, yy), r - 2, _RGB32(t * 30 - 60, t * 30 - 60, 128, n * 63)
            drawc xx, yy, a * r, a, n - 1, -1.5 * o - n * _Pi / 180
        Next
    End If
End Sub

   

oh perfect! https://www.youtube.com/watch?v=uVXR2LYeFBI

[vince]

nice mod, looks like video game water

[bplus]

Metatrons Cube

Code: (Select All)

_Title "Metatrons Cube" ' b+ 2024-03-25
Screen _NewImage(700, 700, 32)
_ScreenMove 300, 40
cx = 350: cy = 350: r = 50
a = _Pi(2 / 6)
Dim ix(5), iy(5), ox(5), oi(5)
For i = 0 To 5
    ix(i) = cx + 2 * r * Cos(a * i - _Pi / 2)
    iy(i) = cy + 2 * r * Sin(a * i - _Pi / 2)
    ox(i) = cx + 4 * r * Cos(a * i - _Pi / 2)
    oy(i) = cy + 4 * r * Sin(a * i - _Pi / 2)
Next
Circle (cx, cy), r
For i = 0 To 5
    Circle (ix(i), iy(i)), r
    For j = 0 To 5
        Circle (ox(j), oy(j)), r
        If j <> i Then
            Line (ix(i), iy(i))-(ix(j), iy(j))
            Line (ix(i), iy(i))-(ox(j), oy(j))
            Line (ox(i), oy(i))-(ox(j), oy(j))
        End If
    Next
Next

   

some animation

Code: (Select All)

_Title "Metatrons Cube 2" ' b+ 2024-03-26
Screen _NewImage(700, 700, 32)
_ScreenMove 300, 40
cx = 350: cy = 350: r = 20
a = _Pi(2 / 6)
Dim ix(5), iy(5), ox(5), oi(5)
For cr = r To 8 * r Step .1
    Cls
    For i = 0 To 5
        ix(i) = cx + 2 * r * Cos(a * i - _Pi / 2)
        iy(i) = cy + 2 * r * Sin(a * i - _Pi / 2)
        ox(i) = cx + 4 * r * Cos(a * i - _Pi / 2)
        oy(i) = cy + 4 * r * Sin(a * i - _Pi / 2)
    Next
    Circle (cx, cy), cr, &HFF0000FF
    Circle (cx, cy), cr - 1, &HFF0000FF
    Circle (cx, cy), cr - 2, &HFF0000FF
    For i = 0 To 5
        Circle (ix(i), iy(i)), cr, &HFFFFFF00
        Circle (ix(i), iy(i)), cr - 1, &HFFFFFF00
        For j = 0 To 5
            Circle (ox(j), oy(j)), cr, &HFFFF0000
            If j <> i Then
                Line (ix(i), iy(i))-(ix(j), iy(j))
                Line (ix(i), iy(i))-(ox(j), oy(j))
                Line (ox(i), oy(i))-(ox(j), oy(j))
            End If
        Next
    Next
    _Display
    _Limit 30
Next

   

[bplus]

Orbit Demo - Make Hairy Wreath

Code: (Select All)

_Title "orbit demo make hairy wreath " 'b+ 2024-05-11
Const Xmax = 700, Ymax = 700
Screen _NewImage(Xmax, Ymax, 32)
_ScreenMove 290, 20
Randomize Timer
x = _Width / 2: y = _Height / 2 ' start in center of screen
pentAngle = 72 ' the angles inside a pentagram are 360 / 5 = 72 degrees
forward = 10
angle = -36
stepper = 1
r = Rnd * Rnd: g = Rnd * Rnd: b = Rnd * Rnd: dc = 0
Do Until _KeyDown(27)
    orbit _Width / 2, _Height / 2, Rnd * 360, 200, x, y
    loops = loops + 1
    Locate 1, 1: Print loops
    If loops = 10 Then Cls: loops = 0: r = Rnd * Rnd: g = Rnd * Rnd: b = Rnd * Rnd: dc = 0
    While y > 0 And y < _Height
        orbit x, y, angle, forward, nextx, nexty
        Color _RGB32(127 + 127 * Sin(r * dc), 127 + 127 * Sin(g * dc), 127 + 127 * Sin(b * dc))
        Line (x, y)-(nextx, nexty)
        forward = forward - stepper
        If forward < 0 Then
            forward = 20
            orbit _Width / 2, _Height / 2, Rnd * 360, 200, nextx, nexty
            angle = Rnd * 360
            pentAngle = Rnd * 90
            If Rnd < .5 Then pentAngle = -pentAngle
            stepper = Rnd * 3 + .5
            dc = dc + .00936
        End If
        angle = angle + pentAngle ' the absolute angle from 0 degrees accumulates at every turn
        x = nextx: y = nexty '      restart where we left off
        _Limit 2000
    Wend
Loop
'      !!!!!!   featuring the use of this SUB routine   !!!!
Sub orbit (X_Origin, Y_Origin, Degrees, Radius, xOut, yOut) ' all default single  should be ok
    xOut = X_Origin + Radius * Cos(_D2R(Degrees))
    yOut = Y_Origin + Radius * Sin(_D2R(Degrees))
End Sub

   

[bplus]

Curlies

Code: (Select All)

Screen _NewImage(1200, 700, 12)
_ScreenMove 40, 20
Color 15, 4
For j = 3.14 To 6.28 Step .0314
    Cls: c = c + 1: Print c, "press any..."
    x = 600: x1 = x: y = 350: f = 0
    For z = 1 To 200000
        f = f + j: g = f * f * .25
        x = x + Cos(g): x1 = x1 - Cos(g)
        y = y + Sin(g): p = z Mod 255
        PSet (x, y), _RGB(p, p, p)
        PSet (x1, y), _RGB(p, p, p)
    Next
    Sleep
Next