    -----------------------------------------------------------------------------
    -- |
    -- 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 :: forall x y. 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 {
                         minsize :: BackendProgram RectSize
    minsize = RectSize -> BackendProgram RectSize
    forall a. a -> ProgramT ChartBackendInstr Identity a
    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))
                             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 :: forall a. 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 :: forall a. [(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
        { _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 )