{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-missing-methods #-}
module Diagrams.TwoD.Apollonian
(
Circle(..), mkCircle, center, radius
, descartes, other, initialConfig
, apollonian
, KissingSet(..), kissingSets, flipSelected, selectOthers
, apollonianTrees, apollonianTree
, drawCircle
, drawGasket
, apollonianGasket
) where
import Data.Complex
import qualified Data.Foldable as F
import Data.Maybe (catMaybes)
import Data.Tree
import Diagrams.Prelude hiding (center, radius)
import Control.Arrow (second, (&&&))
data Circle n = Circle
{ forall n. Circle n -> n
bend :: n
, forall n. Circle n -> Complex n
cb :: Complex n
}
deriving (Circle n -> Circle n -> Bool
forall n. Eq n => Circle n -> Circle n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Circle n -> Circle n -> Bool
$c/= :: forall n. Eq n => Circle n -> Circle n -> Bool
== :: Circle n -> Circle n -> Bool
$c== :: forall n. Eq n => Circle n -> Circle n -> Bool
Eq, Int -> Circle n -> ShowS
forall n. Show n => Int -> Circle n -> ShowS
forall n. Show n => [Circle n] -> ShowS
forall n. Show n => Circle n -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Circle n] -> ShowS
$cshowList :: forall n. Show n => [Circle n] -> ShowS
show :: Circle n -> String
$cshow :: forall n. Show n => Circle n -> String
showsPrec :: Int -> Circle n -> ShowS
$cshowsPrec :: forall n. Show n => Int -> Circle n -> ShowS
Show)
mkCircle :: Fractional n =>
n
-> P2 n
-> Circle n
mkCircle :: forall n. Fractional n => n -> P2 n -> Circle n
mkCircle n
r (forall n. P2 n -> (n, n)
unp2 -> (n
x,n
y)) = forall n. n -> Complex n -> Circle n
Circle (n
1forall a. Fractional a => a -> a -> a
/n
r) (n
bforall a. Num a => a -> a -> a
*n
x forall a. a -> a -> Complex a
:+ n
bforall a. Num a => a -> a -> a
*n
y)
where b :: n
b = n
1forall a. Fractional a => a -> a -> a
/n
r
center :: Fractional n => Circle n -> P2 n
center :: forall n. Fractional n => Circle n -> P2 n
center (Circle n
b (n
cbx :+ n
cby)) = forall n. (n, n) -> P2 n
p2 (n
cbx forall a. Fractional a => a -> a -> a
/ n
b, n
cby forall a. Fractional a => a -> a -> a
/ n
b)
radius :: Fractional n => Circle n -> n
radius :: forall n. Fractional n => Circle n -> n
radius = forall a. Num a => a -> a
abs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Fractional a => a -> a
recip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Circle n -> n
bend
liftF :: RealFloat n => (forall a. Floating a => a -> a) -> Circle n -> Circle n
liftF :: forall n.
RealFloat n =>
(forall a. Floating a => a -> a) -> Circle n -> Circle n
liftF forall a. Floating a => a -> a
f (Circle n
b Complex n
c) = forall n. n -> Complex n -> Circle n
Circle (forall a. Floating a => a -> a
f n
b) (forall a. Floating a => a -> a
f Complex n
c)
liftF2 :: RealFloat n => (forall a. Floating a => a -> a -> a) ->
Circle n -> Circle n -> Circle n
liftF2 :: forall n.
RealFloat n =>
(forall a. Floating a => a -> a -> a)
-> Circle n -> Circle n -> Circle n
liftF2 forall a. Floating a => a -> a -> a
f (Circle n
b1 Complex n
cb1) (Circle n
b2 Complex n
cb2) = forall n. n -> Complex n -> Circle n
Circle (forall a. Floating a => a -> a -> a
f n
b1 n
b2) (forall a. Floating a => a -> a -> a
f Complex n
cb1 Complex n
cb2)
instance RealFloat n => Num (Circle n) where
+ :: Circle n -> Circle n -> Circle n
(+) = forall n.
RealFloat n =>
(forall a. Floating a => a -> a -> a)
-> Circle n -> Circle n -> Circle n
liftF2 forall a. Num a => a -> a -> a
(+)
(-) = forall n.
RealFloat n =>
(forall a. Floating a => a -> a -> a)
-> Circle n -> Circle n -> Circle n
liftF2 (-)
* :: Circle n -> Circle n -> Circle n
(*) = forall n.
RealFloat n =>
(forall a. Floating a => a -> a -> a)
-> Circle n -> Circle n -> Circle n
liftF2 forall a. Num a => a -> a -> a
(*)
negate :: Circle n -> Circle n
negate = forall n.
RealFloat n =>
(forall a. Floating a => a -> a) -> Circle n -> Circle n
liftF forall a. Num a => a -> a
negate
abs :: Circle n -> Circle n
abs = forall n.
RealFloat n =>
(forall a. Floating a => a -> a) -> Circle n -> Circle n
liftF forall a. Num a => a -> a
abs
fromInteger :: Integer -> Circle n
fromInteger Integer
n = forall n. n -> Complex n -> Circle n
Circle (forall a. Num a => Integer -> a
fromInteger Integer
n) (forall a. Num a => Integer -> a
fromInteger Integer
n)
instance RealFloat n => Fractional (Circle n) where
/ :: Circle n -> Circle n -> Circle n
(/) = forall n.
RealFloat n =>
(forall a. Floating a => a -> a -> a)
-> Circle n -> Circle n -> Circle n
liftF2 forall a. Fractional a => a -> a -> a
(/)
recip :: Circle n -> Circle n
recip = forall n.
RealFloat n =>
(forall a. Floating a => a -> a) -> Circle n -> Circle n
liftF forall a. Fractional a => a -> a
recip
instance RealFloat n => Floating (Circle n) where
sqrt :: Circle n -> Circle n
sqrt = forall n.
RealFloat n =>
(forall a. Floating a => a -> a) -> Circle n -> Circle n
liftF forall a. Floating a => a -> a
sqrt
descartes :: Floating n => [n] -> [n]
descartes :: forall n. Floating n => [n] -> [n]
descartes [n
b1,n
b2,n
b3] = [n
r forall a. Num a => a -> a -> a
+ n
s, -n
r forall a. Num a => a -> a -> a
+ n
s]
where r :: n
r = n
2 forall a. Num a => a -> a -> a
* forall a. Floating a => a -> a
sqrt (n
b1forall a. Num a => a -> a -> a
*n
b2 forall a. Num a => a -> a -> a
+ n
b1forall a. Num a => a -> a -> a
*n
b3 forall a. Num a => a -> a -> a
+ n
b2forall a. Num a => a -> a -> a
*n
b3)
s :: n
s = n
b1forall a. Num a => a -> a -> a
+n
b2forall a. Num a => a -> a -> a
+n
b3
descartes [n]
_ = forall a. HasCallStack => String -> a
error String
"descartes must be called on a list of length 3"
other :: Num n => [n] -> n -> n
other :: forall n. Num n => [n] -> n -> n
other [n]
xs n
x = n
2 forall a. Num a => a -> a -> a
* forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [n]
xs forall a. Num a => a -> a -> a
- n
x
initialConfig :: RealFloat n => n -> n -> n -> [Circle n]
initialConfig :: forall n. RealFloat n => n -> n -> n -> [Circle n]
initialConfig n
b1 n
b2 n
b3 = [Circle n]
cs forall a. [a] -> [a] -> [a]
++ [Circle n
c4]
where cs :: [Circle n]
cs = [forall n. n -> Complex n -> Circle n
Circle n
b1 Complex n
0, forall n. n -> Complex n -> Circle n
Circle n
b2 ((n
b2forall a. Fractional a => a -> a -> a
/n
b1 forall a. Num a => a -> a -> a
+ n
1) forall a. a -> a -> Complex a
:+ n
0), forall n. n -> Complex n -> Circle n
Circle n
b3 Complex n
cb3]
a :: n
a = n
1forall a. Fractional a => a -> a -> a
/n
b1 forall a. Num a => a -> a -> a
+ n
1forall a. Fractional a => a -> a -> a
/n
b2
b :: n
b = n
1forall a. Fractional a => a -> a -> a
/n
b1 forall a. Num a => a -> a -> a
+ n
1forall a. Fractional a => a -> a -> a
/n
b3
c :: n
c = n
1forall a. Fractional a => a -> a -> a
/n
b2 forall a. Num a => a -> a -> a
+ n
1forall a. Fractional a => a -> a -> a
/n
b3
x :: n
x = (n
bforall a. Num a => a -> a -> a
*n
b forall a. Num a => a -> a -> a
+ n
aforall a. Num a => a -> a -> a
*n
a forall a. Num a => a -> a -> a
- n
cforall a. Num a => a -> a -> a
*n
c)forall a. Fractional a => a -> a -> a
/(n
2forall a. Num a => a -> a -> a
*n
a)
y :: n
y = forall a. Floating a => a -> a
sqrt (n
bforall a. Num a => a -> a -> a
*n
b forall a. Num a => a -> a -> a
- n
xforall a. Num a => a -> a -> a
*n
x)
cb3 :: Complex n
cb3 = n
b3forall a. Num a => a -> a -> a
*n
x forall a. a -> a -> Complex a
:+ n
b3forall a. Num a => a -> a -> a
*n
y
[Circle n
c4,Circle n
_] = forall n. Floating n => [n] -> [n]
descartes [Circle n]
cs
select :: [a] -> [(a, [a])]
select :: forall a. [a] -> [(a, [a])]
select [] = []
select (a
x:[a]
xs) = (a
x,[a]
xs) forall a. a -> [a] -> [a]
: (forall a b. (a -> b) -> [a] -> [b]
map forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second) (a
xforall a. a -> [a] -> [a]
:) (forall a. [a] -> [(a, [a])]
select [a]
xs)
data KissingSet n = KS { forall n. KissingSet n -> n
selected :: n, forall n. KissingSet n -> [n]
others :: [n] }
deriving (Int -> KissingSet n -> ShowS
forall n. Show n => Int -> KissingSet n -> ShowS
forall n. Show n => [KissingSet n] -> ShowS
forall n. Show n => KissingSet n -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KissingSet n] -> ShowS
$cshowList :: forall n. Show n => [KissingSet n] -> ShowS
show :: KissingSet n -> String
$cshow :: forall n. Show n => KissingSet n -> String
showsPrec :: Int -> KissingSet n -> ShowS
$cshowsPrec :: forall n. Show n => Int -> KissingSet n -> ShowS
Show)
kissingSets :: [n] -> [KissingSet n]
kissingSets :: forall n. [n] -> [KissingSet n]
kissingSets = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall n. n -> [n] -> KissingSet n
KS) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [(a, [a])]
select
flipSelected :: Num n => KissingSet n -> KissingSet n
flipSelected :: forall n. Num n => KissingSet n -> KissingSet n
flipSelected (KS n
c [n]
cs) = forall n. n -> [n] -> KissingSet n
KS (forall n. Num n => [n] -> n -> n
other [n]
cs n
c) [n]
cs
selectOthers :: KissingSet n -> [KissingSet n]
selectOthers :: forall n. KissingSet n -> [KissingSet n]
selectOthers (KS n
c [n]
cs) = [ forall n. n -> [n] -> KissingSet n
KS n
c' (n
cforall a. a -> [a] -> [a]
:[n]
cs') | (n
c',[n]
cs') <- forall a. [a] -> [(a, [a])]
select [n]
cs ]
apollonian :: RealFloat n => n -> [Circle n] -> [Circle n]
apollonian :: forall n. RealFloat n => n -> [Circle n] -> [Circle n]
apollonian n
thresh [Circle n]
cs
= ([Circle n]
csforall a. [a] -> [a] -> [a]
++)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall a. Tree a -> [a]
flatten forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> Tree a -> Maybe (Tree a)
prune Circle n -> Bool
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall n. KissingSet n -> n
selected)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n.
RealFloat n =>
[Circle n] -> [Tree (KissingSet (Circle n))]
apollonianTrees
forall a b. (a -> b) -> a -> b
$ [Circle n]
cs
where
p :: Circle n -> Bool
p Circle n
c = forall n. Fractional n => Circle n -> n
radius Circle n
c forall a. Ord a => a -> a -> Bool
>= n
thresh
apollonianTrees :: RealFloat n => [Circle n] -> [Tree (KissingSet (Circle n))]
apollonianTrees :: forall n.
RealFloat n =>
[Circle n] -> [Tree (KissingSet (Circle n))]
apollonianTrees = forall a b. (a -> b) -> [a] -> [b]
map (forall n.
RealFloat n =>
KissingSet (Circle n) -> Tree (KissingSet (Circle n))
apollonianTree forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Num n => KissingSet n -> KissingSet n
flipSelected) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. [n] -> [KissingSet n]
kissingSets
apollonianTree :: RealFloat n => KissingSet (Circle n) -> Tree (KissingSet (Circle n))
apollonianTree :: forall n.
RealFloat n =>
KissingSet (Circle n) -> Tree (KissingSet (Circle n))
apollonianTree = forall b a. (b -> (a, [b])) -> b -> Tree a
unfoldTree (forall a. a -> a
id forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (forall a b. (a -> b) -> [a] -> [b]
map forall n. Num n => KissingSet n -> KissingSet n
flipSelected forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. KissingSet n -> [KissingSet n]
selectOthers))
prune :: (a -> Bool) -> Tree a -> Maybe (Tree a)
prune :: forall a. (a -> Bool) -> Tree a -> Maybe (Tree a)
prune a -> Bool
p (Node a
a [Tree a]
ts)
| Bool -> Bool
not (a -> Bool
p a
a) = forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> [Tree a] -> Tree a
Node a
a (forall a. [Maybe a] -> [a]
catMaybes (forall a b. (a -> b) -> [a] -> [b]
map (forall a. (a -> Bool) -> Tree a -> Maybe (Tree a)
prune a -> Bool
p) [Tree a]
ts))
drawCircle :: (Renderable (Path V2 n) b, TypeableFloat n) =>
Circle n -> QDiagram b V2 n Any
drawCircle :: forall n b.
(Renderable (Path V2 n) b, TypeableFloat n) =>
Circle n -> QDiagram b V2 n Any
drawCircle Circle n
c = forall t n.
(TrailLike t, V t ~ V2, N t ~ n, Transformable t) =>
n -> t
circle (forall n. Fractional n => Circle n -> n
radius Circle n
c) forall a b. a -> (a -> b) -> b
# forall (v :: * -> *) n t.
(InSpace v n t, HasOrigin t) =>
Point v n -> t -> t
moveTo (forall n. Fractional n => Circle n -> P2 n
center Circle n
c)
# fcA transparent
drawGasket :: (Renderable (Path V2 n) b, TypeableFloat n) =>
[Circle n] -> QDiagram b V2 n Any
drawGasket :: forall n b.
(Renderable (Path V2 n) b, TypeableFloat n) =>
[Circle n] -> QDiagram b V2 n Any
drawGasket [Circle n]
cs = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap forall n b.
(Renderable (Path V2 n) b, TypeableFloat n) =>
Circle n -> QDiagram b V2 n Any
drawCircle [Circle n]
cs
apollonianGasket :: (Renderable (Path V2 n) b, TypeableFloat n)
=> n -> n -> n -> n -> QDiagram b V2 n Any
apollonianGasket :: forall n b.
(Renderable (Path V2 n) b, TypeableFloat n) =>
n -> n -> n -> n -> QDiagram b V2 n Any
apollonianGasket n
thresh n
b1 n
b2 n
b3 = forall n b.
(Renderable (Path V2 n) b, TypeableFloat n) =>
[Circle n] -> QDiagram b V2 n Any
drawGasket forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. RealFloat n => n -> [Circle n] -> [Circle n]
apollonian n
thresh forall a b. (a -> b) -> a -> b
$ (forall n. RealFloat n => n -> n -> n -> [Circle n]
initialConfig n
b1 n
b2 n
b3)