module Wumpus.MicroPrint.Render
(
Graphic
, DGraphic
, MP_config(..)
, greekF
, drawMicroPrint
) where
import Wumpus.Core
import Wumpus.Basic.Monads.TraceMonad
import Wumpus.Basic.Monads.TurtleMonad
import Wumpus.Basic.Utils.HList
import Wumpus.MicroPrint.DrawMonad ( Tile(..), Height )
import Data.AffineSpace
import MonadLib
import Control.Applicative
import Control.Monad
type Graphic u = H (Primitive u)
type DGraphic = Graphic Double
type GraphicF u = Point2 u -> Graphic u
type DGraphicF = GraphicF Double
data MP_config = MP_config
{ char_height :: Double
, char_width :: Double
, line_spacing :: Double
, drawF :: Double -> Double -> DRGB -> DGraphicF
}
greekF :: Double -> Double -> DRGB -> DGraphicF
greekF w h rgb = filledRectangle rgb w h
newtype RenderMonad a = RM { getRM :: ReaderT MP_config
( TraceT DPrimitive Turtle) a }
instance Functor RenderMonad where
fmap f = RM . fmap f . getRM
instance Monad RenderMonad where
return a = RM $ return a
m >>= k = RM $ getRM m >>= getRM . k
instance Applicative RenderMonad where
pure = return
(<*>) = ap
instance TraceM RenderMonad DPrimitive where
trace h = RM $ lift $ trace h
trace1 i = RM $ lift $ trace1 i
instance ReaderM RenderMonad MP_config where
ask = RM $ ask
instance TurtleM RenderMonad where
getLoc = RM $ lift $ lift $ getLoc
setLoc c = RM $ lift $ lift $ setLoc c
drawMicroPrint :: MP_config -> ([Tile],Height) -> Maybe DPicture
drawMicroPrint cfg (xs,h) =
let (_,hf) = runRender cfg (moveUpN h >> interpret xs) in post $ hf []
where
post [] = Nothing
post ps = Just $ frameMulti $ ps
runRender :: MP_config -> RenderMonad a -> (a, DGraphic)
runRender cfg m =
post $ runTurtle $ runTraceT $ runReaderT cfg $ getRM $ m
where
post ((a,w), _) = (a,w)
interpret :: [Tile] -> RenderMonad ()
interpret = mapM_ interp1
interp1 :: Tile -> RenderMonad ()
interp1 LineBreak = nextLine
interp1 (Space i) = moveRightN i
interp1 (Word rgb i) = do
w <- scaleWidth i
h <- asks char_height
pt <- scaleCurrentCoord
dF <- asks drawF
trace (dF w h rgb pt)
moveRightN i
moveRightN :: Int -> RenderMonad ()
moveRightN i = setsLoc_ (\(Coord x y) -> Coord (x+i) y )
moveUpN :: Int -> RenderMonad ()
moveUpN i = setsLoc_ (\(Coord x y) -> Coord x (y+i) )
scaleCurrentCoord :: RenderMonad DPoint2
scaleCurrentCoord =
fn <$> getLoc <*> asks char_width <*> asks char_height <*> asks line_spacing
where
fn (Coord x y) cw ch sp = P2 (cw * fromIntegral x) ((ch+sp) * fromIntegral y)
scaleWidth :: Int -> RenderMonad Double
scaleWidth i = (\cw -> cw * fromIntegral i) <$> asks char_width
filledRectangle :: (Num u, Ord u, Fill t)
=> t -> u -> u -> GraphicF u
filledRectangle t w h bl = wrapH $ fill t $ rectangle w h bl
rectangle :: Num u => u -> u -> Point2 u -> Path u
rectangle w h bl = path bl [ lineTo br, lineTo tr, lineTo tl ]
where
br = bl .+^ hvec w
tr = br .+^ vvec h
tl = bl .+^ vvec h