-----------------------------------------------------------------------------
-- |
-- 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(..),
    legendToRenderable,
    legend_label_style,
    legend_margin,
    legend_plot_size,
    legend_orientation
) 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 {
   _legend_label_style :: FontStyle,
   _legend_margin      :: Double,
   _legend_plot_size   :: Double,
   _legend_orientation :: LegendOrientation
}

-- | 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
                       

data Legend x y = Legend LegendStyle [(String, Rect -> BackendProgram ())]

instance ToRenderable (Legend x y) where
  toRenderable = setPickFn nullPickFn . legendToRenderable

legendToRenderable :: Legend x y -> Renderable String
legendToRenderable (Legend ls lvs) = gridToRenderable grid
  where
    grid :: Grid (Renderable String)
    grid = case _legend_orientation ls of
        LORows n -> mkGrid n aboveG besideG
        LOCols n -> mkGrid n besideG aboveG 

    aboveG, besideG :: [Grid (Renderable String)] -> Grid (Renderable String)
    aboveG = aboveN.intersperse ggap1
    besideG = besideN.intersperse ggap1

    mkGrid :: Int
              -> ([Grid (Renderable String)] -> Grid (Renderable String))
              -> ([Grid (Renderable String)] -> Grid (Renderable String))
              -> Grid (Renderable String)
    mkGrid n join1 join2 = join1 [ join2 (map rf ps1) | ps1 <- groups n ps ]

    ps  :: [(String, [Rect -> BackendProgram ()])]
    ps   = join_nub lvs

    rf :: (String, [Rect -> BackendProgram ()]) -> Grid (Renderable String)
    rf (title,rfs) = besideN [gpic,ggap2,gtitle]
      where
        gpic :: Grid (Renderable String)
        gpic = besideN $ intersperse ggap2 (map rp rfs)

        gtitle :: Grid (Renderable String)
        gtitle = tval $ lbl title

        rp :: (Rect -> BackendProgram ()) -> Grid (Renderable String)
        rp rfn = tval Renderable {
                     minsize = return (_legend_plot_size ls, 0),
                     render  = \(w,h) -> do 
                         _ <- rfn (Rect (Point 0 0) (Point w h))
                         return (\_-> Just title)
                 }

    ggap1, ggap2 :: Grid (Renderable String)
    ggap1 = tval $ spacer (_legend_margin ls,_legend_margin ls / 2)
    ggap2 = tval $ spacer1 (lbl "X")

    lbl :: String -> Renderable String
    lbl = label (_legend_label_style ls) HTA_Left VTA_Centre 

groups :: Int -> [a] -> [[a]]
groups _ [] = []
groups n vs = let (vs1,vs2) = splitAt n vs in vs1:groups n vs2

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

instance Default LegendStyle where
  def = LegendStyle 
    { _legend_label_style = def
    , _legend_margin      = 20
    , _legend_plot_size   = 20
    , _legend_orientation = LORows 4
    }

$( makeLenses ''LegendStyle )