diff --git a/demo/Demo01.hs b/demo/Demo01.hs --- a/demo/Demo01.hs +++ b/demo/Demo01.hs @@ -43,7 +43,7 @@ { char_height = 12.0 , char_width = 8.0 , line_spacing = 3.0 - , drawWordF = borderedF 1.0 + , drawWordF = borderedF } diff --git a/src/Wumpus/MicroPrint/Render.hs b/src/Wumpus/MicroPrint/Render.hs --- a/src/Wumpus/MicroPrint/Render.hs +++ b/src/Wumpus/MicroPrint/Render.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS -Wall #-} @@ -29,26 +30,25 @@ ) where import Wumpus.Core -import Wumpus.Core.Colour ( black ) import Wumpus.Basic.Graphic import Wumpus.Basic.Monads.TurtleMonad -import Wumpus.Basic.Utils.HList import Wumpus.MicroPrint.DrawMonad ( Tile(..), Height ) -import MonadLib -- package: monadLib import Data.AffineSpace -- package: vector-space import Control.Applicative import Control.Monad +import Data.List + -- | 'DrawWordF' : -- @ (num_chars, char_unit_width) * (full_width, full_height) -> rgb -> DGraphicF @ -- -- The libraries currently provides two styles - 'greekF' and -- 'borderedF'. -- -type DrawWordF = (Int,Double) -> (Double,Double) -> RGBi -> DGraphicF +type DrawWordF = (Int,Double) -> (Double,Double) -> RGBi -> DLocGraphic -- | Style properties for micro-print drawing. @@ -63,57 +63,74 @@ -- | Draw the word as a single coloured rectangle. -- greekF :: DrawWordF -greekF _ (w,h) rgb = wrapG . fill rgb . rectanglePath w h +greekF _ (w,h) rgb = + localDrawingContext (secondaryColour rgb) (filledRectangle w h) -- | Draw the word as a coloured rectangle, with a border grid. -- -borderedF :: Double -> DrawWordF -borderedF ln_width (i,uw) (w,h) rgb = - srect `cc` seps `cc` greekF (i,uw) (w,h) rgb +borderedF :: DrawWordF +borderedF (i,uw) (w,h) rgb = concatAt srect seps where - props = default_stroke_attr { line_width = ln_width } + srect :: DLocGraphic + srect = localDrawingContext (secondaryColour rgb) (borderedRectangle w h) - srect :: DGraphicF - srect = wrapG . cstroke black props . rectanglePath w h - - seps :: DGraphicF - seps = \pt -> unfoldrH (phi pt) (1,uw) + seps :: [DLocGraphic] + seps = unfoldr phi (1,uw) - phi pt (n,hshift) | n >= i = Nothing - | otherwise = let ln = vline black props h (pt .+^ hvec hshift) - in Just (ln,(n+1,hshift+uw)) - -vline :: (Num u, Ord u) => RGBi -> StrokeAttr -> u -> Point2 u -> Primitive u -vline rgb attr h = \pt -> ostroke rgb attr $ path pt [lineTo $ pt .+^ vvec h] + phi (n,hshift) | n >= i = Nothing + | otherwise = let fn = \pt -> vline h (pt .+^ hvec hshift) + in Just (fn,(n+1,hshift+uw)) + + + +-- Note - this needs attention due to Z-Order handling in +-- Wumpus-Basic. There are better ways to accomplish what +-- borderedF does... +-- +concatAt :: DLocGraphic -> [DLocGraphic] -> DLocGraphic +concatAt x [] = x +concatAt x xs = foldr appendAt x xs + +vline :: (Num u, Ord u) => u -> LocGraphic u +vline h = \pt -> openStroke $ path pt [lineTo $ pt .+^ vvec h] newtype RenderMonad a = RM { - getRM :: ReaderT MicroPrintConfig - ( TurtleDrawing Double ) a } + getRM :: MicroPrintConfig -> TurtleDrawing Double a } + +type instance MonUnit RenderMonad = Double + instance Functor RenderMonad where - fmap f = RM . fmap f . getRM + fmap f ma = RM $ \cfg -> fmap f $ getRM ma cfg instance Monad RenderMonad where - return a = RM $ return a - m >>= k = RM $ getRM m >>= getRM . k + return a = RM $ \_ -> return a + m >>= k = RM $ \cfg -> getRM m cfg >>= \a -> (getRM . k) a cfg instance Applicative RenderMonad where pure = return (<*>) = ap -instance TraceM RenderMonad Double where - trace h = RM $ lift $ trace h +instance TraceM RenderMonad where + trace h = RM $ \_ -> trace h -instance ReaderM RenderMonad MicroPrintConfig where - ask = RM $ ask +instance DrawingCtxM RenderMonad where + askCtx = RM $ \ _ -> askCtx + localCtx ctx ma = RM $ \cfg -> localCtx ctx (getRM ma cfg) +ask :: RenderMonad MicroPrintConfig +ask = RM $ \cfg -> return cfg + +asks :: (MicroPrintConfig -> a) -> RenderMonad a +asks f = f <$> ask + instance TurtleM RenderMonad where - getLoc = RM $ lift $ getLoc - setLoc c = RM $ lift $ setLoc c - getOrigin = RM $ lift $ getOrigin - setOrigin o = RM $ lift $ setOrigin o + getLoc = RM $ \_ -> getLoc + setLoc c = RM $ \_ -> setLoc c + getOrigin = RM $ \_ -> getOrigin + setOrigin o = RM $ \_ -> setOrigin o drawMicroPrint :: MicroPrintConfig -> ([Tile],Height) -> Maybe DPicture @@ -123,10 +140,10 @@ post [] = Nothing post ps = Just $ frame ps -runRender :: MicroPrintConfig -> RenderMonad a -> (a, DGraphic) +runRender :: MicroPrintConfig -> RenderMonad a -> (a, HPrim Double) runRender cfg m = - runTurtleDrawing (regularConfig 1) (0,0) (standardAttr 14) - $ runReaderT cfg $ getRM $ m + runTurtleDrawing (regularConfig 1) (0,0) (standardContext 14) + $ (getRM m) cfg interpret :: [Tile] -> RenderMonad () interpret = mapM_ interp1 @@ -140,7 +157,7 @@ uw <- asks char_width pt <- scaleCurrentCoord dF <- asks drawWordF - trace (dF (i,uw) (w,h) rgb pt) + drawAt pt (dF (i,uw) (w,h) rgb) moveRightN i moveRightN :: Int -> RenderMonad () diff --git a/src/Wumpus/MicroPrint/VersionNumber.hs b/src/Wumpus/MicroPrint/VersionNumber.hs --- a/src/Wumpus/MicroPrint/VersionNumber.hs +++ b/src/Wumpus/MicroPrint/VersionNumber.hs @@ -22,7 +22,7 @@ -- | Version number -- --- > (0,6,0) +-- > (0,7,0) -- wumpus_microprint_version :: (Int,Int,Int) -wumpus_microprint_version = (0,6,0) +wumpus_microprint_version = (0,7,0) diff --git a/wumpus-microprint.cabal b/wumpus-microprint.cabal --- a/wumpus-microprint.cabal +++ b/wumpus-microprint.cabal @@ -1,5 +1,5 @@ name: wumpus-microprint -version: 0.6.0 +version: 0.7.0 license: BSD3 license-file: LICENSE copyright: Stephen Tetley @@ -25,6 +25,10 @@ . Changelog: . + 0.6.0 to 0.7.0: + . + * Again, internal changes to work with latest @Wumpus-Basic@. + . 0.5.0 to 0.6.0: . * Updated internals to work with latest @wumpus-core@ and @@ -65,9 +69,8 @@ hs-source-dirs: src build-depends: base < 5, vector-space >= 0.6, - monadLib >= 3.6, - wumpus-core == 0.31.0, - wumpus-basic == 0.6.0 + wumpus-core == 0.32.0, + wumpus-basic == 0.7.0 exposed-modules: