Pentagon Fractal
I couldn’t resist trying it with some other regular polygons. Here’s how the pentagon worked out
I think, given more time, that those white blotches would be pentagons. The 50k iterations just didn’t get the job done. I had to up the ante to 5,000,000 iterations – 42 minutes on my machine (Triangle Fractal took 42 seconds). If I could (was willing to) get rid of the randomness, I’m sure it could be done much faster. But then it would lose its charm. Here’s the code
Sub SheetPolygon()
Dim CurrX As Double
Dim CurrY As Double
Dim Vertices(1 To 5, 1 To 2) As Double
Dim NextVert As Long
Dim i As Long
Dim wsh As Worksheet
Dim lMaxVert As Long
Dim lStart As Long
Dim c1 As Double, c2 As Double, s1 As Double, s2 As Double
Const XOFF As Long = 128
Const YOFF As Long = 128
Const PI = 3.14159265358979
Warning: don‘t run this code unless you have some time
lStart = Timer
c1 = Cos(2 * PI / 5)
c2 = Cos(PI / 5)
s1 = Sin(2 * PI / 5)
s2 = Sin(4 * PI / 5)
Vertices(1, 1) = XOFF + 0
Vertices(1, 2) = YOFF – 127
Vertices(2, 1) = XOFF + (s1 * XOFF)
Vertices(2, 2) = YOFF – (c1 * YOFF)
Vertices(3, 1) = XOFF + (s2 * XOFF)
Vertices(3, 2) = YOFF + (c2 * YOFF)
Vertices(4, 1) = XOFF – (s2 * XOFF)
Vertices(4, 2) = YOFF + (c2 * YOFF)
Vertices(5, 1) = XOFF – (s1 * XOFF)
Vertices(5, 2) = YOFF – (c1 * YOFF)
Set wsh = ThisWorkbook.Worksheets.Add
wsh.Cells.RowHeight = 1.5
wsh.Cells.ColumnWidth = 0.17
lMaxVert = UBound(Vertices, 1)
NextVert = lMaxVert
CurrX = Vertices(NextVert, 1)
CurrY = Vertices(NextVert, 2)
‘loop ten thousand times
For i = 1 To 5000000
NextVert = Int(lMaxVert * Rnd + 1) ‘pick a random vertex
GetNewPoint CurrX, CurrY, Vertices(NextVert, 1), Vertices(NextVert, 2)
PlacePointWsh CLng(CurrX), CLng(CurrY), wsh
Next i
Debug.Print Timer – lStart
End Sub
Dim CurrX As Double
Dim CurrY As Double
Dim Vertices(1 To 5, 1 To 2) As Double
Dim NextVert As Long
Dim i As Long
Dim wsh As Worksheet
Dim lMaxVert As Long
Dim lStart As Long
Dim c1 As Double, c2 As Double, s1 As Double, s2 As Double
Const XOFF As Long = 128
Const YOFF As Long = 128
Const PI = 3.14159265358979
Warning: don‘t run this code unless you have some time
lStart = Timer
c1 = Cos(2 * PI / 5)
c2 = Cos(PI / 5)
s1 = Sin(2 * PI / 5)
s2 = Sin(4 * PI / 5)
Vertices(1, 1) = XOFF + 0
Vertices(1, 2) = YOFF – 127
Vertices(2, 1) = XOFF + (s1 * XOFF)
Vertices(2, 2) = YOFF – (c1 * YOFF)
Vertices(3, 1) = XOFF + (s2 * XOFF)
Vertices(3, 2) = YOFF + (c2 * YOFF)
Vertices(4, 1) = XOFF – (s2 * XOFF)
Vertices(4, 2) = YOFF + (c2 * YOFF)
Vertices(5, 1) = XOFF – (s1 * XOFF)
Vertices(5, 2) = YOFF – (c1 * YOFF)
Set wsh = ThisWorkbook.Worksheets.Add
wsh.Cells.RowHeight = 1.5
wsh.Cells.ColumnWidth = 0.17
lMaxVert = UBound(Vertices, 1)
NextVert = lMaxVert
CurrX = Vertices(NextVert, 1)
CurrY = Vertices(NextVert, 2)
‘loop ten thousand times
For i = 1 To 5000000
NextVert = Int(lMaxVert * Rnd + 1) ‘pick a random vertex
GetNewPoint CurrX, CurrY, Vertices(NextVert, 1), Vertices(NextVert, 2)
PlacePointWsh CLng(CurrX), CLng(CurrY), wsh
Next i
Debug.Print Timer – lStart
End Sub
You’ll need to get GetNewPoint and PlacePointWsh from Triangle Fractal. I got the vertices from MathWorld.
I have been playing with Fractals for many years and was recently given a challenge at a meeting where I had stated “Why don’t we do that in Excel? You can do everything in Excel”.
“You Can’t make Mandelbrots without using code” came the response.
So 1 Hr later here is Excel_Madlbrot.xls with a graphics output and no VBA code.
http://www.ianeva.info/Excel_Mandelbrot/Excel_Mandelbrot.html
Hui…
Hui,
That is amazing! I’m going to waste hours on figuring out how you did it.
Rob
Wow Hui!
I am totally blown away by that.
If I had a spare day or two, I might have looked into how you did it, but then again, I sometimes think that knowing why a sunset happens actually takes something away from the experience so perhaps I’ll just remain in awe.
Alan.
The views expressed are my own, and not those of my employer or anyone else associated with me.
My current valid email address is:
6f7chu602@sneakemail.com
This is valid as is. It is not munged, or altered at all.
It will be valid for AT LEAST one month from the date of this post.
If you are trying to contact me after that time,
it MAY still be valid, but may also have been
deactivated due to spam. If so, and you want
to contact me by email, try searching for a
more recent post by me to find my current
email address.
Alan -
Here’s how it works, but you have to promise not to tell anyone.
It’s magic!
- Jon
Sub Tapis()
‘Autor?
ActiveSheet.Unprotect
Randomize
couleur = Int(28 * Rnd + 3)
For Each fou In Range(“Table”)
If fou.Value 0 And fou.Value Mod 2 = 0 Then fou.Interior.ColorIndex = couleur
Next fou
Randomize
couleur = Int(28 * Rnd + 3)
For Each la In Range(“Table1?)
If la.Value 0 And la.Value Mod 2 = 1 Then la.Interior.ColorIndex = couleur
Next la
ActiveSheet.Protect
End Sub
Sub efface()
ActiveSheet.Unprotect
Range(“Table”).Interior.ColorIndex = xlNone
Range(“Table1?).Interior.ColorIndex = xlNone
ActiveSheet.Protect
End Sub