wumpus-drawing 0.5.0 → 0.6.0

raw patch · 21 files changed

+243/−726 lines, 21 filesdep ~wumpus-basicPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: wumpus-basic

API changes (from Hackage documentation)

Files

• CHANGES +20/−1
• demo/Automata.hs +2/−2
• demo/ClipPic.hs +25/−19
• demo/DotPic.hs +4/−2
• demo/SingleChar.hs +0/−1
• src/Wumpus/Drawing/Basis/DrawingPrimitives.hs +3/−3
• src/Wumpus/Drawing/Basis/LocTrace.hs +0/−266
• src/Wumpus/Drawing/Basis/RefTrace.hs +0/−292
• src/Wumpus/Drawing/Connectors/Arrowheads.hs +2/−2
• src/Wumpus/Drawing/Connectors/Base.hs +8/−8
• src/Wumpus/Drawing/Connectors/BoxConnectors.hs +1/−1
• src/Wumpus/Drawing/Dots/AnchorDots.hs +9/−1
• src/Wumpus/Drawing/Extras/Clip.hs +1/−1
• src/Wumpus/Drawing/Extras/Grids.hs +5/−5
• src/Wumpus/Drawing/Paths/Base/AbsPath.hs +4/−4
• src/Wumpus/Drawing/Paths/Base/PathBuilder.hs +133/−80
• src/Wumpus/Drawing/Paths/Base/RelPath.hs +4/−4
• src/Wumpus/Drawing/Shapes/Base.hs +10/−8
• src/Wumpus/Drawing/Shapes/Semiellipse.hs +3/−2
• src/Wumpus/Drawing/VersionNumber.hs +2/−2
• wumpus-drawing.cabal +7/−22

@@ -1,5 +1,24 @@ -+0.4.0 to 0.5.0+  +  * Re-implemented Text drawing. Some functionality moved to +    Wumpus-Basic.+  +  * Re-implemented monadic Path Builder.+  +0.3.0 to 0.4.0:+  +  * Simplified Trapezium shape so it only produces isosceles+    Trapeziums.+  +  * Added Basis modules. These are \"mid-level\" modules similar +    to ones in @Wumpus.Basic.Kernel.Objects@, however they are +    considered less general so there are put here where they can +    be imported individually (and so not pollute the namespace).+  +  * Removed the Turtle modules. The new @LocTrace@ and @RefTrace@ +    modules supercede the Turtle modules.+   0.2.0 to 0.3.0:    * Moved Turtle and Grids into the @Wumpus.Drawing.Extras@

@@ -63,7 +63,7 @@ infixr 1 `mat`  mat :: InterpretUnit u => LocImage u a -> Query u (Point2 u) -> Image u a-mat img mq = zapQuery mq >>= \pt -> img `at` pt+mat img mq = liftQuery mq >>= \pt -> img `at` pt  state :: String -> DLocImage DCircle state ss = @@ -100,7 +100,7 @@ arrloop :: ( Real u, Floating u, InterpretUnit u, Tolerance u)         => Anchor u -> Anchor u -> Image u (AbsPath u) arrloop ctr p1 = -    zapQuery (loop zradius ctr zincl) >>= \absp -> +    liftQuery (loop zradius ctr zincl) >>= \absp ->      rightArrowPath tri45 absp    where     v1      = pvec ctr p1

@@ -46,15 +46,21 @@ clip_pic = drawTracing $ localize (fill_colour medium_slate_blue) $ do     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))+                         (drawClosedPath FILL =<< liftLocQuery (extrPathSpec path02))+    drawl (P2 384 416) $ (drawClosedPath FILL =<< liftLocQuery (extrPathSpec path03))+    drawl (P2 328 512) $ (drawClosedPath FILL =<< liftLocQuery (extrPathSpec path04))     drawl (P2   0   0) $ clip1     drawl (P2 112   0) $ clip2     drawl (P2 384  96) $ clip3     drawl (P2 328 192) $ clip4  +extrPathSpec :: InterpretUnit u +             => PathSpec u a -> LocQuery u (RelPath u)+extrPathSpec spec = fmap post $ stripGenPathSpec spec () (PATH_CLOSED STROKE)+  where+    post (_,_,c) = c+ background :: RGBi -> LocGraphic Double background rgb = promoteLoc $ \_ ->      ignoreAns $ localize (text_colour rgb) $ ihh `at` P2 0 288@@ -103,33 +109,33 @@ -- zeroPt 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))+    hpenline 80 +    penline (vec 112 160) +    penline (vec (-112) 160)+    hpenline (-80)+    penline (vec 112 (-160))+    penline (vec (-112) (-160))     ureturn    -- (P2 112 0) 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))+    hpenline 80 +    penline (vec 72 112)+    penline (vec 72 (-112))+    hpenline 80+    penline (vec (-224) 320)+    hpenline (-80)+    penline (vec 112 (-160))+    penline (vec (-112) (-160))     ureturn  -- (P2 384 96)  path03 :: UPathSpec Double-path03 = hlineto 96 >> vlineto 56 >> hlineto (-136) >> ureturn+path03 = hpenline 96 >> vpenline 56 >> hpenline (-136) >> ureturn  -- (P2 328 192) path04 :: UPathSpec Double-path04 = hlineto 152 >> vlineto 56 >> hlineto (-192) >> ureturn+path04 = hpenline 152 >> vpenline 56 >> hpenline (-192) >> ureturn 

@@ -82,9 +82,11 @@ makeDotDrawing (name,df) =      drawing `mappend` moveStart (vec 86 14) lbl   where-    drawing     = execPathSpec $ localize path_style $ +    drawing     = runPathSpec_ path_spec PATH_OPEN++    path_spec   = localize path_style $                      insertl dot >> -                    mapM (\v -> lineto v >> insertl dot) steps >>+                    mapM (\v -> penline v >> insertl dot) steps >>                     ureturn                                                             

@@ -6,7 +6,6 @@  import Wumpus.Drawing.Colour.SVGColours import Wumpus.Drawing.Dots.SimpleDots-import Wumpus.Drawing.Text.DirectionZero import Wumpus.Drawing.Text.StandardFontDefs  import Wumpus.Basic.Kernel                      -- package: wumpus-basic

@@ -101,12 +101,12 @@ -- | Draw an open path formed from straight line segments. -- oStraightLines :: InterpretUnit u => [Point2 u] -> Graphic u-oStraightLines ps = zapQuery (vertexPP ps) >>= dcOpenPath+oStraightLines ps = liftQuery (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+cStraightLines sty ps = liftQuery (vertexPP ps) >>= dcClosedPath sty   --------------------------------------------------------------------------------@@ -142,7 +142,7 @@ arc :: (Floating u, InterpretUnit u) => u -> Radian -> LocThetaGraphic u arc radius ang = promoteLocTheta $ \pt inclin ->      let ps = bezierArcPoints ang radius inclin pt-    in zapQuery (curvePP ps) >>= dcOpenPath+    in liftQuery (curvePP ps) >>= dcOpenPath  -- | wedge : radius * apex_angle -- 

@@ -1,266 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# OPTIONS -Wall #-}-------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Basis.LocTrace--- Copyright   :  (c) Stephen Tetley 2011--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  highly unstable--- Portability :  GHC ------ Writer monad with imperative /turtle/ style movement to build --- LocGraphics.--------------------------------------------------------------------------------------module Wumpus.Drawing.Basis.LocTrace-  (--  -- * LocTrace monads-    LocTrace-  , LocTraceT--  , runLocTrace-  , evalLocTrace-  , execLocTrace--  , runLocTraceT-  , evalLocTraceT-  , execLocTraceT--  , liftLocTraceT--  -- * LocTrace classes-  , LocTraceM(..)-  , LocForkTraceM(..)--  -- * Derived operations-  , hmoveBy-  , vmoveBy--  )--  where--import Wumpus.Basic.Kernel                      -- package: wumpus-basic--import Wumpus.Core                              -- package: wumpus-core--import Data.VectorSpace                         -- package: vector-space--import Control.Applicative-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--- displacement vector (called a cursor below).----newtype LocTrace u a = LocTrace { -          getLocTrace :: Vec2 u -> (a, Vec2 u, LocGraphic u )}---type instance DUnit (LocTrace u a) = u----- Do we need a transformer version --- | LocTrace is a writer state monad.------ The writer accumulates a LocGraphic the state is a cumulative--- displacement vector.----newtype LocTraceT u m a = LocTraceT { -          getLocTraceT :: Vec2 u -> m (a, Vec2 u, LocGraphic u )}---type instance DUnit (LocTraceT u m a) = u---type instance MonUnit (LocTrace u a) = u-type instance MonUnit (LocTraceT u m a) = u----- Functor--instance Functor (LocTrace u) where-  fmap f ma = LocTrace $ \v0 -> let (a,v1,o) = getLocTrace ma v0-                                in (f a, v1, o)--instance Monad m => Functor (LocTraceT u m) where-  fmap f ma = LocTraceT $ \v0 -> getLocTraceT ma v0 >>= \(a,v1,o) -> -                                 return (f a, v1, o)---- Applicative--instance Applicative (LocTrace u) where-  pure a    = LocTrace $ \v0 -> (a, v0, mempty)-  mf <*> ma = LocTrace $ \v0 -> -                let (f,v1,o1) = getLocTrace mf v0-                    (a,v2,o2) = getLocTrace ma v1-                in (f a, v2, o1 `mappend` o2)-----instance Monad m => Applicative (LocTraceT u m) where-  pure a    = LocTraceT $ \v0 -> return (a, v0, mempty)-  mf <*> ma = LocTraceT $ \v0 -> -                getLocTraceT mf v0 >>= \(f,v1,o1) ->-                getLocTraceT ma v1 >>= \(a,v2,o2) ->-                return (f a, v2, o1 `mappend` o2)------ Monad--instance Monad (LocTrace u) where-  return a  = LocTrace $ \v0 -> (a, v0, mempty)-  ma >>= k  = LocTrace $ \v0 -> -                let (a,v1,o1) = getLocTrace ma v0-                    (b,v2,o2) = (getLocTrace . k) a v1-                in (b, v2, o1 `mappend` o2)--instance Monad m => Monad (LocTraceT u m) where-  return a  = LocTraceT $ \v0 -> return (a, v0, mempty)-  ma >>= k  = LocTraceT $ \v0 -> -                getLocTraceT ma v0 >>= \(a,v1,o1) ->-                (getLocTraceT . k) a v1 >>= \(b,v2,o2) -> -                return (b, v2, o1 `mappend` o2)----runLocTrace :: Num u => LocTrace u a -> (a, Vec2 u, LocGraphic u)-runLocTrace mf = getLocTrace mf (V2 0 0)----- | Forget the generated LocImage, just return the /answer/.----evalLocTrace :: Num u => LocTrace u a -> a-evalLocTrace = post . runLocTrace-  where-    post (a,_,_) = a---- | Forget the /answer/, just return the generated LocImage.----execLocTrace :: Num u => LocTrace u a -> LocGraphic u-execLocTrace = post . runLocTrace-  where-    post (_,_,o) = o----runLocTraceT :: (Monad m, Num u) -             => LocTraceT u m a -> m (a, Vec2 u, LocGraphic u)-runLocTraceT mf = getLocTraceT mf (V2 0 0)----- | Forget the generated LocImage, just return the /answer/.----evalLocTraceT :: (Monad m, Num u) => LocTraceT u m a -> m a-evalLocTraceT = liftM post . runLocTraceT-  where-    post (a,_,_) = a---- | Forget the /answer/, just return the generated LocImage.----execLocTraceT :: (Monad m, Num u) => LocTraceT u m a -> m (LocGraphic u)-execLocTraceT = liftM post . runLocTraceT-  where-    post (_,_,o) = o----liftLocTraceT :: Monad m => m a -> LocTraceT u m a -liftLocTraceT ma = LocTraceT $ \v0 -> -                             ma >>= \a -> return (a,v0,mempty)------- | 'insertl' analogue to Writer monad @tell@.----class Monad m => LocTraceM (m :: * -> *) where-  insertl   :: MonUnit (m ()) ~ u => LocGraphic u -> m ()-  insertl_  :: MonUnit (m ()) ~ u => LocImage u a -> m ()-  -  moveBy    :: MonUnit (m ()) ~ u => Vec2 u -> m ()-  location  :: MonUnit (m ()) ~ u => m (Vec2 u)---  insertl_ = insertl . ignoreAns ------ Note - @reset@ steals a too general name. --- It needs changing...---- | Add operations for branching (fork at the current point)--- and resetting to the start point.--- --- Not all drawings that support tracing support branching. For--- instance Paths can be built by tracing but they always need --- a cumulative progression of /next point/ they cannot resrt to --- the start point and go in a differnt direction.--- -class LocTraceM m => LocForkTraceM (m :: * -> *) where-  reset     :: m ()--  -- Branch is like @local@ in the Reader monad.-  branch    :: m a -> m a------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 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, 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, 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)-------------------------------------------------------------------------------------- Derived operations----- | Move the /cursor/ horizontally.----hmoveBy :: (LocTraceM m, Num u, u ~ MonUnit (m ())) => u -> m ()-hmoveBy dx = moveBy (hvec dx)---- | Move the /cursor/ vertically.----vmoveBy :: (LocTraceM m, Num u, u ~ MonUnit (m ())) => u -> m ()-vmoveBy dx = moveBy (vvec dx)

@@ -1,292 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# OPTIONS -Wall #-}-------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Basis.RefTrace--- Copyright   :  (c) Stephen Tetley 2011--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  highly unstable--- Portability :  GHC ------ Writer monad with imperative /turtle/ style movement to build --- LocGraphics and /references/ allowing connectors between --- objects.------ Note - references are not /feedback/. Subsequent nodes cannot--- be place at anchors of previous nodes - anchors only allow--- connectors to be drawn between located nodes.--------------------------------------------------------------------------------------module Wumpus.Drawing.Basis.RefTrace-  (--    -- * Re-exports-    LocTraceM(..)--  , RefTrace-  , RefTraceT--  , Ref-  , RefTraceM(..)--  , runRefTrace-  , runRefTraceT--  , Lookup-  , RefGraphic-  , lookup-  , unary-  , binary-  , multiway-  , oneToMany--  )--  where--import Wumpus.Drawing.Basis.LocTrace--import Wumpus.Basic.Kernel                      -- package: wumpus-basic-import qualified Wumpus.Basic.Utils.JoinList as JL--import Wumpus.Core                              -- package: wumpus-core--import Data.VectorSpace                         -- package: vector-space--import Control.Applicative-import Control.Monad-import qualified Data.IntMap as IntMap-import Data.Maybe-import Data.Monoid-import Prelude hiding ( lookup )-----newtype RefTrace u z a = RefTrace { -          getRefTrace :: RefSt u z -> (a, RefSt u z) }---type instance MonUnit (RefTrace u z a) = u--newtype RefTraceT u z m a = RefTraceT { -          getRefTraceT :: RefSt u z -> m (a, RefSt u z) }---type instance MonUnit (RefTraceT u z m a) = u---newtype Ref = Ref { getRefUid :: Int }---type Lookup u ans = IntMap.IntMap ans -> Query u (Maybe ans)-type RefGraphic u ans = IntMap.IntMap ans -> 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 (RefGraphic u z)-      }----type instance DUnit (RefSt u z) = u--type RefStF u z = RefSt u z -> RefSt u z ---zeroRefSt :: Num u => RefSt u z-zeroRefSt = RefSt { uid_count   = 0-                  , current_tip = V2 0 0-                  , ref_acc     = mempty-                  , ref_links   = mempty      -                  }------- Functor--instance Functor (RefTrace u z) where-  fmap f ma = RefTrace $ \s0 -> let (a,s1) = getRefTrace ma s0 in (f a, s1)--instance Monad m => Functor (RefTraceT u z m) where-  fmap f ma = RefTraceT $ \s0 -> getRefTraceT ma s0 >>= \(a,s1) ->-                                 return (f a, s1)------ Applicative--instance Applicative (RefTrace u z) where-  pure a    = RefTrace $ \s0 -> (a, s0)-  mf <*> ma = RefTrace $ \s0 -> -                let (f,s1) = getRefTrace mf s0-                    (a,s2) = getRefTrace ma s1-                in (f a, s2)----instance Monad m => Applicative (RefTraceT u z m) where-  pure a    = RefTraceT $ \s0 -> return (a, s0)-  mf <*> ma = RefTraceT $ \s0 -> getRefTraceT mf s0 >>= \(f,s1) -> -                                 getRefTraceT ma s1 >>= \(a,s2) ->-                                 return (f a, s2)------ Monad--instance Monad (RefTrace u z) where-  return a  = RefTrace $ \s0 -> (a, s0)-  ma >>= k  = RefTrace $ \s0 -> -                let (a,s1) = getRefTrace ma s0-                in (getRefTrace . k) a s1---instance Monad m => Monad (RefTraceT u z m) where-  return a  = RefTraceT $ \s0 -> return (a, s0)-  ma >>= k  = RefTraceT $ \s0 -> getRefTraceT ma s0 >>= \(a,s1) ->-                                 (getRefTraceT . k) a s1-                ------ LocTraceM--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, 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)------ Run functions--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, 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------ Note we have to drop the vector--reconcileRefSt :: InterpretUnit u => RefSt u z -> LocGraphic u-reconcileRefSt st = -    ignoreAns $ selaborate (ref_acc st) -                           (\a -> mconcat $ map (fn a) $ JL.toList $ ref_links st)-  where-    fn im g = promoteLoc $ \_ -> g 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) => RefGraphic u a -> m ()--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)--  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 :: InterpretUnit u => LocImage u z2 -> RefStF u ans-insertSt gf = (\s ac v1 -> let g1 = ignoreAns $ moveStart v1 gf-                           in s { ref_acc = sdecorate ac g1 }) -                <*> ref_acc <*> current_tip--snocLink :: RefGraphic u ans -> RefStF u ans-snocLink fn = (\s i -> s { ref_links = JL.snoc i fn }) -                <*> ref_links---incrementSt :: InterpretUnit u -            => LocImage u ans -> RefSt u ans -> (Int, RefSt u ans)-incrementSt img s0 = (uid_count s0, upd s0)-  where-    upd = (\s ac v1 ix -> let img1 = moveStart v1 img-                          in s { ref_acc   = fn ix ac img1-                               , uid_count = ix+1 }) -                <*> ref_acc <*> current_tip <*> uid_count --    fn ix ac gf = fmap (\(a,b) -> IntMap.insert ix b a) $ both ac gf----

@@ -459,7 +459,7 @@   where     body = promoteLocTheta $ \pt theta ->               localize (join_bevel . solid_stroke_tip) $ -               zapQuery (toPrimPath $ curveTipPath pt theta) >>= dcOpenPath+               liftQuery (toPrimPath $ curveTipPath pt theta) >>= dcOpenPath   @@ -485,7 +485,7 @@   where     body = promoteLocTheta $ \pt theta ->               localize (join_bevel . solid_stroke_tip) $ -               zapQuery (toPrimPath $ curveTipRevPath pt theta) >>= dcOpenPath+               liftQuery (toPrimPath $ curveTipRevPath pt theta) >>= dcOpenPath       

@@ -80,7 +80,7 @@ rightArrow :: (Real u, Floating u, InterpretUnit u)              => ArrowTip -> Connector u -> ArrowConnector u rightArrow alg conn = promoteConn $ \p0 p1 ->-    zapConnectorQuery conn p0 p1 >>= \full_path -> +    applyConn (liftConnectorQuery conn) p0 p1 >>= \full_path ->      rightArrowPath alg full_path   @@ -90,7 +90,7 @@ leftArrow :: (Real u, Floating u, InterpretUnit u)              => ArrowTip -> Connector u -> ArrowConnector u leftArrow alg conn = promoteConn $ \p0 p1 ->-    zapConnectorQuery conn p0 p1 >>= \full_path -> +    applyConn (liftConnectorQuery conn) p0 p1 >>= \full_path ->      leftArrowPath alg full_path   @@ -100,7 +100,7 @@ leftRightArrow :: (Real u, Floating u, InterpretUnit u)                 => ArrowTip -> ArrowTip ->  Connector u -> ArrowConnector u leftRightArrow algl algr conn = promoteConn $ \p0 p1 ->-    zapConnectorQuery conn p0 p1 >>= \full_path -> +    applyConn (liftConnectorQuery conn) p0 p1 >>= \full_path ->      leftRightArrowPath algl algr full_path   @@ -111,7 +111,7 @@ uniformArrow :: (Real u, Floating u, InterpretUnit u)                 => ArrowTip ->  Connector u -> ArrowConnector u uniformArrow alg conn = promoteConn $ \p0 p1 ->-    zapConnectorQuery conn p0 p1 >>= \full_path -> +    applyConn (liftConnectorQuery conn) p0 p1 >>= \full_path ->      leftRightArrowPath alg alg full_path   @@ -128,7 +128,7 @@ leftArrowPath :: (Real u, Floating u, InterpretUnit u)                => ArrowTip -> AbsPath u -> Image u (AbsPath u) leftArrowPath alg full_path =-    zapQuery (runArrowTip alg) >>= \(retract, len, deco) -> +    liftQuery (runArrowTip alg) >>= \(retract, len, deco) ->      let short_path      = if retract > 0 then shortenL retract full_path                                           else full_path         mid_ang         = tipDirectionL len full_path@@ -146,7 +146,7 @@ rightArrowPath :: (Real u, Floating u, InterpretUnit u)                 => ArrowTip -> AbsPath u -> Image u (AbsPath u) rightArrowPath alg full_path =-    zapQuery (runArrowTip alg) >>= \(retract, len, deco) -> +    liftQuery (runArrowTip alg) >>= \(retract, len, deco) ->      let short_path      = if retract > 0 then shortenR retract full_path                                           else full_path         mid_ang         = tipDirectionR len full_path@@ -165,8 +165,8 @@ leftRightArrowPath :: (Real u, Floating u, InterpretUnit u)                     => ArrowTip -> ArrowTip -> AbsPath u -> Image u (AbsPath u) leftRightArrowPath algl algr full_path =-    zapQuery (runArrowTip algl) >>= \(retractl, lenl, decol) -> -    zapQuery (runArrowTip algr) >>= \(retractr, lenr, decor) -> +    liftQuery (runArrowTip algl) >>= \(retractl, lenl, decol) -> +    liftQuery (runArrowTip algr) >>= \(retractr, lenr, decor) ->      let short_path      = shortenPath retractl retractr full_path         mid_angl        = tipDirectionL lenl full_path         mid_angr        = tipDirectionR lenr full_path

@@ -62,4 +62,4 @@         tl  = dispOrtho (V2 (-src_arm)   src_arm ) ang p0         br  = dispOrtho (V2   dst_arm  (-src_arm)) ang p1         tr  = dispOrtho (V2   dst_arm    src_arm ) ang p1-    in zapQuery (vertexPP [ bl, br, tr, tl ]) >>= dcClosedPath STROKE+    in liftQuery (vertexPP [ bl, br, tr, tl ]) >>= dcClosedPath STROKE

@@ -88,6 +88,14 @@  type instance DUnit (DotAnchor u) = u +instance Num u => Translate (DotAnchor u) where+  translate x y (DotAnchor ctr radialF cardinalF) = +      DotAnchor { center_anchor   = translate x y ctr+                , radial_anchor   = translate x y . radialF +                , cardinal_anchor = translate x y . cardinalF +                }++ instance CenterAnchor (DotAnchor u) where   center (DotAnchor ca _ _) = ca @@ -190,7 +198,7 @@    in rectangleAnchor hw hh (bl .+^ vec hw hh)  -zeroLDO :: LocQuery u (DotAnchor u)+zeroLDO :: InterpretUnit u => LocQuery u (DotAnchor u) zeroLDO = qpromoteLoc $ \pt -> return $ zeroAnchor pt  rectangleLDO :: (Real u, Floating u, InterpretUnit u) 

@@ -37,5 +37,5 @@ -- locClip :: InterpretUnit u => RelPath u -> LocGraphic u -> LocGraphic u locClip rp gf = promoteLoc $ \pt -> -    zapQuery (toPrimPath pt rp) >>= \pp -> clipImage pp (gf `at` pt)+    liftQuery (toPrimPath pt rp) >>= \pp -> clipImage pp (gf `at` pt) 

@@ -36,9 +36,9 @@   import Wumpus.Drawing.Basis.DrawingPrimitives-import Wumpus.Drawing.Basis.LocTrace  import Wumpus.Basic.Kernel                      -- package: wumpus-basic+ import Wumpus.Core                              -- package: wumpus-core import Wumpus.Core.Colour ( black ) @@ -200,11 +200,11 @@ minorMajor :: InterpretUnit u             => Int -> Int -> Vec2 u -> LocGraphic u -> LocGraphic u             -> LocGraphic u-minorMajor count alt mv mnr mjr = execLocTrace (step count)+minorMajor count alt mv mnr mjr = runLocTrace (step count)   where-    step n | n <= 0           = return ()-           | n `mod` alt == 0 = insertl mjr >> moveBy mv >> step (n-1)-           | otherwise        = insertl mnr >> moveBy mv >> step (n-1)+    step n | n <= 0           = ureturn+           | n `mod` alt == 0 = insertl mjr >> moveby mv >> step (n-1)+           | otherwise        = insertl mnr >> moveby mv >> step (n-1)    

@@ -408,23 +408,23 @@ drawOpenPath :: InterpretUnit u               => AbsPath u -> Image u (AbsPath u) drawOpenPath rp = replaceAns rp $-    zapQuery (toPrimPath rp) >>= dcOpenPath+    liftQuery (toPrimPath rp) >>= dcOpenPath   drawOpenPath_ :: InterpretUnit u                => AbsPath u -> Graphic u-drawOpenPath_ rp = zapQuery (toPrimPath rp) >>= dcOpenPath+drawOpenPath_ rp = liftQuery (toPrimPath rp) >>= dcOpenPath   drawClosedPath :: InterpretUnit u                 => DrawStyle -> AbsPath u -> Image u (AbsPath u) drawClosedPath sty rp = replaceAns rp $ -    zapQuery (toPrimPath rp) >>= dcClosedPath sty+    liftQuery (toPrimPath rp) >>= dcClosedPath sty   drawClosedPath_ :: InterpretUnit u                  => DrawStyle -> AbsPath u -> Graphic u-drawClosedPath_ sty rp = zapQuery (toPrimPath rp) >>= dcClosedPath sty+drawClosedPath_ sty rp = liftQuery (toPrimPath rp) >>= dcClosedPath sty   -- | Turn a Path into an ordinary PrimPath.

@@ -21,41 +21,42 @@ module Wumpus.Drawing.Paths.Base.PathBuilder   (  -    LocTraceM(..) -- re-export -  , GenPathSpec+    GenPathSpec   , PathSpec   , Vamp(..)-+  , PathTerm(..)    , runGenPathSpec+  , execGenPathSpec+  , evalGenPathSpec+  , stripGenPathSpec+   , runPathSpec-  , execPathSpec-  , evalPathSpec-  , extrPathSpec+  , runPathSpec_ ---  , execPivot+  , runPivot -  , pathTip -  , lineto-  , curveto-  , moveto+  , penline+  , pencurve+       , breakPath-  , hlineto-  , vlineto-  , alineto+  , hpenline+  , vpenline+  , apenline +  , penlines+  , pathmoves+   , vamp   , cycleSubPath   , localPen     ) where -import Wumpus.Drawing.Basis.LocTrace import Wumpus.Drawing.Paths.Base.RelPath--- import qualified Wumpus.Drawing.Paths.Base.RelPath as R   import Wumpus.Basic.Kernel                      -- package: wumpus-basic@@ -64,7 +65,7 @@   import Data.AffineSpace                         -- package: vector-space--- import Data.VectorSpace+import Data.VectorSpace  import Control.Applicative import Control.Monad@@ -78,7 +79,6 @@  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 @@ -120,7 +120,7 @@   -data PathTerm = SUBPATH_OPEN | SUBPATH_CLOSED DrawStyle+data PathTerm = PATH_OPEN | PATH_CLOSED DrawStyle   deriving (Eq,Show)  @@ -192,53 +192,78 @@                       in ((), pt, s {st_user_state =  upd ust}, mempty)  --- | Note - location probably should return Point2 not Vec2 hence --- this uses @cheat@ temporarily.------ 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 +-- LocationM++instance InterpretUnit u => LocationM (GenPathSpec st u) where+  location = locationImpl+++-- CursorM ++instance InterpretUnit u => CursorM (GenPathSpec st u) where+  moveby   = movebyImpl+++-- InsertlM++instance InterpretUnit u => InsertlM (GenPathSpec st u) where+  insertl  = insertlImpl+            +--------------------------------------------------------------------------------+-- Run functions  runGenPathSpec :: InterpretUnit u -               => GenPathSpec st u a -> st -> LocImage u (a, RelPath u)-runGenPathSpec ma st = promoteLoc $ \pt -> +               => GenPathSpec st u a -> st -> PathTerm +               -> LocImage u (a, st, RelPath u)+runGenPathSpec ma st term = 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+        (_,wcp)   = runImage (drawActivePen term $ st_active_pen s) ctx         wfinal    = w_trace w `mappend` wcp-    in replaceAns (a,upath) $ primGraphic wfinal+    in replaceAns (a, st_user_state s, upath) $ primGraphic wfinal  -runPathSpec :: InterpretUnit u-            => PathSpec u a -> LocImage u (a, RelPath u)-runPathSpec ma = runGenPathSpec ma ()+-- Note - eval and exec return the RelPath this is as-per RWS+-- which returns @w@ for execRWS (s,w) and evalRWS (a,w)+-- +evalGenPathSpec :: InterpretUnit u+                => GenPathSpec st u a -> st -> PathTerm +                -> LocImage u (a, RelPath u)+evalGenPathSpec ma st term = +    (\(a,_,w) -> (a,w)) <$> runGenPathSpec ma st term -evalPathSpec :: InterpretUnit u-             => PathSpec u a -> LocImage u (RelPath u)-evalPathSpec ma = snd <$> runPathSpec ma+     +execGenPathSpec :: InterpretUnit u+                => GenPathSpec st u a -> st -> PathTerm +                -> LocImage u (st, RelPath u)+execGenPathSpec ma st term =+    (\(_,s,w) -> (s,w)) <$> runGenPathSpec ma st term -execPathSpec :: InterpretUnit u-             => PathSpec u a -> LocImage u a-execPathSpec ma = fst <$> runPathSpec ma  +stripGenPathSpec :: InterpretUnit u+                 => GenPathSpec st u a -> st -> PathTerm +                 -> LocQuery u (a, st, RelPath u)+stripGenPathSpec ma st term = stripLocImage $ runGenPathSpec ma st term -extrPathSpec :: InterpretUnit u-             => PathSpec u a -> LocQuery u (RelPath u)-extrPathSpec ma = extrLoc $ evalPathSpec ma +runPathSpec :: InterpretUnit u+            => PathSpec u a -> PathTerm -> LocImage u (a, RelPath u)+runPathSpec ma term = evalGenPathSpec ma () term +runPathSpec_ :: InterpretUnit u+             => PathSpec u a -> PathTerm -> LocGraphic u+runPathSpec_ ma term = ignoreAns $ evalGenPathSpec ma () term+++ -- Monad run function nomenclature: -- -- > run  - both@@ -266,34 +291,42 @@ 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+    PATH_OPEN -> ignoreAns $ drawOpenPath rp `at` pt+    PATH_CLOSED styl -> ignoreAns $ drawClosedPath styl rp `at` pt      -{- + -- | Form a \"pivot path\" drawing from two path specifications. -- The start point of the drawing is the pivot formed by joining -- the paths. ---execPivot :: (Floating u, InterpretUnit u)+runPivot :: (Floating u, InterpretUnit u)           => PathSpec u a -> PathSpec u a -> LocGraphic u-execPivot ma mb = moveStart (negateV v) $ pen `mappend` ins+runPivot ma mb = promoteLoc $ \pt -> +    askDC >>= \ctx ->+    let dpt         = normalizeF (dc_font_size ctx) pt+        st_zero     = PathSt (zeroActivePath dpt) ()+        (p1,_,s,w1) = getGenPathSpec mz ctx dpt st_zero+        dp1         = normalizeF (dc_font_size ctx) p1+        v1          = pvec dpt dp1+        (_,wcp)     = runImage (drawActivePen PATH_OPEN $ st_active_pen s) ctx+        wfinal      = w_trace w1 `mappend` wcp        +    in primGraphic $ cpmove (negateV v1) wfinal   where-   (v, _, _, pen, ins) = runPathSpec ( ma >> location >>= \ans -> -                                       mb >> return ans )--}+    mz = ma >> location >>= \pt -> mb >> return pt + -------------------------------------------------------------------------------- -- operations  -pathTip :: InterpretUnit u => GenPathSpec st u (Point2 u)-pathTip = GenPathSpec $ \ctx pt s ->+locationImpl :: InterpretUnit u => GenPathSpec st u (Point2 u)+locationImpl = GenPathSpec $ \ctx pt s ->     let upt = dinterpF (dc_font_size ctx) pt     in (upt, pt, s, mempty) @@ -304,9 +337,19 @@ extendPen pt v PEN_UP           = PEN_DOWN pt (line1 v) extendPen _  v (PEN_DOWN p0 rp) = PEN_DOWN p0 (rp `snocLineTo` v) +--+-- NOTE - /lineto/ needs a new name as the @to@ suffix suggests+-- moving to a point, whereas the movement is @by@ a vector.+--+-- @relline@ not a good candidate, need a name that supports +-- horizontal (h) and vertical (v) versions.+-- -lineto :: InterpretUnit u => Vec2 u -> GenPathSpec st u ()-lineto v1 = GenPathSpec $ \ctx pt s -> ++-- | Extend the path with a line, drawn by the pen.+-- +penline :: InterpretUnit u => Vec2 u -> GenPathSpec st u ()+penline v1 = GenPathSpec $ \ctx pt s ->     let sz  = dc_font_size ctx        dv1 = normalizeF sz v1        pen = extendPen pt dv1 (st_active_pen s)@@ -323,9 +366,11 @@   -curveto :: InterpretUnit u +-- | Extend the path with a curve, drawn by the pen.+-- +pencurve :: InterpretUnit u          => Vec2 u -> Vec2 u -> Vec2 u -> GenPathSpec st u ()-curveto v1 v2 v3 = GenPathSpec $ \ctx pt s -> +pencurve v1 v2 v3 = GenPathSpec $ \ctx pt s ->     let sz  = dc_font_size ctx        dv1 = normalizeF sz v1        dv2 = normalizeF sz v2@@ -335,39 +380,46 @@    in ((), pt .+^ dv1, s { st_active_pen = pen }, w1)  --- | @moveto@ causes a pen up.+-- | @moveby@ causes a pen up. ---moveto :: InterpretUnit u => Vec2 u -> GenPathSpec st u ()-moveto v1 = GenPathSpec $ \ctx pt s -> +movebyImpl :: InterpretUnit u => Vec2 u -> GenPathSpec st u ()+movebyImpl 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+        (_,wcp) = runImage (drawActivePen PATH_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)   breakPath :: InterpretUnit u => GenPathSpec st u ()-breakPath = moveto (V2 0 0)+breakPath = movebyImpl (V2 0 0) -hlineto :: InterpretUnit u => u -> GenPathSpec st u ()-hlineto dx = lineto (hvec dx)+hpenline :: InterpretUnit u => u -> GenPathSpec st u ()+hpenline dx = penline (hvec dx) -vlineto :: InterpretUnit u => u -> GenPathSpec st u ()-vlineto dy = lineto (vvec dy)+vpenline :: InterpretUnit u => u -> GenPathSpec st u ()+vpenline dy = penline (vvec dy)  -alineto :: (Floating u, InterpretUnit u) -        => Radian -> u -> GenPathSpec st u ()-alineto ang d = lineto (avec ang d)+apenline :: (Floating u, InterpretUnit u) +         => Radian -> u -> GenPathSpec st u ()+apenline ang d = penline (avec ang d) +penlines :: InterpretUnit u => [Vec2 u] -> GenPathSpec st u ()+penlines = mapM_ penline -insertLocImage :: InterpretUnit u -               => LocImage u a -> GenPathSpec st u ()-insertLocImage gf = GenPathSpec $ \ctx pt s ->+pathmoves :: InterpretUnit u => [Vec2 u] -> GenPathSpec st u ()+pathmoves = mapM_ moveby++++insertlImpl :: InterpretUnit u +            => LocImage u a -> GenPathSpec st u a+insertlImpl gf = GenPathSpec $ \ctx pt s ->     let upt     = dinterpF (dc_font_size ctx) pt-        (_,wcp) = runLocImage gf ctx upt+        (a,wcp) = runLocImage gf ctx upt         w1      = PathW { w_rel_path = mempty, w_trace = wcp }-    in ((), pt, s, w1)+    in (a, pt, s, w1)   @@ -375,7 +427,7 @@ 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+        (_,wcp) = runImage (drawActivePen PATH_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 }@@ -384,7 +436,7 @@  cycleSubPath :: DrawStyle -> GenPathSpec st u () cycleSubPath styl = GenPathSpec $ \ctx pt s ->-    let gf      = drawActivePen (SUBPATH_CLOSED styl) $ st_active_pen s+    let gf      = drawActivePen (PATH_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)@@ -405,8 +457,9 @@  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+    let (_,wcp)      = runImage (drawActivePen PATH_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 }+        w2           = let wcp2 = wcp `mappend` w_trace w1 +                       in w1 { w_trace = wcp2 }     in (a, p1, s1 { st_active_pen = PEN_UP }, w2) 

@@ -343,21 +343,21 @@ drawOpenPath :: InterpretUnit u               => RelPath u -> LocImage u (RelPath u) drawOpenPath rp = replaceAns rp $-    promoteLoc $ \start -> zapQuery (toPrimPath start rp) >>= dcOpenPath+    promoteLoc $ \start -> liftQuery (toPrimPath start rp) >>= dcOpenPath  drawOpenPath_ :: InterpretUnit u                => RelPath u -> LocGraphic u drawOpenPath_ rp = promoteLoc $ \start -> -    zapQuery (toPrimPath start rp) >>= dcOpenPath+    liftQuery (toPrimPath start rp) >>= dcOpenPath   drawClosedPath :: InterpretUnit u                 => DrawStyle -> RelPath u -> LocImage u (RelPath u) drawClosedPath sty rp = replaceAns rp $ -    promoteLoc $ \start -> zapQuery (toPrimPath start rp) >>= dcClosedPath sty+    promoteLoc $ \start -> liftQuery (toPrimPath start rp) >>= dcClosedPath sty  drawClosedPath_ :: InterpretUnit u                  => DrawStyle -> RelPath u -> LocGraphic u drawClosedPath_ sty rp = promoteLoc $ \start -> -    zapQuery (toPrimPath start rp) >>= dcClosedPath sty+    liftQuery (toPrimPath start rp) >>= dcClosedPath sty 

@@ -89,7 +89,8 @@  -------------------------------------------------------------------------------- -shapeMap :: (t u -> t' u) -> Shape t u -> Shape t' u+shapeMap :: InterpretUnit u +         => (t u -> t' u) -> Shape t u -> Shape t' u shapeMap f = (\s sf -> s { shape_ans_fun = qpromoteLocTheta $ \pt ang ->                                             fmap f $ qapplyLocTheta sf pt ang })                  <*> shape_ans_fun@@ -151,10 +152,10 @@ shapeToLoc :: InterpretUnit u            => (PrimPath -> Graphic u) -> Shape t u -> LocImage u (t u) shapeToLoc drawF sh = promoteLoc $ \pt -> -    zapLocThetaQuery (shape_ans_fun sh)  pt 0 >>= \a -> -    zapLocThetaQuery (shape_path_fun sh) pt 0 >>= \spath -> +    applyLocTheta (liftLocThetaQuery $ shape_ans_fun sh)  pt 0 >>= \a -> +    applyLocTheta (liftLocThetaQuery $ shape_path_fun sh) pt 0 >>= \spath ->      let g2 = atIncline (shape_decoration sh) pt 0 -    in replaceAns a (sdecorate g2 $ zapQuery (toPrimPath spath) >>= drawF)+    in replaceAns a (sdecorate g2 $ liftQuery (toPrimPath spath) >>= drawF)   @@ -173,10 +174,10 @@ shapeToLocTheta :: InterpretUnit u                 => (PrimPath -> Graphic u) -> Shape t u -> LocThetaImage u (t u) shapeToLocTheta drawF sh = promoteLocTheta $ \pt theta -> -    zapLocThetaQuery (shape_ans_fun  sh) pt theta >>= \a -> -    zapLocThetaQuery (shape_path_fun sh) pt theta >>= \spath -> +    applyLocTheta (liftLocThetaQuery $ shape_ans_fun sh) pt theta >>= \a -> +    applyLocTheta (liftLocThetaQuery $ shape_path_fun sh) pt theta >>= \spath ->      let g2 = atIncline (shape_decoration sh) pt theta-    in replaceAns a $ sdecorate g2 (zapQuery (toPrimPath spath) >>= drawF)+    in replaceAns a $ sdecorate g2 (liftQuery (toPrimPath spath) >>= drawF)   @@ -196,7 +197,8 @@ -- angle. The anchors are typically implemented by rotating the  -- correspoding anchor of the wrapped Shape about its center. -- -updatePathAngle :: (Radian -> Radian) -> Shape t u -> Shape t u+updatePathAngle :: InterpretUnit u +                => (Radian -> Radian) -> Shape t u -> Shape t u updatePathAngle f =      (\s fi -> s { shape_path_fun = qpromoteLocTheta $ \pt ang ->                                     qapplyLocTheta fi pt (mvTheta ang) })

@@ -214,7 +214,8 @@   -mkSemiellipse :: u -> u -> LocThetaQuery u (Semiellipse u)+mkSemiellipse :: InterpretUnit u +              => u -> u -> LocThetaQuery u (Semiellipse u) mkSemiellipse rx ry = qpromoteLocTheta $ \ctr theta ->      pure $ Semiellipse { se_ctm = makeShapeCTM ctr theta                        , se_rx = rx@@ -222,7 +223,7 @@                        }  -mkSemiellipsePath :: (Real u, Floating u, Tolerance u) +mkSemiellipsePath :: (Real u, Floating u, InterpretUnit u, Tolerance u)                    => u -> u -> u -> LocThetaQuery u (AbsPath u) mkSemiellipsePath rx ry hminor = qpromoteLocTheta $ \pt theta ->     let ctr = dispPerpendicular (-hminor) theta pt

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

@@ -1,5 +1,5 @@ name:             wumpus-drawing-version:          0.5.0+version:          0.6.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -38,25 +38,12 @@   .   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-    Trapeziums.-  .-  * Added Basis modules. These are \"mid-level\" modules similar -    to ones in @Wumpus.Basic.Kernel.Objects@, however they are -    considered less general so there are put here where they can -    be imported individually (and so not pollute the namespace).+  v0.5.0 to v0.6.0   .-  * Removed the Turtle modules. The new @LocTrace@ and @RefTrace@ -    modules supercede the Turtle modules.+  * Removed @LocTRace@ and @RefTrace@ from @Wumpus.Drawing.Basis@,+    they are superseded by @LocDrawing@ in Wumpus-Basic.+  . +  * Remaned path building operations in @RelPathBuilder@.   .   . build-type:         Simple@@ -89,13 +76,11 @@                       containers      >= 0.3     && <= 0.6,                       vector-space    >= 0.6     && <  1.0,                       wumpus-core     >= 0.51.0  && <  0.52.0,-                      wumpus-basic    == 0.20.0+                      wumpus-basic    == 0.21.0       exposed-modules:     Wumpus.Drawing.Basis.DrawingPrimitives,-    Wumpus.Drawing.Basis.LocTrace,-    Wumpus.Drawing.Basis.RefTrace,     Wumpus.Drawing.Colour.SVGColours,     Wumpus.Drawing.Colour.X11Colours,     Wumpus.Drawing.Connectors,