Fractals

[TarotRedhand]

Back in January 2020 I noticed something in the weather (specifically the winds and their direction). This is a snapshot of what the winds were doing in the North Atlantic at that time -



Note I have tweaked the colours to make it stand out more. If you look to the west of the Spanish peninsula you will see a double area of low pressure that looks remarkably similar to the Lorenz attractor fractal -

Note I have tweaked the colours to make it stand out more. If you look to the west of the Spanish peninsula you will see a double area of low pressure that looks remarkably similar to the Lorenz attractor fractal 


TR

[bplus]

Sierpinski Circled

Code: (Select All)

_Title "Sierpinski Circled by bplus"
'2018-07-23 update some code tweaks learned when translating this to other BASIC flavors
'for new ORG avatar?
Const xmax = 740
Const ymax = 740
Randomize Timer
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 360, 5
Dim Shared cx, cy, cr, ra, inc
cx = xmax / 2: cy = ymax / 2: cr = ymax / 6: inc = _Pi(1 / 360)
Color _RGBA(100, 255, 100, 40), _RGB32(0, 0, 0)
For n = 3 To 8
    a = 0
    ra = _Pi(2) / n
    While a < ra
        Cls
        levels = 12 - n
        RecurringCircles cx, cy, cr, n, a, levels
        a = a + inc
        _Display
        _Limit 5
    Wend
    Cls
    RecurringCircles cx, cy, cr, n, 0, levels
    _Display
    _Limit 10
Next
Sub RecurringCircles (x, y, r, n, rao, level)
    fcirc x, y, r
    If level > 0 Then
        For i = 0 To n - 1
            x1 = x + 1.5 * r * Cos(i * ra + rao + _Pi(-.5))
            y1 = y + 1.5 * r * Sin(i * ra + rao + _Pi(-.5))
            RecurringCircles x1, y1, r * .5, n, 2 * rao, level - 1
        Next
    End If
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

   

[bplus]

Classic Fern Swaying in the Wind

Code: (Select All)

_Title "Classic Fern sway in wind mod, press spacebar for new landscape, esc to quit" 'b+ 2020-08-06
Screen _NewImage(1000, 600, 32)
_Delay .25
_ScreenMove _Middle
Window (-5, 0)-(5, 11)
Randomize Timer

Type obj
    x As Single 'offset from centered fern
    y As Single 'offest from centered fern
    scale As Single ' from 0 to 1
    c As _Unsigned Long
End Type

Dim Shared nFerns
ReDim Shared fern(1 To nFerns) As obj

initFerns
wind = 0: dw = .01: dir = 1
While _KeyDown(27) = 0
    If InKey$ = " " Then initFerns
    For i = 4 To 11 Step .2
        Line (-5, i)-(5, i + .2), _RGB32(60, (1 - i / 11) * 150 + 60, (1 - i / 11) * 75 + 180), BF
    Next
    For i = 0 To 4 Step .2
        Line (-5, i)-(5, i + .2), _RGB32(i / 4 * 90 + 10, i / 4 * 45 + 5, i / 4 * 22 + 2), BF
    Next
    For i = 1 To nFerns
        drawFern fern(i).x, fern(i).y, fern(i).scale, fern(i).c, wind
    Next

    _Display
    _Limit 10
    wind = wind + dir * dw
    If wind > .06 Or wind < -.72 Then dir = -dir
Wend

Sub initFerns
    nFerns = 4 + Int(Rnd * 9)
    ReDim fern(1 To nFerns) As obj
    For i = 1 To nFerns
        fern(i).x = Rnd * 10 - 5
        fern(i).y = Rnd * 2 - 1
        fern(i).scale = Rnd * .7 + .3
        g = Rnd * 100 + 40
        fern(i).c = _RGB32(g - 20 - Rnd * 60, g, g - 20 - Rnd * 60)
    Next
End Sub

Sub drawFern (xoff0, yoff0, scale, c As _Unsigned Long, w)
    yAdj = yoff0 + (1 - scale) * 5
    For i = 1 To 90000 'enough dots to get idea
        Select Case Rnd
            Case Is < .01
                nextX = 0
                nextY = .16 * y
            Case .01 TO .08
                nextX = .2 * x - .26 * y
                nextY = .23 * x + .22 * y + 1.6
            Case .08 TO .15
                nextX = -.15 * x + .28 * y
                nextY = .26 * x + .24 * y + .44
            Case Else
                nextX = .85 * x + .04 * y
                nextY = -.04 * x + .85 * y + 1.6
        End Select
        x = nextX + w * nextY / 10
        y = nextY
        Line (x * scale + xoff0, y * scale + yAdj)-Step(0, 0), c, BF
    Next
End Sub

Occasionally with these ferns you get a sighting of the Fernerator
   

[bplus]

Koch Curve (Snow flake)

Thankyou @triggered for this cool method for doing the Koch Curve. I have modified code to show how fractal builds:

Code: (Select All)

_Title "Koch Curve" '  by triggered mod b+ 2022-06-02
Screen _NewImage(700, 700, 12) ' b+ mod tirggered Koch curve
_ScreenMove 300, 20
mx = _Width / 2: my = _Height / 2
Dim a$

a$ = "FRRFRRF"
ss = 600
Circle (mx, my), 1
Circle (mx, my), ss / Sqr(3)
x0 = _Width / 2 + ss / Sqr(3) * Cos(_D2R(210))
y0 = _Height / 2 + ss / Sqr(3) * Sin(_D2R(210))
Dim j, k
For k = 1 To 2
    a$ = "FRRFRRF"
    ss = 600
    TurtleGraphics x0, y0, 0, ss, a$
    _Delay 5
    For j = 1 To 5
        If k = 2 Then Cls
        ss = ss / 3
        a$ = stReplace$(a$, "F", "FLFRRFLF")
        TurtleGraphics x0, y0, 0, ss, a$
        _Delay 1 ' pause 2 x's per sec
    Next j
    If k <> 2 And j <> 5 Then Cls
Next
Sleep

Sub TurtleGraphics (x0 As Double, y0 As Double, a0 As Double, ssize As Double, path As String)
    Dim As Double x, y, angle, stepsize
    Dim w As String
    Dim t As String
    x = x0
    y = y0
    angle = a0
    w = path
    stepsize = ssize

    PReset (x0, y0)

    Do While Len(w)
        t = Left$(w, 1)
        w = Right$(w, Len(w) - 1)
        Select Case t
            Case "F"
                x = x + stepsize * Cos(angle)
                y = y + stepsize * Sin(angle)
            Case "L"
                angle = angle - 60 * _Pi / 180
            Case "R"
                angle = angle + 60 * _Pi / 180
        End Select
        Line -(x, y), 15
    Loop
End Sub

Function stReplace$ (a As String, b As String, c As String)
    Dim i As Integer
    Dim g As String
    Dim r As String
    For i = 1 To Len(a)
        g = Mid$(a, i, 1)
        If g = b Then
            r = r + c
        Else
            r = r + g
        End If
    Next
    stReplace = r
End Function

[bplus]

I liked that method so much I tried it with a square:

Koch Squared

Code: (Select All)

_Title "Koch Squared" '  by triggered mod b+ 2022-06-02
Screen _NewImage(700, 700, 12) ' b+ mod tirggered Koch curve
_ScreenMove 300, 20
mx = _Width / 2: my = _Height / 2
Dim a$
ss = 350
x0 = _Width / 2 + .5 * ss * Sqr(2) * Cos(_D2R(225))
y0 = _Height / 2 + ss / Sqr(2) * Sin(_D2R(225))
For k = 1 To 2
    a$ = "FRFRFRF"
    ss = 350
    TurtleGraphics x0, y0, 0, ss, a$
    _Delay 1
    For j = 1 To 5
        If k = 2 Then Cls
        ss = ss / 3
        a$ = stReplace$(a$, "F", "FLFRFRFLF")
        TurtleGraphics x0, y0, 0, ss, a$
        _Delay 1 ' pause 2 x's per sec
    Next j
    If k <> 2 And j <> 5 Then Cls
Next k
Sleep

Sub TurtleGraphics (x0 As Double, y0 As Double, a0 As Double, ssize As Double, path As String)
    Dim As Double x, y, angle, stepsize
    Dim w As String
    Dim t As String
    x = x0
    y = y0
    angle = a0
    w = path
    stepsize = ssize

    PReset (x0, y0)

    Do While Len(w)
        t = Left$(w, 1)
        w = Right$(w, Len(w) - 1)
        Select Case t
            Case "F"
                x = x + stepsize * Cos(angle)
                y = y + stepsize * Sin(angle)
            Case "L"
                angle = angle - 90 * _Pi / 180
            Case "R"
                angle = angle + 90 * _Pi / 180
        End Select
        Line -(x, y), 15
    Loop
End Sub

Function stReplace$ (a As String, b As String, c As String)
    Dim i As Integer
    Dim g As String
    Dim r As String
    For i = 1 To Len(a)
        g = Mid$(a, i, 1)
        If g = b Then
            r = r + c
        Else
            r = r + g
        End If
    Next
    stReplace = r
End Function