{-# 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 = [AlphaColour Double] -> [AlphaColour Double]
forall a. [a] -> [a]
cycle ((Colour Double -> AlphaColour Double)
-> [Colour Double] -> [AlphaColour Double]
forall a b. (a -> b) -> [a] -> [b]
map Colour Double -> AlphaColour Double
forall a. Num a => Colour a -> AlphaColour a
opaque [Colour Double
forall a. (Ord a, Floating a) => Colour a
blue,Colour Double
forall a. (Ord a, Floating a) => Colour a
green,Colour Double
forall a. (Ord a, Floating a) => Colour a
red,Colour Double
forall a. (Ord a, Floating a) => Colour a
orange,Colour Double
forall a. (Ord a, Floating a) => Colour a
yellow,Colour Double
forall a. (Ord a, Floating a) => Colour a
violet])
      defShapes :: [PointShape]
defShapes = [PointShape] -> [PointShape]
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 = a -> Renderable ()
forall a. ToRenderable a => a -> Renderable ()
toRenderable (a -> Renderable ()) -> (EC a b -> a) -> EC a b -> Renderable ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EC a b -> a
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 :: EC l a -> l
execEC EC l a
ec = State CState l -> CState -> l
forall s a. State s a -> s -> a
evalState (EC l a -> l -> State CState l
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT EC l a
ec l
forall a. Default a => a
def) CState
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 :: EC l1 a -> EC l2 l1
liftEC EC l1 a
ec = do
  CState
cs <- State CState CState -> StateT l2 (State CState) CState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift State CState CState
forall s (m :: * -> *). MonadState s m => m s
get
  let (l1
l,CState
cs') = State CState l1 -> CState -> (l1, CState)
forall s a. State s a -> s -> (a, s)
runState (EC l1 a -> l1 -> State CState l1
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT EC l1 a
ec l1
forall a. Default a => a
def) CState
cs
  State CState () -> StateT l2 (State CState) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (CState -> State CState ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put CState
cs')
  l1 -> EC l2 l1
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 :: State CState a -> EC l a
liftCState = State CState a -> EC l a
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 :: 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
    ([Plot x y] -> Identity [Plot x y])
-> Layout x y -> Identity (Layout x y)
forall x y. Lens' (Layout x y) [Plot x y]
layout_plots (([Plot x y] -> Identity [Plot x y])
 -> Layout x y -> Identity (Layout x y))
-> ([Plot x y] -> [Plot x y]) -> EC (Layout x y) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ([Plot x y] -> [Plot x y] -> [Plot x y]
forall a. [a] -> [a] -> [a]
++[p x y -> Plot x y
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 :: 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
  ([Either (Plot x y1) (Plot x y2)]
 -> Identity [Either (Plot x y1) (Plot x y2)])
-> LayoutLR x y1 y2 -> Identity (LayoutLR x y1 y2)
forall x y1 y2.
Lens' (LayoutLR x y1 y2) [Either (Plot x y1) (Plot x y2)]
layoutlr_plots (([Either (Plot x y1) (Plot x y2)]
  -> Identity [Either (Plot x y1) (Plot x y2)])
 -> LayoutLR x y1 y2 -> Identity (LayoutLR x y1 y2))
-> ([Either (Plot x y1) (Plot x y2)]
    -> [Either (Plot x y1) (Plot x y2)])
-> EC (LayoutLR x y1 y2) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ([Either (Plot x y1) (Plot x y2)]
-> [Either (Plot x y1) (Plot x y2)]
-> [Either (Plot x y1) (Plot x y2)]
forall a. [a] -> [a] -> [a]
++[Plot x y1 -> Either (Plot x y1) (Plot x y2)
forall a b. a -> Either a b
Left (p x y1 -> Plot x y1
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 :: 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
  ([Either (Plot x y1) (Plot x y2)]
 -> Identity [Either (Plot x y1) (Plot x y2)])
-> LayoutLR x y1 y2 -> Identity (LayoutLR x y1 y2)
forall x y1 y2.
Lens' (LayoutLR x y1 y2) [Either (Plot x y1) (Plot x y2)]
layoutlr_plots (([Either (Plot x y1) (Plot x y2)]
  -> Identity [Either (Plot x y1) (Plot x y2)])
 -> LayoutLR x y1 y2 -> Identity (LayoutLR x y1 y2))
-> ([Either (Plot x y1) (Plot x y2)]
    -> [Either (Plot x y1) (Plot x y2)])
-> EC (LayoutLR x y1 y2) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ([Either (Plot x y1) (Plot x y2)]
-> [Either (Plot x y1) (Plot x y2)]
-> [Either (Plot x y1) (Plot x y2)]
forall a. [a] -> [a] -> [a]
++[Plot x y2 -> Either (Plot x y1) (Plot x y2)
forall a b. b -> Either a b
Right (p x y2 -> Plot x y2
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 :: EC l (AlphaColour Double)
takeColor = State CState (AlphaColour Double) -> EC l (AlphaColour Double)
forall a l. State CState a -> EC l a
liftCState (State CState (AlphaColour Double) -> EC l (AlphaColour Double))
-> State CState (AlphaColour Double) -> EC l (AlphaColour Double)
forall a b. (a -> b) -> a -> b
$ do
  (AlphaColour Double
c,[AlphaColour Double]
cs) <- [AlphaColour Double] -> (AlphaColour Double, [AlphaColour Double])
forall a. [a] -> (a, [a])
fromInfiniteList ([AlphaColour Double]
 -> (AlphaColour Double, [AlphaColour Double]))
-> StateT CState Identity [AlphaColour Double]
-> StateT
     CState Identity (AlphaColour Double, [AlphaColour Double])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Getting [AlphaColour Double] CState [AlphaColour Double]
-> StateT CState Identity [AlphaColour Double]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting [AlphaColour Double] CState [AlphaColour Double]
Lens' CState [AlphaColour Double]
colors
  ([AlphaColour Double] -> Identity [AlphaColour Double])
-> CState -> Identity CState
Lens' CState [AlphaColour Double]
colors (([AlphaColour Double] -> Identity [AlphaColour Double])
 -> CState -> Identity CState)
-> [AlphaColour Double] -> State CState ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= [AlphaColour Double]
cs
  AlphaColour Double -> State CState (AlphaColour Double)
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 :: EC l PointShape
takeShape = State CState PointShape -> EC l PointShape
forall a l. State CState a -> EC l a
liftCState (State CState PointShape -> EC l PointShape)
-> State CState PointShape -> EC l PointShape
forall a b. (a -> b) -> a -> b
$ do
  (PointShape
c,[PointShape]
cs) <- [PointShape] -> (PointShape, [PointShape])
forall a. [a] -> (a, [a])
fromInfiniteList ([PointShape] -> (PointShape, [PointShape]))
-> StateT CState Identity [PointShape]
-> StateT CState Identity (PointShape, [PointShape])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Getting [PointShape] CState [PointShape]
-> StateT CState Identity [PointShape]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting [PointShape] CState [PointShape]
Lens' CState [PointShape]
shapes
  ([PointShape] -> Identity [PointShape])
-> CState -> Identity CState
Lens' CState [PointShape]
shapes (([PointShape] -> Identity [PointShape])
 -> CState -> Identity CState)
-> [PointShape] -> State CState ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= [PointShape]
cs
  PointShape -> State CState PointShape
forall (m :: * -> *) a. Monad m => a -> m a
return PointShape
c

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