{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.TwoD.Sunburst
-- Copyright   :  (c) 2013-14 Jeffrey Rosenbluth
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  jeffrey.rosenbluth@gmail.com
--
-- Generation of Sunburst Partitions. A radial view of a Treemap.
--
-- The partitions are created without examining the contents of the tree nodes
-- which allows us to create a sunburst for any @Tree a@. As a consequence we cannot
-- base the size or color of the sections on the data in the tree, but only
-- on depth and number of children. Of course the code could easily be adapted
-- to handle more specific tree data.
--
-- See John Stasko, Richard Catrambone, \"An evaluation of space-filling
-- information visualizations for depicting hierarchical structures\", 2000.
-- <http://www.cc.gatech.edu/~john.stasko/papers/ijhcs00.pdf>.
--
-----------------------------------------------------------------------------

module Diagrams.TwoD.Sunburst
  ( --  * Sunburst
    sunburst'
  , sunburst
  , SunburstOpts(..)
  , radius
  , sectionWidth
  , colors
  ) where

import           Data.Default
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 -- ^ Relative size of the root circle, usually 1.
  , forall n. SunburstOpts n -> n
_sectionWidth :: n -- ^ Relative width of the sections.
  , forall n. SunburstOpts n -> [Colour Double]
_colors       :: [Colour Double]} -- ^ Color list one for each ring.

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       = [ Colour Double
forall a. (Ord a, Floating a) => Colour a
lightcoral, Colour Double
forall a. (Ord a, Floating a) => Colour a
lightseagreen, Colour Double
forall a. (Ord a, Floating a) => Colour a
paleturquoise
                      , Colour Double
forall a. (Ord a, Floating a) => Colour a
lightsteelblue, Colour Double
forall a. (Ord a, Floating a) => Colour a
plum, Colour Double
forall a. (Ord a, Floating a) => Colour a
violet, Colour Double
forall a. (Ord a, Floating a) => Colour a
coral, Colour Double
forall a. (Ord a, Floating a) => Colour a
honeydew]}

makeLenses ''SunburstOpts

-- Section data: Will be stored in nodes of a new rose tree and used to
-- make each section of the sunburst partition.
data SData n = SData
  n-- section radius
  n-- section width
  (Direction V2 n)  -- start direction
  (Angle n)           -- sweep angle
  Int             -- number of sections
  (Colour Double) -- color

-- Make n sections (annular wedges) starting in direction d and sweeping a
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) = [QDiagram b V2 n Any] -> QDiagram b V2 n Any
forall a. Monoid a => [a] -> a
mconcat ([QDiagram b V2 n Any] -> QDiagram b V2 n Any)
-> [QDiagram b V2 n Any] -> QDiagram b V2 n Any
forall a b. (a -> b) -> a -> b
$ Int
-> (QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> QDiagram b V2 n Any
-> [QDiagram b V2 n Any]
forall a. Int -> (a -> a) -> a -> [a]
iterateN Int
n (Angle n -> QDiagram b V2 n Any -> QDiagram b V2 n Any
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 Angle n -> n -> Angle n
forall (f :: * -> *) a.
(Functor f, Fractional a) =>
f a -> a -> f a
^/ Int -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
    w :: QDiagram b V2 n Any
w = n -> n -> Direction V2 n -> Angle n -> QDiagram b V2 n Any
forall t n.
(TrailLike t, V t ~ V2, N t ~ n, RealFloat n) =>
n -> n -> Direction V2 n -> Angle n -> t
annularWedge (n
s n -> n -> n
forall a. Num a => a -> a -> a
+ n
r) n
r Direction V2 n
d Angle n
theta QDiagram b V2 n Any
-> (QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> QDiagram b V2 n Any
forall a b. a -> (a -> b) -> b
# Colour Double -> QDiagram b V2 n Any -> QDiagram b V2 n Any
forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc Colour Double
forall a. (Ord a, Floating a) => Colour a
white QDiagram b V2 n Any
-> (QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> QDiagram b V2 n Any
forall a b. a -> (a -> b) -> b
# n -> QDiagram b V2 n Any -> QDiagram b V2 n Any
forall a n. (N a ~ n, HasStyle a, Typeable n, Num n) => n -> a -> a
lwG n
0.008 QDiagram b V2 n Any
-> (QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> QDiagram b V2 n Any
forall a b. a -> (a -> b) -> b
# Colour Double -> QDiagram b V2 n Any -> QDiagram b V2 n Any
forall n a.
(InSpace V2 n a, Floating n, Typeable n, HasStyle a) =>
Colour Double -> a -> a
fc Colour Double
c

-- Convert an arbitrary @Tree a@ to a @Tree SData@ storing the sections info
-- in the nodes. If color list is shorter than depth of tree than the first
-- color of the list is repeated. If the color list is empty, lightgray is used.
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 =
  SunburstOpts n
-> Tree a -> Direction V2 n -> Angle n -> Tree (SData n)
forall n a.
Floating n =>
SunburstOpts n
-> Tree a -> Direction V2 n -> Angle n -> Tree (SData n)
toTree (n -> n -> [Colour Double] -> SunburstOpts n
forall n. n -> n -> [Colour Double] -> SunburstOpts n
SunburstOpts n
r n
s (Colour Double -> [Colour Double]
forall a. a -> [a]
repeat Colour Double
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 = SData n -> [Tree (SData n)] -> Tree (SData n)
forall a. a -> [Tree a] -> Tree a
Node (n
-> n
-> Direction V2 n
-> Angle n
-> Int
-> Colour Double
-> SData n
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 = [Tree a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tree a]
ts
    dt :: Angle n
dt =  Angle n
a Angle n -> n -> Angle n
forall (f :: * -> *) a.
(Functor f, Fractional a) =>
f a -> a -> f a
^/ Int -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
    qs :: [Direction V2 n]
qs = [Angle n -> Direction V2 n -> Direction V2 n
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate (Int -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i n -> Angle n -> Angle n
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 = SunburstOpts n
-> Tree a -> Direction V2 n -> Angle n -> Tree (SData n)
forall n a.
Floating n =>
SunburstOpts n
-> Tree a -> Direction V2 n -> Angle n -> Tree (SData n)
toTree (n -> n -> [Colour Double] -> SunburstOpts n
forall n. n -> n -> [Colour Double] -> SunburstOpts n
SunburstOpts(n
r n -> n -> n
forall a. Num a => a -> a -> a
+ n
s) n
s ([Colour Double]
cs [Colour Double] -> [Colour Double] -> [Colour Double]
forall a. [a] -> [a] -> [a]
++ [Colour Double
c]))
    ts' :: [Tree (SData n)]
ts' = (Tree a -> Direction V2 n -> Angle n -> Tree (SData n))
-> [Tree a] -> [Direction V2 n] -> [Angle n] -> [Tree (SData n)]
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 (Int -> [Direction V2 n] -> [Direction V2 n]
forall a. Int -> [a] -> [a]
take (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [Direction V2 n]
qs) (Angle n -> [Angle n]
forall a. a -> [a]
repeat Angle n
dt)

-- | Take any @Tree a@ and @SunburstOpts@ and make a sunburst partition.
--   Basically a treemap with a radial layout.
--   The root is the center of the sunburst and its circumference is divided
--   evenly according to the number of child nodes it has. Then each of those
--   sections is treated the same way.
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 = Tree (SData n) -> QDiagram b V2 n Any
forall {n} {b}.
(Renderable (Path V2 n) b, Typeable n, RealFloat n) =>
Tree (SData n) -> QDiagram b V2 n Any
sunB (Tree (SData n) -> QDiagram b V2 n Any)
-> Tree (SData n) -> QDiagram b V2 n Any
forall a b. (a -> b) -> a -> b
$ SunburstOpts n
-> Tree a -> Direction V2 n -> Angle n -> Tree (SData n)
forall n a.
Floating n =>
SunburstOpts n
-> Tree a -> Direction V2 n -> Angle n -> Tree (SData n)
toTree SunburstOpts n
opts Tree a
t Direction V2 n
forall (v :: * -> *) n. (R1 v, Additive v, Num n) => Direction v n
xDir Angle n
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') = SData n -> QDiagram b V2 n Any
forall n b.
(Renderable (Path V2 n) b, TypeableFloat n) =>
SData n -> QDiagram b V2 n Any
sections SData n
sd QDiagram b V2 n Any -> QDiagram b V2 n Any -> QDiagram b V2 n Any
forall a. Semigroup a => a -> a -> a
<> (Tree (SData n) -> QDiagram b V2 n Any)
-> [Tree (SData n)] -> QDiagram b V2 n Any
forall m a. Monoid m => (a -> m) -> [a] -> m
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@ with default opts
--
--   > import Diagrams.TwoD.Sunburst
--   > import Data.Tree (unfoldTree)
--   > aTree = unfoldTree (\n -> (0, replicate n (n-1))) 6
--   > sunburstEx = sunburst aTree # pad 1.1
--
--   <<diagrams/src_Diagrams_TwoD_Sunburst_sunburstEx.svg#diagram=sunburstEx&width=500>>
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 = SunburstOpts n -> Tree a -> QDiagram b V2 n Any
forall n b a.
(Renderable (Path V2 n) b, TypeableFloat n) =>
SunburstOpts n -> Tree a -> QDiagram b V2 n Any
sunburst' SunburstOpts n
forall a. Default a => a
def