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:
Here is one by me:
Almost 5 years and now I notice the spelling error not Fies, Flies!
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!
b = b + ...