-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Chart.Layout
-- Copyright   :  (c) Tim Docker 2006
-- License     :  BSD-style (see chart/COPYRIGHT)
--
-- This module glues together axes and plots to actually create a renderable
-- for a chart.
--
-- Note that template haskell is used to derive accessor functions
-- (see 'Data.Accessor') for each field of the following data types:
--
--     * 'Layout1'
--
--     * 'LayoutAxis'
--
-- 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.Layout(
    Layout1(..),
    LayoutAxis(..),
    MAxisFn,

    defaultLayout1,
    linkAxes,
    independentAxes,

    updateAllAxesStyles,
    setLayout1Foreground,

    defaultLayoutAxis,
    laxis_title_style,
    laxis_title,
    laxis_style,
    laxis_visible,
    laxis_generate,
    laxis_override,
    laxis_reverse,

    layout1_background,
    layout1_plot_background,
    layout1_title,
    layout1_title_style,
    layout1_left_axis,
    layout1_right_axis,
    layout1_top_axis,
    layout1_bottom_axis,
    layout1_yaxes_control,
    layout1_margin,
    layout1_plots,
    layout1_legend,
    layout1_grid_last,

    renderLayout1sStacked,
    AnyLayout1(),
    withAnyOrdinate
  ) where

import qualified Graphics.Rendering.Cairo as C

import Graphics.Rendering.Chart.Axis
import Graphics.Rendering.Chart.Types
import Graphics.Rendering.Chart.Plot
import Graphics.Rendering.Chart.Legend
import Graphics.Rendering.Chart.Renderable
import Graphics.Rendering.Chart.Grid
import Control.Monad
import Control.Monad.Reader (local)
import Data.Accessor.Template
import Data.Accessor
import Data.Colour
import Data.Colour.Names (white)

-- | A @MAxisFn@ is a function that generates an (optional) axis
-- given the points plotted against that axis.
type MAxisFn t = [t] -> Maybe (AxisData t)

data LayoutAxis x = LayoutAxis {
   laxis_title_style_ :: CairoFontStyle,
   laxis_title_ :: String,
   laxis_style_ :: AxisStyle,

   -- | function that determines whether an axis should be visible,
   -- based upon the points plotted on this axis. The default value
   -- is 'not.null'
   laxis_visible_ :: [x] -> Bool,

   -- | function that generates the axis data, based upon the
   -- points plotted. The default value is 'autoAxis'.
   laxis_generate_ :: AxisFn x,

   -- | function that can be used to override the generated axis data.
   -- The default value is 'id'.
   laxis_override_ :: AxisData x -> AxisData x,

   -- | True if left to right (bottom to top) is to show descending values
   laxis_reverse_ :: Bool

}

-- | A Layout1 value is a single plot area, with optional: axes on
-- each of the 4 sides; title at the top; legend at the bottom. It's
-- parameterised by the types of values to be plotted on the horizonal
-- and vertical axes.
data Layout1 x y = Layout1 {

    layout1_background_ :: CairoFillStyle,
    layout1_plot_background_ :: Maybe CairoFillStyle,

    layout1_title_ :: String,
    layout1_title_style_ :: CairoFontStyle,

    layout1_bottom_axis_ :: LayoutAxis x,
    layout1_top_axis_ :: LayoutAxis x,
    layout1_left_axis_ :: LayoutAxis y,
    layout1_right_axis_ :: LayoutAxis y,

    -- | function to map points from the left/right plot
    -- to the left/right axes. The default value is 'id'
    layout1_yaxes_control_ :: ([y],[y]) -> ([y],[y]),

    layout1_margin_ :: Double,
    layout1_plots_ :: [Either (Plot x y) (Plot x y)],
    layout1_legend_ :: Maybe(LegendStyle),

    -- | True if the grid is to be rendered on top of the Plots
    layout1_grid_last_ :: Bool
}

data Layout1Pick x y = L1P_Legend String
                     | L1P_PlotArea x y y
                     | L1P_BottomAxis x
                     | L1P_TopAxis x
                     | L1P_LeftAxis y
                     | L1P_RightAxis y

instance (Ord x, Ord y) => ToRenderable (Layout1 x y) where
    toRenderable = setPickFn nullPickFn.layout1ToRenderable

-- | Encapsulates a 'Layout1' with a fixed abscissa type but arbitrary ordinate type.
data AnyLayout1 x = AnyLayout1 {
    background :: CairoFillStyle,
    titleRenderable :: Renderable (),
    plotAreaGrid :: Grid (Renderable ()),
    legendRenderable :: Renderable (),
    margin :: Double
  }

withAnyOrdinate :: (Ord x,Ord y) => Layout1 x y -> AnyLayout1 x
withAnyOrdinate l = AnyLayout1 {
    background = layout1_background_ l,
    titleRenderable = mapPickFn (const ()) $ layout1TitleToRenderable l,
    plotAreaGrid = fmap (mapPickFn (const ())) $ layout1PlotAreaToGrid l,
    legendRenderable = mapPickFn (const ()) $ layout1LegendsToRenderable l,
    margin = layout1_margin_ l
  }


-- | Render several layouts with the same abscissa type stacked so that their
-- origins and axis titles are aligned horizontally with respect to each other.
-- The exterior margins and background are taken from the first element.
renderLayout1sStacked :: (Ord x) => [AnyLayout1 x] -> Renderable ()
renderLayout1sStacked [] = emptyRenderable
renderLayout1sStacked ls@(l1:_) = gridToRenderable g
  where
    g = fullOverlayUnder (fillBackground (background l1) emptyRenderable)
      $ addMarginsToGrid (lm,lm,lm,lm)
      $ aboveN [
        fullRowAbove (titleRenderable l) 0 (
             fullRowBelow (legendRenderable l) 0
                          (plotAreaGrid l))
      | l <- ls]

    lm = margin l1

addMarginsToGrid :: (Double,Double,Double,Double) -> Grid (Renderable a) -> Grid (Renderable a)
addMarginsToGrid (t,b,l,r) g = aboveN [
     besideN [er, ts, er],
     besideN [ls, g,  rs],
     besideN [er, bs, er]
  ]
  where
    er = empty
    ts = tval $ spacer (0,t)
    ls = tval $ spacer (l,0)
    bs = tval $ spacer (0,b)
    rs = tval $ spacer (r,0)

layout1ToRenderable :: (Ord x, Ord y) => Layout1 x y -> Renderable (Layout1Pick x y)
layout1ToRenderable l =
   fillBackground (layout1_background_ l) $ gridToRenderable (layout1ToGrid l)

layout1ToGrid :: (Ord x, Ord y) => Layout1 x y -> Grid (Renderable (Layout1Pick x y))
layout1ToGrid l = aboveN [
          tval $ layout1TitleToRenderable l,
          weights (1,1) $ tval $ gridToRenderable $
            addMarginsToGrid (lm,lm,lm,lm) (layout1PlotAreaToGrid l),
          tval $ layout1LegendsToRenderable l
       ]
  where
    lm = layout1_margin_ l

layout1TitleToRenderable :: (Ord x, Ord y) => Layout1 x y -> Renderable a
layout1TitleToRenderable l = addMargins (lm/2,0,0,0) title
  where
    title = label (layout1_title_style_ l) HTA_Centre VTA_Centre (layout1_title_ l)
    lm = layout1_margin_ l

layout1LegendsToRenderable :: (Ord x, Ord y) => Layout1 x y -> Renderable (Layout1Pick x y)
layout1LegendsToRenderable l = gridToRenderable g
  where
    g = besideN [ tval $ mkLegend lefts,
                  weights (1,1) $ tval $ emptyRenderable,
                  tval $ mkLegend rights ]
    lefts  = concat [ plot_legend_ p | (Left p ) <- (layout1_plots_ l) ]
    rights = concat [ plot_legend_ p | (Right p) <- (layout1_plots_ l) ]

    lm = layout1_margin_ l

    mkLegend vals = case (layout1_legend_ l) of
        Nothing -> emptyRenderable
        (Just ls) ->  case filter ((/="").fst) vals of {
             []  -> emptyRenderable ;
	         lvs -> addMargins (0,lm,lm,lm)
                      (mapPickFn  L1P_Legend $ legendToRenderable (Legend True ls lvs))
         }

layout1PlotAreaToGrid :: (Ord x, Ord y) => Layout1 x y -> Grid (Renderable (Layout1Pick x y))
layout1PlotAreaToGrid l = layer2 `overlay` layer1
  where
    layer1 = aboveN [
         besideN [er,     er,    er   ],
         besideN [er,     er,    er   ],
         besideN [er,     er,    weights (1,1) plots ]
         ]

    layer2 = aboveN [
         besideN [er,     er,    ttitle, er,    er       ],
         besideN [er,     tl,    taxis,  tr,    er       ],
         besideN [ltitle, laxis, er,     raxis, rtitle   ],
         besideN [er,     bl,    baxis,  br,    er       ],
         besideN [er,     er,    btitle, er,    er       ]
         ]

    ttitle = atitle HTA_Centre VTA_Bottom   0 layout1_top_axis_
    btitle = atitle HTA_Centre VTA_Top      0 layout1_bottom_axis_
    ltitle = atitle HTA_Right  VTA_Centre 270 layout1_left_axis_
    rtitle = atitle HTA_Left   VTA_Centre 270 layout1_right_axis_

    er = tval $ emptyRenderable

    atitle ha va rot af = if ttext == "" then er else tval $ rlabel tstyle ha va rot ttext
      where
        tstyle = laxis_title_style_ (af l)
        ttext = laxis_title_ (af l)

    plots = tval $ mfill (layout1_plot_background_ l) $ plotsToRenderable l
      where
        mfill Nothing = id
        mfill (Just fs) = fillBackground fs

    (ba,la,ta,ra) = getAxes l
    baxis = tval $ maybe emptyRenderable (mapPickFn L1P_BottomAxis . axisToRenderable) ba
    taxis = tval $ maybe emptyRenderable (mapPickFn L1P_TopAxis . axisToRenderable)   ta
    laxis = tval $ maybe emptyRenderable (mapPickFn L1P_LeftAxis . axisToRenderable)  la
    raxis = tval $ maybe emptyRenderable (mapPickFn L1P_RightAxis . axisToRenderable) ra

    tl = tval $ axesSpacer fst ta fst la
    bl = tval $ axesSpacer fst ba snd la
    tr = tval $ axesSpacer snd ta fst ra
    br = tval $ axesSpacer snd ba snd ra

plotsToRenderable :: Layout1 x y -> Renderable (Layout1Pick x y)
plotsToRenderable l = Renderable {
        minsize=return (0,0),
        render =renderPlots l
    }

renderPlots :: Layout1 x y -> RectSize -> CRender (PickFn (Layout1Pick x y))
renderPlots l sz@(w,h) = do
    when (not (layout1_grid_last_ l)) renderGrids
    preserveCState $ do
      -- render the plots
      setClipRegion (Point 0 0) (Point w h)
      mapM_ rPlot (layout1_plots_ l)
    when (layout1_grid_last_ l) renderGrids
    return nullPickFn

  where
    (bAxis,lAxis,tAxis,rAxis) = getAxes l

    rPlot (Left  p) = rPlot1 bAxis lAxis p
    rPlot (Right p) = rPlot1 bAxis rAxis p

    rPlot1 (Just (AxisT _ xs xrev xaxis)) (Just (AxisT _ ys yrev yaxis)) p =
      let xrange = if xrev then (w, 0) else (0, w)
          yrange = if yrev then (0, h) else (h, 0)
          pmfn (x,y) = Point (mapv xrange (axis_viewport_ xaxis xrange) x)
                             (mapv yrange (axis_viewport_ yaxis yrange) y)
          mapv (min,max) _ LMin = min
          mapv (min,max) _ LMax = max
          mapv _         f (LValue v) = f v
	  in plot_render_ p pmfn
    rPlot1 _ _ _ = return ()

    renderGrids = do
      maybeM () (renderAxisGrid sz) tAxis
      maybeM () (renderAxisGrid sz) bAxis
      maybeM () (renderAxisGrid sz) lAxis
      maybeM () (renderAxisGrid sz) rAxis

axesSpacer f1 a1 f2 a2 = embedRenderable $ do
    oh1 <- maybeM (0,0) axisOverhang a1
    oh2 <- maybeM (0,0) axisOverhang a2
    return (spacer (f1 oh1, f2 oh2))

getAxes :: Layout1 x y -> (Maybe (AxisT x), Maybe (AxisT y), Maybe (AxisT x), Maybe (AxisT y))
getAxes l = (bAxis,lAxis,tAxis,rAxis)
  where
    (xvals0,xvals1,yvals0,yvals1) = allPlottedValues (layout1_plots_ l)
    xvals = xvals0 ++ xvals1
    (yvals0',yvals1') = layout1_yaxes_control_ l (yvals0,yvals1)

    bAxis = mkAxis E_Bottom (layout1_bottom_axis_ l) xvals
    tAxis = mkAxis E_Top    (layout1_top_axis_ l) xvals
    lAxis = mkAxis E_Left   (layout1_left_axis_ l) yvals0'
    rAxis = mkAxis E_Right  (layout1_right_axis_ l) yvals1'

    mkAxis t laxis vals = case laxis_visible_ laxis vals of
        False -> Nothing
        True -> Just (AxisT t style rev adata)
      where
        style = laxis_style_ laxis
        rev = laxis_reverse_ laxis
        adata = (laxis_override_ laxis) (laxis_generate_ laxis vals)

allPlottedValues :: [(Either (Plot x y) (Plot x' y'))] -> ( [x], [x'], [y], [y'] )
allPlottedValues plots = (xvals0,xvals1,yvals0,yvals1)
  where
    xvals0 = [ x | (Left p) <- plots, x <- fst $ plot_all_points_ p]
    yvals0 = [ y | (Left p) <- plots, y <- snd $ plot_all_points_ p]
    xvals1 = [ x | (Right p) <- plots, x <- fst $ plot_all_points_ p]
    yvals1 = [ y | (Right p) <- plots, y <- snd $ plot_all_points_ p]

defaultLayout1 :: (PlotValue x,PlotValue y) => Layout1 x y
defaultLayout1 = Layout1 {
    layout1_background_ = solidFillStyle $ opaque white,
    layout1_plot_background_ = Nothing,

    layout1_title_ = "",
    layout1_title_style_ = defaultFontStyle{font_size_=15, font_weight_=C.FontWeightBold},

    layout1_top_axis_ = defaultLayoutAxis {
                          laxis_visible_ = const False
                        },
    layout1_bottom_axis_ = defaultLayoutAxis,
    layout1_left_axis_ = defaultLayoutAxis,
    layout1_right_axis_ = defaultLayoutAxis,

    layout1_yaxes_control_ = id,

    layout1_margin_ = 10,
    layout1_plots_ = [],
    layout1_legend_ = Just defaultLegendStyle,
    layout1_grid_last_ = False
}

defaultLayoutAxis :: PlotValue t => LayoutAxis t
defaultLayoutAxis = LayoutAxis {
   laxis_title_style_ = defaultFontStyle{font_size_=10},
   laxis_title_ = "",
   laxis_style_ = defaultAxisStyle,
   laxis_visible_ = not.null,
   laxis_generate_ = autoAxis,
   laxis_override_ = id,
   laxis_reverse_ = False
}

----------------------------------------------------------------------
-- Template haskell to derive an instance of Data.Accessor.Accessor for each field
$( deriveAccessors ''Layout1 )
$( deriveAccessors ''LayoutAxis )

-- | Helper to update all axis styles on a Layout1 simultaneously
updateAllAxesStyles :: (AxisStyle -> AxisStyle) -> Layout1 x y -> Layout1 x y
updateAllAxesStyles uf = (layout1_top_axis .> laxis_style ^: uf) .
                         (layout1_bottom_axis .> laxis_style ^: uf) .
                         (layout1_left_axis .> laxis_style ^: uf) .
                         (layout1_right_axis .> laxis_style ^: uf)

-- | Helper to set the forground color uniformly on a Layout1
setLayout1Foreground :: AlphaColour Double -> Layout1 x y -> Layout1 x y
setLayout1Foreground fg = updateAllAxesStyles  (
                       (axis_line_style .> line_color ^= fg).
                       (axis_label_style .> font_color ^= fg)
                       )
                 . (layout1_title_style .> font_color ^= fg)
                 . (layout1_legend ^: fmap (legend_label_style .> font_color ^= fg))


linkAxes (ys1,ys2) = (ys1++ys2,ys1++ys2)
independentAxes (ys1,ys2) = (ys1,ys2)