+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://staging.qb64phoenix.com/forumdisplay.php?fid=3)
+---- Forum: Programs (https://staging.qb64phoenix.com/forumdisplay.php?fid=7)
+---- Thread: Just 6 Fractals (/showthread.php?tid=372)
Just 6 Fractals - TarotRedhand - 05-08-2022
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 SubThe 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 xIf 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 YIt 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 YFinally 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
ReturnHave fun and see what you can do with these.
TR
RE: Just 6 Fractals - bplus - 05-08-2022
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 FunctionRE: Just 6 Fractals - TarotRedhand - 05-08-2022
Thanks. That one reminds me of the Blender monkey.
TR
RE: Just 6 Fractals - TarotRedhand - 05-09-2022
@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
RE: Just 6 Fractals - bplus - 05-09-2022
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)RE: Just 6 Fractals - TarotRedhand - 05-19-2022
@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
RE: Just 6 Fractals - bplus - 05-19-2022
(05-19-2022, 05:38 PM)TarotRedhand Wrote: @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 SubRE: Just 6 Fractals - bplus - 05-19-2022
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.
RE: Just 6 Fractals - bplus - 05-19-2022
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!