wumpus-basic-0.7.0: src/Wumpus/Basic/Graphic/Drawing.hs
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS -Wall #-}
--------------------------------------------------------------------------------
-- |
-- Module : Wumpus.Basic.Graphic.Drawing
-- Copyright : (c) Stephen Tetley 2010
-- License : BSD3
--
-- Maintainer : stephen.tetley@gmail.com
-- Stability : unstable
-- Portability : GHC
--
-- Drawing with trace and drawing context (i.e. reader monad
-- of attributes - fill_colour etc.).
--
-- \*\* WARNING \*\* - some names are expected to change
-- particularly the naming of the @draw@, @drawAt@, @node@, @...@
-- functions.
--
--
--------------------------------------------------------------------------------
module Wumpus.Basic.Graphic.Drawing
(
Drawing
, DrawingT
, runDrawing
, execDrawing
, runDrawingT
, execDrawingT
, liftToPictureU
, draw
, drawAt
, drawAtImg
, drawConn
, drawConnImg
, node
) where
import Wumpus.Basic.Graphic.BaseClasses
import Wumpus.Basic.Graphic.BaseTypes
import Wumpus.Basic.Graphic.DrawingContext
import Wumpus.Basic.Utils.HList
import Wumpus.Core -- package: wumpus-core
import Control.Applicative
import Control.Monad
-- Note - Drawing run \once\ - it is supplied with the starting
-- environment (DrawingContext) and returns a Picture.
--
-- Other Wumpus monads (e.g. Turtle) will typically be run inside
-- the Drawing monad as a local effect, rather than built into a
-- transformer stack.
--
newtype Drawing u a = Drawing {
getDrawing :: DrawingContext -> HPrim u -> (a, HPrim u) }
newtype DrawingT u m a = DrawingT {
getDrawingT :: DrawingContext -> HPrim u -> m (a, HPrim u) }
type instance MonUnit (Drawing u) = u
type instance MonUnit (DrawingT u m) = u
-- Functor
instance Functor (Drawing u) where
fmap f ma = Drawing $ \ctx s ->
let (a,s1) = getDrawing ma ctx s in (f a,s1)
instance Monad m => Functor (DrawingT u m) where
fmap f ma = DrawingT $ \ctx s ->
getDrawingT ma ctx s >>= \(a,s1) -> return (f a,s1)
-- Applicative
instance Applicative (Drawing u) where
pure a = Drawing $ \_ s -> (a, s)
mf <*> ma = Drawing $ \ctx s -> let (f,s1) = getDrawing mf ctx s
(a,s2) = getDrawing ma ctx s1
in (f a, s2)
instance Monad m => Applicative (DrawingT u m) where
pure a = DrawingT $ \_ s -> return (a, s)
mf <*> ma = DrawingT $ \ctx s -> getDrawingT mf ctx s >>= \(f,s1) ->
getDrawingT ma ctx s1 >>= \(a,s2) ->
return (f a, s2)
-- Monad
instance Monad (Drawing u) where
return a = Drawing $ \_ s -> (a, s)
ma >>= k = Drawing $ \ctx s -> let (a,s1) = getDrawing ma ctx s
in (getDrawing . k) a ctx s1
instance Monad m => Monad (DrawingT u m) where
return a = DrawingT $ \_ s -> return (a, s)
ma >>= k = DrawingT $ \ctx s -> getDrawingT ma ctx s >>= \(a,s1) ->
(getDrawingT . k) a ctx s1
-- TraceM
--
-- Note - @ state `appendH` a @ means the first expression in a
-- monadic drawing is top of the Z-Order.
--
-- This is the matches a list of Prims in Wumpus-Core where the
-- first element is drawn on top, however is not necessarily
-- intuitive if you regard the do-block as a sequence of
-- /actions/.
--
-- Ideally some control over the Z-Order, possibly adding
-- /layers/ to the drawing model would be valuable.
--
instance TraceM (Drawing u) where
trace a = Drawing $ \_ s -> ((),s `appendH` a)
instance Monad m => TraceM (DrawingT u m) where
trace a = DrawingT $ \_ s -> return ((),s `appendH` a)
-- DrawingCtxM
instance DrawingCtxM (Drawing u) where
askCtx = Drawing $ \ctx s -> (ctx, s)
localCtx cF ma = Drawing $ \ctx s -> getDrawing ma (cF ctx) s
instance Monad m => DrawingCtxM (DrawingT u m) where
askCtx = DrawingT $ \ctx s -> return (ctx,s)
localCtx cF ma = DrawingT $ \ctx s -> getDrawingT ma (cF ctx) s
-- Note - the result type of runDrawing and friends needs more
-- thought and may change.
--
-- Possibly a wrapped HPrim that only supports concat and safe
-- extraction is best.
--
-- Or it could generate a picture, but then separate drawings
-- need the picture combinators to put them together.
--
runDrawing :: DrawingContext -> Drawing u a -> (a, HPrim u)
runDrawing ctx ma = getDrawing ma ctx emptyH
execDrawing :: DrawingContext -> Drawing u a -> HPrim u
execDrawing ctx ma = snd $ runDrawing ctx ma
runDrawingT :: Monad m => DrawingContext -> DrawingT u m a -> m (a, HPrim u)
runDrawingT ctx ma = getDrawingT ma ctx emptyH
execDrawingT :: Monad m => DrawingContext -> DrawingT u m a -> m (HPrim u)
execDrawingT ctx ma = liftM snd $ runDrawingT ctx ma
liftToPictureU :: (Real u, Floating u, FromPtSize u) => HPrim u -> Picture u
liftToPictureU hf = let prims = toListH hf in
if null prims then errK else frame prims
where
errK = error "liftToPictureU - empty prims list."
--------------------------------------------------------------------------------
draw :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Graphic u -> m ()
draw gf = askCtx >>= \ctx -> trace (runGraphic ctx gf)
drawAt :: (TraceM m, DrawingCtxM m, u ~ MonUnit m)
=> Point2 u ->LocGraphic u -> m ()
drawAt pt gfL = askCtx >>= \ctx -> trace (runGraphic ctx (gfL pt))
drawAtImg :: (TraceM m, DrawingCtxM m, u ~ MonUnit m)
=> Point2 u -> LocImage u a -> m a
drawAtImg pt imgL = askCtx >>= \ctx ->
let (a,o) = runImage ctx (imgL pt)
in trace o >> return a
drawConn :: (TraceM m, DrawingCtxM m, u ~ MonUnit m)
=> Point2 u -> Point2 u -> ConnGraphic u -> m ()
drawConn p1 p2 connL = askCtx >>= \ctx -> trace (runGraphic ctx (connL p1 p2))
drawConnImg :: (TraceM m, DrawingCtxM m, u ~ MonUnit m)
=> Point2 u -> Point2 u -> ConnImage u a -> m a
drawConnImg p1 p2 connL = askCtx >>= \ctx ->
let (a,o) = runImage ctx (connL p1 p2)
in trace o >> return a
node :: (TraceM m, DrawingCtxM m, PointSupplyM m, u ~ MonUnit m)
=> LocGraphic u -> m ()
node gfL = askCtx >>= \ctx ->
position >>= \pt -> trace (runGraphic ctx $ gfL pt)