+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Prolific Programmers (https://staging.qb64phoenix.com/forumdisplay.php?fid=26)
+---- Forum: bplus (https://staging.qb64phoenix.com/forumdisplay.php?fid=36)
+---- Thread: Fractals (/showthread.php?tid=439)
Pages:
1
2
RE: Fractals - TarotRedhand - 05-21-2022
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 -
![[Image: 26b1120e821255003d4385112eb22246e96e677c_2_577x500.png]](https://forum.neverwintervault.org/uploads/default/optimized/2X/2/26b1120e821255003d4385112eb22246e96e677c_2_577x500.png)
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
![[Image: ce83e8d78f3ae98dbf67deb6c2e9be019ff42401.png]](https://forum.neverwintervault.org/uploads/default/original/2X/c/ce83e8d78f3ae98dbf67deb6c2e9be019ff42401.png)
TR
RE: Fractals - bplus - 05-21-2022
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 SubRE: Fractals - bplus - 05-21-2022
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 SubOccasionally with these ferns you get a sighting of the Fernerator
RE: Fractals - bplus - 06-03-2022
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 FunctionRE: Fractals - bplus - 06-03-2022
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