wumpus-microprint 0.8.0 → 0.9.0

raw patch · 12 files changed

+589/−443 lines, 12 filesdep ~wumpus-basicdep ~wumpus-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: wumpus-basic, wumpus-core

API changes (from Hackage documentation)

Files

• demo/Demo01.hs +25/−30
• src/Wumpus/MicroPrint.hs +0/−62
• src/Wumpus/MicroPrint/DrawMonad.hs +0/−134
• src/Wumpus/MicroPrint/Render.hs +0/−175
• src/Wumpus/MicroPrint/VersionNumber.hs +0/−28
• src/Wumpus/Microprint.hs +71/−0
• src/Wumpus/Microprint/Datatypes.hs +49/−0
• src/Wumpus/Microprint/Render.hs +99/−0
• src/Wumpus/Microprint/Teletype.hs +139/−0
• src/Wumpus/Microprint/Tokenizer.hs +155/−0
• src/Wumpus/Microprint/VersionNumber.hs +28/−0
• wumpus-microprint.cabal +23/−14

@@ -4,46 +4,41 @@  module Demo01 where -import Wumpus.MicroPrint+import Wumpus.Microprint.Datatypes+import Wumpus.Microprint.Render+import Wumpus.Microprint.Tokenizer  import Wumpus.Core                              -- package: wumpus-core import Wumpus.Basic.Colour.SVGColours           -- package: wumpus-basic+import Wumpus.Basic.Graphic -import Data.Maybe import System.Directory  main :: IO () main = do -    { createDirectoryIfMissing True "./out/"-    ; micro1 <- filePic-    ; let pic1 = fromMaybe errK $ renderMicroPrint cfg1 (prefix micro1)-    ; writeEPS_latin1 "./out/mp01.eps" pic1-    ; writeSVG_latin1 "./out/mp01.svg" pic1-    }-  where-    prefix mp = setRGB moccasin >> mp+    createDirectoryIfMissing True "./out/"+    inp <- readFile "Demo01.hs"	  -- This file+    let gtext = runTokenizer (haskellTokenizer moccasin green) inp+    let pic1  = makePicture gtext+    writeEPS_latin1 "./out/microprint01.eps" pic1+    writeSVG_latin1 "./out/microprint01.svg" pic1+    let pic2  = makeBordered gtext+    writeEPS_latin1 "./out/microprint02.eps" pic2+    writeSVG_latin1 "./out/microprint02.svg" pic2 -errK :: a-errK = error "no picture" -filePic :: IO (MicroPrint ())-filePic = do-  xs <- readFile "Demo01.hs"-  return $ foldr (\a acc -> drawChar a >> acc) (return ()) xs--drawChar :: Char -> MicroPrint ()-drawChar '\n' = linebreak-drawChar '\t' = space >> space >> space >> space-drawChar ' '  = space-drawChar _    = char-+makePicture :: GreekText -> DPicture+makePicture gtext = liftToPictureU $ execDrawing (standardContext 14) $ +    render sctx strokelineF gtext+  where+    sctx = makeRenderScaling (\x -> fromIntegral $ 2*x) +                             (\y -> fromIntegral $ 3*y) -cfg1 :: MicroPrintConfig-cfg1 = MicroPrintConfig -       { char_height    = 12.0-       , char_width     = 8.0-       , line_spacing   = 3.0-       , drawWordF      = borderedF-       }+makeBordered :: GreekText -> DPicture+makeBordered gtext = liftToPictureU $ execDrawing (standardContext 14) $ +    render sctx borderedF gtext+  where+    sctx = makeRenderScaling (\x -> fromIntegral $ 6*x) +                             (\y -> fromIntegral $ 8*y)   

@@ -1,62 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.MicroPrint--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC------ MicroPrints--------------------------------------------------------------------------------------module Wumpus.MicroPrint-  (--  -- * Re-export all MicroPrint.Render        -    module Wumpus.MicroPrint.Render--  -- * Top level rendering functions-  , renderMicroPrint-  , renderMicroPrintU--  -- * Re-export some from MicroPrint.DrawMonad-  , MicroPrint-  , Tile(..)-  , Height-  , linebreak-  , setRGB-  , char-  , space--  ) where---import Wumpus.MicroPrint.DrawMonad-import Wumpus.MicroPrint.Render--import Wumpus.Core                              -- package: wumpus-core--import Data.Maybe----- | Build a picture from a MicroPrint.------ This function returns Nothing if the picture is empty.--- -renderMicroPrint :: MicroPrintConfig -> MicroPrint a -> Maybe DPicture-renderMicroPrint cfg mf = drawMicroPrint cfg $ execMicroPrint mf----- | Build a picture from a MicroPrint - /unsafe/ version.------ This function throws a runtime error if the picture is empty.--- -renderMicroPrintU :: MicroPrintConfig -> MicroPrint a -> DPicture-renderMicroPrintU cfg mf = fromMaybe errK $ renderMicroPrint cfg mf-  where-    errK = error "renderMicroPrintU - empty picture."

@@ -1,134 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.MicroPrint.DrawMonad--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC------ MicroPrints drawing monad - drawing here is analogous to a --- /teletype/ drawing characters, spaces and linebreaks one at a --- time.--------------------------------------------------------------------------------------module Wumpus.MicroPrint.DrawMonad-  (--    MicroPrint-  , runMicroPrint-  , execMicroPrint--  , Tile(..)-  , Height-  , linebreak-  , setRGB-  , char-  , space--  ) where--import Wumpus.Core-import Wumpus.Core.Colour ( black )--import Wumpus.Basic.Utils.HList--import Control.Monad--data Tile = LineBreak | Space Int | Word RGBi Int---- Interim version without colour annotation...-data TileState = Start | S0 Int | W0 Int----type Text       = H Tile-type Trace      = Text-type Height     = Int-type State      = (TileState, RGBi, Height)---- | Build a /microprint/ within a monad...------ Drawings are made in a /teletype/ fashion emitting a character,--- space or line-break at each step.----newtype MicroPrint a = MicroPrint { -          getMicroPrint :: Trace -> State -> (a,Trace,State) }--instance Functor MicroPrint where-  fmap f m = MicroPrint $ \w s -> -                let (a,w',s') = getMicroPrint m w s in (f a,w',s')--instance Monad MicroPrint where-  return a = MicroPrint $ \w s -> (a,w,s)-  m >>= k  = MicroPrint $ \w s -> let (a,w',s') = getMicroPrint m w s -                                  in (getMicroPrint . k) a w' s'---runMicroPrint :: MicroPrint a -> (a,[Tile],Height)-runMicroPrint m = post $ getMicroPrint m emptyH (Start,black,1)-  where-    post (a,f,(W0 n, rgb, h)) = (a, toListH $ f `snocH` (Word rgb n), h)-    post (a,f,(_, _, h))      = (a, f [], h)--execMicroPrint :: MicroPrint a -> ([Tile],Height)-execMicroPrint = post . runMicroPrint-  where post (_,xs,h) = (xs,h)--enqueueTile :: MicroPrint ()-enqueueTile = MicroPrint $ \w (opt,rgb,h) -> -    let tileF = step rgb opt in ((), tileF w, (Start, rgb,h))-  where-    step _   Start  = id-    step _   (S0 n) = (\f -> f `snocH` (Space n))-    step rgb (W0 n) = (\f -> f `snocH` (Word rgb n))----- | Emit a linebreak in the output.----linebreak :: MicroPrint ()-linebreak = enqueueTile >> next-  where-    next = MicroPrint $ -             \w (opt,rgb,h) -> ((),w `snocH` LineBreak, (opt,rgb,h+1))----- | Change the current drawing colour.------ Note - it is permissible to change colour mid-word, but this --- is the same as having a no-space break.----setRGB :: RGBi -> MicroPrint ()-setRGB rgb = enqueueTile >> next-  where-    -- tip will always be Start here...-    next = MicroPrint $ \w (tip,_,h) -> ((),w,(tip,rgb,h))----- | Draw a character - note in the microprint, characters will --- be concatenated together to make a word.----char :: MicroPrint ()-char = MicroPrint $ \w (tip,rgb,h) ->-    let (f,tip') = addChar tip in ((),f w,(tip',rgb,h))-  where-    addChar Start  = (id, W0 1)-    addChar (W0 n) = (id, W0 $ n+1)-    addChar (S0 n) = (\f -> f `snocH` (Space n), W0 1)---- | Draw a space.----space :: MicroPrint ()-space = MicroPrint $ \w (tip,rgb,h) ->-    let (f,tip') = addSpace tip rgb in ((),f w,(tip',rgb,h))-  where-    addSpace Start  _   = (id, S0 1)-    addSpace (W0 n) rgb = (\f -> f `snocH` (Word rgb n), S0 1)-    addSpace (S0 n) _   = (id, S0 $ n+1)-- -

@@ -1,175 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE TypeSynonymInstances       #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.MicroPrint.Render--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC------ Render--------------------------------------------------------------------------------------module Wumpus.MicroPrint.Render-  (--    DrawWordF  -  , MicroPrintConfig(..)-  , greekF-  , borderedF--  , drawMicroPrint--  ) where--import Wumpus.Core-import Wumpus.Basic.Graphic-import Wumpus.Basic.Monads.TurtleMonad--import Wumpus.MicroPrint.DrawMonad ( Tile(..), Height ) --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 -> DLocGraphic----- | Style properties for micro-print drawing.----data MicroPrintConfig = MicroPrintConfig -       { char_height    :: Double-       , char_width     :: Double-       , line_spacing   :: Double -       , drawWordF      :: DrawWordF-       }---- | Draw the word as a single coloured rectangle.----greekF :: DrawWordF-greekF _ (w,h) rgb = -    localLG (secondaryColour rgb) (filledRectangle w h) ----- | Draw the word as a coloured rectangle, with a border grid.----borderedF :: DrawWordF-borderedF (i,uw) (w,h) rgb = concatAt srect seps-  where-    srect :: DLocGraphic-    srect = localLG (secondaryColour rgb) (borderedRectangle w h)--    seps  :: [DLocGraphic]-    seps  = unfoldr phi (1,uw) -    -    phi (n,hshift) | n >= i    = Nothing-                   | otherwise = let fn = \pt -> vline h (pt .+^ hvec hshift)-                                 in  Just (fn,(n+1,hshift+uw))----- At some point this needs a rethink...----concatAt :: DLocGraphic -> [DLocGraphic] -> DLocGraphic -concatAt x [] = x-concatAt x xs = foldl' lgappend 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 :: MicroPrintConfig -> TurtleDrawing Double a }---type instance MonUnit RenderMonad = Double--instance Functor RenderMonad where-  fmap f ma = RM $ \cfg -> fmap f $ getRM ma cfg--instance Monad RenderMonad where-  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 where-  trace  h = RM $ \_ -> trace h--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 $ \_ -> getLoc-  setLoc c      = RM $ \_ -> setLoc c-  getOrigin     = RM $ \_ -> getOrigin-  setOrigin o   = RM $ \_ -> setOrigin o---drawMicroPrint :: MicroPrintConfig -> ([Tile],Height) -> Maybe DPicture-drawMicroPrint cfg (xs,h) = -    let (_,hf) = runRender cfg (moveUpN h >> interpret xs) in liftToPictureMb hf--runRender :: MicroPrintConfig -> RenderMonad a -> (a, HPrim Double)-runRender cfg m = -    runTurtleDrawing (regularConfig 1) (0,0) (standardContext 14) -         $ (getRM m) cfg--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-    uw <- asks char_width-    pt <- scaleCurrentCoord-    dF <- asks drawWordF-    draw $ (dF (i,uw) (w,h) rgb) `at` pt-    moveRightN i-   -moveRightN   :: Int -> RenderMonad ()-moveRightN i = setsLoc_ $ \(x,y) -> (x+i,y)--moveUpN      :: Int -> RenderMonad ()-moveUpN i    = setsLoc_ $ \(x,y) -> (x,y+i)--scaleCurrentCoord :: RenderMonad DPoint2-scaleCurrentCoord = -    fn <$> getLoc <*> asks char_width <*> asks char_height <*> asks line_spacing-  where-    fn (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-------------------------------------------------------------------------------------

@@ -1,28 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.MicroPrint.VersionNumber--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC------ Version number--------------------------------------------------------------------------------------module Wumpus.MicroPrint.VersionNumber-  ( -    wumpus_microprint_version--  ) where---- | Version number------ > (0,8,0)----wumpus_microprint_version :: (Int,Int,Int)-wumpus_microprint_version = (0,8,0)

@@ -0,0 +1,71 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Microprint+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- MicroPrints+--+-- \*\* WARNING \*\* - This module is out-of-date and is due a +-- rethink. Teletype is no longer the recommended drawing style.+--+--------------------------------------------------------------------------------++module Wumpus.Microprint+  (++  -- * Re-export all Microprint.Render        +    module Wumpus.Microprint.Render++  -- * Top level rendering functions+  , renderTeletype+  , renderTeletypeU++  -- * Re-export some from MicroPrint.DrawMonad+  , Teletype+  , Tile(..)+  , Height+  , linebreak+  , setRGB+  , char+  , space++  ) where+++import Wumpus.Microprint.Teletype+import Wumpus.Microprint.Render++import Wumpus.Core                              -- package: wumpus-core+import Wumpus.Basic.Graphic			-- package: wumpus-basic++import Data.Maybe++++-- | Build a picture from a Teletype drawing.+--+-- This function returns Nothing if the picture is empty.+-- +renderTeletype :: RenderScalingCtx -> DrawWordF -> Teletype a -> Maybe DPicture+renderTeletype ctx fn mf = +    liftToPictureMb $ execDrawing (standardContext 14) +                    $ render ctx fn $ execTeletype mf+++-- | Build a picture from a Teletype - /unsafe/ version.+--+-- This function throws a runtime error if the picture is empty.+-- +renderTeletypeU :: RenderScalingCtx -> DrawWordF -> Teletype a -> DPicture+renderTeletypeU ctx fn mf = fromMaybe errK $ renderTeletype ctx fn mf+  where+    errK = error "renderTeletypeU - empty picture."++ 

@@ -0,0 +1,49 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Microprint.Datatypes+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- Base datatypes.+--+--------------------------------------------------------------------------------++module Wumpus.Microprint.Datatypes+  (++  -- * Datatypes  + +    Tile(..)+  , Height+  , GreekText++  ) where++import Wumpus.Core+++++data Tile = Space Int | Word RGBi Int+  deriving (Eq,Ord,Show)++type Height = Int+++-- Note probably better if used a list of lines instead+--+-- > [[Title]] +--+-- and did not have line break in the Tile datatype.+--+type GreekText = (Height,[[Tile]])+++ +

@@ -0,0 +1,99 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Microprint.Render+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- Render+--+--------------------------------------------------------------------------------++module Wumpus.Microprint.Render+  (+    RenderScalingCtx+  , makeRenderScaling+  , DrawWordF  +  , greekF+  , strokelineF+  , borderedF++  , render++  ) where++import Wumpus.Basic.Graphic.ScalingContext++import Wumpus.Microprint.Datatypes ++import Wumpus.Core		     	        -- package: wumpus-core+import Wumpus.Basic.Graphic			-- package: wumpus-basic++import Data.AffineSpace				-- package: vector-space++import Data.Monoid++--------------------------------------------------------------------------------++type RenderScalingCtx = ScalingContext Int Int Double+type RenderScalingT m a = ScalingT Int Int Double m a++makeRenderScaling :: (Int -> Double) -> (Int -> Double) -> ScalingContext Int Int Double+makeRenderScaling fx fy = +    ScalingContext { scale_in_x = fx, scale_in_y = fy }+++-- | 'DrawWordF' :+--+-- > colour * scaled_width * scaled_height -> char_count -> DLocGraphic+--+type DrawWordF = RGBi -> Double -> Double -> Int -> DLocGraphic+++-- | Just a filled rectangle.+--+greekF :: DrawWordF+greekF rgb w h _ = localLG (secondaryColour rgb) (filledRectangle w h)+++borderedF :: DrawWordF+borderedF rgb w h i = background `lgappend` ticks+  where+    background  = localLG (secondaryColour rgb) (borderedRectangle w h)+    v1          = hvec $ w / fromIntegral i+    ticks pt    = mconcat $ map (straightLine (vvec h)) +    	                  $ take (i-1) $ iterate (.+^ v1) (pt .+^ v1)++ +-- | A stroked line.+--+strokelineF :: DrawWordF+strokelineF rgb w _ _ = localLG (primaryColour rgb) (straightLine (hvec w))+++render :: RenderScalingCtx -> DrawWordF -> GreekText -> Drawing Double ()+render ctx wordDraw (hmax,xs) = +    runScalingT ctx $ mstep hmax xs+  where+    mstep h (s:ss) = renderLine wordDraw h s >> mstep (h-1) ss +    mstep _ _      = return ()++renderLine :: DrawWordF -> Int -> [Tile] +	   -> RenderScalingT (Drawing Double) ()+renderLine fn h ts = mstep 0 ts+  where+    mstep x (Word rgb n:xs) = draw1 fn rgb n (x,h) >> mstep (x+n) xs+    mstep x (Space n:xs)    = mstep (x+n) xs  +    mstep _ []              = return ()++draw1 :: DrawWordF -> RGBi -> Int -> (Int,Int) +      -> RenderScalingT (Drawing Double) () +draw1 fn rgb n (x,y)  = +    scalePt x y >>= \pt -> scaleX n >>= \w -> unitY >>= \h ->  +    draw $ fn rgb w h n `at` pt+

@@ -0,0 +1,139 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Microprint.Teletype+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- A drawing monad where drawing is analogous to a /teletype/ +-- printing characters, spaces and linebreaks one at a time.+--+--------------------------------------------------------------------------------++module Wumpus.Microprint.Teletype+  (++    Teletype+  , runTeletype+  , execTeletype++  , Tile(..)+  , Height+  , linebreak+  , setRGB+  , char+  , space++  ) where++import Wumpus.Microprint.Datatypes++import Wumpus.Core				-- package: wumpus-core+import Wumpus.Core.Colour ( black )++import Wumpus.Basic.Utils.HList			-- package: wumpus-basic++import Control.Applicative+import Control.Monad+++-- Interim version without colour annotation...+--+-- Note could start with Space S0 - as spaces aren\'t printed (S0 0) is not a problem +-- +data TileTip = Sp Int | Wo Int+  deriving (Eq,Show)+++type Trace      = (H [Tile], H Tile)+type State      = (RGBi, Height, TileTip)++-- | Build a /microprint/ within a monad...+--+-- Drawings are made in a /teletype/ fashion emitting a character,+-- space or lineMicroprint-break at each step.+--+newtype Teletype a = Teletype { +          getTeletype :: Trace -> State -> (a,Trace,State) }++instance Functor Teletype where+  fmap f m = Teletype $ \w s -> +                let (a,w',s') = getTeletype m w s in (f a,w',s')++instance Applicative Teletype where+  pure a    = Teletype $ \w s -> (a,w,s)+  mf <*> ma = Teletype $ \w s -> let (f,w1,s1) = getTeletype mf w  s+     	      	       	      	     (a,w2,s2) = getTeletype ma w1 s1+				  in (f a,w2,s2)++instance Monad Teletype where+  return a = Teletype $ \w s -> (a,w,s)+  m >>= k  = Teletype $ \w s -> let (a,w1,s1) = getTeletype m w s +                                 in (getTeletype . k) a w1 s1+++runTeletype :: Teletype a -> (a,GreekText)+runTeletype m = post $ getTeletype m (emptyH,emptyH) (black,1,Sp 0)+  where+    post (a, (u,v), (rgb,h,tip)) = let v1 = snocTip v rgb tip+                                   in (a,(h,finalizeTrace (u,v1)))+++finalizeTrace :: Trace -> [[Tile]]+finalizeTrace (a,b) = toListH $ a `snocH` (toListH b)	++execTeletype :: Teletype a -> GreekText+execTeletype = snd . runTeletype+++snocTip :: H Tile -> RGBi -> TileTip -> H Tile+snocTip a _   (Sp n)  | n > 0 = a `snocH` (Space n)+snocTip a rgb (Wo n)  | n > 0 = a `snocH` (Word rgb n)+snocTip a _   _               = a ++++-- | Emit a linebreak in the output.+--+linebreak :: Teletype ()+linebreak = Teletype $ \(a,b) (rgb, h, tip) -> +    let b1 = snocTip b rgb tip +        ac = (a `snocH` toListH b1, emptyH)+    in ((), ac, (rgb, h+1, Sp 0))+++-- | Change the current drawing colour.+--+-- Note - it is permissible to change colour mid-word, but this +-- is the same as having a no-space break and forms a new word.+--+setRGB :: RGBi -> Teletype ()+setRGB rgb = Teletype $ \(a,b) (old,h,tip) -> +    ((), (a, snocTip b old tip), (rgb,h,Sp 0))+++-- | Draw a character - note in the microprint, characters will +-- be concatenated together to make a word.+--+char :: Teletype ()+char = Teletype $ \(a,b) (rgb,h,tip) ->+    case tip of +      Sp _ -> ((), (a, snocTip b rgb tip), (rgb,h,Wo 1))+      Wo n -> ((), (a,b), (rgb,h,Wo $ n+1))+  ++-- | Draw a space.+--+space :: Teletype ()+space = Teletype $ \(a,b) (rgb,h,tip) ->+    case tip of+      Sp n -> ((), (a,b), (rgb,h,Sp $ n+1))+      Wo _ -> ((), (a, snocTip b rgb tip), (rgb,h,Sp 1))++ +

@@ -0,0 +1,155 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Microprint.Tokenizer+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- Simple tokenizing builder.+--+--------------------------------------------------------------------------------++module Wumpus.Microprint.Tokenizer+  ( +    TokenizerConfig(..)+  , haskellTokenizer+  , runTokenizer ++  ) where+++import Wumpus.Microprint.Datatypes++import Wumpus.Basic.Utils.HList			-- package: wumpus-basic+import Wumpus.Core				-- package: wumpus-core++import Control.Applicative+import Control.Monad+import Data.Char ( isSpace )+import Data.List++data TokenizerConfig = TokenizerConfig+      { standard_colour		:: RGBi+      , sgl_comment_start 	:: String   -- note - can be a prefix of a word +      , comment_start	  	:: String+      , comment_end		:: String+      , comment_colour		:: RGBi+      }+++haskellTokenizer :: RGBi -> RGBi -> TokenizerConfig+haskellTokenizer std_rgb comment_rgb = TokenizerConfig +      { standard_colour		= std_rgb+      , sgl_comment_start 	= "--"  +      , comment_start	  	= "{-"+      , comment_end		= "-}"+      , comment_colour		= comment_rgb+      }+ ++data TokState = CommentML | CommentSL | Normal+  deriving (Eq,Ord,Show)++data St = St TokState (H Tile)++newtype Lexer a  = Lexer { getLexer :: TokenizerConfig -> St -> (a,St) }++instance Functor Lexer where+  fmap f m = Lexer $ \r s -> let (a,s1) = getLexer m r s in (f a, s1)++instance Applicative Lexer where+  pure a    = Lexer $ \_ s -> (a,s)+  mf <*> ma = Lexer $ \r s -> let (f,s1) = getLexer mf r s +     	      	      	    	  (a,s2) = getLexer ma r s1+			      in (f a, s2)++instance Monad Lexer where+  return a = Lexer $ \_ s -> (a,s)+  m >>= k  = Lexer $ \r s -> let (a,s1) = getLexer m r s+    	     	     	      in (getLexer . k) a r s1+++tellSpaces :: Int -> Lexer ()+tellSpaces i = Lexer $ \_ (St ts ac) -> +    let ac1 = snocH ac (Space i) in ((), St ts ac1) +++tellChars :: Int -> RGBi -> Lexer ()+tellChars i rgb = Lexer $ \_ (St ts ac) -> +    let ac1 = snocH ac (Word rgb i) in ((), St ts ac1)++askColour :: Lexer RGBi+askColour = Lexer $ \r s@(St ts _) -> +    case ts of+      Normal -> (standard_colour r, s)+      _      -> (comment_colour r,  s)+++asksTC :: (TokenizerConfig -> a) -> Lexer a+asksTC fn = Lexer $ \r s -> (fn r, s) ++setTokState :: TokState -> Lexer ()+setTokState st = Lexer $ \_ (St _ ac) -> ((),St st ac)  ++getTokState :: Lexer TokState +getTokState = Lexer $ \_ s@(St st _) -> (st,s)++runTokenizer :: TokenizerConfig -> String -> GreekText+runTokenizer cfg input = step Normal $ lines input+  where+    step _  []      = (0,[])+    step st (s:ss)  = let (st1,l1) = lexLine cfg st s+    	 	   	  (h,rest) = step st1 ss+                      in (h+1,l1:rest) ++lexLine :: TokenizerConfig -> TokState -> String -> (TokState,[Tile])+lexLine cfg st ss = +    let (_,St st1 hf) = runLexer cfg st ss in (st1, toListH hf) +  ++runLexer :: TokenizerConfig -> TokState -> String -> ((),St)+runLexer cfg ts ss = getLexer (lexer ss) cfg (St (normalize ts) emptyH) +  where+    normalize CommentSL = Normal+    normalize a         = a++lexer :: String -> Lexer ()+lexer (' ':xs)      = spaces 1 xs+lexer ('\t':xs)     = spaces 8 xs+lexer xs            = word xs+++spaces :: Int -> String -> Lexer ()+spaces n (' ':xs)   = spaces (n+1) xs+spaces n ('\t':xs)  = spaces (n+8) xs+spaces n xs         = tellSpaces n >> word xs++word :: String -> Lexer ()+word []	= return ()+word xs	= let (pre,rest) = break isSpace xs in do+    st <- getTokState+    when (st==Normal)  (testPrefix pre)+    rgb <- askColour+    tellChars (length pre) rgb+    when (st==CommentML) (testSuffix pre)+    spaces 0 rest++testPrefix :: String -> Lexer ()+testPrefix ss = +    asksTC sgl_comment_start >>= \a -> +    if isPrefixOf a ss then setTokState CommentSL+      else asksTC comment_start >>= \b ->+           if isPrefixOf b ss then setTokState CommentML+	      		      else return ()++testSuffix :: String -> Lexer ()+testSuffix ss = +    asksTC comment_end >>= \a ->+    if isSuffixOf a ss then setTokState Normal+                       else return ()+      

@@ -0,0 +1,28 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Microprint.VersionNumber+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- Version number+--+--------------------------------------------------------------------------------++module Wumpus.Microprint.VersionNumber+  ( +    wumpus_microprint_version++  ) where++-- | Version number+--+-- > (0,9,0)+--+wumpus_microprint_version :: (Int,Int,Int)+wumpus_microprint_version = (0,9,0)

@@ -1,5 +1,5 @@ name:             wumpus-microprint-version:          0.8.0+version:          0.9.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -12,19 +12,26 @@   A library to produce /microprints/ [1] sometimes known as    \"greek-text\".    .-  Note this library only provides the graphically half of the -  functionality needed to make microprints. There is no support -  for tokenizing input files, and at the moment it is really -  just a test bed for Wumpus.+  A rudimentary tokenizer is provided, but it is largely +  untested.    .-  Currently pictures are made within a monad providing /teletype/ -  style operations. Other methods of drawing are possible, but -  are yet to be implemented.+  Version 0.9.0 adds some new functionality, but the API is+  undercooked and is unsuitable for real use. The API will improve +  as Wumpus-Basic improves...   .+  .   \[1\] <http://scg.unibe.ch/archive/papers/Robb05b-microprintsESUG.pdf>   .   Changelog:   .+  0.8.0 to 0.9.0:+  .+  * Made internal modules visible rather than hidden and changed +    the module path to be @Wumpus.Microprint@ (lower-case p) +    rather then @Wumpus.MicroPrint@ (upper-case P).+  .+  * Added a more efficient builder than the Teletype.+  .   0.7.0 to 0.8.0:   .   * Internal changes to work with latest @Wumpus-Basic@.@@ -43,17 +50,19 @@   hs-source-dirs:     src   build-depends:      base              <  5,                        vector-space      >= 0.6,-                      wumpus-core       == 0.33.0,-                      wumpus-basic      == 0.8.0+                      wumpus-core       == 0.34.0,+                      wumpus-basic      == 0.9.0       exposed-modules:-    Wumpus.MicroPrint,-    Wumpus.MicroPrint.VersionNumber+    Wumpus.Microprint,+    Wumpus.Microprint.Datatypes,+    Wumpus.Microprint.Teletype,+    Wumpus.Microprint.Render,+    Wumpus.Microprint.Tokenizer,+    Wumpus.Microprint.VersionNumber    other-modules:-    Wumpus.MicroPrint.DrawMonad,-    Wumpus.MicroPrint.Render    extensions: