Just 6 Fractals

[TarotRedhand]

From back in the day and made to work in QB64. All six are just the top level of each of the fractals. Of the six, three are not really suitable for zooming in.

It is said that Benois Mandlebrot used the Cantor Dust fractal to illustrate (to a group of electronic engineers) why just increasing the power of transmitted signals wouldn't illiminate the "random" errors they were observing but that some form of error checking would need to be devised.

Cantor.BAS (Not Zoom)

Code: (Select All)

Const Left = 1
Const Right = 640

Screen 2
_FullScreen _SquarePixels
Cls
CantorDust Left, Right, 1
End

Sub CantorDust (Start, Finish, Level)
    Y = Level * 20
    Line (Start, Y)-(Finish, Y), 1
    Length = Finish - Start
    If Length < 2 Then
        Exit Sub
    End If
    Third = Length / 3
    A = Start + Third - 1
    B = 1 + Finish - Third
    CantorDust Start, A, Level + 1
    CantorDust B, Finish, Level + 1
End Sub

The second one is the Henon Fractal. This one achieves variety by asking you to input a number. For an interesting result try the value of PI. Not Zoom.

Henon.BAS

Code: (Select All)

xc = 320
yc = 240
xmul = 400
ymul = 360
Cls
Input "Enter the value for a"; a
Screen 12

_FullScreen _SquarePixels

Cls
For x = -.1 To .8 Step .05
    For y = -.1 To .8 Step .05
        x1 = x
        y1 = y
        For i% = 1 To 1000
            If x1 > 1000 Or y1 > 1000 Or x1 < -1000 Or y1 < -1000 Then
                i% = 1000
            Else
                ca = Cos(a)
                sa = Sin(a)
                yy = y1 - x1 * x1
                xx = x1 * ca - yy * sa
                y1 = x1 * sa + yy * ca
                x1 = xx
                PSet (xc + (x1 * xmul), yc + (y1 * ymul)), (i% Mod 17)
            End If
        Next i%
    Next y
Next x

If you have a slow machine you may want to edit this one. That is because there is a FOR NEXT loop in it, that loops 20,000,000 times. That number is high in order to show most of the finer detail of this fractal. Watching as it builds has somewhat of a retro feel. Again don't bother adding a zoom feature.

Ikida.BAS

Code: (Select All)

x = 0
y = 0
p = 7.7
colour = 16
xc = 435
yc = 270
xmul = 240
ymul = 180
MaxColour = 16

Screen 12
_FullScreen _SquarePixels

Cls
For n& = 1 To 20000000
    theta = .4 - (p / (1 + (x * x + y * y)))
    ctheta = Cos(theta)
    stheta = Sin(theta)
    Point9x = .9 * x
    Point9y = .9 * y
    x1 = .85 + Point9x * ctheta - Point9y * stheta
    y1 = Point9x * stheta + Point9y * ctheta
    PSet (xc + (xmul * -x1), yc + (ymul * y1)), colour
    x = x1
    y = y1
    colour = colour + 1
    If colour > MaxColour Then
        colour = 1
    End If
    Locate 6, 1
    Print "Iterations = ";
    Print Using "##,###,###"; n&;
Next n&

Next, here is the classic Mandlebrot fractal. You can add a zoom to this one if you want.

Mandle.BAS

Code: (Select All)

Const MaxCol% = 17
Const MaxX% = 640
Const MaxY% = 480
Const BailOut = 4!
Const MaxIterations% = 255

AngleR = -2
AngleL = -1.25
Side = 2.5
DistanceX = Side / MaxX%
DistanceY = Side / MaxY%
Screen 12
_FullScreen _SquarePixels
Cls
For Y = 1 To MaxY%
    For X = 1 To MaxX%
        CR = X * DistanceX + AngleR
        CL = Y * DistanceY + AngleL
        ZR = CR
        ZL = CL
        Iteration% = 0
        Do
            A = ZR * ZR
            B = ZL * ZL
            Length = A + B
            ZL = 2 * ZR * ZL + CL
            ZR = A - B + CR
            Iteration% = Iteration% + 1
        Loop Until Length > BailOut Or Iteration% > MaxIterations%
        col = Iteration% Mod MaxCol%
        PSet (X, Y), col
    Next X
Next Y

It is said that for each chaotic point on a Mandlebrot fractal, there is a corresponding Julia fractal. Here is one -

Julia.BAS (Zoom can be added)

Code: (Select All)

Const MaxCol% = 17
Const LastX% = 640
Const LastY% = 480
Const MaxX% = 400
Const MaxY% = 460
Const BailOut = 4!
Const MaxIterations% = 255

AngleR = -2
AngleL = -1.25
CR = -1
CL = -.625
Side = 2.5
DistanceX = Side / MaxX%
DistanceY = Side / MaxY%
Screen 12
_FullScreen _SquarePixels
Cls
For Y = 1 To LastY%
    For X = 1 To LastX%
        ZR = X * DistanceX + AngleR
        ZL = Y * DistanceY + AngleL
        Iteration% = 0
        Do
            A = ZR * ZR
            B = ZL * ZL
            Length = A + B
            ZL = 2 * ZR * ZL + CL
            ZR = A - B + CR
            Iteration% = Iteration% + 1
        Loop Until Length > BailOut Or Iteration% > MaxIterations%
        col = Iteration% Mod MaxCol%
        PSet (X, Y), col
    Next X
Next Y

Finally we have a pseudo fractal. At least the creator of this said that they didn't think it was really a fractal. You be the judge. A zoom feature can certainly be added and values tweaked repeatedly in order to make an animation.

Topham.BAS

Code: (Select All)

Screen 12
_FullScreen _SquarePixels
Cls
xpos = 320
ypos = 240
across = 640
down = 480
a = -1.5
b = -.5
c = 2.4
d = -.45
e = .5
xmin = -3.5
xmax = 4.5
ymin = -2
ymax = 2
maxiter = 70
cresh = 500
dx = (xmax - xmin) / across
dy = (ymax - ymin) / down
For ynn = 1 To down
    For xnn = 1 To across
        k = 0
        xn = xmin + dx * xnn
        yn = ymin + dy * ynn
        Do
            k = k + 1
            xnsqr = xn * xn
            ynsqr = yn * yn
            If (xnsqr + ynsqr) > cresh Then
                GoSub PlotPoint
                Exit Do
            End If
            If k > maxiter Then
                Exit Do
            End If
            xm = a + b * xn + c * ynsqr
            yn = d + e * xn
            xn = xm
        Loop
    Next xnn
Next ynn
End

PlotPoint:
Select Case (k Mod 7) + 1
    Case 1
        col = 12
    Case 2
        col = 10
    Case 3
        col = 14
    Case 4
        col = 9
    Case 5
        col = 15
    Case 6
        col = 11
    Case 7
        col = 13
End Select
PSet (xpos - .5 * across + xnn, ypos - .5 * down + ynn), col
Return

Have fun and see what you can do with these.

TR

[bplus]

Thumbs way up! I luv fractals!

Here is one I call Glitter Hop Along that often has a pattern that reminds me of the painting "The Scream"

Code: (Select All)

_Title "Glitter Hopalong, any key quits" 'trans from SmallBASIC 2020-04-09
'Glitter hopalong.bas SmallBASIC 2015-05-04 modified for Bpf, B+
' color changes for the night shift

Const xmax = 1200, ymax = 700
Screen _NewImage(xmax, ymax, 32)
_Delay .25
_ScreenMove _Middle

xoffs = xmax * 5 / 12
yoffs = ymax * 5 / 12
Do
    Cls
    j = Rnd * 100
    k = Rnd * 100
    x = 0: y = 0: r = 0: n = 0
    For i = 1 To 10000000
        r = Rnd * 4000
        If r > 3997 Then Color qb(Int(Rnd * 15) + 1)
        xx = y - Sgn(x) * Sqr(Abs(k * x - 1))
        y = j - x
        x = xx
        xp = x * 3 + xoffs
        yp = y * 3 + yoffs
        Circle (xp, yp), 1
    Next i
    _Delay 1
Loop Until Len(InKey$)

Function qb~& (n As Integer)
    Select Case n
        Case 0: qb~& = &HFF000000
        Case 1: qb~& = &HFF000088
        Case 2: qb~& = &HFF008800
        Case 3: qb~& = &HFF008888
        Case 4: qb~& = &HFF880000
        Case 5: qb~& = &HFF880088
        Case 6: qb~& = &HFF888800
        Case 7: qb~& = &HFFCCCCCC
        Case 8: qb~& = &HFF888888
        Case 9: qb~& = &HFF0000FF
        Case 10: qb~& = &HFF00FF00
        Case 11: qb~& = &HFF00FFFF
        Case 12: qb~& = &HFFFF0000
        Case 13: qb~& = &HFFFF00FF
        Case 14: qb~& = &HFFFFFF00
        Case 15: qb~& = &HFFFFFFFF
    End Select
End Function

   

[TarotRedhand]

Thanks. That one reminds me of the Blender monkey.

TR

[TarotRedhand]

@bplus Just got around to running your program. That seriously needs either a delay or a wait for a keypress between fractals. At the moment it passes before my eyes faster than my life would when I die   .

TR

[bplus]

Here is slide show of b+ mod of your Henon:

Code: (Select All)

Screen _NewImage(_DesktopWidth, _DesktopHeight, 12)
_FullScreen
xc = _Width / 2
yc = _Height / 2
Do
    a = Rnd * 10 ^ (Rnd * 10)
    xmul = Rnd * 1000
    Cls
    For x = -.1 To .8 Step .05
        For y = -.1 To .8 Step .05
            x1 = x
            y1 = y
            lim = Rnd * 2000 + 200
            For i% = 1 To lim
                'If x1 > 1000 Or y1 > 1000 Or x1 < -1000 Or y1 < -1000 Then
                '    i% = 1000
                'Else
                ca = Cos(a)
                sa = Sin(a)
                yy = y1 - x1 * x1
                xx = x1 * ca - yy * sa
                y1 = x1 * sa + yy * ca
                x1 = xx
                Line (xc + (x1 * xmul), yc + (y1 * xmul))-Step(1, 1), (i% Mod 17), BF
                'End If
            Next i%
        Next y
    Next x
    Print a
    _Display
    _Limit .5
Loop Until _KeyDown(27)

[TarotRedhand]

@bplus Are you aware of these fractals in QB64 over on RosettaCode?

Barnsley Fern
Fractal Tree
Cantor Set (prettier than mine)
Hilbert Curve
Pythagoras Tree
Serpinski Carpet

All QB64 code on RosettaCode.

FWIW all QBasic code on RosettaCode.

TR

[bplus]

@bplus Are you aware of these fractals in QB64 over on RosettaCode?

Barnsley Fern
Fractal Tree
Cantor Set (prettier than mine)
Hilbert Curve
Pythagoras Tree
Serpinski Carpet

All QB64 code on RosettaCode.

FWIW all QBasic code on RosettaCode.

TR

Yeah yeah...  ho hum old stuff! Oh have I got a Hilbert mod for you!

Code: (Select All)

_Title "Hilbert in His Curve" '2021-04-14 B+
' using AndyA's code for Hilbert Curve  and Wiki image of Hilbert

Const wide = 128, cell = 4 ' screen width 512 = height
Screen _NewImage(wide * cell + cell, wide * cell + cell, 32)
ReDim Shared As Long H, I
H = _NewImage(wide * cell + cell, wide * cell + cell, 32)
I = _LoadImage("Hilbert.PNG")
_PutImage , I, H
'Color , &HFFFFFFFF     'nope black still works better!
'Cls
PSet (wide * cell, wide * cell) 'prime pump
Hilbert 0, 0, wide, 0, 0
Sleep
System

Sub Hilbert (x As Integer, y As Integer, lg As Integer, p As Integer, q As Integer)
    Dim As Integer iL, iX, iY
    Dim As _Unsigned Long K
    iL = lg: iX = x: iY = y
    _Source H
    If iL = 1 Then
        K = Point((wide - iX) * cell, (wide - iY) * cell)
        Line -((wide - iX) * cell, (wide - iY) * cell), K
        Exit Sub
    End If
    iL = iL \ 2
    Hilbert iX + p * iL, iY + p * iL, iL, p, 1 - q
    Hilbert iX + q * iL, iY + (1 - q) * iL, iL, p, q
    Hilbert iX + (1 - p) * iL, iY + (1 - p) * iL, iL, p, q
    Hilbert iX + (1 - q) * iL, iY + q * iL, iL, 1 - p, q
End Sub

   

[bplus]

I did a Cantor tree that impressed Aurel way back... maybe I will look for it again.

Serpenski in space is another oldy but goody, hey a screen saver.

[bplus]

OK just for you TR (and me), I found those Fractals though the Cantor dust was more like a Proggie and Sierpinski in Space a Screen Saver, I started a Fractal thread in my little corner of Phoenix Edition.

So I see your 6 Fractals and raise you 2 + 15 + 2 + ? - 6 at least 13 ;-)) plus 1 Hilbert that was originally from Andy Amaya, hope he's found us

Update: yes Andy_A very early on, but hasn't posted anything yet, a lurker ;-))

BTW QB64 is at Rosetta Code too!