{-# 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 { _colors :: [AlphaColour Double], -- ^ An infinite source of colors, for use in plots _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 defColors defShapes where defColors = cycle (map opaque [blue,green,red,orange,yellow,violet]) defShapes = cycle [PointShapeCircle,PointShapePlus,PointShapeCross,PointShapeStar] instance (Default a,ToRenderable a) => ToRenderable (EC a b) where toRenderable = toRenderable . 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 = evalState (execStateT ec def) def -- | Nest the construction of a graphical element within -- the construction of another. liftEC :: (Default l1) => EC l1 a -> EC l2 l1 liftEC ec = do cs <- lift get let (l,cs') = runState (execStateT ec def) cs lift (put cs') return l -- | Lift a a computation over `CState` liftCState :: State CState a -> EC l a liftCState = lift -- | Add a plot to the `Layout` being constructed. plot :: (ToPlot p) => EC (Layout x y) (p x y) -> EC (Layout x y) () plot pm = do p <- pm layout_plots %= (++[toPlot 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 pm = do p <- pm layoutlr_plots %= (++[Left (toPlot 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 pm = do p <- pm layoutlr_plots %= (++[Right (toPlot p)]) -- | Pop and return the next color from the state takeColor :: EC l (AlphaColour Double) takeColor = liftCState $ do (c,cs) <- fromInfiniteList `fmap` use colors colors .= cs return c -- | Pop and return the next shape from the state takeShape :: EC l PointShape takeShape = liftCState $ do (c,cs) <- fromInfiniteList `fmap` use shapes shapes .= cs return c fromInfiniteList :: [a] -> (a, [a]) fromInfiniteList [] = error "fromInfiniteList (takeColor or takeShape): empty list" fromInfiniteList (x:xs) = (x, xs)