{-# 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
data CState = CState {
CState -> [AlphaColour Double]
_colors :: [AlphaColour Double],
CState -> [PointShape]
_shapes :: [PointShape]
}
$( makeLenses ''CState )
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
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
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
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
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])
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)])
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)])
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
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)