wumpus-microprint 0.6.0 → 0.7.0

raw patch · 4 files changed

+64/−44 lines, 4 filesdep −monadLibdep ~wumpus-basicdep ~wumpus-corePVP ok

version bump matches the API change (PVP)

Dependencies removed: monadLib

Dependency ranges changed: wumpus-basic, wumpus-core

API changes (from Hackage documentation)

Files

• demo/Demo01.hs +1/−1
• src/Wumpus/MicroPrint/Render.hs +54/−37
• src/Wumpus/MicroPrint/VersionNumber.hs +2/−2
• wumpus-microprint.cabal +7/−4

@@ -43,7 +43,7 @@        { char_height    = 12.0        , char_width     = 8.0        , line_spacing   = 3.0-       , drawWordF      = borderedF 1.0+       , drawWordF      = borderedF        }   

@@ -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 ()

@@ -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)

@@ -1,5 +1,5 @@ name:             wumpus-microprint-version:          0.6.0+version:          0.7.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -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: