    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Graphics.Rendering.Chart.Renderable
    -- Copyright   :  (c) Tim Docker 2006, 2014
    -- License     :  BSD-style (see chart/COPYRIGHT)
    --
    -- This module contains the definition of the 'Renderable' type, which
    -- is a composable drawing element, along with assorted functions to
    -- them.
    --
    {-# LANGUAGE DeriveFunctor #-}
    {-# LANGUAGE TemplateHaskell #-}

    module Graphics.Rendering.Chart.Renderable(
        Renderable(..),
        ToRenderable(..),
        PickFn,
        Rectangle(..),
        RectCornerStyle(..),

        rectangleToRenderable,
        drawRectangle,

        fillBackground,
        addMargins,
        emptyRenderable,
        embedRenderable,
        label,
        rlabel,
        spacer,
        spacer1,
        setPickFn,
        mapMaybePickFn,
        mapPickFn,
        nullPickFn,

        rect_minsize,
        rect_fillStyle,
        rect_lineStyle,
        rect_cornerStyle,
    ) where

    import Control.Monad
    import Control.Lens
    import Data.Monoid
    import Data.Default.Class

    import Graphics.Rendering.Chart.Geometry
    import Graphics.Rendering.Chart.Drawing
    import Graphics.Rendering.Chart.Utils

    -- | A function that maps a point in device coordinates to some value.
    --
    --   Perhaps it might be generalised from Maybe a to
    --   (MonadPlus m ) => m a in the future.
    type PickFn a = Point -> Maybe a

    nullPickFn :: PickFn a
    nullPickFn = const Nothing

    -- | A Renderable is a record of functions required to layout a
    --   graphic element.
    data Renderable a = Renderable {

       -- | Calculate the minimum size of the renderable.
       minsize :: BackendProgram RectSize,

       -- | Draw the renderable with a rectangle, which covers
       --   the origin to a given point.
       --
       --   The resulting "pick" function  maps a point in the image to a value.
       render  :: RectSize -> BackendProgram (PickFn a)
    }
      deriving (Functor)

    -- | A type class abtracting the conversion of a value to a Renderable.
    class ToRenderable a where
      toRenderable :: a -> Renderable ()

    instance ToRenderable (Renderable a) where
      toRenderable = void

    emptyRenderable :: Renderable a
    emptyRenderable = spacer (0,0)

    -- | Create a blank renderable with a specified minimum size.
    spacer :: RectSize -> Renderable a
    spacer sz  = Renderable {
       minsize = return sz,
       render  = \_ -> return nullPickFn
    }

    -- | Create a blank renderable with a minimum size the same as
    --   some other renderable.
    spacer1 :: Renderable a -> Renderable b
    spacer1 r  = r{ render  = \_ -> return nullPickFn }

    -- | Replace the pick function of a renderable with another.
    setPickFn :: PickFn b -> Renderable a -> Renderable b
    setPickFn pickfn r = r{ render  = \sz -> render r sz >> return pickfn }

    -- | Map a function over the result of a renderable's pickfunction, keeping only 'Just' results.
    mapMaybePickFn :: (a -> Maybe b) -> Renderable a -> Renderable b
    mapMaybePickFn f r = r{ render = \sz -> do pf <- render r sz
                                               return (join . fmap f . pf) }

    -- | Map a function over result of a renderable's pickfunction.
    mapPickFn :: (a -> b) -> Renderable a -> Renderable b
    mapPickFn f = mapMaybePickFn (Just . f)

    -- | Add some spacing at the edges of a renderable.
    addMargins :: (Double,Double,Double,Double) -- ^ The spacing to be added.
               -> Renderable a                  -- ^ The source renderable.
               -> Renderable a
    addMargins (t,b,l,r) rd = Renderable { minsize = mf, render = rf }
      where
        mf = do
            (w,h) <- minsize rd
            return (w+l+r,h+t+b)

        rf (w,h) =
            withTranslation (Point l t) $ do
              pickf <- render rd (w-l-r,h-t-b)
              return (mkpickf pickf (t,b,l,r) (w,h))

        mkpickf pickf (t',b',l',r') (w,h) (Point x y)
            | x >= l' && x <= w-r' && y >= t' && t' <= h-b' = pickf (Point (x-l') (y-t'))
            | otherwise                                     = Nothing

    -- | Overlay a renderable over a solid background fill.
    fillBackground :: FillStyle -> Renderable a -> Renderable a
    fillBackground fs r = r{ render = rf }
      where
        rf rsize@(w,h) = do
          withFillStyle fs $ do
            p <- alignFillPath $ rectPath (Rect (Point 0 0) (Point w h))
            fillPath p
          render r rsize

    -- | Helper function for using a renderable, when we generate it
    --   in the BackendProgram monad.
    embedRenderable :: BackendProgram (Renderable a) -> Renderable a
    embedRenderable ca = Renderable {
       minsize = do { a <- ca; minsize a },
       render  = \ r -> do { a <- ca; render a r }
    }

    ----------------------------------------------------------------------
    -- Labels

    -- | Construct a renderable from a text string, aligned with the axes.
    label :: FontStyle -> HTextAnchor -> VTextAnchor -> String -> Renderable String
    label fs hta vta = rlabel fs hta vta 0

    -- | Construct a renderable from a text string, rotated wrt to axes. The angle
    --   of rotation is in degrees, measured clockwise from the horizontal.
    rlabel :: FontStyle -> HTextAnchor -> VTextAnchor -> Double -> String -> Renderable String
    rlabel fs hta vta rot s = Renderable { minsize = mf, render = rf }
      where
        mf = withFontStyle fs $ do
           ts <- textSize s
           let sz = (textSizeWidth ts, textSizeHeight ts)
           return (xwid sz, ywid sz)

        rf (w0,h0) = withFontStyle fs $ do
          ts <- textSize s
          let sz@(w,h) = (textSizeWidth ts, textSizeHeight ts)
              descent = textSizeDescent ts

              xadj HTA_Left   = xwid sz/2
              xadj HTA_Centre = w0/2
              xadj HTA_Right  = w0 - xwid sz/2

              yadj VTA_Top      = ywid sz/2
              yadj VTA_Centre   = h0/2
              yadj VTA_Bottom   = h0 - ywid sz/2
              yadj VTA_BaseLine = h0 - ywid sz/2 + descent*acr

          withTranslation (Point 0 (-descent)) $
            withTranslation (Point (xadj hta) (yadj vta)) $
              withRotation rot' $ do
                drawText (Point (-w/2) (h/2)) s
                return (\_-> Just s)  -- PickFn String

        rot'      = rot / 180 * pi
        (cr,sr)   = (cos rot', sin rot')
        (acr,asr) = (abs cr, abs sr)

        xwid (w,h) = w*acr + h*asr
        ywid (w,h) = w*asr + h*acr

    ----------------------------------------------------------------------
    -- Rectangles

    data RectCornerStyle = RCornerSquare
                         | RCornerBevel Double
                         | RCornerRounded Double

    data Rectangle = Rectangle {
      _rect_minsize     :: RectSize,
      _rect_fillStyle   :: Maybe FillStyle,
      _rect_lineStyle   :: Maybe LineStyle,
      _rect_cornerStyle :: RectCornerStyle
    }

    instance Default Rectangle where
      def = Rectangle
        { _rect_minsize     = (0,0)
        , _rect_fillStyle   = Nothing
        , _rect_lineStyle   = Nothing
        , _rect_cornerStyle = RCornerSquare
        }

    instance ToRenderable Rectangle where
      toRenderable = rectangleToRenderable

    rectangleToRenderable :: Rectangle -> Renderable a
    rectangleToRenderable rectangle = Renderable mf rf
      where
        mf = return (_rect_minsize rectangle)
        rf = \rectSize -> drawRectangle (Point 0 0)
                                        rectangle{ _rect_minsize = rectSize }

    -- | Draw the specified rectangle such that its top-left vertex is placed at
    --   the given position
    drawRectangle :: Point -> Rectangle -> BackendProgram (PickFn a)
    drawRectangle point rectangle = do
      maybeM () (fill point size) (_rect_fillStyle rectangle)
      maybeM () (stroke point size) (_rect_lineStyle rectangle)
      return nullPickFn
        where
          size = _rect_minsize rectangle

          fill p sz fs =
              withFillStyle fs $
                fillPath $ strokeRectangleP p sz (_rect_cornerStyle rectangle)

          stroke p sz ls =
              withLineStyle ls $
                strokePath $ strokeRectangleP p sz (_rect_cornerStyle rectangle)

          strokeRectangleP (Point x1 y1) (x2,y2) RCornerSquare =
              let (x3,y3) = (x1+x2,y1+y2) in moveTo' x1 y1
                                          <> lineTo' x1 y3
                                          <> lineTo' x3 y3
                                          <> lineTo' x3 y1
                                          <> lineTo' x1 y1

          strokeRectangleP (Point x1 y1) (x2,y2) (RCornerBevel s) =
              let (x3,y3) = (x1+x2,y1+y2) in moveTo' x1 (y1+s)
                                          <> lineTo' x1 (y3-s)
                                          <> lineTo' (x1+s) y3
                                          <> lineTo' (x3-s) y3
                                          <> lineTo' x3 (y3-s)
                                          <> lineTo' x3 (y1+s)
                                          <> lineTo' (x3-s) y1
                                          <> lineTo' (x1+s) y1
                                          <> lineTo' x1 (y1+s)

          strokeRectangleP (Point x1 y1) (x2,y2) (RCornerRounded s) =
              let (x3,y3) = (x1+x2,y1+y2) in
                arcNeg (Point (x1+s) (y3-s)) s (pi2*2) pi2
                <> arcNeg (Point (x3-s) (y3-s)) s pi2 0
                <> arcNeg (Point (x3-s) (y1+s)) s 0 (pi2*3)
                <> arcNeg (Point (x1+s) (y1+s)) s (pi2*3) (pi2*2)
                <> lineTo' x1 (y3-s)

          pi2 = pi / 2

    $( makeLenses ''Rectangle )