Not too complicated and just a different view of Ford’s circles and a way of morphing

them along with a bit of animation.

It’s a continuation of the previous post and there are two parts to it – the real bit and the imaginary part.

#### The Real Part

To start with we take fractions not between 0 and 1 but rather between -n and n. A rough and ready way is

1 2 3 |
-- fractionsN :: Integer -> [Fraction] fractionsN n = nub [ reduce (F p q) | p <- [-n..n], q <- [-n..n]] |

where we take all possible pairs and reduce them. Note we allow 0 as a denominator so as to be consistent with the Farey sequence.

For example

1 2 3 |
-- Ī»-> fractionsN 5 [1/1,5/4,5/3,5/2,5/1,-5/0,-5/1,-5/2,-5/3,-5/4,-1/1,4/5,4/3,2/1,4/1,-4/0,-4/1,-2/1,-4/3,-4/5,3/5,3/4,3/2,3/1,-3/0,-3/1,-3/2,-3/4,-3/5,2/5,1/2,2/3,-2/0,-2/3,-1/2,-2/5,1/5,1/4,1/3,-1/0,-1/3,-1/4,-1/5,0/1,0/0,1/0,2/0,3/0,4/0,5/0] |

The snippets of code below will take a list of *Fraction* and generate Ford circles.

1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
-- fordCircles :: [Fraction] -> [FordCircle] fordCircles = fmap fordCircle fordCircle :: Fraction -> FordCircle fordCircle (F p 0) = (0, 0, 0) fordCircle (F p q) = (r, fromIntegral p / fromIntegral q, r ) where r = 1/fromIntegral (2*q*q) circ :: FordCircle -> Picture circ c@(r, x, y) = translate x y . color (newColour c) . Circle $ r makeCircles :: ([FordCircle] -> [FordCircle]) -> [Fraction] -> Picture makeCircles f = Pictures . fmap circ . f . fordCircles |

The key function is *makeCircles* – notice that its signature is

makeCircles :: ([FordCircle] -> [FordCircle]) -> [Fraction] -> Picture

It takes a function that maps [*FordCircle*] to [*FordCircle*]. The purpose of this will be shown later – at the moment we can just use the identity function so that it has no effect on the list of *FordCircle*. And, using the identity function and polishing to a Gloss finish we can write:

1 2 3 4 5 6 7 8 |
-- main :: IO () main = do let cs = fractionsN 20 display (InWindow "Window" (1400, 800) (0, 0)) (greyN 0.2) (Pictures [scale 100 100 $ makeCircles id cs ]) |

with output:

Very much like the Ford circles in the previous post but ‘longer’. Now the for the

#### Imaginary Part

With a suitable import (*Data.Complex*) we can quite easily use Complex numbers in Haskell code and doing so often makes things simpler.

1 2 3 4 5 6 7 8 |
-- type Cmplx = Complex Float i :: Cmplx i = 0 :+ 1 fz :: Cmplx -> Cmplx fz z = (z - i)/(z + i) |

Here *z* is a Complex number consisting of a Real and Imaginary part – i.e. and the function *fz* is a particular type of complex function (Mobius Transform) that will map a circle onto another circle. Taking a list of circles we can determine three points on the circle, apply *fz* to each point and then determine the new circle that lies on those three points. (Does anyone know if there’s a simpler or better way to do this?) i.e.

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
-- makeCircle :: Cmplx -> Cmplx -> Cmplx -> FordCircle makeCircle z1 z2 z3 = (r, x, y) where x1 = realPart z1 x2 = realPart z2 x3 = realPart z3 y1 = imagPart z1 y2 = imagPart z2 y3 = imagPart z3 k = 2 * (x1 * (y2 - y3) - y1 * (x2 - x3) + x2 * y3 - x3 * y2) x = ((x1^2 + y1^2) * (y2 - y3) + (x2^2 + y2^2) * (y3 - y1) + (x3^2 + y3^2) * (y1 - y2)) / k y = ((x1^2 + y1^2) * (x3 - x2) + (x2^2 + y2^2) * (x1 - x3) + (x3^2 + y3^2) * (x2 - x1)) / k r = sqrt ((x - x1)^2 + (y - y1)^2) planeMap :: [FordCircle] -> [FordCircle] planeMap = fmap f where -- radius, center x, center y f (r, x, y) = makeCircle (fz z1) (fz z2) (fz z3) where z1 = (x + r) :+ y z2 = (x - r) :+ y z3 = x :+ (y + r) |

In the function *planeMap z1, z2* and *z3* are all on the circle and their image under *fz* is used to determine a new circle. The function *makeCircle* is just an exercise in coordinate geometry. Now we can invoke *makeCircles* but this time give it *planeMap* rather than the *id* function.

1 2 3 4 5 6 7 |
main :: IO () main = do let cs = fractionsN 20 display (InWindow "Window" (1400, 800) (0, 0)) (greyN 0.2) (Pictures [scale 100 100 $ makeCircles planeMap cs, translate 0 (-250) $ scale 100 100 $ makeCircles id cs]) |

Here we have the original set of circles and above them, the result of the transform š

To get the animation shown at the beginning we define another complex function, *fzz (*naming things is difficult…)

1 2 3 |
-- fzz :: Float -> Cmplx -> Cmplx fzz flt z= (z - i)/(z + i)**(flt :+ 0) |

When the Float value in *fzz* is 1.0 then *fzz* is a Mobius Transform – it is identical to our first *fz* function. When the Float value is not 1.0 then I’m not sure it has a particular name, its just a mapping š We can apply it along with the animation capability of Gloss to create a ‘morphing’ of the Ford circles into the final disk.

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
-- planeMap' :: Float -> [FordCircle] -> [FordCircle] planeMap' fl = fmap f where f (r, x, y) = makeCircle (fzz fl z1) (fzz fl z2) (fzz fl z3) where z1 = (x + r) :+ y z2 = (x - r) :+ y z3 = x :+ (y + r) frame :: [Fraction] -> Float -> Picture frame cs fl = rotate (fl*50) $ scale 250 250 $ makeCircles (planeMap' step) cs where step = if fl * 0.1 >= 1.0 then 1.0 else fl * 0.1 main :: IO () main = do let cs = fractionsN 20 display (InWindow "Window" (1400, 800) (0, 0)) (greyN 0.2) (Pictures [scale 100 100 $ makeCircles planeMap cs, translate 0 (-250) $ scale 100 100 $ makeCircles id cs]) main :: IO () main = do let cs = fractionsN 20 -- [Fraction] animate FullScreen (greyN 0.2) $ frame cs |

which produce the animation at the top of the page.

For added fun we can just let the value of *step* that get passed into planeMap’ increase unbounded and see how the original line of circles morphs into something intriguing…

All the code is in Github and thanks for reading!