05-21-2022, 10:12 PM (This post was last modified: 05-21-2022, 10:13 PM by 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
_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
_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
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
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
Here's a fractal I've been meaning to port to QB64 for some time! a740g's Julia Rings reminded me of it again this morning.
Finally got around to converting from SmallBASIC. It's a little off the SB version but I animated it to make up the difference while rocking back and forth (mostly p values) it is silently zooming out until it reaches a max then starts over in slightly different values of p and q
Code: (Select All)
_Title "S Virjee Fractal" ' b+ trans from SmallBASIC 2024-10-02 animated zoom, dp, dq added
'Written for Smallbasic Aug 2013 - S Virjee
Dim As Long xmax, ymax
xmax = 1300: ymax = 700
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 0, 0
Dim col As _Unsigned Long
Do
For x = -centerx To centerx
For y = 0 To ymax
c = x / xmax * (1 - zoom * 1.5)
d = y / ymax * (1 - zoom)
ztot = 0
i = 1
z = 1
While i < iter And z < zoom * 1.5
real = c * c - d * d + p
imag = 2 * c * d + q
c = real / Sgn(d - i)
d = imag
z = (c * c + d * d)
If (z < H) Then
If (z > L) And (i > 0) Then
ztot = ztot + (1 - (Abs((z - pqsq) / z) / (i / (iter))))
oldi = i
'if i<25 and z>0 then i=abs((c*d+q))*i
End If
End If
i = i + 1
Wend
If ztot >= 0 Then i = Int(Sqr(ztot) * 256)
If i < 256 Then red = i: green = 0: blue = 0
If i > 255 And i <= 512 Then green = i - 256: blue = 0: red = 255
If i > 511 Then green = 255: blue = 0: red = 255
If i > 511 And i <= 768 Then blue = i - 512: red = 255: green = 255
If i > 768 And i <= 1026 Then blue = 255: red = 255: green = 255
If i > 1026 Then blue = 55: red = 255: green = 55
gray = Int((red + green + blue) * .33)
' hot = if(max(red,green,blue)<255,max(red,green,blue),0) ' what???
hot = max(red, max(green, blue))
If hot > 255 Then hot = -128
If hot < 0 Then hot = -255
' ???
If oldi = 1 Then red = hot: 'Outer Circle 1 Figure 8
If oldi = 2 Then green = hot 'Outer Circle 2
If oldi = 3 Then red = hot: blue = gray 'Inner Circle Figure 8 - Yellow
If oldi = 4 Then blue = hot: green = red: red = gray 'Inner to 2/Outer Circle 4 Loops top
If oldi >= 5 Then red = Int((hot + blue + green) * .33) / (oldi): 'This is main color
'col = -red + (256 * -green) + (256 * 256 * -blue)
col = _RGB32(red, green, blue)
PSet (centerx + x, centery - y), col
PSet (xmax - centerx - x, centery + y), col
Next y
Next x
_Title "S Virjee Fractal" + Str$(zoom) + Spc(2) + Str$(p) + Spc(2) + Str$(q)
_Display
zoom = zoom * .999
If zoom < 2.4 Then zoom = 5
p = p + dp
If p < -.8 Then dp = -dp: p = -.8
If p > -.7 Then dp = -dp: p = -.7
q = q + dq
If q > .13 Then dq = -dq: q = .13
If q < .11 Then dq = -dq: q = .11
Loop
Function max& (a&, b&)
If a& > b& Then max& = a& Else max& = b&
End Function
![[Image: 26b1120e821255003d4385112eb22246e96e677c_2_577x500.png]](https://forum.neverwintervault.org/uploads/default/optimized/2X/2/26b1120e821255003d4385112eb22246e96e677c_2_577x500.png)
![[Image: ce83e8d78f3ae98dbf67deb6c2e9be019ff42401.png]](https://forum.neverwintervault.org/uploads/default/original/2X/c/ce83e8d78f3ae98dbf67deb6c2e9be019ff42401.png)
while rocking back and forth (mostly p values) it is silently zooming out until it reaches a max then starts over in slightly different values of p and q