-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Chart.Plot
-- Copyright   :  (c) Tim Docker 2006
-- License     :  BSD-style (see chart/COPYRIGHT)
--
-- Definitions of various types of Plots we can put on a 2D Chart.
--
-- Note that template haskell is used to derive accessor functions
-- (see 'Data.Accessor') for each field of the following data types:
--
--     * 'Plot'
--
--     * 'PlotLines'
--
--     * 'PlotPoints'
--
--     * 'PlotFillBetween'
--
--     * 'PlotErrBars'
--     
--     * 'PlotBars'
--
-- These accessors are not shown in this API documentation.  They have
-- the same name as the field, but with the trailing underscore
-- dropped. Hence for data field f_::F in type D, they have type
--
-- @
--   f :: Data.Accessor.Accessor D F
-- @
--


{-# OPTIONS_GHC -XTemplateHaskell #-}

module Graphics.Rendering.Chart.Plot(
    Plot(..),
    ToPlot(..),
    PlotPoints(..),
    PlotErrBars(..),
    PlotLines(..),
    PlotFillBetween(..),
    ErrPoint(..),
    PlotBars(..),
    PlotBarsStyle(..),
    PlotBarsSpacing(..),

    symErrPoint,

    defaultPlotLineStyle,
    defaultPlotPoints,
    defaultPlotErrBars,
    defaultPlotFillBetween,
    defaultPlotLines,
    defaultPlotBars,

    plot_lines_title,
    plot_lines_style,
    plot_lines_values,
    plot_lines_limit_values,

    hlinePlot,
    vlinePlot,

    plot_render,
    plot_legend,
    plot_all_points,

    plot_points_title,
    plot_points_style,
    plot_points_values,

    plot_fillbetween_title,
    plot_fillbetween_style,
    plot_fillbetween_values,

    plot_errbars_title,
    plot_errbars_line_style,
    plot_errbars_tick_length,
    plot_errbars_overhang,
    plot_errbars_values,

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

    ) where

import qualified Graphics.Rendering.Cairo as C
import Graphics.Rendering.Chart.Types
import Graphics.Rendering.Chart.Axis
import Control.Monad
import Data.List
import Data.Accessor.Template
import Data.Colour
import Data.Colour.SRGB (sRGB)
import Data.Colour.Names

-- | Interface to control plotting on a 2D area.
data Plot x y = Plot {

    -- | Given the mapping between model space coordinates and device coordinates,
    -- render this plot into a chart.
    plot_render_ :: PointMapFn x y -> CRender (),

    -- | Details for how to show this plot in a legend. For each item
    -- the string is the text to show, and the function renders a
    -- graphical sample of the plot
    plot_legend_ :: [ (String, Rect -> CRender ()) ],

    -- | All of the model space coordinates to be plotted. These are
    -- used to autoscale the axes where necessary.
    plot_all_points_ :: ([x],[y])
}

-- | a type class abstracting the conversion of a value to a Plot.
class ToPlot a where
   toPlot :: a x y -> Plot x y

----------------------------------------------------------------------

mapXY :: PointMapFn x y -> ((x,y) -> Point)
mapXY f (x,y) = f (LValue x, LValue y)

----------------------------------------------------------------------

-- | Value defining a series of (possibly disjointed) lines,
-- and a style in which to render them
data PlotLines x y = PlotLines {
    plot_lines_title_ :: String,
    plot_lines_style_ :: CairoLineStyle,
    plot_lines_values_ :: [[(x,y)]],
    plot_lines_limit_values_ :: [[(Limit x, Limit y)]]
}


instance ToPlot PlotLines where
    toPlot p = Plot {
        plot_render_ = renderPlotLines p,
	plot_legend_ = [(plot_lines_title_ p, renderPlotLegendLines p)],
	plot_all_points_ = (map fst pts ++ xs , map snd pts ++ ys)
    }
      where
        pts = concat (plot_lines_values_ p)
        xs = [ x | (LValue x,_) <- concat (plot_lines_limit_values_ p)]
        ys = [ y | (_,LValue y) <- concat (plot_lines_limit_values_ p)]

renderPlotLines :: PlotLines x y -> PointMapFn x y -> CRender ()
renderPlotLines p pmap = preserveCState $ do
    setLineStyle (plot_lines_style_ p)
    mapM_ (drawLines (mapXY pmap)) (plot_lines_values_ p)
    mapM_ (drawLines pmap) (plot_lines_limit_values_ p)
  where
    drawLines pmap (p:ps) = do
	moveTo (pmap p)
	mapM_ (\p -> lineTo (pmap p)) ps
	c $ C.stroke

renderPlotLegendLines :: PlotLines x y -> Rect -> CRender ()
renderPlotLegendLines p r@(Rect p1 p2) = preserveCState $ do
    setLineStyle (plot_lines_style_ p)
    let y = (p_y p1 + p_y p2) / 2
    moveTo (Point (p_x p1) y)
    lineTo (Point (p_x p2) y)
    c $ C.stroke

defaultPlotLineStyle = (solidLine 1 $ opaque blue){
     line_cap_ = C.LineCapRound,
     line_join_ = C.LineJoinRound
 }

defaultPlotLines = PlotLines {
    plot_lines_title_ = "",
    plot_lines_style_ = defaultPlotLineStyle,
    plot_lines_values_ = [],
    plot_lines_limit_values_ = []
}

-- | Helper function to plot a single horizontal line
hlinePlot :: String -> CairoLineStyle -> b -> Plot a b
hlinePlot t ls v = toPlot defaultPlotLines {
    plot_lines_title_=t,
    plot_lines_style_=ls,
    plot_lines_limit_values_=[[(LMin, LValue v),(LMax, LValue v)]]
    }

-- | Helper function to plot a single vertical line
vlinePlot :: String -> CairoLineStyle -> a -> Plot a b
vlinePlot t ls v = toPlot defaultPlotLines {
    plot_lines_title_=t,
    plot_lines_style_=ls,
    plot_lines_limit_values_=[[(LValue v,LMin),(LValue v,LMax)]]
    }

----------------------------------------------------------------------

-- | Value defining a series of datapoints, and a style in
-- which to render them
data PlotPoints x y = PlotPoints {
    plot_points_title_ :: String,
    plot_points_style_ :: CairoPointStyle,
    plot_points_values_ :: [(x,y)]
}


instance ToPlot PlotPoints where
    toPlot p = Plot {
        plot_render_ = renderPlotPoints p,
	plot_legend_ = [(plot_points_title_ p, renderPlotLegendPoints p)],
	plot_all_points_ = (map fst pts, map snd pts)
    }
      where
        pts = plot_points_values_ p

renderPlotPoints :: PlotPoints x y -> PointMapFn x y -> CRender ()
renderPlotPoints p pmap = preserveCState $ do
    mapM_ (drawPoint.pmap') (plot_points_values_ p)
  where
    pmap' = mapXY pmap
    (CairoPointStyle drawPoint) = (plot_points_style_ p)


renderPlotLegendPoints :: PlotPoints x y -> Rect -> CRender ()
renderPlotLegendPoints p r@(Rect p1 p2) = preserveCState $ do
    drawPoint (Point (p_x p1) ((p_y p1 + p_y p2)/2))
    drawPoint (Point ((p_x p1 + p_x p2)/2) ((p_y p1 + p_y p2)/2))
    drawPoint (Point (p_x p2) ((p_y p1 + p_y p2)/2))

  where
    (CairoPointStyle drawPoint) = (plot_points_style_ p)

defaultPlotPoints = PlotPoints {
    plot_points_title_ = "",
    plot_points_style_ =defaultPointStyle,
    plot_points_values_ = []
}
----------------------------------------------------------------------
-- | Value specifying a plot filling the area between two sets of Y
-- coordinates, given common X coordinates.

data PlotFillBetween x y = PlotFillBetween {
    plot_fillbetween_title_ :: String,
    plot_fillbetween_style_ :: CairoFillStyle,
    plot_fillbetween_values_ :: [ (x, (y,y))]
}


instance ToPlot PlotFillBetween where
    toPlot p = Plot {
        plot_render_ = renderPlotFillBetween p,
	plot_legend_ = [(plot_fillbetween_title_ p, renderPlotLegendFill p)],
	plot_all_points_ = plotAllPointsFillBetween p
    }

renderPlotFillBetween :: PlotFillBetween x y -> PointMapFn x y -> CRender ()
renderPlotFillBetween p pmap = renderPlotFillBetween' p (plot_fillbetween_values_ p) pmap

renderPlotFillBetween' p [] _ = return ()
renderPlotFillBetween' p vs pmap  = preserveCState $ do
    setFillStyle (plot_fillbetween_style_ p)
    moveTo p0
    mapM_ lineTo p1s
    mapM_ lineTo (reverse p2s)
    lineTo p0
    c $ C.fill
  where
    pmap' = mapXY pmap
    (p0:p1s) = map pmap' [ (x,y1) | (x,(y1,y2)) <- vs ]
    p2s = map pmap' [ (x,y2) | (x,(y1,y2)) <- vs ]

renderPlotLegendFill :: PlotFillBetween x y -> Rect -> CRender ()
renderPlotLegendFill p r = preserveCState $ do
    setFillStyle (plot_fillbetween_style_ p)
    rectPath r
    c $ C.fill

plotAllPointsFillBetween :: PlotFillBetween x y -> ([x],[y])
plotAllPointsFillBetween p = ([x|(x,(_,_)) <- pts], concat [[y1,y2]|(_,(y1,y2)) <- pts])
  where
    pts = plot_fillbetween_values_ p


defaultPlotFillBetween = PlotFillBetween {
    plot_fillbetween_title_ = "",
    plot_fillbetween_style_ = solidFillStyle (opaque $ sRGB 0.5 0.5 1.0),
    plot_fillbetween_values_= []
}

----------------------------------------------------------------------

-- | Value for holding a point with associated error bounds for
-- each axis.

data ErrValue x = ErrValue {
      ev_low :: x,
      ev_best :: x,
      ev_high :: x
} deriving Show

data ErrPoint x y = ErrPoint {
      ep_x :: ErrValue x,
      ep_y :: ErrValue y
} deriving Show

-- | When the error is symetric, we can simply pass in dx for the error
symErrPoint x y dx dy = ErrPoint (ErrValue (x-dx) x (x+dx))
                                 (ErrValue (y-dy) y (y+dy))

-- | Value defining a series of error intervals, and a style in
-- which to render them
data PlotErrBars x y = PlotErrBars {
    plot_errbars_title_ :: String,
    plot_errbars_line_style_ :: CairoLineStyle,
    plot_errbars_tick_length_ :: Double,
    plot_errbars_overhang_ :: Double,
    plot_errbars_values_ :: [ErrPoint x y]
}


instance ToPlot PlotErrBars where
    toPlot p = Plot {
        plot_render_ = renderPlotErrBars p,
	plot_legend_ = [(plot_errbars_title_ p,renderPlotLegendErrBars p)],
	plot_all_points_ = ( concat [[ev_low x,ev_high x] |ErrPoint x _ <-pts ],
                             concat [[ev_low y,ev_high y] |ErrPoint _ y <-pts ] )
    }
      where
        pts = plot_errbars_values_ p

renderPlotErrBars :: PlotErrBars x y -> PointMapFn x y -> CRender ()
renderPlotErrBars p pmap = preserveCState $ do
    mapM_ (drawErrBar.epmap) (plot_errbars_values_ p)
  where
    epmap (ErrPoint (ErrValue xl x xh) (ErrValue yl y yh)) =
        ErrPoint (ErrValue xl' x' xh') (ErrValue yl' y' yh')
        where (Point x' y') = pmap' (x,y)
              (Point xl' yl') = pmap' (xl,yl)
              (Point xh' yh') = pmap' (xh,yh)
    drawErrBar = drawErrBar0 p
    pmap' = mapXY pmap

drawErrBar0 ps (ErrPoint (ErrValue xl x xh) (ErrValue yl y yh)) = do
        let tl = plot_errbars_tick_length_ ps
        let oh = plot_errbars_overhang_ ps
        setLineStyle (plot_errbars_line_style_ ps)
        c $ C.newPath
        c $ C.moveTo (xl-oh) y
        c $ C.lineTo (xh+oh) y
        c $ C.moveTo x (yl-oh)
        c $ C.lineTo x (yh+oh)
        c $ C.moveTo xl (y-tl)
        c $ C.lineTo xl (y+tl)
        c $ C.moveTo (x-tl) yl
        c $ C.lineTo (x+tl) yl
        c $ C.moveTo xh (y-tl)
        c $ C.lineTo xh (y+tl)
        c $ C.moveTo (x-tl) yh
        c $ C.lineTo (x+tl) yh
	c $ C.stroke

renderPlotLegendErrBars :: PlotErrBars x y -> Rect -> CRender ()
renderPlotLegendErrBars p r@(Rect p1 p2) = preserveCState $ do
    drawErrBar (symErrPoint (p_x p1) ((p_y p1 + p_y p2)/2) dx dx )
    drawErrBar (symErrPoint ((p_x p1 + p_x p2)/2) ((p_y p1 + p_y p2)/2) dx dx)
    drawErrBar (symErrPoint (p_x p2) ((p_y p1 + p_y p2)/2) dx dx)

  where
    drawErrBar = drawErrBar0 p
    dx = min ((p_x p2 - p_x p1)/6) ((p_y p2 - p_y p1)/2)

defaultPlotErrBars = PlotErrBars {
    plot_errbars_title_ = "",
    plot_errbars_line_style_ = solidLine 1 $ opaque blue,
    plot_errbars_tick_length_ = 3,
    plot_errbars_overhang_ = 0,
    plot_errbars_values_ = []
}

----------------------------------------------------------------------

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

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

data PlotBarsStyle = BarsStacked | BarsClustered
data PlotBarsSpacing = BarsFixWidth Double
                     | BarsFixGap Double

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

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

   -- | 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,
   plot_bars_values_ = [],
   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 -> do 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
           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
             barPath (offset i) x yref0 y
             c $ C.stroke

    offset i = fromIntegral (2*i-nys) * width/2

    stackedBars (x,ys) =  preserveCState $ do
       let y2s = zip (yref0:stack ys) (stack ys)
       forM_ (zip y2s styles) $ \((y0,y1), (fstyle,_)) -> do
           setFillStyle fstyle
           barPath (-width/2) x y0 y1
           c $ C.fill
       forM_ (zip y2s styles) $ \((y0,y1), (_,mlstyle)) -> do
           whenJust mlstyle $ \lstyle -> do
               setLineStyle lstyle
               barPath (-width/2) x y0 y1
               c $ C.stroke

    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 -> case (plot_bars_style_ p) of
            BarsClustered -> (minXInterval - gap) / fromIntegral nys
            BarsStacked -> (minXInterval - gap)
        BarsFixWidth width -> width
    styles = plot_bars_item_styles_ p

    minXInterval = minimum $ zipWith (-) (tail xs) xs
      where               
        xs = nub $ sort $ map (\x-> p_x (pmap' (x,barsReference))) (fst (allBarPoints p))

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

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], concat [ys| (_,ys) <- pts] )
    BarsStacked -> ( [x| (x,_) <- pts], 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
    rectPath r
    c $ C.fill

----------------------------------------------------------------------
-- Template haskell to derive an instance of Data.Accessor.Accessor for each field
$( deriveAccessors ''Plot )
$( deriveAccessors ''PlotLines )
$( deriveAccessors ''PlotPoints )
$( deriveAccessors ''PlotFillBetween )
$( deriveAccessors ''PlotErrBars )
$( deriveAccessors ''PlotBars )