    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Graphics.Rendering.Chart.Plot.Bars
    -- Copyright   :  (c) Tim Docker 2006
    -- License     :  BSD-style (see chart/COPYRIGHT)
    --
    -- Bar Charts
    --
    {-# OPTIONS_GHC -XTemplateHaskell #-}

    module Graphics.Rendering.Chart.Plot.Bars(
        PlotBars(..),
        defaultPlotBars,
        PlotBarsStyle(..),
        PlotBarsSpacing(..),
        PlotBarsAlignment(..),
        BarsPlotValue(..),

        plotBars,
        plot_bars_style,
        plot_bars_item_styles,
        plot_bars_titles,
        plot_bars_spacing,
        plot_bars_alignment,
        plot_bars_reference,
        plot_bars_singleton_width,
        plot_bars_values,

    ) where

    import Data.Accessor.Template
    import Control.Monad
    import Data.List(nub,sort)
    import qualified Graphics.Rendering.Cairo as C
    import Graphics.Rendering.Chart.Types
    import Graphics.Rendering.Chart.Renderable
    import Graphics.Rendering.Chart.Plot.Types
    import Graphics.Rendering.Chart.Axis
    import Data.Colour (opaque)
    import Data.Colour.Names (black, blue)
    import Data.Colour.SRGB (sRGB)

    class PlotValue a => BarsPlotValue a where
        barsReference :: a
        barsAdd       :: a -> a -> a

    instance BarsPlotValue Double where
        barsReference = 0
        barsAdd       = (+)
    instance BarsPlotValue Int where
        barsReference = 0
        barsAdd       = (+)

    data PlotBarsStyle
        = BarsStacked   -- ^ Bars for a fixed x are stacked vertically
                        --   on top of each other.
        | BarsClustered -- ^ Bars for a fixed x are put horizontally
                        --   beside each other.
         deriving (Show)

    data PlotBarsSpacing
        = BarsFixWidth Double       -- ^ All bars have the same width in pixels.
        | BarsFixGap Double Double  -- ^ (BarsFixGap g mw) means make the gaps between
                                    --   the bars equal to g, but with a minimum bar width
                                    --   of mw
         deriving (Show)

    -- | How bars for a given (x,[y]) are aligned with respect to screen
    --   coordinate corresponding to x (deviceX).
    data PlotBarsAlignment = BarsLeft      -- ^ The left edge of bars is at deviceX
                           | BarsCentered  -- ^ The right edge of bars is at deviceX
                           | BarsRight     -- ^ Bars are centered around deviceX
         deriving (Show)

    -- | Value describing how to plot a set of bars.
    --   Note that the input data is typed [(x,[y])], ie for each x value
    --   we plot several y values. Typically the size of each [y] list would
    --   be the same.
    data PlotBars x y = PlotBars {
       -- | This value specifies whether each value from [y] should be
       --   shown beside or above the previous value.
       plot_bars_style_           :: PlotBarsStyle,

       -- | The style in which to draw each element of [y]. A fill style
       --   is required, and if a linestyle is given, each bar will be
       --   outlined.
       plot_bars_item_styles_     :: [ (CairoFillStyle,Maybe CairoLineStyle) ],

       -- | The title of each element of [y]. These will be shown in the legend.
       plot_bars_titles_          :: [String],

       -- | This value controls how the widths of the bars are
       --   calculated. Either the widths of the bars, or the gaps between
       --   them can be fixed.
       plot_bars_spacing_         :: PlotBarsSpacing,

       -- | This value controls how bars for a fixed x are aligned with
       --   respect to the device coordinate corresponding to x.
       plot_bars_alignment_       :: PlotBarsAlignment,

       -- | The starting level for the chart (normally 0).
       plot_bars_reference_       :: y,

       plot_bars_singleton_width_ :: Double,

       -- | The actual points to be plotted.
       plot_bars_values_          :: [ (x,[y]) ]
    }

    defaultPlotBars :: BarsPlotValue y => PlotBars x y
    defaultPlotBars = PlotBars {
       plot_bars_style_           = BarsClustered,
       plot_bars_item_styles_     = cycle istyles,
       plot_bars_titles_          = [],
       plot_bars_spacing_         = BarsFixGap 10 2,
       plot_bars_alignment_       = BarsCentered,
       plot_bars_values_          = [],
       plot_bars_singleton_width_ = 20,
       plot_bars_reference_       = barsReference
       }
      where
        istyles   = map mkstyle defaultColorSeq
        mkstyle c = (solidFillStyle c, Just (solidLine 1.0 $ opaque black))

    plotBars :: (BarsPlotValue y) => PlotBars x y -> Plot x y
    plotBars p = Plot {
            plot_render_     = renderPlotBars p,
            plot_legend_     = zip (plot_bars_titles_ p)
                                   (map renderPlotLegendBars
                                        (plot_bars_item_styles_ p)),
            plot_all_points_ = allBarPoints p
        }

    renderPlotBars :: (BarsPlotValue y) =>
                      PlotBars x y -> PointMapFn x y -> CRender ()
    renderPlotBars p pmap = case (plot_bars_style_ p) of
          BarsClustered -> forM_ vals clusteredBars
          BarsStacked   -> forM_ vals stackedBars
      where
        clusteredBars (x,ys) = preserveCState $ do
           forM_ (zip3 [0,1..] ys styles) $ \(i, y, (fstyle,_)) -> do
               setFillStyle fstyle
               fillPath (barPath (offset i) x yref0 y)
               c $ C.fill
           forM_ (zip3 [0,1..] ys styles) $ \(i, y, (_,mlstyle)) -> do
               whenJust mlstyle $ \lstyle -> do
                 setLineStyle lstyle
                 strokePath (barPath (offset i) x yref0 y)

        offset = case (plot_bars_alignment_ p) of
          BarsLeft     -> \i -> fromIntegral i * width
          BarsRight    -> \i -> fromIntegral (i-nys) * width
          BarsCentered -> \i -> fromIntegral (2*i-nys) * width/2

        stackedBars (x,ys) =  preserveCState $ do
           let y2s = zip (yref0:stack ys) (stack ys)
           let ofs = case (plot_bars_alignment_ p) of {
             BarsLeft     -> 0          ;
             BarsRight    -> (-width)   ;
             BarsCentered -> (-width/2)
             }
           forM_ (zip y2s styles) $ \((y0,y1), (fstyle,_)) -> do
               setFillStyle fstyle
               fillPath (barPath ofs x y0 y1)
           forM_ (zip y2s styles) $ \((y0,y1), (_,mlstyle)) -> do
               whenJust mlstyle $ \lstyle -> do
                   setLineStyle lstyle
                   strokePath (barPath ofs x y0 y1)

        barPath xos x y0 y1 = do
          let (Point x' y') = pmap' (x,y1)
          let (Point _ y0') = pmap' (x,y0)
          rectPath (Rect (Point (x'+xos) y0') (Point (x'+xos+width) y'))

        yref0 = plot_bars_reference_ p
        vals  = plot_bars_values_ p
        width = case plot_bars_spacing_ p of
            BarsFixGap gap minw -> let w = max (minXInterval - gap) minw in
                case (plot_bars_style_ p) of
                    BarsClustered -> w / fromIntegral nys
                    BarsStacked -> w
            BarsFixWidth width -> width
        styles = plot_bars_item_styles_ p

        minXInterval = let diffs = zipWith (-) (tail mxs) mxs
                       in if null diffs
                            then plot_bars_singleton_width_ p
                            else minimum diffs
          where
            xs  = fst (allBarPoints p)
            mxs = nub $ sort $ map mapX xs

        nys    = maximum [ length ys | (x,ys) <- vals ]

        pmap'  = mapXY pmap
        mapX x = p_x (pmap' (x,barsReference))

    whenJust :: (Monad m) => Maybe a -> (a -> m ()) -> m ()
    whenJust (Just a) f = f a
    whenJust _        _ = return ()

    allBarPoints :: (BarsPlotValue y) => PlotBars x y -> ([x],[y])
    allBarPoints p = case (plot_bars_style_ p) of
        BarsClustered -> ( [x| (x,_) <- pts], y0:concat [ys| (_,ys) <- pts] )
        BarsStacked   -> ( [x| (x,_) <- pts], y0:concat [stack ys | (_,ys) <- pts] )
      where
        pts = plot_bars_values_ p
        y0  = plot_bars_reference_ p

    stack :: (BarsPlotValue y) => [y] -> [y]
    stack ys = scanl1 barsAdd ys

    renderPlotLegendBars :: (CairoFillStyle,Maybe CairoLineStyle) -> Rect
                            -> CRender ()
    renderPlotLegendBars (fstyle,mlstyle) r@(Rect p1 p2) = do
        setFillStyle fstyle
        fillPath (rectPath r)

    ----------------------------------------------------------------------
    -- Template haskell to derive an instance of Data.Accessor.Accessor
    -- for each field.

    $( deriveAccessors ''PlotBars )