wumpus-basic 0.17.0 → 0.18.0

raw patch · 33 files changed

+2292/−2471 lines, 33 filesdep ~wumpus-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: wumpus-core

API changes (from Hackage documentation)

Files

• CHANGES +78/−0
• demo/AltUnits.hs +13/−12
• demo/FontDeltaPic.hs +5/−5
• demo/SimpleAdvGraphic.hs +7/−7
• demo/SimplePosObject.hs +22/−17
• src/Wumpus/Basic/Geometry.hs +4/−0
• src/Wumpus/Basic/Geometry/Base.hs +45/−6
• src/Wumpus/Basic/Geometry/Illustrate.hs +69/−0
• src/Wumpus/Basic/Geometry/Intersection.hs +17/−31
• src/Wumpus/Basic/Geometry/Paths.hs +89/−117
• src/Wumpus/Basic/Geometry/Quadrant.hs +324/−29
• src/Wumpus/Basic/Geometry/Vertices.hs +142/−0
• src/Wumpus/Basic/Kernel.hs +0/−4
• src/Wumpus/Basic/Kernel/Base/BaseDefs.hs +46/−27
• src/Wumpus/Basic/Kernel/Base/ContextFun.hs +0/−305
• src/Wumpus/Basic/Kernel/Base/QueryDC.hs +0/−20
• src/Wumpus/Basic/Kernel/Base/UpdateDC.hs +52/−12
• src/Wumpus/Basic/Kernel/Base/WrappedPrimitive.hs +26/−11
• src/Wumpus/Basic/Kernel/Objects/AdvObject.hs +101/−44
• src/Wumpus/Basic/Kernel/Objects/Basis.hs +245/−383
• src/Wumpus/Basic/Kernel/Objects/Bounded.hs +37/−73
• src/Wumpus/Basic/Kernel/Objects/Chain.hs +27/−30
• src/Wumpus/Basic/Kernel/Objects/Connector.hs +171/−48
• src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs +8/−0
• src/Wumpus/Basic/Kernel/Objects/Displacement.hs +124/−218
• src/Wumpus/Basic/Kernel/Objects/DrawingPrimitives.hs +168/−357
• src/Wumpus/Basic/Kernel/Objects/Image.hs +0/−105
• src/Wumpus/Basic/Kernel/Objects/LocImage.hs +205/−58
• src/Wumpus/Basic/Kernel/Objects/LocThetaImage.hs +140/−252
• src/Wumpus/Basic/Kernel/Objects/PosObject.hs +90/−198
• src/Wumpus/Basic/Kernel/Objects/TraceDrawing.hs +17/−21
• src/Wumpus/Basic/VersionNumber.hs +2/−2
• wumpus-basic.cabal +18/−79

@@ -1,3 +1,81 @@++0.16.0 to 0.17.0:++  * Changed representation of ContextFuns - context funs are no +    longer an arity family of newtypes. The new representation +    is simpler, but some of the opportunities for overloading +    have been lost.++  * Substantial round of renaming for the @DrawingContext@ types+    an query and update functions.++  * Re-worked the font metrics and font loader modules. The new+    names should be more systematic. Removed the need for the +    GhostScript font modules to match PostScript names to +    GhostScript font files.    ++  * Superceded the PointSupplyM class by adding snapping grid +    scaling to the DrawingContext. + +  * Removed @ScalingContext@ module.++  * Made text colour a distinct property in the DrawingContext. +    Text is now drawn with the text colour rather than the stroke +    colour.++  * Added FontLoadLog to the DrawingContext - this allows access +    to the errors recorded during font loading.++0.15.0 to 0.16.0:++  * Moved the Geometry modules from Wumpus-Drawing into +    Wumpus-Basic.++  * Re-worked the @CtxPicture@ API, although the current naming +    scheme is not satisfactory.++  * Added extra Anchor classes.++  * Added @PosImage@ object - this is a rectangle-framed object +    that can be drawn from any of its corners or its center. ++  * Added @CF3@, an arity three /ContextFunction/.++  * Added @Displacement@ module. This defines the @PointDisplace@+    type and provides a library of @PointDisplace@ functions.+    Note - some of the new functions have taken names previously +    used for anchor projection functions (@northwards@, +    @southwards@, etc.), anchor projections are now build with the +    function @projectAnchor@.++  * Added the property @descender@ to the font metrics.++  * Split drawing primitives from type in @Objects.Graphic@, +    drawing primitives are now in the module +    @Objects.DrawingPrimitives@.++0.14.0 to 0.15.0:+ +  * Split previous @Wumpus-Basic@ package into two packages:+    @Wumpus-Basic@ and @Wumpus-Drawing@. This is a pratical move +    to separate the developed (although not yet polished) @Kernel@ +    and @FontLoader@ code from the prototypical @Drawing@ code.++  * Renamed the @Drawing@ object to @CtxPicture@. Although +    @CtxPicture@ is a less pleasant name, it should be less +    confusing. A @CtxPicture@ is the essentially the @Picture@ +    type from Wumpus-Core with an implicit context - +    @ContextPicture@ is simply too long and @CtxPicture@ is +    almost jibberish but the previous unrelated name @Drawing@ +    was not helpful.++  * @Kernel.Base.ScalingContext@ has been simplified. +    ScalingContexts are no longer manipulated via a custom Reader+    monad or transformer as the type signatures were too unwieldy.++  * Added @TextMargin@ to the @DrawingContext@ - Wumpus-Drawing +    can now calculate more appealing bounding boxes for text.+ 0.13.0 to 0.14.0:    * Re-organised module hierarchy, Wumpus-Basic is now divided 

@@ -7,6 +7,7 @@  import Wumpus.Core                              -- package: wumpus-core +import Data.Monoid import System.Directory  main :: IO ()@@ -36,30 +37,30 @@ combined :: TraceDrawing Double () combined = do      draw $ dblLocGraphic `at` P2 12 108-    drawl (P2 12 72) $ uconvLocImageF emLocGraphic-    draw $ uconvImageF $ emLocGraphic `at` P2 1 3-    drawl (P2 12 0) $ uconvLocImageF $ pushR1 (hyperlink haskell_org) enLocGraphic+    drawl (P2 12 72) $ uconvF emLocGraphic+    draw $ uconvF $ emLocGraphic `at` P2 1 3+    drawl (P2 12 0) $ uconvF $ hyperlink haskell_org enLocGraphic  dblLocGraphic :: LocGraphic Double-dblLocGraphic = rect1 `oplus` rect2  +dblLocGraphic = rect1 `mappend` rect2     where-    rect1 = borderedRectangle 36 24 -    rect2 = moveStart (displaceH 36) $ borderedRectangle 60 24 +    rect1 = dcRectangle FILL_STROKE 36 24 +    rect2 = moveStart (hvec 36) $ dcRectangle FILL_STROKE 60 24     emLocGraphic :: LocGraphic Em-emLocGraphic = localize swap_colours $  rect1 `oplus` rect2  +emLocGraphic = localize swap_colours $  rect1 `mappend` rect2     where-    rect1 = borderedRectangle 3 2 -    rect2 = moveStart (displaceH 3) $ borderedRectangle 5 2 +    rect1 = dcRectangle FILL_STROKE 3 2 +    rect2 = moveStart (hvec 3) $ dcRectangle FILL_STROKE 5 2    enLocGraphic :: LocGraphic En-enLocGraphic = localize (fill_colour lemon_chiffon) $  rect1 `oplus` rect2  +enLocGraphic = localize (fill_colour lemon_chiffon) $ rect1 `mappend` rect2     where-    rect1 = borderedRectangle 6 4-    rect2 = moveStart (displaceH 6) $ borderedRectangle 10 4+    rect1 = dcRectangle FILL_STROKE 6 4+    rect2 = moveStart (hvec 6) $ dcRectangle FILL_STROKE 10 4   haskell_org :: XLink

@@ -39,11 +39,11 @@     draw $ line4 `at` (P2 0  25)     draw $ line5 `at` (P2 0   0)    where-    line1 = plainTextLine "All the lines of this drawing" -    line2 = plainTextLine "should be grouped within a SVG"-    line3 = plainTextLine "g-element, from where they"-    line4 = plainTextLine "inherit the font-family and"-    line5 = plainTextLine "font-size attributes."+    line1 = dcTextlabel "All the lines of this drawing" +    line2 = dcTextlabel "should be grouped within a SVG"+    line3 = dcTextlabel "g-element, from where they"+    line4 = dcTextlabel "inherit the font-family and"+    line5 = dcTextlabel "font-size attributes."   

@@ -35,33 +35,33 @@ mf :: TraceDrawing Double () mf = do     drawl (P2 0 120) $ -        runAdvObjectR1 $ evenspace (hvec 10) [text01, text02, text01]+        runAdvObject $ evenspace (hvec 10) [text01, text02, text01]      drawl (P2 0 80) $ -        runAdvObjectR1 $ advances [text01, text02, text01]+        runAdvObject $ advances [text01, text02, text01]      drawl (P2 0 40) $ -        runAdvObjectR1 (miniDisk `advance` text01 `advance` miniDisk)+        runAdvObject (miniDisk `advance` text01 `advance` miniDisk)      drawl (P2 0 0) $-        runAdvObjectR1 (miniDisk `advance` text02 `advance` miniDisk)+        runAdvObject (miniDisk `advance` text02 `advance` miniDisk)   -- Normally, text calculate the advance vector from the font  -- metrics... -- text01 :: AdvObject Double-text01 = makeAdvObject (pure $ hvec 84) $ plainTextLine "text01"+text01 = makeAdvObject (pure $ hvec 84) $ dcTextlabel "text01"       text02 :: AdvObject Double-text02 = makeAdvObject (pure $ hvec 210) $ plainTextLine "text number two"+text02 = makeAdvObject (pure $ hvec 210) $ dcTextlabel "text number two"   miniDisk :: AdvObject Double miniDisk = makeAdvObject (pure $ V2 0 0) disk1    where-    disk1 = localize (fill_colour sienna) $ filledDisk 3+    disk1 = localize (fill_colour sienna) $ dcDisk FILL 3   sienna :: RGBi

@@ -8,6 +8,7 @@ import Wumpus.Core                      -- package: wumpus-core import Wumpus.Core.Colour ( red ) +import Data.Monoid import System.Directory  @@ -59,11 +60,13 @@       testDrawBl :: (Floating u, InterpretUnit u) => RectAddress -> LocGraphic u-testDrawBl rpos = -    filledDisk 2 `oplus` (pushR1 ignoreAns $ rectBl `startAddr` rpos)+testDrawBl raddr = dcDisk FILL 2 `mappend` rectBl raddr -rectBl :: (Fractional u, InterpretUnit u) => BoundedLocRectGraphic u-rectBl = runPosObjectR2 $ makePosObject (return ortt) (mkRectBl w h)++rectBl :: (Fractional u, InterpretUnit u) +       => RectAddress -> LocGraphic u+rectBl raddr = +    ignoreAns $ runPosObject raddr $ makePosObject (return ortt) (mkRectBl w h)   where     w    = 40      h    = 30@@ -75,18 +78,20 @@  -- start-point - bottom left mkRectBl :: InterpretUnit u => u -> u -> LocGraphic u-mkRectBl w h = strokedRectangle w h+mkRectBl w h = dcRectangle STROKE w h   -testDrawMinor :: (Floating u, InterpretUnit u) => RectAddress -> LocGraphic u-testDrawMinor rpos = -    filledDisk 2 `oplus` (pushR1 ignoreAns $ rectMinor `startAddr` rpos)+testDrawMinor :: (Floating u, InterpretUnit u) +              => RectAddress -> LocGraphic u+testDrawMinor raddr = +    dcDisk FILL 2 `mappend` (ignoreAns $ rectMinor raddr)  -rectMinor :: (Fractional u, InterpretUnit u) => BoundedLocRectGraphic u -rectMinor = -    runPosObjectR2 $ makePosObject (return ortt) (mkRectMinor m w h)+rectMinor :: (Fractional u, InterpretUnit u) +          => RectAddress -> LocImage u (BoundingBox u)+rectMinor raddr = +    runPosObject raddr $ makePosObject (return ortt) (mkRectMinor m w h)   where     m    = 10     w    = 40 @@ -99,10 +104,10 @@  -- start-point - +10 +10 mkRectMinor :: InterpretUnit u => u -> u -> u -> LocGraphic u-mkRectMinor m w h = promoteR1 $ \pt -> -    let bl = displaceVec (vec (-m) (-m)) pt-        br = displaceH w bl-        tr = displaceV h br-        tl = displaceV h bl-    in vertexPP [bl, br, tr, tl] >>= closedStroke+mkRectMinor m w h = promoteLoc $ \pt -> +    let bl = displace (vec (-m) (-m)) pt+        br = displace (hvec w) bl+        tr = displace (vvec h) br+        tl = displace (vvec h) bl+    in zapQuery (vertexPP [bl, br, tr, tl]) >>= dcClosedPath STROKE 

@@ -18,14 +18,18 @@ module Wumpus.Basic.Geometry   (     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    ) where   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

@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies               #-} {-# OPTIONS -Wall #-}  --------------------------------------------------------------------------------@@ -28,6 +29,10 @@   , identity2'2   , det2'2   , transpose2'2++  -- * Line +  , Line(..)+  , inclinedLine      -- * Line in equational form    , LineEquation(..)@@ -65,7 +70,7 @@   )    where -import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.Kernel  import Wumpus.Core                              -- package: wumpus-core @@ -101,6 +106,8 @@ data Matrix2'2 u = M2'2 !u !u   !u !u   deriving (Eq) +type instance DUnit (Matrix2'2 u) = u+ type DMatrix2'2 = Matrix2'2 Double  @@ -158,6 +165,29 @@  -------------------------------------------------------------------------------- +-- | Infinite line represented by two points.+--+data Line u = Line (Point2 u) (Point2 u)+  deriving (Eq,Show)++type instance DUnit (Line u) = u++++-- | 'inclinedLine' : @ point * ang -> Line @+--+-- Make an infinite line passing through the supplied point +-- inclined by @ang@.+--+inclinedLine :: Floating u => Point2 u -> Radian -> Line u+inclinedLine radial_ogin ang = Line radial_ogin (radial_ogin .+^ avec ang 100)++++++--------------------------------------------------------------------------------+ -- | Line in equational form, i.e. @Ax + By + C = 0@. -- data LineEquation u = LineEquation @@ -167,6 +197,9 @@       }   deriving (Eq,Show) +type instance DUnit (LineEquation u) = u++ type DLineEquation = LineEquation Double  @@ -230,6 +263,9 @@ data LineSegment u = LineSegment (Point2 u) (Point2 u)   deriving (Eq,Ord,Show) +type instance DUnit (LineSegment u) = u++ type DLineSegment = LineSegment Double  @@ -275,6 +311,9 @@ data BezierCurve u = BezierCurve !(Point2 u) !(Point2 u) !(Point2 u) !(Point2 u)   deriving (Eq,Ord,Show) +type instance DUnit (BezierCurve u) = u++ type DBezierCurve = BezierCurve Double  @@ -362,7 +401,7 @@   --- | 'bezierArcPoints' : @ apex_angle * radius * rotation * center -> [Point] @+-- | 'bezierArcPoints' : @ apex_angle * radius * inclination * center -> [Point] @ -- -- > ang should be in the range 0 < ang < 360deg. --@@ -415,10 +454,10 @@     rl      = kfactor * radius * kappa     totang  = circularModulo $ ang + theta -    p0      = displaceParallel radius theta pt-    c1      = displacePerpendicular rl theta p0-    c2      = displacePerpendicular (-rl) totang p3-    p3      = displaceParallel radius totang pt+    p0      = dispParallel radius theta pt+    c1      = dispPerpendicular rl theta p0+    c2      = dispPerpendicular (-rl) totang p3+    p3      = dispParallel radius totang pt   --------------------------------------------------------------------------------

@@ -0,0 +1,69 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Geometry.Illustrate+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Draw the geometrical objects.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Geometry.Illustrate+  ( ++    illustrateLine+  , illustrateLineSegment++  ) +  where++import Wumpus.Basic.Geometry.Base++import Wumpus.Basic.Kernel++import Wumpus.Core                              -- package: wumpus-core+import Wumpus.Core.Colour ++import Data.Monoid+++emline :: InterpretUnit u => Vec2 Em -> LocGraphic u+emline = uconvF . locStraightLine++enDot :: InterpretUnit u => LocGraphic u+enDot = uconvF body+  where+    body :: LocGraphic En+    body = localize (fill_colour white) $ dcDisk FILL_STROKE 0.5++illustrateLine :: (Real u, Floating u, InterpretUnit u) +               => Line u -> Graphic u+illustrateLine (Line p1 p2) = +    mconcat [ prefix, join_line, suffix, d1, d2 ]+  where+    join_line = straightLine p1 p2+    v1        = pvec p1 p2+    dir       = vdirection v1+    +    prefix    = localize dotted_line $ emline (avec dir (-6)) `at` p1+    suffix    = localize dotted_line $ emline (avec dir 6)    `at` p2+    d1        = enDot `at` p1+    d2        = enDot `at` p2++       ++++illustrateLineSegment :: InterpretUnit u => LineSegment u -> Graphic u+illustrateLineSegment (LineSegment p1 p2) = +    join_line `mappend` d1 `mappend` d2+  where+    join_line = straightLine p1 p2+    d1        = enDot `at` p1+    d2        = enDot `at` p2

@@ -26,7 +26,6 @@   , interCurveLine    , findIntersect-  , makePlane     ) @@ -36,7 +35,6 @@  import Wumpus.Core                              -- package: wumpus-core -import Data.AffineSpace                         -- package: vector-space   @@ -50,13 +48,12 @@ -- Lines are infinite they are represented by points on them,  -- they are not line segments. ----- An answer of @Nothing@ may indicate wither the lines coincide+-- An answer of @Nothing@ may indicate either the lines coincide -- or the are parallel. -- interLineLine :: Fractional u -              => (Point2 u, Point2 u) -> (Point2 u, Point2 u) -              -> Maybe (Point2 u)-interLineLine (p1,p2) (q1,q2) = +              => Line u -> Line u -> Maybe (Point2 u)+interLineLine (Line p1 p2) (Line q1 q2) =      if det_co == 0 then Nothing                     else Just $ P2 (det_xm / det_co) (det_ym / det_co)   where@@ -85,7 +82,7 @@ interLinesegLineseg :: (Fractional u, Ord u, Tolerance u)                     => LineSegment u -> LineSegment u -> Maybe (Point2 u) interLinesegLineseg a@(LineSegment p q) b@(LineSegment s t) = -    interLineLine (p,q) (s,t) >>= segcheck+    interLineLine (Line p q) (Line s t) >>= segcheck   where     segcheck = mbCheck (\pt -> withinPoints pt a && withinPoints pt b)  @@ -99,9 +96,9 @@ -- segment coincide, or that there is no intersection. -- interLinesegLine :: (Fractional u, Ord u, Tolerance u)-                 => LineSegment u -> (Point2 u, Point2 u) -> Maybe (Point2 u)+                 => LineSegment u -> Line u -> Maybe (Point2 u) interLinesegLine a@(LineSegment p q) line = -    interLineLine (p,q) line >>= segcheck+    interLineLine (Line p q) line >>= segcheck   where     segcheck = mbCheck (\pt -> withinPoints pt a) @@ -112,7 +109,7 @@ -- | Check the point is \"within\" the span of the line. -- -- Note - this function is to be used \*after\* an intersection--- has been found. Hence it is not export.+-- has been found. Hence it is not exported. -- withinPoints :: (Ord u, Fractional u, Tolerance u)               => Point2 u -> LineSegment u -> Bool@@ -120,7 +117,7 @@     between x (ordpair x0 x1) && between y (ordpair y0 y1)   where     ordpair a b     = (min a b, max a b)-    between a (s,t) = (s `tGT` a) && (a `tGT` t)+    between a (s,t) = (s `tLTE` a) && (a `tLTE` t)   @@ -136,8 +133,8 @@ -- intersection of line and Bezier curve  interCurveLine :: (Floating u , Ord u, Tolerance u)-               => BezierCurve u -> (Point2 u, Point2 u) -> Maybe (Point2 u)-interCurveLine c0 (p,q) = step c0+               => BezierCurve u -> Line u -> Maybe (Point2 u)+interCurveLine c0 (Line p q) = step c0   where     eqline  = lineEquation p q     step c  = case cut c eqline of@@ -156,15 +153,15 @@ -- cut :: (Floating u , Ord u, Tolerance u)     => BezierCurve u -> LineEquation u -> Either (Point2 u) Bool-cut (BezierCurve p0 p1 p2 p3) line = +cut (BezierCurve p0 p1 p2 p3) eqline =      if d0 `tEQ` 0 then Left p0 else     if d3 `tEQ` 0 then Left p3 else     let ds = [d0,d1,d2,d3] in Right $ not $ all pve ds || all nve ds   where-    d0  = pointLineDistance p0 line -    d1  = pointLineDistance p1 line -    d2  = pointLineDistance p2 line -    d3  = pointLineDistance p3 line +    d0  = pointLineDistance p0 eqline +    d1  = pointLineDistance p1 eqline +    d2  = pointLineDistance p2 eqline +    d3  = pointLineDistance p3 eqline    @@ -187,9 +184,9 @@               -> Maybe (Point2 u) findIntersect radial_ogin ang = step    where-    plane       = makePlane radial_ogin ang+    line1       = inclinedLine radial_ogin ang     step []     = Nothing-    step (x:xs) = case interLinesegLine x plane of +    step (x:xs) = case interLinesegLine x line1 of                       Just pt | quadrantCheck ang radial_ogin pt -> Just pt                      _       -> step xs @@ -200,16 +197,5 @@               => Radian -> Point2 u -> Point2 u -> Bool quadrantCheck theta ctr pt = theta == lineAngle ctr pt ------- | 'makePlane' : @ point * ang -> Line @------ Make an infinite line \/ plane passing through the supplied --- with elevation @ang@.----makePlane :: Floating u => Point2 u -> Radian -> (Point2 u, Point2 u)-makePlane radial_ogin ang = (radial_ogin, radial_ogin .+^ avec ang 100)  

@@ -11,10 +11,9 @@ -- Stability   :  highly unstable -- Portability :  GHC ----- Paths for /elementary/ shapes - rectangles...+-- Path /algorithms/ for elementary shapes - rectangle, diamond, +-- polygon. -- --- \*\* - WARNING \*\* - half baked. --- --------------------------------------------------------------------------------  module Wumpus.Basic.Geometry.Paths@@ -23,6 +22,8 @@     PathAlg   , runPathAlgPoint   , runPathAlgVec+  , drawVertexPathAlg+   , pathStartIsStart   , pathStartIsLocus   , pathIterateLocus@@ -31,25 +32,20 @@   , blRectanglePathAlg    , diamondPathAlg+  , isoscelesTriPathAlg   , polygonPathAlg    , arcPathAlg   , circlePathAlg -  , LocCoordPath-  , coordinatePrimPath+  , parallelogramPathAlg+  , isoscelesTrapeziumPathAlg -  , rectangleCoordPath-  , diamondCoordPath-  , polygonCoordPath-  , isoscelesTriangleCoordPath-  , isoscelesTrianglePoints-  , equilateralTriangleCoordPath-  , equilateralTrianglePoints   )    where  import Wumpus.Basic.Geometry.Base+import Wumpus.Basic.Geometry.Vertices import Wumpus.Basic.Kernel  import Wumpus.Core                              -- package: wumpus-core@@ -80,6 +76,7 @@  type instance DUnit (PathAlg u) = u + runPathAlgPoint :: Num u => Point2 u -> PathAlg u -> [Point2 u] runPathAlgPoint _  (PathAlg _   [])       = [] runPathAlgPoint p0 (PathAlg scm (v0:xs)) @@ -96,24 +93,58 @@   --- TO CLARIFY - should all four side paths of a rectangle be --- generated, or three sides with the implication that close forms--- the fourth?--- +drawVertexPathAlg :: InterpretUnit u +                  => DrawStyle -> PathAlg u -> LocGraphic u+drawVertexPathAlg style alg = promoteLoc $ \pt -> +    zapQuery (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 very the first vector represents a++-- | 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@@ -124,20 +155,27 @@   --- | Supplied point is /center/, the genearated points are --- counter-clockwise so [ bl, br, tr, tl ] .+-- | 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 [ vbl, vbr, vtr, vtl ]+rectanglePathAlg w h = +    pathStartIsLocus [ to_bl, to_br, to_tr, to_tl ]   where-    vbl = vec (negate $ 0.5*w) (negate $ 0.5*h)-    vbr = hvec w-    vtr = vvec h-    vtl = hvec (-w) +    to_bl = vec (negate $ 0.5*w) (negate $ 0.5*h)+    to_br = hvec w+    to_tr = vvec h+    to_tl = hvec (-w)  --- | Supplied point is /bottom-left/, subsequent points are --- counter-clockwise so [ bl, br, tr, tl ] .+++-- | 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@@ -158,6 +196,19 @@     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 @ @@ -172,6 +223,8 @@                 | 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@@ -240,104 +293,23 @@   --- arcs - wedges - circles...-------------------------------------------------------------------------------- OLD ...---- | A functional type from /initial point/ to point list.----type LocCoordPath u = Point2 u -> [Point2 u]----- Note - extraction needs a naming scheme - extractFROM or --- extractTO? - in either case this might be queuing up --- name-clash problems.------ The Path data type will also need a similar function...---- --- | Relative unit version of 'coordinatePrimPathAU'.----coordinatePrimPath :: InterpretUnit u -                   => LocCoordPath u -> Point2 u -> Query PrimPath-coordinatePrimPath fn pt = vertexPP $ fn pt------ | Supplied point is /bottom-left/, subsequenct points are --- counter-clockwise so [ bl, br, tr, tl ] .----rectangleCoordPath :: Num u => u -> u -> LocCoordPath u-rectangleCoordPath w h bl = [ bl, br, tr, tl ]-  where-    br = bl .+^ hvec w-    tr = br .+^ vvec h-    tl = bl .+^ vvec h ------ | 'diamondPath' : @ half_width * half_height * center_point -> PrimPath @----diamondCoordPath :: Num u => u -> u -> LocCoordPath u-diamondCoordPath hw hh ctr = [ s,e,n,w ]-  where-    s     = ctr .+^ vvec (-hh)-    e     = ctr .+^ hvec hw-    n     = ctr .+^ vvec hh-    w     = ctr .+^ hvec (-hw)-    ---- | 'polygonCoordPath' : @ num_points * radius * center -> [point] @ +-- | @ width * height * bottom_left_angle @ ---polygonCoordPath :: Floating u => Int -> u -> LocCoordPath u-polygonCoordPath n radius ctr = unfoldr phi (0,(pi*0.5))+parallelogramPathAlg :: Floating u => u -> u -> Radian -> PathAlg u+parallelogramPathAlg w h bl_ang = +    pathIterateLocus [ bl, br, tr, tl ]   where-    theta = (pi*2) / fromIntegral n-    -    phi (i,ang) | i < n     = Just (ctr .+^ avec ang radius, (i+1,ang+theta))-                | otherwise = Nothing+    (bl, br, tr, tl) = parallelogramVertices w h bl_ang   --- | @isocelesTriangle bw h pt@------ Supplied point is the centriod of the triangle. This has a --- nicer visual balance than using half-height.----isoscelesTriangleCoordPath :: Floating u => u -> u -> LocCoordPath u-isoscelesTriangleCoordPath bw h ctr = [bl,br,top]-  where-    (bl,br,top) = isoscelesTrianglePoints bw h ctr----- | @isocelesTriangle bw h pt@------ Supplied point is the centriod of the triangle. This has a --- nicer visual balance than using half-height.+-- | @ base_width * top_width * height @ ---isoscelesTrianglePoints :: Floating u -                        => u -> u -> Point2 u -> (Point2 u, Point2 u, Point2 u)-isoscelesTrianglePoints bw h ctr = (bl, br, top) +isoscelesTrapeziumPathAlg :: Floating u => u -> u -> u -> PathAlg u+isoscelesTrapeziumPathAlg bw tw h = +    pathIterateLocus [ bl, br, tr, tl ]   where-    hw         = 0.5*bw -    theta      = atan $ h / hw-    centroid_h = hw * tan (0.5*theta)-    top        = ctr .+^ vvec (h - centroid_h)-    br         = ctr .+^ V2   hw  (-centroid_h)-    bl         = ctr .+^ V2 (-hw) (-centroid_h)+    (bl, br, tr, tl) = isoscelesTrapeziumVertices bw tw h  --- | @ side_length * ctr -> [Points] @----equilateralTriangleCoordPath :: Floating u => u -> LocCoordPath u-equilateralTriangleCoordPath sl ctr = [bl, br, top] -  where-    (bl,br,top) = equilateralTrianglePoints sl ctr--equilateralTrianglePoints :: Floating u -                          => u -> Point2 u -> (Point2 u, Point2 u, Point2 u)-equilateralTrianglePoints sl = isoscelesTrianglePoints sl h-  where-    h = sl * sin (pi/3) 

@@ -21,11 +21,23 @@     Quadrant(..)    , quadrant-  , qiModulo -  , rectRadialVector+  , RadialIntersect+  , QuadrantAlg(..)+  , runQuadrantAlg+++  , hypotenuseQI   , rectangleQI+  , hquadrilAcuteQI+  , hquadrilObtusQI +  , rectangleQuadrantAlg+  , diamondQuadrantAlg+  , isoscelesTriQuadrantAlg++  -- OLD...+  , rectRadialVector   , diamondRadialVector   , triangleRadialVector   , triangleQI@@ -36,6 +48,8 @@   )    where +import Wumpus.Basic.Geometry.Base+ import Wumpus.Core                              -- package: wumpus-core  data Quadrant = QUAD_NE | QUAD_NW | QUAD_SW | QUAD_SE@@ -54,49 +68,141 @@          | otherwise    = QUAD_SE  --- | 'qiModulo' : @ ang -> Radian @+-- | 'reflectionModuloQI' : @ ang -> Radian @ -- --- Modulo an angle so it lies in quadrant I (north east), --- i.e. modulo into the range @0..(pi/2)@.+-- Modulo an angle so it lies in quadrant I (north east) +-- /by reflection/ - thats to say:+-- +-- > If the angle is in QI the result is identity. ---qiModulo :: Radian -> Radian -qiModulo r = d2r $ dec + (fromIntegral $ i `mod` 90)+-- > If the angle is in QII it is reflected about the Y-axis.+-- >+-- > e.g. 170deg becomes 10deg.+-- +-- > If the angle is in QIII it is reflected about both axes.+-- >+-- > e.g. 190deg becomes 10deg.+-- +-- > If the angle is in QIV it is reflected about the X-axis.+-- >+-- > e.g. 350deg becomes 10deg.+-- +--+reflectionModuloQI :: Radian -> Radian+reflectionModuloQI = step . circularModulo    where-    i       :: Integer-    dec     :: Double-    (i,dec) = properFraction $ r2d r+    step ang | ang < 0.5*pi   = ang+             | ang < pi       = pi - ang+             | ang < 1.5*pi   = ang - pi+             | otherwise      = two_pi - ang  ---------------------------------------------------------------------------------+type RadialIntersect u = Radian -> Vec2 u ++-- | A /Quadrant algorithm/.+--+data QuadrantAlg u = QuadrantAlg +      { calc_quad1 :: RadialIntersect u+      , calc_quad2 :: RadialIntersect u+      , calc_quad3 :: RadialIntersect u+      , calc_quad4 :: RadialIntersect u+      }++runQuadrantAlg :: Radian -> QuadrantAlg u -> Vec2 u+runQuadrantAlg a qa = step (circularModulo a)+  where+    step ang | ang < half_pi  = calc_quad1 qa ang+             | ang < pi       = calc_quad2 qa ang+             | ang < 1.5*pi   = calc_quad3 qa ang+             | otherwise      = calc_quad4 qa ang++    ++-- | Reuse a QI algorithm to work in QII /provided/ it works+-- under reflection.+--+reflectCalcQ2ToQ1 :: Num u => RadialIntersect u -> RadialIntersect u+reflectCalcQ2ToQ1 q1Fun = negateX . q1Fun . reflectionModuloQI+++-- | Reuse a QI algorithm to work in QIII /provided/ it works+-- under reflection.+--+reflectCalcQ3ToQ1 :: Num u => RadialIntersect u -> RadialIntersect u+reflectCalcQ3ToQ1 q1Fun = negateXY . q1Fun . reflectionModuloQI+++-- | Reuse a QI algorithm to work in QIV /provided/ it works+-- under reflection.+--+reflectCalcQ4ToQ1 :: Num u => RadialIntersect u -> RadialIntersect u+reflectCalcQ4ToQ1 q1Fun = negateY . q1Fun . reflectionModuloQI++++--+-- Negating vectors - aka relfecting them:++-- | Negate a vector in X - aka reflect it about the Y-axis.+-- negateX :: Num u => Vec2 u -> Vec2 u negateX (V2 x y) = V2 (-x) y +-- | Negate a vector in Y - aka reflect it about the X-axis.+-- negateY :: Num u => Vec2 u -> Vec2 u negateY (V2 x y) = V2 x (-y) +-- | Negate a vector in X and Y - aka reflect it about both axes.+-- negateXY :: Num u => Vec2 u -> Vec2 u negateXY (V2 x y) = V2 (-x) (-y)  --- | 'rectRadialVector' : @ half_width * half_height * ang -> Vec @++-- | Builder for the usual case of /Quadrant algorithm/ where+-- each quadrant is calculated in QI then the answer is reflected +-- to the respective quadrant. ----- Find where a radial line extended from (0,0) with the elevation--- @ang@ intersects with an enclosing rectangle. The rectangle is --- centered at (0,0).--- --- Internally the calculation is made in quadrant I (north east),--- symmetry is used to translate result to the other quadrants.+-- Calulating for QI is usually easier... ---rectRadialVector :: (Real u, Floating u) => u -> u -> Radian -> Vec2 u-rectRadialVector hw hh ang = fn $ circularModulo ang+makeReflectionQuadrantAlg :: Num u +                          => RadialIntersect u +                          -> RadialIntersect u+                          -> RadialIntersect u +                          -> RadialIntersect u+                          -> QuadrantAlg u+makeReflectionQuadrantAlg f1 f2 f3 f4 = +    QuadrantAlg { calc_quad1 = f1+                , calc_quad2 = reflectCalcQ2ToQ1 f2+                , calc_quad3 = reflectCalcQ3ToQ1 f3+                , calc_quad4 = reflectCalcQ4ToQ1 f4+                }++--------------------------------------------------------------------------------++++-- | 'triangleQI' : @ dx * dy -> RadialIntersect @+--+-- Find where a line from (0,0) with elevation @ang@ intersects +-- the hypotenuse a right triangle in QI (the legs of the triangle +-- take the x and y-axes).  +--+-- > ang must be in the @range 0 < ang <= 90@.+-- >+-- > width and height must be positive.+--+hypotenuseQI :: (Real u, Floating u) => u -> u -> RadialIntersect u+hypotenuseQI dx dy ang = avec ang dist   where-    fn a | a < 0.5*pi   = rectangleQI hw hh a-         | a < pi       = negateX  $ rectangleQI hw hh (pi - a)-         | a < 1.5*pi   = negateXY $ rectangleQI hw hh (a - pi) -         | otherwise    = negateY  $ rectangleQI hw hh (2*pi - a)+    base_ang = atan (dy / dx)+    apex     = pi - (base_ang + fromRadian ang)+    dist     = sin base_ang * (dx / sin apex)  + -- | 'rectangleQI' : @ width * height * ang -> Vec @ -- -- Find where a line from (0,0) in direction @ang@ intersects the @@ -108,13 +214,203 @@ -- > width and height must be positive. -- rectangleQI :: (Real u, Floating u) => u -> u -> Radian -> Vec2 u    -rectangleQI w h ang-    | ang < theta  = let y = w * fromRadian (tan ang) in V2 w y-    | otherwise    = let x = h / fromRadian (tan ang) in V2 x h+rectangleQI dx dy ang+    | ang < theta  = let y1 = dx * fromRadian (tan ang) in V2 dx y1+    | otherwise    = let x1 = dy / fromRadian (tan ang) in V2 x1 dy   where-    theta               = toRadian $ atan (h/w)+    theta               = toRadian $ atan (dy/dx)  ++-- | 'hquadrilAcuteQI' : @ dx * dy * ang -> RadialIntersect @+--+-- Find where a line from (0,0) with elevation @ang@ intersects +-- a quadrilateral in /H acute/ form in QI.  +--+-- > ang must be in the @range 0 < ang <= 90@.+-- >+-- > dx (top width @bc@) and dy (height @ab) must be positive.+--+-- Horizontal acute quadrilateral (@H@ because one of the two +-- \"sides of interest\" is horizontal, /acute/ because the +-- angle of interest @bcd@ is acute:+--+-- >      +-- >  b---*----c+-- >  |       /+-- >  |      %+-- >  |     /+-- >  a----d+-- >+--+hquadrilAcuteQI :: (Real u, Floating u) +                => u -> u -> Radian -> RadialIntersect u+hquadrilAcuteQI bc ab bcd ang = +    if ang >= cad then bisectingHTop ab ang else bisecting_dc ad adc ang+  where+    cad           = half_pi - (atan $ toRadian $ bc / ab)+    adc           = pi - bcd+    star_c        = ab / (fromRadian $ tan bcd)+    ad            = bc - star_c++    +-- This is intersecting dc at percent-sign - now called z.+--+-- Know one side (ad) and two angs (zad which is ang) and (adc == adz)+-- Use law of sines to find (az) :+-- +-- >+-- >         z+-- >    . ' /+-- >  a----d+-- > +--+bisecting_dc :: Floating u => u -> Radian -> Radian -> Vec2 u+bisecting_dc ad adc ang = avec ang az+  where+    adz  = adc+    azd  = pi - (ang + adz)+    sine = fromRadian . sin+    az   = (ad * (sine adz)) / sine azd +  +++-- This is intersecting bc at star now called o.+--+-- >  b---o----c+-- >  |  / +-- >  | /  +-- >  |/    +-- >  a-----+--+bisectingHTop :: Fractional u => u -> Radian -> Vec2 u+bisectingHTop ab ang = V2 bo ab+  where+    bao = half_pi - ang +    bo  = ab * (fromRadian $ tan bao)+     ++-- | 'hquadrilObtusQI' : @ dx * dy * ang -> RadialIntersect @+--+-- Find where a line from (0,0) with elevation @ang@ intersects +-- a quadrilateral in /H obtus/ form in QI.  +--+-- > ang must be in the @range 0 < ang <= 90@.+-- >+-- > dx (top width @bc@) and dy (height @ab) must be positive.+--+-- H Obtus quadrilateral (@H@ because one of the two +-- \"sides of interest\" is horizontal, /obtus/ because the +-- angle interest @bcd@ is obtuse:+--+-- >      +-- >  b---*----c+-- >  |         \+-- >  |          %+-- >  |           \+-- >  a------------d+-- >+--+hquadrilObtusQI :: (Real u, Floating u) +                => u -> u -> Radian -> RadialIntersect u+hquadrilObtusQI bc ab bcd ang = +    if ang < cad then bisecting_dc ad adc ang else bisectingHTop ab ang +  where+    cad           = half_pi - (atan $ toRadian $ bc / ab)+    adc           = pi - bcd+    star_c        = ab / (fromRadian $ tan bcd)+    ad            = bc - star_c++++++     +++++-- | 'diamondQuadrantAlg' : @ width * height -> QuadrantAlg @+--+-- Find where a radial line extended from (0,0) with the elevation+-- @ang@ intersects with an enclosing diamond. The diamond is +-- centered at (0,0).+-- +-- Internally the calculation is made in quadrant I (north east),+-- symmetry is used to translate result to the other quadrants.+--+diamondQuadrantAlg :: (Real u, Floating u) => u -> u -> QuadrantAlg u+diamondQuadrantAlg w h = makeReflectionQuadrantAlg q1 q1 q1 q1+  where+    hw = 0.5 * w+    hh = 0.5 * h+    q1 = hypotenuseQI hw hh+++-- | 'rectangleQuadrantAlg' : @ width * height -> QuadrantAlg @+--+-- Find where a radial line extended from (0,0) with the elevation+-- @ang@ intersects with an enclosing rectangle. The rectangle is +-- centered at (0,0).+-- +-- Internally the calculation is made in quadrant I (north east),+-- symmetry is used to translate result to the other quadrants.+--+rectangleQuadrantAlg :: (Real u, Floating u) => u -> u -> QuadrantAlg u+rectangleQuadrantAlg w h = makeReflectionQuadrantAlg q1 q1 q1 q1+  where+    hw = 0.5 * w+    hh = 0.5 * h+    q1 = rectangleQI hw hh++-- | 'isoscelesTriQuadrantAlg' : @ base_width * height -> QuadrantAlg @+--+-- Find where a radial line extended from (0,0) with the elevation+-- @ang@ intersects with an enclosing isosceles triangle. +-- +-- Note the /center/ of the triangle (0,0) is the centroid not the+-- incenter.+-- +-- Internally the calculation is made in quadrant I (north east),+-- symmetry is used to translate result to the other quadrants.+--+isoscelesTriQuadrantAlg :: (Real u, Floating u) => u -> u -> QuadrantAlg u+isoscelesTriQuadrantAlg bw h = +    makeReflectionQuadrantAlg qtop qtop qbase qbase+  where+    ymaj      = 2 * (h / 3)+    ymin      = h / 3+    hbw       = 0.5 * bw+    half_apex = atan (toRadian $ hbw / h)+    ctrdw     = ymaj * (fromRadian $ tan half_apex)+    ang       = half_pi - half_apex++    qtop      = hypotenuseQI ctrdw ymaj+    qbase     = hquadrilAcuteQI hbw ymin ang+    +++-- OLD ...++-- | 'rectRadialVector' : @ half_width * half_height * ang -> Vec @+--+-- Find where a radial line extended from (0,0) with the elevation+-- @ang@ intersects with an enclosing rectangle. The rectangle is +-- centered at (0,0).+-- +-- Internally the calculation is made in quadrant I (north east),+-- symmetry is used to translate result to the other quadrants.+--+rectRadialVector :: (Real u, Floating u) => u -> u -> Radian -> Vec2 u+rectRadialVector hw hh ang = fn $ circularModulo ang+  where+    fn a | a < 0.5*pi   = rectangleQI hw hh a+         | a < pi       = negateX  $ rectangleQI hw hh (pi - a)+         | a < 1.5*pi   = negateXY $ rectangleQI hw hh (a - pi) +         | otherwise    = negateY  $ rectangleQI hw hh (2*pi - a)+++ -- | 'diamondRadialVector' : @ half_width * half_height * ang -> Vec @ -- -- Find where a radial line extended from (0,0) with the elevation@@ -301,6 +597,5 @@     | tr_ang > half_pi = tw + extend     | otherwise        = tw   where-    half_pi  = 0.5*pi     shorten  = h / fromRadian (tan tr_ang)     extend   = let lr_ang = pi - tr_ang in h / fromRadian (tan lr_ang)

@@ -0,0 +1,142 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Basic.Vertices+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Vertices generators for elementary objects - triangles.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Geometry.Vertices+  ( +    +    Vertices2+  , Vertices3+  , Vertices4++  , runVertices2+  , runVertices3+  , runVertices4+++  , rectangleVertices  +  , isoscelesTriangleVertices+  , equilateralTriangleVertices++  , parallelogramVertices++  , isoscelesTrapeziumVertices++  ) +  where++++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space+import Data.VectorSpace+++type Vertices2 u = (Vec2 u, Vec2 u)+type Vertices3 u = (Vec2 u, Vec2 u, Vec2 u)+type Vertices4 u = (Vec2 u, Vec2 u, Vec2 u, Vec2 u)+++runVertices2 :: Num u => Point2 u -> Vertices2 u -> [Point2 u]+runVertices2 ctr (v1,v2) = [ctr .+^ v1, ctr .+^ v2]++runVertices3 :: Num u => Point2 u -> Vertices3 u -> [Point2 u]+runVertices3 ctr (v1,v2,v3) = [ctr .+^ v1, ctr .+^ v2, ctr .+^ v3]++runVertices4 :: Num u => Point2 u -> Vertices4 u -> [Point2 u]+runVertices4 ctr (v1,v2,v3,v4) = +    [ctr .+^ v1, ctr .+^ v2, ctr .+^ v3, ctr .+^ v4]+++-- | Vertices are from the center to (bl, br, tr, tl).+--+rectangleVertices :: Num u => u -> u -> Vertices4 u+rectangleVertices hw hh = (bl, br, tr, tl)+  where+    bl = V2 (-hw) (-hh)+    br = V2   hw  (-hh)+    tr = V2   hw    hh+    tl = V2 (-hw)   hh +++++++-- | @base_width * height -> (BL,BR,Apex)@+--+-- Vertices are from the centeriod to (bl, br,apex).+--++-- | @ height -> (BL,BR,Apex)@+-- +-- Point is centroid (not incenter).+--+isoscelesTriangleVertices :: Floating u => u -> u -> Vertices3 u+isoscelesTriangleVertices bw h = (bl, br, top) +  where+    hw            = 0.5*bw +    centroid_min  = 1 * (h / 3)+    centroid_maj  = h - centroid_min+    top           = vvec centroid_maj+    br            = V2   hw  (-centroid_min)+    bl            = V2 (-hw) (-centroid_min)++++++-- | @ side_length -> (BL,BR,Apex)@+--+equilateralTriangleVertices :: Floating u => u -> Vertices3 u+equilateralTriangleVertices h = isoscelesTriangleVertices sl h+  where+    sl = 2.0 * (h / tan (pi/3))++++parallelogramVertices :: Floating u => u -> u -> Radian -> Vertices4 u+parallelogramVertices w h bl_ang = (to_bl, to_br, to_tr, to_tl)+  where+    hw              = 0.5 * w+    hh              = 0.5 * h+    hypo            = hh / (fromRadian $ sin bl_ang)++    to_bl           = hvec (-hw) ^+^ avec bl_ang (-hypo)+    to_br           = hvec hw    ^+^ avec bl_ang (-hypo)+    to_tl           = hvec (-hw) ^+^ avec bl_ang hypo+    to_tr           = hvec hw    ^+^ avec bl_ang hypo+++++-- Trapezium - make an isosceles trapezium...+-- base - top - height ++-- +isoscelesTrapeziumVertices :: Floating u+                           => u -> u -> u -> Vertices4 u+isoscelesTrapeziumVertices wbase wtop h = +    (to_bl, to_br, to_tr, to_tl)+  where+    hh    = 0.5 * h+    hbw   = 0.5 * wbase+    htw   = 0.5 * wtop    +    to_bl = V2 (-hbw) (-hh) +    to_br = V2   hbw  (-hh) +    to_tl = V2 (-htw)   hh +    to_tr = V2   htw    hh+

@@ -18,7 +18,6 @@ module Wumpus.Basic.Kernel   (     module Wumpus.Basic.Kernel.Base.BaseDefs-  , module Wumpus.Basic.Kernel.Base.ContextFun   , module Wumpus.Basic.Kernel.Base.DrawingContext   , module Wumpus.Basic.Kernel.Base.FontSupport   , module Wumpus.Basic.Kernel.Base.QueryDC@@ -35,7 +34,6 @@   , module Wumpus.Basic.Kernel.Objects.CtxPicture   , module Wumpus.Basic.Kernel.Objects.Displacement   , module Wumpus.Basic.Kernel.Objects.DrawingPrimitives-  , module Wumpus.Basic.Kernel.Objects.Image   , module Wumpus.Basic.Kernel.Objects.LocImage   , module Wumpus.Basic.Kernel.Objects.LocThetaImage   , module Wumpus.Basic.Kernel.Objects.Orientation@@ -45,7 +43,6 @@   ) where  import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.ContextFun import Wumpus.Basic.Kernel.Base.DrawingContext import Wumpus.Basic.Kernel.Base.FontSupport import Wumpus.Basic.Kernel.Base.QueryDC@@ -62,7 +59,6 @@ import Wumpus.Basic.Kernel.Objects.CtxPicture 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.Kernel.Objects.LocThetaImage import Wumpus.Basic.Kernel.Objects.Orientation

@@ -47,6 +47,12 @@   , intraMapPoint   , intraMapFunctor +  -- * Drawing paths+  , DrawStyle(..)++  -- * Drawing /layer/+  , ZDeco(..)  +   -- * Alignment   , HAlign(..)   , VAlign(..)  @@ -54,11 +60,13 @@   -- * Cardinal (compass) positions   , Cardinal(..) -  -- * Advance vector-  , AdvanceVec-  , advanceH-  , advanceV+  -- * Direction enumeration+  , Direction(..)+   +  -- * Misc (potentially for Wumpus-Core)+  , vsum+   ) where  import Wumpus.Core                              -- package: wumpus-core@@ -323,7 +331,25 @@   --------------------------------------------------------------------------------+-- Drawing closed paths +data DrawStyle = FILL | STROKE | FILL_STROKE+  deriving (Bounded,Enum,Eq,Ord,Show)++++-- | Decorating with resepct to the Z-order +-- +-- > SUPERIOR - in front. +--+-- > ANTERIOR - behind.+--+data ZDeco = SUPERIOR | ANTERIOR+  deriving (Bounded,Enum,Eq,Ord,Show)+++--------------------------------------------------------------------------------+ -- Alignment  -- | Horizontal alignment - align to the top, center or bottom.@@ -346,31 +372,24 @@               | SOUTH | SOUTH_WEST | WEST | NORTH_WEST    deriving (Enum,Eq,Ord,Show)  --------------------------------------------------------------------------------- --- | Advance vectors provide an idiom for drawing consecutive--- graphics. PostScript uses them to draw left-to-right text - --- each character has an advance vector for the width and --- as characters are drawn they successively displace the start--- point for the next character with their advance vector.------ Type alias for Vec2.----type AdvanceVec u = Vec2 u+-- | An enumerated type representing horizontal and vertical +-- directions.+data Direction = UP | DOWN | LEFT | RIGHT+   deriving (Enum,Eq,Ord,Show)   --- | Extract the horizontal component of an advance vector.------ For left-to-right latin text, the vertical component of an--- advance vector is expected to be 0. Ingoring it seems --- permissible when drawing text.----advanceH :: AdvanceVec u -> u-advanceH (V2 w _)  = w --- | Extract the verticall component of an advance vector.----advanceV :: AdvanceVec u -> u-advanceV (V2 _ h)  = h -+-- | 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

@@ -1,305 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Kernel.Base.ContextFun--- Copyright   :  (c) Stephen Tetley 2010-2011--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  highly unstable--- Portability :  GHC ------ Function types operating over the DrawingContext as a /static/ --- argument. --------------------------------------------------------------------------------------module Wumpus.Basic.Kernel.Base.ContextFun-  (--  -- * /Context functional/ type-    CF     --  -- * Alias-  , Query--  -- * Run function-  , runCF--  -- * Construction-  , consCF--  , domMap1-  , domMap2--  , promoteR1-  , promoteR2--  , pushR0-  , pushR1-  , pushR2--  , apply1R1-  , apply1R2-  , apply2R2--  , lift0R1-  , lift0R2-  , lift1R2--  , uconvR0-  , uconvR1-  , uconvR2a-  , uconvR2ab--  , drawingCtx--  ) where--import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.DrawingContext--import Wumpus.Core                              -- package: wumpus-core---import Control.Applicative-import Data.Monoid------------------------------------------------------------------------------------------ NOTE - 31.03.11 - is there an advantage to adding a phantom--- unit param to the CF functions?---- | Most drawing operations in Wumpus-Basic have an implicit --- /graphics state/ the 'DrawingContext', so the most primitive --- building block is a function from the DrawingContext to some --- polymorphic answer.--- --- This functional type is represented concretely as the initials --- @CF@ for /contextual function/.--- --- > CF :: DrawingContext -> a ----newtype CF a            = CF  { getCF :: DrawingContext -> a }--type instance DUnit (CF a) = DUnit a------ | Alias for 'CF'. Wumpus considers Context functions that--- don\'t produce graphics to be /queries/.--- --- > Query :: DrawingContext -> a ------ 'Query' has no unit type parameter.--- -type Query a            = CF a- ----------------------------------------------------------------------------------------- CF instances---- OPlus--instance OPlus a => OPlus (CF a)  where-  fa `oplus` fb = CF $ \ctx -> getCF fa ctx `oplus` getCF fb ctx----- Monoid- -instance Monoid a => Monoid (CF a) where -  mempty          = CF $ \_   -> mempty-  fa `mappend` fb = CF $ \ctx -> getCF fa ctx `mappend` getCF fb ctx----- Functor--instance Functor CF where-  fmap f ma = CF $ \ctx -> f $ getCF ma ctx ------ Applicative--instance Applicative CF where-  pure a    = CF $ \_   -> a-  mf <*> ma = CF $ \ctx -> let f = getCF mf ctx-                               a = getCF ma ctx-                           in f a------ Monad --instance Monad CF where-  return a  = CF $ \_   -> a-  ma >>= k  = CF $ \ctx -> let a = getCF ma ctx in (getCF . k) a ctx ----- DrawingCtxM --instance DrawingCtxM CF where-  askDC           = CF $ \ctx -> ctx-  localize upd df = CF $ \ctx -> getCF df (upd ctx)-  -------------------------------------------------------------------------------------- Affine instances----instance Rotate a => Rotate (CF a) where-  rotate ang            = fmap (rotate ang)--instance RotateAbout a => RotateAbout (CF a) where-  rotateAbout ang pt    = fmap (rotateAbout ang pt)--instance Scale a => Scale (CF a) where-  scale sx sy           = fmap (scale sx sy)--instance Translate a => Translate (CF a) where-  translate dx dy       = fmap (translate dx dy)--------------------------------------------------------------------------------------- Run functions---- | Run a /CF/ (context function) with the supplied --- /DrawingContext/.----runCF :: DrawingContext -> CF a -> a-runCF ctx cf = getCF cf ctx------ | Construction function.----consCF :: (DrawingContext -> a) -> CF a-consCF fn = CF $ \ctx -> fn ctx------domMap1 :: (r1 -> r1) -> CF (r1 -> a) -> CF (r1 -> a)-domMap1 f ma = CF $ \ctx -> -    (\r1 -> let f1 = getCF ma ctx in f1 (f r1))--domMap2 :: (r1 -> r1) -> (r2 -> r2) -> CF (r1 -> r2 -> a) -> CF (r1 -> r2 -> a)-domMap2 f g ma = CF $ \ctx -> -    (\r1 r2 -> let f1 = getCF ma ctx in f1 (f r1) (g r2))----promoteR1 :: (r1 -> CF a) -> CF (r1 -> a)-promoteR1 mf = CF $ \ctx r1 -> getCF (mf r1) ctx--promoteR2 :: (r1 -> r2 -> CF a) -> CF (r1 -> r2 -> a)-promoteR2 mf = CF $ \ctx r1 r2 -> getCF (mf r1 r2) ctx---- | Apply the value transformer to the answer of the context --- function. Figuratively /push it right/ so it works on the --- answer.------ > pushR0 = fmap----pushR0 :: (a -> a1) -> CF a -> CF a1-pushR0 = fmap----- | Apply the value transformer to the answer of the context --- function. Figuratively /push it right/ so it works on the --- answer.------ > pushR1 = fmap . fmap----pushR1 :: (a -> a1) -> CF (r1 -> a) -> CF (r1 -> a1)-pushR1 = fmap . fmap---- | Apply the value transformer to the answer of the context --- function. Figuratively /push it right/ so it works on the --- answer.------ > pushR2 = fmap . fmap . fmap ----pushR2 :: (a -> a1) -> CF (r1 -> r2 -> a) -> CF (r1 -> r2 -> a1)-pushR2 = fmap . fmap . fmap-----apply1R1 :: CF (r1 -> a) -> r1 -> CF a-apply1R1 mf r1 = CF $ \ctx -> getCF mf ctx r1---apply1R2 :: CF (r1 -> r2 -> a) -> r2 -> CF (r1 -> a)-apply1R2 mf r2 = CF $ \ctx r1 -> getCF mf ctx r1 r2---apply2R2 :: CF (r1 -> r2 -> a) -> r1 -> r2 -> CF a-apply2R2 mf r1 r2 = CF $ \ctx -> getCF mf ctx r1 r2---lift0R1             :: CF a -> CF (r1 -> a)-lift0R1 mf          = CF $ \ctx _ -> getCF mf ctx--lift0R2             :: CF a -> CF (r1 -> r2 -> a)-lift0R2 mf          = CF $ \ctx _ _ -> getCF mf ctx--lift1R2             :: CF (r1 -> a) -> CF (r1 -> r2 -> a)-lift1R2 mf          = CF $ \ctx r1 _ -> getCF mf ctx r1-----uconvR0 :: (FontSize -> ans -> ans1)  -> CF ans -> CF ans1-uconvR0 post df = CF $ \ctx ->-    let sz = dc_font_size ctx -    in post sz $ getCF df ctx---uconvR1 :: (Functor t, InterpretUnit u, InterpretUnit u1) -        => (FontSize -> ans -> ans1) -        -> CF (t u -> ans) -> CF (t u1 -> ans1)-uconvR1 post df = CF $ \ctx r1 -> -    let sz = dc_font_size ctx -    in post sz $ getCF df ctx (uconvertF sz r1)---uconvR2a :: (Functor t, InterpretUnit u, InterpretUnit u1) -         => (FontSize -> ans -> ans1)-         -> CF (t u -> r2 -> ans) -> CF (t u1 -> r2 -> ans1)-uconvR2a post df = CF $ \ctx r1 r2 -> -    let sz = dc_font_size ctx -    in post sz $ getCF df ctx (uconvertF sz r1) r2----uconvR2ab :: (Functor t1, Functor t2, InterpretUnit u, InterpretUnit u1) -          => (FontSize -> ans -> ans1)-          -> CF (t1 u -> t2 u ->  ans) -> CF (t1 u1 -> t2 u1 -> ans1)-uconvR2ab post df = CF $ \ctx r1 r2 -> -    let sz = dc_font_size ctx -    in post sz $ getCF df ctx (uconvertF sz r1) (uconvertF sz r2)------ | Extract the drawing context from a CtxFun.------ > (ctx -> ctx)--- -drawingCtx      :: Query DrawingContext-drawingCtx      = CF $ \ctx -> ctx--

@@ -47,8 +47,6 @@   , getFontFace   , getTextColour -  , markHeight-  , markHalfHeight   , textlineSpace    -- * Glyph metrics@@ -78,7 +76,6 @@ import Wumpus.Basic.Kernel.Base.FontSupport  import Wumpus.Core                              -- package: wumpus-core-import qualified Wumpus.Core.FontSize   as FS   import Control.Applicative @@ -185,23 +182,6 @@  getTextColour   :: DrawingCtxM m => m RGBi getTextColour   = asksDC dc_text_colour----- | The /mark/ height is the height of a lowercase letter in the --- Courier font at the current point size.------ Arrowheads, dots etc. should generally be drawn at the mark --- height.--- -markHeight :: (DrawingCtxM m, InterpretUnit u) => m u-markHeight = post <$> asksDC dc_font_size -  where-    post sz = dinterp sz (FS.xcharHeight sz)----markHalfHeight :: (Fractional u, DrawingCtxM m, InterpretUnit u) => m u-markHalfHeight = (0.5*) <$> markHeight   

@@ -24,30 +24,32 @@ module Wumpus.Basic.Kernel.Base.UpdateDC   (  -  -- * Modifiers       +  -- * Globals     snap_grid_factors -  -- ** Line widths+  -- * Line widths   , set_line_width    , line_default   , line_thin   , line_thick   , line_ultra_thick+  +  , relative_line_width -  -- ** Line caps+  -- * Line cap   , cap_default   , cap_butt   , cap_round   , cap_square -  -- ** Line joins+  -- * Line join   , join_default   , join_miter   , join_round   , join_bevel -  -- ** Dash Pattern+  -- * Dash pattern   , set_dash_pattern    , solid_line@@ -63,14 +65,13 @@   , font_attr   , set_font   , set_font_size---  -- * Font / mark drawing size   , scale_point_size    , double_point_size   , half_point_size ++  -- * Text margins   , text_margin   , text_margin_none   , text_margin_tight@@ -187,7 +188,16 @@ line_ultra_thick    = set_line_width 4.0  ++-- | Set the line width to a size relative to the current font +-- size. The size is calculated with the supplied function. --+relative_line_width :: (FontSize -> Double) -> DrawingContextF+relative_line_width fn = +    withFontSize $ \sz s -> set_line_width (fn sz) s+++-- -- All options share the prefix so the enumeration is obvious... -- @@ -211,10 +221,14 @@  -- | Set the line_cap to @butt@. ----- Butt squares of the stroke at the end point.+-- Butt chamfers off the stroke, flush to the end point. -- -- This is the default. --+-- >  .-------.+-- >  |=======|+-- >  '-------'+-- cap_butt            :: DrawingContextF cap_butt            = setLineCap CapButt @@ -223,15 +237,23 @@ -- This rounds the end of the stroke and the visually the  -- rounding slightly extends the length of the line. --+-- >  .-------.+-- > ( ======= )+-- >  '-------'+-- cap_round           :: DrawingContextF cap_round           = setLineCap CapRound   -- | Set the line_cap to @square@. ----- This squares off the end of the stroke, visually extending --- the stroke by half the line width.+-- This squares off the end of the stroke, but visual extends the +-- stroke by half the line width. --+-- >  .---------.+-- >  | ======= |+-- >  '---------'+-- cap_square          :: DrawingContextF cap_square          = setLineCap CapSquare @@ -251,6 +273,12 @@ -- -- This is the default. --+-- >      /\+-- >     /..\ +-- >    /./\.\+-- >   /./  \.\+-- >  /./    \.\+-- join_miter          :: DrawingContextF join_miter          = setLineJoin JoinMiter @@ -259,6 +287,12 @@ -- -- This rounds off the corner of the joined line segments. --+-- >  \.\  +-- >   \.\ +-- >    ,.)+-- >   /./+-- >  /./+-- join_round          :: DrawingContextF join_round          = setLineJoin JoinRound @@ -268,6 +302,12 @@ -- This bevels off the corner of the joined line segments with a  -- notch. --+-- >      __+-- >     /..\ +-- >    /./\.\+-- >   /./  \.\+-- >  /./    \.\+-- join_bevel          :: DrawingContextF join_bevel          = setLineJoin JoinBevel @@ -403,7 +443,7 @@  -- | 'text_margin' : @ x_sep * y_sep -> DrawingContextF @ ----- NOTE - ideally this would use Em or En rather thn Double...+-- Note - this is in @Em@ units. -- text_margin   :: Em -> Em -> DrawingContextF text_margin xsep ysep = \s -> 

@@ -13,13 +13,14 @@ -- -- Wrapped versions of the @Primitive@ type from Wumpus-Core. --+-- This file is essentially /internal/ to Wumpus-Basic.+-- --------------------------------------------------------------------------------  module Wumpus.Basic.Kernel.Base.WrappedPrimitive   (  -   -- * Primitives     CatPrim   , prim1@@ -29,9 +30,6 @@   , hprimToList   , singleH ---   ) where  import Wumpus.Basic.Kernel.Base.BaseDefs@@ -44,9 +42,11 @@   --- | CatPrim could probably manage happily just being a--- Primitive, but it is wrapped as a newtype...+-- | A wrapped version of 'Primitive' from Wumpus-Core that +-- supports Monoid. --+-- This type is essentially internal to Wumpus-Basic.+-- data CatPrim = CZero              | Cat1 Primitive @@ -64,6 +64,11 @@   a      `mappend` CZero  = a   Cat1 a `mappend` Cat1 b = Cat1 $ a `primCat` b +  mconcat []      = mempty+  mconcat (a:as)  = step a as+    where+      step ac []     = ac+      step ac (x:xs) = step (ac `mappend` x) xs   --------------------------------------------------------------------------------@@ -90,6 +95,8 @@ prim1 :: Primitive -> CatPrim  prim1 = Cat1 ++-- | Map  cpmap :: (Primitive -> Primitive) -> CatPrim -> CatPrim cpmap _ CZero    = CZero cpmap f (Cat1 a) = Cat1 $ f a@@ -97,6 +104,7 @@ -------------------------------------------------------------------------------- -- Lists of primitives... + -- | Graphics objects, even simple ones (line, arrow, dot) might  -- need more than one primitive (path or text label) for their -- construction. Hence, the primary representation that all the @@ -111,11 +119,8 @@ -- representation, and a Hughes list which supports -- efficient concatenation is wise. ----- NOTE - currently HPrim has a phantom unit @u@, this is so --- trace drawings can have a unit type, but this may change as --- perhaps trace drawings don\'t benefit from having units.----+-- This type is essentially internal to Wumpus-Basic.+--  newtype HPrim u = HPrim { getHPrim :: H Primitive }  -- Note - only a Monoid instance for HPrim - they cannot be @@ -125,11 +130,21 @@   mempty          = HPrim emptyH   ha `mappend` hb = HPrim $ getHPrim ha `appendH` getHPrim hb +  mconcat []      = mempty+  mconcat (a:as)  = step a as+    where+      step ac []     = ac+      step ac (x:xs) = step (ac `mappend` x) xs ++-- | Extract the internal list of 'Primitive' from a 'HPrim'.+-- hprimToList :: HPrim u -> [Primitive] hprimToList = toListH . getHPrim  +-- | Form a 'HPrim' from a 'CatPrim'.+-- singleH :: CatPrim -> HPrim u singleH CZero    = HPrim emptyH singleH (Cat1 a) = HPrim $ wrapH a

@@ -19,19 +19,23 @@ module Wumpus.Basic.Kernel.Objects.AdvObject   ( ++  -- * Advance vector+    AdvanceVec+  , advanceH+  , advanceV++   -- * Advance-vector object and graphic-    AdvObject+  , AdvObject   , DAdvObject   -  , AdvGraphic-  , DAdvGraphic+  , runAdvObject    , makeAdvObject   , emptyAdvObject--  , runAdvObjectR0-  , runAdvObjectR1-+  , blankAdvObject+      -- * Composition   , advance@@ -46,10 +50,9 @@   ) where  import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.ContextFun+import Wumpus.Basic.Kernel.Base.DrawingContext+import Wumpus.Basic.Kernel.Base.WrappedPrimitive import Wumpus.Basic.Kernel.Objects.Basis-import Wumpus.Basic.Kernel.Objects.Displacement-import Wumpus.Basic.Kernel.Objects.Image import Wumpus.Basic.Kernel.Objects.LocImage  import Wumpus.Core                              -- package: wumpus-core@@ -62,45 +65,86 @@   -type AdvDraw u = Point2 u -> GraphicAns u +-------------------------------------------------------------------------------- +-- | Advance vectors provide an idiom for drawing consecutive+-- graphics. PostScript uses them to draw left-to-right text - +-- each character has an advance vector for the width and +-- as characters are drawn they successively displace the start+-- point for the next character with their advance vector.+--+-- Type alias for Vec2.+--+type AdvanceVec u = Vec2 u+++-- | Extract the horizontal component of an advance vector.+--+-- For left-to-right latin text, the vertical component of an+-- advance vector is expected to be 0. Ingoring it seems +-- permissible when drawing text.+--+advanceH :: AdvanceVec u -> u+advanceH (V2 w _)  = w++-- | Extract the verticall component of an advance vector.+--+advanceV :: AdvanceVec u -> u+advanceV (V2 _ h)  = h+++--------------------------------------------------------------------------------+-- AdvObject++type AdvDraw u = Point2 u -> CatPrim+++ -- | /Advance vector/ graphic - this partially models the  -- PostScript @show@ command which moves the /current point/ by the -- advance (width) vector as each character is drawn. ---newtype AdvObject u = AdvObject { getAdvObject :: CF (Vec2 u, AdvDraw u) }+newtype AdvObject u = AdvObject { getAdvObject :: Query u (Vec2 u, AdvDraw u) }  type instance DUnit (AdvObject u) = u  type DAdvObject     = AdvObject Double  -type AdvGraphic u       = LocImage u (Vec2 u)-type DAdvGraphic        = AdvGraphic Double   --------------------------------------------------------------------------------  instance (InterpretUnit u) => Monoid (AdvObject u) where-  mempty  = emptyAdvObject+  mempty  = blankAdvObject (V2 0 0)   mappend = advplus  +-- | Run an 'AdvObject' turning it into an 'LocImage'.+--+runAdvObject :: AdvObject u -> LocImage u (Vec2 u)+runAdvObject (AdvObject mf) = promoteLoc $ \pt -> +   askDC >>= \ctx -> +   let (v1,df) = runQuery ctx mf+   in replaceAns v1 $ primGraphic (df pt)++ -- | 'makeAdvObject' : @ loc_context_function * graphic -> AdvObject @ -- -- Build an 'AdvObject' from a context function ('CF') that  -- generates the answer displacement vector and a 'LocGraphic'  -- that draws the 'AdvObject'. ---makeAdvObject :: Query (Vec2 u) -> LocGraphic u -> AdvObject u-makeAdvObject qvec gf = AdvObject body+makeAdvObject :: Query u (Vec2 u) -> LocGraphic u -> AdvObject u+makeAdvObject mq gf = AdvObject body   where-    body = drawingCtx >>= \ctx -> -           let v1   = runCF ctx qvec-               pf   = runCF ctx gf+    body = askDC >>= \ctx -> +           let v1   = runQuery ctx mq+               pf   = \pt -> getCP $ runLocImage pt ctx gf            in return (v1,pf) +    getCP (PrimW ca _) = ca   -- | 'emptyAdvObjectAU' : @ AdvObject @@@ -112,45 +156,62 @@ -- the zero vector @(V2 0 0)@. --  emptyAdvObject :: InterpretUnit u => AdvObject u-emptyAdvObject = makeAdvObject (pure $ V2 0 0) emptyLocGraphic+emptyAdvObject = blankAdvObject (V2 0 0)  +blankAdvObject :: Vec2 u -> AdvObject u+blankAdvObject v1 = AdvObject $ pure (v1, const mempty) -runAdvObjectR0 :: Point2 u -> AdvObject u -> Image u (Vec2 u)-runAdvObjectR0 pt (AdvObject mf) =  -   (\(v1,pf) -> replaceAns v1 $ pf pt) <$> mf  -runAdvObjectR1 :: AdvObject u -> AdvGraphic u-runAdvObjectR1 (AdvObject mf) = promoteR1 $ \pt -> -   (\(v1,pf) -> replaceAns v1 $ pf pt) <$> mf   -------------------------------------------------------------------------------- -- Combining AdvObjects  +-- | Design note - this is rather /uncool/.+--+-- Here it would be nicer if PrimW didn\'t cover two cases - +-- queries (Pure) and images (PrimW). However implementing this +-- would double the amount of code and then require extra +-- bind-like combinators to promote queries to images.+--+-- This is simulated in @appendW@ by dropping any graphic embedded +-- in a PrimW (everything should be a query anyway). But it would +-- be nicer in this particular case, if the type system enforced +-- this.+--+appendW :: Num u +        => (Vec2 u, AdvDraw u) +        -> (Vec2 u, AdvDraw u) +        -> (Vec2 u, AdvDraw u)+appendW (v0,pf0) (v1,pf1) = let pf = \pt -> pf0 pt `mappend` pf1 (pt .+^ v0)+                            in (v0 ^+^ v1, pf) + -- | Primitive combination. --  -- Move second object by the advance vector of the first. Sum --- both advance vecots.+-- both advance vectors. -- advplus :: Num u => AdvObject u -> AdvObject u -> AdvObject u advplus a b = AdvObject body   where -    body = drawingCtx >>= \ctx ->-           let (v0,pf0) = runCF ctx (getAdvObject a)-               (v1,pf1) = runCF ctx (getAdvObject b)-               pf       = \pt -> pf0 pt `oplus` pf1 (pt .+^ v0)-           in return (v0 ^+^ v1, pf)+    body = askDC >>= \ctx ->+           let ans1 = runQuery ctx (getAdvObject a)+               ans2 = runQuery ctx (getAdvObject b)+           in return (appendW ans1 ans2) +++ -- Helper for list concatenation. --  listcat :: InterpretUnit u          => (AdvObject u -> AdvObject u -> AdvObject u)         -> [AdvObject u] -> AdvObject u-listcat _ []     = emptyAdvObject+listcat _ []     = mempty listcat op (x:xs) = go x xs   where     go acc []     = acc@@ -186,13 +247,9 @@ -- object.  -- advspace :: Num u => Vec2 u -> AdvObject u -> AdvObject u -> AdvObject u-advspace sep a b = AdvObject body-  where -    body = drawingCtx >>= \ctx ->-           let (v0,pf0) = runCF ctx (getAdvObject a)-               (v1,pf1) = runCF ctx (getAdvObject b)-               pf       = \pt -> pf0 pt `oplus` pf1 (displaceVec (sep ^+^ v0) pt)-           in return (v0 ^+^ sep ^+^ v1, pf)+advspace sep a b = a `advplus` blank `advplus` b+  where+    blank = blankAdvObject sep  -- | List version of 'nextSpace'. --@@ -223,8 +280,8 @@ advfill :: Num u => Vec2 u -> AdvObject u -> AdvObject u advfill sv a = AdvObject body   where -    body = drawingCtx >>= \ctx ->-           let (_,pf) = runCF ctx (getAdvObject a) in return (sv, pf)-+    body = askDC >>= \ctx ->+           let (_,df) = runQuery ctx (getAdvObject a)+           in return (sv,df)  

@@ -21,47 +21,43 @@ module Wumpus.Basic.Kernel.Objects.Basis   ( -    LocQuery-  , LocThetaQuery-  , ConnectorQuery +    PrimW(..)+  , primAnswer -  , GraphicAns-  , ImageAns(..)+  , Image+  , Graphic  -  , graphicAns-  , mapAns-  , replaceAns-  , ignoreAns-  , answer-  , hyperlink  -  , clipObject -  -  , szconvAnsF-  , szconvAnsZ+  , Query +  , DImage+  , DGraphic -  , at-  , incline-  , atIncline-  , connect+  , runImage+  , runQuery+  , zapQuery -  , replaceAnsR0-  , replaceAnsR1-  , replaceAnsR2+  , primGraphic+  , clipImage -  , decorateR0-  , decorateR1-  , decorateR2+  , UConvert(..)+  , uconvImageF+  , uconvImageZ -  , elaborateR0-  , elaborateR1-  , elaborateR2-  +  , emptyImage ++  , both++  , ignoreAns+  , replaceAns++  , Decorate(..)++   ) where  import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.ContextFun+import Wumpus.Basic.Kernel.Base.DrawingContext import Wumpus.Basic.Kernel.Base.WrappedPrimitive  import Wumpus.Core                              -- package: wumpus-core@@ -71,494 +67,360 @@ import Data.Monoid  -type LocQuery u a               = CF (Point2 u -> a)-type LocThetaQuery u a          = CF (Point2 u -> Radian -> a)-type ConnectorQuery u a         = CF (Point2 u -> Point2 u -> a) +-- | Unit @u@ is a phantom.+--+data PrimW u a = PrimW CatPrim a --- Design note - GraphicAns needs a unit for consistency even --- though it is never scrutinized.--- +type instance DUnit (PrimW u a) = u  -data ImageAns u a = Ans CatPrim a+instance Monoid a => Monoid (PrimW u a) where+  mempty = PrimW mempty mempty+  PrimW ca a `mappend` PrimW cb b = PrimW (ca `mappend` cb) (a `mappend` b) -type GraphicAns u = ImageAns u (UNil u)+instance Functor (PrimW u) where+  fmap f (PrimW w a) = PrimW w (f a)  +instance Applicative (PrimW u) where+  pure a                        = PrimW mempty a+  (PrimW c1 f) <*> (PrimW c2 a) = PrimW (c1 `mappend` c2) (f a)  -type instance DUnit (ImageAns u a) = u +instance Monad (PrimW u) where+  return a            = PrimW mempty a+  (PrimW c1 a) >>= mf = let (PrimW c2 b) = mf a+                        in PrimW (c1 `mappend` c2) b ------------------------------------------------------------------------------------ OPlus and monoid +primAnswer :: PrimW u a -> a+primAnswer (PrimW _ a) = a -instance OPlus a => OPlus (ImageAns u a) where-  Ans cp0 a `oplus` Ans cp1 b = Ans (cp0 `oplus` cp1) (a `oplus` b) +-- | For the moment the second fun is type preserving...+--+bimapPrimW :: (CatPrim -> CatPrim) -> (a -> a) -> PrimW u a -> PrimW u a+bimapPrimW f g (PrimW ca a) = PrimW (f ca) (g a) -instance Monoid a => Monoid (ImageAns u a) where-  mempty                        = Ans mempty mempty-  Ans cp0 a `mappend` Ans cp1 b = Ans (cp0 `mappend` cp1) (a `mappend` b)  ------------------------------------------------------------------------------------ Affine instances  --- --- Design Note------ Translate and RotateAbout require the unit to be /scalar/ --- e.g. Double, Centimeter, Pica.------ This is annoying and a limitation, but an alternative would--- need access to current-font-size which cannot be a pure --- function.---  -instance Rotate a => Rotate (ImageAns u a) where-  rotate ang (Ans cp a) = Ans (rotate ang cp) (rotate ang a)  -instance (RotateAbout a, ScalarUnit u, u ~ DUnit a) => -    RotateAbout (ImageAns u a) where-  rotateAbout ang pt@(P2 x y) (Ans cp a) = -    Ans (rotateAbout ang (P2 (toPsPoint x) (toPsPoint y)) cp)-        (rotateAbout ang pt a) -        ---instance Scale a => Scale (ImageAns u a) where-  scale sx sy (Ans cp a) = Ans (scale sx sy cp) (scale sx sy a)+-- | Convert a PrimW where the answer is some functor type +-- parametrized by the unit.+--+szconvPrimF :: (Functor t, InterpretUnit u, InterpretUnit u1)+            => FontSize -> PrimW u (t u)  -> PrimW u1 (t u1)+szconvPrimF sz (PrimW c a) = PrimW c (uconvertF sz a)  -instance (Translate a, ScalarUnit u, u ~ DUnit a) => -    Translate (ImageAns u a) where-  translate dx dy (Ans cp a) = -    Ans (translate (toPsPoint dx) (toPsPoint dy) cp) (translate dx dy a) +-- | Convert a PrimW where the answer is oblivious to unit.+--+szconvPrimZ :: (InterpretUnit u, InterpretUnit u1)+            => FontSize -> PrimW u a  -> PrimW u1 a+szconvPrimZ _ (PrimW c a) = PrimW c a   --------------------------------------------------------------------------------  +newtype Image u a = Image { +          getImage :: DrawingContext -> PrimW u a } --- | Map the answer produced by a graphic object.------ Note - the new answer must share the same unit type as the--- initial answer, although it does not need to have the same--- wrapper type.----mapAns :: (a -> a1) -> ImageAns u a -> ImageAns u a1-mapAns f (Ans cp a) = Ans cp (f a) +type instance DUnit (Image u a) = u +type Graphic u = Image u (UNil u)  --- | Replace the answer produced by a graphic object.+-- | Type specialized version of 'Image'. ----- Note - the new answer must share the same unit type as the--- initial answer, although it does not need to have the same--- wrapper type.+type DImage a       = Image Double a++-- | Type specialized version of 'Graphic'. ---replaceAns :: ans -> ImageAns u a -> ImageAns u ans-replaceAns ans (Ans prim _) = Ans prim ans+type DGraphic       = Graphic Double   --- | Turn an imageAns into a GraphicAns by ignoring the --- result.--- --- Usually this function will be used with one of the @push@ --- family of combinators.------ > LocImage-to-LocGraphic = pushR1 ignoreAns ----ignoreAns :: ImageAns u a -> GraphicAns u-ignoreAns(Ans prim _) = Ans prim UNil+newtype Query u a = Query { +          getQuery :: DrawingContext -> a } +type instance DUnit (Query u a) = u +-- Functor -graphicAns :: CatPrim -> GraphicAns u-graphicAns prim = Ans prim UNil+instance Functor (Image u) where+  fmap f ma = Image $ \ctx -> fmap f $ getImage ma ctx --- | Extractor for the answer part of an image.----answer :: ImageAns u a -> a-answer (Ans _ a) = a+instance Functor (Query u) where+  fmap f ma = Query $ \ctx -> f $ getQuery ma ctx +-- Applicative --- | Note - maybe this requires an arity family instead?----hyperlink :: XLink -> ImageAns u a -> ImageAns u a-hyperlink hypl (Ans prim a) = Ans (cpmap (xlinkPrim hypl) prim) a+instance Applicative (Image u) where+  pure a    = Image $ \_   -> pure a+  mf <*> ma = Image $ \ctx -> +                getImage mf ctx <*> getImage ma ctx +instance Applicative (Query u) where+  pure a    = Query $ \_   -> a+  mf <*> ma = Query $ \ctx -> let f = getQuery mf ctx +                                  a = getQuery ma ctx+                              in f a --- | Clip a graphic object.--- --- Note - maybe this requires an arity family instead?----clipObject :: PrimPath -> ImageAns t u -> ImageAns t u-clipObject pp (Ans prim a) =  Ans (cpmap (clip pp) prim) a +-- Monad ------------------------------------------------------------------------------------ Helpers for unit conversion...+instance Monad (Image u) where+  return a = Image $ \_ -> return a+  ma >>= k = Image $ \ctx -> getImage ma ctx >>= \ans -> getImage (k ans) ctx  +instance Monad (Query u) where+  return a = Query $ \_   -> a+  ma >>= k = Query $ \ctx -> let a = getQuery ma ctx in getQuery (k a) ctx -szconvAnsF :: (Functor t, InterpretUnit u, InterpretUnit u1) -                => FontSize -> ImageAns u (t u) -> ImageAns u1 (t u1)-szconvAnsF sz (Ans prim a) = Ans prim (uconvertF sz a)+-- Monoid -szconvAnsZ :: FontSize -> ImageAns u a -> ImageAns u1 a-szconvAnsZ _ (Ans prim a) = Ans prim a+instance Monoid a => Monoid (Image u a) where+  mempty          = pure mempty+  ma `mappend` mb = Image $ \ctx -> +                      getImage ma ctx `mappend` getImage mb ctx +instance Monoid a => Monoid (Query u a) where+  mempty          = pure mempty+  ma `mappend` mb = Query $ \ctx -> +                      getQuery ma ctx `mappend` getQuery mb ctx  -infixr 1 `at`+-- DrawingCtxM  --- | Downcast a 'LocCF' function by applying it to the supplied --- point, making an arity-zero Context Function. --- --- Remember a 'LocCF' function is a 'CF1' context function where--- the /static argument/ is specialized to a start point.----at :: LocQuery u a -> Point2 u -> CF a-at = apply1R1+instance DrawingCtxM (Image u) where+  askDC           = Image $ \ctx -> return ctx+  asksDC fn       = Image $ \ctx -> return (fn ctx)+  localize upd ma = Image $ \ctx -> getImage ma (upd ctx) +instance DrawingCtxM (Query u) where+  askDC           = Query $ \ctx -> ctx+  asksDC fn       = Query $ \ctx -> (fn ctx)+  localize upd ma = Query $ \ctx -> getQuery ma (upd ctx)  -infixr 1 `incline`+runImage :: DrawingContext -> Image u a -> PrimW u a+runImage ctx mf = getImage mf ctx +runQuery :: DrawingContext -> Query u a -> a+runQuery ctx mf = getQuery mf ctx --- | Downcast a 'LocThetaQuery' function by applying it to the --- supplied angle, making an arity-one Context Function (a --- 'LocCF'). --- -incline :: LocThetaQuery u a -> Radian -> LocQuery u a-incline = apply1R2  --- | Downcast a LocThetaQuery function by applying it to the --- supplied point and angle, making an arity-zero Context Function --- (a CF). +zapQuery :: Query u a -> Image u a+zapQuery mq = askDC >>= \ctx -> let a = runQuery ctx mq in return a++-- | Constructor for Primtive graphics. ---atIncline :: LocThetaQuery u a -> Point2 u -> Radian -> CF a-atIncline = apply2R2+primGraphic :: CatPrim -> Graphic u+primGraphic ca = Image $ \_ -> PrimW ca UNil  --- | Downcast a 'ConnectorQuery' function by applying it to the --- start and end point, making an arity-zero Context Function --- (a 'CF'). +-- | Clip an Image. -- -connect :: ConnectorQuery u a -> Point2 u -> Point2 u -> CF a-connect = apply2R2+clipImage :: PrimPath -> Image u a -> Image u a+clipImage pp ma = Image $ \ctx -> step (getImage ma ctx)+  where+    step (PrimW ca a) = PrimW (cpmap (clip pp) ca) a   --- | Replace the ans - arity 0.--- -replaceAnsR0 :: ans -> CF (ImageAns u a) -> CF (ImageAns u ans)-replaceAnsR0 ans = fmap (replaceAns ans)+class UConvert (f :: * -> * -> *) where+  uconvF :: (Functor t, InterpretUnit u, InterpretUnit u1) +         => f u (t u) -> f u1 (t u1) +  uconvZ :: (InterpretUnit u, InterpretUnit u1) +         => f u a -> f u1 a --- | Replace the ans - arity 1.----replaceAnsR1 :: ans -> CF (r1 -> ImageAns u a) -> CF (r1 -> ImageAns u ans)-replaceAnsR1 ans = fmap $ fmap (replaceAns ans)+instance UConvert Image where+  uconvZ = uconvImageZ+  uconvF = uconvImageF +uconvImageF :: (Functor t, InterpretUnit u, InterpretUnit u1) +            => Image u (t u) -> Image u1 (t u1) +uconvImageF ma = Image $ \ctx -> +                   let sz  = dc_font_size ctx+                       ans = getImage ma ctx+                   in szconvPrimF sz ans --- | Replace the ans - arity 2.----replaceAnsR2 :: ans -             -> CF (r1 -> r2 -> ImageAns u a) -             -> CF (r1 -> r2 -> ImageAns u ans)-replaceAnsR2 ans = fmap $ fmap $ fmap (replaceAns ans)  +uconvImageZ :: (InterpretUnit u, InterpretUnit u1) +            => Image u a -> Image u1 a+uconvImageZ ma = Image $ \ctx -> +                   let sz  = dc_font_size ctx+                       ans = getImage ma ctx+                   in szconvPrimZ sz ans --- | Decorate an Image by superimposing a Graphic.------ Note - this function has a very general type signature and--- supports various graphic types:----decorateR0 :: CF (ImageAns u a) -> CF (GraphicAns u) -> CF (ImageAns u a) -decorateR0 img gf = op <$> img <*> gf-  where-    op (Ans cp a) (Ans cp1 _) = Ans (cp `oplus` cp1) a +-- | Having /empty/ at the specific 'Image' type is useful.+-- +emptyImage :: Monoid a => Image u a+emptyImage = mempty -decorateR1 :: CF (r1 -> ImageAns u a) -           -> CF (r1 -> GraphicAns u) -           -> CF (r1 -> ImageAns u a) -decorateR1 img gf = promoteR1 $ \r1 ->-    op <$> apply1R1 img r1 <*> apply1R1 gf r1-  where-    op (Ans cp a) (Ans cp1 _) = Ans (cp `oplus` cp1) a+--------------------------------------------------------------------------------  -decorateR2 :: CF (r1 -> r2 -> ImageAns u a) -           -> CF (r1 -> r2 -> GraphicAns u) -           -> CF (r1 -> r2 -> ImageAns u a) -decorateR2 img gf = promoteR2 $ \r1 r2 ->-    op <$> apply2R2 img r1 r2 <*> apply2R2 gf r1 r2-  where-    op (Ans cp a) (Ans cp1 _) = Ans (cp `oplus` cp1) a+both :: Applicative f => f a -> f b -> f (a,b)+both fa fb = (,) <$> fa <*> fb  --- | Decorate an Image by superimposing a Graphic.+-- | Note - the kind of f allows fo unit annotation. ----- Note - this function has a very general type signature and--- supports various graphic types:+ignoreAns :: Functor (f u) => f u a -> f u (UNil u)+ignoreAns = fmap (const UNil)++-- | Replace the answer produced by a graphic object. ---elaborateR0 :: CF (ImageAns u a) -> (a -> CF (GraphicAns u)) -> CF (ImageAns u a) -elaborateR0 img gf = -    img  >>= \(Ans p1 a) ->-    gf a >>= \(Ans p2 _) -> -    return $ Ans (p1 `oplus` p2) a+replaceAns :: Functor (f u) => a -> f u z -> f u a+replaceAns a = fmap (const a)    --- | Decorate an Image by superimposing a Graphic.+-- | Decorate an object ----- Note - this function has a very general type signature and--- supports various graphic types:+-- oliterate - drops the graphic from the first object replacing +-- it with the graphic from the second. ---elaborateR1 :: CF (r1 -> ImageAns u a) -            -> (a -> CF (r1 -> GraphicAns u)) -            -> CF (r1 -> ImageAns u a) -elaborateR1 img gf = promoteR1 $ \r1 -> -    apply1R1 img r1    >>= \(Ans p1 a) ->-    apply1R1 (gf a) r1 >>= \(Ans p2 _) -> -    return $ Ans (p1 `oplus` p2) a----elaborateR2 :: CF (r1 -> r2 -> ImageAns u a) -            -> (a -> CF (r1 -> r2 -> GraphicAns u)) -            -> CF (r1 -> r2 -> ImageAns u a) -elaborateR2 img gf = promoteR2 $ \r1 r2 -> -    apply2R2 img r1 r2    >>= \(Ans p1 a) ->-    apply2R2 (gf a) r1 r2 >>= \(Ans p2 _) -> -    return $ Ans (p1 `oplus` p2) a--+class Decorate (f :: * -> * -> *) where+  decorate   :: f u a -> f u z -> f u a+  elaborate  :: f u a -> (a -> f u z) -> f u a+  obliterate :: f u a -> f u z -> f u a+  hyperlink  :: XLink -> f u a -> f u a  -{----- Not exported - thanks to Max Bollingbroke.+-- | Do not export... ---type family   GuardEqAns a b :: *-type instance GuardEqAns a a = a+getCatPrim :: PrimW u a -> CatPrim+getCatPrim (PrimW ca _) = ca --- | An Image always returns a pair of some polymorphic answer @a@--- and a PrimGraphic.+-- | Should a decoration \"lift\" a query (Pure) to an image (PrimW)?  ---data ImageAns t u       = Ans (t u) CatPrim+-- Currently I don\'t think it should.+--+decorateImage :: Image u a -> Image u z -> Image u a+decorateImage ma mb = Image $ \ctx -> +    step (getImage ma ctx) (getImage mb ctx)+  where+    step (PrimW ca a) (PrimW cb _) = PrimW (ca `mappend` cb) a -type instance DUnit (ImageAns t u) = GuardEqAns u (DUnit (t u)) -type GraphicAns u       = ImageAns UNil u+-- |+--+elaborateImage :: Image u a -> (a -> Image u z) -> Image u a+elaborateImage ma k = Image $ \ ctx -> case getImage ma ctx of +    PrimW ca a -> let cb = getCatPrim $ getImage (k a) ctx +                  in PrimW (ca `mappend` cb) a +obliterateImage :: Image u a -> Image u z -> Image u a+obliterateImage ma mb = Image $ \ctx -> +    let a  = primAnswer $ getImage ma ctx+        ca = getCatPrim $ getImage mb ctx+    in PrimW ca a+  +hyperlinkImage :: XLink -> Image u a -> Image u a+hyperlinkImage xl ma = Image $ \ctx -> step (getImage ma ctx)+  where+    step (PrimW ca a) = PrimW (cpmap (xlinkPrim xl) ca) a -instance Functor t => Functor (ImageAns t) where-  fmap f (Ans a prim) = Ans (fmap f a) prim -instance OPlus (t u) => OPlus (ImageAns t u) where-  Ans a p1 `oplus` Ans b p2 = Ans (a `oplus` b) (p1 `oplus` p2) -+instance Decorate Image where+  decorate    = decorateImage+  elaborate   = elaborateImage  +  obliterate  = obliterateImage+  hyperlink   = hyperlinkImage+   -------------------------------------------------------------------------------- -- Affine instances   --  -- Design Note ----- Translate and RotateAbout require the unit to be /scalar/ --- e.g. Double, Centimeter, Pica.------ This is annoying and a limitation, but an alternative would--- need access to current-font-size which cannot be a pure --- function.+-- Are PrimW instances needed as Image cannot use them? --  -instance Rotate (t u) => Rotate (ImageAns t u) where-  rotate ang (Ans a p) = Ans (rotate ang a) (rotate ang p)+instance Rotate a => Rotate (PrimW u a) where+  rotate ang (PrimW ca a) = PrimW (rotate ang ca) (rotate ang a)  -instance (RotateAbout (t u), ScalarUnit u, u ~ DUnit (t u)) => -    RotateAbout (ImageAns t u) where-  rotateAbout ang pt@(P2 x y) (Ans a p) = -    Ans (rotateAbout ang pt a) -        (rotateAbout ang (P2 (toPsPoint x) (toPsPoint y)) p)+instance (RotateAbout a, ScalarUnit u, u ~ DUnit a) => +    RotateAbout (PrimW u a) where+  rotateAbout ang pt@(P2 x y) (PrimW ca a) = +    PrimW (rotateAbout ang (P2 (toPsPoint x) (toPsPoint y)) ca)+          (rotateAbout ang pt a) +          -instance Scale (t u) => Scale (ImageAns t u) where-  scale sx sy (Ans a p) = Ans (scale sx sy a) (scale sx sy p)+instance Scale a => Scale (PrimW u a) where+  scale sx sy (PrimW ca a) = PrimW (scale sx sy ca) (scale sx sy a)  -instance (Translate (t u), ScalarUnit u, u ~ DUnit (t u)) => -    Translate (ImageAns t u) where-  translate dx dy (Ans a p) = -    Ans (translate dx dy a) (translate (toPsPoint dx) (toPsPoint dy) p)+instance (Translate a, ScalarUnit u, u ~ DUnit a) => +    Translate (PrimW u a) where+  translate dx dy (PrimW cp a) = +    PrimW (translate (toPsPoint dx) (toPsPoint dy) cp) (translate dx dy a)   --------------------------------------------------------------------------------- +-- Image+-- Cannot use /fmap/ as it does not touch the CatPrim (w) --- | Ignore the answer produced by an Image (or LocImage, etc.)--- and form a Graphic instead.----ignoreAns :: Functor f-          => cf (ImageAns t u) -> cf (GraphicAns u)-ignoreAns = fmap (\(Ans _ prim) -> Ans UNil prim) +instance Rotate a => Rotate (Image u a) where+  rotate ang ma = Image $ \ctx -> +      bimapPrimW (rotate ang) (rotate ang) $ getImage ma ctx  --- | Replace the answer produced by a graphic object.------ Note - the new answer must share the same unit type as the--- initial answer, although it does not need to have the same--- wrapper type.----replaceAns :: Functor cf-          => t1 u -> cf (ImageAns t u) -> cf (ImageAns t1 u)-replaceAns ans = fmap (\(Ans _ prim) -> Ans ans prim)+instance (RotateAbout a, InterpretUnit u, u ~ DUnit a) => +    RotateAbout (Image u a) where+  rotateAbout ang pt ma = Image $ \ctx -> +      let ptu = uconvertF (dc_font_size ctx) pt+      in bimapPrimW (rotateAbout ang ptu) (rotateAbout ang pt) $ getImage ma ctx  --- | Map the answer produced by a graphic object.------ Note - the new answer must share the same unit type as the--- initial answer, although it does not need to have the same--- wrapper type.----mapAns :: Functor cf-       => (t u -> t1 u) -> cf (ImageAns t u) -> cf (ImageAns t1 u)-mapAns f = fmap (trafoImageAns f id) +instance Scale a => Scale (Image u a) where+  scale sx sy ma = Image $ \ctx -> +      bimapPrimW (scale sx sy) (scale sx sy) $ getImage ma ctx +instance (Translate a, InterpretUnit u, u ~ DUnit a) => +    Translate (Image u a) where+  translate dx dy ma = Image $ \ctx -> +      let sz  = dc_font_size ctx+          ddx = uconvert1 sz dx+          ddy = uconvert1 sz dy+      in bimapPrimW (translate ddx ddy) (translate dx dy) $ getImage ma ctx  --- | Transform both the answer produced by a graphic object and --- transform the primitive drawing.------ Note - the new answer must share the same unit type as the--- initial answer, although it does not need to have the same--- wrapper type. Also this function is specifically exposed to--- enable affine transofrmations - it is not expected to be --- generally useful.----trafoImageAns :: (t u -> t1 u) -> (CatPrim -> CatPrim) -              -> ImageAns t u -> ImageAns t1 u-trafoImageAns f g (Ans a prim) = Ans (f a) (g prim)+--------------------------------------------------------------------------------  --- | Decorate an Image by superimposing a Graphic.------ Note - this function has a very general type signature and--- supports various graphic types:------ > decorate :: Image u a -> Graphic u -> Image u a--- > decorate :: LocImage u a -> LocGraphic u -> LocImage u a--- > decorate :: LocThetaImage u a -> LocThetaGraphic u -> LocTheteImage u a----decorate :: Monad cf-         => cf (ImageAns t u) -> cf (GraphicAns u) -> cf (ImageAns t u) -decorate img gf = combind const img (const gf)   --- | Ante-decorate - version of 'decorate' where the decoration is --- drawn behind the Image.----adecorate :: Monad cf-          => cf (ImageAns t u) -> cf (GraphicAns u) -> cf (ImageAns t u) -adecorate img gf = acombind const img (const gf) ---- | Version of 'elaborate' where the decorating Graphic has access --- to the result produced by the Image.------ Again, this function has a very general type signature and--- supports various graphic types:------ > elaborate :: Image u a -> Graphic u -> Image u a--- > elaborate :: LocImage u a -> LocGraphic u -> LocImage u a--- > elaborate :: LocThetaImage u a -> LocThetaGraphic u -> LocTheteImage u a----elaborate :: Monad cf -          => cf (ImageAns t u) -          -> (t u -> cf (GraphicAns u)) -          -> cf (ImageAns t u)-elaborate img gf = combind const img gf+{- --- | Ante-elaborate - version of 'elaborate' where the decoration --- is drawn behind the Image.----aelaborate :: Monad cf -           => cf (ImageAns t u) -> (t u -> cf (GraphicAns u)) -> cf (ImageAns t u)-aelaborate img gf = acombind const img gf+-- OLD STUFF  --- | Hyperlink a graphic object.--- --- This function has a very general type signature and supports --- various graphic types:------ > hyperlink :: XLink -> Graphic u -> Graphic u--- > hyperlink :: XLink -> Image u a -> Image u a--- > hyperlink :: XLink -> LocImage u a -> LocImage u a--- > hyperlink :: XLink -> LocThetaImage u a -> LocThetaImage u a+-- | Downcast a LocThetaQuery function by applying it to the +-- supplied point and angle, making an arity-zero Context Function +-- (a CF).  ---hyperlink :: Functor cf -          => XLink -> cf (ImageAns t u) -> cf (ImageAns t u)-hyperlink hypl = -    fmap (\(Ans a prim) -> Ans a (cpmap (xlinkPrim hypl) prim))----- | Clip a graphic object.--- -clipObject :: Functor cf -           => PrimPath -> cf (ImageAns t u) -> cf (ImageAns t u)-clipObject pp = -    fmap (\(Ans a prim) -> Ans a (cpmap (clip pp) prim))-+atIncline :: LocThetaQuery u a -> Point2 u -> Radian -> CF a+atIncline = apply2R2   --- | This is a very general monadic combiner.--- --- The first argument is a pure combiner cf. @liftM2@, @liftA2@--- --- The second argument is an Image to be evaluated.------ The third argument, uses the ouput from the first Image to --- build a second Image.--- --- The function concatenates the CatPrims formed by both Images--- and uses the pure combiner to build an answer from the--- intermediate answers.------ NOTE - note useful with CF representation change.----combind :: Monad cf -        => (t1 u -> t2 u -> t3 u)-        -> cf (ImageAns t1 u) -        -> (t1 u -> cf (ImageAns t2 u)) -        -> cf (ImageAns t3 u) -combind op gf fn = gf   >>= \(Ans a p1) -> -                   fn a >>= \(Ans b p2) -> -                   return $ Ans (a `op` b) (p1 `oplus` p2)----- | Version of combind where the drawing order is flipped.----acombind :: Monad cf -         => (t1 u -> t2 u -> t3 u)-         -> cf (ImageAns t1 u) -         -> (t1 u -> cf (ImageAns t2 u)) -         -> cf (ImageAns t3 u) -acombind op gf fn = gf   >>= \(Ans a p1) -> -                    fn a >>= \(Ans b p2) -> -                    return $ Ans (a `op` b) (p2 `oplus` p1)- -}+

@@ -10,12 +10,8 @@ -- Stability   :  highly unstable -- Portability :  GHC  ----- Bounded versions of Graphic and LocGraphic.------ Bounded meaning they are actually Images that return the --- bounding box of the Graphic.--- --- These abojects are type synonyms.+-- Helpers for working with Images and LocImages that produce+-- bounding boxes. -- -------------------------------------------------------------------------------- @@ -23,19 +19,18 @@   (  -  -- * Bounded graphic / loc graphic+  -- * Type synonyms     BoundedGraphic-  , DBoundedGraphic   , BoundedLocGraphic-  , DBoundedLocGraphic   , BoundedLocThetaGraphic-  , DBoundedLocThetaGraphic +  -- * Bounding box graphic helpers+  , centerOrthoBBox +   , emptyBoundedLocGraphic   , emptyBoundedLocThetaGraphic -  , centerOrthoBBox    , illustrateBoundedGraphic   , illustrateBoundedLocGraphic@@ -46,52 +41,25 @@   ) where  import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.ContextFun import Wumpus.Basic.Kernel.Base.DrawingContext import Wumpus.Basic.Kernel.Base.UpdateDC import Wumpus.Basic.Kernel.Objects.Basis 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.Core                              -- package: wumpus-core +import Data.Monoid  -------------------------------------------------------------------------------- --- | Graphic with a bounding box.--- -type BoundedGraphic u      = Image u (BoundingBox u) -type DBoundedGraphic       = BoundedGraphic Double------- | LocGraphic with a bounding box.----type BoundedLocGraphic u      = LocImage u (BoundingBox u)--type DBoundedLocGraphic       = BoundedLocGraphic Double----- | LocThetaGraphic with a bounding box.------ Note the size of bounding box for the \"same\" shape will vary --- according to the rotation. A bounding box is always --- orthonormal (?) to the x- and y-axes.---+type BoundedGraphic u           = Image u (BoundingBox u)+type BoundedLocGraphic u        = LocImage u (BoundingBox u) type BoundedLocThetaGraphic u   = LocThetaImage u (BoundingBox u) -type DBoundedLocThetaGraphic    = BoundedLocThetaGraphic Double ------ -- | 'centerOrthoBBox' : @ theta * bbox -> BBox @ --  -- Rotate a bounding box by @theta@ about its center. Take the @@ -110,37 +78,32 @@     ps  = boundaryCornerList bb  --- | 'emptyBoundedLocGraphic' : @ BoundedLocGraphic @------ Build an empty 'BoundedLocGraphic'.++-- | Build an empty 'LocGraphic' returning a bounding box. --  -- The 'emptyBoundedLocGraphic' is treated as a /null primitive/  -- by @Wumpus-Core@ and is not drawn, although it does generate -- the minimum bounding box with both the bottom-left and  -- upper-right corners at the implicit start point. ---emptyBoundedLocGraphic :: InterpretUnit u => BoundedLocGraphic u-emptyBoundedLocGraphic = intoLocImage fn emptyLocGraphic-  where-    fn = promoteR1 $ \pt -> return $ BBox pt pt+emptyBoundedLocGraphic :: InterpretUnit u => LocImage u (BoundingBox u)+emptyBoundedLocGraphic = promoteLoc $ \pt -> +    replaceAns (BBox pt pt) $ primGraphic mempty    --- | 'emptyBoundedLocThetaGraphic' : @ BoundedLocThetaGraphic @------ Build an empty 'BoundedLocThetaGraphic'.+-- | Build an empty 'LocThetaGraphic' returning a bounding box. -- --- The 'emptyBoundedLocThetaGraphic' is treated as a /null primitive/ --- by @Wumpus-Core@ and is not drawn, although it does generate--- the minimum bounding box with both the bottom-left and --- upper-right corners at the implicit start point (the implicit --- inclination can be ignored).+-- The 'emptyBoundedLocThetaGraphic' is treated as a +-- /null primitive/  by @Wumpus-Core@ and is not drawn, although +-- it does generate the minimum bounding box with both the +-- bottom-left and upper-right corners at the implicit start point  ---emptyBoundedLocThetaGraphic :: InterpretUnit u => BoundedLocThetaGraphic u-emptyBoundedLocThetaGraphic = intoLocThetaImage fn emptyLocThetaGraphic-  where-    fn = promoteR2 $ \pt _ -> return $ BBox pt pt+emptyBoundedLocThetaGraphic :: InterpretUnit u +                            => LocThetaImage u (BoundingBox u)+emptyBoundedLocThetaGraphic = promoteLocTheta $ \pt _ -> +    replaceAns (BBox pt pt) $ primGraphic mempty   --@@ -163,18 +126,19 @@ -- | Draw a BoundedGraphic, illustrating the bounding box. -- illustrateBoundedGraphic :: InterpretUnit u-                         => BoundedGraphic u -> BoundedGraphic u-illustrateBoundedGraphic gf = elaborateR0 gf bbrectangle+                         => Image u (BoundingBox u) -> Image u (BoundingBox u)+illustrateBoundedGraphic gf = elaborate gf bbrectangle    -- | Draw a BoundedLocGraphic, illustrating the bounding box. -- illustrateBoundedLocGraphic :: InterpretUnit u-                            => BoundedLocGraphic u -> BoundedLocGraphic u-illustrateBoundedLocGraphic gf = elaborateR1 gf fn+                            => LocImage u (BoundingBox u) +                            -> LocImage u (BoundingBox u)+illustrateBoundedLocGraphic gf = elaborate gf fn   where-    fn bb = lift0R1 (bbrectangle bb)+    fn bb = promoteLoc $ \_ ->bbrectangle bb   @@ -182,23 +146,23 @@ -- | Draw a BoundedLocThetaGraphic, illustrating the bounding box. -- illustrateBoundedLocThetaGraphic :: InterpretUnit u-                                 => BoundedLocThetaGraphic u -                                 -> BoundedLocThetaGraphic u-illustrateBoundedLocThetaGraphic gf = elaborateR2 gf fn+                                 => LocThetaImage u (BoundingBox u)+                                 -> LocThetaImage u (BoundingBox u)+illustrateBoundedLocThetaGraphic gf = elaborate gf fn   where-    fn bb = lift0R2 (bbrectangle bb)+    fn bb = promoteLocTheta $ \_ _ -> bbrectangle bb     bbrectangle :: InterpretUnit u => BoundingBox u -> Graphic u bbrectangle (BBox p1@(P2 llx lly) p2@(P2 urx ury))-    | llx == urx && lly == ury = emptyLocGraphic `at` p1+    | llx == urx && lly == ury = mempty `at` p1     | otherwise                = -        localize drawing_props $ rect1 `oplus` cross+        localize drawing_props $ rect1 `mappend` cross   where     drawing_props = cap_round . dotted_line-    rect1         = strokedRectangle (urx-llx) (ury-lly) `at` p1+    rect1         = dcRectangle STROKE (urx-llx) (ury-lly) `at` p1     cross         = straightLine p1 p2 -                      `oplus` straightLine (P2 llx ury) (P2 urx lly)+                      `mappend` straightLine (P2 llx ury) (P2 urx lly) 

@@ -25,8 +25,8 @@   , chain   , chain_   -  , linear-  , prefix+  , linearChain+  , prefixChain   , iterationScheme    , chainIterate@@ -42,16 +42,14 @@   import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.ContextFun import Wumpus.Basic.Kernel.Objects.Basis import Wumpus.Basic.Kernel.Objects.Displacement import Wumpus.Basic.Kernel.Objects.LocImage-import Wumpus.Basic.Kernel.Objects.Image import Wumpus.Basic.Utils.HList  import Wumpus.Core                              -- package: wumpus-core -+import Data.Monoid  -- In TikZ chains are finite node list and iterated (infite) points @@ -121,37 +119,36 @@     go (af,_) i (x:xs) | i > 0     = go (af `snocH` x, x) (i-1) xs     go acc    _ _                  = acc -+emptyLoc :: LocGraphic u+emptyLoc = mempty  -- | Returns the end point... ---chain :: InterpretUnit u +chain :: InterpretUnit u       => ChainAlg u -> [LocImage u a] -> LocImage u (Point2 u)-chain _   []      = promoteR1 $ \pt -> -    fmap (replaceAns pt) $ emptyLocGraphic `at` pt--chain alg fs = promoteR1 $ \pt -> -    let ps = interpChainAlg  alg pt in go1 fs pt ps +chain _   [] = promoteLoc $ \pt -> replaceAns pt (applyLoc emptyLoc pt)+chain alg fs = promoteLoc $ \pt -> +    let ps = interpChainAlg alg pt in go1 fs pt ps    where-    go1 (gf:gs) _  (p:ps)     = go (graphic_ $ gf `at` p) gs p ps-    go1 _       p0 _          = fmap (replaceAns p0) $ emptyLocGraphic `at` p0+    go1 (gf:gs) _  (p:ps)     = go (ignoreAns $ applyLoc gf p) gs p ps+    go1 _       p0 _          = replaceAns p0 $ applyLoc emptyLoc p0 -    go acc (gf:gs) _  (p:ps)  = let g1 = graphic_ $ gf `at` p-                                in go (acc `oplus` g1) gs  p ps-    go acc _       p0 _       = fmap (replaceAns p0) acc+    go acc (gf:gs) _  (p:ps)  = let g1 = ignoreAns $ applyLoc gf p+                                in go (acc `mappend` g1) gs  p ps+    go acc _       p0 _       = replaceAns p0 acc   -- | Returns no answer, just a 'LocGraphic'. chain_ :: InterpretUnit u => ChainAlg u -> [LocImage u a] -> LocGraphic u-chain_ alg xs = locGraphic_ $ chain alg xs+chain_ alg xs = fmap (const UNil) $ chain alg xs  -linear :: IterationScheme u -> ChainAlg u-linear = L1+linearChain :: IterationScheme u -> ChainAlg u+linearChain = L1 -prefix :: Int -> ChainAlg u -> ChainAlg u -> ChainAlg u-prefix n c1 c2 | n < 1     = c2-               | otherwise = PX n c1 c2+prefixChain :: Int -> ChainAlg u -> ChainAlg u -> ChainAlg u+prefixChain n c1 c2 | n < 1     = c2+                    | otherwise = PX n c1 c2   iterationScheme :: (Point2 u -> st) @@ -173,7 +170,7 @@  scHorizontal :: Num u => u -> IterationScheme u scHorizontal dx = Scheme { scheme_start = id-                         , scheme_step  = \pt -> (displaceH dx pt, pt)+                         , scheme_step  = \pt -> (displace (hvec dx) pt, pt)                          }     @@ -183,7 +180,7 @@  scVertical :: Num u => u -> IterationScheme u scVertical dy = Scheme { scheme_start = id-                       , scheme_step  = \pt -> (displaceV dy pt, pt)+                       , scheme_step  = \pt -> (displace (vvec dy) pt, pt)                        }  @@ -191,15 +188,15 @@ tableRight num_cols (col_width,row_height) =      L1 $ scStepper downF num_cols rightF   where-    downF   = displaceV $ negate row_height-    rightF  = displaceH col_width+    downF   = displace $ vvec $ negate row_height+    rightF  = displace $ hvec col_width  tableDown :: Num u => Int -> (u,u) -> ChainAlg u tableDown num_rows (col_width,row_height) =      L1 $ scStepper rightF num_rows downF   where-    downF   = displaceV $ negate row_height-    rightF  = displaceH col_width+    downF   = displace $ vvec $ negate row_height+    rightF  = displace $ hvec col_width   -- | Outer and inner steppers.@@ -223,6 +220,6 @@ scCircular radius angstart angseg = Scheme start step    where     start pt        = (pt,angstart)-    step (ogin,ang) = ((ogin,ang + angseg), displaceVec (avec ang radius) ogin)+    step (ogin,ang) = ((ogin,ang + angseg), displace (avec ang radius) ogin)  

@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies               #-} {-# OPTIONS -Wall #-}  --------------------------------------------------------------------------------@@ -24,89 +25,195 @@    , DConnectorImage    , DConnectorGraphic -   , intoConnectorImage-   , connectorGraphic_+   , ConnectorQuery -   , emptyConnectorGraphic+   , runConnectorImage+   , runConnectorQuery+   , connect -   , uconvConnectorImageF-   , uconvConnectorImageZ+   , promoteConn+   , applyConn+   , qpromoteConn+   , qapplyConn+   , zapConnectorQuery +   , emptyConnectorImage+    )     where  import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.ContextFun+import Wumpus.Basic.Kernel.Base.DrawingContext+import Wumpus.Basic.Kernel.Base.QueryDC import Wumpus.Basic.Kernel.Objects.Basis-import Wumpus.Basic.Kernel.Objects.LocImage +import Wumpus.Core                              -- package: wumpus-core  import Control.Applicative+import Data.Monoid   -- | ConnectorImage - function from DrawingContext and start and  -- end points to a polymorphic /answer/ and a graphic /primitive/. ---type ConnectorImage u a = ConnectorQuery u (ImageAns u a)+newtype ConnectorImage u a = ConnectorImage { +          getConnectorImage :: Point2 u -> Point2 u -> Image u a }  --- | ConnectorGraphic - function from DrawingContext and start and --- end points to a graphic /primitive/.----type ConnectorGraphic u = ConnectorQuery u (GraphicAns u)+type instance DUnit (ConnectorImage u a) = u  ++type ConnectorGraphic u = ConnectorImage u (UNil u)+ -- | Type specialized version of 'ConnectorImage'. ---type DConnectorImage a   = ConnectorImage Double a+type DConnectorImage a        = ConnectorImage Double a  -- | Type specialized version of 'ConnectorGraphic'. ---type DConnectorGraphic   = ConnectorGraphic Double +type DConnectorGraphic        = ConnectorGraphic Double   +newtype ConnectorQuery u a = ConnectorQuery { +          getConnectorQuery :: Point2 u -> Point2 u -> Query u a } --- | 'intoConnectorImage' : @ conn_query * conn_graphic -> LocImage @------ /Connector/ version of 'intoImage'. --- --- The 'ConnectorImage' is built as a function from an implicit --- start and end points to the answer.----intoConnectorImage :: ConnectorQuery u a-                   -> ConnectorGraphic u -                   -> ConnectorImage u a-intoConnectorImage qf ma = -    promoteR2 $ \a b -> replaceAns <$> apply2R2 qf a b <*> apply2R2 ma a b   +-- Functor  --- | /Downcast/ an 'ConnectorImage' to a 'ConnectorGraphic'.--- --- This means forgetting the answer of the Image, replacing it --- with @()@.----connectorGraphic_ :: ConnectorImage u a -> ConnectorGraphic u-connectorGraphic_ = (fmap . fmap . fmap) ignoreAns+instance Functor (ConnectorImage u) where+  fmap f ma = ConnectorImage $ \p0 p1 -> fmap f $ getConnectorImage ma p0 p1 +instance Functor (ConnectorQuery u) where+  fmap f ma = ConnectorQuery $ \p0 p1 -> fmap f $ getConnectorQuery ma p0 p1 --- | 'emptyConnectorGraphic' : @ ConnectorGraphic @++-- Applicative++instance Applicative (ConnectorImage u) where+  pure a    = ConnectorImage $ \_  _  -> pure a+  mf <*> ma = ConnectorImage $ \p0 p1 -> +                getConnectorImage mf p0 p1 <*> getConnectorImage ma p0 p1++instance Applicative (ConnectorQuery u) where+  pure a    = ConnectorQuery $ \_  _  -> pure a+  mf <*> ma = ConnectorQuery $ \p0 p1 -> +                getConnectorQuery mf p0 p1 <*> getConnectorQuery ma p0 p1+++-- Monad ++instance Monad (ConnectorImage u) where+  return a  = ConnectorImage $ \_  _  -> return a+  ma >>= k  = ConnectorImage $ \p0 p1 -> +                getConnectorImage ma p0 p1 >>= \ans -> +                getConnectorImage (k ans) p0 p1+++instance Monad (ConnectorQuery u) where+  return a  = ConnectorQuery $ \_  _  -> return a+  ma >>= k  = ConnectorQuery $ \p0 p1 -> +                getConnectorQuery ma p0 p1 >>= \ans -> +                getConnectorQuery (k ans) p0 p1+++-- Monoid++instance Monoid a => Monoid (ConnectorImage u a) where+  mempty          = pure mempty+  ma `mappend` mb = ConnectorImage $ \p0 p1 -> +                      getConnectorImage ma p0 p1 +                        `mappend` getConnectorImage mb p0 p1 +++instance Monoid a => Monoid (ConnectorQuery u a) where+  mempty          = pure mempty+  ma `mappend` mb = ConnectorQuery $ \p0 p1 -> +                      getConnectorQuery ma p0 p1 +                        `mappend` getConnectorQuery mb p0 p1 ++++-- DrawingCtxM++instance DrawingCtxM (ConnectorImage u) where+  askDC           = ConnectorImage $ \_  _  -> askDC+  asksDC fn       = ConnectorImage $ \_  _  -> asksDC fn+  localize upd ma = ConnectorImage $ \p0 p1 -> +                      localize upd (getConnectorImage ma p0 p1)++instance DrawingCtxM (ConnectorQuery u) where+  askDC           = ConnectorQuery $ \_  _  -> askDC+  asksDC fn       = ConnectorQuery $ \_  _  -> asksDC fn+  localize upd ma = ConnectorQuery $ \p0 p1 -> +                      localize upd (getConnectorQuery ma p0 p1)+++  +++instance Decorate ConnectorImage where+  decorate ma mz = ConnectorImage $ \p0 p1 -> +                      getConnectorImage ma p0 p1 `decorate` +                        getConnectorImage mz p0 p1++  elaborate ma f = ConnectorImage $ \p0 p1 -> +                     getConnectorImage ma p0 p1 `elaborate` +                       (\a -> getConnectorImage (f a) p0 p1)++  obliterate ma mz = ConnectorImage $ \p0 p1 -> +                       getConnectorImage ma p0 p1 `obliterate` +                         getConnectorImage mz p0 p1++  hyperlink xl ma = ConnectorImage $ \p0 p1 -> +                       hyperlink xl $ getConnectorImage ma p0 p1++++runConnectorImage :: Point2 u -> Point2 u +                  -> DrawingContext -> ConnectorImage u a +                  -> PrimW u a+runConnectorImage p0 p1 ctx mf = runImage ctx (getConnectorImage mf p0 p1)+++runConnectorQuery :: Point2 u -> Point2 u +                  -> DrawingContext -> ConnectorQuery u a +                  -> a+runConnectorQuery p0 p1 ctx mf = runQuery ctx (getConnectorQuery mf p0 p1)+++connect :: Point2 u -> Point2 u -> ConnectorImage u a -> Image u a+connect p0 p1 mf = getConnectorImage mf p0 p1+++++promoteConn :: (Point2 u -> Point2 u -> Image u a) -> ConnectorImage u a+promoteConn fn       = ConnectorImage $ \p0 p1 -> fn p0 p1++applyConn :: ConnectorImage u a -> Point2 u -> Point2 u -> Image u a+applyConn mf p0 p1   = getConnectorImage mf p0 p1+++qpromoteConn :: (Point2 u -> Point2 u -> Query u a) -> ConnectorQuery u a+qpromoteConn fn      = ConnectorQuery $ \p0 p1 -> fn p0 p1++qapplyConn :: ConnectorQuery u a -> Point2 u -> Point2 u -> Query u a+qapplyConn mf p0 p1   = getConnectorQuery mf p0 p1+++-- | \"zero-apply\" a Connector. ----- Build an empty 'ConnectorGraphic'.--- --- The 'emptyConnectorGraphic' is treated as a /null primitive/ by --- @Wumpus-Core@ and is not drawn, although it does generate a --- bounding box around the rectangular hull of the start and end --- points.--- -emptyConnectorGraphic :: InterpretUnit u => ConnectorGraphic u -emptyConnectorGraphic = promoteR2 $ \start end -> -    let a = emptyLocGraphic `at` start-        b = emptyLocGraphic `at` end-    in a `oplus` b+zapConnectorQuery :: ConnectorQuery u a -> Point2 u -> Point2 u -> Image u a+zapConnectorQuery mq p0 p1  = askDC >>= \ctx -> +    let a = runConnectorQuery p0 p1 ctx mq in return a   +instance UConvert ConnectorImage where+  uconvF = uconvConnectorImageF+  uconvZ = uconvConnectorImageZ   -- | Use this to convert 'ConnectorGraphic' or 'ConnectorImage' @@ -114,20 +221,35 @@ -- uconvConnectorImageF :: (InterpretUnit u, InterpretUnit u1, Functor t)                       => ConnectorImage u (t u) -> ConnectorImage u1 (t u1)-uconvConnectorImageF = uconvR2ab szconvAnsF+uconvConnectorImageF ma = ConnectorImage $ \p0 p1 -> +    getFontSize >>= \sz -> +    let p0u = uconvertF sz p0+        p1u = uconvertF sz p1+    in uconvImageF $ getConnectorImage ma p0u p1u   + -- | Use this to convert 'ConnectorImage' with unit-less answer. -- uconvConnectorImageZ :: (InterpretUnit u, InterpretUnit u1)                       => ConnectorImage u a -> ConnectorImage u1 a-uconvConnectorImageZ = uconvR2ab szconvAnsZ+uconvConnectorImageZ ma = ConnectorImage $ \p0 p1 -> +    getFontSize >>= \sz -> +    let p0u = uconvertF sz p0+        p1u = uconvertF sz p1+    in uconvImageZ $ getConnectorImage ma p0u p1u +-- | Having /empty/ at the specific 'ConnectorImage' type is useful.+-- +emptyConnectorImage :: Monoid a => ConnectorImage u a+emptyConnectorImage = mempty + --------------------------------------------------------------------------------  + -- -- Design note - potentially there are no useful combining  -- operators on Connectors (!).@@ -137,3 +259,4 @@ -- than combination. See the ConnectorPath operations in  -- Wumpus-Drawing for some examples. --+

@@ -177,9 +177,17 @@ -------------------------------------------------------------------------------- -- Monoid +-- | Avoid initial mempty for mconcat.+-- instance Monoid CtxPicture where   mempty  = CtxPicture $ \_ -> Nothing   mappend = moveSnd $ \_ _ -> V2 0 0++  mconcat []      = mempty+  mconcat (a:as)  = step a as+    where+      step ac []     = ac+      step ac (x:xs) = step (ac `mappend` x) xs   --------------------------------------------------------------------------------

@@ -19,73 +19,45 @@ module Wumpus.Basic.Kernel.Objects.Displacement   ( ++  -- * Displacement     PointDisplace-  , ThetaDisplace   , ThetaPointDisplace+  , displace +  , dispParallel+  , dispPerpendicular+  , dispOrtho -  , moveStart-  , moveStartTheta-  , moveStartThetaPoint-  , moveStartThetaIncl+  , dispDirectionTheta+  , dispCardinalTheta -  , displace-  , displaceVec-  , displaceH-  , displaceV+  -- * Named vectors -  , disp_up-  , disp_down-  , disp_left-  , disp_right+  , go_up+  , go_down+  , go_left+  , go_right -  , disp_up_left-  , disp_up_right-  , disp_down_left-  , disp_down_right+  , go_north+  , go_south+  , go_east+  , go_west+  , go_north_east+  , go_north_west+  , go_south_east+  , go_south_west   --  , disp_north-  , disp_south-  , disp_east-  , disp_west--  , disp_northeast-  , disp_northwest-  , disp_southeast-  , disp_southwest+  , go_up_left+  , go_up_right+  , go_down_left+  , go_down_right  -  , displaceParallel-  , displacePerpendicular-  , displaceOrtho--  , adisp_north-  , adisp_south-  , adisp_east-  , adisp_west  --  , adisp_northeast-  , adisp_northwest-  , adisp_southeast-  , adisp_southwest--  , centerRelative-  , left_of-  , right_of-  , above_left_of-  , above_right_of-  , below_left_of-  , below_right_of-   ) where   import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.ContextFun-import Wumpus.Basic.Kernel.Base.QueryDC-import Wumpus.Basic.Kernel.Objects.Anchors-import Wumpus.Basic.Kernel.Objects.Basis  import Wumpus.Core                              -- package: wumpus-core @@ -106,16 +78,6 @@   --- | 'ThetaDisplace' is a type representing functions --- @from Radian to Radian@.------ It is especially useful for building composite graphics where --- one part of the graphic is drawn from a different start point --- to the other part.----type ThetaDisplace = Radian -> Radian-- -- | 'ThetaPointDisplace' is a type representing functions  -- @from Radian * Point to Point@. --@@ -126,218 +88,161 @@ type ThetaPointDisplace u = Radian -> Point2 u -> Point2 u  ------------------------------------------------------------------------------------ Displacing points and inclination ----- | Move the start-point of a 'LocQuery' with the supplied --- displacement function.+-- | 'displace' : @ Vec2 -> PointDisplace @ ---moveStart :: PointDisplace u -> LocQuery u a -> LocQuery u a-moveStart f ma = domMap1 f ma------ | Move the start-point of a 'LocThetaQuery' with the supplied --- displacement function.+-- Alias for @.+^@ from @Data.AffineSpace@. ---moveStartTheta :: ThetaPointDisplace u -               -> LocThetaQuery u a -> LocThetaQuery u a-moveStartTheta f cf = consCF $ \ctx -> -    (\pt ang -> let f1 = runCF ctx cf in f1 (f ang pt) ang)+displace :: Num u => Vec2 u -> PointDisplace u+displace (V2 dx dy) (P2 x y) = P2 (x+dx) (y+dy)  --- | Move the start-point of a 'LocThetaCF' with the supplied --- displacement function.----moveStartThetaPoint :: PointDisplace u -                    -> LocThetaQuery u a -> LocThetaQuery u a-moveStartThetaPoint f = domMap2 f id  --- | Change the inclination of a 'LocThetaCF' with the supplied --- displacement function.----moveStartThetaIncl :: ThetaDisplace -> LocThetaQuery u a -> LocThetaQuery u a-moveStartThetaIncl f = domMap2 id f  ------------------------------------------------------------------------------------ PointDisplace functions --- | 'displace' : @ x -> y -> PointDisplace @------ Build a combinator to move @Points@ by the supplied @x@ and --- @y@ distances.----displace :: Num u => u -> u -> PointDisplace u-displace dx dy (P2 x y) = P2 (x+dx) (y+dy) ---- | 'displaceV' : @ (V2 x y) -> PointDisplace @--- --- Version of 'displace' where the displacement is supplied as--- a vector rather than two parameters.--- -displaceVec :: Num u => Vec2 u -> PointDisplace u-displaceVec (V2 dx dy) (P2 x y) = P2 (x+dx) (y+dy)----- | 'displaceH' : @ x -> PointDisplace @--- --- Build a combinator to move @Points@ by horizontally the --- supplied @x@ distance.----displaceH :: Num u => u -> PointDisplace u-displaceH dx (P2 x y) = P2 (x+dx) y---- | 'displaceV' : @ y -> PointDisplace @--- --- Build a combinator to move @Points@ vertically by the supplied --- @y@ distance.----displaceV :: Num u => u -> PointDisplace u-displaceV dy (P2 x y) = P2 x (y+dy)-----disp_up :: Num u => u -> PointDisplace u-disp_up = displaceV--disp_down :: Num u => u -> PointDisplace u-disp_down = displaceV . negate--disp_left :: Num u => u -> PointDisplace u-disp_left = displaceH . negate--disp_right :: Num u => u -> PointDisplace u-disp_right = displaceH----- diagonals - these are different to cardinals which have the--- hypotenuese as the dist.-----disp_up_left :: Num u => u -> PointDisplace u-disp_up_left u = displaceVec (V2 (-u) u)--disp_up_right :: Num u => u -> PointDisplace u-disp_up_right u = displaceVec (V2 u u)--disp_down_left :: Num u => u -> PointDisplace u-disp_down_left u = displaceVec (V2 (-u) (-u))--disp_down_right :: Num u => u -> PointDisplace u-disp_down_right u = displaceVec (V2 u (-u))---------- Cardinal displacement --disp_north :: Num u => u -> PointDisplace u-disp_north = displaceV---disp_south :: Num u => u -> PointDisplace u-disp_south =  displaceV . negate--disp_east :: Num u => u -> PointDisplace u-disp_east = displaceH--disp_west :: Num u => u -> PointDisplace u-disp_west = displaceH . negate--disp_northeast :: Floating u => u -> PointDisplace u-disp_northeast = displaceVec . avec (0.25 * pi)--disp_northwest ::  Floating u => u -> PointDisplace u-disp_northwest = displaceVec . avec (0.75 * pi)--disp_southeast ::  Floating u => u -> PointDisplace u-disp_southeast = displaceVec . avec (1.75 * pi)--disp_southwest ::  Floating u => u -> PointDisplace u-disp_southwest = displaceVec . avec (1.25 * pi)-- -------------------------------------------------------------------------------- -- ThetaPointDisplace functions  --- | 'displaceParallel' : @ dist -> ThetaPointDisplace @+-- | 'dispParallel' : @ dist -> ThetaPointDisplace @ --  -- Build a combinator to move @Points@ in parallel to the  -- direction of the implicit angle by the supplied distance  -- @dist@.  ---displaceParallel :: Floating u => u -> ThetaPointDisplace u-displaceParallel d = \theta pt -> pt .+^ avec (circularModulo theta) d+dispParallel :: Floating u => u -> ThetaPointDisplace u+dispParallel d = \theta pt -> pt .+^ avec (circularModulo theta) d  --- | 'displaceParallel' : @ dist -> ThetaPointDisplace @+-- | 'dispParallel' : @ dist -> ThetaPointDisplace @ --  -- Build a combinator to move @Points@ perpendicular to the  -- inclnation of the implicit angle by the supplied distance  -- @dist@.  ---displacePerpendicular :: Floating u => u -> ThetaPointDisplace u-displacePerpendicular d = +dispPerpendicular :: Floating u => u -> ThetaPointDisplace u+dispPerpendicular d =      \theta pt -> pt .+^ avec (circularModulo $ theta + (0.5*pi)) d   --- | 'displaceOrtho' : @ vec -> ThetaPointDisplace @+-- | 'dispOrtho' : @ vec -> ThetaPointDisplace @ --  -- This is a combination of @displaceParallel@ and  -- @displacePerpendicular@, with the x component of the vector -- displaced in parallel and the y component displaced -- perpendicular.  -- -displaceOrtho :: Floating u => Vec2 u -> ThetaPointDisplace u-displaceOrtho (V2 x y) = \theta -> -    displaceParallel x theta . displacePerpendicular y theta+dispOrtho :: Floating u => Vec2 u -> ThetaPointDisplace u+dispOrtho (V2 x y) = \theta -> dispParallel x theta . dispPerpendicular y theta  -adisp_north :: Floating u => u -> ThetaPointDisplace u-adisp_north = displacePerpendicular  -adisp_south :: Floating u => u -> ThetaPointDisplace u-adisp_south = displacePerpendicular . negate+-- | /Angular/ version of 'dispDirection'. +--+-- The displacement direction is with respect to implicit angle+-- of inclination, so:+--+-- > up    == perpendicular+-- > down  == perdendicular . negate+-- > left  == parallel . negate+-- > right == parallel+-- +dispDirectionTheta :: Floating u => Direction -> u -> ThetaPointDisplace u+dispDirectionTheta UP      = dispPerpendicular+dispDirectionTheta DOWN    = dispPerpendicular . negate+dispDirectionTheta LEFT    = dispParallel . negate+dispDirectionTheta RIGHT   = dispParallel  -adisp_east :: Floating u => u -> ThetaPointDisplace u-adisp_east = displaceParallel+-- | /Angular/ version of 'dispCardinal'.+--+-- The displacement direction is with respect to implicit angle+-- of inclination, so:+--+-- > north == perpendicular+-- > east  == parallel+-- > south == perdendicular . negate+-- > etc.+-- +dispCardinalTheta :: Floating u => Cardinal -> u -> ThetaPointDisplace u+dispCardinalTheta NORTH      = dispPerpendicular+dispCardinalTheta NORTH_EAST = \d ang -> displace (avec (ang + (0.25*pi)) d)+dispCardinalTheta EAST       = dispParallel+dispCardinalTheta SOUTH_EAST = \d ang -> displace (avec (ang + (1.75*pi)) d)+dispCardinalTheta SOUTH      = dispPerpendicular . negate+dispCardinalTheta SOUTH_WEST = \d ang -> displace (avec (ang + (1.25*pi)) d)+dispCardinalTheta WEST       = dispParallel . negate+dispCardinalTheta NORTH_WEST = \d ang -> displace (avec (ang + (0.75*pi)) d)  -adisp_west :: Floating u => u -> ThetaPointDisplace u-adisp_west = displaceParallel . negate+--------------------------------------------------------------------------------+-- Named vectors -adisp_northeast :: Floating u => u -> ThetaPointDisplace u-adisp_northeast d = \ang pt -> pt .+^ avec (ang + (0.25*pi)) d +go_up :: Num u => u -> Vec2 u+go_up d = V2 0 d -adisp_northwest :: Floating u => u -> ThetaPointDisplace u-adisp_northwest d = \ang pt -> pt .+^ avec (ang + (0.75*pi)) d+go_down :: Num u => u -> Vec2 u+go_down d = V2 0 (-d) +go_left :: Num u => u -> Vec2 u+go_left d = V2 (-d) 0 -adisp_southeast :: Floating u => u -> ThetaPointDisplace u-adisp_southeast d = \ang pt -> pt .+^ avec (ang + (1.75*pi)) d+go_right :: Num u => u -> Vec2 u+go_right d = V2 d 0  -adisp_southwest :: Floating u => u -> ThetaPointDisplace u-adisp_southwest d = \ang pt -> pt .+^ avec (ang + (1.25*pi)) d+go_north :: Num u => u -> Vec2 u+go_north = go_up +go_south :: Num u => u -> Vec2 u+go_south = go_down +go_east :: Num u => u -> Vec2 u+go_east = go_right +go_west :: Num u => u -> Vec2 u+go_west = go_left+++go_north_east :: Floating u => u -> Vec2 u+go_north_east = avec (0.25*pi)++go_north_west :: Floating u => u -> Vec2 u+go_north_west = avec (0.75*pi)++go_south_east :: Floating u => u -> Vec2 u+go_south_east = avec (1.75*pi)++go_south_west :: Floating u => u -> Vec2 u+go_south_west = avec (1.25*pi)+++go_up_left :: Num u => u -> Vec2 u+go_up_left d = V2 (-d) d++go_up_right :: Num u => u -> Vec2 u+go_up_right d = V2 d d++go_down_left :: Num u => u -> Vec2 u+go_down_left d = V2 (-d) (-d)++go_down_right :: Num u => u -> Vec2 u+go_down_right d = V2 d (-d)++ -------------------------------------------------------------------------------- ++{-++-- ORPHANS - need a new home...+ -- | Absolute units. --  centerRelative :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) @@ -405,3 +310,4 @@ below_left_of   = centerRelative ((-1),(-1))   +-}

@@ -28,16 +28,14 @@   , vertexPP   , curvePP -  , openStroke-  , closedStroke-  , filledPath-  , borderedPath+  , dcOpenPath+  , dcClosedPath    -- * Text-  , plainTextLine-  , rplainTextLine-  , escTextLine-  , rescTextLine+  , dcTextlabel+  , dcRTextlabel+  , dcEscapedlabel+  , dcREscapedlabel    , KernChar   , hkernLine@@ -50,41 +48,29 @@   , straightConnector    -- * Circles-  , strokedCircle-  , filledCircle-  , borderedCircle+  , dcCircle    -- * Ellipses-  , strokedEllipse-  , rstrokedEllipse-  , filledEllipse-  , rfilledEllipse-  , borderedEllipse-  , rborderedEllipse+  , dcEllipse+  , dcREllipse +   -- * Rectangles-  , strokedRectangle-  , filledRectangle-  , borderedRectangle+  , dcRectangle    -- * Disks  -  , strokedDisk-  , filledDisk-  , borderedDisk+  , dcDisk+  , dcEllipseDisk -  , strokedEllipseDisk-  , filledEllipseDisk-  , borderedEllipseDisk    ) where  import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.ContextFun import Wumpus.Basic.Kernel.Base.QueryDC import Wumpus.Basic.Kernel.Base.WrappedPrimitive import Wumpus.Basic.Kernel.Objects.Basis import Wumpus.Basic.Kernel.Objects.Connector-import Wumpus.Basic.Kernel.Objects.Image+-- import Wumpus.Basic.Kernel.Objects.Image import Wumpus.Basic.Kernel.Objects.LocImage import Wumpus.Basic.Kernel.Objects.LocThetaImage @@ -96,28 +82,62 @@ -- Helpers  -norm2 :: InterpretUnit u => u -> u -> Query (Double,Double)-norm2 a b = (,) <$> normalizeCtx a <*> normalizeCtx b+textPrim :: (RGBi -> FontAttr -> Primitive) -> Graphic u+textPrim fn = +    textAttr >>= \(rgb,attr) -> primGraphic (prim1 $ fn rgb attr)+     -makeGraphic :: Query a -> (a -> Primitive) -> Graphic u-makeGraphic qy fn = qy >>= \a -> return $ graphicAns $ prim1 $ fn a +strokePrim :: (RGBi -> StrokeAttr -> Primitive) -> Graphic u+strokePrim fn = +    strokeAttr >>= \(rgb,attr) -> primGraphic (prim1 $ fn rgb attr)+                      -makeLocGraphic :: InterpretUnit u -               => Query a -> (a -> DPoint2 -> Primitive) -> LocGraphic u-makeLocGraphic qy fn = promoteR1 $ \pt -> -    normalizeCtxF pt >>= \dpt ->-    qy >>= \a -> return $ graphicAns $ prim1 $ fn a dpt+fillPrim :: (RGBi -> Primitive) -> Graphic u+fillPrim fn = +    fillAttr >>= \rgb -> primGraphic (prim1 $ fn rgb) -makeLocThetaGraphic :: InterpretUnit u -                    => Query a -> (a -> DPoint2 -> Radian -> Primitive) -                    -> LocThetaGraphic u-makeLocThetaGraphic qy fn = promoteR2 $ \pt ang -> -    normalizeCtxF pt >>= \dpt ->-    qy >>= \a -> return $ graphicAns $ prim1 $ fn a dpt ang+fillStrokePrim :: (RGBi -> StrokeAttr -> RGBi -> Primitive) +               -> Graphic u+fillStrokePrim fn = +    borderedAttr >>= \(frgb,attr,srgb) -> +        primGraphic (prim1 $ fn frgb attr srgb)  +textLoc :: InterpretUnit u +        => (RGBi -> FontAttr -> DPoint2 -> Primitive) -> LocGraphic u+textLoc fn = promoteLoc $ \pt -> +    normalizeCtxF pt >>= \dpt -> textPrim (\rgb attr -> fn rgb attr dpt) ++strokeLoc :: InterpretUnit u+          => (RGBi -> StrokeAttr -> DPoint2 -> Primitive) -> LocGraphic u+strokeLoc fn = promoteLoc $ \pt -> +    normalizeCtxF pt >>= \dpt -> strokePrim (\rgb attr -> fn rgb attr dpt)++fillLoc :: InterpretUnit u +        => (RGBi -> DPoint2 -> Primitive) -> LocGraphic u+fillLoc fn = promoteLoc $ \pt ->+    normalizeCtxF pt >>= \dpt -> fillPrim (\rgb -> fn rgb dpt)++fillStrokeLoc :: InterpretUnit u+              => (RGBi -> StrokeAttr -> RGBi -> DPoint2 -> Primitive) +              -> LocGraphic u+fillStrokeLoc fn = promoteLoc $ \pt ->+    normalizeCtxF pt >>= \dpt -> +    fillStrokePrim (\frgb attr srgb -> fn frgb attr srgb dpt) + +++textLocTheta :: InterpretUnit u +             => (RGBi -> FontAttr -> DPoint2 -> Radian -> Primitive) +             -> LocThetaGraphic u+textLocTheta fn = promoteLocTheta $ \pt ang -> +    normalizeCtxF pt >>= \dpt -> textPrim (\rgb attr -> fn rgb attr dpt ang)++++ -------------------------------------------------------------------------------- -- Paths @@ -126,16 +146,16 @@ -- considered more /internal/. -- --- | 'locPP' : @ [next_vector] -> LocQuery PrimPath @+-- | 'locPP' : @ [next_vector] -> LocImage PrimPath @ ----- Create a path 'LocQuery' - i.e. a functional type +-- Create a path /query/ - i.e. a functional type  -- /from Point to PrimPath/. --  -- This is the analogue to 'vectorPath' in @Wumpus-Core@, but the  -- result is produced /within/ the 'DrawingContext'. -- locPP :: InterpretUnit u => [Vec2 u] -> LocQuery u PrimPath-locPP vs = promoteR1 $ \ pt  ->+locPP vs = qpromoteLoc $ \pt ->      vectorPrimPath <$> normalizeCtxF pt <*> mapM normalizeCtxF vs  @@ -143,7 +163,7 @@  -- | 'emptyLocPP' : @ (Point ~> PrimPath) @ ----- Create an empty path 'LocQuery' - i.e. a functional type +-- Create an empty path /query/ - i.e. a functional type  -- /from Point to PrimPath/. -- -- This is the analogue to 'emptyPath' in @Wumpus-Core@, but the@@ -163,7 +183,7 @@ -- This is the analogue to 'vertexPrimPath' in @Wumpus-Core@, but  -- it is polymorphic on unit. ---vertexPP :: InterpretUnit u => [Point2 u] -> Query PrimPath+vertexPP :: InterpretUnit u => [Point2 u] -> Query u PrimPath vertexPP xs = vertexPrimPath <$> mapM normalizeCtxF xs  @@ -176,66 +196,49 @@ -- This is the analogue to 'curvedPrimPath' in @Wumpus-Core@, but  -- it is polymorphic on unit. ---curvePP :: InterpretUnit u => [Point2 u] -> Query PrimPath+curvePP :: InterpretUnit u => [Point2 u] -> Query u PrimPath curvePP xs = curvedPrimPath <$> mapM normalizeCtxF xs   --------------------------------------------------------------------------------  ----- Drawing paths (stroke, fill, bordered)...+-- Drawing paths (stroke, fill, fillStroke)... -- --- | 'openStroke' : @ path -> Graphic @------ This is the analogue to 'ostroke' in @Wumpus-core@, but the --- drawing properties (colour, line width, etc.) are taken from --- the implicit 'DrawingContext'.----openStroke :: PrimPath -> Graphic u-openStroke pp = makeGraphic strokeAttr (\(rgb,attr) -> ostroke rgb attr pp) ----- | 'closedStroke' : @ path -> Graphic @+-- | 'dcOpenPath' : @ path -> Graphic @ ----- This is the analogue to 'cstroke' in @Wumpus-core@, but the --- drawing properties (colour, line width, etc.) are taken from --- the implicit 'DrawingContext'.+-- This is the analogue to the 'ostroke' function in +-- @Wumpus-Core@, but the drawing properties (colour, line width, +-- etc.) are taken from the implicit 'DrawingContext'. ---closedStroke :: PrimPath -> Graphic u-closedStroke pp = -    makeGraphic strokeAttr (\(rgb,attr) -> cstroke rgb attr pp)+dcOpenPath :: PrimPath -> Graphic u+dcOpenPath pp = strokePrim (\rgb attr -> ostroke rgb attr pp)  --- | 'filledPath' : @ path -> Graphic @--- --- This is the analogue to 'fill' in @Wumpus-core@, but the --- fill colour is taken from the implicit 'DrawingContext'.-------filledPath :: PrimPath -> Graphic u-filledPath pp = makeGraphic fillAttr (\rgb -> fill rgb pp)-                  --- | 'borderedPath' : @ path -> Graphic @------ This is the analogue to 'fillStroke' in @Wumpus-core@, but the --- drawing properties (fill colour, border colour, line width, --- etc.) are taken from the implicit 'DrawingContext'.+-- | 'dcClosedPath' : @ DrawStyle * path -> Graphic @ --+-- Draw a closed path according to the supplied DrawStyle+-- ( fill | stroke | fill_stroke). +---+-- Drawing properties (colour, line width, etc.) for the +-- respective style are taken from the implicit 'DrawingContext'. ---borderedPath :: PrimPath -> Graphic u-borderedPath pp =-    makeGraphic borderedAttr -                (\(frgb,attr,srgb) -> fillStroke frgb attr srgb pp)+dcClosedPath :: DrawStyle -> PrimPath -> Graphic u+dcClosedPath FILL        pp = fillPrim (\rgb -> fill rgb pp) +dcClosedPath STROKE      pp = strokePrim (\rgb attr -> cstroke rgb attr pp) +dcClosedPath FILL_STROKE pp = +    fillStrokePrim (\frgb attr srgb -> fillStroke frgb attr srgb pp) + -------------------------------------------------------------------------------- -- Text --- | 'plainTextLine' : @ string -> LocGraphic @+-- | 'dcTextlabel' : @ string -> LocGraphic @ --  -- Create a text 'LocGraphic' - i.e. a functional type  -- /from Point to Graphic/.@@ -246,16 +249,14 @@ -- text properties (font family, font size, colour) are taken from -- the implicit 'DrawingContext'. ---plainTextLine :: InterpretUnit u => String -> LocGraphic u-plainTextLine ss = -    makeLocGraphic textAttr -                   (\(rgb,attr) pt -> textlabel rgb attr ss pt)+dcTextlabel :: InterpretUnit u => String -> LocGraphic u+dcTextlabel ss = textLoc (\rgb attr pt -> textlabel rgb attr ss pt)     --- | 'rplainTextLine' : @ string -> LocThetaGraphic @+-- | 'dcRTextlabel' : @ string -> LocThetaGraphic @ --  -- Create a text 'LocThetaGraphic' - i.e. a functional type  -- /from Point and Angle to Graphic/.@@ -268,13 +269,12 @@ --  -- This is the analogue to 'rtextlabel' in @Wumpus-core@. ---rplainTextLine :: InterpretUnit u => String -> LocThetaGraphic u-rplainTextLine ss =-    makeLocThetaGraphic textAttr-                        (\(rgb,attr) pt ang -> rtextlabel rgb attr ss ang pt)+dcRTextlabel :: InterpretUnit u => String -> LocThetaGraphic u+dcRTextlabel ss =+    textLocTheta (\rgb attr pt ang -> rtextlabel rgb attr ss ang pt)  --- | 'escTextline' : @ escaped_text -> LocGraphic @+-- | 'dcEscapedlabel' : @ escaped_text -> LocGraphic @ --  -- Create a text 'LocGraphic' - i.e. a functional type  -- /from Point to Graphic/.@@ -285,14 +285,13 @@ -- the text properties (font family, font size, colour) are taken  -- from the implicit 'DrawingContext'. ---escTextLine :: InterpretUnit u => EscapedText -> LocGraphic u-escTextLine esc =           -    makeLocGraphic textAttr -                   (\(rgb,attr) pt -> escapedlabel rgb attr esc pt)+dcEscapedlabel :: InterpretUnit u => EscapedText -> LocGraphic u+dcEscapedlabel esc =           +    textLoc (\rgb attr pt -> escapedlabel rgb attr esc pt)   --- | 'rescTextLine' : @ escaped_text -> LocThetaGraphic @+-- | 'dcREscapedlabel' : @ escaped_text -> LocThetaGraphic @ --  -- Create a text 'LocThetaGraphic' - i.e. a functional type  -- /from Point and Angle to Graphic/.@@ -307,10 +306,9 @@ -- the text properties (font family, font size, colour) are taken  -- from the implicit 'DrawingContext'. ---rescTextLine :: InterpretUnit u => EscapedText -> LocThetaGraphic u-rescTextLine esc = -    makeLocThetaGraphic textAttr-                        (\(rgb,attr) pt ang -> rescapedlabel rgb attr esc ang pt)+dcREscapedlabel :: InterpretUnit u => EscapedText -> LocThetaGraphic u+dcREscapedlabel esc = +    textLocTheta (\rgb attr pt ang -> rescapedlabel rgb attr esc ang pt)   @@ -318,7 +316,7 @@ -- type KernChar u = (u,EscapedChar) -uconvKernChar :: InterpretUnit u => [KernChar u] -> Query [KerningChar]+uconvKernChar :: InterpretUnit u => [KernChar u] -> Query u [KerningChar] uconvKernChar = mapM mf   where     mf (u,ch) = (\u1 -> (u1,ch)) <$> normalizeCtx u@@ -337,10 +335,11 @@ -- from the implicit 'DrawingContext'. -- hkernLine :: InterpretUnit u => [KernChar u] -> LocGraphic u-hkernLine ks = uconvKernChar ks >>= body   +hkernLine ks = promoteLoc $ \pt -> +               normalizeCtxF pt >>= \dpt -> +               zapQuery (uconvKernChar ks) >>= body dpt   where-    body ans = makeLocGraphic textAttr-                  (\(rgb,attr) pt -> hkernlabel rgb attr ans pt)+    body pt ans = textPrim (\rgb attr -> hkernlabel rgb attr ans pt)   @@ -356,10 +355,11 @@ -- from the implicit 'DrawingContext'. -- vkernLine :: InterpretUnit u => [KernChar u] -> LocGraphic u-vkernLine ks = uconvKernChar ks >>= body+vkernLine ks = promoteLoc $ \pt -> +               normalizeCtxF pt >>= \dpt -> +               zapQuery (uconvKernChar ks) >>= body dpt   where-    body ans = makeLocGraphic textAttr-                  (\(rgb,attr) pt -> vkernlabel rgb attr ans pt)+    body pt ans = textPrim (\rgb attr -> vkernlabel rgb attr ans pt)  -------------------------------------------------------------------------------- -- Lines@@ -373,7 +373,7 @@ -- from the implicit 'DrawingContext'. --  straightLine :: InterpretUnit u => Point2 u -> Point2 u -> Graphic u-straightLine p1 p2 = vertexPP [p1,p2] >>= openStroke+straightLine p1 p2 = zapQuery (vertexPP [p1,p2]) >>= dcOpenPath   -- | 'locStraightLine' : @ vec_to -> LocGraphic @ @@ -389,8 +389,7 @@ -- from the implicit 'DrawingContext'. --  locStraightLine :: InterpretUnit u => Vec2 u -> LocGraphic u-locStraightLine v = promoteR1 $ \pt -> -    apply1R1 (locPP [v]) pt >>= openStroke+locStraightLine v = promoteLoc $ \pt -> zapLocQuery (locPP [v]) pt >>= dcOpenPath   @@ -405,7 +404,8 @@ --  curvedLine :: InterpretUnit u            => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Graphic u-curvedLine p0 p1 p2 p3 = curvePP [p0,p1,p2,p3] >>= openStroke+curvedLine p0 p1 p2 p3 = +    zapQuery (curvePP [p0,p1,p2,p3]) >>= dcOpenPath   @@ -419,7 +419,8 @@ -- from the implicit 'DrawingContext'. --  straightConnector :: InterpretUnit u => ConnectorGraphic u-straightConnector = promoteR2 $ \p0 p1 -> vertexPP [p0,p1] >>= openStroke+straightConnector = promoteConn $ \p0 p1 -> +    zapQuery (vertexPP [p0,p1]) >>= dcOpenPath   @@ -430,54 +431,25 @@ -- circlePath :: InterpretUnit u           => u -> LocQuery u PrimPath-circlePath r = promoteR1 $ \pt  ->+circlePath r = qpromoteLoc $ \pt ->      (\dr dpt -> curvedPrimPath $ bezierCircle dr dpt)        <$> normalizeCtx r <*> normalizeCtxF pt  ----- | 'strokedCircle' : @ radius -> LocGraphic @------ Create a stroked circle 'LocGraphic' - the implicit point is --- center. The circle is drawn with four Bezier curves. --- --- The line properties (colour, pen thickness, etc.) are taken --- from the implicit 'DrawingContext'.--- -strokedCircle :: InterpretUnit u => u -> LocGraphic u-strokedCircle r = promoteR1 $ \pt -> -    apply1R1 (circlePath r) pt >>= openStroke------- | 'filledCircle' : @ radius -> LocGraphic @+-- | 'dcCircle' : @ DrawStyle * radius -> LocGraphic @ ----- Create a filled circle 'LocGraphic' - the implicit point is +-- Create a circle 'LocGraphic' - the implicit point is  -- center. The circle is drawn with four Bezier curves.  -- --- The fill colour is taken from the implicit 'DrawingContext'.+-- The respective line or fill properties for the 'DrawStyle' are +-- taken from the implicit 'DrawingContext'. -- -filledCircle :: InterpretUnit u => u -> LocGraphic u-filledCircle r = promoteR1 $ \pt -> -    apply1R1 (circlePath r) pt >>= filledPath +dcCircle :: InterpretUnit u => DrawStyle -> u -> LocGraphic u+dcCircle style r = promoteLoc $ \pt -> +    zapLocQuery (circlePath r) pt >>= dcClosedPath style   --- | 'borderedCircle' : @ radius -> LocGraphic @------ Create a bordered circle 'LocGraphic' - the implicit point is --- center. The circle is drawn with four Bezier curves. --- --- The background fill colour and the outline stroke properties --- are taken from the implicit 'DrawingContext'.--- -borderedCircle :: InterpretUnit u => u -> LocGraphic u-borderedCircle r = promoteR1 $ \pt -> -    apply1R1 (circlePath r) pt >>= borderedPath-- -------------------------------------------------------------------------------- -- Ellipses @@ -486,7 +458,7 @@ -- ellipsePath :: InterpretUnit u              => u -> u -> LocQuery u PrimPath-ellipsePath rx ry = promoteR1 $ \pt ->+ellipsePath rx ry = qpromoteLoc $ \pt ->      (\drx dry dpt -> curvedPrimPath $ bezierEllipse drx dry dpt)        <$> normalizeCtx rx <*> normalizeCtx ry <*> normalizeCtxF pt @@ -495,13 +467,11 @@ -- rellipsePath :: InterpretUnit u              => u -> u -> LocThetaQuery u PrimPath-rellipsePath rx ry = promoteR2 $ \pt ang ->+rellipsePath rx ry = qpromoteLocTheta $ \pt ang ->     (\drx dry dpt -> curvedPrimPath $ rbezierEllipse drx dry ang dpt)        <$> normalizeCtx rx <*> normalizeCtx ry <*> normalizeCtxF pt  -- -- | 'strokedEllipse' : @ x_radius * y_radius -> LocGraphic @ -- -- Create a stroked ellipse 'LocGraphic' - the implicit point is @@ -510,70 +480,12 @@ -- The line properties (colour, pen thickness, etc.) are taken  -- from the implicit 'DrawingContext'. -- -strokedEllipse :: InterpretUnit u => u -> u -> LocGraphic u-strokedEllipse rx ry = promoteR1 $ \pt ->-   apply1R1 (ellipsePath rx ry) pt >>= closedStroke------ | 'rstrokedEllipse' : @ x_radius * y_radius -> LocThetaGraphic @------ Create a stroked ellipse 'LocThetaGraphic' - the implicit point--- is center and the angle is rotation about the center. The --- ellipse is drawn with four Bezier curves. --- --- The line properties (colour, pen thickness, etc.) are taken --- from the implicit 'DrawingContext'.--- -rstrokedEllipse :: InterpretUnit u-                => u -> u -> LocThetaGraphic u-rstrokedEllipse rx ry = promoteR2 $ \pt ang -> -    apply2R2 (rellipsePath rx ry) pt ang >>= closedStroke------- | 'filledEllipse' : @ x_radius * y_radius -> LocGraphic @------ Create a filled ellipse 'LocGraphic' - the implicit point is --- center. The ellipse is drawn with four Bezier curves. --- --- The fill colour is taken from the implicit 'DrawingContext'.--- -filledEllipse :: InterpretUnit u => u -> u -> LocGraphic u-filledEllipse rx ry = promoteR1 $ \pt -> -    apply1R1 (ellipsePath rx ry) pt >>= filledPath----- | 'rfilledEllipse' : @ x_radius * y_radius -> LocGraphic @------ Create a filled ellipse 'LocThetaGraphic' - the implicit point--- is center and the angle is rotation about the center. The --- ellipse is drawn with four Bezier curves.  --- --- The fill colour is taken from the implicit 'DrawingContext'.--- -rfilledEllipse :: InterpretUnit u => u -> u -> LocThetaGraphic u-rfilledEllipse rx ry = promoteR2 $ \pt ang ->-    apply2R2 (rellipsePath rx ry) pt ang >>= filledPath------ | 'borderedEllipse' : @ x_radius * y_radius -> LocGraphic @------ Create a bordered ellipse 'LocGraphic' - the implicit point is --- center. The ellipse is drawn with four Bezier curves. --- --- The background fill colour and the outline stroke properties --- are taken from the implicit 'DrawingContext'.--- -borderedEllipse :: InterpretUnit u => u -> u -> LocGraphic u-borderedEllipse rx ry = promoteR1 $ \pt -> -    apply1R1 (ellipsePath rx ry) pt >>= borderedPath-+dcEllipse :: InterpretUnit u => DrawStyle -> u -> u -> LocGraphic u+dcEllipse style rx ry = promoteLoc $ \pt ->+   zapLocQuery (ellipsePath rx ry) pt >>= dcClosedPath style   --- | 'rborderedEllipse' : @ x_radius * y_radius -> LocGraphic @+-- | 'dcREllipse' : @ x_radius * y_radius -> LocGraphic @ -- -- Create a bordered ellipse 'LocThetaGraphic' - the implicit point -- is center and the angle is rotation about the center. The @@ -582,14 +494,13 @@ -- The background fill colour and the outline stroke properties  -- are taken from the implicit 'DrawingContext'. -- -rborderedEllipse :: InterpretUnit u-                 => u -> u -> LocThetaGraphic u-rborderedEllipse rx ry = promoteR2 $ \pt ang -> -    apply2R2 (rellipsePath rx ry) pt ang >>= borderedPath-+dcREllipse :: InterpretUnit u+           => DrawStyle -> u -> u -> LocThetaGraphic u+dcREllipse style rx ry = promoteLocTheta $ \pt ang -> +    zapLocThetaQuery (rellipsePath rx ry) pt ang >>= dcClosedPath style  --- Note - clipping to do...+-- Note - clipping needs some higher level path object than is defined here.  -------------------------------------------------------------------------------- -- Rectangles@@ -601,6 +512,7 @@ rectanglePath w h = locPP [hvec w, vvec h, hvec (-w)]  + -- | 'strokedRectangle' : @ width * height -> LocGraphic @ -- -- Create a stroked rectangle 'LocGraphic' - the implicit point is @@ -609,41 +521,17 @@ -- The line properties (colour, pen thickness, etc.) are taken  -- from the implicit 'DrawingContext'. -- -strokedRectangle :: InterpretUnit u => u -> u -> LocGraphic u-strokedRectangle w h = promoteR1 $ \pt -> -    apply1R1 (rectanglePath w h) pt >>= closedStroke----- | 'filledRectangle' : @ width * height -> LocGraphic @------ Create a filled rectangle 'LocGraphic' - the implicit point is --- the bottom-left. --- --- The fill colour is taken from the implicit 'DrawingContext'.--- -filledRectangle :: InterpretUnit u => u -> u -> LocGraphic u-filledRectangle w h = promoteR1 $ \pt -> -    apply1R1 (rectanglePath w h) pt >>= filledPath+dcRectangle :: InterpretUnit u => DrawStyle -> u -> u -> LocGraphic u+dcRectangle style w h = promoteLoc $ \pt -> +    zapLocQuery (rectanglePath w h) pt >>= dcClosedPath style  --- | 'borderedRectangle' : @ width * height -> LocGraphic @------ Create a bordered rectangle 'LocGraphic' - the implicit point is --- bottom-left. --- --- The background fill colour and the outline stroke properties --- are taken from the implicit 'DrawingContext'.--- -borderedRectangle :: InterpretUnit u => u -> u -> LocGraphic u-borderedRectangle w h = promoteR1 $ \pt -> -    apply1R1 (rectanglePath w h) pt >>= borderedPath - --------------------------------------------------------------------------- --- | 'strokedDisk' : @ radius -> LocGraphic @+-- | 'dcDisk' : @ radius -> LocGraphic @ ----- Create a stroked circle 'LocGraphic' - the implicit point is --- the center. +-- Create a circle 'LocGraphic' - the implicit point is the +-- center.  --  -- This is a efficient representation of circles using  -- PostScript\'s @arc@ or SVG\'s @circle@ in the generated @@ -652,66 +540,28 @@ -- the shape. -- -- For stroked circles that can be adequately scaled, use --- 'strokedCircle' instead.+-- 'dcCircle' instead. ----- The line properties (colour, pen thickness, etc.) are taken --- from the implicit 'DrawingContext'.+-- The fill or stroke properties for the respective DrawStyle are+-- taken from the implicit 'DrawingContext'. -- -strokedDisk :: InterpretUnit u => u -> LocGraphic u-strokedDisk radius = -    normalizeCtx radius >>= body-  where-    body r = makeLocGraphic strokeAttr-                (\(rgb,attr) pt -> strokeEllipse rgb attr r r pt)+dcDisk :: InterpretUnit u => DrawStyle -> u -> LocGraphic u+dcDisk FILL radius = +    normalizeCtx radius >>= \r -> +    fillLoc (\rgb pt -> fillEllipse rgb r r pt) +dcDisk STROKE radius = +    normalizeCtx radius >>= \r -> +    strokeLoc (\rgb attr pt -> strokeEllipse rgb attr r r pt) +dcDisk FILL_STROKE radius = +    normalizeCtx radius >>= \r -> +    fillStrokeLoc (\frgb attr srgb pt -> fillStrokeEllipse frgb attr srgb r r pt)  --- | 'filledDisk' : @ radius -> LocGraphic @------ Create a filled circle 'LocGraphic' - the implicit point is --- the center. --- --- This is a efficient representation of circles using --- PostScript\'s @arc@ or SVG\'s @circle@ in the generated --- output. As the circle is filled rather than drawn with a --- \"pen\" a @filledDisk@ can be scaled. ------ The fill colour is taken from the implicit 'DrawingContext'.--- -filledDisk :: InterpretUnit u => u -> LocGraphic u-filledDisk radius = -    normalizeCtx radius >>= body-  where-    body r = makeLocGraphic fillAttr (\rgb pt -> fillEllipse rgb r r pt)  --- | 'borderedDisk' : @ radius -> LocGraphic @------ Create a bordered circle 'LocGraphic' - the implicit point is --- the center. --- --- This is a efficient representation of circles using --- PostScript\'s @arc@ or SVG\'s @circle@ in the generated --- output. However, bordereded circles do not draw well after --- non-uniform scaling - the pen width of the outline is scaled as --- well as the shape.------ For bordered circles that can be adequately scaled, use --- 'borderedCircle' instead.------ The background fill colour and the outline stroke properties --- are taken from the implicit 'DrawingContext'.--- -borderedDisk :: InterpretUnit u => u -> LocGraphic u-borderedDisk radius = -    normalizeCtx radius >>= body-  where-    body r = makeLocGraphic borderedAttr-                (\(frgb,attr,srgb) pt -> fillStrokeEllipse frgb attr srgb r r pt)----- | 'strokedEllipseDisk' : @ x_radius * y_radius -> LocGraphic @+-- | 'strokeEllipseDisk' : @ x_radius * y_radius -> LocGraphic @ -- -- Create a stroked ellipse 'LocGraphic' - the implicit point is  -- the center. @@ -728,54 +578,15 @@ -- The line properties (colour, pen thickness, etc.) are taken  -- from the implicit 'DrawingContext'. -- -strokedEllipseDisk :: InterpretUnit u => u -> u -> LocGraphic u-strokedEllipseDisk rx ry = norm2 rx ry >>= body-  where-    body (drx,dry) = makeLocGraphic strokeAttr-                        (\(rgb,attr) pt -> strokeEllipse rgb attr drx dry pt)------ | 'filledEllipseDisk' : @ x_radius * y_radius -> LocGraphic @------ Create a filled ellipse 'LocGraphic' - the implicit point is --- the center. --- --- This is a efficient representation of ellipses using --- PostScript\'s @arc@ or SVG\'s @ellipse@ in the generated --- output. As the ellipse is filled rather than drawn with a --- \"pen\" a @filledEllipseDisk@ can be scaled. ------ The fill colour is taken from the implicit 'DrawingContext'.--- -filledEllipseDisk :: InterpretUnit u => u -> u -> LocGraphic u-filledEllipseDisk rx ry = norm2 rx ry >>= body-  where-    body (drx,dry) = makeLocGraphic fillAttr-                        (\rgb pt -> fillEllipse rgb drx dry pt)-+dcEllipseDisk :: InterpretUnit u => DrawStyle -> 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 $ +                       (\frgb attr srgb pt -> +                           fillStrokeEllipse frgb attr srgb drx dry pt) --- | 'borderedEllipseDisk' : @ x_radius * y_radius -> LocGraphic @------ Create a bordered ellipse 'LocGraphic' - the implicit point is --- the center. --- --- This is a efficient representation of ellipses using --- PostScript\'s @arc@ or SVG\'s @ellipse@ in the generated --- output. However, bordereded ellipses do not draw well after --- non-uniform scaling - the pen width of the outline is scaled as --- well as the shape.------ For bordered ellipses that can be adequately scaled, use --- 'borderedEllipse' instead.------ The background fill colour and the outline stroke properties --- are taken from the implicit 'DrawingContext'.--- -borderedEllipseDisk :: InterpretUnit u => u -> u -> LocGraphic u-borderedEllipseDisk rx ry = norm2 rx ry >>= body-  where-    body (drx,dry) = makeLocGraphic borderedAttr-                          (\(frgb,attr,srgb) pt -> -                                fillStrokeEllipse frgb attr srgb drx dry pt) 

@@ -1,105 +0,0 @@-{-# OPTIONS -Wall #-}-------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Kernel.Objects.Image--- Copyright   :  (c) Stephen Tetley 2011--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  highly unstable--- Portability :  GHC ------ Image and Graphic types - these are functional types from the --- DrawingContext to a graphic /primitive/.--------------------------------------------------------------------------------------module Wumpus.Basic.Kernel.Objects.Image-   (-     Graphic-   , Image--   , DImage-   , DGraphic--   , intoImage-   , graphic_--   , uconvImageF-   , uconvImageZ--   )--   where--import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.ContextFun-import Wumpus.Basic.Kernel.Objects.Basis--import Control.Applicative----- | Image - function from the DrawingContext to a polymorphic --- /answer/ and a graphic /primitive/.------ The answer is expected to be a Functor.----type Image u a          = CF (ImageAns u a)------ | Graphic - function from the DrawingContext to a graphic --- /primitive/.----type Graphic u          = CF (GraphicAns u)------ | Type specialized version of 'Image'.----type DImage a           = Image Double a ----- | Type specialized version of 'Graphic'.----type DGraphic           = Graphic Double         ----- | 'intoImage' : @ query * graphic -> Image @------ Build an 'Image' from a context function ('CF') that generates --- the answer and a 'Graphic' that draws the 'Image'.----intoImage :: Query a -> Graphic u -> Image u a-intoImage qf ma = replaceAns <$> qf <*> ma----- | /Downcast/ an 'Image' to a 'Graphic'.--- --- This means forgetting the answer of the Image, replacing it --- with @()@.----graphic_ :: Image u a -> Graphic u-graphic_ = fmap ignoreAns-------- | Use this to convert 'Graphic' or 'Image' with Functor answer.----uconvImageF :: (Functor t, InterpretUnit u, InterpretUnit u1)-            => Image u (t u) -> Image u1 (t u1)-uconvImageF = uconvR0 szconvAnsF---uconvImageZ :: (InterpretUnit u, InterpretUnit u1)-            => Image u a -> Image u1 a-uconvImageZ = uconvR0 szconvAnsZ-------------------------------------------------------------------------------------

@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies               #-} {-# OPTIONS -Wall #-}  --------------------------------------------------------------------------------@@ -17,20 +18,29 @@  module Wumpus.Basic.Kernel.Objects.LocImage    (-     LocGraphic-   , LocImage +     LocImage+   , LocGraphic+    , DLocImage    , DLocGraphic -   , intoLocImage-   , locGraphic_+   , LocQuery -   , emptyLocGraphic+   , runLocImage+   , runLocQuery -   , uconvLocImageF-   , uconvLocImageZ+   , promoteLoc+   , applyLoc+   , qpromoteLoc+   , qapplyLoc+   , zapLocQuery +   , emptyLocImage++   , moveStart+   , at+    -- * Composing LocImages    , distrib    , distribH @@ -46,11 +56,9 @@    where  import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.ContextFun+import Wumpus.Basic.Kernel.Base.DrawingContext import Wumpus.Basic.Kernel.Base.QueryDC-import Wumpus.Basic.Kernel.Base.WrappedPrimitive import Wumpus.Basic.Kernel.Objects.Basis-import Wumpus.Basic.Kernel.Objects.Displacement   import Wumpus.Core                              -- package: wumpus-core@@ -62,20 +70,17 @@ import Data.Monoid  --- | Graphic - function from DrawingContext and start point to a --- polymorphic /answer/ and a graphic /primitive/.------ The answer is expected to be a Functor.----type LocImage u a       = LocQuery u (ImageAns u a) -+-- | 'LocThetaImage' - function from  start point and +-- DrawingContext to a polymorphic /answer/ and a graphic +-- /primitive/ (PrimW).+--+newtype LocImage u a = LocImage { +          getLocImage :: Point2 u -> Image u a } +type instance DUnit (LocImage u a) = u --- | LocGraphic - function from DrawingContext and start point to --- a graphic /primitive/.----type LocGraphic u       = LocQuery u (GraphicAns u)+type LocGraphic u = LocImage u (UNil u)   -- | Type specialized version of 'LocImage'.@@ -86,57 +91,171 @@ -- type DLocGraphic        = LocGraphic Double  +newtype LocQuery u a = LocQuery { +          getLocQuery :: Point2 u -> Query u a } +-- Functor +instance Functor (LocImage u) where+  fmap f ma = LocImage $ \pt -> fmap f $ getLocImage ma pt  +instance Functor (LocQuery u) where+  fmap f ma = LocQuery $ \pt -> fmap f $ getLocQuery ma pt --- | 'intoLocImage' : @ loc_query * loc_graphic -> LocImage @------ /Loc/ version of 'intoImage'. --- --- The 'LocImage' is built as a function from an implicit start --- point to the answer.----intoLocImage :: LocQuery u a -> LocGraphic u -> LocImage u a-intoLocImage ma gf = promoteR1 $ \pt -> -                     replaceAns <$> apply1R1 ma pt <*> apply1R1 gf pt+-- Applicative +instance Applicative (LocImage u) where+  pure a    = LocImage $ \_  -> pure a+  mf <*> ma = LocImage $ \pt -> getLocImage mf pt <*> getLocImage ma pt --- | /Downcast/ an 'LocImage' to a 'LocGraphic'.--- --- This means forgetting the answer of the LocImage, replacing it --- with @()@.+instance Applicative (LocQuery u) where+  pure a    = LocQuery $ \_  -> pure a+  mf <*> ma = LocQuery $ \pt -> getLocQuery mf pt <*> getLocQuery ma pt+                                +++-- Monad++instance Monad (LocImage u) where+  return a  = LocImage $ \_  -> return a+  ma >>= k  = LocImage $ \pt -> getLocImage ma pt >>= \ans -> +                                  getLocImage (k ans) pt+++instance Monad (LocQuery u) where+  return a  = LocQuery $ \_  -> return a+  ma >>= k  = LocQuery $ \pt -> getLocQuery ma pt >>= \ans -> +                                  getLocQuery (k ans) pt+++-- Monoid++instance Monoid a => Monoid (LocImage u a) where+  mempty          = pure mempty+  ma `mappend` mb = LocImage $ \pt -> +                      getLocImage ma pt `mappend` getLocImage mb pt ++instance Monoid a => Monoid (LocQuery u a) where+  mempty          = pure mempty+  ma `mappend` mb = LocQuery $ \pt -> +                      getLocQuery ma pt `mappend` getLocQuery mb pt ++-- DrawingCtxM++instance DrawingCtxM (LocImage u) where+  askDC           = LocImage $ \_  -> askDC+  asksDC fn       = LocImage $ \_  -> asksDC fn+  localize upd ma = LocImage $ \pt -> localize upd (getLocImage ma pt)++instance DrawingCtxM (LocQuery u) where+  askDC           = LocQuery $ \_  -> askDC+  asksDC fn       = LocQuery $ \_  -> asksDC fn+  localize upd ma = LocQuery $ \pt -> localize upd (getLocQuery ma pt)++++  +instance Decorate LocImage where+  decorate ma mz = LocImage $ \pt -> +                      getLocImage ma pt `decorate` getLocImage mz pt ++  elaborate ma f = LocImage $ \pt -> +                      getLocImage ma pt `elaborate` (\a -> getLocImage (f a) pt)++  obliterate ma mz = LocImage $ \pt -> +                       getLocImage ma pt `obliterate` getLocImage mz pt ++  hyperlink xl ma = LocImage $ \pt -> +                       hyperlink xl $ getLocImage ma pt +++runLocImage :: Point2 u -> DrawingContext -> LocImage u a -> PrimW u a+runLocImage pt ctx mf = runImage ctx (getLocImage mf pt)++runLocQuery :: Point2 u -> DrawingContext -> LocQuery u a -> a+runLocQuery pt ctx mf = runQuery ctx (getLocQuery mf pt)++++promoteLoc ::  (Point2 u -> Image u a) -> LocImage u a+promoteLoc k = LocImage $ \pt -> k pt++applyLoc :: LocImage u a -> Point2 u -> Image u a+applyLoc mq pt = getLocImage mq pt+++qpromoteLoc :: (Point2 u -> Query u a) -> LocQuery u a+qpromoteLoc k = LocQuery $ \pt -> k pt++qapplyLoc :: LocQuery u a -> Point2 u -> Query u a+qapplyLoc mq pt = getLocQuery mq pt+++-- qapplyLoc :: LocQuery u a -> Point2 u -> Query u a+-- qapplyLoc mq pt = getLocQuery mq pt++-- | \"zero-apply\" a LocQuery. ---locGraphic_ :: LocImage u a -> LocGraphic u-locGraphic_ = (fmap . fmap) ignoreAns+zapLocQuery :: LocQuery u a -> Point2 u -> Image u a+zapLocQuery mq pt = askDC >>= \ctx -> let a = runLocQuery pt ctx mq in return a  --- | 'emptyLocGraphic' : @ LocGraphic @++-- Maybe there is need for a function line qapplyLoc of this type: ----- Build an empty 'LocGraphic' (i.e. a function --- /from Point to Graphic/). This is a path with a start point --- but no path segments. +-- > blankLoc :: LocQuery u a -> Point2 u -> Image u a -- --- The 'emptyLocGraphic' is treated as a /null primitive/ by --- @Wumpus-Core@ and is not drawn, although it does generate a --- minimum bounding box at the implicit start point.+-- This then means we can have monadic bind back for the notation:+--+-- > qapplyLocTheta (rellipsePath rx ry) pt ang  `bindQ` dcClosedPath style -- -emptyLocGraphic :: InterpretUnit u => LocGraphic u-emptyLocGraphic = promoteR1 $ \pt -> -                  uconvertCtxF pt >>= \dpt -> -                  return $ graphicAns $ prim1 $ zostroke $ emptyPrimPath dpt+-- becomes+--+-- > blankLoc (rellipsePath rx ry) pt ang >>= dcClosedPath style  +--------------------------------------------------------------------------------+-- Affine instances +instance (Real u, Floating u, Rotate a) => Rotate (LocImage u a) where+  rotate ang ma = promoteLoc $ \pt -> +                     fmap (rotate ang) $ getLocImage ma (rotate ang pt)  +instance (Real u, Floating u, RotateAbout a, ScalarUnit u, u ~ DUnit a) => +    RotateAbout (LocImage u a) where+  rotateAbout ang pt ma = promoteLoc $ \p0 -> +                            fmap (rotateAbout ang pt) $ +                              getLocImage ma (rotateAbout ang pt p0)+++instance (Fractional u, Scale a) => Scale (LocImage u a) where+  scale sx sy ma = promoteLoc $ \pt -> +                   fmap (scale sx sy) $ getLocImage ma (scale sx sy pt)++instance (Num u, Translate a, ScalarUnit u, u ~ DUnit a) => +    Translate (LocImage u a) where+  translate dx dy ma = promoteLoc $ \pt -> +                         fmap (translate dx dy) $ +                           getLocImage ma (translate dx dy pt)++--------------------------------------------------------------------------------+++instance UConvert LocImage where+  uconvF = uconvLocImageF+  uconvZ = uconvLocImageZ+ -- | Use this to convert 'LocGraphic' or 'LocImage' with Functor  -- answer. -- uconvLocImageF :: (InterpretUnit u, InterpretUnit u1, Functor t)                 => LocImage u (t u) -> LocImage u1 (t u1)-uconvLocImageF = uconvR1 szconvAnsF+uconvLocImageF ma = LocImage $ \pt -> +    getFontSize >>= \sz -> +    let ptu = uconvertF sz pt+    in uconvF $ getLocImage ma ptu   @@ -144,10 +263,38 @@ -- uconvLocImageZ :: (InterpretUnit u, InterpretUnit u1)                 => LocImage u a -> LocImage u1 a-uconvLocImageZ = uconvR1 szconvAnsZ+uconvLocImageZ ma = LocImage $ \pt -> +    getFontSize >>= \sz ->  +    let ptu = uconvertF sz pt+    in uconvZ $ getLocImage ma ptu  +-- | Having /empty/ at the specific 'LocImage' type is useful.+-- +emptyLocImage :: Monoid a => LocImage u a+emptyLocImage = mempty ++++-- Note - maybe this should just be an operator on LocImage...+--++moveStart :: Num u => Vec2 u -> LocImage u a -> LocImage u a+moveStart v1 ma = LocImage $ \pt -> getLocImage ma (pt .+^ v1) ++++infixr 1 `at`+++-- | Downcast a 'LocImage' function by applying it to the supplied +-- point, making an 'Image'. +-- +at :: LocImage u a -> Point2 u -> Image u a+at mf pt = getLocImage mf pt++ -------------------------------------------------------------------------------- -- Combining LocImages  @@ -162,12 +309,12 @@  distrib :: (Monoid a, InterpretUnit u)          => Vec2 u -> [LocImage u a]  -> LocImage u a-distrib _  [] = pushR1 (replaceAns mempty) $ emptyLocGraphic-distrib v1 (x:xs) = promoteR1 $ \pt -> -    go (x `at` pt) (pt .+^ v1) xs+distrib _  []     = mempty+distrib v1 (x:xs) = promoteLoc $ \pt -> +    go (applyLoc x pt) (pt .+^ v1) xs   where     go acc _  []     = acc-    go acc pt (a:as) = go (acc `mappend` apply1R1 a pt) (pt .+^ v1) as+    go acc pt (a:as) = go (acc `mappend` applyLoc a pt) (pt .+^ v1) as  distribH :: (Monoid a, InterpretUnit u)           => u -> [LocImage u a]  -> LocImage u a@@ -178,17 +325,16 @@ distribV dy = distrib (hvec dy)  - -- | This is analogue to @replicate@ in the Prelude. -- duplicate :: (Monoid a, InterpretUnit u)            => Int -> Vec2 u -> LocImage u a -> LocImage u a-duplicate n _ _   | n < 1 = pushR1 (replaceAns mempty) $ emptyLocGraphic+duplicate n _ _   | n < 1 = mempty duplicate n v img         = go img v (n-1)   where      go acc _  i | i < 1 = acc-     go acc va i         = let img1 = moveStart (displaceVec va) img-                           in go (acc `mappend` img1) (va ^+^ v) (i-1)+     go acc v1 i         = let img1 = moveStart v1 img+                           in go (acc `mappend` img1) (v1 ^+^ v) (i-1)  duplicateH :: (Monoid a, InterpretUnit u)             => Int -> u -> LocImage u a -> LocImage u a@@ -197,3 +343,4 @@ duplicateV :: (Monoid a, InterpretUnit u)             => Int -> u -> LocImage u a -> LocImage u a duplicateV n dy = duplicate n (vvec dy)+

@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies               #-} {-# OPTIONS -Wall #-}  --------------------------------------------------------------------------------@@ -24,344 +25,231 @@    , DLocThetaGraphic    , DLocThetaImage -   , intoLocThetaImage-   , locThetaGraphic_+   , LocThetaQuery -   , emptyLocThetaGraphic+   , runLocThetaImage+   , runLocThetaQuery -   , uconvLocThetaImageF-   , uconvLocThetaImageZ+   , promoteLocTheta+   , applyLocTheta+   , qpromoteLocTheta+   , qapplyLocTheta+   , zapLocThetaQuery +   , emptyLocThetaImage++   , incline+   , atIncline        )     where  import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.ContextFun+import Wumpus.Basic.Kernel.Base.DrawingContext+import Wumpus.Basic.Kernel.Base.QueryDC import Wumpus.Basic.Kernel.Objects.Basis--- import Wumpus.Basic.Kernel.Objects.Displacement import Wumpus.Basic.Kernel.Objects.LocImage --- import Wumpus.Core                              -- package: wumpus-core+import Wumpus.Core                              -- package: wumpus-core  import Control.Applicative-+import Data.Monoid --- | 'LocThetaImage' - function from DrawingContext, start point --- and inclination to a polymorphic /answer/ and a graphic --- /primitive/ (ImageAns).------ The answer is expected to be a Functor.+-- | 'LocThetaImage' - function from start point, inclination and+-- DrawingContext to a polymorphic /answer/ and a graphic +-- /primitive/ (PrimW). ---type LocThetaImage u a = LocThetaQuery u (ImageAns u a)+newtype LocThetaImage u a = LocThetaImage { +          getLocThetaImage :: Point2 u -> Radian -> Image u a } +type instance DUnit (LocThetaImage u a) = u --- | LocThetaGraphic - function from DrawingContext, start point --- and inclination to a graphic /primitive/ (GraphicAns).----type LocThetaGraphic u  = LocThetaQuery u (GraphicAns u)+type LocThetaGraphic u = LocThetaImage u (UNil u)   -- | Type specialized version of 'LocThetaImage'. ---type DLocThetaImage a   = LocThetaImage Double a+type DLocThetaImage a        = LocThetaImage Double a  -- | Type specialized version of 'LocThetaGraphic'. ---type DLocThetaGraphic   = LocThetaGraphic Double +type DLocThetaGraphic        = LocThetaGraphic Double   +newtype LocThetaQuery u a = LocThetaQuery { +          getLocThetaQuery :: Point2 u -> Radian -> Query u a } +-- Functor --- | 'intoLocThetaImage' : @ loc_theta_query * loc_theta_graphic -> LocThetaImage @------ /LocTheta/ version of 'intoImage'. --- --- The 'LocThetaImage' is built as a function from an implicit --- start point and angle of inclination to the answer.----intoLocThetaImage :: LocThetaQuery u a -                  -> LocThetaGraphic u -                  -> LocThetaImage u a-intoLocThetaImage qf ma = -    promoteR2 $ \a b -> replaceAns <$> apply2R2 qf a b <*> apply2R2 ma a b+instance Functor (LocThetaImage u) where+  fmap f ma = LocThetaImage $ \pt ang -> +                fmap f $ getLocThetaImage ma pt ang +instance Functor (LocThetaQuery u) where+  fmap f ma = LocThetaQuery $ \pt ang -> +                fmap f $ getLocThetaQuery ma pt ang  --- | /Downcast/ an 'LocThetaImage' to a 'LocThetaGraphic'.--- --- This means forgetting the answer of the Image, replacing it --- with @()@.----locThetaGraphic_ :: LocThetaImage u a -> LocThetaGraphic u-locThetaGraphic_ = (fmap . fmap . fmap) ignoreAns+-- Applicative +instance Applicative (LocThetaImage u) where+  pure a    = LocThetaImage $ \_  _   -> pure a+  mf <*> ma = LocThetaImage $ \pt ang -> +                getLocThetaImage mf pt ang <*> getLocThetaImage ma pt ang --- | 'emptyLocThetaGraphic' : @ LocThetaGraphic @------ Build an empty 'LocThetaGraphic' (i.e. a function --- /from Point and Inclination to Graphic/). --- --- The 'emptyLocThetaGraphic' is treated as a /null primitive/ by --- @Wumpus-Core@ and is not drawn, although it does generate a --- minimum bounding box at the implicit start point.--- -emptyLocThetaGraphic :: InterpretUnit u => LocThetaGraphic u-emptyLocThetaGraphic = lift1R2 emptyLocGraphic+instance Applicative (LocThetaQuery u) where+  pure a    = LocThetaQuery $ \_  _   -> pure a+  mf <*> ma = LocThetaQuery $ \pt ang -> +                getLocThetaQuery mf pt ang <*> getLocThetaQuery ma pt ang  +-- Monad  +instance Monad (LocThetaImage u) where+  return a  = LocThetaImage $ \_  _   -> return a+  ma >>= k  = LocThetaImage $ \pt ang -> +                getLocThetaImage ma pt ang >>= \ans -> +                getLocThetaImage (k ans) pt ang --- | Use this to convert 'LocThetaGraphic' or 'LocThetaImage' --- with Functor answer.----uconvLocThetaImageF :: (InterpretUnit u, InterpretUnit u1, Functor t) -                    => LocThetaImage u (t u) -> LocThetaImage u1 (t u1)-uconvLocThetaImageF = uconvR2a szconvAnsF +instance Monad (LocThetaQuery u) where+  return a  = LocThetaQuery $ \_  _   -> return a+  ma >>= k  = LocThetaQuery $ \pt ang -> +                getLocThetaQuery ma pt ang >>= \ans -> +                getLocThetaQuery (k ans) pt ang +-- Monoid --- | Use this to convert 'LocThetaImage' with unit-less answer.----uconvLocThetaImageZ :: (InterpretUnit u, InterpretUnit u1) -                    => LocThetaImage u a -> LocThetaImage u1 a-uconvLocThetaImageZ = uconvR2a szconvAnsZ+instance Monoid a => Monoid (LocThetaImage u a) where+  mempty          = pure mempty+  ma `mappend` mb = LocThetaImage $ \pt ang -> +                      getLocThetaImage ma pt ang +                         `mappend` getLocThetaImage mb pt ang   +instance Monoid a => Monoid (LocThetaQuery u a) where+  mempty          = pure mempty+  ma `mappend` mb = LocThetaQuery $ \pt ang -> +                      getLocThetaQuery ma pt ang +                         `mappend` getLocThetaQuery mb pt ang ------------------------------------------------------------------------------------ Combining LocThetaImages+-- DrawingCtxM -{-+instance DrawingCtxM (LocThetaImage u) where+  askDC           = LocThetaImage $ \_  _   -> askDC+  asksDC fn       = LocThetaImage $ \_  _   -> asksDC fn+  localize upd ma = LocThetaImage $ \pt ang -> +                      localize upd (getLocThetaImage ma pt ang) -infixr 6 `catLTI`-infixr 5 `sepLTI`+instance DrawingCtxM (LocThetaQuery u) where+  askDC           = LocThetaQuery $ \_  _   -> askDC+  asksDC fn       = LocThetaQuery $ \_  _   -> asksDC fn+  localize upd ma = LocThetaQuery $ \pt ang -> +                      localize upd (getLocThetaQuery ma pt ang) --- | Concatenate two LocThetaImages. The start point is /shared/. ----- This is just @oplus@.----catLTI :: OPlus (t u)-       => LocThetaImage t u -> LocThetaImage t u -> LocThetaImage t u-catLTI = oplus +instance Decorate LocThetaImage where+  decorate ma mz = LocThetaImage $ \pt ang -> +                      getLocThetaImage ma pt ang `decorate` +                        getLocThetaImage mz pt ang +  elaborate ma f = LocThetaImage $ \pt ang -> +                     getLocThetaImage ma pt ang `elaborate` +                       (\a -> getLocThetaImage (f a) pt ang) --- | Concatenate two LocThetaImages, the second LocThetaImage is --- displaced /orthonormally/ from the the start point by the --- supplied vector (separator). ------ Here, /orthonormally/ means that the x-component of the vector--- displaces the second LocThetaImage in parallel to the angle--- of inclination, the y-component of the vector displaces --- perpendicular to the incliantion.------ Note - the separator is exactly a displacement of the start--- point, LocImages have no notion of border so this function--- can only be used to concatenate to objects side by side if--- there boundaries are known beforehand.--- --- Consider a PosThetaImage if you need more sophisticated arrangement.--- -sepLTI :: (Floating u, OPlus (t u))-       => Vec2 u -> LocThetaImage t u -> LocThetaImage t u -       -> LocThetaImage t u-sepLTI v g1 g2 = g1 `oplus` moveStartTheta (displaceOrtho v) g2+  obliterate ma mz = LocThetaImage $ \pt ang -> +                       getLocThetaImage ma pt ang `obliterate` +                         getLocThetaImage mz pt ang +  hyperlink xl ma = LocThetaImage $ \pt ang -> +                       hyperlink xl $ getLocThetaImage ma pt ang+             --- | Concatenate two LocThetaImages, the second LocImage is --- displaced parallel to the inclination by the supplied distance. ------ Note - this is exactly a start point displacement. See the --- caveat for 'sepLTI'.--- -paraSepLTI :: (Floating u, OPlus (t u))-           => u -> LocThetaImage t u -> LocThetaImage t u -> LocThetaImage t u-paraSepLTI u = sepLTI (hvec u) +runLocThetaImage :: Point2 u -> Radian -> DrawingContext +                 -> LocThetaImage u a +                 -> PrimW u a+runLocThetaImage pt incl ctx mf = runImage ctx (getLocThetaImage mf pt incl)  --- | Concatenate two LocThetaImages, the second LocThetaImage is --- displaced perpendicular to the inclination by the supplied --- distance.------ Note - this is exactly a start point displacement. See the --- caveat for 'sepLTI'.--- -perpSepLTI :: (Floating u, OPlus (t u))-       => u -> LocThetaImage t u -> LocThetaImage t u -> LocThetaImage t u-perpSepLTI u = sepLTI (vvec u)+runLocThetaQuery :: Point2 u -> Radian -> DrawingContext +                 -> LocThetaQuery u a +                 -> a+runLocThetaQuery pt incl ctx mf = runQuery ctx (getLocThetaQuery mf pt incl)  --- | Repeatedly draw a LocThetaImage, moving the start point each time --- /orthonormally/ by the supplied vector.------ Note - the first LocThetaImage argument is the /empty/ alternative--- this is drawn if the repeat count is less than 1.----repeatLTI :: (Floating u, OPlus (t u))-          => LocThetaImage t u -> Int -> Vec2 u -> LocThetaImage t u -          -> LocThetaImage t u-repeatLTI alt i _  _  | i < 1 = alt-repeatLTI _   i v  gf         = promoteR2 $ \start ang -> body start ang-  where-    body start ang = go (i-1) (drawF start) (moveF start)-      where-        drawF pt                = atIncline gf pt ang-        moveF pt                = displaceOrtho v ang pt-        go n acc pt | n < 1     = acc-                    | otherwise = go (n-1) (acc `oplus` drawF pt) (moveF pt)+promoteLocTheta ::  (Point2 u -> Radian -> Image u a) -> LocThetaImage u a+promoteLocTheta k = LocThetaImage $ \pt ang -> k pt ang +applyLocTheta :: LocThetaImage u a -> Point2 u -> Radian -> Image u a+applyLocTheta mq pt ang = getLocThetaImage mq pt ang  --- | Repeatedly draw a LocThetaImage, moving parallel to the --- inclination each time by the supplied distance.------ Note - this draws the alternative LocThetaImage if the repeat count --- is less than 1.----paraRepeatLTI :: (Floating u, OPlus (t u))-              => LocThetaImage t u -> Int -> u -> LocThetaImage t u -              -> LocThetaImage t u-paraRepeatLTI alt i u = repeatLTI alt i (hvec u) +qpromoteLocTheta :: (Point2 u -> Radian -> Query u a) -> LocThetaQuery u a+qpromoteLocTheta k = LocThetaQuery $ \pt ang -> k pt ang  +qapplyLocTheta :: LocThetaQuery u a -> Point2 u -> Radian -> Query u a+qapplyLocTheta mq pt ang = getLocThetaQuery mq pt ang --- | Repeatedly draw a LocThetaImage, moving perpendicular to the--- inclination each time by the supplied distance.------ Note - this draws the alternative LocThetaImage if the repeat count --- is less than 1.+-- | \"zero-apply\" a LocThetaQuery. ---perpRepeatLTI :: (Floating u, OPlus (t u))-          => LocThetaImage t u -> Int -> u -> LocThetaImage t u -> LocThetaImage t u-perpRepeatLTI alt i u = repeatLTI alt i (vvec u) +zapLocThetaQuery :: LocThetaQuery u a -> Point2 u -> Radian -> Image u a+zapLocThetaQuery mq pt ang = askDC >>= \ctx -> +    let a = runLocThetaQuery pt ang ctx mq in return a   --- | Concatenate a list of LocThetaImages, spacing them by moving --- the start point /orthonormally/ each time by the supplied --- vector.------ Note - this draws the /empty/ alternative if the list is empty.----spaceLTI :: (Floating u, OPlus (t u))-         => LocThetaImage t u -> Vec2 u -> [LocThetaImage t u] -         -> LocThetaImage t u-spaceLTI alt _ []     = alt-spaceLTI _   v (g:gs) = promoteR2 $ \start ang -> body start ang -  where-    body start ang = go (drawF g start) (moveF start) gs-      where-        drawF gf pt      = atIncline gf pt ang-        moveF pt         = displaceOrtho v ang pt-        go acc _  []     = acc-        go acc pt (f:fs) = go (acc `oplus` drawF f pt) (moveF pt) fs-+instance UConvert LocThetaImage where+  uconvF = uconvLocThetaImageF+  uconvZ = uconvLocThetaImageZ  --- | Concatenate a list of LocThetaImages, spacing them by moving --- the start point parallel to the inclination each time by the --- supplied distance.------ Note - this draws the /empty/ alternative if the list is empty.+-- | Use this to convert 'LocThetaThetaGraphic' or 'LocThetaThetaImage' +-- with Functor answer. ---paraSpaceLTI :: (Floating u, OPlus (t u))-              => LocThetaImage t u -> u -> [LocThetaImage t u] -              -> LocThetaImage t u-paraSpaceLTI alt u = spaceLTI alt (hvec u)+uconvLocThetaImageF :: (InterpretUnit u, InterpretUnit u1, Functor t) +                    => LocThetaImage u (t u) -> LocThetaImage u1 (t u1)+uconvLocThetaImageF ma = LocThetaImage $ \pt ang -> +    getFontSize >>= \sz -> +    let ptu = uconvertF sz pt+    in uconvF $ getLocThetaImage ma ptu ang  --- | Concatenate a list of LocThetaImages, spacing them by moving --- the start point perpendicular to the inclination each time by --- the supplied distance.------ Note - this draws the /empty/ alternative if the list is empty.----perpSpaceLTI :: (Floating u, OPlus (t u))-              => LocThetaImage t u -> u -> [LocThetaImage t u] -              -> LocThetaImage t u-perpSpaceLTI alt u = spaceLTI alt (vvec u)  --- | Enclose l r x------ Note - the @left@ LocThetaImage is drawn at the start point, the --- LocThetaImage @x@ is concatenated with 'sepLTI' then the right --- LocThetaImage is concatenated with 'sepLi'.+-- | Use this to convert 'LocThetaImage' with unit-less answer. ---encloseLTI :: (Floating u, OPlus (t u))-           => Vec2 u -           -> LocThetaImage t u -> LocThetaImage t u -> LocThetaImage t u -           -> LocThetaImage t u-encloseLTI v lft rht obj = lft `op` obj `op` rht-  where-    op = sepLTI v+uconvLocThetaImageZ :: (InterpretUnit u, InterpretUnit u1) +                    => LocThetaImage u a -> LocThetaImage u1 a+uconvLocThetaImageZ ma = LocThetaImage $ \pt ang -> +    getFontSize >>= \sz -> +    let ptu = uconvertF sz pt+    in uconvZ $ getLocThetaImage ma ptu ang   --- | Parallel version of 'encloseLTI'.------ Note - the @left@ LocThetaImage is drawn at the start point, the --- LocThetaImage @x@ is concatenated with 'sepLTI' then the right --- LocThetaImage is concatenated with 'sepLTI'.----paraEncloseLTI :: (Floating u, OPlus (t u))-               => u -               -> LocThetaImage t u -> LocThetaImage t u -> LocThetaImage t u -               -> LocThetaImage t u-paraEncloseLTI u = encloseLTI (hvec u)+-- | Having /empty/ at the specific 'LocThetaImage' type is useful.+-- +emptyLocThetaImage :: Monoid a => LocThetaImage u a+emptyLocThetaImage = mempty   --- | Perpendicular version of 'encloseLTI'.------ Note - the @left@ LocThetaImage is drawn at the start point, the --- LocThetaImage @x@ is concatenated with 'sepLTI' then the right --- LocThetaImage is concatenated with 'sepLTI'.----perpEncloseLTI :: (Floating u, OPlus (t u))-               => u -               -> LocThetaImage t u -> LocThetaImage t u -> LocThetaImage t u -               -> LocThetaImage t u-perpEncloseLTI u = encloseLTI (vvec u)  ---- | Concatenate a list of LocThetaImages, punctuating with the --- separator.------ Note - this draws the /empty/ alternative if the list is empty.----punctuateLTI :: (Floating u, OPlus (t u))-             => LocThetaImage t u -> Vec2 u -             -> LocThetaImage t u -> [LocThetaImage t u] -             -> LocThetaImage t u-punctuateLTI alt _ _   []     = alt-punctuateLTI _   v sep (g:gs) = go g gs-  where -    go acc []     = acc-    go acc (f:fs) = go (encloseLTI v acc f sep) fs----- | Parallel version of 'punctuateLTI'----paraPunctuateLTI :: (Floating u, OPlus (t u))-                 => LocThetaImage t u -> u -                 -> LocThetaImage t u -> [LocThetaImage t u] -                 -> LocThetaImage t u-paraPunctuateLTI alt u = punctuateLTI alt (hvec u)+infixr 1 `incline`  --- | Perpendicular version of 'punctuateLTI'----perpPunctuateLTI :: (Floating u, OPlus (t u))-                 => LocThetaImage t u -> u -                 -> LocThetaImage t u -> [LocThetaImage t u] -                 -> LocThetaImage t u-perpPunctuateLTI alt u = punctuateLTI alt (vvec u)+-- | Downcast a 'LocThetaImage' function by applying it to the +-- supplied angle, making a 'LocImage'. +-- +incline :: LocThetaImage u a -> Radian -> LocImage u a+incline ma incl = promoteLoc $ \pt -> getLocThetaImage ma pt incl --}+atIncline :: LocThetaImage u a -> Point2 u -> Radian -> Image u a+atIncline ma pt incl = getLocThetaImage ma pt incl

@@ -29,34 +29,19 @@     PosObject   , DPosObject -  , LocRectQuery-  , BoundedLocRectGraphic    -- * Operations+  , runPosObject    , makePosObject-  , makeBindPosObject+--  , makeBindPosObject   , emptyPosObject-  , runPosObjectR0-  , runPosObjectR1-  , runPosObjectR2  -  , localizePO -  , elaboratePO-  , aelaboratePO - -  , startAddr-  , atStartAddr-+  , localPosObject+  , decoPosObject   , extendPosObject--  , padHorizontalPO-  , padLeftPO-  , padRightPO-  , padVerticalPO-  , padUpPO-  , padDownPO+  , mapOrientation    , illustratePosObject @@ -65,15 +50,13 @@   import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.ContextFun 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.Bounded import Wumpus.Basic.Kernel.Objects.Concat import Wumpus.Basic.Kernel.Objects.DrawingPrimitives-import Wumpus.Basic.Kernel.Objects.Displacement import Wumpus.Basic.Kernel.Objects.LocImage import Wumpus.Basic.Kernel.Objects.Orientation @@ -94,14 +77,14 @@ -- graphic from a PosImage have to be generated within the same  -- DrawingContext. ---type PosDraw u = Point2 u -> GraphicAns u+type PosDraw u = Point2 u -> CatPrim   -- | A positionable \"Object\" that is drawn as a  -- 'BoundedLocGraphic'. -- newtype PosObject u = PosObject -          { getPosObject :: CF (Orientation u, PosDraw u) }+          { getPosObject :: Query u (Orientation u, PosDraw u) }  type instance DUnit (PosObject u) = u     @@ -112,38 +95,55 @@   -type LocRectQuery u a = CF (Point2 u ->  RectAddress -> a) -type BoundedLocRectGraphic u = LocRectQuery u (ImageAns u (BoundingBox u))- --------------------------------------------------------------------------------  -instance (Fractional u, Ord u) => OPlus (PosObject u) where-  oplus = poconcat  instance (Fractional u, Ord u, InterpretUnit u) => Monoid (PosObject u) where-  mempty = pozero+  mempty  = emptyPosObject   mappend = poconcat  -pozero :: InterpretUnit u => PosObject u-pozero = PosObject body-  where-    body = drawingCtx >>= \ctx -> -           let pf = \pt -> runCF ctx (apply1R1 emptyLocGraphic pt)-           in return (Orientation 0 0 0 0, pf)  poconcat :: (Fractional u, Ord u) => PosObject u -> PosObject u -> PosObject u poconcat a b = PosObject body    where-     body = drawingCtx >>= \ctx -> -            let (o0,pf0) = runCF ctx (getPosObject a)-                (o1,pf1) = runCF ctx (getPosObject b)-                pf       = \pt -> pf0 pt `oplus` pf1 pt-            in return (o0 `oplus` o1, pf)+    body = askDC >>= \ctx ->+           let ans1 = runQuery ctx (getPosObject a)+               ans2 = runQuery ctx (getPosObject b)+           in pure (appendW ans1 ans2)  ++appendW :: (Fractional u, Ord u)+        => (Orientation u, PosDraw u) +        -> (Orientation u, PosDraw u) +        -> (Orientation u, PosDraw u)+appendW (o0,pf0) (o1,pf1) = let pf = \pt -> pf0 pt `mappend` pf1 pt+                            in (o0 `mappend` o1, pf)++++-- | Version of 'runPosObject' that produces a +-- 'LocImage' that returns a bounding box. +-- +-- The 'PosObject' is run with only rect-address as an explicit +-- argument (start-point is implicit). The corresponding answer is +-- an /arity one/ Graphic that needs drawing with the start-point.+--+runPosObject :: Fractional u +             => RectAddress -> PosObject u -> LocImage u (BoundingBox u)+runPosObject addr (PosObject mf) = promoteLoc $ \pt ->+   askDC >>= \ctx -> +   let (o1,df) = runQuery ctx mf+       v1      = orientationStart addr o1+       p1      = pt .+^ v1+       bb      = orientationBounds o1 p1+   in replaceAns bb $ primGraphic (df p1)+++ -- | 'makePosObject' : @ object_pos * loc_image -> PosObject @  -- -- Create a 'PosObject' from an 'Orientation' describing how it@@ -154,30 +154,15 @@ -- PosObject type is considered as a specialized object it does -- not have the range of functions of LocImage or LocThetaImage. -- -makePosObject :: Query (Orientation u) -> LocGraphic u -> PosObject u+makePosObject :: Query u (Orientation u) -> LocGraphic u -> PosObject u makePosObject qortt gf = PosObject body   where-    body = drawingCtx >>= \ctx -> -           let ortt = runCF ctx qortt-               pf   = runCF ctx gf-           in return (ortt,pf)----- | This is a bit of a hack to overcome that the newtype --- wrapper around PosObject stops monadic bind operating --- with the internal CF function.----makeBindPosObject :: Query a -                  -> (a -> Query (Orientation u)) -> (a -> LocGraphic u) -                  -> PosObject u -makeBindPosObject qy mkO mkG = PosObject body-  where-    body = drawingCtx >>= \ctx -> -           let a    = runCF ctx qy-               ortt = runCF ctx (mkO a)-               pf   = runCF ctx (mkG a)-           in return (ortt,pf)+    body = askDC >>= \ctx -> +           let v1   = runQuery ctx qortt+               pf   = \pt -> getCP $ runLocImage pt ctx gf+           in return (v1,pf) +    getCP (PrimW ca _) = ca   -- | 'emptyPosObject' : @ PosObject @@@ -185,102 +170,31 @@ -- Build an empty 'PosGraphicObject'. -- emptyPosObject :: InterpretUnit u => PosObject u-emptyPosObject = -    makePosObject (pure $ Orientation 0 0 0 0) emptyLocGraphic+emptyPosObject = PosObject $ pure (Orientation 0 0 0 0, const mempty)      --- | Run a PosObject forming an Image (an /arity zero/ answer).----runPosObjectR0 :: Fractional u -               => Point2 u -> RectAddress -> PosObject u -> BoundedGraphic u-runPosObjectR0 pt addr (PosObject mf) = -    mf >>= \(ortt,ptf) -> let sv = orientationStart addr ortt-                              bb = orientationBounds ortt (displaceVec sv pt)-                          in pure $ replaceAns bb $ ptf $ displaceVec sv pt   --- | Version of 'runPosObject' that produces a --- 'BoundedLocGraphic'. --- --- The 'PosObject' is run with only rect-address as an explicit --- argument (start-point is implicit). The corresponding answer is --- an /arity one/ Graphic that needs drawing with the start-point.----runPosObjectR1 :: Fractional u -               => RectAddress -> PosObject u -> BoundedLocGraphic u-runPosObjectR1 addr obj = promoteR1 $ \start -> runPosObjectR0 start addr obj----- | Version of 'runPosObject' that produces a --- 'BoundedLocRectGraphic'. --- --- The 'PosObject' is run with no explicit arguments (rect-address --- or start-point) so the corresponding answer is an /arity two/ --- Graphic that needs drawing with the start-point and --- rect-address.----runPosObjectR2 :: Fractional u -               => PosObject u -> BoundedLocRectGraphic u-runPosObjectR2 obj = promoteR2 $ \start addr -> runPosObjectR0 start addr obj------ | Run a DrawingContext update within a 'PosObject'.+-- | Apply a DrawingContext update to a 'PosObject'. ---localizePO :: DrawingContextF -> PosObject u -> PosObject u-localizePO upd = PosObject . localize upd . getPosObject+localPosObject :: DrawingContextF -> PosObject u -> PosObject u+localPosObject upd = PosObject . localize upd . getPosObject  --- | 'decorate' -like functionality.----elaboratePO :: (Orientation u -> LocGraphic u) -> PosObject u -> PosObject u-elaboratePO fn po = PosObject body-  where-    body = drawingCtx >>= \ctx -> -           let (ortt,ptf) = runCF ctx (getPosObject po)-               deco       = runCF ctx (fn ortt)-           in return (ortt, ptf `oplus` deco)---- | ante-eloborate----aelaboratePO :: (Orientation u -> LocGraphic u) -> PosObject u -> PosObject u-aelaboratePO fn po = PosObject body+decoPosObject :: (Orientation u -> LocGraphic u) -> ZDeco +              -> PosObject u -> PosObject u+decoPosObject fn zdec po = PosObject body   where-    body = drawingCtx >>= \ctx -> -           let (ortt,ptf) = runCF ctx (getPosObject po)-               deco       = runCF ctx (fn ortt)-           in return (ortt, deco `oplus` ptf)------infixr 1 `startAddr`---- | 'startAddr' : @ bounded_loc_rect * rect_pos -> BoundedlocGraphic @------ /Downcast/ a 'BoundedLocRectGraphic' to a 'BoundedLocGraphic' --- by supplying it with a 'RectAddress' (start address on the --- rectangle frame).---  -startAddr :: Floating u -          => BoundedLocRectGraphic u -> RectAddress -> BoundedLocGraphic u-startAddr = apply1R2 --+    body = askDC >>= \ctx -> +           let (ortt,ptf) = runQuery ctx (getPosObject po)+               deco       = \pt -> getCP $ runLocImage pt ctx (fn ortt)+               gf         = case zdec of+                              ANTERIOR -> deco `mappend` ptf+                              SUPERIOR -> ptf  `mappend` deco+           in return (ortt, gf) --- | 'atStartAddr' : @ bounded_loc_rect * start_point * rect_pos ---      -> BoundedGraphic @------ /Downcast/ a 'BoundedLocRectGraphic' to a 'BoundedGraphic' by --- supplying it with an initial point and a 'RectAddress' (start --- address on the rectangle frame).---  -atStartAddr ::  Floating u -            => BoundedLocRectGraphic u -> Point2 u -> RectAddress -            -> BoundedGraphic u-atStartAddr = apply2R2+    getCP (PrimW ca _) = ca   @@ -290,42 +204,19 @@                 => u -> u -> u -> u -> PosObject u -> PosObject u extendPosObject x0 x1 y0 y1 po = PosObject body   where-    body = drawingCtx >>= \ctx -> -           let (o0,pf0) = runCF ctx (getPosObject po)+    body = askDC >>= \ctx -> +           let (o0,pf0) = runQuery ctx (getPosObject po)                ortt     = extendOrientation x0 x1 y0 y1 o0            in return (ortt,pf0) -           ------------------------------------------------------------------------------------ Padding -padHorizontalPO     :: (Fractional u, Ord u) => u -> PosObject u -> PosObject u-padHorizontalPO w   = genPad (padHEven w) -padLeftPO       :: (Num u, Ord u) => u -> PosObject u -> PosObject u-padLeftPO w     = genPad (padXMinor w)--padRightPO      :: (Num u, Ord u) => u -> PosObject u -> PosObject u-padRightPO w    = genPad (padXMajor w)---padVerticalPO       :: (Fractional u, Ord u) => u -> PosObject u -> PosObject u-padVerticalPO w     = genPad (padVEven w)--padUpPO         :: (Num u, Ord u) => u -> PosObject u -> PosObject u-padUpPO h       = genPad (padYMajor h)--padDownPO       :: (Num u, Ord u) => u -> PosObject u -> PosObject u-padDownPO h     = genPad (padYMinor h)---genPad :: (Orientation u -> Orientation u) -> PosObject u -> PosObject u-genPad fn po = PosObject body+mapOrientation :: (Orientation u -> Orientation u) -> PosObject u -> PosObject u+mapOrientation fn po = PosObject body   where-    body = drawingCtx >>= \ctx -> -           let (o0,pf0) = runCF ctx (getPosObject po)-               ortt     = fn o0-           in return (ortt,pf0)+    body = askDC >>= \ctx -> +           let (o0,pf0) = runQuery ctx (getPosObject po)+           in return (fn o0,pf0)   --------------------------------------------------------------------------------@@ -338,31 +229,31 @@ -- illustratePosObject :: InterpretUnit u                     => PosObject u -> LocGraphic u-illustratePosObject (PosObject mf)  = promoteR1 $ \pt ->   -    mf >>= \(ortt,ptf) -> -    decorateR0 (pure $ ptf pt) (illustrateOrientation ortt `at` pt)+illustratePosObject (PosObject mf)  = promoteLoc $ \pt ->   +    zapQuery mf >>= \(ortt,ptf) -> +    decorate (primGraphic $ ptf pt) (illustrateOrientation ortt `at` pt)   illustrateOrientation :: InterpretUnit u                      => Orientation u -> LocGraphic u-illustrateOrientation (Orientation xmin xmaj ymin ymaj) = promoteR1 $ \pt -> +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) $ filledDisk radius `at` pt+        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 $ strokedRectangle (xmin+xmaj) (ymin+ymaj) `at` bl-    in bdr `oplus` hln `oplus` vln `oplus` dot+        bdr = upd $ dcRectangle STROKE (xmin+xmaj) (ymin+ymaj) `at` bl+    in mconcat [ bdr, hln, vln, dot ]   -------------------------------------------------------------------------------- -- Combining PosObject  -instance (Fractional u, Ord u) => ZConcat (PosObject u) where-  superior = oplus-  anterior = flip oplus+instance (Fractional u, Ord u, InterpretUnit u) => ZConcat (PosObject u) where+  superior = mappend+  anterior = flip mappend   instance (Num u, Ord u) => Concat (PosObject u) where@@ -392,9 +283,9 @@              -> PosObject u -> PosObject u -> PosObject u genMoveAlign mkV mkO po0 po1 = PosObject body   where-   body = drawingCtx >>= \ctx -> -          let (ortt0,pf0) = runCF ctx (getPosObject po0)-              (ortt1,pf1) = runCF ctx (getPosObject po1)+   body = askDC >>= \ctx -> +          let (ortt0,pf0) = runQuery ctx (getPosObject po0)+              (ortt1,pf1) = runQuery ctx (getPosObject po1)               v1          = mkV ortt0 ortt1               ortt        = mkO ortt0 ortt1               pf          = \pt -> pf0 pt `oplus` (pf1 $ pt .+^ v1)@@ -421,9 +312,9 @@             -> PosObject u -> PosObject u -> PosObject u genMoveSepH mkV mkO sep po0 po1  = PosObject body   where-    body = drawingCtx >>= \ctx -> -           let (ortt0,pf0) = runCF ctx (getPosObject po0)-               (ortt1,pf1) = runCF ctx (getPosObject po1)+    body = askDC >>= \ctx -> +           let (ortt0,pf0) = runQuery ctx (getPosObject po0)+               (ortt1,pf1) = runQuery ctx (getPosObject po1)                v1          = hvec sep ^+^ mkV ortt0 ortt1                ortt        = extendORight sep $ mkO ortt0 ortt1                pf          = \pt -> pf0 pt `oplus` (pf1 $ pt .+^ v1)@@ -437,10 +328,11 @@             -> PosObject u -> PosObject u -> PosObject u genMoveSepV mkV mkO sep po0 po1 = PosObject body   where-    body = drawingCtx >>= \ctx -> -           let (ortt0,pf0) = runCF ctx (getPosObject po0)-               (ortt1,pf1) = runCF ctx (getPosObject po1)+    body = askDC >>= \ctx -> +           let (ortt0,pf0) = runQuery ctx (getPosObject po0)+               (ortt1,pf1) = runQuery ctx (getPosObject po1)                v1          = vvec (-sep) ^+^ mkV ortt0 ortt1                ortt        = extendODown sep $ mkO ortt0 ortt1                pf          = \pt -> pf0 pt `oplus` (pf1 $ pt .+^ v1)            in return (ortt,pf)+

@@ -48,6 +48,7 @@   , drawi   , drawl   , drawli+   , drawc   , drawci @@ -61,14 +62,12 @@   import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.ContextFun import Wumpus.Basic.Kernel.Base.DrawingContext import Wumpus.Basic.Kernel.Base.QueryDC import Wumpus.Basic.Kernel.Base.WrappedPrimitive import Wumpus.Basic.Kernel.Objects.Anchors import Wumpus.Basic.Kernel.Objects.Basis import Wumpus.Basic.Kernel.Objects.Connector-import Wumpus.Basic.Kernel.Objects.Image import Wumpus.Basic.Kernel.Objects.LocImage  import Wumpus.Core                              -- package: wumpus-core@@ -182,7 +181,7 @@  fontDeltaMon :: TraceDrawing u a -> TraceDrawing u a fontDeltaMon mf = TraceDrawing $ \ctx -> -    let (_,font_attrs) = runCF ctx textAttr+    let (_,font_attrs) = primAnswer $ runImage ctx textAttr         (a,hf)         = runTraceDrawing ctx mf         prim           = fontDeltaContext font_attrs $ primGroup $ hprimToList hf     in (a, singleH $ prim1 $ prim)@@ -193,7 +192,7 @@  fontDeltaTrans :: Monad m => TraceDrawingT u m a -> TraceDrawingT u m a fontDeltaTrans mf = TraceDrawingT $ \ctx -> -    let (_,font_props) = runCF ctx textAttr+    let (_,font_props) = primAnswer $ runImage ctx textAttr     in runTraceDrawingT ctx mf >>= \(a,hf) ->        let prim  = fontDeltaContext font_props $ primGroup $ hprimToList hf        in return (a, singleH $ prim1 $ prim)@@ -307,8 +306,8 @@ --------------------------------------------------------------------------------  -evalQuery :: DrawingCtxM m => Query a -> m a-evalQuery df = askDC >>= \ctx -> return $ runCF ctx  df+evalQuery :: DrawingCtxM m => Query u a -> m a+evalQuery df = askDC >>= \ctx -> return $ runQuery ctx df   @@ -322,7 +321,7 @@ draw :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) )       => Image u a -> m () draw gf = askDC >>= \ctx -> -          let Ans o _ = runCF ctx gf+          let (PrimW o _) = runImage ctx gf           in trace (singleH o) >> return ()  @@ -336,9 +335,10 @@ --  drawi :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) )        => Image u a -> m a-drawi img = askDC >>= \ctx -> -            let Ans o a = runCF ctx img-            in trace (singleH o) >> return a+drawi gf = askDC >>= \ctx -> +           let (PrimW o a) = runImage ctx gf +           in trace (singleH o) >> return a+               -- | Draw a LocImage at the supplied Anchor taking the drawing @@ -362,10 +362,9 @@ --  drawli :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) )         => Anchor u -> LocImage u a -> m a-drawli pt img = askDC >>= \ctx -> -                let Ans o a = runCF ctx img pt -                in trace (singleH o) >> return a-+drawli pt gf = askDC >>= \ctx -> +               let (PrimW o a) = runLocImage pt ctx gf+               in trace (singleH o) >> return a   -- Design note - having @drawlti@ for LocThetaImage does not seem @@ -399,7 +398,7 @@ --  drawci :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) )         => Anchor u -> Anchor u -> ConnectorImage u a -> m a-drawci p0 p1 img = drawi (connect img p0 p1)+drawci p0 p1 img = drawi (connect p0 p1 img)   @@ -429,11 +428,8 @@       => (Int,Int) -> LocImage u a -> m a nodei coord gf = askDC >>= \ctx ->                   position coord >>= \pt ->-                 let Ans o a = runCF ctx gf pt+                 let (PrimW o a) = runLocImage pt ctx gf                  in trace (singleH o) >> return a---    @@ -470,6 +466,6 @@            , u ~ MonUnit (m ()), u ~ DUnit a, u ~ DUnit b            )          => a -> b -> ConnectorImage u ans -> m ans-drawrci a b img = -    let (p0,p1) = radialConnectorPoints a b in drawi (connect img p0 p1)+drawrci a b gf = +    let (p0,p1) = radialConnectorPoints a b in drawi (connect p0 p1 gf) 

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

@@ -1,5 +1,5 @@ name:             wumpus-basic-version:          0.17.0+version:          0.18.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -9,8 +9,8 @@ synopsis:         Basic objects and system code built on Wumpus-Core. description:   .-  Kernel code for higher-level drawing built on Wumpus-Core.-  This package provides font loader code (limited to AFM font +  Kernel code for higher-level drawing built on Wumpus-Core. This +  package provides font loader code (currently limited to AFM font    files) and a various /drawing objects/ intended to be a    higher-level basis to make vector drawings than the primitives    (paths, text labels) provided by Wumpus-Core. @@ -29,83 +29,22 @@   .   .   Changelog:-  . -  v0.16.0 to v0.17.0:   .-  * Changed representation of ContextFuns - context funs are no -    longer an arity family of newtypes. The new representation -    is simpler, but some of the opportunities for overloading -    have been lost.-  .-  * Substantial round of renaming for the @DrawingContext@ types-    an query and update functions.-  .-  * Re-worked the font metrics and font loader modules. The new-    names should be more systematic. Removed the need for the -    GhostScript font modules to match PostScript names to -    GhostScript font files.    -  .-  * Superceded the PointSupplyM class by adding snapping grid -    scaling to the DrawingContext. +  v0.17.0 to v0.18.0:   . -  * Removed @ScalingContext@ module.-  .-  * Made text colour a distinct property in the DrawingContext. -    Text is now drawn with the text colour rather than the stroke -    colour.-  .-  * Added FontLoadLog to the DrawingContext - this allows access -    to the errors recorded during font loading.-  .-  v0.15.0 to v0.16.0:-  .-  * Moved the Geometry modules from Wumpus-Drawing into -    Wumpus-Basic.-  .-  * Re-worked the @CtxPicture@ API, although the current naming -    scheme is not satisfactory.-  .-  * Added extra Anchor classes.-  .-  * Added @PosImage@ object - this is a rectangle-framed object -    that can be drawn from any of its corners or its center. -  .-  * Added @CF3@, an arity three /ContextFunction/.-  .-  * Added @Displacement@ module. This defines the @PointDisplace@-    type and provides a library of @PointDisplace@ functions.-    Note - some of the new functions have taken names previously -    used for anchor projection functions (@northwards@, -    @southwards@, etc.), anchor projections are now build with the -    function @projectAnchor@.-  .-  * Added the property @descender@ to the font metrics.-  .-  * Split drawing primitives from type in @Objects.Graphic@, -    drawing primitives are now in the module -    @Objects.DrawingPrimitives@.+  * Major change - removed @ContextFun@ from @Kernel.Base@. Now +    the drawing objects (Image, LocImage, Connector...) are +    newtype wrapped Reader-Writer monads rather than aliases to +    one of the arity family of ContextFuns. Being newtypes gives+    a lot better opportunities for overloading.   .-  v0.14.0 to v0.15.0:+  * Changed Displacement API - it is smaller, and the function +    naming is more uniform.   . -  * Split previous @Wumpus-Basic@ package into two packages:-    @Wumpus-Basic@ and @Wumpus-Drawing@. This is a pratical move -    to separate the developed (although not yet polished) @Kernel@ -    and @FontLoader@ code from the prototypical @Drawing@ code.-  .-  * Renamed the @Drawing@ object to @CtxPicture@. Although -    @CtxPicture@ is a less pleasant name, it should be less -    confusing. A @CtxPicture@ is the essentially the @Picture@ -    type from Wumpus-Core with an implicit context - -    @ContextPicture@ is simply too long and @CtxPicture@ is -    almost jibberish but the previous unrelated name @Drawing@ -    was not helpful.-  .-  * @Kernel.Base.ScalingContext@ has been simplified. -    ScalingContexts are no longer manipulated via a custom Reader-    monad or transformer as the type signatures were too unwieldy.-  .-  * Added @TextMargin@ to the @DrawingContext@ - Wumpus-Drawing -    can now calculate more appealing bounding boxes for text.+  * Changed @DrawingPimitives@ to use @DrawStyle@.+  . +  * Moved vertices generating functions from @Geometry.Path@ to +    @Geometry.Vertices@.   . build-type:         Simple stability:          highly unstable@@ -126,18 +65,19 @@                       directory       >= 1.0     && <  2.0,                        filepath        >= 1.1     && <  2.0,                       vector-space    >= 0.6     && <  1.0,-                      wumpus-core     >= 0.50.0  && <  0.51.0+                      wumpus-core     >= 0.51.0  && <  0.52.0       exposed-modules:     Wumpus.Basic.Geometry,     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,     Wumpus.Basic.Kernel.Base.BaseDefs,-    Wumpus.Basic.Kernel.Base.ContextFun,     Wumpus.Basic.Kernel.Base.DrawingContext,     Wumpus.Basic.Kernel.Base.FontSupport,     Wumpus.Basic.Kernel.Base.QueryDC,@@ -154,7 +94,6 @@     Wumpus.Basic.Kernel.Objects.CtxPicture,     Wumpus.Basic.Kernel.Objects.Displacement,     Wumpus.Basic.Kernel.Objects.DrawingPrimitives,-    Wumpus.Basic.Kernel.Objects.Image,     Wumpus.Basic.Kernel.Objects.LocImage,     Wumpus.Basic.Kernel.Objects.LocThetaImage,     Wumpus.Basic.Kernel.Objects.Orientation,