Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
Proggies
Sweet.

Here's what I had done in BAM, nothing fancy, hoping it can be easily ported to any BASIC:
Reply
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


Attached Files Image(s)
   
b = b + ...
Reply
I never cease to be amazed at what can be achieved with a few lines of code!
Incredible!  Big Grin
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, W.A.) Big Grin
Please visit my Website at: http://oldendayskids.blogspot.com/
Reply
(01-29-2024, 11:24 PM)PhilOfPerth Wrote: I never cease to be amazed at what can be achieved with a few lines of code!
Incredible!  Big Grin

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?
b = b + ...
Reply
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

   
b = b + ...
Reply
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
b = b + ...
Reply
nice mod, looks like video game water
Reply
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
   
b = b + ...
Reply
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

   
b = b + ...
Reply
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

   
b = b + ...
Reply




Users browsing this thread: 2 Guest(s)