-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Chart.Legend
-- Copyright   :  (c) Tim Docker 2006, 2014
-- License     :  BSD-style (see chart/COPYRIGHT)
-- 
-- Types and functions for handling the legend(s) on a chart. A legend
-- is an area on the chart used to label the plotted values.
{-# 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

----------------------------------------------------------------------
-- Legend

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
}

-- | Legends can be constructed in two orientations: in rows
-- (where we specify the maximum number of columns), and in
-- columns (where we specify the maximum number of rows)
data LegendOrientation = LORows Int
                       | LOCols Int

-- | Defines the position of the legend, relative to the plot.
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 = PickFn () -> Renderable String -> Renderable ()
forall b a. PickFn b -> Renderable a -> Renderable b
setPickFn PickFn ()
forall a. PickFn a
nullPickFn (Renderable String -> Renderable ())
-> (Legend x y -> Renderable String) -> Legend x y -> Renderable ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Legend x y -> Renderable String
forall x y. Legend x y -> Renderable String
legendToRenderable

legendToRenderable :: Legend x y -> Renderable String
legendToRenderable :: Legend x y -> Renderable String
legendToRenderable (Legend LegendStyle
ls [(String, Rect -> BackendProgram ())]
lvs) = Grid (Renderable String) -> Renderable String
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 = [Grid (Renderable String)] -> Grid (Renderable String)
forall a. [Grid a] -> Grid a
aboveN([Grid (Renderable String)] -> Grid (Renderable String))
-> ([Grid (Renderable String)] -> [Grid (Renderable String)])
-> [Grid (Renderable String)]
-> Grid (Renderable String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Grid (Renderable String)
-> [Grid (Renderable String)] -> [Grid (Renderable String)]
forall a. a -> [a] -> [a]
intersperse Grid (Renderable String)
ggap1
    besideG :: [Grid (Renderable String)] -> Grid (Renderable String)
besideG = [Grid (Renderable String)] -> Grid (Renderable String)
forall a. [Grid a] -> Grid a
besideN([Grid (Renderable String)] -> Grid (Renderable String))
-> ([Grid (Renderable String)] -> [Grid (Renderable String)])
-> [Grid (Renderable String)]
-> Grid (Renderable String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Grid (Renderable String)
-> [Grid (Renderable String)] -> [Grid (Renderable String)]
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 (((String, [Rect -> BackendProgram ()]) -> Grid (Renderable String))
-> [(String, [Rect -> BackendProgram ()])]
-> [Grid (Renderable String)]
forall a b. (a -> b) -> [a] -> [b]
map (String, [Rect -> BackendProgram ()]) -> Grid (Renderable String)
rf [(String, [Rect -> BackendProgram ()])]
ps1) | [(String, [Rect -> BackendProgram ()])]
ps1 <- Int
-> [(String, [Rect -> BackendProgram ()])]
-> [[(String, [Rect -> BackendProgram ()])]]
forall a. Int -> [a] -> [[a]]
groups Int
n [(String, [Rect -> BackendProgram ()])]
ps ]

    ps  :: [(String, [Rect -> BackendProgram ()])]
    ps :: [(String, [Rect -> BackendProgram ()])]
ps   = [(String, Rect -> BackendProgram ())]
-> [(String, [Rect -> BackendProgram ()])]
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) = [Grid (Renderable String)] -> Grid (Renderable String)
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 = [Grid (Renderable String)] -> Grid (Renderable String)
forall a. [Grid a] -> Grid a
besideN ([Grid (Renderable String)] -> Grid (Renderable String))
-> [Grid (Renderable String)] -> Grid (Renderable String)
forall a b. (a -> b) -> a -> b
$ Grid (Renderable String)
-> [Grid (Renderable String)] -> [Grid (Renderable String)]
forall a. a -> [a] -> [a]
intersperse Grid (Renderable String)
ggap2 (((Rect -> BackendProgram ()) -> Grid (Renderable String))
-> [Rect -> BackendProgram ()] -> [Grid (Renderable String)]
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 = Renderable String -> Grid (Renderable String)
forall a. a -> Grid a
tval (Renderable String -> Grid (Renderable String))
-> Renderable String -> Grid (Renderable String)
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 = Renderable String -> Grid (Renderable String)
forall a. a -> Grid a
tval Renderable :: forall a.
BackendProgram RectSize
-> (RectSize -> BackendProgram (PickFn a)) -> Renderable a
Renderable {
                     minsize :: BackendProgram RectSize
minsize = RectSize -> BackendProgram RectSize
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))
                         PickFn String -> BackendProgram (PickFn String)
forall (m :: * -> *) a. Monad m => a -> m a
return (\Point
_-> String -> Maybe String
forall a. a -> Maybe a
Just String
title)
                 }

    ggap1, ggap2 :: Grid (Renderable String)
    ggap1 :: Grid (Renderable String)
ggap1 = Renderable String -> Grid (Renderable String)
forall a. a -> Grid a
tval (Renderable String -> Grid (Renderable String))
-> Renderable String -> Grid (Renderable String)
forall a b. (a -> b) -> a -> b
$ RectSize -> Renderable String
forall a. RectSize -> Renderable a
spacer (LegendStyle -> Double
_legend_margin LegendStyle
ls,LegendStyle -> Double
_legend_margin LegendStyle
ls Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2)
    ggap2 :: Grid (Renderable String)
ggap2 = Renderable String -> Grid (Renderable String)
forall a. a -> Grid a
tval (Renderable String -> Grid (Renderable String))
-> Renderable String -> Grid (Renderable String)
forall a b. (a -> b) -> a -> b
$ Renderable String -> Renderable String
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 :: Int -> [a] -> [[a]]
groups Int
_ [] = []
groups Int
n [a]
vs = let ([a]
vs1,[a]
vs2) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
vs in [a]
vs1[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:Int -> [a] -> [[a]]
forall a. Int -> [a] -> [[a]]
groups Int
n [a]
vs2

join_nub :: [(String, a)] -> [(String, [a])]
join_nub :: [(String, a)] -> [(String, [a])]
join_nub ((String
x,a
a1):[(String, a)]
ys) = case ((String, a) -> Bool)
-> [(String, a)] -> ([(String, a)], [(String, a)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
x) (String -> Bool) -> ((String, a) -> String) -> (String, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, a) -> String
forall a b. (a, b) -> a
fst) [(String, a)]
ys of
                         ([(String, a)]
xs, [(String, a)]
rest) -> (String
x, a
a1a -> [a] -> [a]
forall a. a -> [a] -> [a]
:((String, a) -> a) -> [(String, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (String, a) -> a
forall a b. (a, b) -> b
snd [(String, a)]
xs) (String, [a]) -> [(String, [a])] -> [(String, [a])]
forall a. a -> [a] -> [a]
: [(String, a)] -> [(String, [a])]
forall a. [(String, a)] -> [(String, [a])]
join_nub [(String, a)]
rest
join_nub []          = []

instance Default LegendStyle where
  def :: LegendStyle
def = LegendStyle :: FontStyle
-> Double
-> Double
-> LegendOrientation
-> LegendPosition
-> LegendStyle
LegendStyle
    { _legend_label_style :: FontStyle
_legend_label_style = FontStyle
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 )