{-# LANGUAGE TemplateHaskell #-}
module Graphics.Rendering.Chart.Legend(
Legend(..),
LegendStyle(..),
LegendOrientation(..),
LegendPosition(..),
legendToRenderable,
legend_label_style,
legend_margin,
legend_plot_size,
legend_orientation,
legend_position
) where
import Data.List (partition,intersperse)
import Control.Lens
import Data.Default.Class
import Graphics.Rendering.Chart.Geometry
import Graphics.Rendering.Chart.Drawing
import Graphics.Rendering.Chart.Renderable
import Graphics.Rendering.Chart.Grid
data LegendStyle = LegendStyle {
LegendStyle -> FontStyle
_legend_label_style :: FontStyle,
LegendStyle -> Double
_legend_margin :: Double,
LegendStyle -> Double
_legend_plot_size :: Double,
LegendStyle -> LegendOrientation
_legend_orientation :: LegendOrientation,
LegendStyle -> LegendPosition
_legend_position :: LegendPosition
}
data LegendOrientation = LORows Int
| LOCols Int
data LegendPosition = LegendAbove
| LegendBelow
| LegendRight
| LegendLeft
data Legend x y = Legend LegendStyle [(String, Rect -> BackendProgram ())]
instance ToRenderable (Legend x y) where
toRenderable :: Legend x y -> Renderable ()
toRenderable = forall b a. PickFn b -> Renderable a -> Renderable b
setPickFn forall a. PickFn a
nullPickFn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x y. Legend x y -> Renderable String
legendToRenderable
legendToRenderable :: Legend x y -> Renderable String
legendToRenderable :: forall x y. Legend x y -> Renderable String
legendToRenderable (Legend LegendStyle
ls [(String, Rect -> BackendProgram ())]
lvs) = forall a. Grid (Renderable a) -> Renderable a
gridToRenderable Grid (Renderable String)
grid
where
grid :: Grid (Renderable String)
grid :: Grid (Renderable String)
grid = case LegendStyle -> LegendOrientation
_legend_orientation LegendStyle
ls of
LORows Int
n -> Int
-> ([Grid (Renderable String)] -> Grid (Renderable String))
-> ([Grid (Renderable String)] -> Grid (Renderable String))
-> Grid (Renderable String)
mkGrid Int
n [Grid (Renderable String)] -> Grid (Renderable String)
aboveG [Grid (Renderable String)] -> Grid (Renderable String)
besideG
LOCols Int
n -> Int
-> ([Grid (Renderable String)] -> Grid (Renderable String))
-> ([Grid (Renderable String)] -> Grid (Renderable String))
-> Grid (Renderable String)
mkGrid Int
n [Grid (Renderable String)] -> Grid (Renderable String)
besideG [Grid (Renderable String)] -> Grid (Renderable String)
aboveG
aboveG, besideG :: [Grid (Renderable String)] -> Grid (Renderable String)
aboveG :: [Grid (Renderable String)] -> Grid (Renderable String)
aboveG = forall a. [Grid a] -> Grid a
aboveNforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. a -> [a] -> [a]
intersperse Grid (Renderable String)
ggap1
besideG :: [Grid (Renderable String)] -> Grid (Renderable String)
besideG = forall a. [Grid a] -> Grid a
besideNforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. a -> [a] -> [a]
intersperse Grid (Renderable String)
ggap1
mkGrid :: Int
-> ([Grid (Renderable String)] -> Grid (Renderable String))
-> ([Grid (Renderable String)] -> Grid (Renderable String))
-> Grid (Renderable String)
mkGrid :: Int
-> ([Grid (Renderable String)] -> Grid (Renderable String))
-> ([Grid (Renderable String)] -> Grid (Renderable String))
-> Grid (Renderable String)
mkGrid Int
n [Grid (Renderable String)] -> Grid (Renderable String)
join1 [Grid (Renderable String)] -> Grid (Renderable String)
join2 = [Grid (Renderable String)] -> Grid (Renderable String)
join1 [ [Grid (Renderable String)] -> Grid (Renderable String)
join2 (forall a b. (a -> b) -> [a] -> [b]
map (String, [Rect -> BackendProgram ()]) -> Grid (Renderable String)
rf [(String, [Rect -> BackendProgram ()])]
ps1) | [(String, [Rect -> BackendProgram ()])]
ps1 <- forall a. Int -> [a] -> [[a]]
groups Int
n [(String, [Rect -> BackendProgram ()])]
ps ]
ps :: [(String, [Rect -> BackendProgram ()])]
ps :: [(String, [Rect -> BackendProgram ()])]
ps = forall a. [(String, a)] -> [(String, [a])]
join_nub [(String, Rect -> BackendProgram ())]
lvs
rf :: (String, [Rect -> BackendProgram ()]) -> Grid (Renderable String)
rf :: (String, [Rect -> BackendProgram ()]) -> Grid (Renderable String)
rf (String
title,[Rect -> BackendProgram ()]
rfs) = forall a. [Grid a] -> Grid a
besideN [Grid (Renderable String)
gpic,Grid (Renderable String)
ggap2,Grid (Renderable String)
gtitle]
where
gpic :: Grid (Renderable String)
gpic :: Grid (Renderable String)
gpic = forall a. [Grid a] -> Grid a
besideN forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse Grid (Renderable String)
ggap2 (forall a b. (a -> b) -> [a] -> [b]
map (Rect -> BackendProgram ()) -> Grid (Renderable String)
rp [Rect -> BackendProgram ()]
rfs)
gtitle :: Grid (Renderable String)
gtitle :: Grid (Renderable String)
gtitle = forall a. a -> Grid a
tval forall a b. (a -> b) -> a -> b
$ String -> Renderable String
lbl String
title
rp :: (Rect -> BackendProgram ()) -> Grid (Renderable String)
rp :: (Rect -> BackendProgram ()) -> Grid (Renderable String)
rp Rect -> BackendProgram ()
rfn = forall a. a -> Grid a
tval Renderable {
minsize :: BackendProgram RectSize
minsize = forall (m :: * -> *) a. Monad m => a -> m a
return (LegendStyle -> Double
_legend_plot_size LegendStyle
ls, Double
0),
render :: RectSize -> BackendProgram (PickFn String)
render = \(Double
w,Double
h) -> do
()
_ <- Rect -> BackendProgram ()
rfn (Point -> Point -> Rect
Rect (Double -> Double -> Point
Point Double
0 Double
0) (Double -> Double -> Point
Point Double
w Double
h))
forall (m :: * -> *) a. Monad m => a -> m a
return (\Point
_-> forall a. a -> Maybe a
Just String
title)
}
ggap1, ggap2 :: Grid (Renderable String)
ggap1 :: Grid (Renderable String)
ggap1 = forall a. a -> Grid a
tval forall a b. (a -> b) -> a -> b
$ forall a. RectSize -> Renderable a
spacer (LegendStyle -> Double
_legend_margin LegendStyle
ls,LegendStyle -> Double
_legend_margin LegendStyle
ls forall a. Fractional a => a -> a -> a
/ Double
2)
ggap2 :: Grid (Renderable String)
ggap2 = forall a. a -> Grid a
tval forall a b. (a -> b) -> a -> b
$ forall a b. Renderable a -> Renderable b
spacer1 (String -> Renderable String
lbl String
"X")
lbl :: String -> Renderable String
lbl :: String -> Renderable String
lbl = FontStyle
-> HTextAnchor -> VTextAnchor -> String -> Renderable String
label (LegendStyle -> FontStyle
_legend_label_style LegendStyle
ls) HTextAnchor
HTA_Left VTextAnchor
VTA_Centre
groups :: Int -> [a] -> [[a]]
groups :: forall a. Int -> [a] -> [[a]]
groups Int
_ [] = []
groups Int
n [a]
vs = let ([a]
vs1,[a]
vs2) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
vs in [a]
vs1forall a. a -> [a] -> [a]
:forall a. Int -> [a] -> [[a]]
groups Int
n [a]
vs2
join_nub :: [(String, a)] -> [(String, [a])]
join_nub :: forall a. [(String, a)] -> [(String, [a])]
join_nub ((String
x,a
a1):[(String, a)]
ys) = case forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((forall a. Eq a => a -> a -> Bool
==String
x) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(String, a)]
ys of
([(String, a)]
xs, [(String, a)]
rest) -> (String
x, a
a1forall a. a -> [a] -> [a]
:forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(String, a)]
xs) forall a. a -> [a] -> [a]
: forall a. [(String, a)] -> [(String, [a])]
join_nub [(String, a)]
rest
join_nub [] = []
instance Default LegendStyle where
def :: LegendStyle
def = LegendStyle
{ _legend_label_style :: FontStyle
_legend_label_style = forall a. Default a => a
def
, _legend_margin :: Double
_legend_margin = Double
20
, _legend_plot_size :: Double
_legend_plot_size = Double
20
, _legend_orientation :: LegendOrientation
_legend_orientation = Int -> LegendOrientation
LORows Int
4
, _legend_position :: LegendPosition
_legend_position = LegendPosition
LegendBelow
}
$( makeLenses ''LegendStyle )