wumpus-drawing 0.4.0 → 0.5.0

raw patch · 36 files changed

+753/−1489 lines, 36 filesdep ~wumpus-basicPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: wumpus-basic

API changes (from Hackage documentation)

Files

• demo/ArrowCircuit.hs +9/−12
• demo/Arrowheads.hs +6/−3
• demo/Automata.hs +1/−3
• demo/ClipPic.hs +55/−30
• demo/ColourCharts.hs +1/−1
• demo/Connectors.hs +1/−1
• demo/DotPic.hs +7/−4
• demo/FeatureModel.hs +1/−1
• demo/FontPic.hs +6/−6
• demo/LeftRightText.hs +5/−5
• demo/PetriNet.hs +3/−3
• demo/SampleShapes.hs +2/−2
• demo/SingleChar.hs +1/−1
• demo/Symbols.hs +4/−4
• src/Wumpus/Drawing/Basis/DrawingPrimitives.hs +32/−1
• src/Wumpus/Drawing/Basis/LocTrace.hs +18/−4
• src/Wumpus/Drawing/Basis/RefTrace.hs +74/−79
• src/Wumpus/Drawing/Basis/TraceGraphic.hs +0/−168
• src/Wumpus/Drawing/Connectors/Arrowheads.hs +7/−9
• src/Wumpus/Drawing/Connectors/Base.hs +4/−4
• src/Wumpus/Drawing/Dots/AnchorDots.hs +6/−5
• src/Wumpus/Drawing/Dots/SimpleDots.hs +13/−2
• src/Wumpus/Drawing/Extras/Grids.hs +1/−1
• src/Wumpus/Drawing/Paths/Base/AbsPath.hs +20/−8
• src/Wumpus/Drawing/Paths/Base/PathBuilder.hs +241/−405
• src/Wumpus/Drawing/Paths/Base/RelPath.hs +26/−12
• src/Wumpus/Drawing/Paths/Vamps.hs +14/−8
• src/Wumpus/Drawing/Shapes/Base.hs +3/−3
• src/Wumpus/Drawing/Text/Base/Common.hs +0/−143
• src/Wumpus/Drawing/Text/Base/DocTextZero.hs +136/−300
• src/Wumpus/Drawing/Text/Base/Label.hs +15/−15
• src/Wumpus/Drawing/Text/Base/PosChar.hs +0/−73
• src/Wumpus/Drawing/Text/Base/RotTextZero.hs +0/−161
• src/Wumpus/Drawing/Text/DirectionZero.hs +30/−4
• src/Wumpus/Drawing/VersionNumber.hs +2/−2
• wumpus-drawing.cabal +9/−6

@@ -77,26 +77,23 @@      -- Note - need a variant of /bar/ that draws UDLR only. -connWith :: ( TraceM m, DrawingCtxM m, u ~ MonUnit (m ())-            , Real u, Floating u, InterpretUnit u ) -         => Connector u -> Anchor u -> Anchor u -> m ()+connWith :: ( Real u, Floating u, InterpretUnit u ) +         => Connector u -> Anchor u -> Anchor u -> TraceDrawing u () connWith con a0 a1 = localize double_point_size $      drawc a0 a1 (rightArrow tri45 con)  -atext :: ( CenterAnchor (t u)-         , Real u, Floating u, InterpretUnit u-         , TraceM m, DrawingCtxM m, u ~ MonUnit (m ()), u ~ DUnit (t u) )-      => t u -> String -> m ()+atext :: ( CenterAnchor (t u), u ~ DUnit (t u)+         , Real u, Floating u, InterpretUnit u)+      => t u -> String -> TraceDrawing u () atext ancr ss = -    draw $ ccTextline ss `at` (center ancr)+    draw $ textline ss CENTER `at` (center ancr)  -ptext :: ( Real u, Floating u, InterpretUnit u-         , TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) )-      => Point2 u -> String -> m ()+ptext :: (Floating u, InterpretUnit u) +      => Point2 u -> String -> TraceDrawing u () ptext pt ss = localize (font_attr times_italic 14) $ -    draw $ ccTextline ss `at` pt+    draw $ textline ss CENTER `at` pt   -- Note - return type is a LocImage not a shape...

@@ -76,7 +76,7 @@  tableGraphic :: [(String, ArrowTip)] -> TraceDrawing Double () tableGraphic tips = -    drawl start $ chain_ chn_alg (map makeArrowDrawing tips)+    drawl start $ runChain_ (mapM makeArrowDrawing tips) chn_alg    where     chn_alg = tableDown 18 (180,24)     start   = P2 0 480@@ -87,12 +87,15 @@   -makeArrowDrawing :: (String, ArrowTip) -> LocGraphic Double-makeArrowDrawing (name, utip) = aconn `mappend` lbl+-- Note - /null/ chain action needs a better type synonym name.+--+makeArrowDrawing :: (String, ArrowTip) -> Chain Double (UNil Double)+makeArrowDrawing (name, utip) = cnext (aconn `mappend` lbl)   where     aconn = ignoreAns $ promoteLoc $ \pt ->               connect pt (displace (hvec 60) pt) (uniformArrow utip connline)      lbl   = ignoreAns $ promoteLoc $ \pt ->                textline name WW `at` (displace (hvec 66) pt)+ 

@@ -62,7 +62,7 @@ --  infixr 1 `mat` -mat :: LocImage u a -> Query u (Point2 u) -> Image u a+mat :: InterpretUnit u => LocImage u a -> Query u (Point2 u) -> Image u a mat img mq = zapQuery mq >>= \pt -> img `at` pt  state :: String -> DLocImage DCircle@@ -106,8 +106,6 @@     v1      = pvec ctr p1     zradius = vlength v1     zincl   = vdirection v1--   

@@ -39,12 +39,16 @@ std_ctx = standardContext 14  +-- Note - currently the code is quite messy, path drawing needs +-- some convenience combinators.+ clip_pic :: CtxPicture clip_pic = drawTracing $ localize (fill_colour medium_slate_blue) $ do-    drawl (P2   0 320) $ closedRelPath FILL path01-    drawl (P2 112 320) $ localize (fill_colour powder_blue) $ closedRelPath FILL path02-    drawl (P2 384 416) $ closedRelPath FILL path03-    drawl (P2 328 512) $ closedRelPath FILL path04+    drawl (P2   0 320) $ (drawClosedPath FILL =<< zapLocQ (extrPathSpec path01))+    drawl (P2 112 320) $ localize (fill_colour powder_blue) $ +                         (drawClosedPath FILL =<< zapLocQ (extrPathSpec path02))+    drawl (P2 384 416) $ (drawClosedPath FILL =<< zapLocQ (extrPathSpec path03))+    drawl (P2 328 512) $ (drawClosedPath FILL =<< zapLocQ (extrPathSpec path04))     drawl (P2   0   0) $ clip1     drawl (P2 112   0) $ clip2     drawl (P2 384  96) $ clip3@@ -55,21 +59,32 @@ background rgb = promoteLoc $ \_ ->      ignoreAns $ localize (text_colour rgb) $ ihh `at` P2 0 288   where-    ihh = chain (tableDown 18 (86,16)) (replicate 112 iheartHaskell)+    ihh = runChain (mapM cnext $ replicate 112 iheartHaskell) +                   (tableDown 18 (86,16))  +-- | This is one for Wumpus-Basic - the set of combinators to +-- shift between Images and Queries needs sorting out+-- +zapLocQ :: InterpretUnit u => LocQuery u a-> LocImage u a+zapLocQ ma = promoteLoc $ \pt -> +   askDC >>= \ctx ->+   let a = runLocQuery ma ctx pt+   in return a  clip1 :: LocGraphic Double-clip1 = locClip path01 $ background black+clip1 = zapLocQ (extrPathSpec path01) >>= \a -> +        ignoreAns $ locClip a (background black)    clip2 :: LocGraphic Double-clip2 = locClip path02 $ background medium_violet_red+clip2 = zapLocQ (extrPathSpec path02) >>= \a -> +        locClip a (background medium_violet_red)  clip3 :: LocGraphic Double-clip3 = locClip path03 $ background black+clip3 = zapLocQ (extrPathSpec path03) >>= \a -> locClip a (background black)  clip4 :: LocGraphic Double-clip4 = locClip path04 $ background black+clip4 = zapLocQ (extrPathSpec path04) >>= \a -> locClip a (background black)   iheartHaskell :: LocGraphic Double@@ -79,32 +94,42 @@                   dcTextlabel "&heart;" `at` (pt .+^ hvec 7)     in body `mappend` heart +-- Note - this needs a more uniform name. In Wumpus an object +-- that produces a @UNil@ is called a __Graphic but that +-- convention seems misleading here.+--+type UPathSpec u = PathSpec u (UNil u)  -- zeroPt-path01 :: RelPath Double-path01 = evalPathSpec $  hline 80 -                      >> line (vec 112 160) -                      >> line (vec (-112) 160)-                      >> hline (-80)-                      >> line (vec 112 (-160))-                      >> line (vec (-112) (-160))- +path01 :: UPathSpec Double+path01 =  do +    hlineto 80 +    lineto (vec 112 160) +    lineto (vec (-112) 160)+    hlineto (-80)+    lineto (vec 112 (-160))+    lineto (vec (-112) (-160))+    ureturn ++ -- (P2 112 0)-path02 :: RelPath Double-path02 = evalPathSpec  $  hline 80 -                       >> line (vec 72 112)-                       >> line (vec 72 (-112))-                       >> hline 80-                       >> line (vec (-224) 320)-                       >> hline (-80)-                       >> line (vec 112 (-160))-                       >> line (vec (-112) (-160))+path02 :: UPathSpec Double+path02 = do +    hlineto 80 +    lineto (vec 72 112)+    lineto (vec 72 (-112))+    hlineto 80+    lineto (vec (-224) 320)+    hlineto (-80)+    lineto (vec 112 (-160))+    lineto (vec (-112) (-160))+    ureturn  -- (P2 384 96) -path03 :: RelPath Double-path03 = evalPathSpec $ hline 96 >> vline 56 >> hline (-136) +path03 :: UPathSpec Double+path03 = hlineto 96 >> vlineto 56 >> hlineto (-136) >> ureturn  -- (P2 328 192)-path04 :: RelPath Double-path04 = evalPathSpec  $ hline 152 >> vline 56 >> hline (-192) +path04 :: UPathSpec Double+path04 = hlineto 152 >> vlineto 56 >> hlineto (-192) >> ureturn 

@@ -43,7 +43,7 @@ makeDrawing row_count xs = drawTracing $ tableGraphic row_count xs  tableGraphic :: Int -> [(String,RGBi)] -> TraceDrawing Double ()-tableGraphic row_count xs = draw $ (chain_ chn gs) `at` pt+tableGraphic row_count xs = draw $ (runChain (mapM cnext gs) chn) `at` pt   where     chn  = tableDown row_count (152,11)     pt   = displace (vvec $ fromIntegral $ 11 * row_count) zeroPt 

@@ -63,7 +63,7 @@  tableGraphic :: [(String, Connector Double)] -> TraceDrawing Double () tableGraphic conns = -    draw $ chain_ chn_alg (map makeConnDrawing conns) `at` start+    draw $ runChain (mapM (cnext .  makeConnDrawing) conns) chn_alg `at` start   where     chn_alg   = tableDown 8 (180,64)      start     = P2 0 520 

@@ -69,7 +69,7 @@  tableGraphic :: [(String, DotLocImage Double)] -> TraceDrawing Double () tableGraphic imgs = -    draw $ chain_ chn_alg (map makeDotDrawing imgs) `at` pt+    draw $ runChain_ (mapM (cnext . makeDotDrawing) imgs) chn_alg `at` pt   where     row_count   = 18     chn_alg     = tableDown row_count (180,36)@@ -82,9 +82,12 @@ makeDotDrawing (name,df) =      drawing `mappend` moveStart (vec 86 14) lbl   where-    drawing     = execPathSpec $ -                    updatePen path_style >> -                    insertl dot >> mapM (\v -> line v >> insertl dot) steps+    drawing     = execPathSpec $ localize path_style $ +                    insertl dot >> +                    mapM (\v -> lineto v >> insertl dot) steps >>+                    ureturn+                                +                                 lbl         = ignoreAns $ promoteLoc $ \pt ->                      textline name WW `at` pt

@@ -74,7 +74,7 @@         => u -> String -> Point2 u -> TraceDrawing u (Box u) makeBox w ss pt = do      a <- drawi $ (strokedShape $ rectangle w 20) `at` pt-    drawl (center a) $ ccTextline ss+    drawl (center a) $ textline ss CENTER     return a  box :: (Real u, Floating u, InterpretUnit u, Tolerance u) 

@@ -56,14 +56,14 @@ positions = [0, 12, 27, 49, 78, 122]   -- Note - this chain might be worth putting in a library...-pointChain :: (Int -> DLocGraphic) -> DLocImage DPoint2-pointChain fn = chain chn_alg $ map fn point_sizes+pointChain :: (Int -> DLocGraphic) -> DLocGraphic+pointChain fn = runChain_ (mapM (cnext . fn) point_sizes) chn_alg   where-    chn_alg = linearChain $ iterationScheme start step+    chn_alg = ChainScheme start step     start   = \pt -> (pt,point_sizes) -    step (pt,[])     = ((displace (vvec 50) pt, []), pt)-    step (pt,(y:ys)) = ((displace (vvec $ fromIntegral $ 2 + y)  pt, ys), pt)+    step _ (pt,[])     = (pt, (displace (vvec 50) pt, []))+    step _ (pt,(y:ys)) = (pt, (displace (vvec $ fromIntegral $ 2 + y)  pt, ys))  fontGraphic :: RGBi -> FontDef -> DLocGraphic  fontGraphic rgb ft = ignoreAns $ pointChain mkGF@@ -77,7 +77,7 @@  fontDrawing :: [(RGBi,FontDef)] -> CtxPicture fontDrawing xs = drawTracing $  -    draw $ chain_ chn_alg (map (uncurry fontGraphic) xs) `at` start+    draw $ runChain_  (mapM (cnext . uncurry fontGraphic) xs) chn_alg `at` start   where     chn_alg   = tableDown 4 (1,180)     start     = P2 0 (4*180)

@@ -117,22 +117,22 @@   cc_oneline :: BoundedLocGraphic Double-cc_oneline = ccTextline "Center-center..."+cc_oneline = textline "Center-center..." CENTER   blank_text :: BoundedLocGraphic Double-blank_text = blcTextline ""+blank_text = textline "" BLC   left_text :: BoundedLocGraphic Double-left_text = multiAlignLeft dummy_text CENTER+left_text = multilineText VALIGN_LEFT dummy_text CENTER   right_text :: BoundedLocGraphic Double-right_text = multiAlignRight dummy_text CENTER+right_text = multilineText VALIGN_RIGHT dummy_text CENTER  center_text :: BoundedLocGraphic Double-center_text = multiAlignCenter dummy_text CENTER+center_text = multilineText VALIGN_CENTER dummy_text CENTER  dummy_text :: String  dummy_text = unlines $ [ "The quick brown"

@@ -124,15 +124,15 @@  lblParensParens :: DLocGraphic lblParensParens = -    ignoreAns $ localize (set_font helvetica) $ ccTextline "(),()"+    ignoreAns $ localize (set_font helvetica) $ textline "(),()" CENTER  lblParensParensParens :: DLocGraphic lblParensParensParens = -    ignoreAns $ localize (set_font helvetica) $ ccTextline "(),(),()"+    ignoreAns $ localize (set_font helvetica) $ textline "(),(),()" CENTER    lblBold :: String -> DLocGraphic lblBold ss = -    ignoreAns $ localize (set_font helvetica_bold) $ ccTextline ss+    ignoreAns $ localize (set_font helvetica_bold) $ textline ss CENTER 

@@ -156,7 +156,7 @@   where     shape   = strokedShape $ setDecoration textF sh     textF   = promoteLocTheta $ \pt _ -> -                ignoreAns (multiAlignCenter name CENTER) `at` pt+                ignoreAns (multilineText VALIGN_CENTER name CENTER) `at` pt      deg10   = d2r (10::Double)     deg110  = d2r (110::Double)@@ -177,7 +177,7 @@   where     (rpos,fn)     = go cpos     msg           = ignoreAns $ moveStart (fn 10) $ -                       multiAlignCenter ss rpos+                       multilineText VALIGN_CENTER ss rpos      go NORTH      = (SS, go_north)     go NORTH_EAST = (SW, go_north_east)

@@ -62,7 +62,7 @@     draw $ redPlus `at` P2 200 0    where-    fn addr obj = illustrateBoundedLocGraphic $ (runPosObject addr obj)+    fn addr obj = illustrateBoundedLocGraphic $ runPosObjectBBox obj addr   redPlus :: (Fractional u, InterpretUnit u) => LocGraphic u

@@ -31,13 +31,13 @@ symbols :: CtxPicture symbols = udrawTracing (0::Double) $ do     localize (set_font symbol) $ fontDelta $ draw $-               chain_ chn_alg (map sdraw all_letters) `at` start-    fontDelta $ draw $ chain chn_alg (map ldraw all_letters) `at` start+               runChain_ (mapM sdraw all_letters) chn_alg  `at` start+    fontDelta $ draw $ runChain (mapM ldraw all_letters) chn_alg  `at` start   where     chn_alg         = tableDown 30 (100,20)      start           = P2 0 (30*20)-    sdraw (s,_)     = dcTextlabel s-    ldraw (_,name)  = moveStart (hvec 16) (dcTextlabel name)+    sdraw (s,_)     = cnext $ dcTextlabel s+    ldraw (_,name)  = cnext $ moveStart (hvec 16) (dcTextlabel name)   all_letters :: [(String, String)]

@@ -24,13 +24,19 @@ module Wumpus.Drawing.Basis.DrawingPrimitives   ( +  -- * Monoid mappend+    (<>)    -- * Lines -    hline+  , hline   , vline   , pivotLine +  , oStraightLines+  , cStraightLines++   -- * Rectangles   , blRectangle   , ctrRectangle@@ -52,6 +58,20 @@ import Data.AffineSpace                         -- package: vector-space  +import Data.Monoid++infixr 6 <>+++-- | Alias for mappend in Monoid.+--+-- >  <> (infixr 6)+-- +(<>) :: Monoid a => a -> a -> a+(<>) = mappend+++ -------------------------------------------------------------------------------- -- Lines @@ -76,6 +96,17 @@ pivotLine :: (Floating u, InterpretUnit u) => u -> u -> Radian -> LocGraphic u pivotLine lu ru ang = promoteLoc $ \pt ->      straightLine (pt .+^ avec (ang+pi) lu) (pt .+^ avec ang ru)+++-- | Draw an open path formed from straight line segments.+--+oStraightLines :: InterpretUnit u => [Point2 u] -> Graphic u+oStraightLines ps = zapQuery (vertexPP ps) >>= dcOpenPath++-- | Draw an closed path formed from straight line segments.+--+cStraightLines :: InterpretUnit u => DrawStyle -> [Point2 u] -> Graphic u+cStraightLines sty ps = zapQuery (vertexPP ps) >>= dcClosedPath sty   --------------------------------------------------------------------------------

@@ -56,6 +56,19 @@ import Control.Monad import Data.Monoid +--+-- Note - there are no instances of DrawingCtxM for LocTrace or+-- LocTraceT. +-- +-- The type is not directly compatible as we are collecting +-- LocGraphic in a triple, but also localize would change the +-- interpretation of the vector cursor if the font-size changes.+--+++++ -- | LocTrace is a writer state monad. -- -- The writer accumulates a LocGraphic the state is a cumulative@@ -216,22 +229,23 @@   -instance Num u => LocTraceM (LocTrace u) where++instance InterpretUnit u => LocTraceM (LocTrace u) where   insertl gf  = LocTrace $ \v0 -> ((), v0, moveStart v0 gf)   moveBy v    = LocTrace $ \v0 -> ((), v0 ^+^ v, mempty)   location    = LocTrace $ \v0 -> (v0, v0, mempty) -instance Num u => LocForkTraceM (LocTrace u) where+instance InterpretUnit u => LocForkTraceM (LocTrace u) where   reset       = LocTrace $ \_  -> ((), V2 0 0, mempty)   branch ma   = LocTrace $ \v0 -> let (a,_,o) = getLocTrace ma v0 in (a,v0,o)    -instance (Monad m, Num u) => LocTraceM (LocTraceT u m) where+instance (Monad m, InterpretUnit u) => LocTraceM (LocTraceT u m) where   insertl gf  = LocTraceT $ \v0 -> return ((), v0, moveStart v0 gf)   moveBy v    = LocTraceT $ \v0 -> return ((), v0 ^+^ v, mempty)   location    = LocTraceT $ \v0 -> return (v0, v0, mempty) -instance (LocTraceM m, Num u) => LocForkTraceM (LocTraceT u m) where+instance (LocTraceM m, InterpretUnit u) => LocForkTraceM (LocTraceT u m) where   reset       = LocTraceT $ \_  -> return ((), V2 0 0, mempty)   branch ma   = LocTraceT $ \v0 -> getLocTraceT ma v0 >>= \(a,_,o) ->                                     return (a,v0,o)

@@ -37,9 +37,14 @@   , runRefTrace   , runRefTraceT -  , unaryLink-  , binaryLink-  , multiwayLink+  , Lookup+  , RefGraphic+  , lookup+  , unary+  , binary+  , multiway+  , oneToMany+   )    where@@ -58,6 +63,7 @@ import qualified Data.IntMap as IntMap import Data.Maybe import Data.Monoid+import Prelude hiding ( lookup )   @@ -78,36 +84,60 @@ newtype Ref = Ref { getRefUid :: Int }  --- GRAPHIC or LOC_GRAPHIC?   cf. connectors...------ TODO - make this an newtype and only export an arity family of --- constructors.--- --- Maybe we only support the arity2 (connector) and list (path) cases?------ type Elaboration u ans = IntMap.IntMap ans -> Graphic u+type Lookup u ans = IntMap.IntMap ans -> Query u (Maybe ans)+type RefGraphic u ans = IntMap.IntMap ans -> Graphic u -data LinkRef u ans = -      Unary { refU    :: Ref -            , ancrU   :: ans -> Point2 u-            , drawU   :: LocGraphic u -            }-    | Binary { refB1  :: Ref -             , refB2  :: Ref -             , ancrB1 :: ans -> Point2 u-             , ancrB2 :: ans -> Point2 u-             , drawB  :: ConnectorGraphic u-             }-    | Multiway { refLs :: [Ref]-               , ancrM :: ans -> Point2 u-               , drawM :: [Point2 u] -> Graphic u-               } +lookup :: Ref -> Lookup u ans+lookup ref = \im -> return $ IntMap.lookup (getRefUid ref) im+++unary :: InterpretUnit u +      => (ans -> Graphic u) +      -> Ref+      -> RefGraphic u ans+unary gf r1 = \im -> +  zapQuery (lookup r1 im) >>= maybe mempty gf++++binary :: InterpretUnit u +       => (ans -> ans -> Graphic u) +       -> Ref -> Ref+       -> RefGraphic u ans+binary gf r1 r2 = \im -> +  zapQuery (both (lookup r1 im) (lookup r2 im)) >>= \(ma,mb) -> +  case (ma,mb) of+    (Just a, Just b) -> gf a b+    _                -> mempty+++multiway :: InterpretUnit u +         => ([ans] -> Graphic u) +         -> [Ref]+         -> RefGraphic u ans+multiway gf rs = \im -> +  zapQuery (fmap catMaybes $ mapM (\r -> lookup r im) rs) >>= gf+++oneToMany :: InterpretUnit u +         => (ans -> [ans] -> Graphic u) +         -> Ref -> [Ref]+         -> RefGraphic u ans+oneToMany gf r1 rs = \im -> +    zapQuery (both (lookup r1 im) (allrefs im rs)) >>= \(ma,xs) ->+    maybe mempty (\a -> gf a xs) ma+  where+    allrefs im = fmap catMaybes . mapM (\r -> lookup r im)++++ data RefSt u z = RefSt        { uid_count       :: Int       , current_tip     :: Vec2 u       , ref_acc         :: LocImage u (IntMap.IntMap z)-      , ref_links       :: JL.JoinList (LinkRef u z)+      , ref_links       :: JL.JoinList (RefGraphic u z)       }  @@ -176,13 +206,13 @@  -- LocTraceM -instance Num u => LocTraceM (RefTrace u z) where+instance InterpretUnit u => LocTraceM (RefTrace u z) where   insertl gf  = RefTrace $ \s0 -> ((), insertSt gf s0)   moveBy v    = RefTrace $ \s0 -> ((), moveSt v s0)   location    = RefTrace $ \s0 -> (current_tip s0, s0)  -instance (Monad m, Num u) => LocTraceM (RefTraceT u z m) where+instance (Monad m, InterpretUnit u) => LocTraceM (RefTraceT u z m) where   insertl gf  = RefTraceT $ \s0 -> return ((), insertSt gf s0)   moveBy v    = RefTraceT $ \s0 -> return ((), moveSt v s0)   location    = RefTraceT $ \s0 -> return (current_tip s0, s0)@@ -191,13 +221,14 @@  -- Run functions -runRefTrace :: Num u => RefTrace u ans a -> LocImage u a+runRefTrace :: InterpretUnit u => RefTrace u ans a -> LocImage u a runRefTrace mf = post $ getRefTrace mf zeroRefSt   where     post (a,st) = replaceAns a $ reconcileRefSt st  -runRefTraceT :: (Monad m, Num u) => RefTraceT u ans m a -> m (LocImage u a)+runRefTraceT :: (Monad m, InterpretUnit u) +             => RefTraceT u ans m a -> m (LocImage u a) runRefTraceT mf = liftM post $ getRefTraceT mf zeroRefSt   where     post (a,st) = replaceAns a $ reconcileRefSt st@@ -206,38 +237,22 @@  -- Note we have to drop the vector -reconcileRefSt :: RefSt u z -> LocGraphic u+reconcileRefSt :: InterpretUnit u => RefSt u z -> LocGraphic u reconcileRefSt st = -    step (ref_acc st) (JL.toList $ ref_links st)+    ignoreAns $ selaborate (ref_acc st) +                           (\a -> mconcat $ map (fn a) $ JL.toList $ ref_links st)   where-    step img xs = ignoreAns $ elaborate img (\a -> mconcat $ map (fn a) xs)-    -    fn im (Unary r1 ar1 gf) = -      maybe mempty (\pt -> promoteLoc $ \_ -> applyLoc gf pt) (projectRef r1 ar1 im)-   -    fn im (Binary r1 r2 ar1 ar2 conn) = -      case (projectRef r1 ar1 im, projectRef r2 ar2 im) of-        (Just p1, Just p2) -> promoteLoc $ \_ -> applyConn conn p1 p2-        _                  -> mempty---    fn im (Multiway rs ar1 gf) = -        let ps = catMaybes $ map (\a -> projectRef a ar1 im) rs-        in promoteLoc $ \_ -> gf ps-                                 +    fn im g = promoteLoc $ \_ -> g im  -projectRef :: Ref -> (ans -> Point2 u) -> IntMap.IntMap ans -> Maybe (Point2 u)-projectRef r ancr im = ancr <$> IntMap.lookup (getRefUid r) im- -- Note - probably this supports Tree which is not a Trace monad...  class Monad m => RefTraceM (m :: * -> *) where   type MonRef m :: *   insertRef   :: (MonRef m ~ a, MonUnit (m ()) ~ u) => LocImage u a -> m Ref-  linkRef     :: (MonRef m ~ a, MonUnit (m ()) ~ u) => LinkRef u a -> m ()+  linkRef     :: (MonRef m ~ a, MonUnit (m ()) ~ u) => RefGraphic u a -> m () -instance Num u => RefTraceM (RefTrace u z) where+instance InterpretUnit u => RefTraceM (RefTrace u z) where   type MonRef (RefTrace u z) = z   insertRef img = RefTrace $ \s0 -> let (ix,s1) = incrementSt img s0                                     in (Ref ix, s1)@@ -245,21 +260,23 @@   linkRef fn    = RefTrace $ \s0 -> ((), snocLink fn s0)    ++ moveSt :: Num u => Vec2 u -> RefStF u z  moveSt v = (\s i -> s { current_tip = i ^+^ v })               <*> current_tip -insertSt :: Num u => LocImage u z2 -> RefStF u ans+insertSt :: InterpretUnit u => LocImage u z2 -> RefStF u ans insertSt gf = (\s ac v1 -> let g1 = ignoreAns $ moveStart v1 gf-                           in s { ref_acc = decorate ac g1 }) +                           in s { ref_acc = sdecorate ac g1 })                  <*> ref_acc <*> current_tip -snocLink :: LinkRef u ans -> RefStF u ans+snocLink :: RefGraphic u ans -> RefStF u ans snocLink fn = (\s i -> s { ref_links = JL.snoc i fn })                  <*> ref_links  -incrementSt :: Num u +incrementSt :: InterpretUnit u              => LocImage u ans -> RefSt u ans -> (Int, RefSt u ans) incrementSt img s0 = (uid_count s0, upd s0)   where@@ -272,26 +289,4 @@   -unaryLink :: (ans -> Point2 u) -> LocGraphic u -> Ref -> LinkRef u ans-unaryLink f gf = \r1 -> Unary { refU    = r1-                              , ancrU   = f-                              , drawU   = gf-                              } -binaryLink :: (ans -> Point2 u) -> (ans -> Point2 u) -           -> ConnectorGraphic u -> Ref -> Ref -           -> LinkRef u ans-binaryLink f g conn = \r1 r2 -> Binary { refB1  = r1-                                       , refB2  = r2 -                                       , ancrB1 = f-                                       , ancrB2 = g-                                       , drawB  = conn-                                       }---multiwayLink :: (ans -> Point2 u) -> ([Point2 u] -> Graphic u) -> [Ref] -             -> LinkRef u ans-multiwayLink f gf = \rs -> Multiway { refLs = rs-                                    , ancrM = f-                                    , drawM = gf-                                    }

@@ -1,168 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Basis.TraceGraphic--- Copyright   :  (c) Stephen Tetley 2011--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC------ Build multi-part Graphics with an accumulator (i.e. a Writer --- monad).------ Note - the run functions for the transformer and the plain--- monad are quite different. This is mandated by the need to  --- single-thread the DrawingContext through the transformer.--------------------------------------------------------------------------------------module Wumpus.Drawing.Basis.TraceGraphic-  (-    TraceGraphic-  , TraceGraphicT--  , TraceGraphicM(..)--  , runTraceGraphic-  , runTraceGraphicT--  , liftTraceGraphicT--  ) where---import Wumpus.Basic.Kernel                      -- package: wumpus-basic--import Control.Applicative-import Data.Monoid----newtype TraceGraphic u a = TraceGraphic { -    getTraceGraphic :: DrawingContext -> (a, CatPrim) }---newtype TraceGraphicT u m a = TraceGraphicT { -    getTraceGraphicT :: DrawingContext -> m (a, CatPrim) }---type instance MonUnit (TraceGraphic u a)    = u-type instance MonUnit (TraceGraphicT u m a) = u----- Functor--instance Functor (TraceGraphic u) where-  fmap f ma = TraceGraphic $ \ctx -> let (a,w1) = getTraceGraphic ma ctx-                                     in (f a,w1)---instance Monad m => Functor (TraceGraphicT u m) where-  fmap f ma = TraceGraphicT $ \ctx -> getTraceGraphicT ma ctx >>= \(a,w1) -> -                                      return (f a,w1)----- Applicative--instance Applicative (TraceGraphic u) where-  pure a    = TraceGraphic $ \_   -> (a, mempty)-  mf <*> ma = TraceGraphic $ \ctx -> -                let (f,w1) = getTraceGraphic mf ctx-                    (a,w2) = getTraceGraphic ma ctx-                in (f a,w1 `mappend` w2)---instance Monad m => Applicative (TraceGraphicT u m) where-  pure a    = TraceGraphicT $ \_   -> return (a, mempty)-  mf <*> ma = TraceGraphicT $ \ctx -> -                getTraceGraphicT mf ctx >>= \(f,w1) ->-                getTraceGraphicT ma ctx >>= \(a,w2) -> -                return (f a,w1 `mappend` w2)------ Monad--instance Monad (TraceGraphic u) where-  return a  = TraceGraphic $ \_   -> (a, mempty)-  ma >>= k  = TraceGraphic $ \ctx -> -                let (a,w1) = getTraceGraphic ma ctx-                    (b,w2) = (getTraceGraphic . k) a ctx-                in (b, w1 `mappend` w2)-               --instance Monad m => Monad (TraceGraphicT u m) where-  return a  = TraceGraphicT $ \_   -> return (a, mempty)-  ma >>= k  = TraceGraphicT $ \ctx -> -                getTraceGraphicT ma ctx      >>= \(a,w1) -> -                (getTraceGraphicT . k) a ctx >>= \(b,w2) -> -                return (b, w1 `mappend` w2)-               ----- DrawingCtxM--instance DrawingCtxM (TraceGraphic u) where-  askDC           = TraceGraphic $ \ctx -> (ctx, mempty)-  asksDC f        = TraceGraphic $ \ctx -> (f ctx, mempty)-  localize upd ma = TraceGraphic $ \ctx -> getTraceGraphic ma (upd ctx)----instance Monad m => DrawingCtxM (TraceGraphicT u m) where-  askDC           = TraceGraphicT $ \ctx -> return (ctx, mempty)-  asksDC f        = TraceGraphicT $ \ctx -> return (f ctx, mempty)-  localize upd ma = TraceGraphicT $ \ctx -> getTraceGraphicT ma (upd ctx)------ TraceGraphicM--class Monad m => TraceGraphicM m where-  tellImage   :: MonUnit (m ()) ~ u => Image u a -> m a-  tellImage_  :: MonUnit (m ()) ~ u => Image u a -> m ()--  tellImage_ ma = tellImage ma >> return ()---instance TraceGraphicM (TraceGraphic u) where-  tellImage  img = TraceGraphic $ \ctx -> -                     let (PrimW o a) = runImage ctx img in (a,o)--  tellImage_ img = TraceGraphic $ \ctx -> -                     let (PrimW o _) = runImage ctx img in ((),o)---instance Monad m => TraceGraphicM (TraceGraphicT u m) where-  tellImage  img = TraceGraphicT $ \ctx ->  -                     let (PrimW o a) = runImage ctx img in return (a,o) --  tellImage_ img = TraceGraphicT $ \ctx -> -                     let (PrimW o _) = runImage ctx img in return ((),o)---runTraceGraphic :: TraceGraphic u a -> Image u a-runTraceGraphic mf = askDC >>= \ctx -> let (a,o) = getTraceGraphic mf ctx-                                       in replaceAns a $ primGraphic o----- | Note - this needs DrawingContext as an explicit parameter,--- and hence it returns a pair of @(a, HPrim u)@ rather than an--- Image.------ It is expected this will be wrapped in to form a specific--- TraceDrawing /draw/ function for the amalgamated monad.--- -runTraceGraphicT :: Monad m -                 => DrawingContext -> TraceGraphicT u m a -> m (a, HPrim u)-runTraceGraphicT ctx mf = -    getTraceGraphicT mf ctx >>= \(a,o) -> return (a, singleH o)---liftTraceGraphicT :: Monad m => m a -> TraceGraphicT u m a -liftTraceGraphicT ma = TraceGraphicT $ \_ -> ma >>= \a -> return (a,mempty)-

@@ -59,6 +59,7 @@   ) where  +import Wumpus.Drawing.Basis.DrawingPrimitives import Wumpus.Drawing.Connectors.Base import Wumpus.Drawing.Paths.Absolute @@ -83,24 +84,21 @@   filledTipPath :: PointGen -> LocThetaGraphic En-filledTipPath fn = +filledTipPath gen =      localize fill_use_stroke_colour $ promoteLocTheta $ \pt theta ->-      let vs = fn theta -      in zapQuery (vertexPP $ map (pt .+^) vs) >>= dcClosedPath FILL+      cStraightLines FILL $ map (pt .+^) $ gen theta   closedTipPath :: PointGen -> LocThetaGraphic En-closedTipPath fn = +closedTipPath gen =      localize solid_stroke_tip $ promoteLocTheta $ \pt theta ->-      let vs = fn theta -      in zapQuery (vertexPP $ map (pt .+^) vs) >>= dcClosedPath STROKE+      cStraightLines STROKE $ map (pt .+^) $ gen theta   openTipPath :: PointGen -> LocThetaGraphic En-openTipPath fn = +openTipPath gen =      localize solid_stroke_tip $ promoteLocTheta $ \pt theta ->-      let vs = fn theta -      in zapQuery (vertexPP $ map (pt .+^) vs) >>= dcOpenPath+      oStraightLines $ map (pt .+^) $ gen theta   

@@ -134,7 +134,7 @@         mid_ang         = tipDirectionL len full_path         tip             = applyLocTheta deco (tipL full_path) mid_ang     in replaceAns full_path $ -         decorate tip $ zapQuery (toPrimPath short_path) >>= dcOpenPath+         sdecorate tip $ drawOpenPath short_path   @@ -152,7 +152,7 @@         mid_ang         = tipDirectionR len full_path         tip             = applyLocTheta deco (tipR full_path) mid_ang     in replaceAns full_path $ -         decorate tip $ zapQuery (toPrimPath short_path) >>= dcOpenPath+         sdecorate tip $ drawOpenPath short_path   @@ -173,8 +173,8 @@         tipl            = applyLocTheta decol (tipL full_path) mid_angl         tipr            = applyLocTheta decor (tipR full_path) mid_angr     in replaceAns full_path $ -         decorate (tipl `mappend` tipr) $ -            zapQuery (toPrimPath short_path) >>= dcOpenPath+         sdecorate (tipl `mappend` tipr) $ drawOpenPath short_path+             

@@ -65,7 +65,6 @@  import Wumpus.Drawing.Dots.SimpleDots ( MarkSize ) import qualified Wumpus.Drawing.Dots.SimpleDots as SD-import Wumpus.Drawing.Text.Base.RotTextZero  import Wumpus.Basic.Geometry                    -- package: wumpus-basic import Wumpus.Basic.Kernel               @@ -265,7 +264,8 @@   dotText :: (Floating u, Real u, InterpretUnit u) => String -> DotLocImage u -dotText ss = fmap bboxRectAnchor $ ccTextline ss+dotText ss = +    fmap bboxRectAnchor $ runPosObjectBBox (posText ss) CENTER  -- Note - maybe Wumpus-Basic should have a @swapAns@ function? @@ -334,8 +334,9 @@ dotTriangle = intoLocImage (triangleLDO 1) SD.dotTriangle  -intoLocImage :: LocQuery u a -> LocImage u z -> LocImage u a-intoLocImage mq gf = promoteLoc $ \pt -> +intoLocImage :: InterpretUnit u +             => LocQuery u a -> LocImage u z -> LocImage u a+intoLocImage ma gf = promoteLoc $ \pt ->                       askDC >>= \ctx -> -                     let ans = runLocQuery pt ctx mq+                     let ans = runLocQuery ma ctx pt                      in replaceAns ans $ applyLoc gf pt

@@ -42,7 +42,10 @@    , dotChar   , dotText+  , dotEscChar+  , dotEscText +   , dotHLine   , dotVLine   , dotX@@ -65,7 +68,6 @@   ) where  -import Wumpus.Drawing.Text.Base.RotTextZero  import Wumpus.Basic.Geometry                    -- package: wumpus-basic import Wumpus.Basic.Kernel        @@ -143,8 +145,17 @@   dotText :: (Real u, Floating u, InterpretUnit u) => String -> LocGraphic u-dotText ss = ignoreAns $ ccTextline ss+dotText ss = ignoreAns $ runPosObject (posText ss) CENTER +dotEscChar :: (Real u, Floating u, InterpretUnit u) +           => EscapedChar -> LocGraphic u+dotEscChar = dotEscText . wrapEscChar++dotEscText :: (Real u, Floating u, InterpretUnit u) +           => EscapedText -> LocGraphic u+dotEscText esc = ignoreAns $ runPosObject (posEscText esc) CENTER++-- TODO - need Upright versions of dots...   

@@ -197,7 +197,7 @@   -minorMajor :: Num u +minorMajor :: InterpretUnit u             => Int -> Int -> Vec2 u -> LocGraphic u -> LocGraphic u             -> LocGraphic u minorMajor count alt mv mnr mjr = execLocTrace (step count)

@@ -49,8 +49,10 @@   -- * Conversion   , toPrimPath -  , openAbsPath-  , closedAbsPath+  , drawOpenPath+  , drawOpenPath_+  , drawClosedPath+  , drawClosedPath_    -- * Shortening   , shortenPath@@ -403,16 +405,26 @@   -openAbsPath :: InterpretUnit u -            => AbsPath u -> Image u (AbsPath u)-openAbsPath rp = replaceAns rp $+drawOpenPath :: InterpretUnit u +             => AbsPath u -> Image u (AbsPath u)+drawOpenPath rp = replaceAns rp $     zapQuery (toPrimPath rp) >>= dcOpenPath  -closedAbsPath :: InterpretUnit u -              => DrawStyle -> AbsPath u -> Image u (AbsPath u)-closedAbsPath sty rp = replaceAns rp $ +drawOpenPath_ :: InterpretUnit u +              => AbsPath u -> Graphic u+drawOpenPath_ rp = zapQuery (toPrimPath rp) >>= dcOpenPath+++drawClosedPath :: InterpretUnit u +               => DrawStyle -> AbsPath u -> Image u (AbsPath u)+drawClosedPath sty rp = replaceAns rp $      zapQuery (toPrimPath rp) >>= dcClosedPath sty+++drawClosedPath_ :: InterpretUnit u +                => DrawStyle -> AbsPath u -> Graphic u+drawClosedPath_ sty rp = zapQuery (toPrimPath rp) >>= dcClosedPath sty   -- | Turn a Path into an ordinary PrimPath.

@@ -23,38 +23,33 @@      LocTraceM(..) -- re-export +  , GenPathSpec   , PathSpec-  , PathSpecT+  , Vamp(..) -  , Vamp-  , PathTerm(..)-  , makeVamp +  , runGenPathSpec   , runPathSpec   , execPathSpec   , evalPathSpec--  , runPathSpecT-  , execPathSpecT-  , evalPathSpecT--  , execPivot-  , execPivotT---  , PathOpM(..)-+  , extrPathSpec -  -- * Derived operators-  , pen_colour-  , pen_width+--  , execPivot -  , lines+  , pathTip -  , hline-  , vline-  , aline+  , lineto+  , curveto+  , moveto+  +  , breakPath+  , hlineto+  , vlineto+  , alineto +  , vamp+  , cycleSubPath+  , localPen     ) where @@ -68,7 +63,8 @@ import Wumpus.Core                              -- package: wumpus-core  -import Data.VectorSpace                         -- package: vector-space+import Data.AffineSpace                         -- package: vector-space+-- import Data.VectorSpace  import Control.Applicative import Control.Monad@@ -76,241 +72,210 @@ import Prelude hiding ( null, cycle, lines )  +newtype GenPathSpec st u a = GenPathSpec+          { getGenPathSpec :: DrawingContext -> DPoint2 -> PathSt st+                           -> (a, DPoint2, PathSt st, PathW) } +type instance DUnit   (GenPathSpec st u a) = u+type instance UState  (GenPathSpec st u)   = st+type instance MonUnit (GenPathSpec st u a) = u +type PathSpec u a = GenPathSpec () u a  --- | The vector part of the @active_path@ is its start point. --- This allows cycled paths.----data BuildSt u = BuildSt -      { cumulative_tip    :: Vec2 u-      , cumulative_path   :: RelPath u-      , current_incline   :: Radian-      , active_path       :: ActivePath u-      , pen_trace         :: LocGraphic u-      , ins_trace         :: LocGraphic u-      , pen_dc_modifier   :: DrawingContextF+data PathSt st = PathSt+      { st_active_pen :: ActivePen+      , st_user_state :: st       } -      -- TODO - is incline worthwhile? ---- | The vector for @PEN_DOWN@ is the start-point not the current--- tip. +-- | Note - this formulation doesn\'t support monoidal append. -- --- Startpoint is needed for cycling a path.+-- Information gets lost for this one (we really would want to +-- draw the left-hand-side):+--+-- > PEN_DOWN _ _ `mappend` PEN_UP+--+-- So it has to be part of the state not the writer. -- -data ActivePath u = PEN_UP-                  | PEN_DOWN (Vec2 u) (RelPath u)-      +data ActivePen = PEN_UP +               | PEN_DOWN { ap_start_point  :: Point2 Double+                          , ap_rel_path     :: RelPath Double +                          }  +zeroActivePath :: DPoint2 -> ActivePen+zeroActivePath pt = PEN_DOWN pt mempty -type instance DUnit (BuildSt u) = u-type instance DUnit (ActivePath u) = u +data PathW = PathW +      { w_rel_path :: RelPath Double+      , w_trace    :: CatPrim+      } -newtype PathSpec u a = PathSpec { -      getPathSpec :: BuildSt u -> (a, BuildSt u) } +instance Monoid PathW where+  mempty = PathW mempty mempty+  PathW a0 b0 `mappend` PathW a1 b1 = PathW (a0 `mappend` a1) (b0 `mappend` b1) -newtype PathSpecT u m a = PathSpecT { -      getPathSpecT :: BuildSt u -> m (a, BuildSt u) }   --- Note - splitting the state between BuildSt and the /path tip/--- in LocTrace as actually detrimental to clarity of the code --- below. It would make some sense to add the tip and the insert --- trace to @BuildSt@ so everything is in one place.---type instance MonUnit (PathSpec u a) = u-type instance MonUnit (PathSpecT u m a) = u+data PathTerm = SUBPATH_OPEN | SUBPATH_CLOSED DrawStyle+  deriving (Eq,Show)  --- | Vamps...----data Vamp u = Vamp +data Vamp u = Vamp        { vamp_move :: Vec2 u-       , vamp_path :: RelPath u-       , vamp_term :: PathTerm+       , vamp_conn :: ConnectorGraphic u        } - type instance DUnit (Vamp u) = u  -data PathTerm = SUBPATH_OPEN | SUBPATH_CLOSED DrawStyle-  deriving (Eq,Show)---makeVamp :: Vec2 u -> RelPath u -> PathTerm -> Vamp u-makeVamp v1 ph pe = Vamp { vamp_move = v1-                         , vamp_path = ph-                         , vamp_term = pe  -                         }-- ----------------------------------------------------------------------------------- instances+-- Instances   -- Functor -instance Functor (PathSpec u) where-  fmap f mf = PathSpec $ \s0 -> let (a,s1) = getPathSpec mf s0 in (f a,s1)--instance Monad m => Functor (PathSpecT u m) where-  fmap f mf = PathSpecT $ \s0 -> -                getPathSpecT mf s0 >>= \(a,s1) -> return (f a,s1)+instance Functor (GenPathSpec st u) where+  fmap f ma = GenPathSpec $ \ctx pt s -> +                let (a,p1,s1,w1) = getGenPathSpec ma ctx pt s +                in (f a,p1,s1,w1)   -- Applicative-                                -instance Applicative (PathSpec u) where-  pure a    = PathSpec $ \s0 -> (a, s0)-  mf <*> ma = PathSpec $ \s0 -> let (f,s1) = getPathSpec mf s0 -                                    (a,s2) = getPathSpec ma s1-                                in (f a, s2) -instance Monad m => Applicative (PathSpecT u m) where-  pure a    = PathSpecT $ \s0 -> return (a, s0)-  mf <*> ma = PathSpecT $ \s0 -> -                getPathSpecT mf s0 >>= \(f,s1) ->-                getPathSpecT ma s1 >>= \(a,s2) ->-                return (f a, s2)+instance Applicative (GenPathSpec st u) where+  pure a    = GenPathSpec $ \_   pt s -> (a, pt, s, mempty)+  mf <*> ma = GenPathSpec $ \ctx pt s -> +                let (f,p1,s1,w1) = getGenPathSpec mf ctx pt s+                    (a,p2,s2,w2) = getGenPathSpec ma ctx p1 s1+                in (f a, p2, s2, w1 `mappend` w2)   -- Monad -instance Monad (PathSpec u) where-  return a  = PathSpec $ \s0 -> (a, s0)-  ma >>= k  = PathSpec $ \s0 -> -                let (a,s1) = getPathSpec ma s0 in (getPathSpec . k) a s1 +instance Monad (GenPathSpec st u) where+  return a  = GenPathSpec $ \_   pt s -> (a, pt, s, mempty)+  ma >>= k  = GenPathSpec $ \ctx pt s -> +                let (a,p1,s1,w1) = getGenPathSpec ma ctx pt s+                    (b,p2,s2,w2) = (getGenPathSpec . k) a ctx p1 s1+                in (b, p2, s2, w1 `mappend` w2) -instance Monad m => Monad (PathSpecT u m) where-  return a  = PathSpecT $ \s0 -> return (a, s0)-  ma >>= k  = PathSpecT $ \s0 -> -                getPathSpecT ma s0 >>= \(a,s1) -> (getPathSpecT . k) a s1-             +instance Monoid a => Monoid (GenPathSpec st u a) where+  mempty           = GenPathSpec $ \_   pt s -> (mempty, pt, s, mempty)+  ma `mappend` mb  = GenPathSpec $ \ctx pt s -> +                       let (a,p1,s1,w1) = getGenPathSpec ma ctx pt s+                           (b,p2,s2,w2) = getGenPathSpec mb ctx p1 s1+                       in (a `mappend` b, p2, s2, w1 `mappend` w2) --- | Make the initial build state.----zeroBuildSt :: InterpretUnit u => BuildSt u-zeroBuildSt = BuildSt { cumulative_tip    = V2 0 0-                      , cumulative_path   = mempty-                      , current_incline   = 0-                      , active_path       = PEN_UP-                      , pen_trace         = mempty-                      , ins_trace         = mempty-                      , pen_dc_modifier   = id-                      }+-- DrawingCtxM +instance DrawingCtxM (GenPathSpec st u) where+  askDC           = GenPathSpec $ \ctx pt s -> (ctx, pt, s, mempty)+  asksDC f        = GenPathSpec $ \ctx pt s -> (f ctx, pt, s, mempty)+  localize upd ma = GenPathSpec $ \ctx pt s -> +                      getGenPathSpec ma (upd ctx) pt s --- The /full/ versions throw away only parts of the @BuildSt@ .--- +-- UserStateM  --- | Run a PathSpec - return a five-tuple.------ > (ans, path, end_vector, pen_trace, insert_trace) ------ > ans - is the monadic answer, usually ().------ > path - is the relative path formed by all movements during --- > the build. This includes movement where the pen is _up_.------ > end_vector - is the cumulative displacement from the start --- > point.------ > pen_trace - is ...------ > insert_trace - ----runPathSpec :: (Floating u, InterpretUnit u)-            => PathSpec u a -            -> (a, RelPath u, Vec2 u, LocGraphic u, LocGraphic u)-runPathSpec mf = -    post $ getPathSpec mf zeroBuildSt -  where-    post (a,st) = let (ph,end,pen,ins) = postBuildSt st-                  in (a,ph,end,pen,ins)+instance UserStateM (GenPathSpec st u) where+  getState        = GenPathSpec $ \_ pt s -> +                      (st_user_state s, pt, s, mempty)+  setState ust    = GenPathSpec $ \_ pt s -> +                      ((), pt, s {st_user_state = ust} , mempty)+  updateState upd = GenPathSpec $ \_ pt s -> +                      let ust = st_user_state s+                      in ((), pt, s {st_user_state =  upd ust}, mempty) --- | /Close/ the BuildSt, extracting the values.------ A partly drawn sub path will be added to the pen trace as an--- open sub path.++-- | Note - location probably should return Point2 not Vec2 hence +-- this uses @cheat@ temporarily. ---postBuildSt :: InterpretUnit u -            => BuildSt u -> (RelPath u, Vec2 u, LocGraphic u, LocGraphic u)-postBuildSt s0 = step (penUp SUBPATH_OPEN s0) -  where-    step st = ( cumulative_path st-              , cumulative_tip st-              , pen_trace st-              , ins_trace st )+-- TODO - sort out LocTraceM class.+-- +instance InterpretUnit u => LocTraceM (GenPathSpec st u) where+  moveBy   = moveto+  insertl  = insertLocImage+  location = cheat <$> pathTip+    where cheat (P2 x y) = V2 x y +            +runGenPathSpec :: InterpretUnit u +               => GenPathSpec st u a -> st -> LocImage u (a, RelPath u)+runGenPathSpec ma st = promoteLoc $ \pt -> +    askDC >>= \ctx ->+    let dpt       = normalizeF (dc_font_size ctx) pt+        st_zero   = PathSt (zeroActivePath dpt) st+        (a,_,s,w) = getGenPathSpec ma ctx dpt st_zero+        upath     = dinterpF (dc_font_size ctx) $ w_rel_path w+        (_,wcp)   = runImage (drawActivePen SUBPATH_OPEN $ st_active_pen s) ctx+        wfinal    = w_trace w `mappend` wcp+    in replaceAns (a,upath) $ primGraphic wfinal  --- | Run an 'PathSpec' - return the LocGraphic formed by the pen --- trace and the insert trace, /forget/ the outline of the path.--- --- Note - the insert trace is printed above the pen trace in the --- z-order.--- -execPathSpec :: (Floating u, InterpretUnit u)-             => PathSpec u a -> LocGraphic u-execPathSpec mf = post $ runPathSpec mf-  where-    post (_,_,_,g1,g2) = g1 `mappend` g2+runPathSpec :: InterpretUnit u+            => PathSpec u a -> LocImage u (a, RelPath u)+runPathSpec ma = runGenPathSpec ma ()  +evalPathSpec :: InterpretUnit u+             => PathSpec u a -> LocImage u (RelPath u)+evalPathSpec ma = snd <$> runPathSpec ma --- | Run an 'PathSpec' - return the outline of the path, /forget/--- the the pen trace and the insert trace.--- -evalPathSpec :: (Floating u, InterpretUnit u)-             => PathSpec u a -> RelPath u-evalPathSpec mf = post $ runPathSpec mf-  where-    post (_,ph,_,_,_) = ph +execPathSpec :: InterpretUnit u+             => PathSpec u a -> LocImage u a+execPathSpec ma = fst <$> runPathSpec ma --- | Transformer version of 'runPathSpec'+++extrPathSpec :: InterpretUnit u+             => PathSpec u a -> LocQuery u (RelPath u)+extrPathSpec ma = extrLoc $ evalPathSpec ma+++-- Monad run function nomenclature: ---runPathSpecT :: (Monad m, Floating u, InterpretUnit u)-             => PathSpecT u m a -             -> m (a, RelPath u, Vec2 u, LocGraphic u, LocGraphic u)-runPathSpecT mf = -    liftM post $ getPathSpecT mf zeroBuildSt -  where-    post (a,st) = let (ph,end,pen,ins) = postBuildSt st-                  in (a,ph,end,pen,ins)+-- > run  - both+-- > eval - answer (no state)+-- > exec - state (no answer)+-- +-- Note RWS always returns the @w@.+--+-- For Wumpus:+-- +-- > run  - monadic answer, and the writer /construction/+-- > eval - just the monadic answer+-- > exec - just the writer /construction/.+--+-- In all case the CatPrim inside the LocImage may contain +-- additional graphics.+--+-- Client code can use @ignoreAns@ to generate a @LocGraphic@+-- from the @LocImage@.  --- | Transformer version of 'execPathSpec'+-- | Helper. ---execPathSpecT :: (Monad m, Floating u, InterpretUnit u)-              => PathSpecT u m a -> m (LocGraphic u)-execPathSpecT mf = liftM post $ runPathSpecT mf-  where-    post (_,_,_,g1,g2) = g1 `mappend` g2+drawActivePen :: PathTerm -> ActivePen -> DGraphic +drawActivePen _    PEN_UP                            = mempty+drawActivePen term (PEN_DOWN { ap_start_point = pt+                             , ap_rel_path    = rp}) = case term of+    SUBPATH_OPEN -> ignoreAns $ drawOpenPath rp `at` pt+    SUBPATH_CLOSED styl -> ignoreAns $ drawClosedPath styl rp `at` pt  --- | Transformer version of 'evalPathSpec'.--- -evalPathSpecT :: (Monad m, Floating u, InterpretUnit u)-              => PathSpecT u m a -> m (RelPath u)-evalPathSpecT mf = liftM post $ runPathSpecT mf-  where-    post (_,ph,_,_,_) = ph    +{-+ -- | Form a \"pivot path\" drawing from two path specifications. -- The start point of the drawing is the pivot formed by joining -- the paths.@@ -321,256 +286,127 @@   where    (v, _, _, pen, ins) = runPathSpec ( ma >> location >>= \ans ->                                         mb >> return ans )---- | Transformer version of 'execPivot'.--- -execPivotT :: (Floating u, InterpretUnit u, Monad m)-           => PathSpecT u m a -> PathSpecT u m a -> m (LocGraphic u)-execPivotT ma mb = -    liftM post $ runPathSpecT ( ma >> location >>= \ans -> -                                mb >> return ans )-  where-    post (v, _, _, pen, ins) = moveStart (negateV v) $ pen `mappend` ins-       -+-} -  --------------------------------------------------------------------------------+-- operations --- BuildSt modifiers. -type BuildStF u = BuildSt u -> BuildSt u +pathTip :: InterpretUnit u => GenPathSpec st u (Point2 u)+pathTip = GenPathSpec $ \ctx pt s ->+    let upt = dinterpF (dc_font_size ctx) pt+    in (upt, pt, s, mempty)  --- | Helper - extend the path with a line.--- --- This is an implicit PEN_DOWN if the active pen is UP.+-- | @extendPen@ causes a pendown. ---extendPath :: Floating u -           => Vec2 u -> BuildStF u-extendPath v1 = (\s v0 ph pa -> s { cumulative_tip   = v0 ^+^ v1-                                  , cumulative_path  = updP ph-                                  , active_path      = updA v0 pa })-           <*> cumulative_tip <*> cumulative_path <*> active_path-   where-     updP ph                   = snocLineTo ph v1-     updA tip PEN_UP           = PEN_DOWN tip (line1 v1)-     updA _   (PEN_DOWN v0 ph) = PEN_DOWN v0 (snocLineTo ph v1)+extendPen :: DPoint2 -> DVec2 -> ActivePen -> ActivePen+extendPen pt v PEN_UP           = PEN_DOWN pt (line1 v)+extendPen _  v (PEN_DOWN p0 rp) = PEN_DOWN p0 (rp `snocLineTo` v)  +lineto :: InterpretUnit u => Vec2 u -> GenPathSpec st u ()+lineto v1 = GenPathSpec $ \ctx pt s -> +   let sz  = dc_font_size ctx+       dv1 = normalizeF sz v1+       pen = extendPen pt dv1 (st_active_pen s)+       w1  = PathW { w_rel_path = line1 dv1, w_trace = mempty }+   in ((), pt .+^ dv1, s { st_active_pen = pen }, w1)  --- | Helper - extend the path with a curve.------ This is an implicit PEN_DOWN if the active pen is UP.--- -extendPathC :: (Floating u, Ord u, Tolerance u)-            => Vec2 u -> Vec2 u -> Vec2 u -> BuildStF u-extendPathC c1 c2 c3 = -    (\s v0 ph pa -> s { cumulative_tip   = v0 ^+^ c1 ^+^ c2 ^+^ c3-                      , cumulative_path  = updP ph-                      , active_path      = updA v0 pa })-      <*> cumulative_tip <*> cumulative_path <*> active_path-   where-     updP ph                   = snocCurveTo ph c1 c2 c3-     updA tip PEN_UP           = PEN_DOWN tip (curve1 c1 c2 c2)-     updA _   (PEN_DOWN v0 ph) = PEN_DOWN v0 (snocCurveTo ph c1 c2 c3) ---- | Helper - change the active_path to PEN_UP. --- --- This will implicitly log any partly drawn path.+-- | @extendPenC@ causes a pendown. ---penUp :: InterpretUnit u => PathTerm -> BuildStF u-penUp term = -    (\s pt pa upd -> s { active_path = PEN_UP-                       , pen_trace   = pt `mappend` fn upd pa })-      <*> pen_trace <*> active_path <*> pen_dc_modifier-  where-    fn _   PEN_UP           = mempty-    fn upd (PEN_DOWN v0 pa) = subPathDraw upd v0 pa term+extendPenC :: DPoint2 -> DVec2 -> DVec2 -> DVec2 -> ActivePen -> ActivePen+extendPenC pt v1 v2 v3 PEN_UP           = PEN_DOWN pt (curve1 v1 v2 v3)+extendPenC _  v1 v2 v3 (PEN_DOWN p0 rp) = PEN_DOWN p0 (snocCurveTo rp v1 v2 v3)  --- | Move the current tip.------ This is an implicit PEN_UP if the active pen is DOWN.--- -moveTip :: (Floating u, InterpretUnit u) -        => Vec2 u -> BuildStF u-moveTip v1 = -    (\s pa v0 cp -> let s1 = case pa of PEN_UP -> s; _ -> penUp SUBPATH_OPEN s-                    in s1 { cumulative_tip  = v0 ^+^ v1-                          , cumulative_path = snocLineTo cp v1 })-      <*> active_path <*> cumulative_tip <*> cumulative_path +curveto :: InterpretUnit u +        => Vec2 u -> Vec2 u -> Vec2 u -> GenPathSpec st u ()+curveto v1 v2 v3 = GenPathSpec $ \ctx pt s -> +   let sz  = dc_font_size ctx+       dv1 = normalizeF sz v1+       dv2 = normalizeF sz v2+       dv3 = normalizeF sz v3+       pen = extendPenC pt dv1 dv2 dv3 (st_active_pen s)+       w1  = PathW { w_rel_path = line1 dv1, w_trace = mempty }+   in ((), pt .+^ dv1, s { st_active_pen = pen }, w1) --- | Cycle the current active path.----cycleAP :: (Floating u, InterpretUnit u) -        => DrawStyle -> BuildStF u-cycleAP sty = -    (\s pa vtip cp -> case pa of-                        PEN_UP -> s-                        PEN_DOWN v0 _ -> let s1 = penUp (SUBPATH_CLOSED sty) s-                                             mv = v0 ^-^ vtip-                                         in s1 { cumulative_tip  = v0 -                                               , cumulative_path = snocLineTo cp mv })-      <*> active_path <*> cumulative_tip <*> cumulative_path-    -     --- | Change the drawing props of the current pen.+-- | @moveto@ causes a pen up. ----- This is an implicit PEN_UP if the active pen is DOWN.--- -changePen :: InterpretUnit u => DrawingContextF -> BuildStF u-changePen upd = -    (\s pa df -> let s1 = case pa of PEN_UP -> s; _ -> penUp SUBPATH_OPEN s-                 in s1 { pen_dc_modifier  = (upd . df) })-      <*> active_path <*> pen_dc_modifier-+moveto :: InterpretUnit u => Vec2 u -> GenPathSpec st u ()+moveto v1 = GenPathSpec $ \ctx pt s -> +    let sz      = dc_font_size ctx+        dv1     = normalizeF sz v1+        (_,wcp) = runImage (drawActivePen SUBPATH_OPEN $ st_active_pen s) ctx+        w1      = PathW { w_rel_path = mempty, w_trace = wcp }+    in ((), pt .+^ dv1, s { st_active_pen = PEN_UP }, w1)  -insertGf :: Num u => LocGraphic u -> BuildStF u-insertGf gf = -    (\s ins v1 -> let g1 = moveStart v1 gf-                  in s { ins_trace = ins `mappend` g1 })-      <*> ins_trace <*> cumulative_tip-               +breakPath :: InterpretUnit u => GenPathSpec st u ()+breakPath = moveto (V2 0 0) +hlineto :: InterpretUnit u => u -> GenPathSpec st u ()+hlineto dx = lineto (hvec dx) -appendVamp :: (Floating u, InterpretUnit u) -           => Vamp u -> BuildStF u-appendVamp (Vamp { vamp_path = vph, vamp_term = term, vamp_move = mv }) =-    next . penUp SUBPATH_OPEN-  where-    next = (\s v1 cp trc df -> let p1 = subPathDraw df v1 vph term-                               in s { cumulative_tip  = v1 ^+^ mv-                                    , cumulative_path = snocLineTo cp mv-                                    , pen_trace       = trc `mappend` p1 })-            <*> cumulative_tip <*> cumulative_path -            <*> pen_trace      <*> pen_dc_modifier-                                 +vlineto :: InterpretUnit u => u -> GenPathSpec st u ()+vlineto dy = lineto (vvec dy)  -subPathDraw :: InterpretUnit u -            => DrawingContextF -> Vec2 u -> RelPath u -> PathTerm -            -> LocGraphic u-subPathDraw upd v0 subp term = promoteLoc $ \pt -> -    zapQuery (toPrimPath (displace v0 pt) subp) >>= \pp -> localize upd (drawF pp)-  where-    drawF = case term of-              SUBPATH_OPEN -> dcOpenPath-              SUBPATH_CLOSED sty -> dcClosedPath sty+alineto :: (Floating u, InterpretUnit u) +        => Radian -> u -> GenPathSpec st u ()+alineto ang d = lineto (avec ang d)  +insertLocImage :: InterpretUnit u +               => LocImage u a -> GenPathSpec st u ()+insertLocImage gf = GenPathSpec $ \ctx pt s ->+    let upt     = dinterpF (dc_font_size ctx) pt+        (_,wcp) = runLocImage gf ctx upt+        w1      = PathW { w_rel_path = mempty, w_trace = wcp }+    in ((), pt, s, w1)   ------------------------------------------------------------------------------------ LocTraceM instances---- Note - path building does not support forking (LocForkTraceM). ---- moveBy becomes a pen up--instance (Floating u, InterpretUnit u) => -    LocTraceM (PathSpec u) where-  insertl a = PathSpec $ \s0 -> ((), insertGf a s0)-  location  = PathSpec $ \s0 -> (cumulative_tip s0, s0)-  moveBy v  = PathSpec $ \s0 -> ((), moveTip v s0)--+vamp :: InterpretUnit u => Vamp u -> GenPathSpec st u ()+vamp (Vamp v1 conn) = GenPathSpec $ \ctx pt s ->+    let sz      = dc_font_size ctx+        dv1     = normalizeF sz v1+        (_,wcp) = runImage (drawActivePen SUBPATH_OPEN $ st_active_pen s) ctx+        upt     = dinterpF sz pt+        (_,ccp) = runConnectorImage conn ctx upt (upt .+^ v1)+        w1      = PathW { w_rel_path = mempty, w_trace = wcp `mappend` ccp }+    in ((), pt .+^ dv1, s { st_active_pen = PEN_UP }, w1)  -instance (Monad m, Floating u, InterpretUnit u) => -    LocTraceM (PathSpecT u m) where-  insertl a = PathSpecT $ \s0 -> return ((), insertGf a s0)-  location  = PathSpecT $ \s0 -> return (cumulative_tip s0, s0)-  moveBy v  = PathSpecT $ \s0 -> return ((), moveTip v s0)-+cycleSubPath :: DrawStyle -> GenPathSpec st u ()+cycleSubPath styl = GenPathSpec $ \ctx pt s ->+    let gf      = drawActivePen (SUBPATH_CLOSED styl) $ st_active_pen s+        (_,wcp) = runImage gf ctx+        w1      = PathW { w_rel_path = mempty, w_trace = wcp }+    in ((), pt, s { st_active_pen = PEN_UP }, w1)  ---------------------------------------------------------------------------------+-- Design note +--+-- Should pen changing be @local@ style vis the Reader monad or a +-- state change with the State monad? -- ----- | @updatePen@ will draw any in-progress path as an open-stroked--- line before changing the pen properties.+-- @local@ is more idiomatic within the context of Wumpus (and +-- easier to implement), but @state change@ is probably more +-- natural for Path building.+-- +-- For the time being we go with local. ---class Monad m => PathOpM m where-  line         :: u ~ MonUnit (m ()) => Vec2 u -> m ()-  curve        :: u ~ MonUnit (m ()) => Vec2 u -> Vec2 u -> Vec2 u -> m ()-  updatePen    :: DrawingContextF -> m ()-  cycleSubPath :: DrawStyle -> m ()-  vamp         :: u ~ MonUnit (m ()) => Vamp u -> m ()  --instance (Floating u, Ord u, Tolerance u, InterpretUnit u) => -    PathOpM (PathSpec u) where-  line v1           = PathSpec $ \s0 -> ((), extendPath v1 s0)-  curve v1 v2 v3    = PathSpec $ \s0 -> ((), extendPathC v1 v2 v3 s0)-  updatePen upd     = PathSpec $ \s0 -> ((), changePen upd s0)-  cycleSubPath sty  = PathSpec $ \s0 -> ((), cycleAP sty s0)-  vamp vp           = PathSpec $ \s0 -> ((), appendVamp vp s0)----instance (Monad m, Floating u, Ord u, Tolerance u, InterpretUnit u) => -    PathOpM (PathSpecT u m) where-  line v1           = PathSpecT $ \s0 -> return ((), extendPath v1 s0)-  curve v1 v2 v3    = PathSpecT $ \s0 -> return ((), extendPathC v1 v2 v3 s0)-  updatePen upd     = PathSpecT $ \s0 -> return ((), changePen upd s0)-  cycleSubPath sty  = PathSpecT $ \s0 -> return ((), cycleAP sty s0)-  vamp vp           = PathSpecT $ \s0 -> return ((), appendVamp vp s0)--------------------------------------------------------------------------------------- operations----{---setIncline :: Radian -> PathSpec u ()-setIncline ang = sets_ upd-  where-    upd = (\s -> s { current_incline = ang })---}------------------------------------------------------------------------------------- Derived operators-----pen_colour :: PathOpM m-           => RGBi -> m ()-pen_colour rgb = updatePen (stroke_colour rgb)--pen_width  :: PathOpM m -           => Double -> m ()-pen_width d = updatePen (set_line_width d)---lines :: (PathOpM m, u ~ MonUnit (m ())) => [Vec2 u] -> m ()-lines = mapM_ line-------- Note - these names are not consistent with Displacement in --- Wumpus-Basic.-----hline :: (PathOpM m, Num u, u ~ MonUnit (m ())) => u -> m ()-hline dx = line (hvec dx)--vline :: (PathOpM m, Num u, u ~ MonUnit (m ())) => u -> m ()-vline dy = line (vvec dy)-+localPen :: DrawingContextF -> GenPathSpec st u a -> GenPathSpec st u a+localPen upd ma = GenPathSpec $ \ctx pt s ->+    let (_,wcp)      = runImage (drawActivePen SUBPATH_OPEN $ st_active_pen s) ctx+        (a,p1,s1,w1) = getGenPathSpec ma (upd ctx) pt s+        w2           = let wcp2 = wcp `mappend` w_trace w1 in w1 { w_trace = wcp2 }+    in (a, p1, s1 { st_active_pen = PEN_UP }, w2) -aline :: (PathOpM m, Floating u, u ~ MonUnit (m ())) => Radian -> u -> m ()-aline ang d = line (avec ang d)

@@ -58,8 +58,10 @@   , toPrimPath   , toAbsPath -  , openRelPath-  , closedRelPath+  , drawOpenPath+  , drawOpenPath_+  , drawClosedPath+  , drawClosedPath_    ) where @@ -283,14 +285,16 @@ -- Conversion  fromPathAlgVertices :: Floating u => PathAlg u -> (Vec2 u, RelPath u)-fromPathAlgVertices = bimap fn vertexPath . runPathAlgVec+fromPathAlgVertices = step . runPathAlgVec   where-    fn = maybe (V2 0 0) id+    step (Nothing, xs) = (zeroVec, vertexPath xs)+    step (Just v1, xs) = (v1, vertexPath xs)  fromPathAlgCurves :: Floating u => PathAlg u -> (Vec2 u, RelPath u)-fromPathAlgCurves = bimap fn curvedPath . runPathAlgVec+fromPathAlgCurves = step . runPathAlgVec   where-    fn = maybe (V2 0 0) id+    step (Nothing, xs) = (zeroVec, curvedPath xs)+    step (Just v1, xs) = (v1, curvedPath xs)   toPrimPath :: InterpretUnit u => Point2 u -> RelPath u -> Query u PrimPath@@ -336,14 +340,24 @@   -openRelPath :: InterpretUnit u -            => RelPath u -> LocImage u (RelPath u)-openRelPath rp = replaceAns rp $ +drawOpenPath :: InterpretUnit u +             => RelPath u -> LocImage u (RelPath u)+drawOpenPath rp = replaceAns rp $     promoteLoc $ \start -> zapQuery (toPrimPath start rp) >>= dcOpenPath +drawOpenPath_ :: InterpretUnit u +              => RelPath u -> LocGraphic u+drawOpenPath_ rp = promoteLoc $ \start -> +    zapQuery (toPrimPath start rp) >>= dcOpenPath -closedRelPath :: InterpretUnit u -              => DrawStyle -> RelPath u -> LocImage u (RelPath u)-closedRelPath sty rp = replaceAns rp $ ++drawClosedPath :: InterpretUnit u +               => DrawStyle -> RelPath u -> LocImage u (RelPath u)+drawClosedPath sty rp = replaceAns rp $      promoteLoc $ \start -> zapQuery (toPrimPath start rp) >>= dcClosedPath sty++drawClosedPath_ :: InterpretUnit u +                => DrawStyle -> RelPath u -> LocGraphic u+drawClosedPath_ sty rp = promoteLoc $ \start -> +    zapQuery (toPrimPath start rp) >>= dcClosedPath sty 

@@ -22,8 +22,8 @@    ) where -import Wumpus.Drawing.Paths.Base.PathBuilder-import Wumpus.Drawing.Paths.Base.RelPath+import Wumpus.Drawing.Paths.Base.PathBuilder ( Vamp(..) )+import Wumpus.Drawing.Paths.Base.AbsPath  import Wumpus.Basic.Kernel @@ -35,12 +35,18 @@   --squareWE :: (Fractional u, Floating u) => u -> Vamp u-squareWE diam = makeVamp (hvec diam) rpath (SUBPATH_CLOSED STROKE)+-- Note - actual square TODO...+--+squareWE :: (Real u, Floating  u, Ord u, Tolerance u, InterpretUnit u) +         => u -> Vamp u+squareWE diam = Vamp { vamp_move = hvec diam+                     , vamp_conn = conn }   where-    hdiam = 0.5 * diam-    rpath = vertexPath [ vvec hdiam, hvec diam, vvec (-diam), hvec (-diam) ]+    conn = promoteConn $ \p1 p2 -> +           -- TODO ...+           drawClosedPath_ STROKE $ vertexPath $ [ p1, p2 ] +     -- vertexPath [ vvec hdiam, hvec diam, vvec (-diam), hvec (-diam) ] --- Drawing a cirle is probably best done with 90deg arcs.++-- Drawing a cirle picks the half point on the vamp_move vector...

@@ -131,7 +131,7 @@ -- Probably Wumpus should calculate two paths instead. -- dblStrokedShape :: InterpretUnit u => Shape t u -> LocImage u (t u)-dblStrokedShape sh = decorate back fore +dblStrokedShape sh = sdecorate back fore    where     img  = shapeToLoc (dcClosedPath STROKE) sh     back = getLineWidth >>= \lw ->@@ -154,7 +154,7 @@     zapLocThetaQuery (shape_ans_fun sh)  pt 0 >>= \a ->      zapLocThetaQuery (shape_path_fun sh) pt 0 >>= \spath ->      let g2 = atIncline (shape_decoration sh) pt 0 -    in replaceAns a (decorate g2 $ zapQuery (toPrimPath spath) >>= drawF)+    in replaceAns a (sdecorate g2 $ zapQuery (toPrimPath spath) >>= drawF)   @@ -176,7 +176,7 @@     zapLocThetaQuery (shape_ans_fun  sh) pt theta >>= \a ->      zapLocThetaQuery (shape_path_fun sh) pt theta >>= \spath ->      let g2 = atIncline (shape_decoration sh) pt theta-    in replaceAns a $ decorate g2 (zapQuery (toPrimPath spath) >>= drawF)+    in replaceAns a $ sdecorate g2 (zapQuery (toPrimPath spath) >>= drawF)   

@@ -1,143 +0,0 @@-{-# LANGUAGE RankNTypes                 #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Text.Base.Common--- Copyright   :  (c) Stephen Tetley 2011--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC------ Helpers for working with measured / advance text.--- -----------------------------------------------------------------------------------module Wumpus.Drawing.Text.Base.Common-  ( -    posTextWithMargins-  , advtext-  , textVector-  , textOrientationZero--  , charVector-  , charOrientationZero-  , hkernVector-  , hkernOrientationZero--  ) where---import Wumpus.Basic.Kernel                      -- package: wumpus-basic--import Wumpus.Core                              -- package: wumpus-core-import Wumpus.Core.Text.GlyphIndices--import Data.VectorSpace                         -- package: vector-space--import Control.Applicative-import Data.Char-import qualified Data.Map               as Map-import Data.Maybe ----posTextWithMargins :: (Fractional u, InterpretUnit u) -                   => PosObject u -> (RectAddress -> LocImage u (BoundingBox u))-posTextWithMargins obj = \raddr ->-    textMargin >>= \(xsep,ysep) -> -    let body = extendPosObject xsep xsep ysep ysep obj-    in runPosObject raddr body----- | Single line text, returning its advance vector.----advtext :: InterpretUnit u => EscapedText -> LocImage u (Vec2 u)-advtext esc = textVector esc >>= body-  where-    body v = replaceAns v $ dcEscapedlabel esc---textVector :: (DrawingCtxM m, InterpretUnit u) -           => EscapedText -> m (AdvanceVec u)-textVector esc = -    cwLookupTable >>= \table -> -    pointSize     >>= \sz    -> -    let cs = destrEscapedText id esc -    in return $ foldr (step sz table) (vec 0 0) cs-  where-    step sz table ch v = (v ^+^) $ charWidth sz table ch--charVector :: (DrawingCtxM m, InterpretUnit u) -           => EscapedChar -> m (AdvanceVec u)-charVector ch = -    (\table sz -> charWidth sz table ch) <$> cwLookupTable <*> pointSize---- | Build the Orientation of a single line of EscapedText.--- --- The locus of the Orientation is baseline left - margins are --- added.----textOrientationZero :: (DrawingCtxM m, InterpretUnit u )-                    => EscapedText -> m (Orientation u)-textOrientationZero esc = textVector esc >>= bllOrientationZero---- | Build the Orientation of an EscapedChar.--- --- The locus of the Orientation is baseline left - margins are --- added.----charOrientationZero :: (DrawingCtxM m, InterpretUnit u)-                    => EscapedChar -> m (Orientation u)-charOrientationZero ch = charVector ch >>= bllOrientationZero ------ NOTE - TextMargin should probably be added as a final step--- not during construction...--bllOrientationZero :: (DrawingCtxM m, InterpretUnit u )-                   => AdvanceVec u -> m (Orientation u)-bllOrientationZero (V2 w _) = -    (\ymin ymaj -> Orientation 0 w ymin ymaj) -      <$> fmap abs descender <*> capHeight---   --- | 'hkernVector' : @ [kerning_char] -> AdvanceVec @--- --- 'hkernvector' takes whatever length is paired with the --- EscapedChar for the init of the the list, for the last element --- it takes the charVector.----hkernVector :: (DrawingCtxM m, InterpretUnit u) -            => [KernChar u] -> m (AdvanceVec u)-hkernVector = go 0-  where-    go w []             = return $ V2 w 0-    go w [(dx,ch)]      = fmap (addWidth $ w + dx) (charVector ch)-    go w ((dx,_ ):xs)   = go (w + dx) xs-    -    addWidth w (V2 x y) = V2 (w+x) y--    -- ERROR this not the right way to count...-    --hkernOrientationZero :: (DrawingCtxM m, InterpretUnit u )-                     => [KernChar u] -> m (Orientation u)-hkernOrientationZero xs = hkernVector xs >>= bllOrientationZero- --- | This is outside the Drawing context as we don\'t want to get--- the @cwLookupTable@ for every char.----charWidth :: InterpretUnit u -          => FontSize -> CharWidthLookup -> EscapedChar -> AdvanceVec u-charWidth sz fn (CharLiteral c) = fmap (dinterp sz) $ fn $ ord c-charWidth sz fn (CharEscInt i)  = fmap (dinterp sz) $ fn i-charWidth sz fn (CharEscName s) = fmap (dinterp sz) $ fn ix-  where-    ix = fromMaybe (-1) $ Map.lookup s ps_glyph_indices-

@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies               #-} {-# OPTIONS -Wall #-}  --------------------------------------------------------------------------------@@ -20,392 +21,226 @@ module Wumpus.Drawing.Text.Base.DocTextZero   (  -    Doc -  , TextFrame-  , render  -  , leftAlign-  , centerAlign-  , rightAlign+    Doc +  , DocGraphic+  , runDoc +  , (<+>)   , blank   , space   , string   , escaped-  , int+  , embedPosObject+  +  , bold+  , italic+  , boldItalic++  , monospace+  , int    , integer   , float   , ffloat -  , (<>)-  , (<+>) -  , vcatl-  , vcatc -  , vcatr--  , lfill-  , rfill-  , centerfill--  , fontColour-  , textSize-  , bold-  , italic-  , boldItalic     , strikethrough   , underline   , highlight    ) where -import Wumpus.Drawing.Text.Base.Common  import Wumpus.Basic.Kernel                      -- package: wumpus-basic  import Wumpus.Core                              -- package: wumpus-core  import Control.Applicative-import Data.Char ( ord )+import Data.Monoid import Numeric  --- | Space is the width of a space in the current font - it is --- filled in during interpretation.+ +-- | Doc type. ---data Doc u = Empty-           | Space -           | Text EscapedText-           | Cat (Doc u) (Doc u)-           | VCat VAlign (Doc u) (Doc u)-           | Fill VAlign u (Doc u)-           | DLocal DrawingContextF (Doc u)-           | TLocal (TextContextF u) (Doc u)-           | Mono (WidthQuery u) [EscapedChar]-           | AElab (AElaborateF u) (Doc u)+newtype Doc u a = Doc { getDoc :: DocEnv -> PosObject u a }  -type WidthQuery u = Query u (AdvanceVec u)+type instance DUnit (Doc u a) = u -type TextContextF u = TextContext u -> TextContext u+type DocGraphic u = Doc u (UNil u) -type AElaborateF u = Orientation u -> LocGraphic u +data DocEnv = DocEnv +      { doc_alignment   :: VAlign+      , doc_font_family :: FontFamily+      } +instance Functor (Doc u) where+  fmap f ma = Doc $ \env -> fmap f $ getDoc ma env --- | TextFrame is the result Graphic made from rendering multiple--- lines of DocText.----type TextFrame u = RectAddress -> LocImage u (BoundingBox u)+instance Applicative (Doc u) where+  pure a    = Doc $ \_   -> pure a+  mf <*> ma = Doc $ \env -> getDoc mf env <*> getDoc ma env  --- NOTE - should the API use @em@ for fill, padding etc.?+instance Monad (Doc u) where+  return a  = Doc $ \_   -> return a+  ma >>= k  = Doc $ \env -> getDoc ma env >>= \a -> getDoc (k a) env -blank       :: Doc u-blank       = Empty -space       :: Doc u-space       = Space -string      :: String -> Doc u-string      = Text . escapeString+instance DrawingCtxM (Doc u) where+  askDC           = Doc $ \_   -> askDC +  asksDC fn       = Doc $ \_   -> asksDC fn+  localize upd ma = Doc $ \env -> localize upd (getDoc ma env) -escaped     :: EscapedText -> Doc u-escaped     = Text+instance (Monoid a, InterpretUnit u) => Monoid (Doc u a) where+  mempty = Doc $ \_ -> mempty+  ma `mappend` mb = Doc $ \env -> getDoc ma env `hconcat` getDoc mb env   -int :: InterpretUnit u => Int -> Doc u-int i = integer $ fromIntegral i---integer :: InterpretUnit u => Integer -> Doc u-integer i = Mono (charVector $ CharLiteral '0') (map CharLiteral $ show i)---- | Specialized version of 'ffloat' - the answer is always --- rendered at \"full precision\".----float :: (RealFloat a, InterpretUnit u) => a -> Doc u-float = ffloat Nothing----- | This is equivalent to 'showFFloat' in the Numeric module.--- --- Like 'showFFloat', the answer is rendered to supplied --- precision. @Nothing@ indicated full precision.----ffloat :: (RealFloat a, InterpretUnit u) => (Maybe Int) -> a -> Doc u-ffloat mb d = Mono (charVector $ CharLiteral '0') xs+runDoc :: Doc u a -> VAlign -> FontFamily -> PosObject u a+runDoc ma va ff = getDoc ma env1    where-    xs = (map CharLiteral $ ($ []) $ showFFloat mb d)+    env1 = DocEnv { doc_alignment = va, doc_font_family = ff }   +--------------------------------------------------------------------------------+-- Get vcat vconcat... from the Concat class -infixr 6 <>, <+>+instance (Monoid a, Fractional u, InterpretUnit u) => Concat (Doc u a) where+  hconcat = mappend+  vconcat = vcatImpl +vcatImpl        :: (Monoid a, Fractional u, InterpretUnit u) +                => Doc u a -> Doc u a -> Doc u a+vcatImpl ma mb  = Doc $ \env -> +    let va = doc_alignment env +    in textlineSpace >>= \sep -> +       valignSpace va sep (getDoc ma env) (getDoc mb env) --- | Concatenate two DocTexts separated with no spacing.------ (infixr 6)----(<>) :: Doc u -> Doc u -> Doc u-a <> b = Cat a b- +--------------------------------------------------------------------------------+-- Primitives +infixr 6 <+>+ -- | Concatenate two Docs separated with a space. -- -- (infixr 6) ---(<+>) :: Doc u -> Doc u -> Doc u-a <+> b = a <> space <> b +(<+>) :: InterpretUnit u => DocGraphic u -> DocGraphic u -> DocGraphic u+a <+> b = a `mappend` space `mappend` b  -infixr 5 `vcatl`, `vcatc`, `vcatr` --- | Vertically concatenate - aligning left.--- --- (infixr 5) ----vcatl :: Doc u -> Doc u -> Doc u-vcatl = VCat VLeft --- | Vertically concatenate - aligning center.--- --- (infixr 5) ----vcatc :: Doc u -> Doc u -> Doc u-vcatc = VCat VCenter+blank     :: InterpretUnit u => DocGraphic u+blank     = Doc $ \_ -> posTextPrim (Left "") --- | Vertically concatenate - aligning right.--- --- (infixr 5) ----vcatr :: Doc u -> Doc u -> Doc u-vcatr = VCat VRight+space     :: InterpretUnit u => DocGraphic u+space     = Doc $ \_ -> posCharPrim (Left ' ') -leftAlign  :: [Doc u] -> Doc u-leftAlign  = multiline vcatl -centerAlign  :: [Doc u] -> Doc u-centerAlign  = multiline vcatc+string    :: InterpretUnit u => String -> DocGraphic u+string ss = Doc $ \_ -> posTextPrim (Left ss) -rightAlign  :: [Doc u] -> Doc u-rightAlign  = multiline vcatr  -multiline :: (Doc u -> Doc u -> Doc u) -> [Doc u] -> Doc u-multiline _  []     = blank -multiline op (x:xs) = go x xs-  where-    go a [] = a-    go a (b:bs) = go (a `op` b) bs+escaped     :: InterpretUnit u => EscapedText -> DocGraphic u+escaped esc = Doc $ \_ -> posTextPrim (Right esc) +embedPosObject :: PosObject u a -> Doc u a+embedPosObject ma = Doc $ \_ -> ma   -rfill :: u -> Doc u -> Doc u-rfill = Fill VLeft+--------------------------------------------------------------------------------+-- Change font weight -lfill :: u -> Doc u -> Doc u-lfill = Fill VRight+bold :: Doc u a -> Doc u a +bold ma = Doc $ \env -> +    localize (set_font $ boldWeight $ doc_font_family env)+             (getDoc ma env)  -centerfill :: u -> Doc u -> Doc u-centerfill = Fill VCenter+italic :: Doc u a -> Doc u a +italic ma = Doc $ \env -> +    localize (set_font $ italicWeight $ doc_font_family env)+             (getDoc ma env)  +boldItalic :: Doc u a -> Doc u a +boldItalic ma = Doc $ \env -> +    localize (set_font $ boldItalicWeight $ doc_font_family env)+             (getDoc ma env) -fontColour :: RGBi -> Doc u -> Doc u-fontColour rgb = DLocal (text_colour rgb) +--------------------------------------------------------------------------------+-- Monospace +monospace :: InterpretUnit u => EscapedChar -> EscapedText -> DocGraphic u+monospace ref_ch esc = Doc $ \_ -> +    monospaceEscText (vector_x <$> escCharVector ref_ch) esc -textSize :: Int -> Doc u -> Doc u-textSize sz = DLocal (set_font_size sz)   -bold        :: Doc u -> Doc u-bold        = TLocal (\s -> s { text_bold = True, text_italic = False })--italic      :: Doc u -> Doc u-italic      = TLocal (\s -> s { text_bold = False, text_italic = True })--boldItalic  :: Doc u -> Doc u-boldItalic  = TLocal (\s -> s { text_bold = True, text_italic = True })---strikethrough :: Doc u -> Doc u-strikethrough = TLocal (\s -> s { text_strikethrough = True })--underline :: Doc u -> Doc u-underline = TLocal (\s -> s { text_underline = True })---- | Background fill.----highlight :: (Fractional u, InterpretUnit u) -          => RGBi -> Doc u -> Doc u-highlight rgb = AElab (drawBackfill rgb)----render :: (Real u, Floating u, InterpretUnit u) -       => FontFamily -> Doc u -> (RectAddress -> LocImage u (BoundingBox u))-render ff doc = \raddr -> localize (set_font $ regularWeight ff) $-    textlineSpace               >>= \sep -> -    let po = runEvalM (initTextCtx sep ff) (interpret doc) -    in posTextWithMargins po raddr---data TextContext u = TextContext-      { text_strikethrough      :: Bool-      , text_underline          :: Bool-      , text_sep                :: u-      , text_font_family        :: FontFamily-      , text_bold               :: Bool-      , text_italic             :: Bool-      }-  ---initTextCtx :: u -> FontFamily -> TextContext u-initTextCtx sep ff = TextContext -    { text_strikethrough      = False-    , text_underline          = False-    , text_sep                = sep-    , text_font_family        = ff-    , text_bold               = False-    , text_italic             = False -    }--newtype EvalM u a = EvalM { getEvalM :: TextContext u -> a }---instance Functor (EvalM u) where-  fmap f mf = EvalM $ \ctx -> f $ getEvalM mf ctx+int :: InterpretUnit u => Int -> DocGraphic u+int i = integer $ fromIntegral i  -instance Applicative (EvalM u) where-  pure a    = EvalM $ \_   -> a-  mf <*> ma = EvalM $ \ctx -> -                let f = getEvalM mf ctx-                    a = getEvalM ma ctx-                in f a--instance Monad (EvalM u) where-  return a  = EvalM $ \_   -> a-  ma >>= k  = EvalM $ \ctx -> -                let a = getEvalM ma ctx-                in (getEvalM . k) a ctx--asks :: (TextContext u -> a) -> EvalM u a-asks f = EvalM $ \ctx -> f ctx--lineSpace :: EvalM u u-lineSpace = asks text_sep--local :: (TextContext u -> TextContext u) -> EvalM u a -> EvalM u a-local upd mf = EvalM $ \ctx -> getEvalM mf (upd ctx)--runEvalM :: TextContext u -> EvalM u a -> a-runEvalM ctx mf = getEvalM mf ctx+integer :: InterpretUnit u => Integer -> DocGraphic u+integer i = monospace (CharLiteral '0') (escapeString $ show i)   -interpret :: (Fractional u, Ord u, InterpretUnit u) -          => Doc u -> EvalM u (PosObject u)-interpret Empty             = interpEmpty-interpret Space             = interpSpace-interpret (Text esc)        = interpText esc-interpret (Cat a b)         = hconcat <$> interpret a <*> interpret b-interpret (VCat va a b)     = -    valignSpace va  <$> lineSpace <*> interpret a <*> interpret b--interpret (Fill va w a)     = ppad va w <$> interpret a-interpret (DLocal upd a)    = localPosObject upd <$> interpret a-interpret (TLocal upd a)    = local upd (interpret a)-interpret (Mono q1 xs)      = interpMono q1 xs-interpret (AElab fn a)      = decoPosObject fn ANTERIOR <$> interpret a--+--------------------------------------------------------------------------------  -interpEmpty :: InterpretUnit u => EvalM u (PosObject u)-interpEmpty = -    return $ makePosObject (pure $ Orientation 0 0 0 0) emptyLocImage-+-- | Specialized version of 'ffloat' - the answer is always +-- rendered at \"full precision\".+--+float :: (RealFloat a, InterpretUnit u) => a -> DocGraphic u+float = ffloat Nothing  --- | Note - the current way of seeding the LocGraphic with the --- DrawingContext looks dodgy (substantial copying). +-- | This is equivalent to 'showFFloat' in the Numeric module. -- --- Maybe EvalM should have a private, much smaller --- DrawingContext...+-- Like 'showFFloat', the answer is rendered to supplied +-- precision. @Nothing@ indicated full precision. ---interpText :: (Fractional u, InterpretUnit u) -           => EscapedText -> EvalM u (PosObject u)-interpText esc = interpretLeaf $-    makePosObject (textOrientationZero esc) (dcEscapedlabel esc)-   +ffloat :: (RealFloat a, InterpretUnit u) => (Maybe Int) -> a -> DocGraphic u+ffloat mb d = +    monospace (CharLiteral '0') $ escapeString  $ ($ "") $ showFFloat mb d   --- | Note - a space character is not draw in the output, instead --- 'space' advances the width vector by the width of a space in --- the current font.----interpSpace :: InterpretUnit u -            => EvalM u (PosObject u)-interpSpace = return $ makePosObject qy1  emptyLocImage-  where-    qy1 = charOrientationZero $ CharEscInt $ ord ' '  -ppad :: (Fractional u, Ord u) -     => VAlign -> u -> PosObject u -> PosObject u-ppad VLeft   du = mapOrientation (padXMinor du)-ppad VCenter du = mapOrientation (padHEven $ 0.5 * du)-ppad VRight  du = mapOrientation (padXMajor du) +--------------------------------------------------------------------------------+-- Decorate -interpMono :: (Fractional u, InterpretUnit u)-           => Query u (AdvanceVec u) -> [EscapedChar] -           -> EvalM u (PosObject u)-interpMono avq chs = -    interpretLeaf $ makePosObject (qChars >>= hkernOrientationZero) -                                  (promoteLoc $ \pt -> -                                    zapQuery qChars >>= \ks -> hkernLine ks `at` pt)-  where-    qChars = (\v1 -> monoSpace (advanceH v1) chs) <$> avq+strikethrough :: (Fractional u, InterpretUnit u) +              => Doc u a -> Doc u a+strikethrough = decorateDoc SUPERIOR drawStrikethrough  -                        +underline :: (Fractional u, InterpretUnit u) +          => Doc u a -> Doc u a+underline = decorateDoc SUPERIOR drawUnderline +highlight :: (Fractional u, InterpretUnit u) +          => RGBi -> Doc u a -> Doc u a+highlight rgb = decorateDoc ANTERIOR (drawBackfill rgb) +  -interpretLeaf :: (Fractional u, InterpretUnit u)-              => PosObject u -> EvalM u (PosObject u)-interpretLeaf po = -    (\f1 f2 sty -> f1 $ f2 $ localPosObject sty po) -       <$> (fmap (condE drawUnderline)       $ asks text_underline)-       <*> (fmap (condE drawStrikethrough)   $ asks text_strikethrough)-       <*> textstyle-   where-     condE f b = if b then decoPosObject f SUPERIOR else id -textstyle :: EvalM u DrawingContextF-textstyle = -    fn <$> asks text_font_family <*> asks text_bold <*> asks text_italic-  where-    fn ff False False = set_font $ regularWeight ff-    fn ff True  False = set_font $ boldWeight ff-    fn ff False True  = set_font $ italicWeight ff-    fn ff _     _     = set_font $ boldItalicWeight ff------------------------------------------------------------------------------------- Helpers+decorateDoc :: InterpretUnit u +            => ZDeco -> (Orientation u -> LocGraphic u) -> Doc u a -> Doc u a+decorateDoc zdec fn ma = Doc $ \env -> +    decoratePosObject zdec fn $ getDoc ma env  -monoSpace :: Num u => u -> [EscapedChar] -> [KernChar u]-monoSpace w1 (c:cs) = (0,c) : map (\ch -> (w1,ch)) cs-monoSpace _  []     = []-              -- API might be simple if we conditionally apply strikethrough on @@ -415,43 +250,44 @@ -- fromf font size as well... -- drawStrikethrough :: (Fractional u, InterpretUnit u) -              => Orientation u -> LocGraphic u+                  => Orientation u -> LocGraphic u drawStrikethrough (Orientation xmin xmaj _ ymaj) = -    linestyle $ moveStart (vec (-xmin) vpos) hline +    linestyle $ moveStart (vec (-xmin) vpos) ln   where     vpos  = 0.45 * ymaj-    hline = locStraightLine (hvec $ xmin + xmaj)+    ln    = locStraightLine (hvec $ xmin + xmaj)    drawUnderline :: (Fractional u, InterpretUnit u)                => Orientation u -> LocGraphic u-drawUnderline (Orientation xmin xmaj ymin _) = -    linestyle $ moveStart (vec (-xmin) vpos) hline +drawUnderline (Orientation xmin xmaj _ _) = +    underlinePosition >>= \vpos ->+    linestyle $ moveStart (vec (-xmin) vpos) ln   where-    vpos  = negate $ 0.45 * ymin-    hline = locStraightLine (hvec $ xmin + xmaj)+    ln    = locStraightLine (hvec $ xmin + xmaj) ++-- | This uses underline_thickness ...+-- linestyle :: LocGraphic u -> LocGraphic u linestyle mf = -    pointSize >>= \sz -> -    localize (stroke_use_text_colour . set_line_width (lim sz)) mf-  where-    lim i | i < 10    = 1.0-          | otherwise = (fromIntegral i) / 15.0 +    underlineThickness >>= \sz -> +    localize (stroke_use_text_colour . set_line_width sz) mf  --- | Note - halving the TextMargin looks good.+-- | Note - quarter margin looks good. -- drawBackfill :: (Fractional u, InterpretUnit u) -              => RGBi -> Orientation u -> LocGraphic u+             => RGBi -> Orientation u -> LocGraphic u drawBackfill rgb (Orientation xmin xmaj ymin ymaj) =      textMargin >>= \(dx,dy) -> -    let hdx = 0.5 * dx-        hdy = 0.5 * dy +    let hdx = 0.25 * dx+        hdy = 0.25 * dy      in localize (fill_colour rgb) $ moveStart (mkVec hdx hdy) (mkRect hdx hdy)   where     mkVec  dx dy = vec (negate $ xmin+dx) (negate $ ymin+dy)     mkRect dx dy = let w = dx + xmin + xmaj + dx                        h = dy + ymin + ymaj + dy                    in dcRectangle FILL w h+

@@ -52,71 +52,71 @@ type BoundedLocRectGraphic u = RectAddress -> LocImage u (BoundingBox u)  -locImageLabel :: Floating u +locImageLabel :: InterpretUnit u                => (a -> Anchor u)                -> RectAddress                -> (RectAddress -> LocImage u (BoundingBox u))                -> LocImage u a                -> LocImage u a locImageLabel fn rpos mklabel obj = promoteLoc $ \pt -> -    elaborate (obj `at` pt)  (\a -> ignoreAns $ mklabel rpos `at` fn a)+    selaborate (obj `at` pt)  (\a -> ignoreAns $ mklabel rpos `at` fn a)   -label_center_of :: (Floating u, CenterAnchor a, u ~ DUnit a) +label_center_of :: (InterpretUnit u, CenterAnchor a, u ~ DUnit a)                  => BoundedLocRectGraphic u -> LocImage u a -> LocImage u a label_center_of = locImageLabel center CENTER  -label_left_of :: (Floating u, CardinalAnchor a, u ~ DUnit a) +label_left_of :: (InterpretUnit u, CardinalAnchor a, u ~ DUnit a)                => BoundedLocRectGraphic u -> LocImage u a -> LocImage u a label_left_of = locImageLabel west EE -label_right_of :: (Floating u, CardinalAnchor a, u ~ DUnit a) +label_right_of :: (InterpretUnit u, CardinalAnchor a, u ~ DUnit a)                 => BoundedLocRectGraphic u -> LocImage u a -> LocImage u a label_right_of = locImageLabel east WW  -label_above :: (Floating u, CardinalAnchor a, u ~ DUnit a) +label_above :: (InterpretUnit u, CardinalAnchor a, u ~ DUnit a)              => BoundedLocRectGraphic u -> LocImage u a -> LocImage u a label_above = locImageLabel north SS  -label_below :: (Floating u, CardinalAnchor a, u ~ DUnit a) +label_below :: (InterpretUnit u, CardinalAnchor a, u ~ DUnit a)              => BoundedLocRectGraphic u -> LocImage u a -> LocImage u a label_below = locImageLabel south NN    -connectorPathLabel :: Floating u +connectorPathLabel :: InterpretUnit u                     => (AbsPath u -> Point2 u)                     -> RectAddress                    -> BoundedLocRectGraphic u                    -> Image u (AbsPath u)                     -> Image u (AbsPath u) connectorPathLabel fn rpos lbl img =  -    elaborate img  (\a -> ignoreAns $ lbl rpos `at` (fn a))+    selaborate img  (\a -> ignoreAns $ lbl rpos `at` (fn a))  -label_midway_of :: (Real u, Floating u) +label_midway_of :: (Real u, Floating u, InterpretUnit u)                  => RectAddress                  -> BoundedLocRectGraphic u                  -> Image u (AbsPath u) -> Image u (AbsPath u) label_midway_of = connectorPathLabel midway_  -label_atstart_of :: (Real u, Floating u) +label_atstart_of :: (Real u, Floating u, InterpretUnit u)                   => RectAddress                   -> BoundedLocRectGraphic u                   -> Image u (AbsPath u) -> Image u (AbsPath u) label_atstart_of = connectorPathLabel atstart_  -label_atend_of :: (Real u, Floating u) -                 => RectAddress -                 -> BoundedLocRectGraphic u-                 -> Image u (AbsPath u) -> Image u (AbsPath u)+label_atend_of :: (Real u, Floating u, InterpretUnit u) +               => RectAddress +               -> BoundedLocRectGraphic u+               -> Image u (AbsPath u) -> Image u (AbsPath u) label_atend_of = connectorPathLabel atend_  

@@ -1,73 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Text.Base.PosChar--- Copyright   :  (c) Stephen Tetley 2011--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC------ Drawing single a char as a PosImage.--- -----------------------------------------------------------------------------------module Wumpus.Drawing.Text.Base.PosChar-  ( -    LocRectChar--  , posChar-  , posEscChar--  , charLabel-  , escCharLabel--  ) where--import Wumpus.Drawing.Text.Base.Common--import Wumpus.Basic.Kernel                      -- package: wumpus-basic--import Wumpus.Core                              -- package: wumpus-core---type PosChar u = PosObject u--posChar :: InterpretUnit u => Char -> PosChar u-posChar = makePosChar . CharLiteral--posEscChar :: InterpretUnit u => EscapedChar -> PosChar u-posEscChar = makePosChar------ Note this type doesn\'t support concat...--- --- While it may be adequate, it does need another prefix.----type LocRectChar u = RectAddress -> LocImage u (BoundingBox u)-----charLabel :: (Floating u, InterpretUnit u) => Char -> LocRectChar u-charLabel ch = escCharLabel $ CharLiteral ch---escCharLabel :: (Floating u, InterpretUnit u) -             => EscapedChar -> LocRectChar u-escCharLabel esc = \raddr -> runPosObject raddr (makePosChar esc) ---makePosChar :: InterpretUnit u -            => EscapedChar -> PosObject u-makePosChar esc = makePosObject (charOrientationZero esc) (escText1 esc)---escText1 :: InterpretUnit u => EscapedChar -> LocGraphic u-escText1 ch = dcEscapedlabel $ wrapEscChar ch---

@@ -1,161 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Text.Base.RotTextZero--- Copyright   :  (c) Stephen Tetley 2011--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC------ Direction zero (left-to-right) measured text that supports --- radial inclination. Caveat - rendering at any inclination other --- than the horizontal may not look good in PostScript or SVG.------ \*\* WARNING \*\* - the API for this module needs some polish.------ -----------------------------------------------------------------------------------module Wumpus.Drawing.Text.Base.RotTextZero-  ( -    LocRectTextLine-  , LocTextLine-  , TextObject--  , textline-  , bllTextline-  , blcTextline-  , ccTextline--  , multiAlignLeft-  , multiAlignCenter-  , multiAlignRight--  , rtextline-  , rescTextline--  ) where--import Wumpus.Drawing.Text.Base.Common--import Wumpus.Basic.Kernel                      -- package: wumpus-basic--import Wumpus.Core                              -- package: wumpus-core--import Control.Applicative--type LocRectTextLine u  = RectAddress -> LocImage u (BoundingBox u)-type LocTextLine u      = LocImage u (BoundingBox u)--type TextObject u       = PosObject u------ | Draw a single line of text.----textline :: (Fractional u, InterpretUnit u) -         => String -> LocRectTextLine u-textline ss = posTextWithMargins (makeTextObject ss)---bllTextline :: (Floating u, InterpretUnit u) -            => String -> LocTextLine u-bllTextline ss = textline ss BLL---blcTextline :: (Floating u, InterpretUnit u) -            => String -> LocTextLine u-blcTextline ss = textline ss BLC--ccTextline :: (Floating u, InterpretUnit u) -            => String -> LocTextLine u-ccTextline ss = textline ss CENTER---multiAlignLeft :: (Real u, Floating u, InterpretUnit u) -               => String -> LocRectTextLine u-multiAlignLeft ss = -    renderMultiLine VLeft (map makeTextObject $ lines ss)--multiAlignCenter :: (Real u, Floating u, InterpretUnit u) -                 => String -> LocRectTextLine u-multiAlignCenter ss = -    renderMultiLine VCenter (map makeTextObject $ lines ss)--multiAlignRight :: (Real u, Floating u, InterpretUnit u) -                => String -> LocRectTextLine u-multiAlignRight ss = -    renderMultiLine VRight (map makeTextObject $ lines ss)---renderMultiLine :: (Real u, Floating u, InterpretUnit u) -                => VAlign -> [TextObject u] -> LocRectTextLine u-renderMultiLine va docs = \raddr -> -    body >>= \ans -> posTextWithMargins ans raddr-  where-    body  = (\dy -> alignColumnSep va dy docs) <$> textlineSpace---makeTextObject :: InterpretUnit u => String -> TextObject u-makeTextObject = makeEscTextObject . escapeString ---makeEscTextObject :: InterpretUnit u => EscapedText -> TextObject u-makeEscTextObject esc = -    makePosObject (textOrientationZero esc) (dcEscapedlabel esc)----- Note inclided text will (probably) have to construct with the --- incline angle rather than apply it as part of the run function.-----rtextline :: (Real u, Floating u, Ord u, InterpretUnit u) -          => Radian -> String -> LocRectTextLine u-rtextline ang ss = rescTextline ang (escapeString ss) ---rescTextline :: (Real u, Floating u, Ord u, InterpretUnit u) -          => Radian -> EscapedText -> LocRectTextLine u-rescTextline ang esc = \raddr -> runPosObject raddr $ makePosObject ortt body-  where-    ortt = fmap (rotOrientation ang) $ textOrientationZero esc-    body = incline (dcREscapedlabel esc) ang------ | Rotate an Orientation about its locus.----rotOrientation :: (Real u, Floating u, Ord u) -               => Radian -> Orientation u -> Orientation u-rotOrientation ang (Orientation { or_x_minor = xmin-                                , or_x_major = xmaj-                                , or_y_minor = ymin-                                , or_y_major = ymaj }) = -    orthoOrientation bl br tl tr  -  where-    bl  = rotateAbout ang zeroPt $ P2 (-xmin) (-ymin)-    br  = rotateAbout ang zeroPt $ P2   xmaj  (-ymin)-    tr  = rotateAbout ang zeroPt $ P2   xmaj    ymaj-    tl  = rotateAbout ang zeroPt $ P2 (-xmin)   ymaj-  --orthoOrientation :: (Num u, Ord u)-                 => Point2 u -> Point2 u -> Point2 u -> Point2 u -                 -> Orientation u-orthoOrientation (P2 x0 y0) (P2 x1 y1) (P2 x2 y2) (P2 x3 y3) = -    Orientation { or_x_minor = abs $ min4 x0 x1 x2 x3-                , or_x_major = max4 x0 x1 x2 x3-                , or_y_minor = abs $ min4 y0 y1 y2 y3-                , or_y_major = max4 y0 y1 y2 y3-                }---min4 :: Ord u => u -> u -> u -> u -> u-min4 a b c d = min (min a b) (min c d)--max4 :: Ord u => u -> u -> u -> u -> u-max4 a b c d = max (max a b) (max c d)-

@@ -17,11 +17,37 @@ module Wumpus.Drawing.Text.DirectionZero   (      module Wumpus.Drawing.Text.Base.DocTextZero-  , module Wumpus.Drawing.Text.Base.PosChar-  , module Wumpus.Drawing.Text.Base.RotTextZero +  , textline+  , rtextline+  , multilineText+   ) where  import Wumpus.Drawing.Text.Base.DocTextZero-import Wumpus.Drawing.Text.Base.PosChar-import Wumpus.Drawing.Text.Base.RotTextZero++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core++-- | Note - this is likely to be moved...+-- +-- Also, reversed argument order would be more convenient as +-- RectAddress always short but String could be long. +--+textline :: InterpretUnit u => String -> RectAddress -> BoundedLocGraphic u+textline ss addr = runPosObjectBBox (posText ss) addr+++-- | Note - this is likely to be moved too...+--+rtextline :: (Real u, Floating u, InterpretUnit u)+          => Radian -> String -> RectAddress -> BoundedLocGraphic u+rtextline ang ss addr = runPosObjectBBox (rposText ang ss) addr+++multilineText :: (Fractional u, InterpretUnit u)+              => VAlign -> String -> RectAddress -> BoundedLocGraphic u+multilineText va ss addr = runPosObjectBBox (multilinePosText va ss) addr++

@@ -23,7 +23,7 @@  -- | Version number ----- > (0,4,0)+-- > (0,5,0) -- wumpus_drawing_version :: (Int,Int,Int)-wumpus_drawing_version = (0,4,0)+wumpus_drawing_version = (0,5,0)

@@ -1,5 +1,5 @@ name:             wumpus-drawing-version:          0.4.0+version:          0.5.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -38,6 +38,13 @@   .   Changelog:   .+  v0.4.0 to v0.5.0+  .+  * Re-implemented Text drawing. Some functionality moved to +    Wumpus-Basic.+  .+  * Re-implemented monadic Path Builder.+  .   v0.3.0 to v0.4.0:   .   * Simplified Trapezium shape so it only produces isosceles@@ -82,12 +89,11 @@                       containers      >= 0.3     && <= 0.6,                       vector-space    >= 0.6     && <  1.0,                       wumpus-core     >= 0.51.0  && <  0.52.0,-                      wumpus-basic    == 0.18.0+                      wumpus-basic    == 0.20.0       exposed-modules:     Wumpus.Drawing.Basis.DrawingPrimitives,-    Wumpus.Drawing.Basis.TraceGraphic,     Wumpus.Drawing.Basis.LocTrace,     Wumpus.Drawing.Basis.RefTrace,     Wumpus.Drawing.Colour.SVGColours,@@ -123,11 +129,8 @@     Wumpus.Drawing.Shapes.Semicircle,     Wumpus.Drawing.Shapes.Semiellipse,     Wumpus.Drawing.Shapes.Triangle,-    Wumpus.Drawing.Text.Base.Common,     Wumpus.Drawing.Text.Base.DocTextZero,     Wumpus.Drawing.Text.Base.Label,-    Wumpus.Drawing.Text.Base.PosChar,-    Wumpus.Drawing.Text.Base.RotTextZero,     Wumpus.Drawing.Text.DirectionZero,     Wumpus.Drawing.Text.StandardFontDefs,     Wumpus.Drawing.VersionNumber