{-# LANGUAGE TemplateHaskell, FlexibleInstances #-}
module Graphics.Rendering.Chart.State(
  plot,
  plotLeft,
  plotRight,

  takeColor,
  takeShape,

  CState,
  colors,
  shapes,

  EC,
  execEC,
  liftEC,
  liftCState,
  ) where

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

import Data.Colour
import Data.Colour.Names

import Graphics.Rendering.Chart.Layout
import Graphics.Rendering.Chart.Plot
import Graphics.Rendering.Chart.Drawing
import Graphics.Rendering.Chart.Renderable

-- | The state held when monadically constructing a graphical element
data CState = CState {
  CState -> [AlphaColour Double]
_colors :: [AlphaColour Double], -- ^ An infinite source of colors, for use in plots
  CState -> [PointShape]
_shapes :: [PointShape]          -- ^ An infinite source of shapes, for use in plots
  }

$( makeLenses ''CState )

-- | We use nested State monads to give nice syntax. The outer state
-- is the graphical element being constructed (typically a
-- layout). The inner state contains any additional state
-- reqired. This approach means that lenses and the state monad lens
-- operators can be used directly on the value being constructed.
type EC l a = StateT l (State CState) a

instance Default CState where
  def :: CState
def = [AlphaColour Double] -> [PointShape] -> CState
CState [AlphaColour Double]
defColors [PointShape]
defShapes
    where
      defColors :: [AlphaColour Double]
defColors = forall a. [a] -> [a]
cycle (forall a b. (a -> b) -> [a] -> [b]
map forall a. Num a => Colour a -> AlphaColour a
opaque [forall a. (Ord a, Floating a) => Colour a
blue,forall a. (Ord a, Floating a) => Colour a
green,forall a. (Ord a, Floating a) => Colour a
red,forall a. (Ord a, Floating a) => Colour a
orange,forall a. (Ord a, Floating a) => Colour a
yellow,forall a. (Ord a, Floating a) => Colour a
violet])
      defShapes :: [PointShape]
defShapes = forall a. [a] -> [a]
cycle [PointShape
PointShapeCircle,PointShape
PointShapePlus,PointShape
PointShapeCross,PointShape
PointShapeStar]

instance (Default a,ToRenderable a) => ToRenderable (EC a b) where
  toRenderable :: EC a b -> Renderable ()
toRenderable = forall a. ToRenderable a => a -> Renderable ()
toRenderable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l a. Default l => EC l a -> l
execEC
      
-- | Run the monadic `EC` computation, and return the graphical
-- element (ie the outer monad' state)
execEC :: (Default l) => EC l a -> l
execEC :: forall l a. Default l => EC l a -> l
execEC EC l a
ec = forall s a. State s a -> s -> a
evalState (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT EC l a
ec forall a. Default a => a
def) forall a. Default a => a
def

-- | Nest the construction of a graphical element within
-- the construction of another.
liftEC :: (Default l1) => EC l1 a -> EC l2 l1
liftEC :: forall l1 a l2. Default l1 => EC l1 a -> EC l2 l1
liftEC EC l1 a
ec = do
  CState
cs <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall s (m :: * -> *). MonadState s m => m s
get
  let (l1
l,CState
cs') = forall s a. State s a -> s -> (a, s)
runState (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT EC l1 a
ec forall a. Default a => a
def) CState
cs
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall s (m :: * -> *). MonadState s m => s -> m ()
put CState
cs')
  forall (m :: * -> *) a. Monad m => a -> m a
return l1
l

-- | Lift a a computation over `CState`
liftCState :: State CState a -> EC l a
liftCState :: forall a l. State CState a -> EC l a
liftCState = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | Add a plot to the `Layout` being constructed.
plot :: (ToPlot p) => EC (Layout x y) (p x y) -> EC (Layout x y) ()
plot :: forall (p :: * -> * -> *) x y.
ToPlot p =>
EC (Layout x y) (p x y) -> EC (Layout x y) ()
plot EC (Layout x y) (p x y)
pm = do
    p x y
p <- EC (Layout x y) (p x y)
pm
    forall x y. Lens' (Layout x y) [Plot x y]
layout_plots forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (forall a. [a] -> [a] -> [a]
++[forall (a :: * -> * -> *) x y. ToPlot a => a x y -> Plot x y
toPlot p x y
p])

-- | Add a plot against the left axis to the `LayoutLR` being constructed.
plotLeft :: (ToPlot p) => EC (LayoutLR x y1 y2) (p x y1) -> EC (LayoutLR x y1 y2) ()
plotLeft :: forall (p :: * -> * -> *) x y1 y2.
ToPlot p =>
EC (LayoutLR x y1 y2) (p x y1) -> EC (LayoutLR x y1 y2) ()
plotLeft EC (LayoutLR x y1 y2) (p x y1)
pm = do
  p x y1
p <- EC (LayoutLR x y1 y2) (p x y1)
pm
  forall x y1 y2.
Lens' (LayoutLR x y1 y2) [Either (Plot x y1) (Plot x y2)]
layoutlr_plots forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (forall a. [a] -> [a] -> [a]
++[forall a b. a -> Either a b
Left (forall (a :: * -> * -> *) x y. ToPlot a => a x y -> Plot x y
toPlot p x y1
p)])

-- | Add a plot against the right axis tof the `LayoutLR` being constructed.
plotRight :: (ToPlot p) => EC (LayoutLR x y1 y2) (p x y2) -> EC (LayoutLR x y1 y2) ()
plotRight :: forall (p :: * -> * -> *) x y1 y2.
ToPlot p =>
EC (LayoutLR x y1 y2) (p x y2) -> EC (LayoutLR x y1 y2) ()
plotRight EC (LayoutLR x y1 y2) (p x y2)
pm = do
  p x y2
p <- EC (LayoutLR x y1 y2) (p x y2)
pm
  forall x y1 y2.
Lens' (LayoutLR x y1 y2) [Either (Plot x y1) (Plot x y2)]
layoutlr_plots forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (forall a. [a] -> [a] -> [a]
++[forall a b. b -> Either a b
Right (forall (a :: * -> * -> *) x y. ToPlot a => a x y -> Plot x y
toPlot p x y2
p)])

-- | Pop and return the next color from the state
takeColor :: EC l (AlphaColour Double)
takeColor :: forall l. EC l (AlphaColour Double)
takeColor = forall a l. State CState a -> EC l a
liftCState forall a b. (a -> b) -> a -> b
$ do
  (AlphaColour Double
c,[AlphaColour Double]
cs) <- forall a. [a] -> (a, [a])
fromInfiniteList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' CState [AlphaColour Double]
colors
  Lens' CState [AlphaColour Double]
colors forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= [AlphaColour Double]
cs
  forall (m :: * -> *) a. Monad m => a -> m a
return AlphaColour Double
c

-- | Pop and return the next shape from the state
takeShape :: EC l PointShape
takeShape :: forall l. EC l PointShape
takeShape = forall a l. State CState a -> EC l a
liftCState forall a b. (a -> b) -> a -> b
$ do
  (PointShape
c,[PointShape]
cs) <- forall a. [a] -> (a, [a])
fromInfiniteList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' CState [PointShape]
shapes
  Lens' CState [PointShape]
shapes forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= [PointShape]
cs
  forall (m :: * -> *) a. Monad m => a -> m a
return PointShape
c

fromInfiniteList :: [a] -> (a, [a])
fromInfiniteList :: forall a. [a] -> (a, [a])
fromInfiniteList []     = forall a. HasCallStack => [Char] -> a
error [Char]
"fromInfiniteList (takeColor or takeShape): empty list"
fromInfiniteList (a
x:[a]
xs) = (a
x, [a]
xs)