Fractals

[bplus]

Here is my favorite of all time! I imagined it in college 1976 let's say, way before I've heard term fractals and it took 40 years to get around to drawing it as imagined thanks to Alpha coloring in QB64, sort of had it with SmallBASIC but needed alpha to get the full spectrum of shading of overlapping squares. 

Code: (Select All)

_Title "recurring squares 2017-10-26 by bplus"
' Now with Alpha coloring!
'reoccuring squares SmallBASIC translation from
Rem reoccuring squares NaaLaa started 2015-05-14 MGA/B+

Const xmax = 700
Const ymax = 700

Screen _NewImage(xmax, ymax, 32)
_ScreenMove 360, 30 'adjust as needed _MIDDLE needs a delay .5 or more for me
Common Shared dimmer
sq = 700: dir = 1
While 1
    Cls
    white& = _RGB(255, 255, 255)
    fRecStep 0, 0, sq, sq, white&
    sqPlus sq / 2, sq / 2, sq / 2
    _Display
    _Limit 20
    dimmer = dimmer + dir
    If dimmer > 255 Then dimmer = 255: dir = dir * -1: _Delay .5
    If dimmer < 0 Then dimmer = 0: dir = dir * -1: _Delay .5
Wend

Sub fRecStep (x1, y1, x2, y2, c&)
    Line (x1, y1)-Step(x2, y2), c&, BF
End Sub

Sub sqPlus (x, y, side)
    cx = x - side / 2: cy = y - side / 2
    fRecStep cx, cy, side, side, _RGBA(0, 0, 0, dimmer)
    If side < 10 Then Exit Sub
    ns = side / 2: nc = colorNumber - 35
    sqPlus cx, cy, ns
    sqPlus cx + side, cy, ns
    sqPlus cx, cy + side, ns
    sqPlus cx + side, cy + side, ns
End Sub

   
I have an 40 year old Ink Wash Drawing that looks very close to this snapshot.

[bplus]

Sierpinski Flies a Kite

Here is probably my 2nd favorite fractal, a happy accident while playing around with Ashish Kite fractal.

Code: (Select All)

_Title "Sierpinski flies a kite by bplus 2017-10-16"
' after playing with Ashish Kite Fractal

Screen _NewImage(1200, 700, 32)
_ScreenMove 100, 20
While 1
    Cls
    drawKite 600, 540, 200, a
    _Display
    _Limit 20
    a = a + _Pi(2 / 360)
Wend
Sleep
Sub drawKite (xx, yy, s, a)
    x = xx: y = yy
    x2 = x + 3 * s * Cos(_Pi(1 / 2) - a / 2): y2 = y + 3 * s * Sin(_Pi(1 / 2) - a / 2)
    x3 = x + 3 * s * Cos(_Pi(1 / 2) + a / 2): y3 = y + 3 * s * Sin(_Pi(1 / 2) + a / 2)
    SierLineTri x, y, x2, y2, x3, y3, 0
    'LINE (x, y)-(x + s * COS(_PI(2) - a / 2), (y - s) + s * SIN(_PI(2) - a / 2))
    'LINE (x, y)-(x + s * COS(_PI + a / 2), (y - s) + s * SIN(_PI + a / 2))

    If s > 10 Then
        drawKite x + 1 * s * Cos(_Pi(2) - a), (y - s) + 1 * s * Sin(_Pi(2) - a), s / 2, a
        drawKite x + 1 * s * Cos(_Pi + a), (y - s) + 1 * s * Sin(_Pi + a), s / 2, a
    End If
End Sub
Sub SierLineTri (x1, y1, x2, y2, x3, y3, depth)
    If depth = 0 Then 'draw out triangle if level 0
        Line (x1, y1)-(x2, y2)
        Line (x2, y2)-(x3, y3)
        Line (x1, y1)-(x3, y3)
    End If
    'find midpoints
    If x2 < x1 Then mx1 = (x1 - x2) / 2 + x2 Else mx1 = (x2 - x1) / 2 + x1
    If y2 < y1 Then my1 = (y1 - y2) / 2 + y2 Else my1 = (y2 - y1) / 2 + y1
    If x3 < x2 Then mx2 = (x2 - x3) / 2 + x3 Else mx2 = (x3 - x2) / 2 + x2
    If y3 < y2 Then my2 = (y2 - y3) / 2 + y3 Else my2 = (y3 - y2) / 2 + y2
    If x3 < x1 Then mx3 = (x1 - x3) / 2 + x3 Else mx3 = (x3 - x1) / 2 + x1
    If y3 < y1 Then my3 = (y1 - y3) / 2 + y3 Else my3 = (y3 - y1) / 2 + y1

    Line (mx1, my1)-(mx2, my2) '  'draw all inner triangles
    Line (mx2, my2)-(mx3, my3)
    Line (mx1, my1)-(mx3, my3)

    If depth < 4 Then 'not done so call me again
        SierLineTri x1, y1, mx1, my1, mx3, my3, depth + 1
        SierLineTri x2, y2, mx1, my1, mx2, my2, depth + 1
        SierLineTri x3, y3, mx3, my3, mx2, my2, depth + 1
    End If
End Sub

Love the way the triangles dance on the screen!
   

[bplus]

I liked that fractal so much I told a little story in code how it was born:

Birth of Sierpinski Flies a Kite

Code: (Select All)

_Title "Birth of Sirepinski Flies a Kite" 'b+ 2020-01-02
Screen _NewImage(800, 600, 32)
_ScreenMove 300, 50
drawKite 400, 500, 140, .5 'here was Ashish fractal, now put a 2 after drawKite
Print "Original Kite Fractal from Ashish, press any..."
Sleep
drawKite2 400, 500, 140, .5
Print "Sub in Sierpinski, press any..."
Sleep
Cls
drawKite2 400, 500, 140, -.5
Print "Mess with the a variable, press any..."
Sleep
For i = -1 To 1 Step .1
    Cls
    drawKite2 400, 500, 140, i
    Print "Run a continuous change on variable a, press any..."
    _Limit 15
Next
Sleep
For i = _Pi(-2) To _Pi(2) Step .1
    Cls
    drawKite2 400, 500, 140, i
    Print "Oh more continuous change on variable a, press any..."
    _Limit 15
Next
Sleep
Cls
Print "WOW! what was that!?"
Print
_Delay 1
Print "The Birth of Sierpinski Flies a Kite."
Print
_Delay 1
Print "Actually any symmetric object might dance around like that!"
Print
_Delay 1
Print "Maybe you have one to try?"

Sub drawKite (x, y, s, a)
    Line (x, y)-(x + s * Cos(_Pi(2) - a), (y - s) + s * Sin(_Pi(2) - a))
    Line (x, y)-(x + s * Cos(_Pi + a), (y - s) + s * Sin(_Pi + a))
    If s > 1 Then
        drawKite x + s * Cos(_Pi(2) - a), (y - s) + s * Sin(_Pi(2) - a), s / 2, a
        drawKite x + s * Cos(_Pi + a), (y - s) + s * Sin(_Pi + a), s / 2, a
    End If
End Sub

Sub drawKite2 (xx, yy, s, a)
    x = xx: y = yy
    x2 = x + 3 * s * Cos(_Pi(1 / 2) - a / 2): y2 = y + 3 * s * Sin(_Pi(1 / 2) - a / 2)
    x3 = x + 3 * s * Cos(_Pi(1 / 2) + a / 2): y3 = y + 3 * s * Sin(_Pi(1 / 2) + a / 2)
    SierLineTri x, y, x2, y2, x3, y3, 0
    If s > 10 Then
        drawKite2 x + 1 * s * Cos(_Pi(2) - a), (y - s) + 1 * s * Sin(_Pi(2) - a), s / 2, a
        drawKite2 x + 1 * s * Cos(_Pi + a), (y - s) + 1 * s * Sin(_Pi + a), s / 2, a
    End If
End Sub


Sub SierLineTri (x1, y1, x2, y2, x3, y3, depth)
    If depth = 0 Then 'draw out triangle if level 0
        Line (x1, y1)-(x2, y2)
        Line (x2, y2)-(x3, y3)
        Line (x1, y1)-(x3, y3)
    End If
    'find midpoints
    If x2 < x1 Then mx1 = (x1 - x2) / 2 + x2 Else mx1 = (x2 - x1) / 2 + x1
    If y2 < y1 Then my1 = (y1 - y2) / 2 + y2 Else my1 = (y2 - y1) / 2 + y1
    If x3 < x2 Then mx2 = (x2 - x3) / 2 + x3 Else mx2 = (x3 - x2) / 2 + x2
    If y3 < y2 Then my2 = (y2 - y3) / 2 + y3 Else my2 = (y3 - y2) / 2 + y2
    If x3 < x1 Then mx3 = (x1 - x3) / 2 + x3 Else mx3 = (x3 - x1) / 2 + x1
    If y3 < y1 Then my3 = (y1 - y3) / 2 + y3 Else my3 = (y3 - y1) / 2 + y1
    Line (mx1, my1)-(mx2, my2) '  'draw all inner triangles
    Line (mx2, my2)-(mx3, my3)
    Line (mx1, my1)-(mx3, my3)
    If depth < 4 Then 'not done so call me again
        SierLineTri x1, y1, mx1, my1, mx3, my3, depth + 1
        SierLineTri x2, y2, mx1, my1, mx2, my2, depth + 1
        SierLineTri x3, y3, mx3, my3, mx2, my2, depth + 1
    End If
End Sub

   

[bplus]

Speaking of Ashish, he had posted a number of Fractals that I put together in a single program and added a couple of my own including his Kite fractal version and my Sierpinski Flies a Kite... about 15 fractals:

   

Code: (Select All)

_Title "Ashish Fractals Plus! mods by bplus 2017-10-19, press space to return to menu"
Randomize Timer
Dim Shared lowX, highX, lowY, highY

While 1
    Screen 0
    Cls
    cp 2, "Fractal Menu:"
    lp 4, 25, " 1 Circle"
    lp 5, 25, " 2 Arc"
    lp 6, 25, " 3 Tree"
    lp 7, 25, " 4 Quad"
    lp 8, 25, " 5 Quad & Circle"
    lp 9, 25, " 6 Squares forming triangle"
    lp 10, 25, " 7 Sierpinski Carpet"
    lp 11, 25, " 8 Kite"
    lp 12, 25, " 9 Dragon"
    lp 13, 25, "10 Triangle of Circles"
    lp 14, 25, "11 Vicsek"
    lp 15, 25, "12 Circle Illusion?"
    lp 16, 25, "13 Sierpinski Triangle"
    lp 17, 25, "14 Plus, another variation"
    lp 18, 25, "15 Sierpinski Fies a Kite"
    lp 20, 25, "16 Exit"
    Locate 22, 20
    Input "Enter the menu number of your choice "; menu

    Select Case menu
        Case 1: CircleFrac
        Case 2: arcFrac
        Case 3: treeFrac
        Case 4: quadFrac
        Case 5: qncFrac
        Case 6: tnsFrac
        Case 7: sierCarFrac
        Case 8: KiteFrac
        Case 9: dragonFrac
        Case 10: TofCsFrac
        Case 11: VicsekFrac
        Case 12: cIllusFrac
        Case 13: SierTriFrac
        Case 14: PlusFrac
        Case 15: SierFliesKiteFrac
        Case 16: End
    End Select
Wend

Sub arcFrac
    Screen _NewImage(800, 600, 32)
    r = 40
    needUpdate = 1
    Do
        If _KeyDown(32) Then Exit Sub
        If _KeyDown(Asc("w")) Then r = r + s: needUpdate = 1
        If _KeyDown(Asc("s")) And r > 2 Then r = r - s: needUpdate = 1
        If needUpdate = 1 Then
            needUpdate = 0
            ttl "Arc Fractal, Press 'w' and 's' to zoom-in and zoom-out, space to return to Menu"
            drawArc 400, 300, r, 1
            _Display
            Cls
        End If
        _Limit 60
        s = map(r, 1, 10000, 1, 300)
    Loop
End Sub

Sub CF (x, y, r)
    Circle (x, y), r
    If r > 2 Then
        CF x + r, y, r / 2
        CF x - r, y, r / 2
    End If
End Sub

Sub cIll (x, y, r)
    Line (x, y)-(x - r, y)
    Line (x, y)-(x + r, y)
    Line (x, y)-(x, y - r)
    Line (x, y)-(x, y + r)
    If r > 21 Then
        cIll (x - r) + r / 3, y, r / 2
        cIll (x + r) - r / 3, y, r / 2
        cIll x, (y + r) - r / 3, r / 2
        cIll x, (y - r) + r / 3, r / 2
    End If
End Sub

Sub cIllusFrac
    'Coded By Ashish with <3
    'Can you observe circle in this fractal!? (no, sorry)
    'I was able to do so... :D
    Screen _NewImage(800, 600, 32)
    cIll 400, 300, 200
    ttl "Circle with 4 line variation, Illusion? press any..."
    _Display
    Sleep
End Sub

Sub CircleFrac
    'Idea from  https://youtu.be/jPsZwrV9ld0
    Screen _NewImage(800, 600, 32)
    r = 50
    needUpdate = 1
    Do
        If _KeyDown(32) Then Exit Sub
        If _KeyDown(Asc("w")) Then r = r + s: needUpdate = 1
        If _KeyDown(Asc("s")) And r > 2 Then r = r - s: needUpdate = 1
        If needUpdate = 1 Then
            needupadte = 0
            ttl "Circle Fractal, Press 'w' and 's' to zoom-in and zoom-out, space to return to Menu"
            CF 400, 300, r
            _Display
            Cls
        End If
        s = map(r, 1, 10000, 1, 300)
        _Limit 60
    Loop
End Sub

Sub cp (r%, txt$)
    Locate r%, (80 - Len(txt$)) / 2: Print txt$
End Sub

'Calculate the distance between two points.
Function dist! (x1!, y1!, x2!, y2!)
    dist! = Sqr((x2! - x1!) ^ 2 + (y2! - y1!) ^ 2)
End Function

Sub dragonFrac
    Screen _NewImage(800, 600, 32)
    drawDragon 400, 300, 400, 300, 60, Rnd * _Pi(2), Rnd * 255, Rnd * 255, Rnd * 255
    ttl "Dragon Curve Fractal, press any except space for more..."
    _Display
    Sleep
    Do
        If _KeyDown(32) Then Exit Sub
        xx = Rnd * _Width
        yy = Rnd * _Height
        drawDragon xx, yy, xx, yy, 60, Rnd * _Pi(2), Rnd * 255, Rnd * 255, Rnd * 255 ': f = 0
        Line (0, 0)-(_Width, _Height), _RGBA(0, 0, 0, 30), BF
        f = f + 1
        ttl "Dragon Curve Fractal, press space to exit"
        _Display
        _Limit 60
    Loop
End Sub

Sub drawArc (x, y, r, f)
    If f = 1 Then
        Circle (x, y), r, , 0, _Pi
    Else
        Circle (x, y), r, , _Pi, _Pi(2)
    End If
    If r > 2 Then
        If f = 1 Then e = 0 Else e = 1
        drawArc x + r, y, r / 2, e
        drawArc x - r, y, r / 2, e
    End If
End Sub

Sub drawDragon (cx, cy, x, y, r, a, mR, mG, mB)
    d = dist(x, y, cx, cy)
    Color _RGB(map(d, 0, 200, mR, 0), map(d + y, y, d + y, 0, mG), map(d, 0, 200, 0, mB))
    fcirc x, y, r
    If r > 1 Then
        drawDragon cx, cy, x + r * 1.75 * Cos(a), y + r * 1.75 * Sin(a), r * 0.75, a - 0.62, mR, mG, mB
        drawDragon cx, cy, x + r * 1.75 * Cos(a + _Pi), y + r * 1.75 * Sin(a + _Pi), r * 0.75, (a + _Pi) - 0.62, mR, mG, mB ')+_PI
    End If
End Sub

Sub drawKite (x, y, s, a)
    Line (x, y)-(x + s * Cos(_Pi(2) - a), (y - s) + s * Sin(_Pi(2) - a))
    Line (x, y)-(x + s * Cos(_Pi + a), (y - s) + s * Sin(_Pi + a))
    If s > 1 Then
        drawKite x + s * Cos(_Pi(2) - a), (y - s) + s * Sin(_Pi(2) - a), s / 2, a
        drawKite x + s * Cos(_Pi + a), (y - s) + s * Sin(_Pi + a), s / 2, a
    End If
End Sub

Sub drawKite2 (xx, yy, s, a)
    x = xx: y = yy
    x2 = x + 3 * s * Cos(_Pi(1 / 2) - a / 2): y2 = y + 3 * s * Sin(_Pi(1 / 2) - a / 2)
    x3 = x + 3 * s * Cos(_Pi(1 / 2) + a / 2): y3 = y + 3 * s * Sin(_Pi(1 / 2) + a / 2)
    SierLineTri x, y, x2, y2, x3, y3, 0
    If s > 10 Then
        drawKite2 x + 1 * s * Cos(_Pi(2) - a), (y - s) + 1 * s * Sin(_Pi(2) - a), s / 2, a
        drawKite2 x + 1 * s * Cos(_Pi + a), (y - s) + 1 * s * Sin(_Pi + a), s / 2, a
    End If
End Sub

Sub drawTree (x, y, r, a, s)
    If r < 14 Then c~& = _RGB(10, 200, 10) Else c~& = _RGB(160, 10, 10)
    internalp5line x, y, x + r * Cos(a - s), y + r * Sin(a - s), r / 10, c~&
    internalp5line x, y, x + r * Cos(a + s * 3), y + r * Sin(a + s * 3), r / 10, c~&
    If r > 2 Then
        drawTree x + r * Cos(a - s), y + r * Sin(a - s), r * 0.67, a - s, s
        drawTree x + r * Cos(a + s * 3), y + r * Sin(a + s * 3), r * 0.67, a + s * 3, s
    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

'taken from QB64's p5.js
'http://bit.ly/p5jsbas
Sub internalp5line (x0!, y0!, x1!, y1!, s!, col~&)
    dx! = x1! - x0!
    dy! = y1! - y0!
    d! = Sqr(dx! * dx! + dy! * dy!)
    For i = 0 To d!
        Color col~&
        fcirc x0! + dxx!, y0! + dyy!, s!
        dxx! = dxx! + dx! / d!
        dyy! = dyy! + dy! / d!
    Next
End Sub

Sub KiteFrac
    Screen _NewImage(800, 600, 32)
    ttl "Kite Fractal, press any"
    drawKite 400, 500, 140, .5
    _Display
    Sleep
End Sub

Sub lp (r%, c%, txt$)
    Locate r%, c%: Print txt$
End Sub

'taken from QB64's p5.js
'http://bit.ly/p5jsbas
Function map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!)
    map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange!
End Function

Sub Plus (x, y, r)
    'variation BF, B, B, BF
    'variation #2 BF, BF, BF, BF
    'variation #3 B, B, B, B
    'How many plus can you find?
    Color _RGB(r, 255 - r, 255 - r)
    Line (x, y)-(x - r, y - r), , BF
    Line (x, y)-(x + r, y - r), , B
    Line (x, y)-(x - r, y + r), , B
    Line (x, y)-(x + r, y + r), , BF
    If r > 6 Then
        Plus x - r / 2, y - r / 2, r / 2.3
        Plus x + r / 2, y - r / 2, r / 2.3
        Plus x - r / 2, y + r / 2, r / 2.3
        Plus x + r / 2, y + r / 2, r / 2.3
    End If
End Sub

Sub PlusFrac
    'playing with Ashish circle with 4 line by bplus 2017-10-16
    Screen _NewImage(800, 600, 32)
    Plus 400, 300, 290
    ttl "Plus, another variation "
    _Display
    Sleep
End Sub

Sub qncFrac
    Screen _NewImage(800, 600, 32)
    r = 100
    needupdate = 1
    Do
        If _KeyDown(32) Then Exit Sub
        If _KeyDown(Asc("w")) Then r = r + s: needupdate = 1
        If _KeyDown(Asc("s")) And r > 2 Then r = r - s: needupdate = 1
        If needupdate = 1 Then
            needupdate = 0
            ttl "Quad Inside Circle Inside Quad, press w to widen, s to shrink, space to exit"
            quad_circle 400, 300, 0, 0, r, 0
            _Display
            Cls
            s = map(r, 1, 10000, 1, 300)
        End If
        _Limit 40
    Loop
End Sub

Sub quad_circle (x, y, x2, y2, r, e)
    If e = 1 Then
        Line (x, y)-(x2, y2), , B
    Else
        Circle (x, y), r
    End If
    If r > 2 Then
        If e = 1 Then
            If x2 > x Then newR = x2 - x Else newR = x - x2
            quad_circle (x + x2) / 2, (y + y2) / 2, 0, 0, newR / 2, 0
        Else
            tx1 = x + r * Cos(_Pi - .7)
            ty1 = y + r * Sin(_Pi - .7)
            tx2 = x + r * Cos(_Pi(2) - .7)
            ty2 = y + r * Sin(_Pi(2) - .7)
            quad_circle tx1, ty1, tx2, ty2, r / 2, 1
        End If
    End If
End Sub

Sub quad_fractal (x, y, r, e)
    If _KeyDown(32) Then Exit Sub
    Line (x - r, y - r)-(x + r, y - r)
    Line (x + r, y - r)-(x + r, y + r)
    Line (x + r, y + r)-(x - r, y + r)
    Line (x - r, y + r)-(x - r, y - r)
    If r > e Then
        quad_fractal x - r, y - r, r / 2, e
        quad_fractal x + r, y - r, r / 2, e
        quad_fractal x + r, y + r, r / 2, e
        quad_fractal x - r, y + r, r / 2, e
    End If
End Sub

Sub quadFrac
    Screen _NewImage(800, 600, 32)
    k = 100: dir = .5
    Do
        If _KeyDown(32) Then Exit Sub
        Cls
        ttl "Quads!!, press space to exit"
        quad_fractal 400, 300, 100, k
        _Display
        _Limit 2
        k = k * dir
        If k < 2 Then dir = 2
        If k > 100 Then dir = .5
    Loop
End Sub

Sub SC (x, y, r)
    Line (x - r, y - r)-(x + r, y + r), _RGB(map(x, lowX, highX, 0, 255), map(y, lowY, highY, 255, 0), map(x + y, lowX + lowY, highX + highY, 255, 0)), BF
    If r > 3 Then
        v = r * 2
        SC x, y - v, r / 3
        SC x, y + v, r / 3
        SC x + v, y, r / 3
        SC x - v, y, r / 3
        SC x - v, y - v, r / 3
        SC x + v, y + v, r / 3
        SC x - v, y + v, r / 3
        SC x + v, y - v, r / 3
    End If
End Sub

Sub SC0 (x, y, r)
    Line (x - r, y - r)-(x + r, y + r), _RGB(0, 0, 0), BF
    If x - r < lowX Then lowX = x - r
    If x + r > highX Then highX = x + r
    If y - r < lowY Then lowY = y - r
    If y + r > highY Then highY = y + r
    If r > 3 Then
        v = r * 2
        SC0 x, y - v, r / 3
        SC0 x, y + v, r / 3
        SC0 x + v, y, r / 3
        SC0 x - v, y, r / 3
        SC0 x - v, y - v, r / 3
        SC0 x + v, y + v, r / 3
        SC0 x - v, y + v, r / 3
        SC0 x + v, y - v, r / 3
    End If
End Sub

Sub sierCarFrac
    Screen _NewImage(1000, 700, 32)
    lowX = 500
    highX = 500
    highY = 500
    lowY = 500
    Cls , _RGB(255, 255, 255)
    SC0 500, 350, 120
    Line (0, 0)-(lowX, _Height), _RGB(0, 0, 0), BF
    Line (_Width - 1, 0)-(highX, _Height), _RGB(0, 0, 0), BF
    Line (0, 0)-(_Width, lowY), _RGB(0, 0, 0), BF
    Line (0, _Height)-(_Width, highY), _RGB(0, 0, 0), BF
    ttl "Sierpinski_Carpet, press any"
    _Display
    Sleep
    SC 500, 350, 120
    ttl "Sierpinski_Carpet, press any"
    _Display
    Sleep
End Sub

Sub SierFliesKiteFrac
    ' after playing with Ashish Kite Fractal,  by bplus 2017-10-16
    Screen _NewImage(1200, 700, 32)
    While 1
        Cls
        If _KeyDown(32) Then Exit Sub
        drawKite2 600, 540, 200, a
        ttl "Sierpinski flies a Kite, press space to exit"
        _Display
        _Limit 20
        a = a + _Pi(2 / 360)
    Wend
End Sub

Sub SierLineTri (x1, y1, x2, y2, x3, y3, depth)
    If depth = 0 Then 'draw out triangle if level 0
        Line (x1, y1)-(x2, y2)
        Line (x2, y2)-(x3, y3)
        Line (x1, y1)-(x3, y3)
    End If
    'find midpoints
    If x2 < x1 Then mx1 = (x1 - x2) / 2 + x2 Else mx1 = (x2 - x1) / 2 + x1
    If y2 < y1 Then my1 = (y1 - y2) / 2 + y2 Else my1 = (y2 - y1) / 2 + y1
    If x3 < x2 Then mx2 = (x2 - x3) / 2 + x3 Else mx2 = (x3 - x2) / 2 + x2
    If y3 < y2 Then my2 = (y2 - y3) / 2 + y3 Else my2 = (y3 - y2) / 2 + y2
    If x3 < x1 Then mx3 = (x1 - x3) / 2 + x3 Else mx3 = (x3 - x1) / 2 + x1
    If y3 < y1 Then my3 = (y1 - y3) / 2 + y3 Else my3 = (y3 - y1) / 2 + y1
    Line (mx1, my1)-(mx2, my2) '  'draw all inner triangles
    Line (mx2, my2)-(mx3, my3)
    Line (mx1, my1)-(mx3, my3)
    If depth < 4 Then 'not done so call me again
        SierLineTri x1, y1, mx1, my1, mx3, my3, depth + 1
        SierLineTri x2, y2, mx1, my1, mx2, my2, depth + 1
        SierLineTri x3, y3, mx3, my3, mx2, my2, depth + 1
    End If
End Sub

Sub SierTri (x, y, r)
    Line (x + r * Cos(_D2R(330)), y + r * Sin(_D2R(330)))-(x + r * Cos(_D2R(90)), y + r * Sin(_D2R(90)))
    Line (x + r * Cos(_D2R(90)), y + r * Sin(_D2R(90)))-(x + r * Cos(_D2R(210)), y + r * Sin(_D2R(210)))
    Line (x + r * Cos(_D2R(210)), y + r * Sin(_D2R(210)))-(x + r * Cos(_D2R(330)), y + r * Sin(_D2R(330)))
    If r > 4 Then
        SierTri x + r * Cos(_D2R(30)), y + r * Sin(_D2R(30)), r / 2
        SierTri x + r * Cos(_D2R(150)), y + r * Sin(_D2R(150)), r / 2
        SierTri x + r * Cos(_D2R(270)), y + r * Sin(_D2R(270)), r / 2
    End If
End Sub

Sub SierTriFrac
    Screen _NewImage(800, 600, 32)
    SierTri 400, 400, 160
    ttl "Sierpinski Triangle, press any..."
    _Display
    Sleep
End Sub

Sub TofCs (x, y, r, t)
    Color _RGB(Rnd * 255, Rnd * 255, Rnd * 255)
    fcirc x, y, r
    If r > 2 Then
        TofCs x + r * 1.75 * Cos(t), y + r * 1.75 * Sin(t), r * 0.75, t
        TofCs x + r * 1.75 * Cos(_Pi + t), y + r * 1.75 * Sin(_Pi - t), r * 0.75, t
    End If
End Sub

Sub TofCsFrac 'modified for speed as Petr had shown
    Screen _NewImage(1000, 600, 32)
    TofCs 500, 200, 80, .5
    ttl "Triangle Formed By Circle, press any..."
    _Display
    Sleep
End Sub

Sub tns (x, y, r)
    Line (x - r, y - r)-(x + r, y + r), _RGB(Rnd * 255, Rnd * 255, Rnd * 255), BF
    If r > 1 Then
        v = r * 2
        tns x, y - v, r / 2
        tns x + v, y - r * 2, r / 2
        tns x + v, y, r / 2
    End If
End Sub

Sub tnsFrac
    ttl "Square_formed_triangle, press any..."
    Screen _NewImage(800, 600, 32)
    tns 250, 450, 100
    _Display
    Sleep
End Sub

Sub treeFrac
    Screen _NewImage(800, 600, 32)
    radius = 130
    Do
        Cls
        ttl "Fractal_Trees, press space to return to Menu"
        If _KeyDown(32) Then Exit Sub
        drawTree 400, 400, radius, _Pi(3 / 2), s
        internalp5line 400, 600, 400, 400, radius / 10, _RGB(160, 10, 10)
        _Display
        _Limit 40
        s = Abs(Sin(v#)) * 0.25 + 0.2
        v# = v# + 0.01
    Loop
End Sub

Sub ttl (txt$)
    Color _RGB(0, 200, 200)
    lp 2, 5, txt$
    Color _RGB(255, 255, 255)
End Sub

Sub vicsek (x, y, r)
    Line (x, y)-(x - r, y)
    Line (x, y)-(x + r, y)
    Line (x, y)-(x, y - r)
    Line (x, y)-(x, y + r)
    If r > 2 Then
        vicsek x - r, y, r / 3
        vicsek x + r, y, r / 3
        vicsek x, y + r, r / 3
        vicsek x, y - r, r / 3
        vicsek x, y, r / 3
    End If
End Sub

Sub VicsekFrac
    Screen _NewImage(800, 600, 32)
    vicsek 400, 300, 180
    ttl "Vicsek Fractal, press any..."
    _Display
    Sleep
End Sub

Here is one by me:
   

Almost 5 years and now I notice the spelling error not Fies, Flies!

[bplus]

And here is another Ashish fractal I started playing around with:

Code: (Select All)

_Title "Carbonated Circles Fractal by bplus 2017-10-15"
' working from Ashish simple Circle Fractal

Const xmax = 660
Const ymax = 700
DefInt A-Z
Screen _NewImage(xmax, ymax, 32)
_Delay .8 'sorry, my system needs .6 delay for _MIDDLE, yours may NOT
_ScreenMove _Middle ' not working with 32 in line above

Randomize Timer
Common Shared cx(), cy(), cr(), ci

ReDim cx(0): ReDim cy(0): ReDim cr(0)
r1 = 150: basey = ymax - r1 - 10
drawCircle xmax / 2, basey, r1
antigravity = -.6
nb = 60
Dim bx(nb), by(nb), br(nb), bdy(nb)
Dim bc&(nb)
For i = 1 To nb
    r = rand%(1, ci)
    bx(i) = cx(r): by(i) = rand(0, basey): br(i) = cr(r): bdy(i) = rand(-4, -2)
    bc&(i) = _RGB(Rnd * 155 + 100, Rnd * 155 + 100, Rnd * 155 + 100)
Next
Cls
Do
    While 1
        Cls
        For i = 1 To ci
            Color &HFF88DDDD
            Circle (cx(i), cy(i)), cr(i)
        Next
        For i = 1 To nb
            Color bc&(i)
            Circle (bx(i), by(i)), br(i)
            If by(i) - 4 + br(i) < 0 Then
                r = rand%(1, ci)
                bx(i) = cx(r): by(i) = cy(r): br(i) = cr(r): bdy(i) = rand(-4, -2)
                bc& = _RGB(rand%(100, 255), rand(100, 255), rand(100, 255))
            Else
                bdy(i) = bdy(i) + antigravity
                by(i) = by(i) + bdy(i)
            End If
        Next
        _Display
        _Limit 10
    Wend
Loop

Sub drawCircle (x, y, r)
    Circle (x, y), r
    ci = ci + 1
    ReDim _Preserve cx(ci): cx(ci) = x
    ReDim _Preserve cy(ci): cy(ci) = y
    ReDim _Preserve cr(ci): cr(ci) = r
    'PRINT cx(ci), cy(ci), cr(ci)
    If r > 2 Then
        drawCircle x + r, y, r / 2
        drawCircle x - r, y, r / 2
    End If
End Sub

Function rand% (lo%, hi%)
    rand% = Int(Rnd * (hi% - lo% + 1)) + lo%
End Function

Just another b+ mod

[bplus]

Bert's Fractal

Here is nice one from Bert that I saved from around time I started at net?

Code: (Select All)

Rem  According to Wikipedia, "In mathematics a fractal is an abstract object
Rem  used to describe and simulate naturally occurring objects. Artificially
Rem  created fractals commonly exhibit similar patterns at increasingly small
Rem  scales. It is also known as expanding symmetry or evolving symmetry."
Rem
Rem  The evolving symmetry is created via an iterative process.
Rem
Rem  Program creates a rotating fractal consisting of squares.
Rem -------
_Title "Bert's Fractal Squares 2017-10-25 mods by B + "
Screen _NewImage(700, 700, 12)
_ScreenMove 360, 30
While 1
    frac 5
    _Delay 1
    frac2 5
Wend

Sub frac (ii) 'now it's a fractal and now its rotating
    i = ii
    Line ((350 - i), (350 - i) - (i - 5))-((350 + i) + (i - 5), (350 - i)), 14, B
    _Delay .05
    Line ((350 - i), (350 - i) - (i - 5))-((350 - i) - (i - 5), (350 + i)), 12, B
    _Delay .05
    Line ((350 + i), (350 + i) + (i - 5))-((350 - i) - (i - 5), (350 + i)), 2, B
    _Delay .05
    Line ((350 + i), (350 + i) + (i - 5))-((350 + i) + (i - 5), (350 - i)), 9, B
    _Delay .05
    i = i + 5
    If i < 170 Then frac (i)
End Sub

Sub frac2 (ii) 'now it's a fractal and now its rotating
    i = ii
    Line ((350 - i), (350 - i) - (i - 5))-((350 + i) + (i - 5), (350 - i)), 0, B
    _Delay .05
    Line ((350 - i), (350 - i) - (i - 5))-((350 - i) - (i - 5), (350 + i)), 0, B
    _Delay .05
    Line ((350 + i), (350 + i) + (i - 5))-((350 - i) - (i - 5), (350 + i)), 0, B
    _Delay .05
    Line ((350 + i), (350 + i) + (i - 5))-((350 + i) + (i - 5), (350 - i)), 0, B
    _Delay .05
    i = i + 5
    If i < 170 Then frac2 (i)
End Sub

   

[TarotRedhand]

Did you know that Alexander Graham Bell invented and conducted research on tetrahedral kites from when Sierpinski was around 8 years old? Here's a step-by-step guide to making a simple one.

TR

[bplus]

I did not know, interesting that such a thing flies!

[TarotRedhand]

Ooops. Sorry for the missed link. Here's 3 YouTube and one wikipedia links for you to make up for me being too sleepy when I posted.

This is a medium sized kite in flight from 5 years ago at the Beamish Museum in the UK.
Another medium sized kite in flight from 6 years ago.
How to make one of these kites (really a section of a bigger one) using just drinking straws, string and lightweight material.

TR

[bplus]

The one showing how to make one answered a question I was wondering about how many sides of tetrahedron were papered, so yeah, seems more likely to fly than a box kite. Now I am wondering about shallow paper cups ;-))