+- 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
Fractals - bplus - 05-19-2022
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 SubI have an 40 year old Ink Wash Drawing that looks very close to this snapshot.
RE: Fractals - bplus - 05-19-2022
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 SubLove the way the triangles dance on the screen!
RE: Fractals - bplus - 05-19-2022
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 SubRE: Fractals - bplus - 05-19-2022
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 SubHere is one by me:
Almost 5 years and now I notice the spelling error not Fies, Flies!
RE: Fractals - bplus - 05-19-2022
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![[Image: Carbonated-Circles-Fractal.png]](https://i.ibb.co/c2kG4mJ/Carbonated-Circles-Fractal.png)
Just another b+ mod
RE: Fractals - bplus - 05-19-2022
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 SubRE: Fractals - TarotRedhand - 05-19-2022
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
RE: Fractals - bplus - 05-20-2022
I did not know, interesting that such a thing flies!
RE: Fractals - TarotRedhand - 05-20-2022
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
RE: Fractals - bplus - 05-20-2022
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 ;-))