{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
#ifdef TRUSTWORTHY
{-# LANGUAGE Trustworthy #-}
#endif
-------------------------------------------------------------------------------
-- |
-- Module      :  Control.Lens.Getter
-- Copyright   :  (C) 2012 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  Rank2Types
--
--
-- A @'Getter' s a@ is just any function @(s -> a)@, which we've flipped
-- into continuation passing style, @(a -> r) -> s -> r@ and decorated
-- with 'Accessor' to obtain:
--
-- @type 'Getting' r s t a b = (a -> 'Accessor' r b) -> s -> 'Accessor' r t@
--
-- If we restrict access to knowledge about the type 'r' and can work for
-- any b and t, we could get:
--
-- @type 'Getter' s a = forall r. 'Getting' r s s a a@
--
-- But we actually hide the use of 'Accessor' behind a class 'Gettable'
-- to error messages from type class resolution rather than at unification
-- time, where they are much uglier.
--
-- @type 'Getter' s a = forall f. 'Gettable' f => (a -> f a) -> s -> f s@
--
-- Everything you can do with a function, you can do with a 'Getter', but
-- note that because of the continuation passing style ('.') composes them
-- in the opposite order.
--
-- Since it is only a function, every 'Getter' obviously only retrieves a
-- single value for a given input.
--
-------------------------------------------------------------------------------
module Control.Lens.Getter
  (
  -- * Getters
    Getter
  , Getting
  -- * Building Getters
  , to
  -- * Combinators for Getters and Folds
  , (^.)
  , (&)
  , view
  , views
  , use
  , uses
  -- * Simple Getter Operations
  , view'
  , views'
  , use'
  , uses'
  -- * Storing Getters
  , ReifiedGetter(..)
  , Gettable
  , Accessor
  ) where

import Control.Lens.Classes
import Control.Lens.Internal
import Control.Lens.Internal.Composition
import Control.Monad.Reader.Class as Reader
import Control.Monad.State        as State

-- $setup
-- >>> import Control.Lens
-- >>> import Data.List.Lens
-- >>> import Debug.SimpleReflect.Expr
-- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g)
-- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f
-- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g

infixl 8 ^.
infixl 1 &

-------------------------------------------------------------------------------
-- Pipelining
-------------------------------------------------------------------------------

-- | Passes the result of the left side to the function on the right side (forward pipe operator).
--
-- This is the flipped version of ('$'), which is more common in languages like F# as (@|>@) where it is needed
-- for inference. Here it is supplied for notational convenience and given a precedence that allows it
-- to be nested inside uses of ('$').
--
-- >>> a & f
-- f a
--
-- >>> "hello" & length & succ
-- 6
--
-- This combinator is commonly used when applying multiple lens operations in sequence.
--
-- >>> ("hello","world") & _1.element 0 .~ 'j' & _1.element 4 .~ 'y'
-- ("jelly","world")
--
-- This reads somewhat similar to:
--
-- >>> flip execState ("hello","world") $ do _1.element 0 .= 'j'; _1.element 4 .= 'y'
-- ("jelly","world")
--

(&) :: a -> (a -> b) -> b
a & f = f a
{-# INLINE (&) #-}

-------------------------------------------------------------------------------
-- Getters
-------------------------------------------------------------------------------

-- | A 'Getter' describes how to retrieve a single value in a way that can be
-- composed with other lens-like constructions.
--
-- Unlike a 'Control.Lens.Type.Lens' a 'Getter' is read-only. Since a 'Getter'
-- cannot be used to write back there are no lens laws that can be applied to
-- it. In fact, it is isomorphic to an arbitrary function from @(a -> s)@.
--
-- Moreover, a 'Getter' can be used directly as a 'Control.Lens.Fold.Fold',
-- since it just ignores the 'Applicative'.
type Getter s a = forall f. Gettable f => (a -> f a) -> s -> f s

-- | Build a 'Getter' from an arbitrary Haskell function.
--
-- @'to' f . 'to' g ≡ 'to' (g . f)@
--
-- @a '^.' 'to' f ≡ f a@
--
-- >>> a ^.to f
-- f a
--
-- >>> ("hello","world")^.to snd
-- "world"
--
-- >>> 5^.to succ
-- 6
--
-- >>> (0, -5)^._2.to abs
-- 5
to :: (s -> a) -> Getter s a
to f g = coerce . g . f
{-# INLINE to #-}

-- |
-- When you see this in a type signature it indicates that you can
-- pass the function a 'Control.Lens.Type.Lens', 'Getter',
-- 'Control.Lens.Traversal.Traversal', 'Control.Lens.Fold.Fold',
-- 'Control.Lens.Prism.Prism', 'Control.Lens.Iso.Iso', or one of
-- the indexed variants, and it will just \"do the right thing\".
--
-- Most 'Getter' combinators are able to be used with both a 'Getter' or a
-- 'Control.Lens.Fold.Fold' in limited situations, to do so, they need to be
-- monomorphic in what we are going to extract with 'Const'. To be compatible
-- with 'Control.Lens.Type.Lens', 'Control.Lens.Traversal.Traversal' and
-- 'Control.Lens.Iso.Iso' we also restricted choices of the irrelevant @t@ and
-- @b@ parameters.
--
-- If a function accepts a @'Getting' r s t a b@, then when @r@ is a 'Monoid', then
-- you can pass a 'Control.Lens.Fold.Fold' (or
-- 'Control.Lens.Traversal.Traversal'), otherwise you can only pass this a
-- 'Getter' or 'Control.Lens.Type.Lens'.
--
type Getting r s t a b = (a -> Accessor r b) -> s -> Accessor r t

-------------------------------------------------------------------------------
-- Getting Values
-------------------------------------------------------------------------------

-- | View the value pointed to by a 'Getter', 'Control.Lens.Iso.Iso' or
-- 'Control.Lens.Type.Lens' or the result of folding over all the results of a
-- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points
-- at a monoidal values.
--
-- @'view' . 'to' ≡ 'id'@
--
-- >>> view (to f) a
-- f a
--
-- >>> view _2 (1,"hello")
-- "hello"
--
-- >>> view (to succ) 5
-- 6
--
-- >>> view (_2._1) ("hello",("world","!!!"))
-- "world"
--
--
-- As @views@ is commonly used to access the target of a 'Getter' or obtain a monoidal summary of the targets of a 'Fold',
-- It may be useful to think of it as having one of these more restrictive signatures:
--
-- @
-- 'view' ::             'Getter' s a             -> s -> a
-- 'view' :: 'Monoid' m => 'Control.Lens.Fold.Fold' s m               -> s -> m
-- 'view' ::             'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a         -> s -> a
-- 'view' ::             'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a        -> s -> a
-- 'view' :: 'Monoid' m => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s m   -> s -> m
-- @
--
-- In a more general setting, such as when working with a monad transformer stack you can use:
--
-- @
-- 'view' :: 'MonadReader' s m             => 'Getter' s a           -> m a
-- 'view' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Fold.Fold' s a             -> m a
-- 'view' :: 'MonadReader' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a       -> m a
-- 'view' :: 'MonadReader' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a      -> m a
-- 'view' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> m a
-- @
view :: MonadReader s m => Getting a s t a b -> m a
view l = Reader.asks (runAccessor #. l Accessor)
{-# INLINE view #-}

-- | View the value of a 'Getter', 'Control.Lens.Iso.Iso',
-- 'Control.Lens.Type.Lens' or the result of folding over the result of mapping
-- the targets of a 'Control.Lens.Fold.Fold' or
-- 'Control.Lens.Traversal.Traversal'.
--
-- It may be useful to think of 'views' as having these more restrictive
-- signatures:
--
-- @'views' l f ≡ 'view' (l '.' 'to' f)@
--
-- >>> views (to f) g a
-- g (f a)
--
-- >>> views _2 length (1,"hello")
-- 5
--
-- As @views@ is commonly used to access the target of a 'Getter' or obtain a monoidal summary of the targets of a 'Fold',
-- It may be useful to think of it as having one of these more restrictive signatures:
--
-- @
-- 'views' ::             'Getter' s a             -> (a -> r) -> s -> r
-- 'views' :: 'Monoid' m => 'Control.Lens.Fold.Fold' s a               -> (a -> m) -> s -> m
-- 'views' ::             'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a         -> (a -> r) -> s -> r
-- 'views' ::             'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a        -> (a -> r) -> s -> r
-- 'views' :: 'Monoid' m => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a   -> (a -> m) -> s -> m
-- @
--
-- In a more general setting, such as when working with a monad transformer stack you can use:
--
-- @
-- 'view' :: 'MonadReader' s m             => 'Getter' s a           -> m a
-- 'view' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Fold.Fold' s a             -> m a
-- 'view' :: 'MonadReader' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a       -> m a
-- 'view' :: 'MonadReader' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a      -> m a
-- 'view' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> m a
-- @
views :: MonadReader s m => Getting r s t a b -> (a -> r) -> m r
views l f = Reader.asks (runAccessor #. l (Accessor #. f))
{-# INLINE views #-}

-- | View the value pointed to by a 'Getter' or 'Control.Lens.Type.Lens' or the
-- result of folding over all the results of a 'Control.Lens.Fold.Fold' or
-- 'Control.Lens.Traversal.Traversal' that points at a monoidal values.
--
-- This is the same operation as 'view' with the arguments flipped.
--
-- The fixity and semantics are such that subsequent field accesses can be
-- performed with ('Prelude..')
--
-- >>> (a,b)^._2
-- b
--
-- >>> ("hello","world")^._2
-- "world"
--
-- >>> import Data.Complex
-- >>> ((0, 1 :+ 2), 3)^._1._2.to magnitude
-- 2.23606797749979
--
-- @
-- ('^.') ::             s -> 'Getter' s a             -> a
-- ('^.') :: 'Monoid' m => s -> 'Control.Lens.Fold.Fold' s m               -> m
-- ('^.') ::             s -> 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a         -> a
-- ('^.') ::             s -> 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a        -> a
-- ('^.') :: 'Monoid' m => s -> 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s m   -> m
-- @
(^.) :: s -> Getting a s t a b -> a
s ^. l = runAccessor (l Accessor s)
{-# INLINE (^.) #-}

-------------------------------------------------------------------------------
-- MonadState
-------------------------------------------------------------------------------

-- |
-- Use the target of a 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', or
-- 'Getter' in the current state, or use a summary of a
-- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points
-- to a monoidal value.
--
-- >>> evalState (use _1) (a,b)
-- a
--
-- >>> evalState (use _1) ("hello","world")
-- "hello"
--
-- @
-- 'use' :: 'MonadState' s m             => 'Getter' s a             -> m a
-- 'use' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Fold.Fold' s r               -> m r
-- 'use' :: 'MonadState' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a         -> m a
-- 'use' :: 'MonadState' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a        -> m a
-- 'use' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s r   -> m r
-- @
use :: MonadState s m => Getting a s t a b -> m a
use l = State.gets (view l)
{-# INLINE use #-}

-- |
-- Use the target of a 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso' or
-- 'Getter' in the current state, or use a summary of a
-- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that
-- points to a monoidal value.
--
-- >>> evalState (uses _1 length) ("hello","world")
-- 5
--
-- @
-- 'uses' :: 'MonadState' s m             => 'Getter' s a           -> (a -> r) -> m r
-- 'uses' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Fold.Fold' s a             -> (a -> r) -> m r
-- 'uses' :: 'MonadState' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a      -> (a -> r) -> m r
-- 'uses' :: 'MonadState' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a       -> (a -> r) -> m r
-- 'uses' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> r) -> m r
-- @
uses :: MonadState s m => Getting r s t a b -> (a -> r) -> m r
uses l f = State.gets (views l f)
{-# INLINE uses #-}

------------------------------------------------------------------------------
-- Accessing State, Simplified
------------------------------------------------------------------------------

-- |
-- This is a type restricted version of 'use' that expects a 'Simple' 'Getter'.
--
-- Use the target of a 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', or
-- 'Getter' in the current state, or use a summary of a
-- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points
-- to a monoidal value.
--
-- This use of this combinator may aid type-inference when working with lenses or traversals that
-- have non-defaultable typeclass constraints on their arguments.
--
-- >>> evalState (use' _1) (a,b)
-- a
--
--
-- >>> evalState (use' _1) ("hello","world")
-- "hello"
--
-- @
-- 'use'' :: 'MonadState' s m             => 'Getter' s a             -> m a
-- 'use'' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Fold.Fold' s r               -> m r
-- 'use'' :: 'MonadState' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a         -> m a
-- 'use'' :: 'MonadState' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a        -> m a
-- 'use'' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s r   -> m r
-- @
use' :: MonadState s m => Getting a s s a a -> m a
use' l = State.gets (view' l)
{-# INLINE use' #-}

-- |
-- This is a type restricted version of 'uses' that expects a 'Simple' 'Getter'.
--
-- Use the target of a 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso' or
-- 'Getter' in the current state, or use a summary of a
-- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that
-- points to a monoidal value.
--
-- >>> evalState (uses' _1 length) ("hello","world")
-- 5
--
-- @
-- 'uses'' :: 'MonadState' s m             => 'Getter' s a           -> (a -> r) -> m r
-- 'uses'' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Fold.Fold' s a             -> (a -> r) -> m r
-- 'uses'' :: 'MonadState' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a      -> (a -> r) -> m r
-- 'uses'' :: 'MonadState' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a       -> (a -> r) -> m r
-- 'uses'' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> r) -> m r
-- @
uses' :: MonadState s m => Getting r s s a a -> (a -> r) -> m r
uses' l f = State.gets (views' l f)
{-# INLINE uses' #-}

------------------------------------------------------------------------------
-- Viewing, Simplified
------------------------------------------------------------------------------

-- | This is a type restricted version of 'view' that expects a 'Simple' 'Getter'.
--
-- View the value pointed to by a 'Getter', 'Control.Lens.Iso.Iso' or
-- 'Control.Lens.Type.Lens' or the result of folding over all the results of a
-- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points
-- at a monoidal values.
--
-- @'view'' . 'to' ≡ 'id'@
--
-- >>> view' (to f) a
-- f a
--
-- >>> view' _2 (1,"hello")
-- "hello"
--
-- >>> view' (to succ) 5
-- 6
--
-- >>> view' (_2._1) ("hello",("world","!!!"))
-- "world"
--
-- As 'view'' is commonly used to access the target of a 'Getter' or obtain a monoidal summary of the targets of a 'Fold',
-- It may be useful to think of it as having one of these more restrictive signatures:
--
-- @
-- 'view'' ::             'Getter' s a             -> s -> a
-- 'view'' :: 'Monoid' m => 'Control.Lens.Fold.Fold' s m               -> s -> m
-- 'view'' ::             'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a         -> s -> a
-- 'view'' ::             'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a        -> s -> a
-- 'view'' :: 'Monoid' m => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s m   -> s -> m
-- @
--
-- In a more general setting, such as when working with a monad transformer stack you can use:
--
-- @
-- 'view'' :: 'MonadReader' s m             => 'Getter' s a           -> m a
-- 'view'' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Fold.Fold' s a             -> m a
-- 'view'' :: 'MonadReader' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a       -> m a
-- 'view'' :: 'MonadReader' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a      -> m a
-- 'view'' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> m a
-- @
view' :: MonadReader s m => Getting a s s a a -> m a
view' l = Reader.asks (runAccessor #. l Accessor)
{-# INLINE view' #-}

-- | This is a type restricted version of 'views' that expects a 'Simple' 'Getter'.
--
-- View the value of a 'Getter', 'Control.Lens.Iso.Iso',
-- 'Control.Lens.Type.Lens' or the result of folding over the result of mapping
-- the targets of a 'Control.Lens.Fold.Fold' or
-- 'Control.Lens.Traversal.Traversal'.
--
-- It may be useful to think of 'perviews' as having these more restrictive
-- signatures:
--
-- @'views'' l f ≡ 'view'' (l '.' 'to' f)@
--
-- >>> views' _2 length (1,"hello")
-- 5
--
-- As 'views'' is commonly used to access the target of a 'Getter' or obtain a monoidal summary of the targets of a 'Fold',
-- It may be useful to think of it as having one of these more restrictive signatures:
--
-- @
-- 'views'' ::             'Getter' s a             -> (a -> r) -> s -> r
-- 'views'' :: 'Monoid' m => 'Control.Lens.Fold.Fold' s a               -> (a -> m) -> s -> m
-- 'views'' ::             'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a         -> (a -> r) -> s -> r
-- 'views'' ::             'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a        -> (a -> r) -> s -> r
-- 'views'' :: 'Monoid' m => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a   -> (a -> m) -> s -> m
-- @
--
-- In a more general setting, such as when working with a monad transformer stack you can use:
--
-- @
-- 'views'' :: 'MonadReader' s m             => 'Getter' s a           -> (a -> r) -> m r
-- 'views'' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Fold.Fold' s a             -> (a -> r) -> m r
-- 'views'' :: 'MonadReader' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a       -> (a -> r) -> m r
-- 'views'' :: 'MonadReader' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a      -> (a -> r) -> m r
-- 'views'' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> r) -> m r
-- @
views' :: MonadReader s m => Getting r s s a a -> (a -> r) -> m r
views' l f = Reader.asks (runAccessor #. l (Accessor #. f))
{-# INLINE views' #-}

------------------------------------------------------------------------------
-- Reified Getters
------------------------------------------------------------------------------

-- | Useful for storing getters in containers.
newtype ReifiedGetter s a = ReifyGetter { reflectGetter :: Getter s a }


{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Plot.Figure.Plot.Data
-- Copyright   :  (c) A. V. H. McPhail 2010
-- License     :  BSD3
--
-- Maintainer  :  haskell.vivian.mcphail <at> gmail <dot> com
-- Stability   :  provisional
-- Portability :  portable
--
-- 'Data' operations
--
-----------------------------------------------------------------------------

module Graphics.Rendering.Plot.Figure.Plot.Data (
                                                 Data
                                                 -- * Series data
                                                , FormattedSeries()
                                                , line, point, linepoint
                                                , impulse, step
                                                , area
                                                , bar
                                                , hist
                                                , candle, whisker
                                                , setDataSeries
                                                -- * Plot type
                                                , setSeriesType
                                                , setAllSeriesTypes
                                                -- * Formatting
                                                , PlotFormats(..)
                                                , withSeriesFormat
                                                , withAllSeriesFormats
                                                -- * Internal
                                                , Abscissa(), Ordinate(), Dataset()
                                                ) where

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

import Numeric.LinearAlgebra.Data hiding (format,step)
import Numeric.LinearAlgebra.Devel

import Data.Maybe

import qualified Data.Array.IArray as A

import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Supply
import Control.Monad.Trans.Maybe

import Graphics.Rendering.Plot.Types
import Graphics.Rendering.Plot.Figure.Line
import Graphics.Rendering.Plot.Figure.Point
import Graphics.Rendering.Plot.Figure.Bar

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

dataSeriesNum :: DataSeries -> Int
dataSeriesNum (DS_Y a)      = A.rangeSize $ A.bounds $ a
dataSeriesNum (DS_1toN _ a) = A.rangeSize $ A.bounds $ a
dataSeriesNum (DS_1to1 a)   = A.rangeSize $ A.bounds $ a
dataSeriesNum (DS_Surf _)   = 1

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

class SeriesTypes a where
    setSeriesType'' :: SeriesType -> a -> Data a

instance SeriesTypes Decoration where
    setSeriesType'' Line      d@(DecLine _)    = return d
    setSeriesType'' Line      (DecPoint pt)    = do
                                                 let c = getPointColour pt
                                                 lt <- toLine c
                                                 return $ DecLine lt
    setSeriesType'' Line      (DecLinPt lt _)  = return $ DecLine lt
    setSeriesType'' Line      (DecImpulse lt)  = return $ DecLine lt
    setSeriesType'' Line      (DecStep lt)     = return $ DecLine lt
    setSeriesType'' Line      (DecArea lt)     = return $ DecLine lt
    setSeriesType'' Line      (DecBar bt)      = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecLine lt
    setSeriesType'' Line      (DecHist bt)     = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecLine lt
    setSeriesType'' Line      (DecCand bt)     = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecLine lt
    setSeriesType'' Line      (DecWhisk bt)    = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecLine lt
    setSeriesType'' Point     (DecLine lt)     = do
                                                 let c = fromJust $ getLineColour lt
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecPoint pt
    setSeriesType'' Point     d@(DecPoint _)   = return d
    setSeriesType'' Point     (DecLinPt _ pt)  = return $ DecPoint pt
    setSeriesType'' Point     (DecImpulse lt)  = do
                                                 let c = fromJust $ getLineColour lt
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecPoint pt
    setSeriesType'' Point     (DecStep lt)     = do
                                                 let c = fromJust $ getLineColour lt
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecPoint pt
    setSeriesType'' Point     (DecArea lt)     = do
                                                 let c = fromJust $ getLineColour lt
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecPoint pt
    setSeriesType'' Point     (DecBar bt)      = do
                                                 let c = getBarColour bt
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecPoint pt
    setSeriesType'' Point     (DecHist bt)     = do
                                                 let c = getBarColour bt
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecPoint pt
    setSeriesType'' Point     (DecCand bt)     = do
                                                 let c = getBarColour bt
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecPoint pt
    setSeriesType'' Point     (DecWhisk bt)    = do
                                                 let c = getBarColour bt
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecPoint pt
    setSeriesType'' LinePoint (DecLine lt)     = do
                                                 let c = fromJust $ getLineColour lt
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecLinPt lt pt
    setSeriesType'' LinePoint (DecPoint pt)    = do
                                                 let c = getPointColour pt
                                                 lt <- toLine (c :: Color)
                                                 return $ DecLinPt lt pt
    setSeriesType'' LinePoint d@(DecLinPt _ _) = return d
    setSeriesType'' LinePoint (DecImpulse lt)  = do
                                                 let c = fromJust $ getLineColour lt
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecLinPt lt pt
    setSeriesType'' LinePoint (DecStep lt)     = do
                                                 let c = fromJust $ getLineColour lt
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecLinPt lt pt
    setSeriesType'' LinePoint (DecArea lt)     = do
                                                 let c = fromJust $ getLineColour lt
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecLinPt lt pt
    setSeriesType'' LinePoint (DecBar bt)      = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecLinPt lt pt
    setSeriesType'' LinePoint (DecHist bt)     = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecLinPt lt pt
    setSeriesType'' LinePoint (DecCand bt)     = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecLinPt lt pt
    setSeriesType'' LinePoint (DecWhisk bt)    = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecLinPt lt pt
    setSeriesType'' Impulse   (DecLine lt)     = return $ DecImpulse lt
    setSeriesType'' Impulse   (DecPoint pt)    = do
                                                 let c = getPointColour pt
                                                 lt <- toLine c
                                                 return $ DecImpulse lt
    setSeriesType'' Impulse   (DecLinPt lt _)  = return $ DecImpulse lt
    setSeriesType'' Impulse   d@(DecImpulse _) = return d
    setSeriesType'' Impulse   (DecStep lt)     = return $ DecImpulse lt
    setSeriesType'' Impulse   (DecArea lt)     = return $ DecImpulse lt
    setSeriesType'' Impulse   (DecBar bt)      = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecImpulse lt
    setSeriesType'' Impulse   (DecHist bt)     = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecImpulse lt
    setSeriesType'' Impulse   (DecCand bt)     = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecImpulse lt
    setSeriesType'' Impulse   (DecWhisk bt)    = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecImpulse lt
    setSeriesType'' Step      (DecLine lt)     = return $ DecStep lt
    setSeriesType'' Step      (DecPoint pt)    = do
                                                 let c = getPointColour pt
                                                 lt <- toLine c
                                                 return $ DecStep lt
    setSeriesType'' Step      (DecLinPt lt _)  = return $ DecStep lt
    setSeriesType'' Step      (DecImpulse lt)  = return $ DecStep lt
    setSeriesType'' Step      d@(DecStep _)    = return d
    setSeriesType'' Step      (DecArea lt)     = return $ DecStep lt
    setSeriesType'' Step      (DecBar bt)      = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecStep lt
    setSeriesType'' Step      (DecHist bt)     = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecStep lt
    setSeriesType'' Step      (DecCand bt)     = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecStep lt
    setSeriesType'' Step      (DecWhisk bt)    = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecStep lt
    setSeriesType'' Area      (DecLine lt)     = return $ DecArea lt
    setSeriesType'' Area      (DecPoint pt)    = do
                                                 let c = getPointColour pt
                                                 lt <- toLine c
                                                 return $ DecArea lt
    setSeriesType'' Area      (DecLinPt lt _)  = return $ DecArea lt
    setSeriesType'' Area      (DecImpulse lt)  = return $ DecArea lt
    setSeriesType'' Area      (DecStep lt)     = return $ DecArea lt
    setSeriesType'' Area      d@(DecArea _)    = return d
    setSeriesType'' Area      (DecBar bt)      = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecArea lt
    setSeriesType'' Area      (DecHist bt)     = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecArea lt
    setSeriesType'' Area      (DecCand bt)     = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecArea lt
    setSeriesType'' Area      (DecWhisk bt)    = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecArea lt
    setSeriesType'' Bar      (DecLine lt)      = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecBar bt
    setSeriesType'' Bar      (DecPoint pt)     = do
                                                 let c = getPointColour pt
                                                 bt <- toBar c
                                                 return $ DecBar bt
    setSeriesType'' Bar      (DecLinPt lt _)   = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecBar bt
    setSeriesType'' Bar      (DecImpulse lt)   = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecBar bt
    setSeriesType'' Bar      (DecStep lt)      = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecBar bt
    setSeriesType'' Bar      (DecArea lt)      = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecBar bt
    setSeriesType'' Bar      d@(DecBar _)      = return d
    setSeriesType'' Bar      (DecHist bt)      = return $ DecBar bt
    setSeriesType'' Bar      (DecCand bt)      = return $ DecBar bt
    setSeriesType'' Bar      (DecWhisk bt)     = return $ DecBar bt
    setSeriesType'' Hist     (DecLine lt)      = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecHist bt
    setSeriesType'' Hist     (DecPoint pt)     = do
                                                 let c = getPointColour pt
                                                 bt <- toBar c
                                                 return $ DecHist bt
    setSeriesType'' Hist     (DecLinPt lt _)   = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecHist bt
    setSeriesType'' Hist     (DecImpulse lt)   = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecHist bt
    setSeriesType'' Hist     (DecStep lt)      = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecHist bt
    setSeriesType'' Hist     (DecArea lt)      = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecHist bt
    setSeriesType'' Hist     (DecBar bt)       = return $ DecHist bt
    setSeriesType'' Hist     d@(DecHist _)     = return d
    setSeriesType'' Hist     (DecCand bt)      = return $ DecHist bt
    setSeriesType'' Hist     (DecWhisk bt)     = return $ DecHist bt
    setSeriesType'' Candle  (DecLine lt)      = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecCand bt
    setSeriesType'' Candle  (DecPoint pt)     = do
                                                 let c = getPointColour pt
                                                 bt <- toBar c
                                                 return $ DecCand bt
    setSeriesType'' Candle  (DecLinPt lt _)   = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecCand bt
    setSeriesType'' Candle  (DecImpulse lt)   = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecCand bt
    setSeriesType'' Candle  (DecStep lt)      = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecCand bt
    setSeriesType'' Candle  (DecArea lt)      = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecCand bt
    setSeriesType'' Candle  (DecBar bt)       = return $ DecCand bt
    setSeriesType'' Candle  (DecHist bt)      = return $ DecCand bt
    setSeriesType'' Candle  d@(DecCand _)     = return d
    setSeriesType'' Candle  (DecWhisk bt)     = return $ DecCand bt
    setSeriesType'' Whisker  (DecLine lt)      = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecWhisk bt
    setSeriesType'' Whisker  (DecPoint pt)     = do
                                                 let c = getPointColour pt
                                                 bt <- toBar c
                                                 return $ DecWhisk bt
    setSeriesType'' Whisker  (DecLinPt lt _)   = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecWhisk bt
    setSeriesType'' Whisker  (DecImpulse lt)   = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecWhisk bt
    setSeriesType'' Whisker  (DecStep lt)      = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecWhisk bt
    setSeriesType'' Whisker  (DecArea lt)      = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecWhisk bt
    setSeriesType'' Whisker  (DecBar bt)       = return $ DecWhisk bt
    setSeriesType'' Whisker  (DecHist bt)      = return $ DecWhisk bt
    setSeriesType'' Whisker  (DecCand bt)      = return $ DecWhisk bt
    setSeriesType'' Whisker  d@(DecWhisk _)    = return d

instance SeriesTypes DecoratedSeries where
    setSeriesType'' t (DecSeries o d) = do
                                       d' <- setSeriesType'' t d
                                       return $ DecSeries o d'

setSeriesType' :: Int -> SeriesType -> DataSeries -> Data DataSeries
setSeriesType' i t (DS_Y a)      = do
                                      s' <- setSeriesType'' t $ a A.! i
                                      return $ DS_Y $ a A.// [(i,s')]
setSeriesType' i t (DS_1toN x a) = do
                                      s' <- setSeriesType'' t $ a A.! i
                                      return $ DS_1toN x $ a A.// [(i,s')]
setSeriesType' i t (DS_1to1 a)   = do
                                      let (x,s) = a A.! i
                                      s' <- setSeriesType'' t s
                                      return $ DS_1to1 $ a A.// [(i,(x,s'))]
setSeriesType' _ _ d@(DS_Surf _) = return d

-- | set the series type of a given data series
setSeriesType :: SeriesType -> Int -> Data ()
setSeriesType t i = do
                       ds <- get
                       ds' <- setSeriesType' i t ds
                       put ds'

-- | set the series type of all data series
setAllSeriesTypes :: SeriesType -> Data ()
setAllSeriesTypes t = do
                         ds <- get
                         let ln = dataSeriesNum ds
                         mapM_ (setSeriesType t) [1..ln]

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

class PlotFormats m where
    modifyFormat :: m () -> DecoratedSeries -> Data DecoratedSeries

instance PlotFormats Line where
    modifyFormat l (DecSeries o (DecLine lt))     = do
                                                    lo <- asks _lineoptions
                                                    let lt' = execLine l lo lt
                                                    return $ DecSeries o (DecLine lt')
    modifyFormat _ d@(DecSeries _ (DecPoint _))   = return d
    modifyFormat l (DecSeries o (DecLinPt lt pt)) = do
                                                    lo <- asks _lineoptions
                                                    let lt' = execLine l lo lt
                                                    return $ DecSeries o (DecLinPt lt' pt)
    modifyFormat l (DecSeries o (DecImpulse lt))  = do
                                                    lo <- asks _lineoptions
                                                    let lt' = execLine l lo lt
                                                    return $ DecSeries o (DecImpulse lt')
    modifyFormat l (DecSeries o (DecStep lt))     = do
                                                    lo <- asks _lineoptions
                                                    let lt' = execLine l lo lt
                                                    return $ DecSeries o (DecStep lt')
    modifyFormat l (DecSeries o (DecArea lt))     = do
                                                    lo <- asks _lineoptions
                                                    let lt' = execLine l lo lt
                                                    return $ DecSeries o (DecArea lt')
    modifyFormat _ d@(DecSeries _ (DecBar _))     = return d
    modifyFormat _ d@(DecSeries _ (DecHist _))    = return d
    modifyFormat _ d@(DecSeries _ (DecCand _))    = return d
    modifyFormat _ d@(DecSeries _ (DecWhisk _))   = return d

instance PlotFormats Point where
    modifyFormat _ d@(DecSeries _ (DecLine _))    = return d
    modifyFormat _ d@(DecSeries _ (DecImpulse _)) = return d
    modifyFormat _ d@(DecSeries _ (DecStep _))    = return d
    modifyFormat _ d@(DecSeries _ (DecArea _))    = return d
    modifyFormat p (DecSeries o (DecPoint pt))    = do
                                                    po <- asks _pointoptions
                                                    let pt' = execPoint p po pt
                                                    return $ DecSeries o (DecPoint pt')
    modifyFormat p (DecSeries o (DecLinPt lt pt)) = do
                                                    po <- asks _pointoptions
                                                    let pt' = execPoint p po pt
                                                    return $ DecSeries o (DecLinPt lt pt')
    modifyFormat _ d@(DecSeries _ (DecBar _))     = return d
    modifyFormat _ d@(DecSeries _ (DecHist _))    = return d
    modifyFormat _ d@(DecSeries _ (DecCand _))    = return d
    modifyFormat _ d@(DecSeries _ (DecWhisk _))   = return d

instance PlotFormats Bar where
    modifyFormat _ d@(DecSeries _ (DecLine _))    = return d
    modifyFormat _ d@(DecSeries _ (DecImpulse _)) = return d
    modifyFormat _ d@(DecSeries _ (DecStep _))    = return d
    modifyFormat _ d@(DecSeries _ (DecArea _))    = return d
    modifyFormat _ d@(DecSeries _ (DecPoint _))   = return d
    modifyFormat _ d@(DecSeries _ (DecLinPt _ _)) = return d
    modifyFormat b   (DecSeries o (DecBar bt))    = do
                                                    bo <- asks _baroptions
                                                    let bt' = execBar b bo bt
                                                    return $ DecSeries o (DecBar bt')
    modifyFormat b   (DecSeries o (DecHist bt))   = do
                                                    bo <- asks _baroptions
                                                    let bt' = execBar b bo bt
                                                    return $ DecSeries o (DecHist bt')
    modifyFormat b   (DecSeries o (DecCand bt))   = do
                                                    bo <- asks _baroptions
                                                    let bt' = execBar b bo bt
                                                    return $ DecSeries o (DecCand bt')
    modifyFormat b   (DecSeries o (DecWhisk bt))  = do
                                                    bo <- asks _baroptions
                                                    let bt' = execBar b bo bt
                                                    return $ DecSeries o (DecWhisk bt')

-- | format the plot elements of a given series
withSeriesFormat :: PlotFormats m => Int -> m () -> Data ()
withSeriesFormat i f = do
                       ds <- get
                       ds' <- case ds of
                                      (DS_Y a)      -> do
                                                       let d = a A.! i
                                                       d' <- modifyFormat f d
                                                       return $ DS_Y $ a A.// [(i,d')]
                                      (DS_1toN x a) -> do
                                                       let d = a A.! i
                                                       d' <- modifyFormat f d
                                                       return $ DS_1toN x $ a A.// [(i,d')]
                                      (DS_1to1 a)   -> do
                                                       let (x,d) = a A.! i
                                                       d' <- modifyFormat f d
                                                       return $ DS_1to1 $ a A.// [(i,(x,d'))]
                                      d@(DS_Surf _) -> return d
                       put ds'

-- | format the plot elements of all series
-- |     the operation to modify the formats is passed the series index
-- |     this allows, for example, colours to be selected from a list
-- |     that gets indexed by the argument
-- | @setColour i = setLineColour $ [black,blue,red,green,yellow] !! i@
withAllSeriesFormats :: PlotFormats m => (Int -> m ()) -> Data ()
withAllSeriesFormats f = do
                         ds <- get
                         let ln = dataSeriesNum ds
                         mapM_ (\i -> withSeriesFormat i (f i)) [1..ln]

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

class Abscissa a where
    toAbscissa :: a -> Abscissae

toAbscissae :: Abscissa a => [a] -> [Abscissae]
toAbscissae = map toAbscissa

instance Abscissa Series                   where toAbscissa s         = AbsPoints (isMonotoneIncreasing s) s

class Ordinate a where
    toOrdinate :: a -> Ordinates

toOrdinates :: Ordinate a => [a] -> [Ordinates]
toOrdinates = map toOrdinate

instance Ordinate Function                           where toOrdinate f         = OrdFunction Lower (cmap f) Nothing
instance Ordinate VectorFunction                     where toOrdinate f         = OrdFunction Lower f Nothing
instance Ordinate Series                             where toOrdinate s         = OrdPoints Lower (Plain s) Nothing
instance Ordinate (Series,ErrorSeries)               where toOrdinate (s,e)     = OrdPoints Lower (Error s (Left e)) Nothing
instance Ordinate (Series,(ErrorSeries,ErrorSeries)) where toOrdinate (s,(l,u)) = OrdPoints Lower (Error s (Right (l,u))) Nothing
instance Ordinate (MinMaxSeries,(ErrorSeries,ErrorSeries)) where toOrdinate (s,(l,u)) = OrdPoints Lower (MinMax s (Just (l,u))) Nothing
instance Ordinate (Function,AxisSide)                         where toOrdinate (f,ax)       = OrdFunction ax (cmap f) Nothing
instance Ordinate (VectorFunction,AxisSide)                   where toOrdinate (f,ax)       = OrdFunction ax f Nothing
instance Ordinate (Series,AxisSide)                           where toOrdinate (s,ax)       = OrdPoints ax (Plain s) Nothing
instance Ordinate (Series,ErrorSeries,AxisSide)               where toOrdinate (s,e,ax)     = OrdPoints ax (Error s (Left e)) Nothing
instance Ordinate (Series,(ErrorSeries,ErrorSeries),AxisSide) where toOrdinate (s,(l,u),ax) = OrdPoints ax (Error s (Right (l,u))) Nothing
instance Ordinate (MinMaxSeries,(ErrorSeries,ErrorSeries),AxisSide) where toOrdinate (s,(l,u),ax) = OrdPoints ax (MinMax s (Just (l,u))) Nothing
instance Ordinate (Function,SeriesLabel)                         where toOrdinate (f,la)       = OrdFunction Lower (cmap f) (Just la)
instance Ordinate (VectorFunction,SeriesLabel)                   where toOrdinate (f,la)       = OrdFunction Lower f (Just la)
instance Ordinate (Series,SeriesLabel)                           where toOrdinate (s,la)       = OrdPoints Lower (Plain s) (Just la)
instance Ordinate (Series,ErrorSeries,SeriesLabel)               where toOrdinate (s,e,la)     = OrdPoints Lower (Error s (Left e)) (Just la)
instance Ordinate (Series,(ErrorSeries,ErrorSeries),SeriesLabel) where toOrdinate (s,(l,u),la) = OrdPoints Lower (Error s (Right (l,u))) (Just la)

instance Ordinate (Function,AxisSide,SeriesLabel)                          where toOrdinate (f,ax,la)       = OrdFunction ax (cmap f) (Just la)
instance Ordinate (VectorFunction,AxisSide,SeriesLabel)                    where toOrdinate (f,ax,la)       = OrdFunction ax f (Just la)
instance Ordinate (Series,AxisSide,SeriesLabel)                            where toOrdinate (s,ax,la)       = OrdPoints ax (Plain s) (Just la)
instance Ordinate (Series,ErrorSeries,AxisSide,SeriesLabel)                where toOrdinate (s,e,ax,la)     = OrdPoints ax (Error s (Left e)) (Just la)
instance Ordinate (Series,(ErrorSeries,ErrorSeries),AxisSide,SeriesLabel)  where toOrdinate (s,(l,u),ax,la) = OrdPoints ax (Error s (Right (l,u))) (Just la)
instance Ordinate (MinMaxSeries,(ErrorSeries,ErrorSeries),AxisSide,SeriesLabel) where toOrdinate (s,(l,u),ax,la) = OrdPoints ax (MinMax s (Just (l,u))) (Just la)

class Decorations a where
    toDecoration :: a -> Decoration

toDecorations :: Decorations a => [a] -> [Decoration]
toDecorations = map toDecoration

instance Decorations LineType             where toDecoration l     = DecLine l
instance Decorations PointType            where toDecoration p     = DecPoint p
instance Decorations (LineType,PointType) where toDecoration (l,p) = DecLinPt l p
instance Decorations (PointType,LineType) where toDecoration (p,l) = DecLinPt l p
instance Decorations BarType              where toDecoration b     = DecBar b
instance Decorations Decoration           where toDecoration       = id

format :: (Ordinate a, Decorations b) => a -> b -> DecoratedSeries
format o f = DecSeries (toOrdinate o) (toDecoration f)

line :: (Ordinate a, LineFormat b) => a -> b -> FormattedSeries
line o f = do
           f' <- toLine f
           return $ format o f'

point :: (Ordinate a, PointFormat b) => a -> b -> FormattedSeries
point o f = do
            f' <- toPoint f
            return $ format o f'

linepoint :: (Ordinate a, LineFormat b, PointFormat c) => a -> b -> c -> FormattedSeries
linepoint o l p = do
                  l' <- toLine l
                  p' <- toPoint p
                  return $ format o (l',p')

impulse :: (Ordinate a, LineFormat b) => a -> b -> FormattedSeries
impulse o f = do
              f' <- toLine f
              setSeriesType'' Impulse (format o f')

step :: (Ordinate a, LineFormat b) => a -> b -> FormattedSeries
step o f = do
           f' <- toLine f
           setSeriesType'' Step (format o f')

area :: (Ordinate a, LineFormat b) => a -> b -> FormattedSeries
area o f = do
           f' <- toLine f
           setSeriesType'' Area (format o f')

bar :: (Ordinate a, BarFormat b) => a -> b -> FormattedSeries
bar o f = do
          f' <- toBar f
          return $ format o f'

hist :: (Ordinate a, BarFormat b) => a -> b -> FormattedSeries
hist o f = do
          f' <- toBar f
          setSeriesType'' Hist (format o f')

candle :: (Ordinate a, BarFormat b) => a -> b -> FormattedSeries
candle o f = do
          f' <- toBar f
          setSeriesType'' Candle (format o f')

whisker :: (Ordinate a, BarFormat b) => a -> b -> FormattedSeries
whisker o f = do
          f' <- toBar f
          setSeriesType'' Whisker (format o f')

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

getType :: SeriesType -> Data Decoration
getType Line = do
               c <- supply
               lt <- toLine (c :: Color)
               return $ toDecoration lt
getType Point = do
                g <- supply
                pt <- toPoint (g :: Glyph)
                return $ toDecoration pt
getType LinePoint = do
                    c <- supply
                    g <- supply
                    lt <- toLine (c :: Color)
                    pt <- toPoint (g :: Glyph)
                    return $ toDecoration (lt,pt)
getType Impulse = do
                  c <- supply
                  lt <- toLine (c :: Color)
                  setSeriesType'' Impulse $ toDecoration lt
getType Step = do
               c <- supply
               lt <- toLine (c :: Color)
               setSeriesType'' Impulse $ toDecoration lt
getType Area = do
               c <- supply
               lt <- toLine (c :: Color)
               setSeriesType'' Area $ toDecoration lt
getType Bar  = do
               c <- supply
               bt <- toBar (c :: Color)
               return $ toDecoration bt
getType Hist = do
               c <- supply
               bt <- toBar (c :: Color)
               setSeriesType'' Hist $ toDecoration bt
getType Candle = do
               c <- supply
               bt <- toBar (c :: Color)
               setSeriesType'' Candle $ toDecoration bt
getType Whisker = do
               c <- supply
               bt <- toBar (c :: Color)
               setSeriesType'' Whisker $ toDecoration bt

getNTypes :: Int -> SeriesType -> Data [Decoration]
getNTypes n st = mapM getType (replicate n st)

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

class Dataset a where
    toDataSeries :: a -> Data DataSeries

instance Dataset Surface where
    toDataSeries m = return $ DS_Surf m

instance (Ordinate a) => Dataset (SeriesType,[a]) where
    toDataSeries (Line,os) = do
                             let ln = length os
                             cs <- supplyN ln
                             ls <- mapM toLine (cs :: [Color])
                             return $ DS_Y $ A.listArray (1,ln) $ zipWith format os ls
    toDataSeries (Point,os) = do
                              let ln = length os
                              cs <- supplyN ln
                              gs <- supplyN ln
                              ps <- mapM toPoint (zip (gs :: [Glyph]) (cs :: [Color]))
                              return $ DS_Y $ A.listArray (1,ln) $ zipWith format os ps
    toDataSeries (LinePoint,os) = do
                              let ln = length os
                              cs <- supplyN ln
                              gs <- supplyN ln
                              ls <- mapM toLine cs
                              ps <- mapM toPoint (zip (gs :: [Glyph]) (cs :: [Color]))
                              let ds = toDecorations (zip ls ps)
                              return $ DS_Y $ A.listArray (1,ln) $ zipWith format os ds
    toDataSeries (Impulse,os) = do
                              let ln = length os
                              cs <- supplyN ln
                              ls <- mapM toLine (cs :: [Color])
                              ds <- mapM (setSeriesType'' Impulse) $ toDecorations ls
                              return $ DS_Y $ A.listArray (1,ln) $ zipWith format os ds
    toDataSeries (Step,os) = do
                             let ln = length os
                             cs <- supplyN ln
                             ls <- mapM toLine (cs :: [Color])
                             ds <- mapM (setSeriesType'' Step) $ toDecorations ls
                             return $ DS_Y $ A.listArray (1,ln) $ zipWith format os ds
    toDataSeries (Area,os) = do
                             let ln = length os
                             cs <- supplyN ln
                             ls <- mapM toLine (cs :: [Color])
                             ds <- mapM (setSeriesType'' Area) $ toDecorations ls
                             return $ DS_Y $ A.listArray (1,ln) $ zipWith format os ds
    toDataSeries (Bar,os) = do
                            let ln = length os
                            cs <- supplyN ln
                            bs <- mapM toBar (cs :: [Color])
                            return $ DS_Y $ A.listArray (1,ln) $ zipWith format os bs
    toDataSeries (Hist,os) = do
                            let ln = length os
                            cs <- supplyN ln
                            bs <- mapM toBar (cs :: [Color])
                            ds <- mapM (setSeriesType'' Hist) $ toDecorations bs
                            return $ DS_Y $ A.listArray (1,ln) $ zipWith format os ds
    toDataSeries (Candle,os) = do
                            let ln = length os
                            cs <- supplyN ln
                            bs <- mapM toBar (cs :: [Color])
                            ds <- mapM (setSeriesType'' Candle) $ toDecorations bs
                            return $ DS_Y $ A.listArray (1,ln) $ zipWith format os ds
    toDataSeries (Whisker,os) = do
                            let ln = length os
                            cs <- supplyN ln
                            bs <- mapM toBar (cs :: [Color])
                            ds <- mapM (setSeriesType'' Whisker) $ toDecorations bs
                            return $ DS_Y $ A.listArray (1,ln) $ zipWith format os ds

instance (Abscissa a, Ordinate b) => Dataset (SeriesType,a,[b]) where
    toDataSeries (Line,t,os) = do
                               let ln = length os
                               cs <- supplyN ln
                               ls <- mapM toLine (cs :: [Color])
                               return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
                                        $ zipWith format os ls
    toDataSeries (Point,t,os) = do
                                let ln = length os
                                cs <- supplyN ln
                                gs <- supplyN ln
                                ps <- mapM toPoint (zip (gs :: [Glyph]) (cs :: [Color]))
                                return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
                                        $ zipWith format os ps
    toDataSeries (LinePoint,t,os) = do
                                let ln = length os
                                cs <- supplyN ln
                                gs <- supplyN ln
                                ls <- mapM toLine cs
                                ps <- mapM toPoint (zip (gs :: [Glyph]) (cs :: [Color]))
                                let ds = toDecorations (zip ls ps)
                                return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
                                        $ zipWith format os ds
    toDataSeries (Impulse,t,os) = do
                              let ln = length os
                              cs <- supplyN ln
                              ls <- mapM toLine (cs :: [Color])
                              ds <- mapM (setSeriesType'' Impulse) $ toDecorations ls
                              return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
                                         $ zipWith format os ds
    toDataSeries (Step,t,os) = do
                              let ln = length os
                              cs <- supplyN ln
                              ls <- mapM toLine (cs :: [Color])
                              ds <- mapM (setSeriesType'' Step) $ toDecorations ls
                              return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
                                         $ zipWith format os ds
    toDataSeries (Area,t,os) = do
                              let ln = length os
                              cs <- supplyN ln
                              ls <- mapM toLine (cs :: [Color])
                              ds <- mapM (setSeriesType'' Area) $ toDecorations ls
                              return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
                                         $ zipWith format os ds
    toDataSeries (Bar,t,os) = do
                              let ln = length os
                              cs <- supplyN ln
                              bs <- mapM toBar (cs :: [Color])
                              return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
                                         $ zipWith format os bs
    toDataSeries (Hist,t,os) = do
                              let ln = length os
                              cs <- supplyN ln
                              bs <- mapM toBar (cs :: [Color])
                              ds <- mapM (setSeriesType'' Hist) $ toDecorations bs
                              return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
                                         $ zipWith format os ds
    toDataSeries (Candle,t,os) = do
                              let ln = length os
                              cs <- supplyN ln
                              bs <- mapM toBar (cs :: [Color])
                              ds <- mapM (setSeriesType'' Candle) $ toDecorations bs
                              return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
                                         $ zipWith format os ds
    toDataSeries (Whisker,t,os) = do
                              let ln = length os
                              cs <- supplyN ln
                              bs <- mapM toBar (cs :: [Color])
                              ds <- mapM (setSeriesType'' Whisker) $ toDecorations bs
                              return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
                                         $ zipWith format os ds

instance (Abscissa a, Ordinate b) => Dataset [(SeriesType,a,b)] where
    toDataSeries prs = do
                       let ln = length prs
                           (ss,xs,ys) = unzip3 prs
                       ds <- mapM toDataSeries' $ zip ss ys
                       return $ DS_1to1 $ A.listArray (1,ln) $ zip (toAbscissae xs) ds

toDataSeries' :: Ordinate b => (SeriesType,b) -> Data DecoratedSeries
toDataSeries' (Line,o) = do
                         c <- supply
                         l <- toLine (c :: Color)
                         return $ format o l
toDataSeries' (Point,o) = do
                          c <- supply
                          g <- supply
                          p <- toPoint ((g :: Glyph),(c :: Color))
                          return $ format o p
toDataSeries' (LinePoint,o) = do
                          c <- supply
                          g <- supply
                          l <- toLine (c :: Color)
                          p <- toPoint ((g :: Glyph),(c :: Color))
                          let d = toDecoration (l,p)
                          return $ format o d
toDataSeries' (Impulse,o) = do
                         c <- supply
                         l <- toLine (c :: Color)
                         d <- setSeriesType'' Impulse $ toDecoration l
                         return $ format o d
toDataSeries' (Step,o) = do
                         c <- supply
                         l <- toLine (c :: Color)
                         d <- setSeriesType'' Step $ toDecoration l
                         return $ format o d
toDataSeries' (Area,o) = do
                         c <- supply
                         l <- toLine (c :: Color)
                         d <- setSeriesType'' Area $ toDecoration l
                         return $ format o d
toDataSeries' (Bar,o)  = do
                         c <- supply
                         b <- toBar (c :: Color)
                         return $ format o b
toDataSeries' (Hist,o)  = do
                         c <- supply
                         b <- toBar (c :: Color)
                         d <- setSeriesType'' Hist $ toDecoration b
                         return $ format o d
toDataSeries' (Candle,o)  = do
                         c <- supply
                         b <- toBar (c :: Color)
                         d <- setSeriesType'' Candle $ toDecoration b
                         return $ format o d
toDataSeries' (Whisker,o)  = do
                         c <- supply
                         b <- toBar (c :: Color)
                         d <- setSeriesType'' Whisker $ toDecoration b
                         return $ format o d

instance Dataset [FormattedSeries] where
    toDataSeries ds = do
                      let ln = length ds
                      ds' <- sequence ds
                      return $ DS_Y $ A.listArray (1,ln) ds'

instance (Abscissa a) => Dataset (a,[FormattedSeries]) where
    toDataSeries (t,prs) = do
                           let ln = length prs
                           prs' <- sequence prs
                           return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln) prs'

instance (Abscissa a) => Dataset [(a,FormattedSeries)] where
    toDataSeries prs = do
                       let ln = length prs
                           (xs,ys) = unzip prs
                       ys' <- sequence ys
                       return $ DS_1to1 $ A.listArray (1,ln) (zip (toAbscissae xs) ys')

-- | set the data set
setDataSeries :: Dataset a => a -> Data ()
setDataSeries d = do
                  ds <- toDataSeries d
                  put ds

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

monoStep :: Double -> MaybeT (State Double) ()
monoStep d = do
             dp <- get
             when (d < dp) (fail "negative difference")
             put d
{-# INLINE monoStep #-}

isMonotoneIncreasing :: Vector Double -> Bool
isMonotoneIncreasing v = maybe False (\_ -> True) $ evalState (runMaybeT $ (mapVectorM_ monoStep (subVector 1 (size v -1) v))) (v `atIndex` 0)

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


{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}
module Amby.Plot
  ( getEC
  , getRenderable
  , save
  , saveSvg

  , cairoDefSave
  , diagramsDefSave
  ) where

import Control.Arrow
import Control.Monad
import Control.Monad.State
import qualified Data.List as L
import qualified Data.Maybe as Maybe
import Data.Tuple (swap)
import qualified Data.Vector.Generic as G
import qualified Data.Vector as V
import qualified Data.Vector.Unboxed as U

import Control.Lens
import Data.Colour as Colour
import Data.Default.Class
import Graphics.Rendering.Chart.Easy (Layout, EC, Renderable, LayoutPick)
import qualified Graphics.Rendering.Chart.Easy as Chart
import qualified Graphics.Rendering.Chart.Backend.Cairo as Cairo
import qualified Graphics.Rendering.Chart.Backend.Diagrams as Diagrams
import Safe (maximumMay)
import qualified Statistics.Sample.KernelDensity.Simple as Stats
import qualified Statistics.Sample as Stats

import Amby.BoxPlot
import Amby.Compatibility.HistogramPlot
import Amby.FactorPlot
import Amby.Numeric
import Amby.Theme (toColour)
import Amby.Types

--------------------------
-- Instance declarations
--------------------------

instance AmbyContainer (V.Vector Double) where
  type Value (V.Vector Double) = Double

  plot = plotVec
  plot' = plotVec'
  plotEq = plotEqVec
  plotEq' = plotEqVec'
  distPlot = distPlotVec
  distPlot' = distPlotVec'
  kdePlot = kdePlotVec
  kdePlot' = kdePlotVec'
  rugPlot = rugPlotVec
  rugPlot' = rugPlotVec'
  boxPlot = boxPlotVec
  boxPlot' = boxPlotVec'
  factorPlot = factorPlotVec

instance AmbyContainer (U.Vector Double) where
  type Value (U.Vector Double) = Double

  plot = plotVec
  plot' = plotVec'
  plotEq = plotEqVec
  plotEq' = plotEqVec'
  distPlot = distPlotVec
  distPlot' = distPlotVec'
  kdePlot = kdePlotVec
  kdePlot' = kdePlotVec'
  rugPlot = rugPlotVec
  rugPlot' = rugPlotVec'
  boxPlot = boxPlotVec
  boxPlot' = boxPlotVec'
  factorPlot v = factorPlotVec (G.convert v)

instance (Real a) => AmbyContainer [a] where
  type Value [a] = a

  plot x y optsState = plotList vals opts
    where
      opts = execState optsState def
      vals = L.zipWith realToTuple x y
  plot' x y = plot x y $ return ()

  plotEq x fn optsState = plotList vals $ def
      & color .~ (opts ^. color)
    where
      opts = execState optsState def
      vals = L.zipWith realToTuple x $ map fn x
  plotEq' x fn = plotEq x fn $ return ()

  distPlot xs optsState = distPlotVec (realToVec xs) optsState
  distPlot' xs = distPlot xs $ return ()

  kdePlot xs optsState = kdePlotVec (realToVec xs) optsState
  kdePlot' xs = kdePlot xs $ return ()

  rugPlot xs optsState = rugPlotVec (realToVec xs) optsState
  rugPlot' xs = rugPlot xs $ return ()

  boxPlot xs optsState = boxPlotVec (realToVec xs) optsState
  boxPlot' xs = boxPlot xs $ return ()

  factorPlot xs optsState = factorPlotVec (realToVec xs) optsState

realToVec :: (Real a) => [a] -> V.Vector Double
realToVec = V.map realToFrac . V.fromList

realToTuple :: Real a => a -> a -> (Double, Double)
realToTuple a b = (realToFrac a, realToFrac b)

--------------------------
-- Generic vec plotters
--------------------------

plotVec :: (G.Vector v Double, G.Vector v (Double, Double))
        => v Double -> v Double -> State PlotOpts () -> AmbyChart ()
plotVec x y optsState = plotList vals opts
  where
    opts = execState optsState def
    vals = G.toList $ G.zip x y

plotVec' :: (G.Vector v Double, G.Vector v (Double, Double))
         => v Double -> v Double -> AmbyChart ()
plotVec' x y = plotVec x y $ return ()

plotEqVec :: (G.Vector v Double, G.Vector v (Double, Double))
          => v Double -> (Double -> Double) -> State PlotEqOpts ()
          -> AmbyChart ()
plotEqVec x fn optsState = plotList vals $ def
    & color .~ (opts ^. color)
  where
    opts = execState optsState def
    vals = G.toList $ G.zip x (G.map fn x)

plotEqVec' :: (G.Vector v Double, G.Vector v (Double, Double))
           => v Double -> (Double -> Double) -> AmbyChart ()
plotEqVec' x fn = plotEqVec x fn $ return ()

distPlotVec :: (G.Vector v Double, G.Vector v (Double, Double))
            => v Double -> State DistPlotOpts ()
            -> AmbyChart ()
distPlotVec xs optsState = plotDistribution xs $ execState optsState def

distPlotVec' :: (G.Vector v Double, G.Vector v (Double, Double))
             => v Double -> AmbyChart ()
distPlotVec' xs = distPlotVec xs $ return ()

kdePlotVec :: (G.Vector v Double) => v Double -> State KdePlotOpts ()
           -> AmbyChart ()
kdePlotVec xs optsState = do
    layout <- takeLayout
    putLayout $ do
      layout
      nextColor <- toColour (opts ^. color) <$> Chart.takeColor
      plotKde nextColor xs opts
  where
    opts = execState optsState def

kdePlotVec' :: (G.Vector v Double) => v Double -> AmbyChart ()
kdePlotVec' xs = kdePlotVec xs $ return ()

rugPlotVec :: (G.Vector v Double, G.Vector v (Double, Double))
           => v Double -> State RugPlotOpts ()
           -> AmbyChart ()
rugPlotVec xs optsState = do
    layout <- takeLayout
    putLayout $ do
      layout
      nextColor <- toColour (opts ^. color) <$> Chart.takeColor
      plotRug nextColor xs opts
  where
    opts = execState optsState def

rugPlotVec' :: (G.Vector v Double, G.Vector v (Double, Double))
            => v Double -> AmbyChart ()
rugPlotVec' xs = rugPlotVec xs $ return ()

--------------------------
-- Generic plotters
--------------------------

plotDistribution :: (G.Vector v Double, G.Vector v (Double, Double))
                 => v Double -> DistPlotOpts -> AmbyChart ()
plotDistribution xs opts = do
    layout <- takeLayout
    putLayout $ do
      layout
      nextColor <- toColour (opts ^. color) <$> Chart.takeColor
      when (opts ^. hist) $ plotHist opts nextColor numBins xs
      when (opts ^. kde) $ plotKde nextColor xs $ def
        & bw .~ (opts ^. bw)
        & shade .~ (opts ^. shade)
        & gridsize .~ (opts ^. gridsize)
        & axis .~ (opts ^. axis)
        & linewidth .~ (opts ^. kdeLinewidth)
        & cut .~ (opts ^. cut)
      when (opts ^. rug) $ plotRug nextColor xs $ def
        & height .~ (opts ^. rugHeight)
        & axis .~ (opts ^. axis)
        & linewidth .~ (opts ^. rugLinewidth)
  where
    numBins = if opts ^. bins /= 0
      then opts ^. bins
      else min 50 $ freedmanDiaconisBins xs

plotList :: [(Double, Double)] -> PlotOpts -> AmbyChart ()
plotList xs opts = do
    layout <- takeLayout
    putLayout $ do
      layout
      nextColor <- toColour (opts ^. color) <$> Chart.takeColor
      plotLine nextColor (opts ^. linewidth) xs

--------------------------
-- Composable plotters
--------------------------

plotHist :: (G.Vector v Double) => DistPlotOpts -> AlphaColour Double -> Int -> v Double
         -> EC (Layout Double Double) ()
plotHist opts c numBins xs =
  Chart.plot $ fmap histToPlot $ Chart.liftEC $ do
    plot_hist_bins .= numBins
    plot_hist_drop_lines .= True
    plot_hist_values .= G.toList xs
    plot_hist_line_style . Chart.line_width .= (opts ^. histLinewidth)
    plot_hist_line_style . Chart.line_color .= Colour.dissolve 0.5 c
    plot_hist_fill_style . Chart.fill_color .= Colour.dissolve 0.4 c
    plot_hist_vertical .= (opts ^. axis == YAxis)

plotRug :: forall v. (G.Vector v Double, G.Vector v (Double, Double))
        => AlphaColour Double -> v Double -> RugPlotOpts
        -> EC (Layout Double Double) ()
plotRug c xs opts = do
      maxMay <- getPlotMaxHeightMay
      h <- calcRugHeight maxMay
      Chart.plot $ return $ Chart.Plot
        { Chart._plot_render = renderPlotRug h
        , Chart._plot_legend = [("", const $ return ())]
        , Chart._plot_all_points = join (***) G.toList
          $ G.unzip
          $ G.concatMap (toPoints h) xs
        }
      updatePlotHeight maxMay
    where
      getPlotMaxHeightMay :: EC (Layout Double Double) (Maybe Double)
      getPlotMaxHeightMay = do
        layout <- get
        layout ^.. Chart.layout_plots . each . Chart.plot_all_points
          & concatMap (if opts ^. axis == XAxis then snd else fst)
          & maximumMay
          & return

      toPoints :: Double -> Double -> v (Double, Double)
      toPoints h x = if opts ^. axis == XAxis
        then G.fromList [(x, 0), (x, h)]
        else G.fromList [(0, x), (h, x)]

      calcRugHeight :: (Maybe Double) -> EC (Layout Double Double) Double
      calcRugHeight maxMay =
        return $ (Maybe.fromMaybe 1.0 maxMay) * (opts ^. height)

      renderPlotRug :: Double -> Chart.PointMapFn Double Double
                    -> BackendProgram ()
      renderPlotRug h pmap =
        Chart.withLineStyle lineStyle $ do
          Chart.alignStrokePath (plotPath h pmap) >>= Chart.strokePath
        where
          lineStyle = def
            & Chart.line_width .~ (opts ^. linewidth)
            & Chart.line_color .~ c

      plotPath :: Double -> Chart.PointMapFn Double Double -> Chart.Path
      plotPath h pmap =
          go (G.toList xs)
        where
          go [] = Chart.End
          go [b] = Chart.MoveTo (pt b 0) $ Chart.LineTo (pt b h) $ Chart.End
          go (b:rest) = Chart.MoveTo (pt b 0) $ Chart.LineTo (pt b h) $ go rest
          pt x y = pmap (Chart.LValue x, Chart.LValue y)

      updatePlotHeight :: (Maybe Double)
                       -> EC (Layout Double Double) ()
      updatePlotHeight maxMay = do
        layout2 <- get
        layout2 & Chart.layout_plots . mapped . Chart.plot_all_points
          %~ updatePlotPoints maxMay
          & put

      updatePlotPoints :: (Maybe Double) -> ([Double], [Double])
                       -> ([Double], [Double])
      updatePlotPoints maxMay (as, bs) =
        if | maxMay == Nothing && opts ^. axis == XAxis -> (0.0:as, 1.0:bs)
           | maxMay == Nothing && opts ^. axis == YAxis -> (1.0:as, 0.0:bs)
           | otherwise -> (as, bs)

plotKde :: (G.Vector v Double) => AlphaColour Double -> v Double -> KdePlotOpts
        -> EC (Layout Double Double) ()
plotKde c xs opts = do
    plotLine c (opts ^. linewidth) kdeVals
    when (opts ^. shade) $ plotShade c kdeVals
  where
    minX = G.minimum xs
    maxX = G.maximum xs
    iqr = interquartileRange xs
    std = Stats.stdDev xs
    n = fromIntegral $ G.length xs
    a = min std (iqr / 1.34)
    bandwidth = if | opts ^. bw == Scott -> 1.059 * a * n ** ((-1) / 5)
                   | (BwScalar b) <- opts ^. bw -> b
    clipLeft = minX - (opts ^. cut) * bandwidth
    clipRight = maxX + (opts ^. cut) * bandwidth
    sizeEstimate = fromIntegral $ opts ^. gridsize :: Double
    numEstimates = 2 ^ (ceiling (log sizeEstimate / log 2) :: Int)
    xVals = Stats.Points $ linspace clipLeft clipRight numEstimates
    kdeResult = Stats.estimatePDF Stats.gaussianKernel bandwidth xs xVals
    kdeVals' = U.zip (Stats.fromPoints xVals) kdeResult
    kdeVals = if opts ^. axis == YAxis
      then U.toList $ U.map swap kdeVals'
      else U.toList kdeVals'

plotLine :: AlphaColour Double -> Double -> [(Double, Double)]
         -> EC (Layout Double Double) ()
plotLine c lineWidth xs = Chart.plot $ Chart.liftEC $ do
  Chart.plot_lines_values .= [xs]
  Chart.plot_lines_style . Chart.line_width .= lineWidth
  Chart.plot_lines_style . Chart.line_color .= c

plotShade :: AlphaColour Double -> [(Double, Double)]
          -> EC (Layout Double Double) ()
plotShade c xs = Chart.plot $ Chart.liftEC $ do
  Chart.plot_fillbetween_values .= (xs & mapped . _2 %~ \y -> (0, y))
  Chart.plot_fillbetween_style .= Chart.solidFillStyle (Colour.dissolve 0.25 c)

--------------------------
-- Rendering
--------------------------

-- | Default save filename for Cairo.
cairoDefSave :: FilePath
cairoDefSave = ".__amby.png"

-- | Default save filename for Diagrams.
diagramsDefSave :: FilePath
diagramsDefSave = ".__amby.svg"

-- | Convert 'AmbyChart' into Chart's 'EC (Layout Double Double) ()'.
getEC :: AmbyChart () -> EC (Layout Double Double) ()
getEC compute = getLayout $ execState compute def

-- | Convert 'AmbyGrid' into Chart's 'Renderable a'.
getRenderable :: Saveable s => s -> Renderable (LayoutPick Double Double Double)
getRenderable ch = getSaveObjectRenderable (toSaveObject ch)

-- Short-hand to render to png file using Cairo backend.
save :: Saveable s => s -> IO ()
save chart = void $ Cairo.renderableToFile
    def { Cairo._fo_size = newSize }
    cairoDefSave
    (getSaveObjectRenderable so)
  where
    so = toSaveObject chart
    newSize = getSize so

-- | Short-hand to render to svg using Cairo backend
saveSvg :: Saveable s => s -> IO ()
saveSvg chart = void $ Diagrams.renderableToFile
    def { Diagrams._fo_size = join (***) fromIntegral newSize }
    diagramsDefSave
    (getSaveObjectRenderable so)
  where
    so = toSaveObject chart
    newSize = getSize so


{-# LANGUAGE CPP              #-}
{-# LANGUAGE DataKinds        #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs            #-}
{-# LANGUAGE TemplateHaskell  #-}
{-# LANGUAGE TypeOperators    #-}

module Test.Grenade.Sys.Networks where

import qualified Numeric.LinearAlgebra        as LA
import qualified Numeric.LinearAlgebra.Data   as D
import           Numeric.LinearAlgebra.Static (L)
import qualified Numeric.LinearAlgebra.Static as H

import           Hedgehog

import           Test.Grenade.Sys.Utils
import           Test.Hedgehog.Compat

import           Data.List
import           Data.Maybe
import           Data.Function
import           Data.Either
import           System.FilePath

import           Grenade
import           Grenade.Utils.PascalVoc

-- Checks that the differences in the reference and the output from the network are "acceptable". Due to floating
-- point errors, using doubles instead of floats, etc. the outputs can be not precisely the same. We check that
-- each box given by the reference output has a corresponding box in ours which roughly overlaps with it, detects
-- the same object, with approximately the same confidence, and vice versa for our output compared to the reference.
yoloAcceptableDifference :: [(Int, Int, Int, Int, Double, String)] -> [(Int, Int, Int, Int, Double, String)] -> Bool
yoloAcceptableDifference ref out = all (isJust . (searchForMatch out)) ref && all (isJust . (searchForMatch ref)) out
  where
    searchForMatch searchSpace (li, ri, ti, bi, p, x)
      | null matches = Nothing
      | otherwise    = Just $ head matches
      where
        -- Find all entries with the same name
        sameName = filter (\(_, _, _, _, _, x') -> x == x') searchSpace
        -- Find entries with sufficient overlap
        overlap = \(li', ri', ti', bi', _, _) -> sufficientOverlap (li, ri, ti, bi) (li', ri', ti', bi')
        overlapping = filter overlap sameName
        -- Finally, ensure that the probabilities are within a threshold
        matches = filter (\(_, _, _, _, p', _) -> abs p - p' <= 0.1) overlapping

    sufficientOverlap (li, ri, ti, bi) (li', ri', ti', bi') = overlap >= 0.6
      where
        (l, r, t, b) = (fromIntegral li, fromIntegral ri, fromIntegral ti, fromIntegral bi)
        (l', r', t', b') = (fromIntegral li', fromIntegral ri', fromIntegral ti', fromIntegral bi')
        xOverlap = maximum [ 0, minimum [r, r'] - maximum [l, l'] ]
        yOverlap = maximum [ 0, minimum [b, b'] - maximum [t, t'] ]
        overlap1 = (xOverlap * yOverlap) / ((r - l) * (b - t))
        overlap2 = (xOverlap * yOverlap) / ((r' - l') * (b' - t'))
        -- Get the least overlap, to avoid the case where a very large/small
        -- and incorrect bounding box output is treated as being correct
        overlap = minimum [overlap1, overlap2] :: Double

-- Test that the bundled TinyYOLOv2 network, stored as an ONNX file
-- loads correctly and gives expected output when given a test image
prop_yolo_loads_and_finds_objects :: Property
prop_yolo_loads_and_finds_objects = withTests 1 $ property $ do
  img <- evalIO (loadSerializedImage (imagesDir </> "person") :: IO (Maybe (S ('D3 416 416 3))))
  netPath <- evalIO $ getPathForNetwork TinyYoloV2
  net     <- evalIO $ loadTinyYoloV2 netPath

  assert $ isJust img
  assert $ isRight net

  let Just img'  = img
      Right net' = net
      probs = processOutput (runNet net' img') 0.3 2.0
      -- Values taken from running the TinyYolov2 network bundled
      -- with grenade through the ONNX inference runtime Python
      -- module
      reference = [ (75, 163, 97, 371,   0.7742048036087853, "person")
                  , (2, 86, 262, 354,    0.7187669842556927, "sheep" )
                  , (283, 409, 151, 335, 0.6768828930128936, "sheep" )
                  , (305, 410, 155, 323, 0.5562674827033209, "sheep" ) ]
  assert $ yoloAcceptableDifference reference probs

-- Test that the bundled ResNet-18 network, stored as an ONNX file,
-- loads correctly and gives expected output when given a test image
prop_resnet_loads_and_finds_objects :: Property
prop_resnet_loads_and_finds_objects = withTests 1 $ property $ do
  img <- evalIO (loadSerializedImage (imagesDir </> "dog") :: IO (Maybe (S ('D3 224 224 3))))
  netPath <- evalIO $ getPathForNetwork ResNet18
  net     <- evalIO $ loadResNet netPath

  assert $ isJust img
  assert $ isRight net

  let Just img'  = img
      Right net' = net
      S1D y = runNet net' img'
      tops  = getTop 5 $ LA.toList $ H.extract y
  tops === [162,166,167,215,164] -- beagle, Walker hound, English foxhound, Brittany spaniel, bluetick
  where
    getTop :: Ord a => Int -> [a] -> [Int]
    getTop n xs = map fst $ take n $ sortBy (flip compare `on` snd) $ zip [0..] xs

prop_superresolution_loads_and_upsamples :: Property
prop_superresolution_loads_and_upsamples = withTests 1 $ property $ do
  imgY0 <- evalIO (loadSerializedChannel (imagesDir </> "cheetah_Y0") :: IO (Maybe (S ('D3 224 224 1))))
  netPath <- evalIO $ getPathForNetwork SuperResolution
  net     <- evalIO $ loadSuperResolution netPath

  assert $ isJust imgY0
  assert $ isRight net

  let Just input = imgY0
      Right net' = net
      (S3D input') = input
      (S3D v)      = runNet net' input :: S ('D3 672 672 1)
      down         = downsample v
      diffs        = zipWith (\x y -> abs (x - y)) (concat $ D.toLists $ H.extract down) (concat $ D.toLists $ H.extract input')
      avgDiff      = (sum diffs) / (224 * 224)
  isWithinOf 0.01 avgDiff 0
  where
    downsample :: L 672 672 -> L 224 224
    downsample mat = H.build builder
      where
        mat' = H.extract mat
        builder i j = (sum vals) / 9
          where
            ro = (floor i) * 3
            co = (floor j) * 3
            vals = [mat' `D.atIndex` (ro', co') | ro' <- [ro..ro + 2], co' <- [co..co + 2]]

tests :: IO Bool
tests = checkParallel $$(discover)


module Imports where

import           Control.Applicative
import           Control.Arrow
import           Control.Monad
import           Control.Monad.Cont
import           Control.Monad.Fix
import           Control.Monad.Identity
import           Control.Monad.RWS
import           Control.Monad.Reader
import           Control.Monad.State
import           Control.Monad.Writer
import           Data.Bits
import           Data.Bool
import           Data.Char
import           Data.Complex
import           Data.Dynamic
import           Data.Either
import           Data.Eq
import           Data.Fixed
import           Data.Function
import           Data.Graph
import           Data.Int
import           Data.Ix
import           Data.List
import qualified Data.Map as M
import           Data.Maybe
import           Data.Monoid
import           Data.Ord
import           Data.Ratio
import           Data.Tree
import           Data.Tuple
import           Data.Typeable
import           Data.Word
import           Prelude hiding (IO,putStr,putStrLn,getLine,readLn,print,readIO,readFile,writeFile,appendFile)
import           PureIO as IO
import           ShowFun
import           Test.QuickCheck
import           Text.Printf

-- | Run the given command and then show the output. This constraint
-- is to aid communication between mueval and tryhaskell.
runTryHaskellIO :: (Read b,Show b)
                => ([String],[(FilePath,String)])
                -> IO b
                -> Either (Interrupt,([String],[(FilePath,String)]))
                          (String,([String],[(FilePath,String)]))
runTryHaskellIO (is,fs) m =
  case runIO (Input is (M.fromList fs)) m of
    (Left i,out) -> Left (i,convert out)
    (Right r,out) -> Right (show r,convert out)
  where convert (Output os fs) = (os,M.toList fs)