A few weeks ago, Paul Salomon posted a really beautiful work of mathematical art on his blog, Lost In Recursion:

He included a precise mathematical description of the image, and I naturally wondered how difficult it would be to replicate using the diagrams framework which I wrote about previously.

The answer: not hard! All told it is only about 30 lines of code, give or take. So I decided to exhibit it here, both as a way of explaining the cool math behind Paul’s image, and as a way of showing off the power of diagrams to do this sort of visualization and mathematical art.

This post is literate Haskell—you should be able to copy and paste the contents of this post into a file with an .lhs extension, and run and play around with it yourself. First, some requisite imports and such:

> {-# LANGUAGE NoMonomorphismRestriction #-}
> 
> module SOTMS where
> 
> import           Control.Arrow                  ((***))
> import           Data.Colour.SRGB
> import           Data.Colour.RGBSpace
> import           Data.Colour.RGBSpace.HSV
> import           Diagrams.Backend.Cairo.CmdLine
> import           Diagrams.Prelude

Star polygons

The image is primarily composed of a bunch of star polygons, the figures you get when you take points evenly spaced around a circle and connect every th point. For example, here’s what we get when we pick and :

I’ve numbered the vertices to make it easier to see how vertex is always connected to vertex (modulo 12) by a line segment. Vertex is connected to , which is connected to , which is connected to , and so on.

In this example, we get one continuous polygonal path which cycles through all the vertices. But sometimes we get several disjoint paths. For example, below is what we get with and . I’ve used distinct colors to make it easy to see the three separate squares:

If you connect every third point out of twelve, you come back to where you started after hitting only four points, so three separate square paths are needed to connect all the points. Given values for and , can you say in general how many distinct paths result? Here are a few more examples to fuel your investigations:

In fact, the number of separate paths needed to draw a given star polygon is how Paul chooses the color: red for star polygons that are one continuous path, yellow for two paths, blue for a lot (that is, 24), and shading gradually from yellow to green to blue for numbers in between. (Now that you know this, you might want to go back and study the image again, looking for patterns!)

There’s one thing left: what about ? This is a sort of “degenerate” star polygon where we don’t connect any of the points. Paul chose to draw those using just dots for the vertices, like this:

In Paul’s image you can see these going in a straight line from the center to the top, though it’s a little hard to see what’s going on since they all overlap with each other.

Drawing star polygons

So, let’s see some code already! First, a simple function to generate the kind of regular polygons we want:

> -- Make a regular polygon with n sides and radius r, oriented with
> -- one vertex pointing in the positive y direction.
> regP n r = polygon with { polyType   = PolyRegular n r
>                         , polyOrient = NoOrient
>                         }
>          # rotateBy (1/4)

Now, we define a function mkStar which takes and as inputs and draws a -star polygon, coloring it according to Paul’s color scheme:

> -- If q = 0, draw a bunch of dots at the vertices of a regular polygon
> mkStar n 0    = decoratePath (regP n 1) (repeat (circle 0.1 # lw 0))
>               # fc (colorByNumber n)
> 
> -- Otherwise draw a star polygon
> mkStar n skip = let p        = star (StarSkip skip) (regP n 1)
>                     numPaths = length . pathTrails $ p
>                 in
>                     p # stroke # lw 0.08 # lc (colorByNumber numPaths)

Incidentally, the coloring scheme was the only part that wasn’t specified in Paul’s post, so I hacked something together using trial and error and the “eyedropper” tool in GIMP. I also have to go to a bit of trouble to blend from yellow to blue in HSV space, so it looks like this:

and not in RGB space, which looks like this:

You need not pay too much attention to this code, but I’m including it here for completeness. (I plan to soon include some extra tools in diagrams for helping manipulate colors, which would make this a lot easier to accomplish.)

> paulRed    = sRGB24 0xDA 0x22 0x22
> paulBlue   = sRGB24 0x4C 0x89 0xC0
> paulYellow = sRGB24 0xD1 0xB3 0x41
> 
> colorByNumber 1 = paulRed
> colorByNumber c = hsvBlend (min 1 ((fromIntegral c - 2)/10))
>                     paulBlue paulYellow
> 
> hsvBlend t c1 c2 = uncurryRGB sRGB . hsv3 $ lerp h2 h1 t
>   where
>     [h1, h2] = map (hsvView . toSRGB) [c1,c2]
>     fst3 (x,_,_) = x
>     hsv3 (h,s,v) = hsv h s v

The final colors don’t look exactly like Paul’s original image but they’re close enough.

Orbits

Now that we can generate individual star polygons we have to put them together into “orbits”. All the star polygons in a particular “orbit” (that is, at a particular distance from the center) have the same value of (that is, the same number of vertices). The star with is at the top, and then the stars for other values of progress in order around the orbit. (Quick quiz: does the value of increase going clockwise, or counterclockwise?)

Making the stars around a particular orbit is easy: we create all the stars (map (mkStar n) [0..] will make one star for each value of ), and then place them at the vertices of a radius- regular -gon using decoratePath.

> stars n = decoratePath
>             (regP n (fromIntegral n - 1))
>             (map (mkStar n) [0..])

For example, here are the outputs for stars 6 and stars 7:

Finally, each orbit is shown with a faint circle, so we make an orbit function which returns the stars and associated circle together:

> orbit n = ( stars n
>           , circle (fromIntegral n - 1)
>             # lc (blend 0.95 white black)
>             # lw 0.08
>           )

Putting it all together

Finally, we generate the orbits from to and draw them all! Note that we have to draw all the orbit circles first and then the stars, because we don’t want any of the orbit circles getting drawn on top of the stars. This is what the funny business with unzip, uncurry atop, etc. is doing.

> starsOfTheMindsSky = uncurry atop
>                    . (mconcat***mconcat)
>                    . unzip
>                    . reverse
>                    . map orbit
>                    $ [2..24]
> 
> main = defaultMain (starsOfTheMindsSky # centerXY # pad 1.1)

And here’s Paul’s original version for comparison. Pretty close!

I love all the different patterns you can see in this work of art—close inspection and thinking really pays off as you discover more and more interesting structure. For example, this could really make a wonderful activity for a class—you could buy a print from Paul, put it up, and see what the students find!

Incidentally, I have also really been enjoying Paul’s “imbalance problems”, here, here, and here—go check them out!