wumpus-basic 0.21.0 → 0.22.0

raw patch · 35 files changed

+2050/−1482 lines, 35 filesdep ~wumpus-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: wumpus-core

API changes (from Hackage documentation)

Files

• CHANGES +15/−0
• demo/AltUnits.hs +6/−6
• demo/SimpleAdvGraphic.hs +1/−1
• demo/SimplePosObject.hs +7/−7
• src/Wumpus/Basic/Geometry.hs +0/−2
• src/Wumpus/Basic/Geometry/Base.hs +1/−14
• src/Wumpus/Basic/Geometry/Illustrate.hs +1/−1
• src/Wumpus/Basic/Geometry/Paths.hs +0/−315
• src/Wumpus/Basic/Geometry/Quadrant.hs +7/−7
• src/Wumpus/Basic/Kernel.hs +4/−2
• src/Wumpus/Basic/Kernel/Base/BaseDefs.hs +101/−24
• src/Wumpus/Basic/Kernel/Base/DrawingContext.hs +0/−79
• src/Wumpus/Basic/Kernel/Base/QueryDC.hs +0/−64
• src/Wumpus/Basic/Kernel/Base/Units.hs +13/−10
• src/Wumpus/Basic/Kernel/Base/UpdateDC.hs +0/−137
• src/Wumpus/Basic/Kernel/Drawing/Chain.hs +119/−50
• src/Wumpus/Basic/Kernel/Drawing/CtxPicture.hs +4/−4
• src/Wumpus/Basic/Kernel/Drawing/LocDrawing.hs +12/−12
• src/Wumpus/Basic/Kernel/Drawing/LocTrace.hs +10/−10
• src/Wumpus/Basic/Kernel/Drawing/PosObject.hs +661/−0
• src/Wumpus/Basic/Kernel/Drawing/TraceDrawing.hs +17/−17
• src/Wumpus/Basic/Kernel/Objects/AdvObject.hs +2/−2
• src/Wumpus/Basic/Kernel/Objects/Anchors.hs +4/−7
• src/Wumpus/Basic/Kernel/Objects/Basis.hs +6/−5
• src/Wumpus/Basic/Kernel/Objects/Bounded.hs +28/−4
• src/Wumpus/Basic/Kernel/Objects/Connector.hs +21/−14
• src/Wumpus/Basic/Kernel/Objects/Displacement.hs +83/−1
• src/Wumpus/Basic/Kernel/Objects/DrawingPrimitives.hs +32/−20
• src/Wumpus/Basic/Kernel/Objects/Image.hs +22/−12
• src/Wumpus/Basic/Kernel/Objects/LocImage.hs +21/−8
• src/Wumpus/Basic/Kernel/Objects/LocThetaImage.hs +33/−16
• src/Wumpus/Basic/Kernel/Objects/PosObject.hs +0/−599
• src/Wumpus/Basic/Kernel/Objects/Trail.hs +785/−0
• src/Wumpus/Basic/VersionNumber.hs +2/−2
• wumpus-basic.cabal +32/−30

@@ -1,4 +1,19 @@ +0.20.0 to 0.21.0:++  * The code from the @Kernel.Base.UserState@ module has been +    moved to the module @Kernel.Drawing.Basis@.++  * Moved @Image@ and @Query@ from @Objects.Basis@ to new module+    @Objects.Image@. Moved @Chain@, @CtxPicture@ and +    @TraceDrawing@ into the new @Drawing@ folder.++  * Added @Wumpus.Basic.Kernel.Drawing.LocDrawing@ module.+ +  * Rationalized the combinators exported by the drawing objects +    @Image@, @LocImage@, @LocThetaImage@ and @Connector@.+ + 0.18.0 to 0.20.0 (no release numbered v0.19.0):    * Added text advance-vector calculations to @QueryDC@ - 

@@ -44,23 +44,23 @@ dblLocGraphic :: LocGraphic Double dblLocGraphic = rect1 `mappend` rect2     where-    rect1 = dcRectangle FILL_STROKE 36 24 -    rect2 = moveStart (hvec 36) $ dcRectangle FILL_STROKE 60 24 +    rect1 = dcRectangle DRAW_FILL_STROKE 36 24 +    rect2 = moveStart (hvec 36) $ dcRectangle DRAW_FILL_STROKE 60 24     emLocGraphic :: LocGraphic Em emLocGraphic = localize swap_colours $  rect1 `mappend` rect2     where-    rect1 = dcRectangle FILL_STROKE 3 2 -    rect2 = moveStart (hvec 3) $ dcRectangle FILL_STROKE 5 2 +    rect1 = dcRectangle DRAW_FILL_STROKE 3 2 +    rect2 = moveStart (hvec 3) $ dcRectangle DRAW_FILL_STROKE 5 2    enLocGraphic :: LocGraphic En enLocGraphic = localize (fill_colour lemon_chiffon) $ rect1 `mappend` rect2     where-    rect1 = dcRectangle FILL_STROKE 6 4-    rect2 = moveStart (hvec 6) $ dcRectangle FILL_STROKE 10 4+    rect1 = dcRectangle DRAW_FILL_STROKE 6 4+    rect2 = moveStart (hvec 6) $ dcRectangle DRAW_FILL_STROKE 10 4   haskell_org :: XLink

@@ -61,7 +61,7 @@ miniDisk :: AdvGraphic Double miniDisk = makeAdvObject (pure $ V2 0 0) disk1    where-    disk1 = localize (fill_colour sienna) $ dcDisk FILL 3+    disk1 = localize (fill_colour sienna) $ dcDisk DRAW_FILL 3   sienna :: RGBi

@@ -58,18 +58,18 @@     draw $ testDrawBl    BLC    `at` (P2 150  0)     draw $ testDrawBl    BLR    `at` (P2 225  0)     -    drawl (P2 300 0) $ runPosObject msg SW+    drawl (P2 300 0) $ runPosObject SW msg   where     msg = multilinePosText VALIGN_RIGHT "Red dot represents the\nrectangle address."   testDrawBl :: RectAddress -> LocGraphic Double-testDrawBl raddr = dcDisk FILL 2 `mappend` rectBl raddr+testDrawBl raddr = dcDisk DRAW_FILL 2 `mappend` rectBl raddr   rectBl :: RectAddress -> LocGraphic Double rectBl raddr = -    ignoreAns $ runPosObject (makePosObject (return ortt) (mkRectBl w h)) raddr+    ignoreAns $ runPosObject raddr $ makePosObject (return ortt) (mkRectBl w h)   where     w    = 40      h    = 30@@ -81,18 +81,18 @@  -- start-point - bottom left mkRectBl :: InterpretUnit u => u -> u -> LocGraphic u-mkRectBl w h = dcRectangle STROKE w h+mkRectBl w h = dcRectangle DRAW_STROKE w h    testDrawMinor :: RectAddress -> LocGraphic Double testDrawMinor raddr = -    dcDisk FILL 2 `mappend` (ignoreAns $ rectMinor raddr)+    dcDisk DRAW_FILL 2 `mappend` (ignoreAns $ rectMinor raddr)   rectMinor :: RectAddress -> LocGraphic Double rectMinor raddr = -    runPosObject (makePosObject (return ortt) (mkRectMinor m w h)) raddr+    runPosObject raddr $ makePosObject (return ortt) (mkRectMinor m w h)   where     m    = 10     w    = 40 @@ -110,5 +110,5 @@         br = displace (hvec w) bl         tr = displace (vvec h) br         tl = displace (vvec h) bl-    in liftQuery (vertexPP [bl, br, tr, tl]) >>= dcClosedPath STROKE+    in liftQuery (vertexPP [bl, br, tr, tl]) >>= dcClosedPath DRAW_STROKE 

@@ -20,7 +20,6 @@     module Wumpus.Basic.Geometry.Base   , module Wumpus.Basic.Geometry.Illustrate   , module Wumpus.Basic.Geometry.Intersection-  , module Wumpus.Basic.Geometry.Paths   , module Wumpus.Basic.Geometry.Quadrant   , module Wumpus.Basic.Geometry.Vertices @@ -30,6 +29,5 @@ import Wumpus.Basic.Geometry.Base import Wumpus.Basic.Geometry.Illustrate import Wumpus.Basic.Geometry.Intersection-import Wumpus.Basic.Geometry.Paths import Wumpus.Basic.Geometry.Quadrant import Wumpus.Basic.Geometry.Vertices

@@ -18,13 +18,9 @@ module Wumpus.Basic.Geometry.Base   (  -  -- * constants-    quarter_pi-  , half_pi-  , two_pi    -- * 2x2 Matrix-  , Matrix2'2(..)+    Matrix2'2(..)   , DMatrix2'2   , identity2'2   , det2'2@@ -81,15 +77,6 @@   --quarter_pi      :: Floating u => u-quarter_pi      = 0.25 * pi--half_pi         :: Floating u => u-half_pi         = 0.5 * pi--two_pi          :: Floating u => u-two_pi          = 2.0 * pi   --------------------------------------------------------------------------------

@@ -40,7 +40,7 @@ enDot = uconvF body   where     body :: LocGraphic En-    body = localize (fill_colour white) $ dcDisk FILL_STROKE 0.5+    body = localize (fill_colour white) $ dcDisk DRAW_FILL_STROKE 0.5  illustrateLine :: (Real u, Floating u, InterpretUnit u)                 => Line u -> Graphic u

@@ -1,315 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Basic.Paths--- Copyright   :  (c) Stephen Tetley 2010-2011--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Path /algorithms/ for elementary shapes - rectangle, diamond, --- polygon.--- -----------------------------------------------------------------------------------module Wumpus.Basic.Geometry.Paths-  ( --    PathAlg-  , runPathAlgPoint-  , runPathAlgVec-  , drawVertexPathAlg--  , pathStartIsStart-  , pathStartIsLocus-  , pathIterateLocus--  , rectanglePathAlg-  , blRectanglePathAlg--  , diamondPathAlg-  , isoscelesTriPathAlg-  , polygonPathAlg--  , arcPathAlg-  , circlePathAlg--  , parallelogramPathAlg-  , isoscelesTrapeziumPathAlg--  ) -  where--import Wumpus.Basic.Geometry.Base-import Wumpus.Basic.Geometry.Vertices-import Wumpus.Basic.Kernel--import Wumpus.Core                              -- package: wumpus-core--import Data.AffineSpace                         -- package: vector-space-import Data.VectorSpace--import Data.List ( unfoldr )---data PathAlgScheme = START_IS_START | START_IS_LOCUS -  deriving (Enum,Eq,Ord,Show)----- | A vector chain building a path.------ The vectors are relative to the predecessor, so the--- rendering of a 'PathAlg' iterates the start point.------ A polygon PathAlg should have steps for all sides of the --- polygon with the end point generated by the last vector --- coinciding with thet start point.--- -data PathAlg u = PathAlg { path_alg_scheme  :: PathAlgScheme-                         , path_alg_steps   :: [Vec2 u]-                         }---type instance DUnit (PathAlg u) = u---runPathAlgPoint :: Num u => Point2 u -> PathAlg u -> [Point2 u]-runPathAlgPoint _  (PathAlg _   [])       = []-runPathAlgPoint p0 (PathAlg scm (v0:xs)) -    | scm == START_IS_START = p0 : step (p0 .+^ v0) xs-    | otherwise             = step (p0 .+^ v0) xs-  where-    step pt []      = [pt]-    step pt (v:vs)  = pt : step (pt .+^ v) vs---runPathAlgVec :: PathAlg u -> (Maybe (Vec2 u), [Vec2 u]) -runPathAlgVec (PathAlg START_IS_LOCUS (v:vs)) = (Just v, vs)-runPathAlgVec (PathAlg _ vs)                  = (Nothing, vs)-----drawVertexPathAlg :: InterpretUnit u -                  => DrawStyle -> PathAlg u -> LocGraphic u-drawVertexPathAlg style alg = promoteLoc $ \pt -> -    liftQuery (vertexPP $ runPathAlgPoint pt alg) >>= dcClosedPath style----- | Create a PathAlg from the vertex list.------ When the PathAlg is run the supplied point will be the start --- of the path. --- -pathStartIsStart :: [Vec2 u] -> PathAlg u-pathStartIsStart vs = PathAlg { path_alg_scheme = START_IS_START-                              , path_alg_steps  = vs }------ | Create a PathAlg from the vector list - the first vector--- displaces the /start point/ the subsequent vectors displace --- the /current tip/. Figuratively, this is rather like Logo --- /turtle drawing/.------ When the PathAlg is run, the supplied point is the /locus/ of --- the path and it does not form part of the path proper.--- --- This constructor is typically used to make /shape paths/ where--- the supplied point is the center and the generated path is the --- border.--- -pathStartIsLocus :: [Vec2 u] -> PathAlg u-pathStartIsLocus vs = PathAlg { path_alg_scheme = START_IS_LOCUS-                              , path_alg_steps  = vs }----- | Note this creates a path where the first vector represents a--- @moveto@, then the subsequence vectors represent @linetos@.--- ----- | Create a PathAlg from the vector list - each vector in the --- input list iterates to the start point rather then the --- cumulative tip.------ When the PathAlg is run, the supplied point is the /locus/ of --- the path and it does not form part of the path proper.--- --- Like 'pathStartIsLocus', this constructor is typically used to --- make /shape paths/. Some shapes are easier to express as --- iterated displacements of the center rather than --- /turtle drawing/. --- -pathIterateLocus :: Num u => [Vec2 u] -> PathAlg u-pathIterateLocus []      = pathStartIsLocus []-pathIterateLocus (v0:xs) = pathStartIsLocus $ v0 : step v0 xs-  where-    step v1 []      = [v0 ^-^ v1]-    step v1 (v2:vs) = (v2 ^-^ v1) : step v2 vs------- | Implicit start point is /center/, the genearated moves are --- counter-clockwise so the move-list is------ > [ moveto_bl, moveto_br, moveto_tr, moveto_tl ]----rectanglePathAlg :: Fractional u => u -> u -> PathAlg u-rectanglePathAlg w h = -    pathStartIsLocus [ to_bl, to_br, to_tr, to_tl ]-  where-    to_bl = vec (negate $ 0.5*w) (negate $ 0.5*h)-    to_br = hvec w-    to_tr = vvec h-    to_tl = hvec (-w) ------ | Implicit start point is /bottom-left/, subsequent moves are --- counter-clockwise so the move-list is:------ > [ moveto_br, moveto_tr, moveto_tl, moveto_bl ]----blRectanglePathAlg :: Num u => u -> u -> PathAlg u-blRectanglePathAlg w h = pathStartIsStart [ vbr, vtr, vtl, vbl ]-  where-    vbr = hvec w-    vtr = vvec h-    vtl = hvec (-w) -    vbl = vvec (-h)------- | 'diamondPathAlg' : @ half_width * half_height -> PathAlg @----diamondPathAlg :: Num u => u -> u -> PathAlg u-diamondPathAlg hw hh = pathIterateLocus [ vs,ve,vn,vw ]-  where-    vs = vvec (-hh)-    ve = hvec hw-    vn = vvec hh-    vw = hvec (-hw)------ | 'isoscelesTriPathAlg' : @ base_width * height -> PathAlg @------ Start point is centtroid not incenter.----isoscelesTriPathAlg :: Floating u => u -> u -> PathAlg u-isoscelesTriPathAlg bw h = -    pathIterateLocus [ to_bl, to_br, to_apex ]-  where-    (to_bl, to_br, to_apex) = isoscelesTriangleVertices bw h--    ---- | 'polygonPathAlg' : @ num_points * radius -> PathAlg @ ----polygonPathAlg :: Floating u => Int -> u -> PathAlg u-polygonPathAlg n radius = pathIterateLocus $ unfoldr phi (0,top)-  where-    top                     = 0.5*pi-    theta                   = (2*pi) / fromIntegral n-    -    phi (i,ang) | i < n     = Just (avec ang radius, (i+1,ang+theta))-                | otherwise = Nothing----- | 'arcPathAlg' : @ radius * angle1 * angle2 ->  PathAlg @ ----arcPathAlg :: Floating u => u -> Radian -> Radian -> PathAlg u-arcPathAlg r ang1 ang2 = pathStartIsLocus $ step1 $ arcdiv ang1 ang2-  where-    step1 []         = []-    step1 ((a,b):xs) = let (v0,v1,v2,v3) = minorArcQuadVec r a b-                       in v0 : v1: v2: v3 : step xs--    step []         = []-    step ((a,b):xs)  = let (_,v1,v2,v3) = minorArcQuadVec r a b-                       in v1: v2: v3 : step xs---    --- | Helper - generate four vectors building a minor (<90 deg) --- arc.------ The first vec is from center - for cumulative arcs this should --- only taken once.----minorArcQuadVec :: Floating u -                => u -> Radian -> Radian -> (Vec2 u, Vec2 u, Vec2 u, Vec2 u)-minorArcQuadVec r ang1 ang2 = (v0, v1, v2, v3)-  where-    (p1,p2,p3,p4) = bezierArc r ang1 ang2 zeroPt-    v0            = pvec zeroPt p1 -    v1            = pvec p1 p2-    v2            = pvec p2 p3-    v3            = pvec p3 p4---circlePathAlg :: (Fractional u, Floating u) -              => u -> PathAlg u-circlePathAlg r = pathStartIsLocus vs-  where-    vs = hvec r : diff (flip pvec) (bezierCircle r zeroPt)------- | Helper - diff --- --- Note diff relies on the pointlist cycling the endpoint--- --- > [p0, ..., p0]------ This is how Wumpus-Core generates Bezier circles.--- -diff :: (a -> a -> b) -> [a] -> [b]-diff _  [] = []-diff op (x:xs) = step x xs-  where-    step _ []     = []-    step a (b:bs) = b `op` a : step b bs---- | Helper - divide an arc into quadrants plus remainder.----arcdiv :: Radian -> Radian -> [(Radian,Radian)]-arcdiv ang1 ang2 | ang1 >  ang2 = step ang1 (ang2 + 2 * pi) -                 | otherwise    = step ang1 ang2-  where-    step a1 a2 | a1 == a2 = []-    step a1 a2 | a2 - a1 > half_pi = norm (a1,a1+half_pi) : step (a1+half_pi) a2-               | otherwise         = [(a1,a2)]--    norm (a,b) = (circularModulo a, circularModulo b)------ | @ width * height * bottom_left_angle @----parallelogramPathAlg :: Floating u => u -> u -> Radian -> PathAlg u-parallelogramPathAlg w h bl_ang = -    pathIterateLocus [ bl, br, tr, tl ]-  where-    (bl, br, tr, tl) = parallelogramVertices w h bl_ang------ | @ base_width * top_width * height @----isoscelesTrapeziumPathAlg :: Floating u => u -> u -> u -> PathAlg u-isoscelesTrapeziumPathAlg bw tw h = -    pathIterateLocus [ bl, br, tr, tl ]-  where-    (bl, br, tr, tl) = isoscelesTrapeziumVertices bw tw h---

@@ -48,7 +48,7 @@   )    where -import Wumpus.Basic.Geometry.Base+import Wumpus.Basic.Kernel  import Wumpus.Core                              -- package: wumpus-core @@ -198,8 +198,8 @@ hypotenuseQI dx dy ang = avec ang dist   where     base_ang = atan (dy / dx)-    apex     = pi - (base_ang + fromRadian ang)-    dist     = sin base_ang * (dx / sin apex)+    apex_c   = pi - (base_ang + fromRadian ang)+    dist     = sin base_ang * (dx / sin apex_c)   @@ -467,8 +467,8 @@ triangleQI w h ang = avec ang dist   where     base_ang = atan (h / w)-    apex     = pi - (base_ang + fromRadian ang)-    dist     = sin base_ang * (w / sin apex)+    apex_c   = pi - (base_ang + fromRadian ang)+    dist     = sin base_ang * (w / sin apex_c)   @@ -568,8 +568,8 @@ triangleLeftSide base_width lang rang =     (fromRadian $ sin rang) / factor    where-    apex   = pi - (lang + rang)-    factor = (fromRadian $ sin apex) / base_width+    apex_c = pi - (lang + rang)+    factor = (fromRadian $ sin apex_c) / base_width   -- | 'rightTrapeziumBaseWidth' : @ top_width * height * top_right_ang -> Length @

@@ -29,6 +29,7 @@   , module Wumpus.Basic.Kernel.Drawing.CtxPicture   , module Wumpus.Basic.Kernel.Drawing.LocDrawing   , module Wumpus.Basic.Kernel.Drawing.LocTrace+  , module Wumpus.Basic.Kernel.Drawing.PosObject   , module Wumpus.Basic.Kernel.Drawing.TraceDrawing   , module Wumpus.Basic.Kernel.Objects.AdvObject   , module Wumpus.Basic.Kernel.Objects.Anchors@@ -42,7 +43,7 @@   , module Wumpus.Basic.Kernel.Objects.LocImage   , module Wumpus.Basic.Kernel.Objects.LocThetaImage   , module Wumpus.Basic.Kernel.Objects.Orientation-  , module Wumpus.Basic.Kernel.Objects.PosObject+  , module Wumpus.Basic.Kernel.Objects.Trail    ) where @@ -58,6 +59,7 @@ import Wumpus.Basic.Kernel.Drawing.CtxPicture import Wumpus.Basic.Kernel.Drawing.LocDrawing import Wumpus.Basic.Kernel.Drawing.LocTrace+import Wumpus.Basic.Kernel.Drawing.PosObject import Wumpus.Basic.Kernel.Drawing.TraceDrawing import Wumpus.Basic.Kernel.Objects.AdvObject import Wumpus.Basic.Kernel.Objects.Anchors@@ -71,4 +73,4 @@ import Wumpus.Basic.Kernel.Objects.LocImage import Wumpus.Basic.Kernel.Objects.LocThetaImage import Wumpus.Basic.Kernel.Objects.Orientation-import Wumpus.Basic.Kernel.Objects.PosObject+import Wumpus.Basic.Kernel.Objects.Trail

@@ -18,10 +18,23 @@  module Wumpus.Basic.Kernel.Base.BaseDefs   (-   +  -- * Constants+    quarter_pi+  , half_pi+  , two_pi++  , ang180+  , ang150+  , ang120+  , ang90+  , ang60+  , ang45+  , ang30+  , ang15+   -- * Unit phantom type-    UNil(..)+  , UNil(..)   , ureturn   , uvoid @@ -42,10 +55,12 @@   -- * KernChar   , KernChar -  -- * Drawing paths-  , DrawStyle(..)+  -- * Drawing paths and shapes (closed paths)+  , PathMode(..)+  , DrawMode(..)+  , closedMode -  -- * Drawing /layer/+  -- * Drawing layers   , ZDeco(..)      -- * Alignment@@ -60,17 +75,17 @@    -- * Direction enumeration   , Direction(..)-  +  , ClockDirection(..)      -- * Misc-  , vsum+   , both+  , monPreRepeatPost    ) where  import Wumpus.Core                              -- package: wumpus-core -import Data.VectorSpace                         -- package: vector-space  import Control.Applicative import Data.Monoid@@ -80,7 +95,42 @@   +quarter_pi      :: Radian+quarter_pi      = 0.25 * pi +half_pi         :: Radian+half_pi         = 0.5 * pi++two_pi          :: Radian+two_pi          = 2.0 * pi+++ang180          :: Radian+ang180          = pi++ang150          :: Radian+ang150          = 5 * ang30++ang120          :: Radian +ang120          = 3 * ang60++ang90           :: Radian+ang90           = pi / 2++ang60           :: Radian+ang60           = pi / 3++ang45           :: Radian +ang45           = pi / 4++ang30           :: Radian+ang30           = pi / 6++ang15           :: Radian+ang15           = pi / 12+++ -------------------------------------------------------------------------------- -- Simple objects wrapped with unit phatom type  @@ -242,17 +292,42 @@  -- | Draw closed paths.  -- --- > FILL +-- > OSTROKE - open and stroked++-- > CSTROKE - closed and stroke ----- > STROKE+-- > CFILL - closed and filled ----- > FILL_STROKE - the path is filled and its edge is stroked.+-- > CFILL_STROKE - closed, the path is filled, its edge is stroked. ---data DrawStyle = FILL | STROKE | FILL_STROKE+data PathMode = OSTROKE | CSTROKE | CFILL | CFILL_STROKE   deriving (Bounded,Enum,Eq,Ord,Show)   +-- | Draw closed paths and shapes. +-- +-- > DRAW_STROKE - closed and stroked+--+-- > DRAW_FILL - closed and filled+--+-- > CLOSED_FILL_STROKE - the path is filled, its edge is stroked.+--+data DrawMode = DRAW_STROKE | DRAW_FILL | DRAW_FILL_STROKE+  deriving (Bounded,Enum,Eq,Ord,Show)+++-- | Interpret a 'DrawMode' for a closed path.+--+closedMode :: DrawMode -> PathMode+closedMode DRAW_STROKE      = CSTROKE +closedMode DRAW_FILL        = CFILL +closedMode DRAW_FILL_STROKE = CFILL_STROKE+++++ -- | Decorating with resepct to the Z-order  --  -- > SUPERIOR - in front. @@ -312,24 +387,17 @@  -- | An enumerated type representing horizontal and vertical  -- directions.+-- data Direction = UP | DOWN | LEFT | RIGHT    deriving (Enum,Eq,Ord,Show)   +-- | An enumerated type representing /clock/ directions.+--+data ClockDirection = CW | CCW+   deriving (Enum,Eq,Ord,Show)   --- | Sum a list of Vectors.------ Note - this function is a candidate to go in Wumpus-Core, but--- it will be added when there is an intrinsic reason to to update--- Core (bug fix, or API change).----vsum :: Num u => [Vec2 u] -> Vec2 u-vsum [] = V2 0 0-vsum (v:vs) = go v vs-  where-    go a []     = a-    go a (b:bs) = go (a ^+^ b) bs   -- | Applicative /both/ - run both computations return the pair@@ -338,3 +406,12 @@ both :: Applicative f => f a -> f b -> f (a,b) both fa fb = (,) <$> fa <*> fb ++-- | Monodial scheme - prefix, repeat body n times, suffix.+--+monPreRepeatPost :: Monoid a => a -> (Int, a) -> a -> a+monPreRepeatPost pre (n,body1) post = step pre n+  where+    step ac i | i < 1     = ac `mappend` post+              | otherwise = step (ac `mappend` body1) (i - 1) +    

@@ -29,7 +29,6 @@    , DrawingContextF   , TextMargin(..)-  , ConnectorProps(..)    -- * Construction   , standardContext@@ -89,7 +88,6 @@       , dc_text_colour          :: RGBi       , dc_line_spacing_factor  :: Double       , dc_text_margin          :: TextMargin-      , dc_connector_props      :: ConnectorProps       }  -- TODO - what parts of the Drawing Context should be strict? @@ -110,58 +108,7 @@        }  --- | ConnectorProps control the drawing of connectors in --- Wumpus-Drawing.------ > conn_src_space     :: Em--- > conn_dst_space     :: Em------ Source and destination spacers - these add spacing between the --- respective connector points and the tips of the drawn connector.--- --- > conn_src_offset    :: Em--- > conn_dst_offset    :: Em------ Source and destination offsets - these offset the drawing of--- the connector perpendicular to the direction of line formed --- between the connector points (a positive offset is drawn above, --- a negative offset below). The main use of offsets is to draw--- parallel line connectors.------ > conn_arc_ang       :: Radian ------ Control the /bend/ of an arc connector.--- --- > conn_src_arm       :: Em--- > conn_dst_arm       :: Em ------ Control the /arm/ length of a jointed connector - arms are the --- initial segments of the connector. ------ > conn_loop_size     :: Em------ Control the /height/ of a loop connector. ------ > conn_box_halfsize  :: Em--- --- Control the size of a connector box. Connector boxes are --- drawn with the exterior lines projected out from the connector--- points a halfsize above and below.--- -data ConnectorProps = ConnectorProps-      { dc_conn_src_space       :: !Em-      , dc_conn_dst_space       :: !Em-      , dc_conn_src_offset      :: !Em-      , dc_conn_dst_offset      :: !Em-      , dc_conn_arc_ang         :: !Radian-      , dc_conn_src_arm         :: !Em-      , dc_conn_dst_arm         :: !Em-      , dc_conn_loop_size       :: !Em-      , dc_conn_box_halfsize    :: !Em-      } -- -- | 'standardContext' : @ font_size -> DrawingContext @   -- -- Create a 'DrawingContext'.@@ -193,15 +140,6 @@ -- > round_corner_factor: 0 -- > text_margin:         (0.5 em, 0.5 em)  ----- > conn_src_sep:        0--- > conn_dst_sep:        0--- > conn_src_offset:     0--- > conn_dst_offset:     0--- > conn_arc_ang:        pi / 12--- > conn_src_arm:        1--- > conn_dst_arm:        1--- > conn_loop_size:      2 ---  -- standardContext :: FontSize -> DrawingContext standardContext sz = @@ -217,7 +155,6 @@                    , dc_text_colour          = wumpus_black                    , dc_line_spacing_factor  = default_line_spacing                      , dc_text_margin          = default_text_margin-                   , dc_connector_props      = default_connector_props                    }  @@ -278,7 +215,6 @@          , dc_text_colour           = wumpus_black          , dc_line_spacing_factor   = default_line_spacing          , dc_text_margin           = default_text_margin-         , dc_connector_props       = default_connector_props          }  -- Ideally @reset_drawing_properties@ would be in the UpdateDC @@ -313,21 +249,6 @@ default_text_margin :: TextMargin default_text_margin = TextMargin { text_margin_x = 0.5, text_margin_y = 0.5 } ---- Arc angle is 15deg - quite shallow.----default_connector_props :: ConnectorProps-default_connector_props = -    ConnectorProps { dc_conn_src_space    = 0-                   , dc_conn_dst_space    = 0-                   , dc_conn_src_offset   = 0-                   , dc_conn_dst_offset   = 0-                   , dc_conn_arc_ang      = pi / 12-                   , dc_conn_src_arm      = 1-                   , dc_conn_dst_arm      = 1-                   , dc_conn_loop_size    = 2 -                   , dc_conn_box_halfsize = 2 -                   }   default_line_spacing :: Double

@@ -65,18 +65,6 @@    , cwLookupTable --  -- * Connector props-  , connectorSrcSpace-  , connectorDstSpace-  , connectorSrcOffset-  , connectorDstOffset-  , connectorArcAngle-  , connectorSrcArm-  , connectorDstArm-  , connectorLoopSize-  , connectorBoxHalfSize-   ) where  import Wumpus.Basic.Kernel.Base.BaseDefs@@ -343,55 +331,3 @@ -- cwLookupTable :: DrawingCtxM m => m CharWidthLookup cwLookupTable = glyphQuery get_cw_table------------------------------------------------------------------------------------- Connector props---- helper -connectorAsks :: DrawingCtxM m => (ConnectorProps -> a) -> m a-connectorAsks f = f <$> asksDC dc_connector_props----connectorSrcSpace :: (DrawingCtxM m, InterpretUnit u) => m u -connectorSrcSpace = (\sz u -> uconvert1 sz u) -                      <$> pointSize <*> connectorAsks dc_conn_src_space---connectorDstSpace :: (DrawingCtxM m, InterpretUnit u) => m u -connectorDstSpace = (\sz u -> uconvert1 sz u) -                      <$> pointSize <*> connectorAsks dc_conn_dst_space--connectorSrcOffset :: (DrawingCtxM m, InterpretUnit u) => m u -connectorSrcOffset = (\sz u -> uconvert1 sz u) -                       <$> pointSize <*> connectorAsks dc_conn_src_offset---connectorDstOffset :: (DrawingCtxM m, InterpretUnit u) => m u -connectorDstOffset = (\sz u -> uconvert1 sz u) -                       <$> pointSize <*> connectorAsks dc_conn_dst_offset---connectorArcAngle :: DrawingCtxM m => m Radian-connectorArcAngle = connectorAsks dc_conn_arc_ang---connectorSrcArm :: (DrawingCtxM m, InterpretUnit u) => m u -connectorSrcArm = (\sz u -> uconvert1 sz u) -                    <$> pointSize <*> connectorAsks dc_conn_src_arm---connectorDstArm :: (DrawingCtxM m, InterpretUnit u) => m u -connectorDstArm = (\sz u -> uconvert1 sz u) -                    <$> pointSize <*> connectorAsks dc_conn_dst_arm---connectorLoopSize :: (DrawingCtxM m, InterpretUnit u) => m u -connectorLoopSize = (\sz u -> uconvert1 sz u) -                      <$> pointSize <*> connectorAsks dc_conn_loop_size---connectorBoxHalfSize :: (DrawingCtxM m, InterpretUnit u) => m u -connectorBoxHalfSize = -    (\sz u -> uconvert1 sz u) -      <$> pointSize <*> connectorAsks dc_conn_box_halfsize

@@ -75,7 +75,12 @@   normalize _ = cm    dinterp   _ = dcm +instance Tolerance Centimeter where +  eq_tolerance     = 0.001+  length_tolerance = 0.01 ++ -- | Wrapped Double /Pica/ unit type. --  -- Pica is 12 Points.@@ -102,11 +107,7 @@ dpica = Pica . (\x -> x / 12.0)  -instance Tolerance Pica where -  eq_tolerance     = 0.001-  length_tolerance = 0.01 - instance ScalarUnit Pica where   fromPsPoint = dpica   toPsPoint   = pica@@ -116,7 +117,12 @@   dinterp   _ = dpica  +instance Tolerance Pica where +  eq_tolerance     = 0.001+  length_tolerance = 0.01 ++ -------------------------------------------------------------------------------- -- Contextual units @@ -134,7 +140,8 @@   normalize sz a = fromIntegral sz * realToFrac a   dinterp sz d   = realToFrac d / fromIntegral sz -instance Tolerance Centimeter where ++instance Tolerance Em where    eq_tolerance     = 0.001   length_tolerance = 0.01 @@ -153,11 +160,7 @@   dinterp sz d   = 2 * (realToFrac d) / (fromIntegral sz)  --instance Tolerance Em where -  eq_tolerance     = 0.001-  length_tolerance = 0.01- instance Tolerance En where   eq_tolerance     = 0.001    length_tolerance = 0.01+

@@ -96,23 +96,9 @@   , text_use_stroke_colour   , text_use_fill_colour -  -- * Connector Props-  , source_space-  , dest_space-  , source_offset-  , dest_offset-  , uniform_conn_space-  , conn_arc_angle-  , source_arm_len-  , dest_arm_len-  , uniform_arm_len-  , conn_loop_size-  , conn_box_halfsize-   ) where  -import Wumpus.Basic.Kernel.Base.BaseDefs import Wumpus.Basic.Kernel.Base.DrawingContext import Wumpus.Basic.Kernel.Base.FontSupport import Wumpus.Basic.Kernel.Base.Units@@ -563,126 +549,3 @@     (\s a -> s { dc_text_colour = a }) <*> dc_fill_colour  ------------------------------------------------------------------------------------- Connector props---- helper -connectorUpd :: (ConnectorProps -> ConnectorProps) -> DrawingContextF-connectorUpd f = -   (\s a -> s { dc_connector_props = f a }) <*> dc_connector_props---- | Normalize to zero if negative.----normZero :: (Num u, Ord u) => u -> u-normZero u = if u < 0 then 0 else u---- | Set the connector source spacing.------ The spacing is used as a projection along the line formed --- between connector points making the connection /looser/ if --- required.--- --- The default value is 0. Negative values are not allowed, they--- are normalized to 0.----source_space :: (Ord u, InterpretUnit u) => u -> DrawingContextF-source_space u = withFontSize $ \sz -> -    connectorUpd (\s -> s { dc_conn_src_space = uconvert1 sz $ normZero u })----- | Set the connector destination spacing.------ The spacing is used as a projection along the line formed --- between connector points making the connection /looser/ if --- required.--- --- The default value is 0. Negative values are not allowed, they--- are normalized to 0.----dest_space :: (Ord u, InterpretUnit u) => u -> DrawingContextF-dest_space u = withFontSize $ \sz -> -    connectorUpd (\s -> s { dc_conn_dst_space = uconvert1 sz $ normZero u })------ | Set the connector source and destination spacings to the --- same length.----uniform_conn_space :: (Ord u, InterpretUnit u) => u -> DrawingContextF-uniform_conn_space u = withFontSize $ \sz -> -    connectorUpd (\s -> s { dc_conn_src_space = uconvert1 sz $ normZero u-                          , dc_conn_dst_space = uconvert1 sz $ normZero u })------ | Set the connector source offset.------ The offset is used to shift the start point /upwards/ --- perpendicular to its true origin (negative values are --- downwards). This can be used to draw a connector with two --- parallel lines, for example.------ Upwards and downwards in this description are dependent on the--- direction of the line, of course. Generally the documentations --- consider lines are left-to-right unless specifically noted.----source_offset :: (Ord u, InterpretUnit u) => u -> DrawingContextF-source_offset u = withFontSize $ \sz -> -    connectorUpd (\s -> s { dc_conn_src_offset = uconvert1 sz u })----- | Set the connector destination offset.------ See 'source_offset' for an explanation.----dest_offset :: (Ord u, InterpretUnit u) => u -> DrawingContextF-dest_offset u = withFontSize $ \sz -> -    connectorUpd (\s -> s { dc_conn_dst_offset = uconvert1 sz u })----- | Set the connector arc angle.----conn_arc_angle :: Radian -> DrawingContextF-conn_arc_angle ang = -    connectorUpd (\s -> s { dc_conn_arc_ang = ang })----- | Set the connector source arm length.----source_arm_len :: InterpretUnit u => u -> DrawingContextF-source_arm_len u = withFontSize $ \sz -> -    connectorUpd (\s -> s { dc_conn_src_arm = uconvert1 sz u })-                       ------ | Set the connector destination arm length.----dest_arm_len :: InterpretUnit u => u -> DrawingContextF-dest_arm_len u = withFontSize $ \sz -> -    connectorUpd (\s -> s { dc_conn_dst_arm = uconvert1 sz u })------- | Set the connector source and destination arms to the same --- length.----uniform_arm_len :: InterpretUnit u => u -> DrawingContextF-uniform_arm_len u = withFontSize $ \sz -> -    connectorUpd (\s -> s { dc_conn_src_arm = uconvert1 sz u-                          , dc_conn_dst_arm = uconvert1 sz u })----- | Set the connector loop size.----conn_loop_size :: InterpretUnit u => u -> DrawingContextF-conn_loop_size u = withFontSize $ \sz -> -    connectorUpd (\s -> s { dc_conn_loop_size = uconvert1 sz u })---- | Set the connector box halfsize.----conn_box_halfsize :: InterpretUnit u => u -> DrawingContextF-conn_box_halfsize u = withFontSize $ \sz -> -    connectorUpd (\s -> s { dc_conn_box_halfsize = uconvert1 sz u })

@@ -33,17 +33,26 @@   , runChain   , runChain_ -  , cnext+  , chain1+  , sequenceChain+   , setChainScheme +  , chainPrefix    , chainIterate-  , chainH-  , chainV -  , tableRight  -  , tableDown+  , horizontalChainScm+  , verticalChainScm+  , runChainH+  , runChainV +  , tableRowwiseScm+  , tableColumnwiseScm+  +  , runTableRowwise+  , runTableColumnwise+   , radialChain    ) where@@ -83,8 +92,8 @@ -- not be possible if start was just a pure @cst@ value.  -- data ChainScheme u = forall cst. ChainScheme -      { scheme_start    :: Point2 u -> cst-      , scheme_step     :: Point2 u -> cst -> (Point2 u,cst)+      { chain_init      :: Point2 u -> cst+      , chain_step      :: Point2 u -> cst -> (Point2 u,cst)       }  type instance DUnit (ChainScheme u) = u@@ -170,8 +179,8 @@ -- Run functions  runGenChain :: InterpretUnit u -         => GenChain st u a -> ChainScheme u -> st -> LocImage u (a,st)-runGenChain ma (ChainScheme start step) ust = promoteLoc $ \pt -> +            => ChainScheme u -> st -> GenChain st u a -> LocImage u (a,st)+runGenChain (ChainScheme start step) ust ma = promoteLoc $ \pt ->      askDC >>= \ctx ->     let st_zero     = ChainSt { chain_st         = start pt                               , chain_next       = step@@ -185,121 +194,181 @@ -- | Forget the user state LocImage, just return the /answer/. -- evalGenChain :: InterpretUnit u -             => GenChain st u a -> ChainScheme u -> st -> LocImage u a-evalGenChain ma cscm st = fmap fst $ runGenChain ma cscm st+             => ChainScheme u -> st -> GenChain st u a -> LocImage u a+evalGenChain cscm st ma = fmap fst $ runGenChain cscm st ma   -- | Forget the /answer/, just return the user state. -- execGenChain :: InterpretUnit u -             => GenChain st u a -> ChainScheme u -> st -> LocImage u st -execGenChain ma cscm st = fmap snd $ runGenChain ma cscm st+             => ChainScheme u -> st -> GenChain st u a -> LocImage u st +execGenChain cscm st ma = fmap snd $ runGenChain cscm st ma   stripGenChain :: InterpretUnit u -              => GenChain st u a -> ChainScheme u -> st -> LocQuery u (a,st)-stripGenChain ma cscm st = stripLocImage $ runGenChain ma cscm st +              => ChainScheme u -> st -> GenChain st u a -> LocQuery u (a,st)+stripGenChain cscm st ma = stripLocImage $ runGenChain cscm st ma    runChain :: InterpretUnit u -         => Chain u a -> ChainScheme u -> LocImage u a-runChain ma cscm = evalGenChain ma cscm ()+         => ChainScheme u -> Chain u a -> LocImage u a+runChain cscm ma = evalGenChain cscm () ma  runChain_ :: InterpretUnit u -          => Chain u a -> ChainScheme u -> LocGraphic u-runChain_ ma cscm = ignoreAns $ runChain ma cscm+          => ChainScheme u -> Chain u a -> LocGraphic u+runChain_ cscm ma = ignoreAns $ runChain cscm ma   + -------------------------------------------------------------------------------- -- Operations -cnext :: InterpretUnit u -      => LocImage u a -> GenChain st u a-cnext gf  = GenChain $ \ctx pt (ChainSt s0 sf ust) -> -    let dpt       = dinterpF (dc_font_size ctx) pt-        (pt1,st1) = sf dpt s0+chain1 :: InterpretUnit u +        => LocImage u a -> GenChain st u a+chain1 gf  = GenChain $ \ctx pt (ChainSt s0 sf ust) -> +    let upt       = dinterpF (dc_font_size ctx) pt+        (a,w1)    = runImage ctx $ applyLoc gf upt+        (pt1,st1) = sf upt s0         dpt1      = normalizeF (dc_font_size ctx) pt1-        (a,w1)    = runImage (applyLoc gf pt1) ctx-        new_st    = ChainSt { chain_st = st1-                            , chain_next = sf+        new_st    = ChainSt { chain_st         = st1+                            , chain_next       = sf                             , chain_user_state = ust }     in (a, dpt1, new_st, w1) +sequenceChain :: InterpretUnit u +              => [LocImage u a] -> GenChain st u (UNil u)+sequenceChain = ignoreAns . mapM_ chain1 +--+-- Note - onChain draws at the initial position, then increments +-- the next position.+--++ setChainScheme :: InterpretUnit u                 => ChainScheme u -> GenChain st u () setChainScheme (ChainScheme start step) =      GenChain $ \ctx pt (ChainSt _ _ ust) ->        let upt     = dinterpF (dc_font_size ctx) pt-          new_st  = ChainSt { chain_st = start upt-                            , chain_next = step+          new_st  = ChainSt { chain_st         = start upt+                            , chain_next       = step                             , chain_user_state = ust }       in ((), pt, new_st, mempty)    +chainPrefix :: ChainScheme u -> Int -> ChainScheme u -> ChainScheme u+chainPrefix (ChainScheme astart astep) ntimes chb@(ChainScheme bstart bstep)+    | ntimes < 1 = chb+    | otherwise  = ChainScheme { chain_init = start, chain_step = next }+  where+    start pt = (astart pt,ntimes, bstart pt)++    next pt (ast,n,bst) +        | n > 0     = let (p2,ast1) = astep pt ast in (p2, (ast1,n-1,bst))+        | n == 0    = let bst1      = bstart pt +                          (p2,bst2) = bstep pt bst1 +                      in (p2, (ast,(-1),bst2))+        | otherwise = let (p2,bst1) = bstep pt bst in (p2,(ast, (-1), bst1))+ ++++ -------------------------------------------------------------------------------- -- Schemes  chainIterate :: (Point2 u -> Point2 u) -> ChainScheme u-chainIterate fn = ChainScheme { scheme_start = const ()-                              , scheme_step  = \pt _ -> (fn pt, ())+chainIterate fn = ChainScheme { chain_init = const ()+                              , chain_step = \pt _ -> (fn pt, ())                               }  -chainH :: Num u => u -> ChainScheme u-chainH dx = -    ChainScheme { scheme_start = const ()-                , scheme_step  = \pt _ -> (displace (hvec dx) pt, ())+horizontalChainScm :: Num u => u -> ChainScheme u+horizontalChainScm dx = +    ChainScheme { chain_init = const ()+                , chain_step = \pt _ -> (displace (hvec dx) pt, ())                 }    -chainV :: Num u => u -> ChainScheme u-chainV dy = -    ChainScheme { scheme_start = const ()-                , scheme_step  = \pt _ -> (displace (vvec dy) pt, ())+verticalChainScm :: Num u => u -> ChainScheme u+verticalChainScm dy = +    ChainScheme { chain_init = const ()+                , chain_step = \pt _ -> (displace (vvec dy) pt, ())                 }  +-- Horizontal and vertical chains are common enough to merit +-- dedicated run functions. +runChainH :: InterpretUnit u => u -> Chain u a -> LocImage u a+runChainH dx ma = runChain (horizontalChainScm dx) ma ++runChainV :: InterpretUnit u => u -> Chain u a -> LocImage u a+runChainV dy ma = runChain (verticalChainScm dy) ma++ -- | Outer and inner steppers. -- scStepper :: PointDisplace u -> Int -> PointDisplace u            -> ChainScheme u scStepper outF n innF = -    ChainScheme { scheme_start = start, scheme_step = step }+    ChainScheme { chain_init = start, chain_step = step }   where-    start pt                      = (pt,0)-    step  pt (ogin,i) | i < n     = (innF pt, (ogin, i+1))+    start pt                      = (pt,1)+    step  pt (ogin,i) | i <  n    = (innF pt, (ogin, i+1))                       | otherwise = let o1 = outF ogin -                                    in (innF o1, (o1,1)) +                                    in (o1, (o1,1))   -tableRight :: Num u => Int -> (u,u) -> ChainScheme u-tableRight num_cols (col_width,row_height) = +tableRowwiseScm :: Num u => Int -> (u,u) -> ChainScheme u+tableRowwiseScm num_cols (col_width,row_height) =      scStepper downF num_cols rightF   where     downF   = displace $ vvec $ negate row_height     rightF  = displace $ hvec col_width -tableDown :: Num u => Int -> (u,u) -> ChainScheme u-tableDown num_rows (col_width,row_height) = +tableColumnwiseScm :: Num u => Int -> (u,u) -> ChainScheme u+tableColumnwiseScm num_rows (col_width,row_height) =      scStepper rightF num_rows downF   where     downF   = displace $ vvec $ negate row_height     rightF  = displace $ hvec col_width  +runTableRowwise :: InterpretUnit u +             => Int -> (u,u) -> Chain u a -> LocImage u a+runTableRowwise num_cols dims ma = +    runChain (tableRowwiseScm num_cols dims) ma ++runTableColumnwise :: InterpretUnit u +             => Int -> (u,u) -> Chain u a -> LocImage u a+runTableColumnwise num_rows dims ma = +    runChain (tableColumnwiseScm num_rows dims) ma+++ radialChain :: Floating u              => u -> Radian -> Radian -> ChainScheme u radialChain radius angstart angi = -    ChainScheme { scheme_start = start, scheme_step = step }+    ChainScheme { chain_init = start, chain_step = step }   where-    start pt           = (pt,angstart)-    step  _ (ogin,ang) = (displace (avec ang radius) ogin, (ogin,ang + angi))+    start pt           = let ogin = displace (avec angstart (-radius)) pt+                         in (ogin, angstart)+    step  _ (ogin,ang) = let ang_next = ang + angi +                             pt       = displace (avec ang_next radius) ogin+                         in (pt, (ogin, ang_next))++    ++-- radialChain is convoluted because first point is not the +-- circle center but a point on the circumference. Also the next+-- step iterates the (constant) origin rather than the previous +-- point.+  -- Note - radialChains stepper is oblivious to the previous point... 

@@ -129,8 +129,8 @@ -- Transform a 'TraceDrawing' into a 'CtxPicture'. -- drawTracing :: TraceDrawing u a -> CtxPicture-drawTracing mf = -    CtxPicture $ \ctx -> liftToPictureMb $ execTraceDrawing mf ctx+drawTracing ma = +    CtxPicture $ \ctx -> liftToPictureMb $ execTraceDrawing ctx ma  -- | 'udrawTracing' : @ scalar_unit_value * trace_drawing  -> CtxPicture @ --@@ -140,8 +140,8 @@ -- -- udrawTracing :: u -> TraceDrawing u a -> CtxPicture-udrawTracing _ mf = -    CtxPicture $ \ctx -> liftToPictureMb $ execTraceDrawing mf ctx+udrawTracing _ ma = +    CtxPicture $ \ctx -> liftToPictureMb $ execTraceDrawing ctx ma   -- Note need Gen versions with user state...

@@ -163,8 +163,8 @@   runGenLocDrawing :: (Translate a, InterpretUnit u, u ~ DUnit a) -                 => GenLocDrawing st u a -> st -> LocImage u (a,st)-runGenLocDrawing ma st = promoteLoc $ \(P2 x y) -> +                 => st -> GenLocDrawing st u a -> LocImage u (a,st)+runGenLocDrawing st ma = promoteLoc $ \(P2 x y) ->      askDC >>= \ctx ->     let (a,s1,w1) = getGenLocDrawing ma ctx st         ans       = translate x y a @@ -177,20 +177,20 @@ -- | Forget the user state LocImage, just return the /answer/. -- evalGenLocDrawing :: (Translate a, InterpretUnit u, u ~ DUnit a) -                  => GenLocDrawing st u a -> st -> LocImage u a-evalGenLocDrawing ma st = fmap fst $ runGenLocDrawing ma st+                  => st -> GenLocDrawing st u a -> LocImage u a+evalGenLocDrawing st ma = fmap fst $ runGenLocDrawing st ma   -- | Forget the /answer/, just return the user state. -- execGenLocDrawing :: (Translate a, InterpretUnit u, u ~ DUnit a) -                  => GenLocDrawing st u a -> st -> LocImage u st -execGenLocDrawing ma st = fmap snd $ runGenLocDrawing ma st+                  => st -> GenLocDrawing st u a -> LocImage u st +execGenLocDrawing st ma = fmap snd $ runGenLocDrawing st ma   stripGenLocDrawing :: (Translate a, InterpretUnit u, u ~ DUnit a) -                   => GenLocDrawing st u a -> st -> LocQuery u (a,st)-stripGenLocDrawing ma st = stripLocImage $ runGenLocDrawing ma st +                   => st -> GenLocDrawing st u a -> LocQuery u (a,st)+stripGenLocDrawing st ma = stripLocImage $ runGenLocDrawing st ma   -- | Simple version of 'runGenLocDrawing' - run a 'LocDrawing' without@@ -198,7 +198,7 @@ -- runLocDrawing :: (Translate a, InterpretUnit u, u ~ DUnit a)                => LocDrawing u a -> LocImage u a-runLocDrawing ma = evalGenLocDrawing ma ()+runLocDrawing ma = evalGenLocDrawing () ma   runLocDrawing_ :: (Translate a, InterpretUnit u, u ~ DUnit a) @@ -212,7 +212,7 @@ insertiImpl :: InterpretUnit u              => Image u a -> GenLocDrawing st u a insertiImpl gf = GenLocDrawing $ \ctx s -> -    let (a,w1)   = runImage gf ctx in (a,s,w1) +    let (a,w1)   = runImage ctx gf in (a,s,w1)    @@ -221,7 +221,7 @@ insertliImpl :: InterpretUnit u              => Anchor u -> LocImage u a -> GenLocDrawing st u a insertliImpl p1 gf = GenLocDrawing $ \ctx s -> -    let (a,w1) = runLocImage gf ctx p1 in (a,s,w1) +    let (a,w1) = runLocImage ctx p1 gf in (a,s,w1)    @@ -235,4 +235,4 @@              => Anchor u -> Anchor u -> ConnectorImage u a               -> GenLocDrawing st u a insertciImpl p1 p2 gf = GenLocDrawing $ \ctx s -> -    let (a,w1) = runConnectorImage gf ctx p1 p2 in (a,s,w1) +    let (a,w1) = runConnectorImage ctx p1 p2 gf in (a,s,w1) 

@@ -146,7 +146,7 @@ insertlImpl :: InterpretUnit u => LocImage u a -> GenLocTrace st u a insertlImpl gf = GenLocTrace $ \ctx pt s ->     let upt    = dinterpF (dc_font_size ctx) pt -        (a,w1) = runLocImage gf ctx upt+        (a,w1) = runLocImage ctx upt gf     in (a,pt,s,w1)   @@ -171,8 +171,8 @@   runGenLocTrace :: InterpretUnit u -               => GenLocTrace st u a -> st -> LocImage u (a,st)-runGenLocTrace ma st = promoteLoc $ \pt -> +               => st -> GenLocTrace st u a -> LocImage u (a,st)+runGenLocTrace st ma = promoteLoc $ \pt ->      askDC >>= \ctx ->     let dpt         = normalizeF (dc_font_size ctx) pt         (a,_,s1,w1) = getGenLocTrace ma ctx dpt st@@ -184,20 +184,20 @@ -- | Forget the user state LocImage, just return the /answer/. -- evalGenLocTrace :: InterpretUnit u -                => GenLocTrace st u a -> st -> LocImage u a-evalGenLocTrace ma st = fmap fst $ runGenLocTrace ma st+                => st -> GenLocTrace st u a -> LocImage u a+evalGenLocTrace st ma = fmap fst $ runGenLocTrace st ma   -- | Forget the /answer/, just return the user state. -- execGenLocTrace :: InterpretUnit u -                => GenLocTrace st u a -> st -> LocImage u st -execGenLocTrace ma st = fmap snd $ runGenLocTrace ma st+                => st -> GenLocTrace st u a -> LocImage u st +execGenLocTrace st ma = fmap snd $ runGenLocTrace st ma   stripGenLocTrace :: InterpretUnit u -                 => GenLocTrace st u a -> st -> LocQuery u (a,st)-stripGenLocTrace ma st = stripLocImage $ runGenLocTrace ma st +                 => st -> GenLocTrace st u a -> LocQuery u (a,st)+stripGenLocTrace st ma = stripLocImage $ runGenLocTrace st ma   -- | Simple version of 'runGenLocTrace' - run a 'LocTrace' without@@ -205,7 +205,7 @@ -- runLocTrace :: InterpretUnit u              => LocTrace u a -> LocImage u a-runLocTrace ma = evalGenLocTrace ma ()+runLocTrace ma = evalGenLocTrace () ma   runLocTrace_ :: InterpretUnit u 

@@ -0,0 +1,661 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Drawing.PosObject+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Extended Graphic object - a rectangular /positionable/ Image.+-- +-- This graphic object has a more flexible API for positioning +-- than other graphic objects. Rather than a LocGraphic which +-- supports a single method of positioning at some start-point,+-- a @PosGraphic@ can be drawn at its center or locations on its +-- outer rectangle.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Drawing.PosObject+  (++  -- * Positionable image+    GenPosObject+  , GenPosGraphic++  , PosObject+  , DPosObject++  , PosGraphic+  , DPosGraphic++  -- * Operations+  , runGenPosObject+  , evalGenPosObject+  , execGenPosObject+  +  , runPosObject++  , runPosObjectBBox++  , makePosObject+  , emptyPosObject++  , elaboratePosObject+  , decoratePosObject++  , extendPosObject+  , mapOrientation++  , illustratePosObject++  -- * Primitive text PosObjects+  , posChar+  , posEscChar +  , posCharUpright+  , posEscCharUpright+  +  , posCharPrim++  , posText+  , posEscText +  , posTextUpright+  , posEscTextUpright++  , posTextPrim++  , multilinePosText+  , multilinePosEscText++  , rposText+  , rposEscText+  , rposChar+  , rposEscChar+  ++  , posHKernText++  , monospaceText+  , monospaceEscText++  ) where+++import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Base.DrawingContext+import Wumpus.Basic.Kernel.Base.QueryDC+import Wumpus.Basic.Kernel.Base.UpdateDC+import Wumpus.Basic.Kernel.Base.WrappedPrimitive+import Wumpus.Basic.Kernel.Drawing.Basis+import Wumpus.Basic.Kernel.Objects.Basis+import Wumpus.Basic.Kernel.Objects.Concat+import Wumpus.Basic.Kernel.Objects.DrawingPrimitives+import Wumpus.Basic.Kernel.Objects.Image+import Wumpus.Basic.Kernel.Objects.LocImage+import Wumpus.Basic.Kernel.Objects.LocThetaImage+import Wumpus.Basic.Kernel.Objects.Orientation++import Wumpus.Core                              -- package: wumpus-core+import Wumpus.Core.Colour ( red, blue )++import Data.AffineSpace                         -- package: vector-space+import Data.VectorSpace++import Control.Applicative+import Data.Monoid++type DOrt = Orientation Double++-- | A positionable \"Object\".+--+newtype GenPosObject st u a = GenPosObject { +    getGenPosObject :: DrawingContext -> DPoint2 -> st -> (a, st, DOrt, CatPrim) }++type instance DUnit   (GenPosObject st u a) = u+type instance UState  (GenPosObject st u)   = st++type GenPosGraphic st u = GenPosObject st u (UNil u)+++-- | Type synonym for @GenPosObject () u a@, a PosObject without+-- user state.+--+type PosObject u a = GenPosObject () u a+    +-- | Version of PosObject specialized to Double for the unit type.+--+type DPosObject a = PosObject Double a+++-- | Version of PosObject with answer specialized to UNil.+--+type PosGraphic u = PosObject u (UNil u)++-- | Version of PosGraphic specialized to Double for the unit type.+--+type DPosGraphic = PosGraphic Double+++++instance Functor (GenPosObject st u) where+  fmap f mf = GenPosObject $ \ctx pt s -> +              let (a,s1,o1,w1) = getGenPosObject mf ctx pt s in (f a,s1,o1,w1)+++instance Applicative (GenPosObject st u) where+  pure a    = GenPosObject $ \_   _  s -> (a,s,mempty,mempty)+  mf <*> ma = GenPosObject $ \ctx pt s -> +              let (f,s1,o1,w1) = getGenPosObject mf ctx pt s+                  (a,s2,o2,w2) = getGenPosObject ma ctx pt s1+              in (f a, s2, o1 `mappend` o2, w1 `mappend` w2)++++instance Monad (GenPosObject st u) where+  return a  = GenPosObject $ \_   _  s  -> (a, s, mempty, mempty)+  mf >>= k  = GenPosObject $ \ctx pt s -> +              let (a,s1,o1,w1) = getGenPosObject mf ctx pt s+                  (b,s2,o2,w2) = getGenPosObject (k a) ctx pt s1+              in (b, s2, o1 `mappend` o2, w1 `mappend` w2)+++instance (Monoid a, InterpretUnit u) => Monoid (GenPosObject st u a) where+  mempty = GenPosObject $ \_ _ s -> (mempty, s, mempty, mempty)+  ma `mappend` mb = GenPosObject $ \ctx pt s -> +                    let (a,s1,o1,w1) = getGenPosObject ma ctx pt s+                        (b,s2,o2,w2) = getGenPosObject mb ctx pt s1+                    in (a `mappend` b, s2, o1 `mappend` o2, w1 `mappend` w2)++++-- DrawingCtxM++instance DrawingCtxM (GenPosObject st u) where+  askDC           = GenPosObject $ \ctx _  s -> (ctx, s, mempty, mempty)+  asksDC fn       = GenPosObject $ \ctx _  s -> (fn ctx, s, mempty, mempty)+  localize upd ma = GenPosObject $ \ctx pt s -> +                      getGenPosObject ma (upd ctx) pt s++instance UserStateM (GenPosObject st u) where+  getState        = GenPosObject $ \_ _ s -> (s, s, mempty, mempty)+  setState s      = GenPosObject $ \_ _ _ -> ((), s, mempty, mempty)+  updateState upd = GenPosObject $ \_ _ s -> ((), upd s, mempty, mempty)++++-- | Running an PosObject produces a LocImage.+--+runGenPosObject :: InterpretUnit u +                => RectAddress -> st -> GenPosObject st u a -> LocImage u (a,st)+runGenPosObject addr st ma = promoteLoc $ \ot -> +    askDC >>= \ctx -> +    let dot          = normalizeF (dc_font_size ctx) ot+        (a,s1,o1,ca) = getGenPosObject ma ctx dot st+        v1           = vtoOrigin addr o1+    in replaceAns (a,s1) $ primGraphic $ cpmove v1 ca+++evalGenPosObject :: InterpretUnit u +                 => RectAddress -> st -> GenPosObject st u a -> LocImage u a+evalGenPosObject addr st ma = fmap fst $ runGenPosObject addr st ma++execGenPosObject :: InterpretUnit u +                 => RectAddress -> st -> GenPosObject st u a -> LocImage u st+execGenPosObject addr st ma = fmap snd $ runGenPosObject addr st ma++runPosObject :: InterpretUnit u +             => RectAddress -> PosObject u a -> LocImage u a+runPosObject addr ma = fmap fst $ runGenPosObject addr () ma+++++-- | Run a PosObject producing a LocImage (BoundingBox u).+--+runPosObjectBBox :: InterpretUnit u +                    => RectAddress -> PosObject u a -> LocImage u (BoundingBox u)+runPosObjectBBox addr ma = promoteLoc $ \pt -> +    askDC >>= \ctx -> +    let sz          = dc_font_size ctx +        dpt         = normalizeF sz pt+        (_,_,o1,w1) = getGenPosObject ma ctx dpt ()+        v1          = vtoOrigin addr o1+        bb          = dinterpF sz $ orientationBounds o1 (dpt .+^ v1)+    in replaceAns bb $ primGraphic $ cpmove v1 w1+++++--------------------------------------------------------------------------------+++-- | 'makePosObject' : @ object_pos * loc_image -> PosObject @ +--+-- Create a 'PosObject' from an 'Orientation' describing how it+-- is orientated within a border rectangle and a 'LocImage' that +-- draws it.+--+-- This is the /primary/ constructor for PosObjects. Because the+-- PosObject type is considered as a specialized object it does+-- not have the range of functions of LocImage or LocThetaImage.+-- +makePosObject :: InterpretUnit u+              => Query u (Orientation u) -> LocImage u a -> GenPosObject st u a+makePosObject ma gf = GenPosObject $ \ctx pt s -> +    let ort1  = runQuery ctx ma+        dort1 = normalizeF (dc_font_size ctx) ort1+        upt   = dinterpF (dc_font_size ctx) pt+        (a,w) = runLocImage ctx upt gf+    in (a,s,dort1,w)+++-- | 'emptyPosObject' : @ PosObject @+--+-- Build an empty 'PosGraphicObject'.+--+emptyPosObject :: (Monoid a, InterpretUnit u) => GenPosObject st u a+emptyPosObject = mempty++    ++--+-- decorate  - oblivious to /answer/.+-- elaborate - derives annotation from the /answer/ and makes a +--             cumulative graphic.+--+++elaboratePosObject :: (Fractional u, Ord u, InterpretUnit u)+                   => ZDeco -> RectAddress -> LocGraphic u -> GenPosObject st u a+                   -> GenPosObject st u a+elaboratePosObject zdec raddr gf ma = decoratePosObject zdec fn ma+  where+    fn ortt = moveStart (vtoRectAddress ortt raddr) gf++++decoratePosObject :: InterpretUnit u +                  => ZDeco -> (Orientation u -> LocGraphic u) -> GenPosObject st u a+                  -> GenPosObject st u a+decoratePosObject zdec fn ma = GenPosObject $ \ctx pt s -> +    let (a,s1,o1,w1) = getGenPosObject ma ctx pt s+        uortt        = dinterpF (dc_font_size ctx) o1+        upt          = dinterpF (dc_font_size ctx) pt+        (_,w2)       = runLocImage ctx upt $ fn uortt+        wout         = case zdec of+                         ANTERIOR -> w2 `mappend` w1+                         SUPERIOR -> w1  `mappend` w2+    in (a,s1,o1,wout)+++++-- | Extend the orientation.+--+extendPosObject :: InterpretUnit u +                => u -> u -> u -> u -> GenPosObject st u a +                -> GenPosObject st u a+extendPosObject x0 x1 y0 y1 ma = GenPosObject $ \ctx pt s ->+    let (a,s1,o1,w1) = getGenPosObject ma ctx pt s+        sz           = dc_font_size ctx        +        ux0          = normalize sz x0+        ux1          = normalize sz x1+        uy0          = normalize sz y0+        uy1          = normalize sz y1+        o2           = extendOrientation ux0 ux1 uy0 uy1 o1+    in (a,s1,o2,w1)+++-- | Note - this is a bad API, it would be better to have padders+-- and fillers and not expose the orientation directly.+-- +mapOrientation :: InterpretUnit u+               => (Orientation u -> Orientation u) +               -> GenPosObject st u a -> GenPosObject st u a+mapOrientation fn mf = GenPosObject $ \ctx pt s -> +    let (a,s1,o1,w1) = getGenPosObject mf ctx pt s+        uort      = fn $ dinterpF (dc_font_size ctx) o1+        o2        = normalizeF (dc_font_size ctx) uort+    in (a,s1,o2,w1)+++--------------------------------------------------------------------------------+++-- | Illustrate a 'PosObject' by super-imposing its 'Orientation'.+--+-- This turns the 'PosObject' into a 'LocImage' drawn at the locus+-- of the PosObject.+--+illustratePosObject :: InterpretUnit u +                    => PosObject u a -> LocGraphic u+illustratePosObject mf  = promoteLoc $ \pt ->   +    askDC >>= \ctx ->+    let dpt         = normalizeF (dc_font_size ctx) pt +        (_,_,o1,w1) = getGenPosObject mf ctx dpt ()+        uort        = dinterpF (dc_font_size ctx) o1+    in adecorate (primGraphic w1) (illustrateOrientation uort `at` pt)+++illustrateOrientation :: InterpretUnit u +                      => Orientation u -> LocGraphic u+illustrateOrientation (Orientation xmin xmaj ymin ymaj) = promoteLoc $ \pt -> +    dinterpCtx 3 >>= \radius -> +    let upd = localize (fill_colour blue . dotted_line)+        bl  = pt .-^ V2 xmin ymin+        dot = localize (fill_colour red) $ dcDisk DRAW_FILL radius `at` pt+        hln = upd $ locStraightLine (hvec $ xmin+xmaj) `at` pt .-^ hvec xmin+        vln = upd $ locStraightLine (vvec $ ymin+ymaj) `at` pt .-^ vvec ymin+        bdr = upd $ dcRectangle DRAW_STROKE (xmin+xmaj) (ymin+ymaj) `at` bl+    in mconcat [ bdr, hln, vln, dot ]++++--------------------------------------------------------------------------------+-- Char PosObjects+++-- Note - because the TextHeight constructors are so long winded,+-- using them directly makes for a bad API. Instead we have two +-- versions for each function.++-- | Note - no margins are added to the containing rectangle.+-- +-- To get a Char with margins, use 'posText' instead:+--+-- > posText ['1']+-- +posChar             :: InterpretUnit u +                    => Char -> GenPosGraphic st u+posChar             = makeCharPO CAP_HEIGHT_PLUS_DESCENDER . CharLiteral++posEscChar          :: InterpretUnit u +                    => EscapedChar -> GenPosGraphic st u+posEscChar          = makeCharPO CAP_HEIGHT_PLUS_DESCENDER++posCharUpright      :: InterpretUnit u +                    => Char -> GenPosGraphic st u+posCharUpright      = makeCharPO JUST_CAP_HEIGHT . CharLiteral++posEscCharUpright   :: InterpretUnit u +                    => EscapedChar -> GenPosGraphic st u+posEscCharUpright   = makeCharPO JUST_CAP_HEIGHT+++-- | Primtive builder that does not add margins.+--+posCharPrim         :: InterpretUnit u +                    => Either Char EscapedChar -> GenPosGraphic st u+posCharPrim = makeCharPO CAP_HEIGHT_PLUS_DESCENDER . either CharLiteral id+++makeCharPO :: InterpretUnit u +           => TextHeight -> EscapedChar -> GenPosGraphic st u+makeCharPO hspec esc = +    makePosObject (charOrientation hspec esc) +                  (dcEscapedlabel $ wrapEscChar esc)+++++-- | Build the Orientation of an EscapedChar.+-- +-- The locus of the Orientation is baseline left - margins are +-- added.+--+charOrientation :: (DrawingCtxM m, InterpretUnit u)+                => TextHeight -> EscapedChar -> m (Orientation u)+charOrientation hspec esc = +    (\(V2 x _ ) (ymin,ymaj) -> Orientation 0 x ymin ymaj) +      <$> escCharVector esc <*> heightSpan hspec+++--------------------------------------------------------------------------------+-- Text PosObjects++++posText     :: InterpretUnit u +            => String -> GenPosGraphic st u+posText     = addMargins . makeTextPO CAP_HEIGHT_PLUS_DESCENDER . escapeString++posEscText  :: InterpretUnit u +            => EscapedText -> GenPosGraphic st u+posEscText  = addMargins . makeTextPO CAP_HEIGHT_PLUS_DESCENDER+++posTextUpright      :: InterpretUnit u +                    => String -> GenPosGraphic st u+posTextUpright      = addMargins . makeTextPO JUST_CAP_HEIGHT . escapeString++posEscTextUpright   :: InterpretUnit u +                    => EscapedText -> GenPosGraphic st u+posEscTextUpright   = addMargins . makeTextPO JUST_CAP_HEIGHT++-- | Primtive builder that does not add margins.+--+posTextPrim         :: InterpretUnit u +                    => Either String EscapedText -> GenPosGraphic st u+posTextPrim = makeTextPO CAP_HEIGHT_PLUS_DESCENDER . either escapeString id+++multilinePosText :: (Fractional u, InterpretUnit u)+                 => VAlign -> String -> PosGraphic u+multilinePosText vspec xs = +    multilinePosEscText vspec $ map escapeString $ lines xs++multilinePosEscText :: (Fractional u, InterpretUnit u)+                    => VAlign -> [EscapedText] -> GenPosGraphic st u+multilinePosEscText vspec xs = addMargins $ GenPosObject $ \ctx pt s -> +      let sep    = runQuery ctx textlineSpace+      in getGenPosObject (body sep) ctx pt s+  where+    body sp = alignColumnSep vspec sp $ +                map (makeTextPO CAP_HEIGHT_PLUS_DESCENDER) xs++++-- | Note - this does not add margins.+--+makeTextPO :: InterpretUnit u +           => TextHeight -> EscapedText -> GenPosGraphic st u+makeTextPO hspec esc = +    makePosObject (textOrientationZero hspec esc) (dcEscapedlabel esc)+++addMargins :: InterpretUnit u => GenPosObject st u a -> GenPosObject st u a+addMargins ma = +   textMargin >>= \(xsep,ysep) -> extendPosObject xsep xsep ysep ysep ma++-- | Build the Orientation of a single line of EscapedText - +-- writing direction zero (left-to-right).+-- +-- The locus of the Orientation is baseline left - margins are +-- added.+--+textOrientationZero :: (DrawingCtxM m, InterpretUnit u )+                    => TextHeight -> EscapedText -> m (Orientation u)+textOrientationZero hspec esc = +    (\(V2 x _ ) (ymin,ymaj) -> Orientation 0 x ymin ymaj) +      <$> escTextVector esc <*> heightSpan hspec+++--------------------------------------------------------------------------------+-- Rotated text++-- | Note - for single line text.+--+rposText        :: (Real u, Floating u, InterpretUnit u) +                => Radian -> String -> GenPosGraphic st u+rposText ang    = addMargins . makeRotatedPO ang . escapeString++-- | Note - for single line text.+--+rposEscText     :: (Real u, Floating u, InterpretUnit u) +                => Radian -> EscapedText -> GenPosGraphic st u+rposEscText ang = addMargins . makeRotatedPO ang+++rposChar        :: (Real u, Floating u, InterpretUnit u) +                => Radian -> Char -> GenPosGraphic st u+rposChar ang ch = rposEscText ang $ wrapEscChar $ CharLiteral ch++rposEscChar     :: (Real u, Floating u, InterpretUnit u) +                => Radian -> EscapedChar -> GenPosGraphic st u+rposEscChar ang ch = rposEscText ang $ wrapEscChar ch+++++makeRotatedPO :: (Real u, Floating u, InterpretUnit u) +              => Radian -> EscapedText -> GenPosGraphic st u+makeRotatedPO ang esc = makePosObject qry body+  where+    qry  = rotateOrientation ang <$> +             textOrientationZero CAP_HEIGHT_PLUS_DESCENDER esc++    body = incline (dcREscapedlabel esc) ang+++--------------------------------------------------------------------------------+-- Kerned text+++posHKernText :: InterpretUnit u+            => [KernChar u] -> GenPosGraphic st u+posHKernText xs = makePosObject (hkernOrientationZero xs) (hkernLine xs)++-- | The query should retrieve the width of one char.+--+monospaceText :: InterpretUnit u +              => Query u u -> String -> GenPosGraphic st u+monospaceText qry = monospaceEscText qry . escapeString+++-- | The query should retrieve the width of one char.+--+monospaceEscText :: InterpretUnit u +                 => Query u u -> EscapedText -> GenPosGraphic st u+monospaceEscText qry esc = GenPosObject $ \ctx pt s ->+    let upt    = dinterpF (dc_font_size ctx) pt+        uw     = runQuery ctx qry+        ks     = monos uw $ destrEscapedText id esc+        ortt   = runQuery ctx $ hkernOrientationZero ks+        dort   = normalizeF (dc_font_size ctx) ortt+        (_,w1) = runLocImage ctx upt $ hkernLine ks+    in (UNil, s, dort, w1)++++++monos :: Num u => u -> [EscapedChar] -> [KernChar u]+monos w1 (c:cs) = (0,c) : map (\ch -> (w1,ch)) cs+monos _  []     = []++++-- | Note - always CAP_HEIGHT_PLUS_DESCENDER for this one.+--+hkernOrientationZero :: (DrawingCtxM m, InterpretUnit u )+                     => [KernChar u] -> m (Orientation u)+hkernOrientationZero xs = +    (\(V2 x _ ) (ymin,ymaj) -> Orientation 0 x ymin ymaj) +      <$> hkernVector xs <*> heightSpan CAP_HEIGHT_PLUS_DESCENDER++ ++--------------------------------------------------------------------------------+-- Combining PosObject+++instance (Monoid a, InterpretUnit u) => ZConcat (GenPosObject st u a) where+  superior = mappend+  anterior = flip mappend+++instance Monoid a => Concat (GenPosObject st u a) where+  hconcat = genMoveAlign spinemoveH spineRight+  vconcat = genMoveAlign spinemoveV spineBelow++instance (Monoid a, InterpretUnit u) => CatSpace (GenPosObject st u a) where+  hspace = genMoveSepH spinemoveH spineRight+  vspace = genMoveSepV spinemoveV spineBelow++++instance Monoid a => Align (GenPosObject st u a) where+  halign HALIGN_TOP    = genMoveAlign binmoveHTop    halignTopO+  halign HALIGN_CENTER = genMoveAlign binmoveHCenter halignCenterO+  halign HALIGN_BASE   = genMoveAlign binmoveHBottom halignBottomO++  valign VALIGN_LEFT   = genMoveAlign binmoveVLeft   valignLeftO+  valign VALIGN_CENTER = genMoveAlign binmoveVCenter valignCenterO+  valign VALIGN_RIGHT  = genMoveAlign binmoveVRight  valignRightO++++genMoveAlign :: Monoid a+             => (Orientation Double -> Orientation Double -> Vec2 Double) +             -> (Orientation Double -> Orientation Double -> Orientation Double) +             -> GenPosObject st u a -> GenPosObject st u a -> GenPosObject st u a+genMoveAlign mkV mkO ma mb = GenPosObject $ \ctx pt s -> +    let (a,s1,o1,w1) = getGenPosObject ma ctx pt s+        (b,s2,o2,w2) = getGenPosObject mb ctx pt s1+        v1           = mkV o1 o2+        ortt         = mkO o1 o2+        w2'          = cpmove v1 w2 +    in (a `mappend` b, s2, ortt, w1 `mappend` w2')+++--------------------------------------------------------------------------------+-- Sep++instance (Monoid a, InterpretUnit u) => AlignSpace (GenPosObject st u a) where+  halignSpace HALIGN_TOP    = genMoveSepH binmoveHTop    halignTopO+  halignSpace HALIGN_CENTER = genMoveSepH binmoveHCenter halignCenterO+  halignSpace HALIGN_BASE   = genMoveSepH binmoveHBottom halignBottomO++  valignSpace VALIGN_LEFT   = genMoveSepV binmoveVLeft   valignLeftO+  valignSpace VALIGN_CENTER = genMoveSepV binmoveVCenter valignCenterO+  valignSpace VALIGN_RIGHT  = genMoveSepV binmoveVRight  valignRightO+++genMoveSepH :: (Monoid a, InterpretUnit u) +            => (Orientation Double -> Orientation Double -> Vec2 Double) +            -> (Orientation Double -> Orientation Double -> Orientation Double) +            -> u+            -> GenPosObject st u a -> GenPosObject st u a +            -> GenPosObject st u a+genMoveSepH mkV mkO sep ma mb  = GenPosObject $ \ctx pt s -> +    let (a,s1,o1,w1) = getGenPosObject ma ctx pt s+        (b,s2,o2,w2) = getGenPosObject mb ctx pt s1+        dsep         = normalize (dc_font_size ctx) sep+        v1           = hvec dsep ^+^ mkV o1 o2+        ortt         = extendORight dsep $ mkO o1 o2+        w2'          = cpmove v1 w2+    in (a `mappend` b, s2, ortt, w1 `mappend` w2')++++genMoveSepV :: (Monoid a, InterpretUnit u)+            => (Orientation Double -> Orientation Double -> Vec2 Double) +            -> (Orientation Double -> Orientation Double -> Orientation Double) +            -> u+            -> GenPosObject st u a -> GenPosObject st u a +            -> GenPosObject st u a+genMoveSepV mkV mkO sep ma mb = GenPosObject $ \ctx pt s -> +    let (a,s1,o1,w1) = getGenPosObject ma ctx pt s +        (b,s2,o2,w2) = getGenPosObject mb ctx pt s1+        dsep         = normalize (dc_font_size ctx) sep+        v1           = vvec (-dsep) ^+^ mkV o1 o2+        ortt         = extendODown dsep $ mkO o1 o2+        w2'          = cpmove v1 w2+    in (a `mappend` b, s2, ortt, w1 `mappend` w2')+

@@ -146,8 +146,8 @@   -runTraceDrawing :: TraceDrawing u a -> DrawingContext -> (a, HPrim u)-runTraceDrawing ma ctx = post $ getGenTraceDrawing ma ctx ()+runTraceDrawing :: DrawingContext -> TraceDrawing u a -> (a, HPrim u)+runTraceDrawing ctx ma = post $ getGenTraceDrawing ma ctx ()   where     post (a,_,w1) = (a,w1) @@ -156,8 +156,8 @@ -- | Run the drawing returning only the output it produces, drop -- any answer from the monadic computation. ---execTraceDrawing :: TraceDrawing u a -> DrawingContext -> HPrim u-execTraceDrawing ma ctx = snd $ runTraceDrawing ma ctx+execTraceDrawing :: DrawingContext -> TraceDrawing u a -> HPrim u+execTraceDrawing ctx ma = snd $ runTraceDrawing ctx ma  -- | Run the drawing ignoring the output it produces, return the  -- answer from the monadic computation.@@ -166,13 +166,13 @@ -- opposite behaviour (return the drawing, ignore than the  -- answer). -- -evalTraceDrawing :: TraceDrawing u a -> DrawingContext -> a-evalTraceDrawing ma ctx = fst $ runTraceDrawing ma ctx+evalTraceDrawing :: DrawingContext -> TraceDrawing u a -> a+evalTraceDrawing ctx ma = fst $ runTraceDrawing ctx ma  -runGenTraceDrawing :: GenTraceDrawing st u a -> DrawingContext -> st +runGenTraceDrawing :: DrawingContext -> st -> GenTraceDrawing st u a                     -> (a,st,HPrim u)-runGenTraceDrawing = getGenTraceDrawing+runGenTraceDrawing ctx st ma = getGenTraceDrawing ma ctx st   @@ -242,7 +242,7 @@  fontDelta :: GenTraceDrawing st u a -> GenTraceDrawing st u a fontDelta mf = GenTraceDrawing $ \ctx s -> -    let (_,font_attrs) = runQuery textAttr ctx+    let (_,font_attrs) = runQuery ctx textAttr         (a,s1,w1)      = getGenTraceDrawing mf ctx s         prim           = fontDeltaContext font_attrs $ primGroup $ hprimToList w1     in (a, s1, singleH $ prim1 $ prim)@@ -250,7 +250,7 @@ -- Note - this function is in the wrong module.... -- evalQuery :: DrawingCtxM m => Query u a -> m a-evalQuery df = askDC >>= \ctx -> return $ runQuery df ctx+evalQuery df = askDC >>= \ctx -> return $ runQuery ctx df   @@ -263,7 +263,7 @@ --  draw :: Image u a -> GenTraceDrawing st u () draw gf = askDC >>= \ctx -> -          let (_,w) = runImage gf ctx +          let (_,w) = runImage ctx gf           in trace (singleH w) >> return ()  @@ -277,7 +277,7 @@ --  drawi :: Image u a -> GenTraceDrawing st u a drawi gf = askDC >>= \ctx -> -           let (a,w) = runImage gf ctx+           let (a,w) = runImage ctx gf            in trace (singleH w) >> return a              @@ -304,7 +304,7 @@ drawli :: InterpretUnit u        => Anchor u -> LocImage u a -> GenTraceDrawing st u a drawli pt gf = askDC >>= \ctx -> -               let (a,w) = runLocImage gf ctx pt+               let (a,w) = runLocImage ctx pt gf                in trace (singleH w) >> return a  @@ -328,7 +328,7 @@ --  drawc :: InterpretUnit u       => Anchor u -> Anchor u -> ConnectorImage u a -> GenTraceDrawing st u ()-drawc an0 an1 img = drawci an0 an1 img >> return () +drawc an0 an1 gf = drawci an0 an1 gf >> return ()    -- | Draw a ConnectorImage with the supplied Points taking the @@ -339,7 +339,7 @@ --  drawci :: InterpretUnit u         => Anchor u -> Anchor u -> ConnectorImage u a -> GenTraceDrawing st u a-drawci p0 p1 img = drawi (connect p0 p1 img)+drawci p0 p1 gf = drawi (connect gf p0 p1)   @@ -369,7 +369,7 @@       => (Int,Int) -> LocImage u a -> GenTraceDrawing st u a nodei coord gf = askDC >>= \ctx ->                   position coord >>= \pt ->-                 let (a,w) = runLocImage gf ctx pt+                 let (a,w) = runLocImage ctx pt gf                  in trace (singleH w) >> return a   @@ -408,4 +408,4 @@            )          => a1 -> a2 -> ConnectorImage u a -> GenTraceDrawing st u a drawrci a b gf = -    let (p0,p1) = radialConnectorPoints a b in drawi (connect p0 p1 gf)+    let (p0,p1) = radialConnectorPoints a b in drawi (connect gf p0 p1)

@@ -191,10 +191,10 @@ makeAdvObject :: InterpretUnit u                => Query u (Vec2 u) -> LocImage u a -> AdvObject u a makeAdvObject ma gf = AdvObject $ \ctx pt -> -    let v1    = runQuery ma ctx+    let v1    = runQuery ctx ma         dav1  = DAV $ normalizeF (dc_font_size ctx) v1         upt   = dinterpF (dc_font_size ctx) pt-        (a,w) = runLocImage gf ctx upt+        (a,w) = runLocImage ctx upt gf     in (a,dav1,w)  

@@ -17,14 +17,11 @@ -- Anchor points on shapes, bounding boxes, etc. -- -- Anchors are addressable positions, an examplary use is taking--- anchors on node shapes to get the start and end points for --- connectors in a network (graph) diagram.+-- anchors on node shapes to get the in-bound and out-bound points +-- for connectors in a network (graph) diagram. -- --- \*\* WARNING \*\* - The API here needs some thought as to a--- good balance of the type classes - in a nutshell \"are corners --- better than cardinals\". Originally I tried to follow how I --- understand the TikZ anchors to work, but this is perhaps not --- ideal for dividing into type-classes.+-- \*\* WARNING \*\* - the API here probably needs some more +-- thought. -- -------------------------------------------------------------------------------- 

@@ -81,11 +81,12 @@ -- it with the graphic from the second. -- class Decorate (f :: * -> * -> *) where-  decorate   :: ZDeco -> f u a -> f u z -> f u a-  elaborate  :: ZDeco -> f u a -> (a -> f u z) -> f u a-  obliterate :: f u a -> f u a-  hyperlink  :: XLink -> f u a -> f u a-+  decorate    :: ZDeco -> f u a -> f u z -> f u a+  elaborate   :: ZDeco -> f u a -> (a -> f u z) -> f u a+  obliterate  :: f u a -> f u a+  hyperlink   :: XLink -> f u a -> f u a+  svgId       :: String -> f u a -> f u a+  svgAnnotate :: [SvgAttr] -> f u a -> f u a  sdecorate :: Decorate f => f u a -> f u z -> f u a sdecorate = decorate SUPERIOR

@@ -38,6 +38,8 @@    , bbrectangle +  , boundedRect+   ) where  import Wumpus.Basic.Kernel.Base.BaseDefs@@ -61,6 +63,8 @@ type BoundedLocThetaGraphic u   = LocThetaImage u (BoundingBox u)  ++ -- | 'centerOrthoBBox' : @ theta * bbox -> BBox @ --  -- Rotate a bounding box by @theta@ about its center. Take the @@ -87,7 +91,7 @@ -- the minimum bounding box with both the bottom-left and  -- upper-right corners at the implicit start point. ---emptyBoundedLocGraphic :: InterpretUnit u => LocImage u (BoundingBox u)+emptyBoundedLocGraphic :: InterpretUnit u => BoundedLocGraphic u  emptyBoundedLocGraphic = promoteLoc $ \pt ->      replaceAns (BBox pt pt) $ primGraphic mempty @@ -102,7 +106,7 @@ -- bottom-left and upper-right corners at the implicit start point  -- emptyBoundedLocThetaGraphic :: InterpretUnit u -                            => LocThetaImage u (BoundingBox u)+                            => BoundedLocThetaGraphic u emptyBoundedLocThetaGraphic = promoteLocTheta $ \pt _ ->      replaceAns (BBox pt pt) $ primGraphic mempty @@ -155,7 +159,9 @@   -+-- | Draw a bounding box as a stroked rectangle with +-- dotted lines.+-- bbrectangle :: InterpretUnit u => BoundingBox u -> Graphic u bbrectangle (BBox p1@(P2 llx lly) p2@(P2 urx ury))     | llx == urx && lly == ury = mempty `at` p1@@ -163,7 +169,25 @@         localize drawing_props $ rect1 `mappend` cross   where     drawing_props = cap_round . dotted_line-    rect1         = dcRectangle STROKE (urx-llx) (ury-lly) `at` p1+    rect1         = dcRectangle DRAW_STROKE (urx-llx) (ury-lly) `at` p1     cross         = straightLine p1 p2                        `mappend` straightLine (P2 llx ury) (P2 urx lly) +++-- | 'boundedRect' : @ style * width * height -> LocGraphic @+--+-- Create a stroked rectangle - the implicit start point is +-- /bottom-left/, return the bounding box of the rectangle as the +-- answer.+-- +-- The line properties (colour, pen thickness, etc.) are taken +-- from the implicit 'DrawingContext'.+-- +boundedRect :: InterpretUnit u +            => DrawMode -> u -> u -> BoundedLocGraphic u +boundedRect style w h = promoteLoc $ \pt@(P2 x y) -> +    let bb = BBox pt (P2 (x + w) (y + h))+    in replaceAns bb $ applyLoc (dcRectangle style w h) pt++ 

@@ -158,44 +158,51 @@   instance Decorate ConnectorImage where-  decorate zo ma mz = ConnectorImage $ \p0 p1 -> +  decorate zo ma mz     = ConnectorImage $ \p0 p1 ->      decorate zo (getConnectorImage ma p0 p1) (getConnectorImage mz p0 p1) -  elaborate zo ma f = ConnectorImage $ \p0 p1 -> +  elaborate zo ma f     = ConnectorImage $ \p0 p1 ->      elaborate zo (getConnectorImage ma p0 p1)                   (\a -> getConnectorImage (f a) p0 p1) -  obliterate ma = ConnectorImage $ \p0 p1 -> +  obliterate ma         = ConnectorImage $ \p0 p1 ->      obliterate $ getConnectorImage ma p0 p1 -  hyperlink xl ma = ConnectorImage $ \p0 p1 -> +  hyperlink xl ma       = ConnectorImage $ \p0 p1 ->      hyperlink xl $ getConnectorImage ma p0 p1 +  svgId ss ma           = ConnectorImage $ \p0 p1 -> +    svgId ss $ getConnectorImage ma p0 p1 +  svgAnnotate attrs ma  = ConnectorImage $ \p0 p1 -> +    svgAnnotate attrs $ getConnectorImage ma p0 p1 +++ runConnectorImage :: InterpretUnit u -                  => ConnectorImage u a -> DrawingContext -                  -> Point2 u -> Point2 u+                  => DrawingContext -> Point2 u -> Point2 u+                  -> ConnectorImage u a                   -> PrimResult u a-runConnectorImage ma ctx p0 p1 = +runConnectorImage ctx p0 p1 ma =      let dp0 = normalizeF (dc_font_size ctx) p0         dp1 = normalizeF (dc_font_size ctx) p1 -    in runImage (getConnectorImage ma dp0 dp1) ctx+    in runImage ctx $ getConnectorImage ma dp0 dp1   runConnectorQuery :: InterpretUnit u -                  => ConnectorQuery u a -> DrawingContext -                  -> Point2 u -> Point2 u +                  => DrawingContext -> Point2 u -> Point2 u +                  -> ConnectorQuery u a                   -> a-runConnectorQuery ma ctx p0 p1 = +runConnectorQuery ctx p0 p1 ma =      let dp0 = normalizeF (dc_font_size ctx) p0         dp1 = normalizeF (dc_font_size ctx) p1 -    in runQuery (getConnectorQuery ma dp0 dp1) ctx+    in runQuery ctx $ getConnectorQuery ma dp0 dp1   connect :: InterpretUnit u -        => Point2 u -> Point2 u -> ConnectorImage u a -> Image u a-connect p0 p1 ma = normalizeCtxF p0 >>= \dp0 -> +        => ConnectorImage u a -> Point2 u -> Point2 u -> Image u a+connect ma p0 p1 = normalizeCtxF p0 >>= \dp0 ->                     normalizeCtxF p1 >>= \dp1 ->                     getConnectorImage ma dp0 dp1 

@@ -32,7 +32,7 @@   , dispDirectionTheta   , dispCardinalTheta -  -- * Named vectors+  -- * Named vector constructors    , go_up   , go_down@@ -53,7 +53,25 @@   , go_down_left   , go_down_right +  , theta_up+  , theta_down+  , theta_left+  , theta_right +  , theta_north+  , theta_south+  , theta_east+  , theta_west+  , theta_north_east+  , theta_north_west+  , theta_south_east+  , theta_south_west++  , theta_up_left+  , theta_up_right+  , theta_down_left+  , theta_down_right+   ) where  @@ -234,6 +252,70 @@  go_down_right :: Num u => u -> Vec2 u go_down_right d = V2 d (-d)+++--------------------------------------------------------------------------------++++theta_up :: Floating u => u -> Radian -> Vec2 u+theta_up d ang = avec (ang + half_pi) d++theta_down :: Floating u => u -> Radian -> Vec2 u+theta_down d ang = avec (ang - half_pi) d+++-- | Parallel (reverse)+--+theta_left :: Floating u => u -> Radian -> Vec2 u+theta_left d ang = avec (ang + pi) d++-- | Parallel (forward)+--+theta_right :: Floating u => u -> Radian -> Vec2 u+theta_right d ang = avec ang d++++theta_north :: Floating u => u -> Radian -> Vec2 u+theta_north = theta_up++theta_south :: Floating u => u -> Radian -> Vec2 u+theta_south = theta_down++theta_east :: Floating u => u -> Radian -> Vec2 u+theta_east = theta_right++theta_west :: Floating u => u -> Radian -> Vec2 u+theta_west = theta_left+++theta_north_east :: Floating u => u -> Radian -> Vec2 u+theta_north_east d ang = avec (ang + quarter_pi) d++theta_north_west :: Floating u => u -> Radian -> Vec2 u+theta_north_west d ang = avec (ang + 0.75*pi) d++theta_south_east :: Floating u => u -> Radian -> Vec2 u+theta_south_east d ang = avec (ang - quarter_pi) d++theta_south_west :: Floating u => u -> Radian -> Vec2 u+theta_south_west d ang = avec (ang + 1.25*pi) d++++theta_up_left :: Floating u => u -> Radian -> Vec2 u+theta_up_left d = orthoVec (-d) d++theta_up_right :: Floating u => u -> Radian -> Vec2 u+theta_up_right d = orthoVec d d++theta_down_left :: Floating u => u -> Radian -> Vec2 u+theta_down_left d = orthoVec (-d) (-d)++theta_down_right :: Floating u => u -> Radian -> Vec2 u+theta_down_right d = orthoVec d (-d)+   --------------------------------------------------------------------------------

@@ -10,10 +10,11 @@ -- Stability   :  highly unstable -- Portability :  GHC  ----- Graphic type - this is largely equivalent to Primitive in--- Wumpus-Core, but drawing attributes are implicitly supplied --- by the DrawingContext.+-- Primitive drawings - text, paths, lines, rectangles, disks, +-- ellipses... --+-- All the primitives take their drawing properties (colour, line +-- width, etc.) from the DrawingContext. -- -------------------------------------------------------------------------------- @@ -28,6 +29,8 @@   , vertexPP   , curvePP ++  , dcPath   , dcOpenPath   , dcClosedPath @@ -204,7 +207,14 @@ -- Drawing paths (stroke, fill, fillStroke)... -- +dcPath :: PathMode -> PrimPath -> Graphic u+dcPath OSTROKE      = dcOpenPath+dcPath CSTROKE      = dcClosedPath DRAW_STROKE+dcPath CFILL        = dcClosedPath DRAW_FILL+dcPath CFILL_STROKE = dcClosedPath DRAW_FILL_STROKE ++ -- | 'dcOpenPath' : @ path -> Graphic @ -- -- This is the analogue to the 'ostroke' function in @@ -224,12 +234,12 @@ -- Drawing properties (colour, line width, etc.) for the  -- respective style are taken from the implicit 'DrawingContext'. ---dcClosedPath :: DrawStyle -> PrimPath -> Graphic u-dcClosedPath FILL        pp = fillPrim (\rgb -> fill rgb pp)+dcClosedPath :: DrawMode -> PrimPath -> Graphic u+dcClosedPath DRAW_FILL        pp = fillPrim (\rgb -> fill rgb pp) -dcClosedPath STROKE      pp = strokePrim (\rgb attr -> cstroke rgb attr pp)+dcClosedPath DRAW_STROKE      pp = strokePrim (\rgb attr -> cstroke rgb attr pp) -dcClosedPath FILL_STROKE pp = +dcClosedPath DRAW_FILL_STROKE pp =      fillStrokePrim (\frgb attr srgb -> fillStroke frgb attr srgb pp)  @@ -437,7 +447,7 @@ -- The respective line or fill properties for the 'DrawStyle' are  -- taken from the implicit 'DrawingContext'. -- -dcCircle :: InterpretUnit u => DrawStyle -> u -> LocGraphic u+dcCircle :: InterpretUnit u => DrawMode -> u -> LocGraphic u dcCircle style r = promoteLoc $ \pt ->      liftQuery (qapplyLoc (circlePath r) pt) >>= dcClosedPath style @@ -473,7 +483,7 @@ -- The line properties (colour, pen thickness, etc.) are taken  -- from the implicit 'DrawingContext'. -- -dcEllipse :: InterpretUnit u => DrawStyle -> u -> u -> LocGraphic u+dcEllipse :: InterpretUnit u => DrawMode -> u -> u -> LocGraphic u dcEllipse style rx ry = promoteLoc $ \pt ->    liftQuery (qapplyLoc (ellipsePath rx ry) pt) >>= dcClosedPath style  @@ -488,7 +498,7 @@ -- are taken from the implicit 'DrawingContext'. --  dcREllipse :: InterpretUnit u-           => DrawStyle -> u -> u -> LocThetaGraphic u+           => DrawMode -> u -> u -> LocThetaGraphic u dcREllipse style rx ry = promoteLocTheta $ \pt ang ->      liftQuery (qapplyLocTheta (rellipsePath rx ry) pt ang) >>=      dcClosedPath style@@ -507,7 +517,7 @@   --- | 'strokedRectangle' : @ width * height -> LocGraphic @+-- | 'strokedRectangle' : @ style * width * height -> LocGraphic @ -- -- Create a stroked rectangle 'LocGraphic' - the implicit point is  -- bottom-left. @@ -515,7 +525,7 @@ -- The line properties (colour, pen thickness, etc.) are taken  -- from the implicit 'DrawingContext'. -- -dcRectangle :: InterpretUnit u => DrawStyle -> u -> u -> LocGraphic u+dcRectangle :: InterpretUnit u => DrawMode -> u -> u -> LocGraphic u dcRectangle style w h = promoteLoc $ \pt ->      liftQuery (qapplyLoc (rectanglePath w h) pt) >>= dcClosedPath style @@ -539,16 +549,16 @@ -- The fill or stroke properties for the respective DrawStyle are -- taken from the implicit 'DrawingContext'. -- -dcDisk :: InterpretUnit u => DrawStyle -> u -> LocGraphic u-dcDisk FILL radius = +dcDisk :: InterpretUnit u => DrawMode -> u -> LocGraphic u+dcDisk DRAW_FILL radius =      normalizeCtx radius >>= \r ->      fillLoc (\rgb pt -> fillEllipse rgb r r pt) -dcDisk STROKE radius = +dcDisk DRAW_STROKE radius =      normalizeCtx radius >>= \r ->      strokeLoc (\rgb attr pt -> strokeEllipse rgb attr r r pt) -dcDisk FILL_STROKE radius = +dcDisk DRAW_FILL_STROKE radius =      normalizeCtx radius >>= \r ->      fillStrokeLoc (\frgb attr srgb pt -> fillStrokeEllipse frgb attr srgb r r pt) @@ -572,14 +582,16 @@ -- The line properties (colour, pen thickness, etc.) are taken  -- from the implicit 'DrawingContext'. -- -dcEllipseDisk :: InterpretUnit u => DrawStyle -> u -> u -> LocGraphic u+dcEllipseDisk :: InterpretUnit u +              => DrawMode -> u -> u -> LocGraphic u dcEllipseDisk style rx ry =      normalizeCtx rx >>= \drx ->      normalizeCtx ry >>= \dry ->      case style of-      FILL -> fillLoc (\rgb pt -> fillEllipse rgb drx dry pt)-      STROKE -> strokeLoc (\rgb attr pt -> strokeEllipse rgb attr drx dry pt)-      FILL_STROKE -> fillStrokeLoc $ +      DRAW_FILL -> fillLoc (\rgb pt -> fillEllipse rgb drx dry pt)+      DRAW_STROKE -> strokeLoc +                       (\rgb attr pt -> strokeEllipse rgb attr drx dry pt)+      DRAW_FILL_STROKE -> fillStrokeLoc $                         (\frgb attr srgb pt ->                             fillStrokeEllipse frgb attr srgb drx dry pt) 

@@ -142,11 +142,11 @@   localize upd ma = Query $ \ctx -> getQuery ma (upd ctx)  -runImage :: Image u a -> DrawingContext -> PrimResult u a-runImage = getImage+runImage :: DrawingContext -> Image u a -> PrimResult u a+runImage ctx ma = getImage ma ctx -runQuery :: Query u a -> DrawingContext -> a-runQuery = getQuery+runQuery :: DrawingContext -> Query u a -> a+runQuery ctx ma = getQuery ma ctx   @@ -159,7 +159,7 @@ -- | Turn a 'Query' into an 'Image' without graphic content. -- liftQuery :: Query u a -> Image u a-liftQuery ma = askDC >>= \ctx -> let a = runQuery ma ctx in return a+liftQuery ma = askDC >>= \ctx -> let a = runQuery ctx ma in return a   @@ -173,7 +173,7 @@ --  clipImage :: PrimPath -> Image u a -> Image u a clipImage pp ma = Image $ \ctx -> -     let (a,w) = getImage ma ctx in (a, cpmap (clip pp) w)+     let (a,w) = getImage ma ctx in (a, cpmap (clipPrim pp) w)   @@ -203,12 +203,12 @@   instance Decorate Image where-  decorate    = decorateImage-  elaborate   = elaborateImage  -  obliterate  = obliterateImage-  hyperlink   = hyperlinkImage-  -+  decorate      = decorateImage+  elaborate     = elaborateImage  +  obliterate    = obliterateImage+  hyperlink     = hyperlinkImage+  svgId         = svgIdImage  +  svgAnnotate   = svgAnnotateImage   -- | Decorate Image. --@@ -239,6 +239,16 @@ hyperlinkImage xl ma = Image $ \ctx -> step (getImage ma ctx)   where     step (a,w) = (a, cpmap (xlinkPrim xl) w)++svgIdImage :: String -> Image u a -> Image u a+svgIdImage ss ma = Image $ \ctx -> step (getImage ma ctx)+  where+    step (a,w) = (a, cpmap (xidPrim ss) w)++svgAnnotateImage :: [SvgAttr] -> Image u a -> Image u a+svgAnnotateImage attrs ma = Image $ \ctx -> step (getImage ma ctx)+  where+    step (a,w) = (a, cpmap (annotateGroup attrs) w)   --------------------------------------------------------------------------------

@@ -35,6 +35,7 @@     , promoteLoc    , applyLoc+   , supplyLoc    , qpromoteLoc    , qapplyLoc @@ -170,18 +171,22 @@    hyperlink xl ma = LocImage $ \pt -> hyperlink xl $ getLocImage ma pt  +  svgId ss ma = LocImage $ \pt -> svgId ss $ getLocImage ma pt  +  svgAnnotate attrs ma = LocImage $ \pt -> svgAnnotate attrs $ getLocImage ma pt++ runLocImage :: InterpretUnit u -            => LocImage u a -> DrawingContext -> Point2 u -> PrimResult u a-runLocImage ma ctx pt = +            => DrawingContext -> Point2 u -> LocImage u a -> PrimResult u a+runLocImage ctx pt ma =      let dpt = normalizeF (dc_font_size ctx) pt -    in runImage (getLocImage ma dpt) ctx+    in runImage ctx $ getLocImage ma dpt  runLocQuery :: InterpretUnit u -            => LocQuery u a -> DrawingContext -> Point2 u -> a-runLocQuery ma ctx pt = +            => DrawingContext -> Point2 u -> LocQuery u a -> a+runLocQuery ctx pt ma =      let dpt = normalizeF (dc_font_size ctx) pt -    in runQuery (getLocQuery ma dpt) ctx+    in runQuery ctx $ getLocQuery ma dpt   stripLocImage :: LocImage u a -> LocQuery u a@@ -201,6 +206,12 @@ applyLoc ma pt = normalizeCtxF pt >>= getLocImage ma  +-- | Flipped version of 'applyLoc'. +-- +supplyLoc :: InterpretUnit u => Point2 u -> LocImage u a -> Image u a+supplyLoc = flip at++ qpromoteLoc :: InterpretUnit u              => (Point2 u -> Query u a) -> LocQuery u a qpromoteLoc k = LocQuery $ \pt -> dinterpCtxF pt >>= k@@ -285,12 +296,14 @@  infixr 1 `at` - -- | Downcast a 'LocImage' function by applying it to the supplied  -- point, making an 'Image'.  -- +-- > infixr 1 `at`+--  at :: InterpretUnit u => LocImage u a -> Point2 u -> Image u a-at mf pt = normalizeCtxF pt >>= \dpt -> getLocImage mf dpt+at = applyLoc+   --------------------------------------------------------------------------------

@@ -35,6 +35,7 @@        , promoteLocTheta    , applyLocTheta+   , supplyLocTheta    , qpromoteLocTheta    , qapplyLocTheta @@ -42,6 +43,7 @@     , incline    , atIncline+   , supplyIncline        ) @@ -155,38 +157,44 @@ --  instance Decorate LocThetaImage where-  decorate zo ma mz = LocThetaImage $ \pt ang -> +  decorate zo ma mz     = LocThetaImage $ \pt ang ->      decorate zo (getLocThetaImage ma pt ang) (getLocThetaImage mz pt ang) -  elaborate zo ma f = LocThetaImage $ \pt ang -> +  elaborate zo ma f     = LocThetaImage $ \pt ang ->      elaborate zo (getLocThetaImage ma pt ang)                   (\a -> getLocThetaImage (f a) pt ang) -  obliterate ma = LocThetaImage $ \pt ang -> +  obliterate ma         = LocThetaImage $ \pt ang ->      obliterate $ getLocThetaImage ma pt ang -  hyperlink xl ma = LocThetaImage $ \pt ang -> +  hyperlink xl ma       = LocThetaImage $ \pt ang ->      hyperlink xl $ getLocThetaImage ma pt ang++  svgId ss ma           = LocThetaImage $ \pt ang -> +    svgId ss $ getLocThetaImage ma pt ang++  svgAnnotate attrs ma  = LocThetaImage $ \pt ang -> +    svgAnnotate attrs $ getLocThetaImage ma pt ang                runLocThetaImage :: InterpretUnit u -                 => LocThetaImage u a -> DrawingContext -                 -> Point2 u -> Radian+                 => DrawingContext -> Point2 u -> Radian+                 -> LocThetaImage u a                   -> PrimResult u a-runLocThetaImage ma ctx pt incl = +runLocThetaImage ctx pt incl ma =      let dpt = normalizeF (dc_font_size ctx) pt -    in runImage (getLocThetaImage ma dpt incl) ctx+    in runImage ctx $ getLocThetaImage ma dpt incl   runLocThetaQuery :: InterpretUnit u -                 => LocThetaQuery u a -> DrawingContext -                 -> Point2 u -> Radian  +                 => DrawingContext -> Point2 u -> Radian  +                 -> LocThetaQuery u a                   -> a-runLocThetaQuery ma ctx pt incl = +runLocThetaQuery ctx pt incl ma =      let dpt = normalizeF (dc_font_size ctx) pt -    in runQuery (getLocThetaQuery ma dpt incl) ctx+    in runQuery ctx $ getLocThetaQuery ma dpt incl   @@ -209,10 +217,14 @@  applyLocTheta :: InterpretUnit u                => LocThetaImage u a -> Point2 u -> Radian -> Image u a-applyLocTheta mq pt ang = -    normalizeCtxF pt >>= \dpt -> getLocThetaImage mq dpt ang+applyLocTheta ma pt ang = +    normalizeCtxF pt >>= \dpt -> getLocThetaImage ma dpt ang +supplyLocTheta :: InterpretUnit u +               => Point2 u -> Radian -> LocThetaImage u a -> Image u a+supplyLocTheta pt ang ma = applyLocTheta ma pt ang + qpromoteLocTheta :: InterpretUnit u                   => (Point2 u -> Radian -> Query u a) -> LocThetaQuery u a qpromoteLocTheta k = LocThetaQuery $ \pt ang ->@@ -273,5 +285,10 @@  atIncline :: InterpretUnit u            => LocThetaImage u a -> Point2 u -> Radian -> Image u a-atIncline ma pt incl = -    normalizeCtxF pt >>= \dpt -> getLocThetaImage ma dpt incl+atIncline = applyLocTheta+++-- | Flipped version of 'incline'+--+supplyIncline :: InterpretUnit u => Radian -> LocThetaImage u a -> LocImage u a+supplyIncline = flip incline

@@ -1,599 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Kernel.Objects.PosObject--- Copyright   :  (c) Stephen Tetley 2011--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  highly unstable--- Portability :  GHC ------ Extended Graphic object - a rectangular /positionable/ Image.--- --- This graphic object has a more flexible API for positioning --- than other graphic objects. Rather than a LocGraphic which --- supports a single method of positioning at some start-point,--- a @PosGraphic@ can be drawn at its center or locations on its --- outer rectangle.--------------------------------------------------------------------------------------module Wumpus.Basic.Kernel.Objects.PosObject-  (--  -- * Positionable image--    PosObject-  , DPosObject--  , PosGraphic-  , DPosGraphic--  -- * Operations-  , runPosObject-  , runPosObjectBBox--  , makePosObject-  , emptyPosObject--  , elaboratePosObject-  , decoratePosObject--  , extendPosObject-  , mapOrientation--  , illustratePosObject--  , posChar-  , posEscChar -  , posCharUpright-  , posEscCharUpright-  -  , posCharPrim--  , posText-  , posEscText -  , posTextUpright-  , posEscTextUpright--  , posTextPrim--  , multilinePosText-  , multilinePosEscText--  , rposText-  , rposEscText--  , posHKernText--  , monospaceText-  , monospaceEscText--  ) where---import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.DrawingContext-import Wumpus.Basic.Kernel.Base.QueryDC-import Wumpus.Basic.Kernel.Base.UpdateDC-import Wumpus.Basic.Kernel.Base.WrappedPrimitive-import Wumpus.Basic.Kernel.Objects.Basis-import Wumpus.Basic.Kernel.Objects.Concat-import Wumpus.Basic.Kernel.Objects.DrawingPrimitives-import Wumpus.Basic.Kernel.Objects.Image-import Wumpus.Basic.Kernel.Objects.LocImage-import Wumpus.Basic.Kernel.Objects.LocThetaImage-import Wumpus.Basic.Kernel.Objects.Orientation--import Wumpus.Core                              -- package: wumpus-core-import Wumpus.Core.Colour ( red, blue )--import Data.AffineSpace                         -- package: vector-space-import Data.VectorSpace--import Control.Applicative-import Data.Monoid--type DOrt = Orientation Double---- | A positionable \"Object\".----newtype PosObject u a = PosObject -          { getPosObject :: DrawingContext -> DPoint2 -> (a, DOrt, CatPrim) }--type instance DUnit (PosObject u a) = u-    --- | Version of PosObject specialized to Double for the unit type.----type DPosObject a = PosObject Double a----- | Version of PosObject with answer specialized to UNil.----type PosGraphic u = PosObject u (UNil u)---- | Version of PosGraphic specialized to Double for the unit type.----type DPosGraphic = PosGraphic Double-----instance Functor (PosObject u) where-  fmap f mf = PosObject $ \ctx pt -> -              let (a,o1,w1) = getPosObject mf ctx pt in (f a,o1,w1)---instance Applicative (PosObject u) where-  pure a    = PosObject $ \_   _  -> (a,mempty,mempty)-  mf <*> ma = PosObject $ \ctx pt -> -              let (f,o1,w1) = getPosObject mf ctx pt-                  (a,o2,w2) = getPosObject ma ctx pt-              in (f a, o1 `mappend` o2, w1 `mappend` w2)----instance Monad (PosObject u) where-  return a  = PosObject $ \_   _  -> (a,mempty,mempty)-  mf >>= k  = PosObject $ \ctx pt -> -              let (a,o1,w1) = getPosObject mf ctx pt-                  (b,o2,w2) = getPosObject (k a) ctx pt-              in (b, o1 `mappend` o2, w1 `mappend` w2)----instance DrawingCtxM (PosObject u) where-  askDC           = PosObject $ \ctx _ -> (ctx, mempty, mempty)-  asksDC fn       = PosObject $ \ctx _ -> (fn ctx, mempty, mempty)-  localize upd ma = PosObject $ \ctx pt -> getPosObject ma (upd ctx) pt-----instance (Monoid a, InterpretUnit u) => Monoid (PosObject u a) where-  mempty = PosObject $ \_ _ -> (mempty, mempty, mempty)-  ma `mappend` mb = PosObject $ \ctx pt -> -                    let (a,o1,w1) = getPosObject ma ctx pt-                        (b,o2,w2) = getPosObject mb ctx pt-                    in (a `mappend` b, o1 `mappend` o2, w1 `mappend` w2)------ | Running an PosObject produces a LocImage.----runPosObject :: InterpretUnit u -             => PosObject u a -> RectAddress -> LocImage u a-runPosObject ma addr = promoteLoc $ \ot -> -    askDC >>= \ctx -> -    let dot       = normalizeF (dc_font_size ctx) ot-        (a,o1,ca) = getPosObject ma ctx dot-        v1        = vtoOrigin addr o1-    in replaceAns a $ primGraphic $ cpmove v1 ca------ | Run a PosObject producing a LocImage (BoundingBox u).----runPosObjectBBox :: InterpretUnit u -                 => PosObject u a -> RectAddress -> LocImage u (BoundingBox u)-runPosObjectBBox ma addr = promoteLoc $ \pt -> -    askDC >>= \ctx -> -    let sz        = dc_font_size ctx -        dpt       = normalizeF sz pt-        (_,o1,w1) = getPosObject ma ctx dpt-        v1        = vtoOrigin addr o1-        bb        = dinterpF sz $ orientationBounds o1 (dpt .+^ v1)-    in replaceAns bb $ primGraphic $ cpmove v1 w1------------------------------------------------------------------------------------------ | 'makePosObject' : @ object_pos * loc_image -> PosObject @ ------ Create a 'PosObject' from an 'Orientation' describing how it--- is orientated within a border rectangle and a 'LocImage' that --- draws it.------ This is the /primary/ constructor for PosObjects. Because the--- PosObject type is considered as a specialized object it does--- not have the range of functions of LocImage or LocThetaImage.--- -makePosObject :: InterpretUnit u-              => Query u (Orientation u) -> LocImage u a -> PosObject u a-makePosObject ma gf = PosObject $ \ctx pt -> -    let ort1  = runQuery ma ctx-        dort1 = normalizeF (dc_font_size ctx) ort1-        upt   = dinterpF (dc_font_size ctx) pt-        (a,w) = runLocImage gf ctx upt-    in (a,dort1,w)----- | 'emptyPosObject' : @ PosObject @------ Build an empty 'PosGraphicObject'.----emptyPosObject :: (Monoid a, InterpretUnit u) => PosObject u a-emptyPosObject = PosObject $ \_ _ -> (mempty, mempty, mempty) --    ------- decorate  - oblivious to /answer/.--- elaborate - derives annotation from the /answer/ and makes a ---             cumulative graphic.------elaboratePosObject :: (Fractional u, Ord u, InterpretUnit u)-                   => ZDeco -> RectAddress -> LocGraphic u -> PosObject u a-                   -> PosObject u a-elaboratePosObject zdec raddr gf ma = decoratePosObject zdec fn ma-  where-    fn ortt = moveStart (vtoRectAddress ortt raddr) gf----decoratePosObject :: InterpretUnit u -                  => ZDeco -> (Orientation u -> LocGraphic u) -> PosObject u a-                  -> PosObject u a-decoratePosObject zdec fn ma = PosObject $ \ctx pt -> -    let (a,o1,w1) = getPosObject ma ctx pt-        uortt     = dinterpF (dc_font_size ctx) o1-        upt       = dinterpF (dc_font_size ctx) pt-        (_,w2)    = runLocImage (fn uortt) ctx upt-        wout      = case zdec of-                         ANTERIOR -> w2 `mappend` w1-                         SUPERIOR -> w1  `mappend` w2-    in (a,o1,wout)------- | Extend the orientation.----extendPosObject :: InterpretUnit u -                => u -> u -> u -> u -> PosObject u a -> PosObject u a-extendPosObject x0 x1 y0 y1 ma = PosObject $ \ctx pt ->-    let (a,o1,w1) = getPosObject ma ctx pt-        sz        = dc_font_size ctx        -        ux0       = normalize sz x0-        ux1       = normalize sz x1-        uy0       = normalize sz y0-        uy1       = normalize sz y1-        o2        = extendOrientation ux0 ux1 uy0 uy1 o1-    in (a,o2,w1)----- | Note - this is a bad API, it would be better to have padders--- and fillers and not expose the orientation directly.--- -mapOrientation :: InterpretUnit u-               => (Orientation u -> Orientation u) -               -> PosObject u a -> PosObject u a-mapOrientation fn mf = PosObject $ \ctx pt -> -    let (a,o1,w1) = getPosObject mf ctx pt-        uort      = fn $ dinterpF (dc_font_size ctx) o1-        o2        = normalizeF (dc_font_size ctx) uort-    in (a,o2,w1)---------------------------------------------------------------------------------------- | Illustrate a 'PosObject' by super-imposing its 'Orientation'.------ This turns the 'PosObject' into a 'LocImage' drawn at the locus--- of the PosObject.----illustratePosObject :: InterpretUnit u -                   => PosObject u a -> LocGraphic u-illustratePosObject mf  = promoteLoc $ \pt ->   -    askDC >>= \ctx ->-    let dpt       = normalizeF (dc_font_size ctx) pt -        (_,o1,w1) = getPosObject mf ctx dpt-        uort      = dinterpF (dc_font_size ctx) o1-    in adecorate (primGraphic w1) (illustrateOrientation uort `at` pt)---illustrateOrientation :: InterpretUnit u -                      => Orientation u -> LocGraphic u-illustrateOrientation (Orientation xmin xmaj ymin ymaj) = promoteLoc $ \pt -> -    dinterpCtx 3 >>= \radius -> -    let upd = localize (fill_colour blue . dotted_line)-        bl  = pt .-^ V2 xmin ymin-        dot = localize (fill_colour red) $ dcDisk FILL radius `at` pt-        hln = upd $ locStraightLine (hvec $ xmin+xmaj) `at` pt .-^ hvec xmin-        vln = upd $ locStraightLine (vvec $ ymin+ymaj) `at` pt .-^ vvec ymin-        bdr = upd $ dcRectangle STROKE (xmin+xmaj) (ymin+ymaj) `at` bl-    in mconcat [ bdr, hln, vln, dot ]--------------------------------------------------------------------------------------- Char PosObjects----- Note - because the TextHeight constructors are so long winded,--- using them directly makes for a bad API. Instead we have two --- versions for each function.---- | Note - no margins are added to the containing rectangle.--- --- To get a Char with margins, use 'posText' instead:------ > posText ['1']--- -posChar             :: InterpretUnit u => Char -> PosGraphic u-posChar             = makeCharPO CAP_HEIGHT_PLUS_DESCENDER . CharLiteral--posEscChar          :: InterpretUnit u => EscapedChar -> PosGraphic u-posEscChar          = makeCharPO CAP_HEIGHT_PLUS_DESCENDER--posCharUpright      :: InterpretUnit u => Char -> PosGraphic u-posCharUpright      = makeCharPO JUST_CAP_HEIGHT . CharLiteral--posEscCharUpright   :: InterpretUnit u => EscapedChar -> PosGraphic u-posEscCharUpright   = makeCharPO JUST_CAP_HEIGHT----- | Primtive builder that does not add margins.----posCharPrim         :: InterpretUnit u -                    => Either Char EscapedChar -> PosGraphic u-posCharPrim = makeCharPO CAP_HEIGHT_PLUS_DESCENDER . either CharLiteral id---makeCharPO :: InterpretUnit u -           => TextHeight -> EscapedChar -> PosGraphic u-makeCharPO hspec esc = -    makePosObject (charOrientation hspec esc) -                  (dcEscapedlabel $ wrapEscChar esc)------- | Build the Orientation of an EscapedChar.--- --- The locus of the Orientation is baseline left - margins are --- added.----charOrientation :: (DrawingCtxM m, InterpretUnit u)-                => TextHeight -> EscapedChar -> m (Orientation u)-charOrientation hspec esc = -    (\(V2 x _ ) (ymin,ymaj) -> Orientation 0 x ymin ymaj) -      <$> escCharVector esc <*> heightSpan hspec-------------------------------------------------------------------------------------- Text PosObjects----posText     :: InterpretUnit u => String -> PosGraphic u-posText     = addMargins . makeTextPO CAP_HEIGHT_PLUS_DESCENDER . escapeString--posEscText  :: InterpretUnit u => EscapedText -> PosGraphic u-posEscText  = addMargins . makeTextPO CAP_HEIGHT_PLUS_DESCENDER---posTextUpright      :: InterpretUnit u => String -> PosGraphic u-posTextUpright      = addMargins . makeTextPO JUST_CAP_HEIGHT . escapeString--posEscTextUpright   :: InterpretUnit u => EscapedText -> PosGraphic u-posEscTextUpright   = addMargins . makeTextPO JUST_CAP_HEIGHT---- | Primtive builder that does not add margins.----posTextPrim         :: InterpretUnit u -                    => Either String EscapedText -> PosGraphic u-posTextPrim = makeTextPO CAP_HEIGHT_PLUS_DESCENDER . either escapeString id---multilinePosText :: (Fractional u, InterpretUnit u)-                 => VAlign -> String -> PosGraphic u-multilinePosText vspec xs = -    multilinePosEscText vspec $ map escapeString $ lines xs--multilinePosEscText :: (Fractional u, InterpretUnit u)-                    => VAlign -> [EscapedText] -> PosGraphic u-multilinePosEscText vspec xs = -    addMargins $ PosObject $ \ctx pt -> -      let sep    = runQuery textlineSpace ctx-      in getPosObject (body sep) ctx pt-  where-    body sp = alignColumnSep vspec sp $ -                map (makeTextPO CAP_HEIGHT_PLUS_DESCENDER) xs------ | Note - this does not add margins.----makeTextPO :: InterpretUnit u -           => TextHeight -> EscapedText -> PosGraphic u-makeTextPO hspec esc = -    makePosObject (textOrientationZero hspec esc) (dcEscapedlabel esc)---addMargins :: InterpretUnit u => PosObject u a -> PosObject u a-addMargins ma = -   textMargin >>= \(xsep,ysep) -> extendPosObject xsep xsep ysep ysep ma---- | Build the Orientation of a single line of EscapedText - --- writing direction zero (left-to-right).--- --- The locus of the Orientation is baseline left - margins are --- added.----textOrientationZero :: (DrawingCtxM m, InterpretUnit u )-                    => TextHeight -> EscapedText -> m (Orientation u)-textOrientationZero hspec esc = -    (\(V2 x _ ) (ymin,ymaj) -> Orientation 0 x ymin ymaj) -      <$> escTextVector esc <*> heightSpan hspec-------------------------------------------------------------------------------------- Rotated text---- | Note - for single line text.----rposText        :: (Real u, Floating u, InterpretUnit u) -                => Radian -> String -> PosGraphic u-rposText ang    = addMargins . makeRotatedPO ang . escapeString---- | Note - for single line text.----rposEscText     :: (Real u, Floating u, InterpretUnit u) -                => Radian -> EscapedText -> PosGraphic u-rposEscText ang = addMargins . makeRotatedPO ang---makeRotatedPO :: (Real u, Floating u, InterpretUnit u) -              => Radian -> EscapedText -> PosGraphic u-makeRotatedPO ang esc = makePosObject qry body-  where-    qry  = rotateOrientation ang <$> -             textOrientationZero CAP_HEIGHT_PLUS_DESCENDER esc--    body = incline (dcREscapedlabel esc) ang-------------------------------------------------------------------------------------- Kerned text---posHKernText :: InterpretUnit u-            => [KernChar u] -> PosGraphic u-posHKernText xs = makePosObject (hkernOrientationZero xs) (hkernLine xs)---- | The query should retrieve the width of one char.----monospaceText :: InterpretUnit u -              => Query u u -> String -> PosGraphic u-monospaceText qry = monospaceEscText qry . escapeString----- | The query should retrieve the width of one char.----monospaceEscText :: InterpretUnit u -                 => Query u u -> EscapedText -> PosGraphic u-monospaceEscText qry esc = PosObject $ \ctx pt ->-    let upt    = dinterpF (dc_font_size ctx) pt-        uw     = runQuery qry ctx-        ks     = monos uw $ destrEscapedText id esc-        ortt   = runQuery (hkernOrientationZero  ks) ctx-        dort   = normalizeF (dc_font_size ctx) ortt-        (_,w1) = runLocImage (hkernLine ks) ctx upt-    in (UNil, dort, w1)------monos :: Num u => u -> [EscapedChar] -> [KernChar u]-monos w1 (c:cs) = (0,c) : map (\ch -> (w1,ch)) cs-monos _  []     = []------ | Note - always CAP_HEIGHT_PLUS_DESCENDER for this one.----hkernOrientationZero :: (DrawingCtxM m, InterpretUnit u )-                     => [KernChar u] -> m (Orientation u)-hkernOrientationZero xs = -    (\(V2 x _ ) (ymin,ymaj) -> Orientation 0 x ymin ymaj) -      <$> hkernVector xs <*> heightSpan CAP_HEIGHT_PLUS_DESCENDER-- ------------------------------------------------------------------------------------- Combining PosObject---instance (Monoid a, InterpretUnit u) => ZConcat (PosObject u a) where-  superior = mappend-  anterior = flip mappend---instance Monoid a => Concat (PosObject u a) where-  hconcat = genMoveAlign spinemoveH spineRight-  vconcat = genMoveAlign spinemoveV spineBelow--instance (Monoid a, InterpretUnit u) => CatSpace (PosObject u a) where-  hspace = genMoveSepH spinemoveH spineRight-  vspace = genMoveSepV spinemoveV spineBelow----instance Monoid a => Align (PosObject u a) where-  halign HALIGN_TOP    = genMoveAlign binmoveHTop    halignTopO-  halign HALIGN_CENTER = genMoveAlign binmoveHCenter halignCenterO-  halign HALIGN_BASE   = genMoveAlign binmoveHBottom halignBottomO--  valign VALIGN_LEFT   = genMoveAlign binmoveVLeft   valignLeftO-  valign VALIGN_CENTER = genMoveAlign binmoveVCenter valignCenterO-  valign VALIGN_RIGHT  = genMoveAlign binmoveVRight  valignRightO----genMoveAlign :: Monoid a-             => (Orientation Double -> Orientation Double -> Vec2 Double) -             -> (Orientation Double -> Orientation Double -> Orientation Double) -             -> PosObject u a -> PosObject u a -> PosObject u a-genMoveAlign mkV mkO ma mb = PosObject $ \ctx pt -> -    let (a,o1,w1) = getPosObject ma ctx pt-        (b,o2,w2) = getPosObject mb ctx pt-        v1        = mkV o1 o2-        ortt      = mkO o1 o2-        w2'       = cpmove v1 w2 -    in (a `mappend` b, ortt, w1 `mappend` w2')-------------------------------------------------------------------------------------- Sep--instance (Monoid a, InterpretUnit u) => AlignSpace (PosObject u a) where-  halignSpace HALIGN_TOP    = genMoveSepH binmoveHTop    halignTopO-  halignSpace HALIGN_CENTER = genMoveSepH binmoveHCenter halignCenterO-  halignSpace HALIGN_BASE   = genMoveSepH binmoveHBottom halignBottomO--  valignSpace VALIGN_LEFT   = genMoveSepV binmoveVLeft   valignLeftO-  valignSpace VALIGN_CENTER = genMoveSepV binmoveVCenter valignCenterO-  valignSpace VALIGN_RIGHT  = genMoveSepV binmoveVRight  valignRightO---genMoveSepH :: (Monoid a, InterpretUnit u) -            => (Orientation Double -> Orientation Double -> Vec2 Double) -            -> (Orientation Double -> Orientation Double -> Orientation Double) -            -> u-            -> PosObject u a -> PosObject u a -> PosObject u a-genMoveSepH mkV mkO sep ma mb  = PosObject $ \ctx pt -> -    let (a,o1,w1) = getPosObject ma ctx pt-        (b,o2,w2) = getPosObject mb ctx pt-        dsep      = normalize (dc_font_size ctx) sep-        v1        = hvec dsep ^+^ mkV o1 o2-        ortt      = extendORight dsep $ mkO o1 o2-        w2'       = cpmove v1 w2-    in (a `mappend` b, ortt, w1 `mappend` w2')----genMoveSepV :: (Monoid a, InterpretUnit u)-            => (Orientation Double -> Orientation Double -> Vec2 Double) -            -> (Orientation Double -> Orientation Double -> Orientation Double) -            -> u-            -> PosObject u a -> PosObject u a -> PosObject u a-genMoveSepV mkV mkO sep ma mb = PosObject $ \ctx pt -> -    let (a,o1,w1) = getPosObject ma ctx pt-        (b,o2,w2) = getPosObject mb ctx pt-        dsep      = normalize (dc_font_size ctx) sep-        v1        = vvec (-dsep) ^+^ mkV o1 o2-        ortt      = extendODown dsep $ mkO o1 o2-        w2'       = cpmove v1 w2-    in (a `mappend` b, ortt, w1 `mappend` w2')-

@@ -0,0 +1,785 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Objects.Trial+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- /Trails/ - prototype paths. Less resource heavy than the Path+-- object in Wumpus-Drawing.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Objects.Trail+  (++    TrailSegment(..)+  , CatTrail+  , PlacedTrail++  , drawPlacedTrail+  , drawCatTrail++  , destrPlacedTrail+  , destrCatTrail++  , placeCatTrail+  +  , trailIterateLocus++  , placedTrailPoints++  , rectangleTrail+  , diamondTrail+  , polygonTrail+++  , catline+  , catcurve+  +  , trail_up+  , trail_down+  , trail_left+  , trail_right++  , trail_north+  , trail_south+  , trail_east+  , trail_west+  , trail_north_east+  , trail_north_west+  , trail_south_east+  , trail_south_west++  , trail_up_left+  , trail_up_right+  , trail_down_left+  , trail_down_right++  , orthoCatline++  , trail_theta_up+  , trail_theta_down+  , trail_theta_left+  , trail_theta_right++  , trail_theta_north+  , trail_theta_south+  , trail_theta_east+  , trail_theta_west+  , trail_theta_north_east+  , trail_theta_north_west+  , trail_theta_south_east+  , trail_theta_south_west++  , trail_theta_up_left+  , trail_theta_up_right+  , trail_theta_down_left+  , trail_theta_down_right+++ +  , semicircleCW+  , semicircleCCW++  , minorCircleSweepCW+  , minorCircleSweepCCW+  , circleSweepCW+  , circleSweepCCW+  , circularArcCW+  , circularArcCCW++  , sineWave+  , sineWave1+  , squareWave+  , sawtoothWave+  , squiggleWave+  , semicircleWave++  , tricurve+  , rectcurve+  , trapcurveCW+  , trapcurveCCW+  , bowcurve+  , wedgecurve+  , loopcurve++  ) where++import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Base.QueryDC+import Wumpus.Basic.Kernel.Objects.Displacement+import Wumpus.Basic.Kernel.Objects.DrawingPrimitives+import Wumpus.Basic.Kernel.Objects.Image+import Wumpus.Basic.Kernel.Objects.LocImage+import Wumpus.Basic.Utils.HList++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space+import Data.VectorSpace++import Data.List ( unfoldr )+import Data.Monoid++data PlacedTrail u = PlacedTrail+      { pt_init_vec :: Vec2 u+      , pt_segments :: [TrailSegment u]+      }+  deriving (Eq,Ord,Show)++type instance DUnit (PlacedTrail u) = u++newtype CatTrail u = CatTrail { getCatTrail :: H (TrailSegment u) }++type instance DUnit (CatTrail u) = u+++data TrailSegment u = TLine (Vec2 u)+                    | TCurve (Vec2 u) (Vec2 u) (Vec2 u)+  deriving (Eq,Ord,Show)++type instance DUnit (TrailSegment u) = u+++instance Functor TrailSegment where+  fmap f (TLine v1)        = TLine $ fmap f v1+  fmap f (TCurve v1 v2 v3) = TCurve (fmap f v1) (fmap f v2) (fmap f v3)+++instance Monoid (CatTrail u) where+  mempty        = CatTrail emptyH+  a `mappend` b = CatTrail $ getCatTrail a `appendH` getCatTrail b+++--------------------------------------------------------------------------------+++drawCatTrail :: InterpretUnit u => PathMode -> CatTrail u -> LocGraphic u+drawCatTrail mode (CatTrail ct) = promoteLoc $ \pt -> +    drawTrailBody mode (toListH ct) pt +++drawPlacedTrail :: InterpretUnit u => PathMode -> PlacedTrail u -> LocGraphic u+drawPlacedTrail mode (PlacedTrail v0 xs) = promoteLoc $ \pt -> +    drawTrailBody mode xs (pt .+^ v0)+++-- | Note - this optimizes contiguous lines that share the same +-- direction. +--+drawTrailBody :: InterpretUnit u +              => PathMode -> [TrailSegment u] -> Point2 u -> Graphic u+drawTrailBody mode ts pt = +    normalizeCtxF pt >>= \dpt -> +    mapM normalizeCtxF ts >>= \dxs ->+    dcPath mode $ relPrimPath dpt $ stepA id dxs+  where+    stepA f []                   = toListH f+    stepA f (TLine v1:ys)        = stepB f (vdirection v1) v1 ys+    stepA f (TCurve v1 v2 v3:ys) = stepA (f `snocH` relCurveTo v1 v2 v3) ys++    stepB f dir v0 (TLine v1:ys) +        | vdirection v1 == dir   = stepB f dir (v0 ^+^ v1) ys+    stepB f _   v0 ys            = stepA (f `snocH` relLineTo v0) ys+++-- | /Destructor/ for the opaque 'PlacedTrail' type.+--+destrPlacedTrail :: PlacedTrail u -> (Vec2 u, [TrailSegment u])+destrPlacedTrail (PlacedTrail v0 ss) = (v0,ss)++-- | /Destructor/ for the opaque 'CatTrail' type.+--+destrCatTrail :: CatTrail u -> [TrailSegment u]+destrCatTrail = toListH . getCatTrail++++-- | Turn a 'CatTrail' into a 'PlacedTrail'.+--+placeCatTrail :: Vec2 u -> CatTrail u -> PlacedTrail u+placeCatTrail vinit cat = PlacedTrail { pt_init_vec = vinit+                                      , pt_segments = getCatTrail cat []+                                      }++++-- | Create a PlacedTrail from the vector list - each vector in the +-- input list iterates to the start point rather then the +-- cumulative tip.+--+-- When the PlacedTrail is run, the supplied point is the /locus/ of +-- the path and it does not form part of the path proper.+-- +-- Like 'trailStartIsLocus', this constructor is typically used to +-- make /shape paths/. Some shapes are easier to express as +-- iterated displacements of the center rather than +-- /turtle drawing/. +-- +trailIterateLocus :: Num u => [Vec2 u] -> PlacedTrail u+trailIterateLocus []      = PlacedTrail zeroVec []+trailIterateLocus (v0:xs) = PlacedTrail v0 (step v0 xs)+  where+    step v1 []      = [ TLine (v0 ^-^ v1) ]+    step v1 (v2:vs) = TLine (v2 ^-^ v1) : step v2 vs+++placedTrailPoints :: InterpretUnit u => PlacedTrail u -> LocQuery u [Point2 u]+placedTrailPoints (PlacedTrail v0 ts) = qpromoteLoc $ \pt -> +    return $ step (pt .+^ v0) ts+  where+    step p1 []                    = [p1]+    step p1 (TLine v1:xs)         = p1 : step (p1 .+^ v1) xs+    step p1 (TCurve v1 v2 v3 :xs) = let p2 = p1 .+^ v1+                                        p3 = p2 .+^ v2+                                        p4 = p3 .+^ v3 +                                    in p1 : p2 : p3 : step p4 xs++-- | 'rectangleTrail' : @ width * height -> PlacedTrail @+--+rectangleTrail :: Fractional u => u -> u -> PlacedTrail u+rectangleTrail w h = +    PlacedTrail { pt_init_vec = ctr_to_bl +                , pt_segments = map TLine spec+                }+  where+    ctr_to_bl = vec (negate $ 0.5*w) (negate $ 0.5*h)+    spec      = [ go_right w, go_up h, go_left w, go_down h ]+++++-- | 'diamondTrail' : @ half_width * half_height -> PlacedTrail @+--+diamondTrail :: Num u => u -> u -> PlacedTrail u+diamondTrail hw hh = trailIterateLocus [ vs,ve,vn,vw ]+  where+    vs = vvec (-hh)+    ve = hvec hw+    vn = vvec hh+    vw = hvec (-hw)+++-- | 'polygonTrail' : @ num_points * radius -> PlacedTrail @ +--+polygonTrail :: Floating u => Int -> u -> PlacedTrail u+polygonTrail n radius = trailIterateLocus $ unfoldr phi (0,top)+  where+    top                     = 0.5*pi+    theta                   = (2*pi) / fromIntegral n+    +    phi (i,ang) | i < n     = Just (avec ang radius, (i+1,ang+theta))+                | otherwise = Nothing+++++catline :: Vec2 u -> CatTrail u +catline = CatTrail . wrapH . TLine++++catcurve :: Vec2 u -> Vec2 u -> Vec2 u -> CatTrail u+catcurve v1 v2 v3 = CatTrail $ wrapH $ TCurve v1 v2 v3+++trail_up :: Num u => u -> CatTrail u+trail_up = catline . go_up++trail_down :: Num u => u -> CatTrail u+trail_down = catline . go_down++trail_left :: Num u => u -> CatTrail u+trail_left = catline . go_left++trail_right :: Num u => u -> CatTrail u+trail_right = catline . go_right+++trail_north :: Num u => u -> CatTrail u+trail_north = trail_up++trail_south :: Num u => u -> CatTrail u+trail_south = catline . go_down++trail_east :: Num u => u -> CatTrail u+trail_east = catline . go_right++trail_west :: Num u => u -> CatTrail u+trail_west = catline . go_left+++trail_north_east :: Floating u => u -> CatTrail u+trail_north_east = catline . go_north_east++trail_north_west :: Floating u => u -> CatTrail u+trail_north_west = catline . go_north_west++trail_south_east :: Floating u => u -> CatTrail u+trail_south_east = catline . go_south_east++trail_south_west :: Floating u => u -> CatTrail u+trail_south_west = catline . go_south_west+++trail_up_left :: Num u => u -> CatTrail u+trail_up_left = catline . go_up_left++trail_up_right :: Num u => u -> CatTrail u+trail_up_right = catline . go_up_right++trail_down_left :: Num u => u -> CatTrail u+trail_down_left = catline . go_down_left++trail_down_right :: Num u => u -> CatTrail u+trail_down_right = catline . go_down_right+++-- | Alternative to @catline@, specifying the vector components +-- rather the vector itself.+--+orthoCatline :: Floating u => u -> u -> Radian -> CatTrail u +orthoCatline x y ang = catline (orthoVec x y ang)+++trail_theta_up :: Floating u => u -> Radian -> CatTrail u+trail_theta_up u = catline . theta_up u++trail_theta_down :: Floating u => u -> Radian -> CatTrail u+trail_theta_down u = catline . theta_down u++trail_theta_left :: Floating u => u -> Radian -> CatTrail u+trail_theta_left u = catline . theta_left u++trail_theta_right :: Floating u => u -> Radian -> CatTrail u+trail_theta_right u = catline . theta_right u+++trail_theta_north :: Floating u => u -> Radian -> CatTrail u+trail_theta_north = trail_theta_up++trail_theta_south :: Floating u => u -> Radian -> CatTrail u+trail_theta_south = trail_theta_down++trail_theta_east :: Floating u => u -> Radian -> CatTrail u+trail_theta_east = trail_theta_right++trail_theta_west :: Floating u => u -> Radian -> CatTrail u+trail_theta_west = trail_theta_left+++trail_theta_north_east :: Floating u => u -> Radian -> CatTrail u+trail_theta_north_east u = catline . theta_north_east u++trail_theta_north_west :: Floating u => u -> Radian -> CatTrail u+trail_theta_north_west u = catline . theta_north_west u++trail_theta_south_east :: Floating u => u -> Radian -> CatTrail u+trail_theta_south_east u = catline . theta_south_east u++trail_theta_south_west :: Floating u => u -> Radian -> CatTrail u+trail_theta_south_west u = catline . theta_south_west u+++trail_theta_up_left :: Floating u => u -> Radian -> CatTrail u+trail_theta_up_left u = catline . theta_up_left u++trail_theta_up_right :: Floating u => u -> Radian -> CatTrail u+trail_theta_up_right u = catline . theta_up_right u++trail_theta_down_left :: Floating u => u -> Radian -> CatTrail u+trail_theta_down_left u = catline . theta_down_left u++trail_theta_down_right :: Floating u => u -> Radian -> CatTrail u+trail_theta_down_right u = catline . theta_down_right u++++--------------------------------------------------------------------------------++--+-- DESIGN NOTE+--+-- Angle, unit width and number of repetitions (plus height etc.) +-- seems the best API, although this make fitting an issue.+--+++sineWave :: (Real u, Floating u) => Int -> u -> Radian -> CatTrail u+sineWave i unit ang = +    mconcat $ replicate i $ sineWave1 (0.25 * unit) unit ang+++-- | One-phase sine wave. Height is parametric.+--+sineWave1 :: (Real u, Floating u)+              => u -> u -> Radian -> CatTrail u+sineWave1 h unit ang = +              catcurve  v1            (vdiff v1 v2)   (vdiff v2 v3)+    `mappend` catcurve (vdiff v3 v4)  (vdiff v4 v5)   (vdiff v5 v6)+    `mappend` catcurve (vdiff v6 v7)  (vdiff v7 v8)   (vdiff v8 v9)+    `mappend` catcurve (vdiff v9 v10) (vdiff v10 v11) (vdiff v11 v12)+  where+    base1 = unit / 12+    h2    = h * (pi / 6)+    v1    = orthoVec     base1    h2  ang+    v2    = orthoVec  (2*base1)   h   ang+    v3    = orthoVec  (3*base1)   h   ang+    v4    = orthoVec  (4*base1)   h   ang+    v5    = orthoVec  (5*base1)   h2  ang+    v6    = orthoVec  (6*base1)   0   ang+    v7    = orthoVec  (7*base1) (-h2) ang+    v8    = orthoVec  (8*base1) (-h)  ang+    v9    = orthoVec  (9*base1) (-h)  ang+    v10   = orthoVec (10*base1) (-h)  ang+    v11   = orthoVec (11*base1) (-h2) ang+    v12   = orthoVec (12*base1)   0   ang++++kappa :: Floating u => u+kappa = 4 * ((sqrt 2 - 1) / 3)+++-- DESIGN NOTE - different functions for CW and CCW or same +-- function with @ClockDirection@ as first argument?+++-- | 'semicircleCW' : @ base_vector -> CatTrail @ +-- +-- Make a clockwise semicircle from two Bezier curves. Although +-- this function produces an approximation of a semicircle, the +-- approximation seems fine in practice.+--+semicircleCW :: (Real u, Floating u) => Vec2 u -> CatTrail u+semicircleCW base_vec =+              catcurve  v1           (vdiff v1 v2) (vdiff v2 v3)+    `mappend` catcurve (vdiff v3 v4) (vdiff v4 v5) (vdiff v5 v6)+  where+    circum  = vlength base_vec+    radius  = 0.5 * circum+    ang     = vdirection base_vec+    rl      = radius * kappa+    +    v1      = orthoVec 0 rl ang+    v2      = orthoVec (radius - rl) radius ang+    v3      = orthoVec radius radius ang++    v4      = orthoVec (radius + rl) radius ang+    v5      = orthoVec circum rl ang+    v6      = orthoVec circum 0 ang+++-- | 'semicircleCCW' : @ base_vector_vector -> CatTrail @ +-- +-- Make a counter-clockwise semicircle from two Bezier curves. +-- Although this function produces an approximation of a +-- semicircle, the approximation seems fine in practice.+--+semicircleCCW :: (Real u, Floating u) => Vec2 u -> CatTrail u+semicircleCCW base_vec =+              catcurve  v1           (vdiff v1 v2) (vdiff v2 v3)+    `mappend` catcurve (vdiff v3 v4) (vdiff v4 v5) (vdiff v5 v6)+  where+    circum  = vlength base_vec+    radius  = 0.5 * circum+    ang     = vdirection base_vec+    rl      = radius * kappa+    +    v1      = orthoVec 0 (-rl) ang+    v2      = orthoVec (radius - rl) (-radius) ang+    v3      = orthoVec radius (-radius) ang++    v4      = orthoVec (radius + rl) (-radius) ang+    v5      = orthoVec circum (-rl) ang+    v6      = orthoVec circum 0 ang+++++-- | 'minorCircleSweepCW' : @ angle * radius * inclination -> CatTrail @+--+-- > ang should be in the range 0 < ang <= 90deg.+--+minorCircleSweepCW :: (Real u, Floating u)+                   => Radian -> u -> Radian -> CatTrail u+minorCircleSweepCW ang radius theta = +    catcurve (pvec p0 p1) (pvec p1 p2) (pvec p2 p3)+  where+    kfactor = fromRadian $ ang / (0.5*pi)+    rl      = kfactor * radius * kappa+    totang  = circularModulo $ theta + (half_pi - ang)++    p0      = displace (theta_up    radius theta) zeroPt+    p1      = displace (theta_right rl     theta) p0+    p2      = displace (theta_up    rl     totang) p3+    p3      = displace (avec totang radius) zeroPt+++-- | 'minorCircleSweepCCW' : @ angle * radius * inclination -> CatTrail @+--+-- > ang should be in the range 0 < ang <= 90deg.+--+minorCircleSweepCCW :: (Real u, Floating u)+                    => Radian -> u -> Radian -> CatTrail u+minorCircleSweepCCW ang radius theta = +    catcurve (pvec p0 p1) (pvec p1 p2) (pvec p2 p3)+  where+    kfactor = fromRadian $ ang / (0.5*pi)+    rl      = kfactor * radius * kappa+    totang  = circularModulo $ theta - half_pi + ang++    p0      = displace (theta_down  radius theta) zeroPt+    p1      = displace (theta_right rl     theta) p0+    p2      = displace (theta_down  rl     totang) p3+    p3      = displace (avec totang radius) zeroPt++++-- | 'circleSweepCW' : @ apex_angle * radius * inclination -> CatTrail @+--+-- > ang should be in the range 0 < ang < 360deg.+--+-- > if   0 < ang <=  90 returns 1 segment+-- > if  90 < ang <= 180 returns 2 segments+-- > if 180 < ang <= 270 returns 3 segments+-- > if 270 < ang <  360 returns 4 segmenets+--+circleSweepCW :: (Real u, Floating u)+              => Radian -> u -> Radian -> CatTrail u+circleSweepCW ang radius theta = go (circularModulo ang)+  where+    go a | a <= half_pi = wedge1 a+         | a <= pi      = wedge2 (a/2)+         | a <= 1.5*pi  = wedge3 (a/3)+         | otherwise    = wedge4 (a/4)+    +    wedge1 a =           minorCircleSweepCW a radius theta++    wedge2 a =           minorCircleSweepCW a radius theta+               `mappend` minorCircleSweepCW a radius (theta-a)++    wedge3 a =           minorCircleSweepCW a radius theta+               `mappend` minorCircleSweepCW a radius (theta - a)+               `mappend` minorCircleSweepCW a radius (theta - 2*a)+  +    wedge4 a =           minorCircleSweepCW a radius theta+               `mappend` minorCircleSweepCW a radius (theta - a)+               `mappend` minorCircleSweepCW a radius (theta - 2*a)+               `mappend` minorCircleSweepCW a radius (theta - 3*a)+++++-- | 'circleSweepCCW' : @ apex_angle * radius * inclination -> CatTrail @+--+-- > ang should be in the range 0 < ang < 360deg.+--+-- > if   0 < ang <=  90 returns 1 segment+-- > if  90 < ang <= 180 returns 2 segments+-- > if 180 < ang <= 270 returns 3 segments+-- > if 270 < ang <  360 returns 4 segmenets+--+circleSweepCCW :: (Real u, Floating u)+               => Radian -> u -> Radian -> CatTrail u+circleSweepCCW ang radius theta = go (circularModulo ang)+  where+    go a | a <= half_pi = wedge1 a+         | a <= pi      = wedge2 (a/2)+         | a <= 1.5*pi  = wedge3 (a/3)+         | otherwise    = wedge4 (a/4)+    +    wedge1 a =           minorCircleSweepCCW a radius theta++    wedge2 a =           minorCircleSweepCCW a radius theta+               `mappend` minorCircleSweepCCW a radius (theta+a)++    wedge3 a =           minorCircleSweepCCW a radius theta+               `mappend` minorCircleSweepCCW a radius (theta+a)+               `mappend` minorCircleSweepCCW a radius (theta+a+a)+  +    wedge4 a =           minorCircleSweepCCW a radius theta+               `mappend` minorCircleSweepCCW a radius (theta+a)+               `mappend` minorCircleSweepCCW a radius (theta+a+a)+               `mappend` minorCircleSweepCCW a radius (theta+a+a+a)+++-- | inclination is the inclination of the chord.+--+circularArcCW :: (Real u, Floating u) => Radian -> u -> Radian -> CatTrail u +circularArcCW apex_ang radius inclin = +    circleSweepCW apex_ang radius (inclin + 0.5 * apex_ang)+++-- | inclination is the inclination of the chord.+--+circularArcCCW :: (Real u, Floating u) => Radian -> u -> Radian -> CatTrail u +circularArcCCW apex_ang radius inclin = +    circleSweepCCW apex_ang radius (inclin - 0.5 * apex_ang)+++-- | Proper semicircles do not make a good squiggle (it needs a +-- bit of pinch).+--+squiggleWave :: (Real u, Floating u) => Int -> u -> Radian -> CatTrail u+squiggleWave i unit ang = mconcat $ replicate i $ squiggle1 unit ang+    +squiggle1 :: (Real u, Floating u) => u -> Radian -> CatTrail u+squiggle1 unit ang = +              catcurve  v1            (vdiff v1 v2)   (vdiff v2 v3)+    `mappend` catcurve (vdiff v3 v4)  (vdiff v4 v5)   (vdiff v5 v6)+    `mappend` catcurve (vdiff v6 v7)  (vdiff v7 v8)   (vdiff v8 v9)+    `mappend` catcurve (vdiff v9 v10) (vdiff v10 v11) (vdiff v11 v12)+  where+    four_radius   = unit+    radius        = 0.25 * four_radius+    two_radius    = 0.5  * four_radius+    three_radius  = 0.75 * four_radius+    rl            = radius * kappa+    micro         = 0.33 * rl           -- seems good+    +    v1            = orthoVec micro rl ang+    v2            = orthoVec (radius - rl) radius ang+    v3            = orthoVec radius radius ang++    v4            = orthoVec (radius + rl) radius ang+    v5            = orthoVec (two_radius - micro) rl ang+    v6            = orthoVec two_radius  0 ang++    v7            = orthoVec (two_radius + micro) (-rl) ang+    v8            = orthoVec (three_radius - rl) (-radius) ang+    v9            = orthoVec three_radius (-radius) ang++    v10           = orthoVec (three_radius + rl) (-radius) ang+    v11           = orthoVec (four_radius - micro) (-rl) ang+    v12           = orthoVec four_radius 0 ang++    ++squareWave :: Floating u => Int -> u -> Radian -> CatTrail u +squareWave n unit ang +    | n >  0    = monPreRepeatPost up_half (n - 1,kont) fin+    | otherwise = mempty+  where+    up_half     = catline $ theta_up    (0.25 * unit) ang+    up_one      = catline $ theta_up    (0.5  * unit) ang+    down_one    = catline $ theta_down  (0.5  * unit) ang+    right_half  = catline $ theta_right (0.5  * unit) ang++    kont        = right_half `mappend` down_one `mappend` right_half+                             `mappend` up_one++    fin         = right_half `mappend` down_one `mappend` right_half+                             `mappend` up_half+++++-- |+--  +sawtoothWave :: (Real u, Floating u) => Int -> u -> Radian -> CatTrail u +sawtoothWave n unit ang +    | n >  0    = monPreRepeatPost up_half (n - 1,kont) fin+    | otherwise = mempty+  where+    up_half  = catline $ theta_up_right (0.25 * unit) ang+    up_one   = catline $ theta_up_right (0.5  * unit) ang+    down_one = catline $ theta_down_right (0.5 * unit) ang++    kont     = down_one `mappend` up_one+    fin      = down_one `mappend` up_half++++semicircleWave :: (Real u, Floating u) +               => ClockDirection -> Int -> u -> Radian -> CatTrail u+semicircleWave cdir i unit ang = +    mconcat $ replicate i $ fn cdir (avec ang unit)+  where+    fn CCW = semicircleCCW+    fn _   = semicircleCW++++--------------------------------------------------------------------------------++++-- | Curve in a triangle.+-- +tricurve :: Floating u => u -> u -> Radian -> CatTrail u+tricurve bw h ang = catcurve v1 zeroVec v2+  where+    v1 = orthoVec (0.5 * bw) h ang+    v2 = orthoVec (0.5 * bw) (-h) ang++++-- | Curve in a rectangle.+-- +rectcurve :: Floating u => u -> u -> Radian -> CatTrail u+rectcurve bw h ang = catcurve v1 v2 v3+  where+    v1 = orthoVec 0    h  ang+    v2 = orthoVec bw   0  ang+    v3 = orthoVec 0  (-h) ang++-- | Curve in a trapezium (CW).+-- +trapcurveCW :: Floating u => u -> u -> Radian -> Radian -> CatTrail u+trapcurveCW bw h interior_ang ang = catcurve v1 v2 v3+  where+    minor_bw = h / (fromRadian $ tan interior_ang)+    v1       = orthoVec minor_bw                h  ang+    v2       = orthoVec (bw - (2 * minor_bw))   0  ang+    v3       = orthoVec minor_bw              (-h) ang++++-- | Curve in a trapezium (CCW).+-- +trapcurveCCW :: Floating u => u -> u -> Radian -> Radian -> CatTrail u+trapcurveCCW bw h interior_ang ang = catcurve v1 v2 v3+  where+    minor_bw = h / (fromRadian $ tan interior_ang)+    v1       = orthoVec minor_bw              (-h)  ang+    v2       = orthoVec (bw - (2 * minor_bw))   0  ang+    v3       = orthoVec minor_bw                h ang+++-- | Curve in half a /bowtie/.+-- +bowcurve :: Floating u => u -> u -> Radian -> CatTrail u+bowcurve bw h ang = catcurve v1 v2 v3+  where+    v1 = orthoVec 0    h  ang+    v2 = orthoVec bw (-h)  ang+    v3 = orthoVec 0    h ang+++-- | Wedge curve formed inside a bowtie rotated by 90deg.+-- +wedgecurve :: Floating u => u -> u -> Radian -> CatTrail u+wedgecurve bw h ang = catcurve v1 v2 v3+  where+    v1 = orthoVec   bw    h  ang+    v2 = orthoVec (-bw)   0  ang+    v3 = orthoVec   bw  (-h) ang+++-- | Variation of wedge curve that draws a loop.+-- +loopcurve :: Floating u => u -> u -> Radian -> CatTrail u+loopcurve bw h ang = catcurve v1 v2 v3+  where+    ww = 2.0 * bw +    v1 = orthoVec  (1.5 * bw)    h  ang+    v2 = orthoVec  (-ww)         0  ang+    v3 = orthoVec  (1.5 * bw)  (-h) ang

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

@@ -1,5 +1,5 @@ name:             wumpus-basic-version:          0.21.0+version:          0.22.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -30,6 +30,34 @@   .   Changelog:   .+  v0.21.0 to v0.22.0:+  .+  * Reverted argument order of @run@ functions they back to the +    @monadLib@ style (args * monadic_operation) rather than @MTL@+    style (monadic_operation * args). Typographically this seems +    better.+  .+  * Removed module @Geometry.Paths@ it is superseded in+    Wumpus-Drawing.+  .+  * Added user state to PosObject and moved it into +    @Kernel.Drawing@.+  .+  * Changed the enumeration @DrawStyle@ to @DrawMode@. Added +    another enumeration @PathMode@.+  .+  * Changed Chain so that first item in the chain is the start +    point (previously the start point was iterated by the chain).+  .+  * Removed @ConnectorProps@ from the @DrawingContext@ , they are +    now used \"locally\" in Wumpus-Drawing.+  .+  * Added more vector constructors to +    @Kernel.Objects.Displacement@. +  .+  * Added extra methods to the @Decorate@ class for annotating +    SVG elements.+  .   v0.20.0 to v0.21.0:   .   * The code from the @Kernel.Base.UserState@ module has been @@ -44,33 +72,7 @@   * Rationalized the combinators exported by the drawing objects      @Image@, @LocImage@, @LocThetaImage@ and @Connector@.   . -  v0.18.0 to v0.20.0:   .-  * Added text advance-vector calculations to @QueryDC@ - -    previously they were in Wumpus-Drawing.-  . -  * Changed argument order of @run@ functions to follow the usual-    style - monadic action first and then dependent parameters -    (initial state, reader environment etc.).-  . -  * Changed representation of Chains to a monadic type with an -    explicit operation for next position.-  .-  * Removed @PrimW@ type - pairs are now used instead. -  .-  * Removed transformer version of @TraceDrawing@. All operations -    in TraceDrawing are now specialized to work only on the -    @TraceDrawing@ type. Added @UserState@ to TraceDrawing and-    other drawing monads to compensate for the loss of-    expressiveness.-  .-  * Changed the internals of @AdvObject@ and @PosObject@ so they -    are more idiomatic - both are now essentially reader-writer -    monads. Added PosObject functions for text primitives (moved -    from Wumpus-Drawing).-  .-  * Changed the @obliterate@ method of the @Decorate@ class.-  . build-type:         Simple stability:          highly unstable cabal-version:      >= 1.2@@ -90,7 +92,7 @@                       directory       >= 1.0     && <  2.0,                        filepath        >= 1.1     && <  2.0,                       vector-space    >= 0.6     && <  1.0,-                      wumpus-core     >= 0.51.0  && <  0.52.0+                      wumpus-core     >= 0.52.0  && <  0.53.0       exposed-modules:@@ -98,7 +100,6 @@     Wumpus.Basic.Geometry.Base,     Wumpus.Basic.Geometry.Illustrate,     Wumpus.Basic.Geometry.Intersection,-    Wumpus.Basic.Geometry.Paths,     Wumpus.Basic.Geometry.Quadrant,     Wumpus.Basic.Geometry.Vertices,     Wumpus.Basic.Kernel,@@ -114,6 +115,7 @@     Wumpus.Basic.Kernel.Drawing.CtxPicture,     Wumpus.Basic.Kernel.Drawing.LocDrawing,     Wumpus.Basic.Kernel.Drawing.LocTrace,+    Wumpus.Basic.Kernel.Drawing.PosObject,     Wumpus.Basic.Kernel.Drawing.TraceDrawing,     Wumpus.Basic.Kernel.Objects.AdvObject,     Wumpus.Basic.Kernel.Objects.Anchors,@@ -127,7 +129,7 @@     Wumpus.Basic.Kernel.Objects.LocImage,     Wumpus.Basic.Kernel.Objects.LocThetaImage,     Wumpus.Basic.Kernel.Objects.Orientation,-    Wumpus.Basic.Kernel.Objects.PosObject,+    Wumpus.Basic.Kernel.Objects.Trail,     Wumpus.Basic.System.FontLoader,     Wumpus.Basic.System.FontLoader.AfmParserBase,     Wumpus.Basic.System.FontLoader.AfmTopLevel,