{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Diagrams.TwoD.Sunburst
(
sunburst'
, sunburst
, SunburstOpts(..)
, radius
, sectionWidth
, colors
) where
import Data.Default.Class
import qualified Data.Foldable as F
import Data.Tree
import Diagrams.Prelude hiding (radius)
data SunburstOpts n = SunburstOpts
{ forall n. SunburstOpts n -> n
_radius :: n
, forall n. SunburstOpts n -> n
_sectionWidth :: n
, forall n. SunburstOpts n -> [Colour Double]
_colors :: [Colour Double]}
instance Fractional n => Default (SunburstOpts n) where
def :: SunburstOpts n
def = SunburstOpts
{ _radius :: n
_radius = n
1.0
, _sectionWidth :: n
_sectionWidth = n
0.3
, _colors :: [Colour Double]
_colors = [ forall a. (Ord a, Floating a) => Colour a
lightcoral, forall a. (Ord a, Floating a) => Colour a
lightseagreen, forall a. (Ord a, Floating a) => Colour a
paleturquoise
, forall a. (Ord a, Floating a) => Colour a
lightsteelblue, forall a. (Ord a, Floating a) => Colour a
plum, forall a. (Ord a, Floating a) => Colour a
violet, forall a. (Ord a, Floating a) => Colour a
coral, forall a. (Ord a, Floating a) => Colour a
honeydew]}
makeLenses ''SunburstOpts
data SData n = SData
n
n
(Direction V2 n)
(Angle n)
Int
(Colour Double)
sections :: (Renderable (Path V2 n) b, TypeableFloat n) =>
SData n -> QDiagram b V2 n Any
sections :: forall n b.
(Renderable (Path V2 n) b, TypeableFloat n) =>
SData n -> QDiagram b V2 n Any
sections (SData n
r n
s Direction V2 n
d Angle n
a Int
n Colour Double
c) = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a. Int -> (a -> a) -> a -> [a]
iterateN Int
n (forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate Angle n
theta) QDiagram b V2 n Any
w
where
theta :: Angle n
theta = Angle n
a forall (f :: * -> *) a.
(Functor f, Fractional a) =>
f a -> a -> f a
^/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
w :: QDiagram b V2 n Any
w = forall t n.
(TrailLike t, V t ~ V2, N t ~ n, RealFloat n) =>
n -> n -> Direction V2 n -> Angle n -> t
annularWedge (n
s forall a. Num a => a -> a -> a
+ n
r) n
r Direction V2 n
d Angle n
theta forall a b. a -> (a -> b) -> b
# forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc forall a. (Ord a, Floating a) => Colour a
white forall a b. a -> (a -> b) -> b
# forall a n. (N a ~ n, HasStyle a, Typeable n, Num n) => n -> a -> a
lwG n
0.008 forall a b. a -> (a -> b) -> b
# forall n a.
(InSpace V2 n a, Floating n, Typeable n, HasStyle a) =>
Colour Double -> a -> a
fc Colour Double
c
toTree :: Floating n =>
SunburstOpts n -> Tree a -> Direction V2 n -> Angle n -> Tree (SData n)
toTree :: forall n a.
Floating n =>
SunburstOpts n
-> Tree a -> Direction V2 n -> Angle n -> Tree (SData n)
toTree (SunburstOpts n
r n
s []) Tree a
x Direction V2 n
q1 Angle n
q2 =
forall n a.
Floating n =>
SunburstOpts n
-> Tree a -> Direction V2 n -> Angle n -> Tree (SData n)
toTree (forall n. n -> n -> [Colour Double] -> SunburstOpts n
SunburstOpts n
r n
s (forall a. a -> [a]
repeat forall a. (Ord a, Floating a) => Colour a
lightgray)) Tree a
x Direction V2 n
q1 Angle n
q2
toTree (SunburstOpts n
r n
s (Colour Double
c:[Colour Double]
cs)) (Node a
_ [Tree a]
ts) Direction V2 n
d Angle n
a = forall a. a -> [Tree a] -> Tree a
Node (forall n.
n
-> n
-> Direction V2 n
-> Angle n
-> Int
-> Colour Double
-> SData n
SData n
r n
s Direction V2 n
d Angle n
a Int
n Colour Double
c) [Tree (SData n)]
ts'
where
n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tree a]
ts
dt :: Angle n
dt = Angle n
a forall (f :: * -> *) a.
(Functor f, Fractional a) =>
f a -> a -> f a
^/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
qs :: [Direction V2 n]
qs = [forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ Angle n
dt ) Direction V2 n
d | Int
i <- [Int
0..Int
n]]
fs :: Tree a -> Direction V2 n -> Angle n -> Tree (SData n)
fs = forall n a.
Floating n =>
SunburstOpts n
-> Tree a -> Direction V2 n -> Angle n -> Tree (SData n)
toTree (forall n. n -> n -> [Colour Double] -> SunburstOpts n
SunburstOpts(n
r forall a. Num a => a -> a -> a
+ n
s) n
s ([Colour Double]
cs forall a. [a] -> [a] -> [a]
++ [Colour Double
c]))
ts' :: [Tree (SData n)]
ts' = forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Tree a -> Direction V2 n -> Angle n -> Tree (SData n)
fs [Tree a]
ts (forall a. Int -> [a] -> [a]
take (Int
nforall a. Num a => a -> a -> a
-Int
1) [Direction V2 n]
qs) (forall a. a -> [a]
repeat Angle n
dt)
sunburst' :: (Renderable (Path V2 n) b, TypeableFloat n) =>
SunburstOpts n -> Tree a -> QDiagram b V2 n Any
sunburst' :: forall n b a.
(Renderable (Path V2 n) b, TypeableFloat n) =>
SunburstOpts n -> Tree a -> QDiagram b V2 n Any
sunburst' SunburstOpts n
opts Tree a
t = forall {n} {b}.
(Renderable (Path V2 n) b, Typeable n, RealFloat n) =>
Tree (SData n) -> QDiagram b V2 n Any
sunB forall a b. (a -> b) -> a -> b
$ forall n a.
Floating n =>
SunburstOpts n
-> Tree a -> Direction V2 n -> Angle n -> Tree (SData n)
toTree SunburstOpts n
opts Tree a
t forall (v :: * -> *) n. (R1 v, Additive v, Num n) => Direction v n
xDir forall v. Floating v => Angle v
fullTurn
where sunB :: Tree (SData n) -> QDiagram b V2 n Any
sunB (Node SData n
sd [Tree (SData n)]
ts') = forall n b.
(Renderable (Path V2 n) b, TypeableFloat n) =>
SData n -> QDiagram b V2 n Any
sections SData n
sd forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap Tree (SData n) -> QDiagram b V2 n Any
sunB [Tree (SData n)]
ts'
sunburst :: (Renderable (Path V2 n) b, TypeableFloat n) => Tree a -> QDiagram b V2 n Any
sunburst :: forall n b a.
(Renderable (Path V2 n) b, TypeableFloat n) =>
Tree a -> QDiagram b V2 n Any
sunburst = forall n b a.
(Renderable (Path V2 n) b, TypeableFloat n) =>
SunburstOpts n -> Tree a -> QDiagram b V2 n Any
sunburst' forall a. Default a => a
def