wumpus-basic 0.7.0 → 0.8.0

raw patch · 18 files changed

+924/−275 lines, 18 filesdep ~wumpus-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: wumpus-core

API changes (from Hackage documentation)

Files

• CHANGES +49/−0
• demo/ColourCharts.hs +3/−3
• demo/DotPic.hs +1/−1
• demo/Picture.hs +4/−4
• src/Wumpus/Basic/Arrows.hs +6/−6
• src/Wumpus/Basic/Arrows/Tips.hs +3/−3
• src/Wumpus/Basic/Dots.hs +7/−7
• src/Wumpus/Basic/Dots/Primitive.hs +16/−15
• src/Wumpus/Basic/Graphic/BaseTypes.hs +130/−75
• src/Wumpus/Basic/Graphic/Chain.hs +2/−2
• src/Wumpus/Basic/Graphic/Drawing.hs +151/−48
• src/Wumpus/Basic/Graphic/PrimGraphic.hs +42/−24
• src/Wumpus/Basic/Monads/TurtleMonad.hs +9/−3
• src/Wumpus/Basic/SafeFonts.hs +67/−49
• src/Wumpus/Basic/Text/LRSymbol.hs +213/−0
• src/Wumpus/Basic/Text/LRText.hs +197/−0
• src/Wumpus/Basic/VersionNumber.hs +2/−2
• wumpus-basic.cabal +22/−33

@@ -1,4 +1,53 @@ +0.7.0 to 0.8.0:++  * Re-introduced LRText and LRSymbol - they now work with +    Wumpus-Core\'s kerning support.+ +  * Changes to @Graphic.Basic.BaseTypes@ - @DrawingObject@ +    renamed to @DrawingF@. @HPrim@ wrapped as a newtype to +    support a Monoid instance. Removed @appendGraphic@ and @gcat@ +    as they can be achieved with @mappend@ and @mconcat@. +    @appendAt@ renamed to @lgappend@. @PointT@ remaned to +    @PointF@.++  * Changes to @Graphic.Basic.Drawing@ - @drawAt@, @drawAtImg@, +    @drawConn@, @drawConnImg@ all removed. They are replaced +    by @draw@ and @drawi@ together with then new @at@ and @conn@+    combinators.++  * Changes to @Basic.Graphic.PrimGraphic@ - @localDrawingContext@+    renamed to @localLG@ and moved to @Basic.Graphic.BaseTypes@.++  * Updates to @Basic.SafeFonts@ to work with changes to +    @Wumpus.Core@.++0.6.0 to 0.7.0:++  * Major rework of Graphic types, the old types (AGraphic, +    GraphicF etc.) and the old drawing monads have been removed. +    The new types are based on the AGraphic and related types but +    their implementation is different. The new types track the +    /graphics state/ within the type (the DrawingContext) plus +    how to draw themselves. For real drawings, graphics are +    collected with a Writer-like monad the @Basic.Graphic.Drawing@ +    monad which replaces the DrawingCtx and Trace monads. The +    Turtle monad remains and has been updated to work with the new+    drawing monads.++  * LRText and LRSymbol modules temporarily removed as they +    contradict the new, optimized kerning functionality in +    @Wumpus.Core@.++0.5.0 to 0.6.0:++  * Updates to work with wumpus-core-0.30.0.++  * The code from @Basic.Graphic@ has been moved in to +    @Basic.Graphic.Primitive@ - this module is due a major +    overhaul. @Basic.Graphic@ is now an /import/ shim for+    @Basic.Graphic.Primitive@.+ 0.4.0 to 0.5.0:    * Re-worked the PictureLanguage module.

@@ -1,6 +1,6 @@ {-# OPTIONS -Wall #-} -module ColourChart where+module ColourCharts where  import ColourDefns @@ -41,8 +41,8 @@ colourSample :: String -> RGBi -> ChainT Double (Drawing Double) () colourSample name rgb = localCtx (secondaryColour rgb) $ do      { pt <- position -    ; drawAt pt (borderedRectangle 15 10)-    ; drawAt (displace 20 2 pt) (textline name)+    ; draw $ borderedRectangle 15 10 `at` pt+    ; draw $ textline name `at` displace 20 2 pt      }      

@@ -64,7 +64,7 @@            => DotLocImage u -> [Point2 u] -> Picture u makeDotPic dotImg xs = liftToPictureU $ execDrawing std_ctx $ do      dashline-    mapM_ (\pt -> drawAtImg pt dotImg) xs+    mapM_ (\pt -> drawi $ dotImg `ati` pt) xs   where     dashline = localCtx attrUpd (draw $ openStroke $ vertexPath xs) 

@@ -130,22 +130,22 @@ picAnno pic msg = alignHSep HCenter 30 pic lbl   where     lbl = liftToPictureU $ execDrawing pic_drawing_ctx $ -            drawAt zeroPt (textline msg)+            draw $ textline msg `at` zeroPt   rect_red :: DPicture rect_red = liftToPictureU $ execDrawing pic_drawing_ctx $                localCtx (secondaryColour indian_red)-                       (drawAt (P2 0 10) $ borderedRectangle 30 10)+                       (draw $ borderedRectangle 30 10 `at` (P2 0 10))                   rect_green :: DPicture rect_green = liftToPictureU $ execDrawing pic_drawing_ctx $                localCtx (secondaryColour olive_drab)-                       (drawAt (P2 10 10) $ borderedRectangle 15 15)+                       (draw $ borderedRectangle 15 15 `at` (P2 10 10))   rect_blue :: DPicture rect_blue = liftToPictureU $ execDrawing pic_drawing_ctx $                localCtx (secondaryColour powder_blue)-                       (drawAt (P2 10 0) $ borderedRectangle 20 30)+                       (draw $ borderedRectangle 20 30 `at` (P2 10 0)) 

@@ -46,10 +46,10 @@ import Wumpus.Core                      -- package: wumpus-core  import Control.Applicative-+import Data.Monoid -liftPathF :: PathF u -> ConnDrawingObject u (Path u)-liftPathF pF p1 p2 = DrawingObject $ \ _ -> pF p1 p2+liftPathF :: PathF u -> ConnDrawingF u (Path u)+liftPathF pF p1 p2 = pureDF $ pF p1 p2  line :: Num u => PathF u -> ConnImage u (Path u) line pathF = intoConnImage (liftPathF pathF) (pathGraphic pathF)@@ -58,7 +58,7 @@ -- Here the path is already shortened - we have accounted for the -- points already, so it is just a graphic.  lineTipR :: Num u => Path u -> Graphic u -> Graphic u-lineTipR bpath tip = openStroke (toPrimPathU bpath) `appendGraphic` tip+lineTipR bpath tip = openStroke (toPrimPathU bpath) `mappend` tip      @@ -74,10 +74,10 @@ -- path segments. -- rightPathProps :: (Real u, Floating u, FromPtSize u) -               => PathF u -> ConnDrawingObject u (Path u,Radian)+               => PathF u -> ConnDrawingF u (Path u,Radian) rightPathProps pathF p1 p2 =      (\h sw -> (shortenPath h sw, calcTheta h))-      <$> asksObj lowerxHeight <*> asksObj (line_width . stroke_props)  +      <$> asksDF lowerxHeight <*> asksDF (line_width . stroke_props)     where     long_path          = pathF p1 p2       shortenPath lxh sw = shortenR (lxh + (realToFrac sw)) long_path 

@@ -47,11 +47,11 @@ -- | tripoints takes dimensions from the xlowerHeight. -- tripoints :: (Floating u, FromPtSize u)-          => Radian -> Radian -> LocDrawingObject u (Point2 u, Point2 u)+          => Radian -> Radian -> LocDrawingF u (Point2 u, Point2 u) tripoints triang theta tip =      (\h -> let d = h / (fromRadian $ cos halfang)             in (tip .-^ v1 d, tip .-^ v2 d))-      <$> asksObj lowerxHeight+      <$> asksDF lowerxHeight   where     halfang = 0.5 * triang     v1 d    = avec (theta + halfang) d@@ -124,7 +124,7 @@  perp :: (Floating u, FromPtSize u) => Radian -> LocGraphic u perp theta pt =  -    asksObj lowerxHeight >>= \ h -> +    asksDF lowerxHeight >>= \ h ->      let v = makeV h in openStroke $ vertexPath [ pt .+^ v, pt .-^ v]   where     makeV h  = avec (theta + pi/2) (0.5 * h)

@@ -139,8 +139,8 @@                              $ rectangleLines ctr hw hh  rectangleLDO :: (Real u, Floating u) -             => u -> u -> LocDrawingObject u (DotAnchor u)-rectangleLDO w h pt = liftDrawingObject $ rectangleAnchor (w*0.5) (h*0.5) pt+             => u -> u -> LocDrawingF u (DotAnchor u)+rectangleLDO w h pt = pureDF $ rectangleAnchor (w*0.5) (h*0.5) pt   circleAnchor :: Floating u => u -> Point2 u -> DotAnchor u@@ -148,8 +148,8 @@                                  (\theta -> ctr .+^ (avec theta rad))                                  (radialCardinal rad ctr) -circleLDO :: (Floating u, FromPtSize u) => LocDrawingObject u (DotAnchor u)-circleLDO pt = (\diam -> circleAnchor (diam * 0.5) pt) <$> asksObj markHeight +circleLDO :: (Floating u, FromPtSize u) => LocDrawingF u (DotAnchor u)+circleLDO pt = (\diam -> circleAnchor (diam * 0.5) pt) <$> asksDF markHeight    @@ -161,13 +161,13 @@  dotChar :: (Floating u, Real u, FromPtSize u)          => Char -> DotLocImage u-dotChar ch pt = asksObj (textDimensions [ch]) >>= \(w,h) -> +dotChar ch pt = asksDF (textDimensions [ch]) >>= \(w,h) ->                  intoLocImage (rectangleLDO w h) (markChar ch) pt   dotText :: (Floating u, Real u, FromPtSize u)          => String -> DotLocImage u -dotText ss pt = asksObj (textDimensions ss) >>= \(w,h) -> +dotText ss pt = asksDF (textDimensions ss) >>= \(w,h) ->                  intoLocImage (rectangleLDO w h) (markText ss) pt  @@ -201,7 +201,7 @@   dotSquare :: (Floating u, Real u, FromPtSize u) => DotLocImage u-dotSquare pt = asksObj markHeight >>= \ h ->+dotSquare pt = asksDF markHeight >>= \ h ->                intoLocImage (rectangleLDO h h) markSquare pt  

@@ -56,6 +56,7 @@  import Control.Applicative import Data.List+import Data.Monoid  -- Marks should be the height of a lower-case letter... @@ -81,11 +82,11 @@ -- | A mark is the height of a lowercase \'x\'. --  standardSize :: FromPtSize u => (u -> LocGraphic u) -> LocGraphic u-standardSize f = \pt -> asksObj markHeight >>= \h -> f h pt+standardSize f = \pt -> asksDF markHeight >>= \h -> f h pt  halfHeightSize :: (Fractional u, FromPtSize u)                 => (u -> LocGraphic u) -> LocGraphic u-halfHeightSize f = \pt -> asksObj markHeight >>= \h -> f (h * 0.5) pt+halfHeightSize f = \pt -> asksDF markHeight >>= \h -> f (h * 0.5) pt   @@ -101,7 +102,7 @@ -- Note - eta-expanded (?) -- markText :: (Fractional u, FromPtSize u) => String -> LocGraphic u-markText ss pt = asksObj (textDimensions ss) >>= \(w,h) -> +markText ss pt = asksDF (textDimensions ss) >>= \(w,h) ->                   shiftOrigin (0.5 * (-w)) (0.5 * (-h)) (textline ss) pt  @@ -125,17 +126,17 @@  markX :: (Fractional u, FromPtSize u) => LocGraphic u markX = standardSize (\h -> let w = 0.75 * h in-                            axialLine (vec w h) `appendAt` axialLine (vec (-w) h))+                            axialLine (vec w h) `lgappend` axialLine (vec (-w) h))    markPlus :: (Fractional u, FromPtSize u) =>  LocGraphic u-markPlus = markVLine `appendAt` markHLine+markPlus = markVLine `lgappend` markHLine   markCross :: (Floating u, FromPtSize u) =>  LocGraphic u markCross = standardSize -             (\h -> axialLine (avec ang h) `appendAt` axialLine (avec (-ang) h))+             (\h -> axialLine (avec ang h) `lgappend` axialLine (avec (-ang) h))   where     ang = pi*0.25   @@ -144,10 +145,10 @@ -- needs horizontal pinch...  pathDiamond :: (Fractional u, FromPtSize u) -            => Point2 u -> DrawingObject (PrimPath u)+            => Point2 u -> DrawingF (PrimPath u) pathDiamond pt = (\h -> let hh    = 0.66 * h; hw = 0.5 * h                          in vertexPath [dvs hh, dve hw,dvn hh, dvw hw])-                   <$> asksObj markHeight+                   <$> asksDF markHeight   where     dvs hh = pt .+^ vvec (-hh)     dve hw = pt .+^ hvec hw@@ -189,15 +190,15 @@   markPentagon :: (Floating u, FromPtSize u) => LocGraphic u-markPentagon pt = asksObj markHeight >>= \h ->+markPentagon pt = asksDF markHeight >>= \h ->                   closedStroke $ vertexPath $ polygonPoints 5 (0.5*h) pt      markStar :: (Floating u, FromPtSize u) => LocGraphic u -markStar pt = asksObj markHeight >>= \h -> -              let (p:ps) = polygonPoints 5 (0.5*h) pt in gcat (fn p) $ map fn ps+markStar pt = asksDF markHeight >>= \h -> +              let ps = polygonPoints 5 (0.5*h) pt in mconcat $ map fn ps   where     fn p1  = openStroke $ path pt [lineTo p1]  @@ -205,7 +206,7 @@   markAsterisk :: (Floating u, FromPtSize u) => LocGraphic u-markAsterisk = standardSize (\h -> lineF1 h `appendAt` lineF2 h `appendAt` lineF3 h)+markAsterisk = standardSize (\h -> lineF1 h `lgappend` lineF2 h `lgappend` lineF3 h)   where     ang       = (pi*2) / 6     lineF1 z  = axialLine (vvec z)@@ -215,15 +216,15 @@   markOPlus :: (Fractional u, FromPtSize u) => LocGraphic u-markOPlus = markCircle `appendAt` markPlus+markOPlus = markCircle `lgappend` markPlus   markOCross :: (Floating u, FromPtSize u) => LocGraphic u-markOCross = markCircle `appendAt` markCross+markOCross = markCircle `lgappend` markCross   markFOCross :: (Floating u, FromPtSize u) => LocGraphic u-markFOCross = markCross `appendAt` markBCircle +markFOCross = markCross `lgappend` markBCircle    -- bkCircle :: (Fractional u, FromPtSize u) => LocGraphic u

@@ -23,28 +23,33 @@           HPrim-  , Point2T-  , DPoint2T+  , hprimToList+  , singleH -  , DrawingObject(..)-  , LocDrawingObject-  , DLocDrawingObject+  , Point2F+  , DPoint2F -  , liftDrawingObject +  , DrawingF+  , LocDrawingF+  , DLocDrawingF +  , runDF+  , pureDF +  , askDF+  , asksDF+  , localDF+   , Graphic   , DGraphic-  , appendGraphic-  , gcat   -  , asksObj-  , localCtxObj    , runGraphic+  , xlinkGraphic    , LocGraphic   , DLocGraphic-  , appendAt+  , localLG+  , lgappend    , Image   , DImage@@ -54,9 +59,10 @@   , runImage   , intoImage   , intoLocImage+  , xlinkImage -  , ConnDrawingObject-  , DConnDrawingObject+  , ConnDrawingF+  , DConnDrawingF   , ConnGraphic   , DConnGraphic   , ConnImage@@ -73,9 +79,7 @@   import Control.Applicative---+import Data.Monoid   @@ -93,79 +97,118 @@ -- representation, and a Hughes list which supports -- efficient concatenation is wise. ---type HPrim u = H (PrimElement u)+newtype HPrim u = HPrim { getHPrim :: H (PrimElement u) } +-- Note - only a Monoid instance for HPrim - they cannot be +-- shown, fmapped etc. --- | Point transformation function.----type Point2T u = Point2 u -> Point2 u+instance Monoid (HPrim u) where+  mempty          = HPrim emptyH+  ha `mappend` hb = HPrim $ getHPrim ha `appendH` getHPrim hb -type DPoint2T = Point2T Double +hprimToList :: HPrim u -> [PrimElement u]+hprimToList = toListH . getHPrim -newtype DrawingObject a = DrawingObject { -          getDrawingObject :: DrawingContext -> a } +singleH :: PrimElement u -> HPrim u+singleH = HPrim . wrapH  +-- | Point transformation function.+--+type Point2F u = Point2 u -> Point2 u -type LocDrawingObject u a = Point2 u -> DrawingObject a +type DPoint2F = Point2F Double -type DLocDrawingObject a = LocDrawingObject Double a+--------------------------------------------------------------------------------+-- +-- | Drawings in Wumpus-Basic have an implicit /graphics state/ +-- the @DrawingContext@, the most primitive building block is +-- a function from the DrawingContext to some polymorphic answer.+-- +-- This functional type is represented concretely as @DrawingF@.+-- +-- > DrawingF :: DrawingContext -> a +--+newtype DrawingF a = DrawingF { getDrawingF :: DrawingContext -> a }  -instance Functor DrawingObject where-  fmap f ma = DrawingObject $ \ctx -> f $ getDrawingObject ma ctx +instance Functor DrawingF where+  fmap f ma = DrawingF $ \ctx -> f $ getDrawingF ma ctx  +-- The monoid instance seems sensible...+--+instance Monoid a => Monoid (DrawingF a) where +  mempty          = DrawingF $ \_   -> mempty+  fa `mappend` fb = DrawingF $ \ctx -> +                      getDrawingF fa ctx `mappend` getDrawingF fb ctx  -- Applicative -instance Applicative DrawingObject where-  pure a    = DrawingObject $ \_   -> a-  mf <*> ma = DrawingObject $ \ctx -> let f = getDrawingObject mf ctx-                                          a = getDrawingObject ma ctx-                                      in f a+instance Applicative DrawingF where+  pure a    = DrawingF $ \_   -> a+  mf <*> ma = DrawingF $ \ctx -> let f = getDrawingF mf ctx+                                     a = getDrawingF ma ctx+                                 in f a  -- Monad  -instance Monad DrawingObject where-  return a  = DrawingObject $ \_   -> a-  ma >>= k  = DrawingObject $ \ctx -> let a = getDrawingObject ma ctx-                                      in (getDrawingObject . k) a ctx +instance Monad DrawingF where+  return a  = DrawingF $ \_   -> a+  ma >>= k  = DrawingF $ \ctx -> let a = getDrawingF ma ctx+                                 in (getDrawingF . k) a ctx  +-- | Run a /Drawing Function/ with the supplied /Drawing Context/.+--+runDF :: DrawingContext -> DrawingF a -> a+runDF ctx df = getDrawingF df ctx -liftDrawingObject :: a -> DrawingObject a-liftDrawingObject a = DrawingObject $ \ _ctx -> a  --- Simple drawing - representing one or more prims+-- | Wrap a value into a DrawingF.+--+-- Note the value is /pure/ it does depend on the DrawingContext+-- (it is /context free/).+--+pureDF :: a -> DrawingF a+pureDF a = DrawingF $ \ _ctx -> a  -type Graphic u = DrawingObject (HPrim u)+askDF :: DrawingF DrawingContext+askDF = DrawingF id -type DGraphic = Graphic Double+asksDF :: (DrawingContext -> a) -> DrawingF a+asksDF fn = DrawingF $ \ctx -> fn ctx +localDF :: (DrawingContext -> DrawingContext) +        -> DrawingF a -> DrawingF a+localDF upd gf = DrawingF $ \ctx -> getDrawingF gf (upd ctx) -appendGraphic :: Graphic u -> Graphic u -> Graphic u-appendGraphic gf1 gf2 = DrawingObject $ \ctx ->          -      (getDrawingObject gf1 ctx) `appendH` (getDrawingObject gf2 ctx) -gcat :: Graphic u -> [Graphic u] -> Graphic u-gcat a = step a -  where-    step ac []     = ac-    step ac (x:xs) = step (ac `appendGraphic` x) xs-  -asksObj :: (DrawingContext -> a) -> DrawingObject a-asksObj fn = DrawingObject $ \ctx -> fn ctx+type LocDrawingF u a = Point2 u -> DrawingF a  -localCtxObj :: (DrawingContext -> DrawingContext) -            -> DrawingObject a -> DrawingObject a-localCtxObj upd gf = DrawingObject $ \ctx -> getDrawingObject gf (upd ctx)+type DLocDrawingF a = LocDrawingF Double a ++--------------------------------------------------------------------------------+++-- Simple drawing - representing one or more prims++type Graphic u = DrawingF (HPrim u)++type DGraphic = Graphic Double++ runGraphic :: DrawingContext -> Graphic u -> HPrim u-runGraphic ctx gf = (getDrawingObject gf) ctx+runGraphic ctx gf = (getDrawingF gf) ctx  +xlinkGraphic :: XLink -> Graphic u -> Graphic u+xlinkGraphic xlink gf = askDF >>= \ctx -> +    let xs = hprimToList $ runGraphic ctx gf in pureDF (singleH $ xlinkGroup xlink xs)++ --------------------------------------------------------------------------------  @@ -180,14 +223,17 @@ type DLocGraphic = LocGraphic Double  +localLG :: +    (DrawingContext -> DrawingContext) -> LocGraphic u -> LocGraphic u+localLG upd img = \pt -> localDF upd (img pt)    -- | Composition operator for LocGraphic - both LocGraphics -- are drawn at the same origin and the results concatenated. -- ---appendAt :: LocGraphic u -> LocGraphic u -> LocGraphic u-appendAt f g = \pt -> f pt `appendGraphic` g pt+lgappend :: LocGraphic u -> LocGraphic u -> LocGraphic u+lgappend f g = \pt -> f pt `mappend` g pt   --------------------------------------------------------------------------------@@ -197,7 +243,7 @@ -- typical example - nodes are drawing but the also support  -- taking anchor points. ---type Image u a = DrawingObject (a, HPrim u)+type Image u a = DrawingF (a, HPrim u)  type DImage a = Image Double a @@ -206,24 +252,31 @@ type DLocImage a = LocImage Double a  runImage :: DrawingContext -> Image u a -> (a,HPrim u)-runImage ctx img = (getDrawingObject img) ctx+runImage ctx img = (getDrawingF img) ctx  -intoImage :: DrawingObject a -> Graphic u -> Image u a-intoImage f g = DrawingObject $ \ctx -> -    let a = getDrawingObject f ctx; o = getDrawingObject g ctx in (a,o)+intoImage :: DrawingF a -> Graphic u -> Image u a+intoImage f g = DrawingF $ \ctx -> +    let a = getDrawingF f ctx; o = getDrawingF g ctx in (a,o)  -intoLocImage :: LocDrawingObject u a -> LocGraphic u -> LocImage u a-intoLocImage f g pt = DrawingObject $ \ctx -> -    let a = getDrawingObject (f pt) ctx-        o = getDrawingObject (g pt) ctx -    in (a,o)+intoLocImage :: LocDrawingF u a -> LocGraphic u -> LocImage u a+intoLocImage f g pt = DrawingF $ \ctx -> +    let a = getDrawingF (f pt) ctx; o = getDrawingF (g pt) ctx in (a,o) -type ConnDrawingObject u a = Point2 u -> Point2 u -> DrawingObject a -type DConnDrawingObject a = ConnDrawingObject Double a+xlinkImage :: XLink -> Image u a -> Image u a+xlinkImage xlink img = askDF >>= \ctx -> +    let (a,hp) = runImage ctx img +    in pureDF (a, singleH $ xlinkGroup xlink $ hprimToList hp) +--------------------------------------------------------------------------------+--++type ConnDrawingF u a = Point2 u -> Point2 u -> DrawingF a++type DConnDrawingF a = ConnDrawingF Double a+ -- | ConnGraphic is a connector drawn between two points  -- contructing a Graphic. --@@ -239,8 +292,10 @@ type DConnImage a = ConnImage Double a  -intoConnImage :: ConnDrawingObject u a -> ConnGraphic u -> ConnImage u a-intoConnImage f g p1 p2 = DrawingObject $ \ctx -> -    let a = getDrawingObject (f p1 p2) ctx-        o = getDrawingObject (g p1 p2) ctx -    in (a,o)+intoConnImage :: ConnDrawingF u a -> ConnGraphic u -> ConnImage u a+intoConnImage f g p1 p2 = DrawingF $ \ctx -> +    let a = getDrawingF (f p1 p2) ctx; o = getDrawingF (g p1 p2) ctx in (a,o)++++

@@ -38,7 +38,7 @@   newtype ChainT u m a = ChainT { -          getChainT :: Point2T u -> Point2 u -> m (a, Point2 u) }+          getChainT :: Point2F u -> Point2 u -> m (a, Point2 u) }   type instance MonUnit (ChainT u m) = u@@ -68,7 +68,7 @@   position = ChainT $ \rf s -> return (s, rf s)  runChainT :: Monad m -          => Point2T u -> Point2 u -> ChainT u m a -> m a+          => Point2F u -> Point2 u -> ChainT u m a -> m a runChainT f pt0 ma = liftM fst $ getChainT ma f pt0  horizontal :: (Num u, Monad m)

@@ -14,13 +14,9 @@ -- 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.---+-- Drawing with /trace/ - a Writer like monad collecting +-- intermediate graphics - and /drawing context/ - a reader monad+-- of attributes - font_face, fill_colour etc. -- -------------------------------------------------------------------------------- @@ -33,14 +29,27 @@   , execDrawing   , runDrawingT   , execDrawingT++  , runFdcDrawing+  , execFdcDrawing+  , runFdcDrawingT+  , execFdcDrawingT+   , liftToPictureU+  , liftToPictureMb+  , mbPictureU     , draw-  , drawAt-  , drawAtImg-  , drawConn-  , drawConnImg+  , xdraw+  , drawi+  , xdrawi++  , at+  , ati+  , conn+   , node+  , nodei    ) where @@ -48,14 +57,13 @@ 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-+import Data.Monoid   @@ -129,24 +137,20 @@  -- 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/.+-- Note -  @ state `mappend` a @ means the first expression in a +-- monadic drawing is the first element in the output file. It is+-- also \*\* at the back \*\* in the the Z-Order. ----- Ideally some control over the Z-Order, possibly adding --- /layers/ to the drawing model would be valuable. +-- Some control over the Z-Order, possibly by adding /layers/ to +-- the drawing model would be valuable.  --   instance TraceM (Drawing u) where-  trace a = Drawing $ \_ s -> ((),s `appendH` a)+  trace a = Drawing $ \_ s -> ((), s `mappend` a)   instance Monad m => TraceM (DrawingT u m) where-  trace a = DrawingT $ \_ s -> return ((),s `appendH` a)+  trace a = DrawingT $ \_ s -> return ((), s `mappend` a)   @@ -176,7 +180,7 @@   runDrawing :: DrawingContext -> Drawing u a -> (a, HPrim u)-runDrawing ctx ma = getDrawing ma ctx emptyH+runDrawing ctx ma = getDrawing ma ctx mempty  execDrawing :: DrawingContext -> Drawing u a -> HPrim u execDrawing ctx ma = snd $ runDrawing ctx ma@@ -184,50 +188,149 @@   runDrawingT :: Monad m => DrawingContext -> DrawingT u m a -> m (a, HPrim u) -runDrawingT ctx ma = getDrawingT ma ctx emptyH+runDrawingT ctx ma = getDrawingT ma ctx mempty  execDrawingT :: Monad m => DrawingContext -> DrawingT u m a -> m (HPrim u) execDrawingT ctx ma = liftM snd $ runDrawingT ctx ma +-- | Run the Drawing generating a Picture /within/ a +-- \"font delta context\" using the font-family and font-size +-- from the intial DrawingContext.+--+-- Using a /font delta context/ can reduce the code size of the+-- generated SVG file (PostScript ignores the FDC).+--+runFdcDrawing :: (Real u, Floating u, FromPtSize u)+             => DrawingContext -> Drawing u a -> (a, Maybe (Picture u))+runFdcDrawing ctx ma = +    let (a,hp) = runDrawing ctx ma+        ps     = hprimToList hp+        fdc    = font_props ctx+    in if null ps then (a, Nothing)+                 else (a, Just $ fontDeltaContext fdc $ frame ps) +-- | /exec/ version of 'runFdcContext'.+--+execFdcDrawing :: (Real u, Floating u, FromPtSize u)+             => DrawingContext -> Drawing u a -> Maybe (Picture u)+execFdcDrawing ctx ma = snd $ runFdcDrawing ctx ma++-- | Transformer version of 'runFdcDrawing'.+--+runFdcDrawingT :: (Real u, Floating u, FromPtSize u, Monad m)+             => DrawingContext -> DrawingT u m a -> m (a, Maybe (Picture u))+runFdcDrawingT ctx ma = +    runDrawingT ctx ma >>= \(a,hp) -> +    let ps     = hprimToList hp+        fdc    = font_props ctx+    in if null ps then return (a, Nothing)+                  else return (a, Just $ fontDeltaContext fdc $ frame ps)+  +-- | Transformer version of 'execFdcDrawing'.+--       +execFdcDrawingT :: (Real u, Floating u, FromPtSize u, Monad m)+             => DrawingContext -> DrawingT u m a -> m (Maybe (Picture u))+execFdcDrawingT ctx ma = liftM snd $ runFdcDrawingT ctx ma++-- | /Unsafe/ promotion of @HPrim@ to @Picture@.+--+-- If the HPrim is empty, a run-time error is thrown.+--  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+liftToPictureU hf = +    let prims = hprimToList hf in if null prims then errK else frame prims   where-    errK = error "liftToPictureU - empty prims list."+    errK = error "toPictureU - empty prims list." +-- | /Safe/ promotion of @HPrim@ to @(Maybe Picture)@.+--+-- If the HPrim is empty, then @Nothing@ is returned.+-- +liftToPictureMb :: (Real u, Floating u, FromPtSize u) +               => HPrim u -> Maybe (Picture u)+liftToPictureMb hf = let prims = hprimToList hf in +    if null prims then Nothing else Just (frame prims)++++-- | /Unsafe/ promotion of @(Maybe Picture)@ to @Picture@.+--+-- This is equivalent to:+--+-- > fromMaybe (error "empty") $ pic+--+-- This function is solely a convenience, using it saves one +-- import and a few characters.+--+-- If the supplied value is @Nothing@ a run-time error is thrown.+-- +mbPictureU :: (Real u, Floating u, FromPtSize u) +           => Maybe (Picture u) -> Picture u+mbPictureU Nothing  = error "mbPictureU - empty picture."+mbPictureU (Just a) = a+++ -------------------------------------------------------------------------------- +-- | Draw a Graphic taking the drawing style from the +-- /drawing context/. +--+-- This operation is analogeous to @tell@ in a Writer monad.+--  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))+-- | Hyperlink version of 'draw'.+--+xdraw :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) +      => XLink -> Graphic u -> m ()+xdraw xl gf = draw (xlinkGraphic xl gf) -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-            +-- | Draw an Image taking the drawing style from the +-- /drawing context/. +--+-- The graphic representation of the Image is drawn in the Trace +-- monad, and the result is returned.+-- +drawi ::  (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Image u a -> m a+drawi img = askCtx >>= \ctx -> +            let (a,o) = runImage ctx img in trace o >> return a +-- | Hyperlink version of 'drawi'.+--+xdrawi ::  (TraceM m, DrawingCtxM m, u ~ MonUnit m) +       => XLink -> Image u a -> m a+xdrawi xl img = drawi (xlinkImage xl img) ++++infixr 1 `at`, `ati`+at :: LocGraphic u -> Point2 u -> Graphic u+at = ($)++ati :: LocImage u a -> Point2 u -> Image u a+ati = ($)++++infixl 1 `conn`+conn :: ConnImage u a -> Point2 u -> LocImage u a+conn = ($)++ node :: (TraceM m, DrawingCtxM m, PointSupplyM m, u ~ MonUnit m)       => LocGraphic u -> m () node gfL = askCtx   >>= \ctx ->             position >>= \pt  -> trace (runGraphic ctx $ gfL pt) ++nodei :: (TraceM m, DrawingCtxM m, PointSupplyM m, u ~ MonUnit m) +     => LocImage u a -> m a+nodei imgL = askCtx   >>= \ctx -> +             position >>= \pt  -> +             let (a,o) = runImage ctx (imgL pt) in trace o >> return a 

@@ -29,12 +29,15 @@   , filledPath   , borderedPath   , textline+  , hkernline+  , vkernline++   , strokedEllipse   , filledEllipse     , borderedEllipse    , supplyPt-  , localDrawingContext   , localPoint   , displace @@ -58,7 +61,6 @@  import Wumpus.Basic.Graphic.DrawingContext import Wumpus.Basic.Graphic.BaseTypes-import Wumpus.Basic.Utils.HList  import Wumpus.Core                              -- package: wumpus-core @@ -70,62 +72,81 @@             => DrawingContext -> Graphic u -> Maybe (Picture u) drawGraphic ctx gf = post $ runGraphic ctx gf   where-    post hf = let xs = toListH hf in +    post hf = let xs = hprimToList hf in                if null xs then Nothing else Just (frame xs)  drawGraphicU :: (Real u, Floating u, FromPtSize u)               => DrawingContext -> Graphic u -> Picture u drawGraphicU ctx gf = post $ runGraphic ctx gf   where-    post hf = let xs = toListH hf in +    post hf = let xs = hprimToList hf in                if null xs then errK else frame xs     errK    = error "drawGraphicU - empty Graphic."  ++ -- having the same names is actually not so useful...  openStroke :: Num u => PrimPath u -> Graphic u-openStroke pp = (\rgb attr -> wrapH $ ostroke rgb attr pp) -                    <$> asksObj primary_colour <*> asksObj stroke_props+openStroke pp = (\rgb attr -> singleH $ ostroke rgb attr pp) +                    <$> asksDF primary_colour <*> asksDF stroke_props   closedStroke :: Num u => PrimPath u -> Graphic u-closedStroke pp = (\rgb attr -> wrapH $ cstroke rgb attr pp) -                      <$> asksObj primary_colour <*> asksObj stroke_props+closedStroke pp = (\rgb attr -> singleH $ cstroke rgb attr pp) +                      <$> asksDF primary_colour <*> asksDF stroke_props   filledPath :: Num u => PrimPath u -> Graphic u-filledPath pp = (\rgb -> wrapH $ fill rgb pp) -                    <$> asksObj secondary_colour+filledPath pp = (\rgb -> singleH $ fill rgb pp) +                    <$> asksDF secondary_colour   borderedPath :: Num u => PrimPath u -> Graphic u borderedPath pp = -    (\frgb attr srgb -> wrapH $ fillStroke frgb attr srgb pp) -        <$> asksObj secondary_colour <*> asksObj stroke_props <*> asksObj primary_colour+    (\frgb attr srgb -> singleH $ fillStroke frgb attr srgb pp) +        <$> asksDF secondary_colour <*> asksDF stroke_props +                                    <*> asksDF primary_colour  +--------------------------------------------------------------------------------+-- + textline :: Num u => String -> LocGraphic u textline ss baseline_left =-    (\(rgb,attr) -> wrapH $ textlabel rgb attr ss baseline_left) -       <$> asksObj textAttr+    (\(rgb,attr) -> singleH $ textlabel rgb attr ss baseline_left) +       <$> asksDF textAttr +hkernline :: Num u => [KerningChar u] -> LocGraphic u+hkernline ks baseline_left = +    (\(rgb,attr) -> singleH $ hkernlabel rgb attr ks baseline_left) +       <$> asksDF textAttr +vkernline :: Num u => [KerningChar u] -> LocGraphic u+vkernline ks baseline_left = +    (\(rgb,attr) -> singleH $ vkernlabel rgb attr ks baseline_left) +       <$> asksDF textAttr+++--------------------------------------------------------------------------------++ strokedEllipse :: Num u => u -> u -> LocGraphic u strokedEllipse hw hh pt =  -    (\rgb attr -> wrapH $ strokeEllipse rgb attr hw hh pt) -       <$> asksObj primary_colour <*> asksObj stroke_props+    (\rgb attr -> singleH $ strokeEllipse rgb attr hw hh pt) +       <$> asksDF primary_colour <*> asksDF stroke_props  filledEllipse :: Num u => u -> u -> LocGraphic u filledEllipse hw hh pt =  -    (\rgb -> wrapH $ fillEllipse rgb hw hh pt) -       <$> asksObj secondary_colour+    (\rgb -> singleH $ fillEllipse rgb hw hh pt) +       <$> asksDF secondary_colour  borderedEllipse :: Num u => u -> u -> LocGraphic u borderedEllipse hw hh pt = -    (\frgb attr srgb -> wrapH $ fillStrokeEllipse frgb attr srgb hw hh pt) -        <$> asksObj secondary_colour <*> asksObj stroke_props -        <*> asksObj primary_colour+    (\frgb attr srgb -> singleH $ fillStrokeEllipse frgb attr srgb hw hh pt) +        <$> asksDF secondary_colour <*> asksDF stroke_props +        <*> asksDF primary_colour   --------------------------------------------------------------------------------@@ -142,9 +163,6 @@ displace dx dy (P2 x y) = P2 (x+dx) (y+dy)  -localDrawingContext :: -    (DrawingContext -> DrawingContext) -> LocGraphic u -> LocGraphic u-localDrawingContext upd img = \pt -> localCtxObj upd (img pt)   localPoint :: (Point2 u -> Point2 u) -> LocGraphic u -> LocGraphic u localPoint upd gf = \pt -> gf (upd pt)

@@ -133,6 +133,9 @@   trace a  = TurtleT $ \_ s -> trace a >> return ((),s)  +instance (Monad m, u ~ MonUnit m, Num u) => PointSupplyM (TurtleT u m) where+  position = getPos+ --------------------------------------------------------------------------------  @@ -171,19 +174,22 @@   yStep    = TurtleDrawing $ yStep  --- Lifters no longer supplied...+ -- TraceM   instance TraceM (TurtleDrawing u) where   trace a = TurtleDrawing $ trace a -- -- DrawingCtxM  instance DrawingCtxM (TurtleDrawing u) where   askCtx          = TurtleDrawing $ askCtx   localCtx ctx ma = TurtleDrawing $ localCtx ctx (getTurtleDrawing ma)++-- PointSupplyM++instance Num u => PointSupplyM (TurtleDrawing u) where+  position = getPos   runTurtleDrawing :: Num u 

@@ -36,7 +36,6 @@   , courierBoldOblique    -- * Symbol-  -- $symboldoc   , symbol    ) where@@ -45,95 +44,114 @@  import Wumpus.Core -{--- Times-Roman  Times-Italic  Times-Bold  Times-BoldItalic- Helvetica  Helvetica-Oblique  Helvetica-Bold  Helvetica-Bold-Oblique- Courier  Courier-Oblique  Courier-Bold  Courier-Bold-Oblique- Symbol+-- Supported fonts are:+--+-- Times-Roman  Times-Italic       Times-Bold      Times-BoldItalic+-- Helvetica    Helvetica-Oblique  Helvetica-Bold  Helvetica-Bold-Oblique+-- Courier      Courier-Oblique    Courier-Bold    Courier-Bold-Oblique+-- Symbol --} ----------------------------------------------------------------------------------- Times-Roman+--  +-- | Times-Roman+--  timesRoman :: FontFace-timesRoman = FontFace "Times-Roman" "Times New Roman" SVG_REGULAR---- Times Italic+timesRoman = +    FontFace "Times-Roman" "Times New Roman" SVG_REGULAR latin1_font_encoder +-- | Times Italic+-- timesItalic :: FontFace-timesItalic = FontFace "Times-Italic" "Times New Roman" SVG_ITALIC---- Times Bold-+timesItalic = +    FontFace "Times-Italic" "Times New Roman" SVG_ITALIC latin1_font_encoder+                       +-- | Times Bold+-- timesBold :: FontFace-timesBold = FontFace "Times-Bold" "Times New Roman" SVG_BOLD---- Times Bold Italic+timesBold = +    FontFace "Times-Bold" "Times New Roman" SVG_BOLD latin1_font_encoder +-- | Times Bold Italic+-- timesBoldItalic :: FontFace-timesBoldItalic = -    FontFace "Times-BoldItalic" "Times New Roman" SVG_BOLD_ITALIC+timesBoldItalic = FontFace "Times-BoldItalic" +                           "Times New Roman" +                           SVG_BOLD_ITALIC +                           latin1_font_encoder   -------------------------------------------------------------------------------- -- Helvetica +-- | Helvetica +-- helvetica :: FontFace-helvetica = FontFace "Helvetica" "Helvetica" SVG_REGULAR+helvetica = FontFace "Helvetica" "Helvetica" SVG_REGULAR latin1_font_encoder  --- Helvetica Oblique-+-- | Helvetica Oblique+-- helveticaOblique :: FontFace-helveticaOblique = FontFace "Helvetica-Oblique" "Helvetica" SVG_OBLIQUE---- Helvetica Bold+helveticaOblique = +    FontFace "Helvetica-Oblique" "Helvetica" SVG_OBLIQUE latin1_font_encoder +-- | Helvetica Bold+--  helveticaBold :: FontFace-helveticaBold = FontFace "Helvetica-Bold" "Helvetica" SVG_BOLD+helveticaBold = +    FontFace "Helvetica-Bold" "Helvetica" SVG_BOLD latin1_font_encoder  --- Helvetica Bold Oblique-+-- | Helvetica Bold Oblique+-- helveticaBoldOblique :: FontFace-helveticaBoldOblique = -    FontFace "Helvetica-Bold-Oblique" "Helvetica" SVG_BOLD_OBLIQUE+helveticaBoldOblique = FontFace "Helvetica-Bold-Oblique" +                                "Helvetica" +                                SVG_BOLD_OBLIQUE +                                latin1_font_encoder    ----------------------------------------------------------------------------------- Courier +-- | Courier+--  courier :: FontFace-courier = FontFace "Courier" "Courier New" SVG_REGULAR---- Courier Oblique+courier = FontFace "Courier" "Courier New" SVG_REGULAR latin1_font_encoder +-- | Courier Oblique+--  courierOblique :: FontFace-courierOblique = FontFace "Courier-Oblique" "Courier New" SVG_OBLIQUE---- Courier Bold+courierOblique = +    FontFace "Courier-Oblique" "Courier New" SVG_OBLIQUE latin1_font_encoder +-- | Courier Bold+--  courierBold :: FontFace-courierBold = FontFace "Courier-Bold" "Courier New" SVG_BOLD+courierBold = +    FontFace "Courier-Bold" "Courier New" SVG_BOLD latin1_font_encoder  --- Courier Bold Oblique-+-- | Courier Bold Oblique+--  courierBoldOblique :: FontFace-courierBoldOblique = -    FontFace "Courier-Bold-Oblique" "Courier New" SVG_BOLD_OBLIQUE+courierBoldOblique = FontFace "Courier-Bold-Oblique" +                              "Courier New" +                              SVG_BOLD_OBLIQUE +                              latin1_font_encoder  -------------------------------------------------------------------------------- -- Symbol --- $symboldoc--- Symbol does not appear to be well supported by SVG.--- It renders in Chrome but not in Firefox.-+-- | Symbol+--+-- Note - Symbol does not appear to be well supported by some SVG+-- renders. Seemingly Chrome is fine but Firefox defaults to some+-- serif font.+--  symbol :: FontFace-symbol = FontFace "Symbol" "Symbol" SVG_REGULAR+symbol = FontFace "Symbol" "Symbol" SVG_REGULAR symbol_font_encoder   

@@ -0,0 +1,213 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Text.LRSymbol+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Named literals from Symbol font, drawn with the LRText monad.+-- +-- Note - currently the techinique used here generates adequate+-- PostScript, but very ineficient SVG.+-- +-- Also uUpsilon is not mapped to the correct character...+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Text.LRSymbol+  ( ++  -- * Lower case Greek letters++    alpha+  , beta+  , gamma+  , delta+  , epsilon+  , zeta+  , eta+  , theta+  , iota+  , kappa+  , lambda+  , mu+  , nu+  , xi+  , pi+  , rho+  , sigma+  , tau+  , upsilon+  , phi+  , chi+  , psi+  , omega++  -- * Upper case Greek letters+  , uGamma+  , uDelta+  , uTheta+  , uLambda+  , uXi+  , uPi+  , uSigma+  , uUpsilon+  , uPhi+  , uPsi+  , uOmega++  , otimes+  , oplus++  ) where+++import Wumpus.Basic.Text.LRText+++import Prelude hiding ( pi )++-- Note - due to a optimization in Wumpus-Core, the PostScript+-- generated by the techinique here - writing a +-- (single-character) label one at a time - isn\'t too bad as +-- Wumpus-Core only issues a findfont command when the font +-- changes. +-- +-- However for SVG the result is very poor - one text element +-- including an orientation changing matrix transforming for +-- each character.+-- +-- Wumpus-Core\'s SVG rendering will work at some point.+-- +++--------------------------------------------------------------------------------+-- lower case+++alpha       :: Num u => TextM u ()+alpha       = symb 'a'++beta        :: Num u => TextM u ()+beta        = symb 'b'++gamma       :: Num u => TextM u ()+gamma       = symb 'g'++delta       :: Num u => TextM u ()+delta       = symb 'd'++epsilon     :: Num u => TextM u ()+epsilon     = symb 'e'++zeta        :: Num u => TextM u ()+zeta        = symb 'z'++eta         :: Num u => TextM u ()+eta         = symb 'h'++theta       :: Num u => TextM u ()+theta       = symb 'q'++iota        :: Num u => TextM u ()+iota        = symb 'i'++kappa       :: Num u => TextM u ()+kappa       = symb 'k'++lambda      :: Num u => TextM u ()+lambda      = symb 'l'++mu          :: Num u => TextM u ()+mu          = symb 'm'++nu          :: Num u => TextM u ()+nu          = symb 'n'++xi          :: Num u => TextM u ()+xi          = symb 'x'++pi          :: Num u => TextM u ()+pi          = symb 'p'++rho         :: Num u => TextM u ()+rho         = symb 'r'++sigma       :: Num u => TextM u ()+sigma       = symb 's'++tau         :: Num u => TextM u ()+tau         = symb 't'++upsilon     :: Num u => TextM u ()+upsilon     = symb 'u'++phi         :: Num u => TextM u ()+phi         = symb 'j'++chi         :: Num u => TextM u ()+chi         = symb 'c'++psi         :: Num u => TextM u ()+psi         = symb 'y'++omega       :: Num u => TextM u ()+omega       = symb 'w'+++--------------------------------------------------------------------------------+-- upper case++uGamma      :: Num u => TextM u ()+uGamma      = symb 'G'++uDelta      :: Num u => TextM u ()+uDelta      = symb 'D'++uTheta      :: Num u => TextM u ()+uTheta      = symb 'Q'++uLambda     :: Num u => TextM u ()+uLambda     = symb 'L'++uXi         :: Num u => TextM u ()+uXi         = symb 'X'++uPi         :: Num u => TextM u ()+uPi         = symb 'P'++uSigma      :: Num u => TextM u ()+uSigma      = symb 'S'++-- | Not working in PostScript, @\&\#161;@ works for SVG but +-- PostScript needs an encoding table for Symbol-Font not Latin1!+--+-- For PostScript, Latin1 @161@ maps to @exclamdown@ not +-- @Upsilon1@, extending Wumpus-Core to support this will require +-- quite some work...+--+uUpsilon    :: Num u => TextM u ()+uUpsilon    = symbEscInt 161++uPhi        :: Num u => TextM u ()+uPhi        = symb 'F'++uPsi        :: Num u => TextM u ()+uPsi        = symb 'Y'++uOmega      :: Num u => TextM u ()+uOmega      = symb 'W'+++--------------------------------------------------------------------------------++otimes      :: Num u => TextM u ()+otimes      = symbi 0xc4++oplus       :: Num u => TextM u ()+oplus       = symbi 0xc5

@@ -0,0 +1,197 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Text.LRText+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- LRText monad - left-to-right text, with kerning.+-- +-- Note - because Wumpus has no access to the metrics data inside+-- a font file, the default spacing is not good and it is +-- expected that kerning will need to be added per-letter for+-- variable width fonts.+--+-- This module makes precise text spacing \*possible\* - it does +-- not make it \*easy\*.+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.Text.LRText+  ( +++    TextM+  , runTextM+  , execTextM++  , kern+  , char+  , symb+  , symbi+  , symbEscInt++  ) where++import Wumpus.Basic.Graphic+import Wumpus.Basic.SafeFonts+import Wumpus.Basic.Utils.HList++import Wumpus.Core                              -- package: wumpus-core++import Control.Applicative+import Control.Monad+import Data.Char ( chr )+import Data.Monoid++++++-- Need a note in wumpus-core and here about space:preserve++-- Note - if we have font change (e.g. to symbol font) then we +-- have to generate more than one hkernline.+-- +-- If one wants to be really prissy about optimization, one could+-- generate two simultaneous and overlayed lines - one in regular +-- font, one in Symbol. +--+-- Result should be a LocGraphic (so cannot do a trace as we go). +--++-- Note - the the state tracks two kernlines: one for symbols,  ++data St u = St +      { delta_chr       :: !u+      , delta_sym       :: !u+      , acc_chr         :: H (KerningChar u)+      , acc_sym         :: H (KerningChar u)+      }+++data Env u = Env +      { char_width      :: !u+      , spacer_width    :: !u+      }++-- Note - unlike Turtle for example, Text is a monad not a +-- transformer.+--+-- The rationale for this is to avoid complications percolating +-- from the Drawing monad. It Text were built over the Drawing+-- monad what would it do on a font change, a colour change...+-- +-- That say Text must still be run /within/ the Drawing so it +-- can take the initial font size, stroke colour etc.+--++newtype TextM u a = TextM { getTextM :: Env u -> St u -> (a, St u) }++type instance MonUnit (TextM u) = u++instance Functor (TextM u) where+  fmap f mf = TextM $ \r s -> let (a,s') = getTextM mf r s in (f a,s')+++instance Applicative (TextM u) where+  pure a    = TextM $ \_ s -> (a,s)+  mf <*> ma = TextM $ \r s -> let (f,s')  = getTextM mf r s+                                  (a,s'') = getTextM ma r s'+                              in (f a,s'')++instance Monad (TextM u) where+  return a  = TextM $ \_ s -> (a,s)+  m >>= k   = TextM $ \r s -> let (a,s')  = getTextM m r s +                              in (getTextM . k) a r s'++                              +-- Note - post has to displace in the vertical to get the bottom +-- line at the base line...++runTextM :: (Num u, FromPtSize u, DrawingCtxM m, u ~ MonUnit m) +         => TextM u a -> m (a, LocGraphic u)+runTextM ma = askCtx >>= \ctx -> +    let e = runDF ctx envZero in post $ getTextM ma e stZero+  where+    post (a,st)  = let sG = updCtxSym $ mkHKern $ toListH $ acc_sym st+                       cG = mkHKern $ toListH $ acc_chr st+                   in return (a, sG `lgappend` cG)++    mkHKern []   = const mempty+    mkHKern xs   = hkernline xs++    updCtxSym lg = localLG (fontface symbol) lg+++execTextM :: (Num u, FromPtSize u, DrawingCtxM m, u ~ MonUnit m) +          => TextM u a -> m (LocGraphic u)+execTextM ma = liftM snd $ runTextM ma  +++stZero :: Num u => St u+stZero = St { delta_chr       = 0+            , delta_sym       = 0+            , acc_chr         = emptyH+            , acc_sym         = emptyH }++envZero :: FromPtSize u => DrawingF (Env u)+envZero = (\sz -> Env { char_width   = fromPtSize $ charWidth sz+                      , spacer_width = fromPtSize $ spacerWidth sz })+            <$> asksDF (font_size . font_props)+++gets :: (St u -> a) -> TextM u a+gets fn = TextM $ \_ s -> (fn s, s)++charMove :: Num u => TextM u ()+charMove = TextM $ \(Env {char_width=cw, spacer_width=sw}) s -> +             let step_width = cw + sw    +                 d_sym      = (delta_sym s) + step_width+             in ((), s { delta_chr = step_width, delta_sym = d_sym }) ++symbMove :: Num u => TextM u ()+symbMove = TextM $ \(Env {char_width=cw, spacer_width=sw}) s -> +             let step_width = cw + sw+                 d_chr      = (delta_chr s) + step_width+             in ((), s { delta_chr = d_chr, delta_sym = step_width }) ++snocSymb :: KerningChar u -> TextM u ()+snocSymb kc = TextM $ \_ s -> ((), upd s)+  where+    upd = (\s a -> s { acc_sym = a `snocH` kc}) <*> acc_sym++snocChar :: KerningChar u -> TextM u ()+snocChar kc = TextM $ \_ s -> ((), upd s)+  where+    upd = (\s a -> s { acc_chr = a `snocH` kc}) <*> acc_chr++kern :: Num u => u -> TextM u ()+kern dx = TextM $ \_ s -> ((), upd s)+  where+    upd = (\s a b -> s { delta_chr = a+dx, delta_sym = b+dx}) +            <*> delta_chr <*> delta_sym++char :: Num u => Char -> TextM u ()+char ch = gets delta_chr           >>= \u -> +          snocChar (kernchar u ch) >> charMove++symb :: Num u => Char -> TextM u ()+symb sy = gets delta_sym           >>= \u -> +          snocSymb (kernchar u sy) >> symbMove+++symbi :: Num u => Int -> TextM u ()+symbi i = symb (chr i) +++symbEscInt :: Num u => Int -> TextM u ()+symbEscInt i = gets delta_sym            >>= \u -> +               snocSymb (kernEscInt u i) >> symbMove+

@@ -23,7 +23,7 @@  -- | Version number ----- > (0,7,0)+-- > (0,8,0) -- wumpus_basic_version :: (Int,Int,Int)-wumpus_basic_version = (0,7,0)+wumpus_basic_version = (0,8,0)

@@ -1,5 +1,5 @@ name:             wumpus-basic-version:          0.7.0+version:          0.8.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -21,41 +21,28 @@   .   Changelog:   .-  0.6.0 to 0.7.0:-  .-  * Major rework of Graphic types, the old types (AGraphic, -    GraphicF etc.) and the old drawing monads have been removed. -    The new types are based on the AGraphic and related types but -    their implementation is different. The new types track the -    /graphics state/ within the type (the DrawingContext) plus -    how to draw themselves. For real drawings, graphics are -    collected with a Writer-like monad the @Basic.Graphic.Drawing@ -    monad which replaces the DrawingCtx and Trace monads. The -    Turtle monad remains and has been updated to work with the new-    drawing monads.-  .-  * LRText and LRSymbol modules temporarily removed as they -    contradict the new, optimized kerning functionality in -    @Wumpus.Core@.-  .-  0.5.0 to 0.6.0:-  .-  * Updates to work with wumpus-core-0.30.0.-  .-  * The code from @Basic.Graphic@ has been moved in to -    @Basic.Graphic.Primitive@ - this module is due a major -    overhaul. @Basic.Graphic@ is now an /import/ shim for-    @Basic.Graphic.Primitive@.+  0.7.0 to 0.8.0:   .-  0.4.0 to 0.5.0:+  * Re-introduced LRText and LRSymbol - they now work with +    Wumpus-Core\'s kerning support.+  . +  * Changes to @Graphic.Basic.BaseTypes@ - @DrawingObject@ +    renamed to @DrawingF@. @HPrim@ wrapped as a newtype to +    support a Monoid instance. Removed @appendGraphic@ and @gcat@ +    as they can be achieved with @mappend@ and @mconcat@. +    @appendAt@ renamed to @lgappend@. @PointT@ remaned to +    @PointF@.   .-  * Re-worked the PictureLanguage module.+  * Changes to @Graphic.Basic.Drawing@ - @drawAt@, @drawAtImg@, +    @drawConn@, @drawConnImg@ all removed. They are replaced +    by @draw@ and @drawi@ together with then new @at@ and @conn@+    combinators.   .-  * SVGColours and X11Colours moved into @Wumpus.Basic.Colour@.-    Naming scheme for colours changed to use underscore between -    words rather than camelCase.+  * Changes to @Basic.Graphic.PrimGraphic@ - @localDrawingContext@+    renamed to @localLG@ and moved to @Basic.Graphic.BaseTypes@.   .-  * Updates to work with wumpus-core-0.30.0.+  * Updates to @Basic.SafeFonts@ to work with changes to +    @Wumpus.Core@.   .   . build-type:         Simple@@ -76,7 +63,7 @@   build-depends:      base            <  5,                        containers      >= 0.3     && <= 0.4,                        vector-space    >= 0.6,-                      wumpus-core     == 0.32.0+                      wumpus-core     == 0.33.0       exposed-modules:@@ -100,6 +87,8 @@     Wumpus.Basic.Paths.Base,     Wumpus.Basic.Paths.Construction,     Wumpus.Basic.SafeFonts,+    Wumpus.Basic.Text.LRSymbol,+    Wumpus.Basic.Text.LRText,     Wumpus.Basic.Utils.HList,     Wumpus.Basic.Utils.Intersection,     Wumpus.Basic.VersionNumber,