wumpus-basic 0.15.0 → 0.16.0

raw patch · 28 files changed

+3203/−774 lines, 28 filesdep ~wumpus-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: wumpus-core

API changes (from Hackage documentation)

Files

• demo/SimpleAdvGraphic.hs +52/−0
• demo/SimplePosImage.hs +98/−0
• src/Wumpus/Basic/Geometry/Base.hs +468/−0
• src/Wumpus/Basic/Geometry/Intersection.hs +223/−0
• src/Wumpus/Basic/Geometry/Paths.hs +138/−0
• src/Wumpus/Basic/Geometry/Quadrant.hs +306/−0
• src/Wumpus/Basic/Kernel.hs +7/−1
• src/Wumpus/Basic/Kernel/Base/Anchors.hs +77/−93
• src/Wumpus/Basic/Kernel/Base/BaseDefs.hs +25/−92
• src/Wumpus/Basic/Kernel/Base/GlyphMetrics.hs +13/−10
• src/Wumpus/Basic/Kernel/Base/QueryDC.hs +31/−15
• src/Wumpus/Basic/Kernel/Base/UpdateDC.hs +9/−4
• src/Wumpus/Basic/Kernel/Objects/AdvanceGraphic.hs +90/−30
• src/Wumpus/Basic/Kernel/Objects/BaseObjects.hs +0/−5
• src/Wumpus/Basic/Kernel/Objects/Bounded.hs +35/−7
• src/Wumpus/Basic/Kernel/Objects/Connector.hs +42/−4
• src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs +227/−175
• src/Wumpus/Basic/Kernel/Objects/Displacement.hs +277/−0
• src/Wumpus/Basic/Kernel/Objects/DrawingPrimitives.hs +651/−0
• src/Wumpus/Basic/Kernel/Objects/Graphic.hs +126/−322
• src/Wumpus/Basic/Kernel/Objects/PosImage.hs +237/−0
• src/Wumpus/Basic/System/FontLoader/Afm.hs +1/−0
• src/Wumpus/Basic/System/FontLoader/Base/AfmParserBase.hs +4/−0
• src/Wumpus/Basic/System/FontLoader/Base/Datatypes.hs +12/−8
• src/Wumpus/Basic/System/FontLoader/Base/FontLoadMonad.hs +12/−2
• src/Wumpus/Basic/System/FontLoader/GhostScript.hs +1/−0
• src/Wumpus/Basic/VersionNumber.hs +3/−3
• wumpus-basic.cabal +38/−3

@@ -0,0 +1,52 @@+{-# OPTIONS -Wall #-}+++module SimpleAdvGraphic where++import Wumpus.Basic.Kernel++import Wumpus.Core                      -- package: wumpus-core++import System.Directory++main :: IO ()+main = do +    createDirectoryIfMissing True "./out/"+    let pic1 = runCtxPictureU std_attr drawing01+    writeEPS "./out/simple_adv_graphic01.eps" pic1+    writeSVG "./out/simple_adv_graphic01.svg" pic1+++std_attr :: DrawingContext+std_attr = standardContext 24+++drawing01 :: DCtxPicture+drawing01 = drawTracing $ mf +++mf :: (Floating u, FromPtSize u) => TraceDrawing u ()+mf = do+    drawi_ $ advspace (hvec 10) [text01, text02, text01] `at` P2 0 120+    drawi_ $ advconcat [text01, text02, text01] `at` P2 0 80+    drawi_ $ (miniDisk `advcat` text01 `advcat` miniDisk) `at` P2 0 40 +    drawi_ $ (miniDisk `advcat` text02 `advcat` miniDisk) `at` P2 0 0 +++-- Normally, text calculate the advance vector from the font +-- metrics...+--+text01 :: Num u => AdvGraphic u +text01 = replaceAns (hvec 84) $ textline "text01"+    ++text02 :: Num u => AdvGraphic u +text02 = replaceAns (hvec 210) $ textline "text number two"+++miniDisk :: Num u => AdvGraphic u+miniDisk = replaceAns (V2 0 0) $ localize (fillColour sienna) $ filledDisk 3+++sienna :: RGBi+sienna = RGBi 160 82 45

@@ -0,0 +1,98 @@+{-# OPTIONS -Wall #-}+++module SimplePosImage where++import Wumpus.Basic.Kernel++import Wumpus.Core                      -- package: wumpus-core+import Wumpus.Core.Colour ( red )++import System.Directory++main :: IO ()+main = do +    createDirectoryIfMissing True "./out/"+    let pic1 = runCtxPictureU std_attr drawing01+    writeEPS "./out/simple_pos_image01.eps" pic1+    writeSVG "./out/simple_pos_image01.svg" pic1+++std_attr :: DrawingContext+std_attr = standardContext 24+++drawing01 :: DCtxPicture+drawing01 = drawTracing $ localize (fillColour red) $ mf +++mf :: (Floating u, FromPtSize u) => TraceDrawing u ()+mf = do+    draw $ testDrawMinor NN     `at` (P2   0 300)+    draw $ testDrawMinor SS     `at` (P2  75 300)+    draw $ testDrawMinor EE     `at` (P2 150 300)+    draw $ testDrawMinor WW     `at` (P2 225 300)+    draw $ testDrawMinor NE     `at` (P2   0 225)+    draw $ testDrawMinor SE     `at` (P2  75 225)+    draw $ testDrawMinor SW     `at` (P2 150 225)+    draw $ testDrawMinor NW     `at` (P2 225 225)+    draw $ testDrawMinor CENTER `at` (P2   0 150)+    draw $ testDrawBl    CENTER `at` (P2 225 150)+    draw $ testDrawBl    NN     `at` (P2   0 75)+    draw $ testDrawBl    SS     `at` (P2  75 75)+    draw $ testDrawBl    EE     `at` (P2 150 75)+    draw $ testDrawBl    WW     `at` (P2 225 75)+    draw $ testDrawBl    NE     `at` (P2   0 0)+    draw $ testDrawBl    SE     `at` (P2  75 0)+    draw $ testDrawBl    SW     `at` (P2 150 0)+    draw $ testDrawBl    NW     `at` (P2 225 0)+    ++testDrawBl :: Floating u => RectPosition -> LocGraphic u+testDrawBl rpos = filledDisk 2 `oplus` (rectBl `startPos` rpos)++rectBl :: Floating u => PosGraphic u +rectBl = makePosImage opos (mkRectBl w h)+  where+    w    = 40 +    h    = 20+    opos = ObjectPos { op_x_minor = 0+                     , op_x_major = w+                     , op_y_minor = 0+                     , op_y_major = h }+ ++-- start-point - bottom left+mkRectBl :: Floating u => u -> u -> LocGraphic u+mkRectBl w h = promoteR1 $ \bl -> +    let br = displaceH w bl+        tr = displaceV h br+        tl = displaceV h bl+    in closedStroke $ vertexPath [bl, br, tr, tl]++++testDrawMinor :: Floating u => RectPosition -> LocGraphic u+testDrawMinor rpos = filledDisk 2 `oplus` (rectMinor `startPos` rpos)++rectMinor :: Floating u => PosGraphic u +rectMinor = makePosImage opos (mkRectMinor m w h)+  where+    m    = 10+    w    = 40 +    h    = 20+    opos = ObjectPos { op_x_minor = m+                     , op_x_major = (w-m)+                     , op_y_minor = m+                     , op_y_major = (h-m) }+ ++-- start-point - +10 +10+mkRectMinor :: Floating 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 closedStroke $ vertexPath [bl, br, tr, tl]+

@@ -0,0 +1,468 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Geometry.Base+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Base geometric types and operations.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Geometry.Base+  ( ++  -- * constants+    half_pi+  , two_pi++  -- * 2x2 Matrix+  , Matrix2'2(..)+  , DMatrix2'2+  , identity2'2+  , det2'2+  , transpose2'2+  +  -- * Line in equational form +  , LineEquation(..)+  , DLineEquation+  , lineEquation+  , pointViaX+  , pointViaY+  , pointLineDistance++  -- * Line segment+  , LineSegment(..)+  , DLineSegment+  +  , rectangleLineSegments+  , polygonLineSegments++  -- * Cubic Bezier curves+  +  , BezierCurve(..)+  , DBezierCurve++  , bezierLength+  , subdivide+  , subdividet+  +  , bezierArcPoints+  , bezierMinorArc++  -- * Functions+  , affineComb+  , midpoint+  , lineAngle+++  ) +  where++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space+import Data.VectorSpace+++++half_pi :: Floating u => u+half_pi = 0.5*pi++two_pi  :: Floating u => u+two_pi  = 2*pi+++--------------------------------------------------------------------------------+-- 2x2 matrix+++-- | 2x2 matrix, considered to be in row-major form.+-- +-- > (M2'2 a b+-- >       c d)+--+-- ++data Matrix2'2 u = M2'2 !u !u   !u !u+  deriving (Eq)++type DMatrix2'2 = Matrix2'2 Double+++type instance DUnit (Matrix2'2 u)   = u+++instance Functor Matrix2'2 where+  fmap f (M2'2 a b  c d) = M2'2 (f a) (f b)  (f c) (f d)++instance Show u => Show (Matrix2'2 u) where+  show (M2'2 a b c d) = "(M2'2 " ++ body ++ ")" +    where+      body = show [[a,b],[c,d]]++lift2Matrix2'2 :: (u -> u -> u) -> Matrix2'2 u -> Matrix2'2 u -> Matrix2'2 u+lift2Matrix2'2 op (M2'2 a b c d) (M2'2 m n o p) = +      M2'2 (a `op` m) (b `op` n) +           (c `op` o) (d `op` p)++instance Num u => Num (Matrix2'2 u) where+  (+) = lift2Matrix2'2 (+) +  (-) = lift2Matrix2'2 (-)++  (*) (M2'2 a b c d) (M2'2 m n o p) = +      M2'2 (a*m + b*o) (a*n + b*p)  +           (c*m + d*o) (c*n + d*p) +  +  abs    = fmap abs +  negate = fmap negate+  signum = fmap signum+  fromInteger a = M2'2 a' a'  a' a' where a' = fromInteger a+++-- | Construct the identity 2x2 matrix:+--+-- > (M2'2 1 0 +-- >       0 1 )+--+identity2'2 :: Num u => Matrix2'2 u+identity2'2 = M2'2  1 0  +                    0 1+++-- | Determinant of a 2x2 matrix.+--+det2'2 :: Num u => Matrix2'2 u -> u+det2'2 (M2'2 a b c d) = a*d - b*c+++-- | Transpose a 2x2 matrix.+--+transpose2'2 :: Matrix2'2 u -> Matrix2'2 u+transpose2'2 (M2'2 a b +                   c d) = M2'2 a c+                               b d+++--------------------------------------------------------------------------------++-- | Line in equational form, i.e. @Ax + By + C = 0@.+--+data LineEquation u = LineEquation +      { line_eqn_A :: !u+      , line_eqn_B :: !u+      , line_eqn_C :: !u +      }+  deriving (Eq,Show)++type DLineEquation = LineEquation Double++type instance DUnit (LineEquation u) = u++-- | 'lineEquation' : @ point1 * point2 -> LineEquation @+-- +-- Construct a line in equational form bisecting the supplied +-- points.+--+lineEquation :: Num u => Point2 u -> Point2 u -> LineEquation u+lineEquation (P2 x1 y1) (P2 x2 y2) = LineEquation a b c +  where+    a = y1 - y2+    b = x2 - x1+    c = (x1*y2) - (x2*y1)++-- | 'pointViaX' : @ x * line_equation -> Point @+--+-- Calculate the point on the line for the supplied @x@ value.+-- +pointViaX :: Fractional u => u -> LineEquation u -> Point2 u+pointViaX x (LineEquation a b c) = P2 x y+  where+    y = ((a*x) + c) / (-b)+++-- | 'pointViaY' : @ y * line_equation -> Point @+--+-- Calculate the point on the line for the supplied @y@ value.+-- +pointViaY :: Fractional u => u -> LineEquation u -> Point2 u+pointViaY y (LineEquation a b c) = P2 x y+  where+    x = ((b*y) + c) / (-a)+++-- | 'pointLineDistance' : @ point -> line -> Distance @+--+-- Find the distance from a point to a line in equational form+-- using this formula:+-- +-- > P(u,v) +-- > L: Ax + By + C = 0+-- >+-- > (A*u) + (B*v) + C +-- > -----------------+-- > sqrt $ (A^2) +(B^2)+--+-- A positive distance indicates the point is above the line, +-- negative indicates below.+--+pointLineDistance :: Floating u => Point2 u -> LineEquation u -> u+pointLineDistance (P2 u v) (LineEquation a b c) = +    ((a*u) + (b*v) + c) / base+  where+    base = sqrt $ (a^two) + (b^two)+    two  :: Integer+    two  = 2++--------------------------------------------------------------------------------++data LineSegment u = LineSegment (Point2 u) (Point2 u)+  deriving (Eq,Ord,Show)++type DLineSegment = LineSegment Double++type instance DUnit (LineSegment u) = u++++-- | 'rectangleLineSegments' : @ half_width * half_height -> [LineSegment] @+--+-- Compute the line segments of a rectangle.+--+rectangleLineSegments :: Num u => u -> u -> Point2 u -> [LineSegment u]+rectangleLineSegments hw hh ctr = +    [ LineSegment br tr, LineSegment tr tl, LineSegment tl bl+    , LineSegment bl br +    ]+  where+    br = ctr .+^ vec hw    (-hh)+    tr = ctr .+^ vec hw    hh+    tl = ctr .+^ vec (-hw) hh+    bl = ctr .+^ vec (-hw) (-hh)+++-- | 'polygonLineSegments' : @ [point] -> [LineSegment] @+--+-- Build the line segments of a polygon fome a list of +-- its vertices.+--+polygonLineSegments :: [Point2 u] -> [LineSegment u]+polygonLineSegments []     = []+polygonLineSegments (x:xs) = step x xs +  where+    step a []        = [LineSegment a x]+    step a (b:bs)    = (LineSegment a b) : step b bs+++++--------------------------------------------------------------------------------+-- Bezier curves+++-- | A Strict cubic Bezier curve.+--+data BezierCurve u = BezierCurve !(Point2 u) !(Point2 u) !(Point2 u) !(Point2 u)+  deriving (Eq,Ord,Show)++type DBezierCurve = BezierCurve Double++type instance DUnit (BezierCurve u) = u++++-- | 'bezierLength' : @ start_point * control_1 * control_2 * +--        end_point -> Length @ +--+-- Find the length of a Bezier curve. The result is an +-- approximation, with the /tolerance/ is 0.1 of a point. This+-- seems good enough for drawing (potentially the tolerance could +-- be larger still). +--+-- The result is found through repeated subdivision so the +-- calculation is potentially costly.+--+bezierLength :: (Floating u, Ord u, FromPtSize u)      +             => BezierCurve u -> u+bezierLength = gravesenLength (fromPtSize 0.1)++++-- | Jens Gravesen\'s bezier arc-length approximation. +--+-- Note this implementation is parametrized on error tolerance.+--+gravesenLength :: (Floating u, Ord u) => u -> BezierCurve u -> u+gravesenLength err_tol crv = step crv +  where+    step c = let l1 = ctrlPolyLength c+                 l0 = cordLength c+             in if   l1-l0 > err_tol+                then let (a,b) = subdivide c in step a + step b+                else 0.5*l0 + 0.5*l1++-- | Length of the tree lines spanning the control points.+--+ctrlPolyLength :: Floating u => BezierCurve u -> u+ctrlPolyLength (BezierCurve p0 p1 p2 p3) = len p0 p1 + len p1 p2 + len p2 p3+  where+    len pa pb = vlength $ pvec pa pb+++-- | Length of the cord - start point to end point.+--+cordLength :: Floating u => BezierCurve u -> u+cordLength (BezierCurve p0 _ _ p3) = vlength $ pvec p0 p3+++++-- | Curve subdivision via de Casteljau\'s algorithm.+--+subdivide :: Fractional u +          => BezierCurve u -> (BezierCurve u, BezierCurve u)+subdivide (BezierCurve p0 p1 p2 p3) =+    (BezierCurve p0 p01 p012 p0123, BezierCurve p0123 p123 p23 p3)+  where+    p01   = midpoint p0    p1+    p12   = midpoint p1    p2+    p23   = midpoint p2    p3+    p012  = midpoint p01   p12+    p123  = midpoint p12   p23+    p0123 = midpoint p012  p123++-- | subdivide with an affine weight along the line...+--+subdividet :: Real u+           => u -> BezierCurve u -> (BezierCurve u, BezierCurve u)+subdividet t (BezierCurve p0 p1 p2 p3) = +    (BezierCurve p0 p01 p012 p0123, BezierCurve p0123 p123 p23 p3)+  where+    p01   = affineComb t p0    p1+    p12   = affineComb t p1    p2+    p23   = affineComb t p2    p3+    p012  = affineComb t p01   p12+    p123  = affineComb t p12   p23+    p0123 = affineComb t p012  p123+++++kappa :: Floating u => u+kappa = 4 * ((sqrt 2 - 1) / 3)++++-- | 'bezierArcPoints' : @ apex_angle * radius * rotation * center -> [Point] @+--+-- > ang should be in the range 0 < ang < 360deg.+--+-- > if   0 < ang <=  90 returns 4 points+-- > if  90 < ang <= 180 returns 7 points+-- > if 180 < ang <= 270 returns 10 points+-- > if 270 < ang <  360 returns 13 points+--+bezierArcPoints ::  Floating u +                => Radian -> u -> Radian -> Point2 u -> [Point2 u]+bezierArcPoints ang radius theta pt = go (circularModulo ang)+  where+    go a | a <= half_pi = wedge1 a+         | a <= pi      = wedge2 (a/2)+         | a <= 1.5*pi  = wedge3 (a/3)+         | otherwise    = wedge4 (a/4)+    +    wedge1 a = +      let (BezierCurve p0 p1 p2 p3) = bezierMinorArc a radius theta pt+      in [p0,p1,p2,p3]++    wedge2 a = +      let (BezierCurve  p0 p1 p2 p3) = bezierMinorArc a radius theta pt+          (BezierCurve _   p4 p5 p6) = bezierMinorArc a radius (theta+a) pt+      in [ p0,p1,p2,p3, p4,p5,p6 ] ++    wedge3 a = +      let (BezierCurve p0 p1 p2 p3) = bezierMinorArc a radius theta pt+          (BezierCurve _  p4 p5 p6) = bezierMinorArc a radius (theta+a) pt+          (BezierCurve _  p7 p8 p9) = bezierMinorArc a radius (theta+a+a) pt+      in [ p0,p1,p2,p3, p4,p5,p6, p7, p8, p9 ] +  +    wedge4 a = +      let (BezierCurve p0 p1 p2 p3)    = bezierMinorArc a radius theta pt+          (BezierCurve _  p4 p5 p6)    = bezierMinorArc a radius (theta+a) pt+          (BezierCurve _  p7 p8 p9)    = bezierMinorArc a radius (theta+a+a) pt+          (BezierCurve _  p10 p11 p12) = bezierMinorArc a radius (theta+a+a+a) pt+      in [ p0,p1,p2,p3, p4,p5,p6, p7,p8,p9, p10,p11, p12 ] +++-- | 'bezierMinorArc' : @ apex_angle * radius * rotation * center -> BezierCurve @+--+-- > ang should be in the range 0 < ang <= 90deg.+--+bezierMinorArc :: Floating u +                 => Radian -> u -> Radian -> Point2 u -> BezierCurve u+bezierMinorArc ang radius theta pt = BezierCurve p0 c1 c2 p3+  where+    kfactor = fromRadian $ ang / (0.5*pi)+    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+++--------------------------------------------------------------------------------+--+++-- | Affine combination...+--+affineComb :: Real u => u -> Point2 u -> Point2 u -> Point2 u+affineComb t p1 p2 = p1 .+^ t *^ (p2 .-. p1)+++-- | 'midpoint' : @ start_point * end_point -> Midpoint @+-- +-- Mid-point on the line formed between the two supplied points.+--+midpoint :: Fractional u => Point2 u -> Point2 u -> Point2 u+midpoint p0 p1 = p0 .+^ v1 ^/ 2 where v1 = p1 .-. p0++++-- | 'lineAngle' : @ start_point * end_point -> Angle @+--+-- Calculate the counter-clockwise angle between the line formed +-- by the two points and the horizontal plane.+--+lineAngle :: (Floating u, Real u) => Point2 u -> Point2 u -> Radian+lineAngle (P2 x1 y1) (P2 x2 y2) = step (x2 - x1) (y2 - y1)+  where+    -- north-east quadrant +    step x y | pve x && pve y = toRadian $ atan (y/x)          +    +    -- north-west quadrant+    step x y | pve y          = pi     - (toRadian $ atan (y / abs x))++    -- south-east quadrant+    step x y | pve x          = (2*pi) - (toRadian $ atan (abs y / x)) ++    -- otherwise... south-west quadrant+    step x y                  = pi     + (toRadian $ atan (y/x))++    pve a                     = signum a >= 0++-- Ideally this would be in Geometry.Quadrant.+-- And surely there is a simpler formulation...++

@@ -0,0 +1,223 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Geometry.Intersection+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Intersection of line to line and line to plane.+-- +-- \*\* - WARNING \*\* - this uses quite a high tolerance for +-- floating point equality. +--+--------------------------------------------------------------------------------++module Wumpus.Basic.Geometry.Intersection+  ( ++    LineSegment+  , interLineLine+  , interLinesegLineseg+  , interLinesegLine+  , interCurveLine++  , findIntersect+  , makePlane+  , rectangleLineSegments+  , polygonLineSegments+++  ) +  where++import Wumpus.Basic.Geometry.Base++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space++++-- Potentially lines hould be a new datatype.+++-- | 'interLineLine' : @ line1 * line2 -> Maybe Point @+-- +-- Find the intersection of two lines, if there is one. +--+-- 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+-- or the are parallel.+--+interLineLine :: Fractional u +              => (Point2 u, Point2 u) -> (Point2 u, Point2 u) +              -> Maybe (Point2 u)+interLineLine (p1,p2) (q1,q2) = +    if det_co == 0 then Nothing +                   else Just $ P2 (det_xm / det_co) (det_ym / det_co)+  where+    -- Ax + By + C = 0+    LineEquation a1 b1 c1 = lineEquation p1 p2+    LineEquation a2 b2 c2 = lineEquation q1 q2++    coeffM                = M2'2 a1 b1  a2 b2+    det_co                = det2'2 coeffM++    xM                    = M2'2  (negate c1) b1  (negate c2) b2+    det_xm                = det2'2 xM++    yM                    = M2'2  a1 (negate c1) a2 (negate c2)+    det_ym                = det2'2 yM++++-- | 'interLinesegLineseg' : @ line_segment1 * line_segment2 -> Maybe Point @+-- +-- Find the intersection of two line segments, if there is one. +--+-- An answer of @Nothing@ indicates that the line segments +-- coincide, or that there is no intersection.+--+interLinesegLineseg :: (Fractional u, Ord u, FromPtSize u)+                    => LineSegment u -> LineSegment u -> Maybe (Point2 u)+interLinesegLineseg a@(LineSegment p q) b@(LineSegment s t) = +    interLineLine (p,q) (s,t) >>= segcheck+  where+    segcheck = mbCheck (\pt -> withinPoints pt a && withinPoints pt b)+ ++-- | 'interLinesegLine' : @ line_segment * line -> Maybe Point @+-- +-- Find the intersection of a line and a line segment, if there +-- is one. +--+-- An answer of @Nothing@ indicates that the the line and line+-- segment coincide, or that there is no intersection.+--+interLinesegLine :: (Fractional u, Ord u, FromPtSize u)+                 => LineSegment u -> (Point2 u, Point2 u) -> Maybe (Point2 u)+interLinesegLine a@(LineSegment p q) line = +    interLineLine (p,q) line >>= segcheck+  where+    segcheck = mbCheck (\pt -> withinPoints pt a)+++mbCheck :: (a -> Bool) -> a -> Maybe a+mbCheck test a = if test a then Just a else Nothing++-- | 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.+--+withinPoints :: (Ord u, FromPtSize u) => Point2 u -> LineSegment u -> Bool+withinPoints (P2 x y) (LineSegment (P2 x0 y0) (P2 x1 y1)) =  +    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)++    tGT a b         = a < b || abs (a-b) < tolerance++-- | Note - its important to use tolerance for the @withPoints@ +-- function.+--+tolerance :: FromPtSize u => u+tolerance = fromPtSize 0.01+++++++--------------------------------------------------------------------------------+-- intersection of line and Bezier curve++interCurveLine :: (Floating u , Ord u, FromPtSize u)+               => BezierCurve u -> (Point2 u, Point2 u) -> Maybe (Point2 u)+interCurveLine c0 (p,q) = step c0+  where+    eqline  = lineEquation p q+    step c  = case cut c eqline of+                Left pt     -> Just pt      -- cut at start or end+                Right False -> Nothing+                Right True  -> let (a,b) = subdivide c+                               in case step a of+                                   Just pt -> Just pt+                                   Nothing -> step b+ +-- | Is the curve cut by the line? +--+-- The curve might cut at the start or end points - which is good+-- as it saves performing a subdivision. But make the return type+-- a bit involved.+--+cut :: (Floating u , Ord u, FromPtSize u)+    => BezierCurve u -> LineEquation u -> Either (Point2 u) Bool+cut (BezierCurve p0 p1 p2 p3) line = +    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+    tEQ = \a b -> abs (a-b) < tolerance+    pve = \a -> a > tolerance+    nve = \a -> a < (negate tolerance)+    d0  = pointLineDistance p0 line +    d1  = pointLineDistance p1 line +    d2  = pointLineDistance p2 line +    d3  = pointLineDistance p3 line ++++    +++--------------------------------------------------------------------------------+-- Intersection of shape boundaries...++++-- | 'findIntersect' :: @ radial_origin * theta * [line_segment] -> Maybe Point @+--+-- Find the first intersection of a line through @radial_origin@ +-- at angle @theta@ and the supplied line segments, if there +-- is one. +--+findIntersect :: (Floating u, Real u, Ord u, FromPtSize u)+               => Point2 u -> Radian -> [LineSegment u] +               -> Maybe (Point2 u)+findIntersect radial_ogin ang = step +  where+    plane       = makePlane radial_ogin ang+    step []     = Nothing+    step (x:xs) = case interLinesegLine x plane of +                     Just pt | quadrantCheck ang radial_ogin pt -> Just pt+                     _       -> step xs+++-- | The tolerance on Radian equality should be acceptable...+--+quadrantCheck :: (Real u, Floating u) +              => 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)++

@@ -0,0 +1,138 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Basic.Paths+-- Copyright   :  (c) Stephen Tetley 2010-2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Paths for /elementary/ shapes - rectangles...+-- +-- \*\* - WARNING \*\* - half baked. +--+--------------------------------------------------------------------------------++module Wumpus.Basic.Geometry.Paths+  ( +    LocCoordPath+  , coordinatePrimPath++  , rectangleCoordPath+  , diamondCoordPath+  , polygonCoordPath+  , isoscelesTriangleCoordPath+  , isoscelesTrianglePoints+  , equilateralTriangleCoordPath+  , equilateralTrianglePoints+  ) +  where++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space+++import Data.List ( unfoldr )+++-- | 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...+--+ +coordinatePrimPath :: Num u => Point2 u -> LocCoordPath u -> PrimPath u+coordinatePrimPath pt fn = go (fn pt)+  where+    go ps@(_:_) = vertexPath ps+    go []       = emptyPath pt        -- fallback+++-- NOTE - These functions need changing to generate LocCoordPaths...++-- | Supplied point is /bottom-left/, subsequenct points are +-- counter-clockise 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] @ +--+polygonCoordPath :: Floating u => Int -> u -> LocCoordPath u+polygonCoordPath n radius ctr = unfoldr phi (0,(pi*0.5))+  where+    theta = (pi*2) / fromIntegral n+    +    phi (i,ang) | i < n     = Just (ctr .+^ avec ang radius, (i+1,ang+theta))+                | otherwise = Nothing++++-- | @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.+--+isoscelesTrianglePoints :: Floating u +                        => u -> u -> Point2 u -> (Point2 u, Point2 u, Point2 u)+isoscelesTrianglePoints bw h ctr = (bl, br, top) +  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)+++-- | @ 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)+

@@ -0,0 +1,306 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Geometry.Quadrant+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Quadrants and trigonometric calculations.+-- +-- \*\* - WARNING \*\* - in progress. +--+--------------------------------------------------------------------------------++module Wumpus.Basic.Geometry.Quadrant+  ( +    Quadrant(..)++  , quadrant+  , qiModulo++  , rectRadialVector+  , rectangleQI++  , diamondRadialVector+  , triangleRadialVector+  , triangleQI+  , rightTrapezoidQI+  +  , rightTrapeziumBaseWidth++  ) +  where++import Wumpus.Core                              -- package: wumpus-core++data Quadrant = QUAD_NE | QUAD_NW | QUAD_SW | QUAD_SE+  deriving (Enum,Eq,Ord,Show)++-- | 'quadrant' : @ ang -> Quadrant @+--+-- Get the quadrant of an angle.+--+quadrant :: Radian -> Quadrant+quadrant = fn . circularModulo+  where+    fn a | a < 0.5*pi   = QUAD_NE+         | a < pi       = QUAD_NW+         | a < 1.5*pi   = QUAD_SW+         | otherwise    = QUAD_SE+++-- | 'qiModulo' : @ ang -> Radian @+-- +-- Modulo an angle so it lies in quadrant I (north east), +-- i.e. modulo into the range @0..(pi/2)@.+--+qiModulo :: Radian -> Radian +qiModulo r = d2r $ dec + (fromIntegral $ i `mod` 90)+  where+    i       :: Integer+    dec     :: Double+    (i,dec) = properFraction $ r2d r+++--------------------------------------------------------------------------------++negateX :: Num u => Vec2 u -> Vec2 u+negateX (V2 x y) = V2 (-x) y++negateY :: Num u => Vec2 u -> Vec2 u+negateY (V2 x y) = V2 x (-y)++negateXY :: Num u => Vec2 u -> Vec2 u+negateXY (V2 x y) = V2 (-x) (-y)+++-- | '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)+++-- | 'rectangleQI' : @ width * height * ang -> Vec @+--+-- Find where a line from (0,0) in direction @ang@ intersects the +-- top or right side of a rectangle in QI (left side is the +-- y-axis, bottom is the x-axis).  +--+-- > ang must be in the @range 0 < ang <= 90 deg@.+-- >+-- > 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+  where+    theta               = toRadian $ atan (h/w)+++-- | 'diamondRadialVector' : @ half_width * half_height * ang -> Vec @+--+-- 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.+--+diamondRadialVector :: (Real u, Floating u) => u -> u -> Radian -> Vec2 u+diamondRadialVector hw hh ang = fn $ circularModulo ang+  where+    fn a | a < 0.5*pi   = triangleQI hw hh a+         | a < pi       = negateX  $ triangleQI hw hh (pi - a)+         | a < 1.5*pi   = negateXY $ triangleQI hw hh (a - pi) +         | otherwise    = negateY  $ triangleQI hw hh (2*pi - a)+++-- | 'triangleRadialVector' : @ half_base_width * height_minor * +--        height_minor * ang -> Vec @+--+-- Find where a radial line extended from (0,0) with the elevation+-- @ang@ intersects with an enclosing triangle. The triangle has +-- the centroid at (0,0), so solutions in quadrants I and II are +-- intersections with a simple line. Intersections in quadrants+-- III and IV can intersect either the respective side or the +-- base.+-- +--+triangleRadialVector :: (Real u, Floating u) => u -> u -> u -> Radian -> Vec2 u+triangleRadialVector hbw hminor hmajor ang = fn $ circularModulo ang+  where+    fn a | a < 0.5*pi   = triangleQI major_width hmajor a+         | a < pi       = negateX  $ triangleQI major_width hmajor (pi - a)+         | a < 1.5*pi   = negateXY $ rightTrapezoidQI hbw hminor base_rang (a - pi) +         | otherwise    = negateY  $ rightTrapezoidQI hbw hminor base_rang (2*pi - a)++    height              = hmajor + hminor+    base_rang           = toRadian $ atan (height / hbw)+    major_width         = hmajor / (fromRadian $ tan base_rang)+++-- | 'triangleQI' : @ width * height * ang -> Vec @+--+-- 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.+--+triangleQI :: (Real u, Floating u) => u -> u -> Radian -> Vec2 u+triangleQI w h ang = avec ang dist+  where+    base_ang = atan (h / w)+    apex     = pi - (base_ang + fromRadian ang)+    dist     = sin base_ang * (w / sin apex)++++-- | 'rightTrapezoidQI' : @ top_width * height * top_right_ang -> Vec @+--+-- Find where a line from (0,0) with elevation @ang@ intersects +-- the either the lines A_B or B_D in a right trapezoid in QI. +-- +-- The right trapezoid has a variable right side. Left side is the+-- y-axis (C_A), bottom side is the x-axis (C_D), top side is +-- parallel to the x-axis (A_B).+--+-- >  A   B+-- >  -----+-- >  |    \+-- >  |     \     +-- >  -------+-- >  C      D+--+-- >  A      B+-- >  -------+-- >  |     /+-- >  |    /     +-- >  -----+-- >  C   D+--+-- > ang must be in the range 0 < ang <= 90.+-- >+-- > top_width and height must be positive.+--+rightTrapezoidQI :: (Real u, Floating u) +                 => u -> u -> Radian -> Radian -> Vec2 u+rightTrapezoidQI tw h top_rang ang = +    if w0 <= tw then dv else avec ang minor_dist+  where+    -- dist is hypotenuse of a right triangle1+    dist         = h / (fromRadian $ sin ang)+    +    -- potentially this vector is *too long*.+    dv@(V2 w0 _) = avec ang dist++    -- this is dist *cut short* because it intersects the right+    -- side rather than the top+    minor_dist   = triangleLeftSide base_width ang lr_ang+    +    lr_ang       = pi - top_rang++    base_width   = rightTrapeziumBaseWidth tw h top_rang+++-- Legend:+-- +-- > @top_rang@ is A/B\C.+-- >+-- > @ang@ is B/C\D.+-- > +-- > w (width) is A_B.+--+-- > h (height) is C_A.+-- +-- >  A     B+-- >  ------ +-- >  |    / .+-- >  |   /   .+-- >  |  /     .+-- >  | /       .     +-- >  |/..........+-- >  C          D+--+-- Synthetically:+--+-- > Right triangle 1 is ABC.+-- >+-- > @dist@ is C_B.+-- >+-- > @base_width@ is C_D.+-- >+-- > @lr_ang is C/D\B. +--   +++-- | 'traingleLeftSide' : @ base_width * left_ang * right_ang -> Length @+--+-- >  +-- >        C   +-- >       /\+-- >      /  \+-- >     /    \+-- >    /      \    +-- >   /________\+-- >  A          B+-- >+-- +-- > Calculate A_C given side A_B, angle C/A\B and angle A/B\C.+--+triangleLeftSide :: Fractional u => u -> Radian -> Radian -> u+triangleLeftSide base_width lang rang =+    (fromRadian $ sin rang) / factor +  where+    apex   = pi - (lang + rang)+    factor = (fromRadian $ sin apex) / base_width+++-- | 'rightTrapeziumBaseWidth' : @ top_width * height * top_right_ang -> Length @+-- +-- Find the length of the line C_D:+--+-- >  A   B+-- >  -----+-- >  |    \+-- >  |     \     +-- >  -------+-- >  C      D+--+-- >  A      B+-- >  -------+-- >  |     /+-- >  |    /     +-- >  -----+-- >  C   D+--+-- +rightTrapeziumBaseWidth :: Fractional u => u -> u -> Radian -> u+rightTrapeziumBaseWidth tw h tr_ang +    | tr_ang < half_pi = tw - shorten+    | 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)

@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.Kernel--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2010-2011 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com@@ -31,7 +31,10 @@   , module Wumpus.Basic.Kernel.Objects.Bounded   , module Wumpus.Basic.Kernel.Objects.Connector   , module Wumpus.Basic.Kernel.Objects.CtxPicture+  , module Wumpus.Basic.Kernel.Objects.Displacement+  , module Wumpus.Basic.Kernel.Objects.DrawingPrimitives   , module Wumpus.Basic.Kernel.Objects.Graphic+  , module Wumpus.Basic.Kernel.Objects.PosImage   , module Wumpus.Basic.Kernel.Objects.TraceDrawing   ) where @@ -49,5 +52,8 @@ import Wumpus.Basic.Kernel.Objects.Bounded import Wumpus.Basic.Kernel.Objects.Connector import Wumpus.Basic.Kernel.Objects.CtxPicture+import Wumpus.Basic.Kernel.Objects.Displacement+import Wumpus.Basic.Kernel.Objects.DrawingPrimitives import Wumpus.Basic.Kernel.Objects.Graphic+import Wumpus.Basic.Kernel.Objects.PosImage import Wumpus.Basic.Kernel.Objects.TraceDrawing

@@ -17,6 +17,12 @@ -- anchors on node shapes to get the start and end points for  -- connectors in a network (graph) diagram. -- +-- \*\* WARNING \*\* - The API here needs some thought as to a+-- good balance of the type classes - in a nutshell \"are corners +-- better than cardinals\". Originally I tried to follow how I +-- understand the TikZ anchors to work, but this is perhaps not +-- ideal for dividing into type-classes.+-- --------------------------------------------------------------------------------  module Wumpus.Basic.Kernel.Base.Anchors@@ -24,19 +30,17 @@    -- * Anchors     CenterAnchor(..)+  , ApexAnchor(..)   , CardinalAnchor(..)   , CardinalAnchor2(..)   , RadialAnchor(..)+  , TopCornerAnchor(..)+  , BottomCornerAnchor(..)+  , SideMidpointAnchor(..) +   -- * Extended anchor points-  , northwards-  , southwards-  , eastwards-  , westwards-  , northeastwards-  , southeastwards-  , southwestwards-  , northwestwards+  , projectAnchor    , radialConnectorPoints @@ -52,6 +56,13 @@ class CenterAnchor t where   center :: DUnit t ~ u => t -> Point2 u ++-- | Apex of an object.+--+class ApexAnchor t where+  apex :: DUnit t ~ u => t -> Point2 u++ -- | Cardinal (compass) positions on an object.  --  -- Note - in TikZ cardinal anchors are not necessarily at the@@ -67,13 +78,23 @@   east  :: DUnit t ~ u => t -> Point2 u   west  :: DUnit t ~ u => t -> Point2 u +--+-- Note - a design change is probably in order where the cardinals +-- should /always/ represent their true cardinal position.+--+-- If this change is made, it is worthwhile having cardinals as+-- classes (rather than making them derived operations on +-- RadialAnchor) as classes allow for more efficient +-- implementations usually by trigonometry.+--  + -- | Secondary group of cardinal (compass) positions on an object.  --  -- It seems possible that for some objects defining the primary -- compass points (north, south,...) will be straight-forward  -- whereas defining the secondary compass points may be --- problemmatic, hence the compass points are split into two +-- problematic, hence the compass points are split into two  -- classes. -- class CardinalAnchor2 t where@@ -92,108 +113,71 @@   radialAnchor :: DUnit t ~ u => Radian -> t -> Point2 u  ---extendPtDist :: (Real u, Floating u) => u -> Point2 u -> Point2 u -> Point2 u-extendPtDist d p1 p2 = let v   = pvec p1 p2-                           ang = vdirection v-                           len = vlength v-                       in p1 .+^ avec ang (len+d)----- | 'northwards' : @ dist * object -> Point @--- --- Project the anchor along a line from the center that goes --- through the north anchor. ------ If the distance is zero the answer with be the north anchor.------ If the distance is negative the answer within the object before --- the north anchor.+-- | Anchors at the top left and right corners of a shape. ----- If the distance is positive the anchor outside the object.+-- For some shapes (Rectangle) the TikZ convention appears to be+-- have cardinals as the corner anchors, but this doesn\'t seem+-- to be uniform. Wumpus will need to reconsider anchors at some +-- point... ---northwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t-              , u ~ DUnit t ) -           => u -> t -> Point2 u-northwards u a = extendPtDist u (center a) (north a)+class TopCornerAnchor t where+  topLeftCorner  :: DUnit t ~ u => t -> Point2 u+  topRightCorner :: DUnit t ~ u => t -> Point2 u  --- | 'southwards' : @ dist * object -> Point @--- --- Variant of the function 'northwards', but projecting the line --- southwards from the center of the object.+-- | Anchors at the bottom left and right corners of a shape. ---southwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t-              , u ~ DUnit t ) -           => u -> t -> Point2 u-southwards u a = extendPtDist u (center a) (south a)+class BottomCornerAnchor t where+  bottomLeftCorner  :: DUnit t ~ u => t -> Point2 u+  bottomRightCorner :: DUnit t ~ u => t -> Point2 u  --- | 'eastwards' : @ dist * object -> Point @+-- | Anchors in the center of a side. -- --- Variant of the function 'northwards', but projecting the line --- eastwards from the center of the object.----eastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t-             , u ~ DUnit t ) -          => u -> t -> Point2 u-eastwards u a = extendPtDist u (center a) (east a)----- | 'westwards' : @ dist * object -> Point @+-- Sides are addressable by index. Following TikZ, side 1 is +-- expected to be the top of the shape. If the shape has an apex +-- instead of a side then side 1 is expected to be the first side +-- left of the apex. -- --- Variant of the function 'northwards', but projecting the line --- westwards from the center of the object.+-- Implementations are also expected to modulo the side number, +-- rather than throw an out-of-bounds error. ---westwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t-             , u ~ DUnit t ) -          => u -> t -> Point2 u-westwards u a = extendPtDist u (center a) (west a)+class SideMidpointAnchor t where+  sideMidpoint :: DUnit t ~ u => Int -> t -> Point2 u  --- | 'northeastwards' : @ dist * object -> Point @--- --- Variant of the function 'northwards', but projecting the line --- northeastwards from the center of the object.----northeastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t-                  , u ~ DUnit t ) -               => u -> t -> Point2 u-northeastwards u a = extendPtDist u (center a) (northeast a) +-------------------------------------------------------------------------------- --- | 'southeastwards' : @ dist * object -> Point @+-- | 'projectAnchor' : @ extract_func * dist * object -> Point @ -- --- Variant of the function 'northwards', but projecting the line --- southeastwards from the center of the object.----southeastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t-                  , u ~ DUnit t ) -               => u -> t -> Point2 u-southeastwards u a = extendPtDist u (center a) (southeast a)----- | 'southwestwards' : @ dist * object -> Point @+-- Derive a anchor by projecting a line from the center of an +-- object through the intermediate anchor (produced by the +-- extraction function). The final answer point is located along+-- the projected line at the supplied distance @dist@. -- --- Variant of the function 'northwards', but projecting the line --- southwestwards from the center of the object.+-- E.g. take the north of a rectangle and project it 10 units +-- further on:+--  +-- > projectAnchor north 10 my_rect ---southwestwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t-                  , u ~ DUnit t ) -               => u -> t -> Point2 u-southwestwards u a = extendPtDist u (center a) (southwest a)----- | 'northwestwards' : @ dist * object -> Point @--- --- Variant of the function 'northwards', but projecting the line --- northwestwards from the center of the object.+-- If the distance is zero the answer with be whatever point the +-- the extraction function produces. ---northwestwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t-                  , u ~ DUnit t ) -               => u -> t -> Point2 u-northwestwards u a = extendPtDist u (center a) (northwest a)+-- If the distance is negative the answer will be along the +-- projection line, between the center and the intermediate anchor.+--+-- If the distance is positive the anchor will be extend outwards +-- from the intermediate anchor.+--+projectAnchor :: (Real u, Floating u, u ~ DUnit t, CenterAnchor t) +              => (t -> Point2 u) -> u -> t -> Point2 u+projectAnchor f d a = p1 .+^ (avec ang d)+  where+    p1  = f a+    v   = pvec (center a) p1+    ang = vdirection v+        --------------------------------------------------------------------------------

@@ -35,23 +35,15 @@   , HAlign(..)   , VAlign(..)   +  -- * Cardinal (compass) positions+  , Cardinal(..)+   -- * Advance vector   , AdvanceVec   , advanceH   , advanceV -  -- * Moving points-  , PointDisplace-  , displace-  , displaceVec-  , displaceH-  , displaceV -  , ThetaPointDisplace-  , displaceParallel-  , displacePerpendicular--   -- * Monadic drawing   , MonUnit @@ -61,7 +53,7 @@  import Wumpus.Core                              -- package: wumpus-core -import Data.AffineSpace                         -- package: vector-space+import Data.VectorSpace                         -- package: vector-space  infixr 6 `oplus` @@ -95,15 +87,26 @@   a `oplus` b = primGroup [a,b]  instance (OPlus a, OPlus b) => OPlus (a,b) where-  (a,b) `oplus` (a',b') = (a `oplus` a', b `oplus` b')+  (a,b) `oplus` (m,n) = (a `oplus` m, b `oplus` n) +instance (OPlus a, OPlus b, OPlus c) => OPlus (a,b,c) where+  (a,b,c) `oplus` (m,n,o) = (a `oplus` m, b `oplus` n, c `oplus` o) +instance (OPlus a, OPlus b, OPlus c, OPlus d) => OPlus (a,b,c,d) where+  (a,b,c,d) `oplus` (m,n,o,p) = (oplus a m, oplus b n, oplus c o, oplus d p)+++ instance OPlus a => OPlus (r -> a) where   f `oplus` g = \x -> f x `oplus` g x  -- The functional instance (r -> a) also covers (r1 -> r2 -> a), -- (r1 -> r2 -> r3 -> a) etc. +instance Num u => OPlus (Vec2 u) where +  oplus = (^+^)++ --------------------------------------------------------------------------------  -- | A Bifunctor class.@@ -154,7 +157,16 @@ data VAlign = VLeft | VCenter | VRight   deriving (Enum,Eq,Ord,Show) +-------------------------------------------------------------------------------- +-- Compass positions++-- | An enumeratied type representing the compass positions.+--+data Cardinal = NORTH | NORTH_EAST | EAST | SOUTH_EAST +              | SOUTH | SOUTH_WEST | WEST | NORTH_WEST+   deriving (Enum,Eq,Ord,Show) + --------------------------------------------------------------------------------  -- | Advance vectors provide an idiom for drawing consecutive@@ -181,85 +193,6 @@ -- advanceV :: AdvanceVec u -> u advanceV (V2 _ h)  = h------------------------------------------------------------------------------------- Displacing points---- | 'PointDisplace' is a type representing functions --- @from Point to Point@.------ 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 PointDisplace u = Point2 u -> Point2 u---- | '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)----- | 'ThetaPointDisplace' is a type representing functions --- @from Radian * Point to Point@.------ It is useful for building arrowheads which are constructed --- with an implicit angle representing the direction of the line --- at the arrow tip.----type ThetaPointDisplace u = Radian -> PointDisplace u------ | 'displaceParallel' : @ 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----- | 'displaceParallel' : @ dist -> ThetaPointDisplace @--- --- Build a combinator to move @Points@ perpendicular to the --- direction of the implicit angle by the supplied distance --- @dist@. ----displacePerpendicular :: Floating u => u -> ThetaPointDisplace u-displacePerpendicular d = -    \theta pt -> pt .+^ avec (circularModulo $ theta + (0.5*pi)) d-   

@@ -66,9 +66,10 @@       { get_bounding_box  :: forall u. FromPtSize u => PtSize -> BoundingBox u        , get_cw_table      :: forall u. FromPtSize u => PtSize -> CharWidthTable u       , get_cap_height    :: forall u. FromPtSize u => PtSize -> u+      , get_descender     :: forall u. FromPtSize u => PtSize -> u       } --- | 'MetricsOps' tfor a particular named font.+-- | 'MetricsOps' for a particular named font. --  data FontMetricsOps = FontMetricsOps FontName MetricsOps @@ -101,17 +102,19 @@     { get_bounding_box  = \sz -> BBox (lowerLeft sz) (upperRight sz)     , get_cw_table      = \sz _ -> hvec (upscale sz width_vec)      , get_cap_height    = \sz -> upscale sz cap_height+    , get_descender     = \sz -> upscale sz descender     }   where-    llx           = (-23)  / 1000-    lly           = (-250) / 1000-    urx           = 715    / 1000-    ury           = 805    / 1000-    width_vec     = 600    / 1000-    cap_height    = 562    / 1000+    llx             = (-23)  / 1000+    lly             = (-250) / 1000+    urx             = 715    / 1000+    ury             = 805    / 1000+    width_vec       = 600    / 1000+    cap_height      = 562    / 1000+    descender       = (-157) / 1000 -    upscale sz d  = fromPtSize $ sz * d-    lowerLeft sz  = P2 (upscale sz llx) (upscale sz lly) -    upperRight sz = P2 (upscale sz urx) (upscale sz ury) +    upscale sz d    = fromPtSize $ sz * d+    lowerLeft sz    = P2 (upscale sz llx) (upscale sz lly) +    upperRight sz   = P2 (upscale sz urx) (upscale sz ury)   

@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.Kernel.Base.QueryDC--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2010-2011 -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>@@ -12,6 +12,10 @@ -- -- Querying the Drawing Context. --+-- \*\* WARNING \*\* - parts of this module especially the +-- mono-space glyph metrics need a re-think and will change or be +-- dropped.+-- --------------------------------------------------------------------------------  module Wumpus.Basic.Kernel.Base.QueryDC@@ -43,10 +47,9 @@    -- * Glyph metrics   , glyphBoundingBox-  , glyphHeightRange-  , glyphHeight   , glyphCapHeight-+  , glyphDescender+  , glyphVerticalSpan   , cwLookupTable    -- * Default monospace metrics@@ -108,8 +111,7 @@   --- | Vertical distance between baselines of consecutive text --- lines.+-- | Size of the round corner factor. -- getRoundCornerSize :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u getRoundCornerSize = (\factor -> (realToFrac factor) * fromPtSize 1)@@ -117,9 +119,11 @@   --- | Vertical distance between baselines of consecutive text --- lines.+-- | Get the (x,y) margin around text. --+-- Note - not all text operations in Wumpus are drawn with text +-- margin. +--  getTextMargin :: (DrawingCtxM m, Fractional u, FromPtSize u) => m (u,u) getTextMargin = (\(TextMargin xsep ysep) -> (fn xsep, fn ysep))                     <$> asksDC text_margin@@ -174,23 +178,32 @@ glyphQuery :: DrawingCtxM m => (MetricsOps -> PtSize -> u) -> m u glyphQuery fn = (\ctx -> withFontMetrics fn ctx) <$> askDC +-- | Get the font bounding box - this is the maximum boundary of +-- the glyphs in the font. The span of the height is expected to +-- be bigger than the cap_height plus descender depth.+-- glyphBoundingBox :: (FromPtSize u, DrawingCtxM m) => m (BoundingBox u) glyphBoundingBox = glyphQuery get_bounding_box  -glyphHeightRange :: (FromPtSize u, DrawingCtxM m) => m (u,u)-glyphHeightRange = fn <$> glyphBoundingBox-  where-    fn (BBox (P2 _ ymin) (P2 _ ymax)) = (ymin,ymax)  -glyphHeight :: (FromPtSize u, DrawingCtxM m) => m u-glyphHeight = (\(ymax,ymin) -> ymax - ymin) <$> glyphHeightRange - glyphCapHeight :: (FromPtSize u, DrawingCtxM m) => m u glyphCapHeight = glyphQuery get_cap_height +-- | Note - descender is expected to be negative.+--+glyphDescender :: (FromPtSize u, DrawingCtxM m) => m u+glyphDescender = glyphQuery get_descender++-- | This is the distance from cap_height to descender.+--+glyphVerticalSpan :: (FromPtSize u, DrawingCtxM m) => m u+glyphVerticalSpan = +    (\ch dd -> ch - dd) <$> glyphCapHeight <*> glyphDescender++ cwLookupTable :: (FromPtSize u, DrawingCtxM m) => m (CharWidthTable u) cwLookupTable = glyphQuery get_cw_table @@ -271,11 +284,14 @@     -- no longer quite works...    +{-# DEPRECATED monoDefaultPadding "Needs a rethink" #-}  -- | The default padding is half of the /char width/. -- monoDefaultPadding :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u monoDefaultPadding = (0.5*) <$> monoCharWidth++  -- | Vector from baseline left to center --

@@ -58,6 +58,7 @@   , fontFace    -- * Font / mark drawing size+  , scalesize   , doublesize   , halfsize @@ -79,6 +80,7 @@  import Control.Applicative +import Data.Ratio  -------------------------------------------------------------------------------- @@ -214,12 +216,16 @@  -------------------------------------------------------------------------------- +scalesize           :: Ratio Int -> DrawingContextF+scalesize r         = let (n,d) = (numerator r, denominator r)+                      in (\s sz -> fontSize (n * sz `div` d) s) +                           <*> (font_size . font_props)+ -- | Set the font size to double the current size, note the font -- size also controls the size of dots, arrowsheads etc. --  doublesize          :: DrawingContextF-doublesize          = (\s sz -> fontSize (sz*2) s) -                        <*> (font_size . font_props)+doublesize          = scalesize 2    -- | Set the font size to half the current size, note the font@@ -229,8 +235,7 @@ -- 15pt type is 7pt. --  halfsize            :: DrawingContextF-halfsize            = (\s sz -> fontSize (sz `div` 2) s) -                        <*> (font_size . font_props)+halfsize            = scalesize (1%2)   --------------------------------------------------------------------------------

@@ -13,7 +13,7 @@ -- Portability :  GHC  -- -- Extended Graphic object - an AdvanceGraphic is a Graphic --- twinned with and AdvanceV vector.+-- twinned with and advance vector. -- -------------------------------------------------------------------------------- @@ -25,33 +25,37 @@   , DAdvGraphic  -  , makeAdvGraphic-  , extractLocGraphic-  , runAdvGraphic+  , intoAdvGraphic+  , emptyAdvGraphic +   -- * Composition-  , advplus+  , advcat+  , advsep   , advconcat+  , advspace+  , advpunctuate+  , advfill    ) 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.BaseObjects import Wumpus.Basic.Kernel.Objects.Graphic  import Wumpus.Core                              -- package: wumpus-core +import Data.AffineSpace                         -- package: vector-space+import Data.VectorSpace -import Control.Applicative + -- | /Advance vector/ graphic - this partially models the  -- PostScript @show@ command which moves the /current point/ by the--- width (advance) vector as each character is drawn.+-- advance (width) vector as each character is drawn. ---type AdvGraphic u      = LocImage u (Point2 u)+type AdvGraphic u      = LocImage u (Vec2 u)  type DAdvGraphic       = AdvGraphic Double @@ -61,27 +65,35 @@   --- | Construction is different to intoZZ functions hence the --- different name.++-- | 'intoAdvGraphic' : @ loc_context_function * graphic -> Image @ ---makeAdvGraphic :: DrawingInfo (PointDisplace u)+-- Build an 'AdvGraphic' from a context function ('CF') that +-- generates the answer displacement vector and a 'LocGraphic' +-- that draws the 'AdvGraphic'.+--+intoAdvGraphic :: LocCF u (Vec2 u)                -> LocGraphic u                 -> AdvGraphic u-makeAdvGraphic dispf gf = -    promoteR1 $ \pt -> dispf >>= \fn -> fmap (replaceL $ fn pt) (gf `at` pt)  +intoAdvGraphic = intoLocImage  +-- | 'emptyAdvGraphic' : @ AdvGraphic @+--+-- Build an empty 'AdvGraphic'.+-- +-- The 'emptyAdvGraphic' is treated as a /null primitive/ by +-- @Wumpus-Core@ and is not drawn, the answer vetor generated is+-- the empty vector @(V2 0 0)@.+-- +emptyAdvGraphic :: Num u => AdvGraphic u+emptyAdvGraphic = replaceAns (V2 0 0) $ emptyLocGraphic   --- This should probably go - the name is not exact enough...--extractLocGraphic :: AdvGraphic u -> LocGraphic u-extractLocGraphic = fmap (replaceL uNil)--runAdvGraphic :: DrawingContext  -> Point2 u -> AdvGraphic u -              -> (Point2 u, PrimGraphic u)-runAdvGraphic ctx pt df = runCF1 ctx pt df+-- runAdvGraphic :: DrawingContext  -> Point2 u -> AdvGraphic u +--               -> (Point2 u, PrimGraphic u)+-- runAdvGraphic ctx pt df = runCF1 ctx pt df   @@ -91,16 +103,64 @@ -- Note there are opportunities for extra composition operators -- like the /picture language/... -infixr 6 `advplus` +-- Naming convention - binary functions are favoured for shorter names. --- | \*\* WARNING \*\* - pending removal.+infixr 6 `advcat`+infixr 5 `advsep`++-- | Concatenate the two AdvGraphics. ---advplus :: AdvGraphic u -> AdvGraphic u -> AdvGraphic u-advplus = chain1+advcat :: Num u => AdvGraphic u -> AdvGraphic u -> AdvGraphic u+advcat af ag = promoteR1 $ \start -> +                 (af `at` start)        >>= \(v1,prim1) -> +                 (ag `at` start .+^ v1) >>= \(v2,prim2) -> +                 return (v1 ^+^ v2, prim1 `oplus` prim2)  +-- | Concatenate the two AdvGraphics spacing them by the supplied +-- vector.+--+advsep :: Num u => Vec2 u -> AdvGraphic u -> AdvGraphic u -> AdvGraphic u+advsep sv af ag = promoteR1 $ \start -> +                 (af `at` start)        >>= \(v1,prim1) -> +                 (ag `at` start .+^ sv ^+^ v1) >>= \(v2,prim2) -> +                 return (v1 ^+^ sv ^+^  v2, prim1 `oplus` prim2)+++-- | Concatenate the list of AdvGraphic with 'advcat'.+-- advconcat :: Num u => [AdvGraphic u] -> AdvGraphic u-advconcat []     = makeAdvGraphic (pure id) emptyLocGraphic-advconcat [x]    = x-advconcat (x:xs) = x `chain1` advconcat xs +advconcat []     = emptyAdvGraphic+advconcat (x:xs) = step x xs+  where+    step a (b:bs) = step (a `advcat` b) bs+    step a []     = a+++-- | Concatenate the list of AdvGraphic with 'advsep'.+--+advspace :: Num u => Vec2 u -> [AdvGraphic u] -> AdvGraphic u+advspace _  []     = emptyAdvGraphic+advspace sv (x:xs) = step x xs+  where+    step a (b:bs) = step (advsep sv a b) bs+    step a []     = a+++-- | Concatenate the list of AdvGraphic with 'advsep'.+--+advpunctuate :: Num u => AdvGraphic u -> [AdvGraphic u] -> AdvGraphic u+advpunctuate _  []     = emptyAdvGraphic+advpunctuate sep (x:xs) = step x xs+  where+    step a (b:bs) = step (a `advcat` sep `advcat` b) bs+    step a []     = a+++-- | Render the supplied AdvGraphic, but swap the result advance+-- for the supplied vector. This function has behaviour analogue +-- to @fill@ in the @wl-pprint@ library.+-- +advfill :: Num u => Vec2 u -> AdvGraphic u -> AdvGraphic u+advfill sv = replaceAns sv

@@ -38,8 +38,6 @@   , DLocImage   , DLocThetaImage -  , hyperlink-   ) where  import Wumpus.Basic.Kernel.Base.ContextFun@@ -180,9 +178,6 @@ --------------------------------------------------------------------------------  -hyperlink :: XLink -> Image u a -> Image u a-hyperlink hypl = -    fmap (\(a,prim) -> (a, metamorphPrim (xlink hypl) prim))   

@@ -30,12 +30,15 @@   , DBoundedLocThetaGraphic    , emptyBoundedLocGraphic+  , emptyBoundedLocThetaGraphic    , centerOrthoBBox   , illustrateBoundedGraphic   , illustrateBoundedLocGraphic   , illustrateBoundedLocThetaGraphic +  , bbrectangle+   ) where  import Wumpus.Basic.Kernel.Base.BaseDefs@@ -43,10 +46,10 @@ import Wumpus.Basic.Kernel.Base.DrawingContext import Wumpus.Basic.Kernel.Base.UpdateDC import Wumpus.Basic.Kernel.Objects.BaseObjects+import Wumpus.Basic.Kernel.Objects.DrawingPrimitives import Wumpus.Basic.Kernel.Objects.Graphic  import Wumpus.Core                              -- package: wumpus-core-import Wumpus.Core.Colour ( blue )  import Control.Applicative @@ -81,7 +84,7 @@   --- | 'openStroke' : @ theta * bbox -> BBox @+-- | 'centerOrthoBBox' : @ theta * bbox -> BBox @ --  -- Rotate a bounding box by @theta@ about its center. Take the  -- new bounding box.@@ -99,11 +102,36 @@     ctr = boundaryCenter bb  +++-- | 'emptyBoundedLocGraphic' : @ BoundedLocGraphic @+--+-- Build an empty 'BoundedLocGraphic'.+-- +-- 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 :: Num u => BoundedLocGraphic u-emptyBoundedLocGraphic = intoLocImage fn  emptyLocGraphic+emptyBoundedLocGraphic = intoLocImage fn emptyLocGraphic   where     fn = promoteR1 $ \pt -> pure (BBox pt pt) ++-- | 'emptyBoundedLocThetaGraphic' : @ BoundedLocThetaGraphic @+--+-- Build an empty 'BoundedLocThetaGraphic'.+-- +-- 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).+--+emptyBoundedLocThetaGraphic :: Num u => BoundedLocThetaGraphic u+emptyBoundedLocThetaGraphic = lift1R2 emptyBoundedLocGraphic+ -------------------------------------------------------------------------------- --  @@ -126,15 +154,15 @@     promoteR2 $ \pt theta-> illustrateBoundedGraphic $ apply2R2 mf pt theta  -+--  bbrectangle :: Fractional u => BoundingBox u -> Graphic u bbrectangle (BBox p1@(P2 llx lly) p2@(P2 urx ury))     | llx == urx && lly == ury = emptyLocGraphic `at` p1     | otherwise                =          localize drawing_props $ rect1 `oplus` cross   where-    drawing_props = strokeColour blue . capRound . dashPattern (Dash 0 [(1,2)])+    drawing_props = capRound . dashPattern (Dash 0 [(1,2)])     rect1         = strokedRectangle (urx-llx) (ury-lly) `at` p1-    cross         = straightLineBetween p1 p2 -                      `oplus` straightLineBetween (P2 llx ury) (P2 urx lly)+    cross         = straightLineGraphic p1 p2 +                      `oplus` straightLineGraphic (P2 llx ury) (P2 urx lly) 

@@ -29,15 +29,19 @@   , ConnectorImage   , DConnectorImage -+  , intoConnectorImage+  , emptyConnectorGraphic    ) where +import Wumpus.Basic.Kernel.Base.BaseDefs import Wumpus.Basic.Kernel.Base.ContextFun import Wumpus.Basic.Kernel.Objects.BaseObjects+import Wumpus.Basic.Kernel.Objects.Graphic  -- import Wumpus.Core                              -- package: wumpus-core +import Control.Applicative  -------------------------------------------------------------------------------- -- Connector Graphic@@ -48,7 +52,9 @@ -- type ConnectorGraphic u         = ConnectorCF u (GraphicAns u) -+-- | Alias of 'ConnectorGraphic' where the unit type is +-- specialized to Double. +-- type DConnectorGraphic          = ConnectorGraphic Double  @@ -61,14 +67,46 @@ -- | ConnectorImage is a connector drawn between two points  -- constructing an Image. ----- Usually the answer type of a ConnectorImage will be a Path so--- the Points ar @midway@, @atstart@ etc. can be taken on it.+-- Usually the answer type of a ConnectorImage will be a Path +-- (defined in Wumpus-Drawing) so the points at @midway@, +-- @atstart@ etc. or the end directions and tangents can be taken +-- on it. -- type ConnectorImage u a = ConnectorCF u (ImageAns u a)  +-- | Alias of 'ConnectorImage' where the unit type is +-- specialized to Double. +-- type DConnectorImage a  = ConnectorImage Double a  ++-- | 'intoConnectorImage' : @ conn_context_function * 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 :: ConnectorCF u a -> ConnectorGraphic u +                   -> ConnectorImage u a+intoConnectorImage = liftA2 (\a (_,b) -> (a,b))+++-- | 'emptyConnectorGraphic' : @ ConnectorGraphic @+--+-- 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 :: Num u => ConnectorGraphic u +emptyConnectorGraphic = promoteR2 $ \start end -> +    let a = emptyLocGraphic `at` start+        b = emptyLocGraphic `at` end+    in a `oplus` b  

@@ -4,7 +4,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.Kernel.Objects.CtxPicture--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2010-2011 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com@@ -15,14 +15,16 @@ --  -- This is the corresponding type to Picture in the Wumpus-Core. -- --- CtxPicture is a function from the DrawingContext to a Picture.--- Internally the result is actually a (Maybe Picture) and not a --- Picture, this is a trick to promote the extraction from --- possibly empty drawings (created by TraceDrawing) to the --- top-level of the type hierarchy where client code can deal --- with empty drawings explicitly (empty Pictures cannot be --- rendered by Wumpus-Core).+-- Note - many of the composition functions are in +-- /destructor form/. As Wumpus cannot make a Picture from an +-- empty list of Pictures, /destructor form/ decomposes the +-- list into the @head@ and @rest@ as arguments in the function +-- signature, rather than take a possibly empty list and have to +-- throw an error. -- +-- TODO - PosImage no longer supports composition operators, so +-- better names are up for grabs...+--  --------------------------------------------------------------------------------  module Wumpus.Basic.Kernel.Objects.CtxPicture@@ -38,36 +40,33 @@   , mapCtxPicture    -- * Composition-  , over -  , under+  , cxpBeneath -  , centric-  , nextToH-  , nextToV+  , cxpUniteCenter+  , cxpRight+  , cxpDown   -  , atPoint -  , centeredAt+  , cxpCenteredAt -  , zconcat -  , hcat -  , vcat+  , cxpRow +  , cxpColumn  -  , hspace-  , vspace-  , hsep-  , vsep+  , cxpRightSep+  , cxpDownSep+  , cxpRowSep+  , cxpColumnSep     -- * Compose with alignment-  , alignH-  , alignV-  , alignHSep-  , alignVSep-  , hcatA-  , vcatA-  , hsepA-  , vsepA+  , cxpAlignH+  , cxpAlignV+  , cxpAlignSepH+  , cxpAlignSepV+  , cxpAlignRow+  , cxpAlignColumn+  , cxpAlignRowSep+  , cxpAlignColumnSep     ) where@@ -87,9 +86,34 @@ import Data.List ( foldl' )  +-- Note - PosGraphic should take priority for the good names. +-- | A /Contextual Picture/.+-- +-- This type corresponds to the 'Picture' type in Wumpus-Core, but+-- it is embedded with a 'DrawingContext' (for font properties, +-- fill colour etc.). So it is a function +-- /from DrawingContext to Picture/.+--+-- Internally the result is actually a (Maybe Picture) and not a +-- Picture, this is a trick to promote the extraction from +-- possibly empty drawings (created by TraceDrawing) to the +-- top-level of the type hierarchy where client code can deal +-- with empty drawings explicitly (empty Pictures cannot be +-- rendered by Wumpus-Core).+--+-- > a `oplus` b+--+-- The 'OPlus' (semigroup) instance for 'CtxPicture' draws picture +-- a in front of picture b in the z-order, neither picture is +-- moved. (Usually the picture composition operators in this +-- module move the second picture aligning it somehow with the +-- first).+-- newtype CtxPicture u = CtxPicture { getCtxPicture :: CF (Maybe (Picture u)) } +-- | Version of CtxPicture specialized to Double for the unit type.+-- type DCtxPicture = CtxPicture Double  @@ -97,22 +121,40 @@   -+-- | 'runCtxPicture' : @ drawing_ctx * ctx_picture -> Maybe Picture @+--+-- Run a 'CtxPicture' with the supplied 'DrawingContext' +-- producing a 'Picture'.+--+-- The resulting Picture may be empty. Wumpus-Core cannot +-- generate empty pictures as they have no bounding box, so the +-- result is wrapped within a Maybe. This delegates reponsibility +-- for handling empty pictures to client code.+-- runCtxPicture :: DrawingContext -> CtxPicture u -> Maybe (Picture u) runCtxPicture ctx drw = runCF ctx (getCtxPicture drw)   -+-- | 'runCtxPictureU' : @ drawing_ctx * ctx_picture -> Picture @+--+-- /Unsafe/ version of 'runCtxPicture'.+--+-- This function throws a runtime error when supplied with an+-- empty CtxPicture.+-- runCtxPictureU :: DrawingContext -> CtxPicture u -> Picture u runCtxPictureU ctx df = maybe fk id $ runCtxPicture ctx df   where     fk = error "runCtxPictureU - empty CtxPicture."     -+-- | 'drawTracing' : @ trace_drawing  -> CtxPicture @+--+-- Transform a 'TraceDrawing' into a 'CtxPicture'.+-- drawTracing :: (Real u, Floating u, FromPtSize u)              => TraceDrawing u a -> CtxPicture u drawTracing mf = CtxPicture $ -    drawingCtx >>= \ctx -> return (liftToPictureMb (execTraceDrawing ctx mf) )+    drawingCtx >>= \ctx -> return (liftToPictureMb $ execTraceDrawing ctx mf)   -- Note - cannot get an answer from a TraceDrawing with this @@ -127,15 +169,34 @@ -- a where this would be useful (rather than just making things  -- more complicated)?  ----------------------------------------------------------------------------------- -clipCtxPicture :: (Num u, Ord u) => (PrimPath u) -> CtxPicture u -> CtxPicture u+-- | 'clipCtxPicture' : @ path * ctx_picture -> CtxPicture @+--+-- Clip a picture with a path.+-- +clipCtxPicture :: (Num u, Ord u) => PrimPath u -> CtxPicture u -> CtxPicture u clipCtxPicture cpath = mapCtxPicture (clip cpath) +-- Note - it seems preferable to clip a smaller type in the +-- hierarchy than CtxPicture. But which one Graphic, TraceDrawing? +-- ...+-- ++-- | 'mapCtxPicture' : @ trafo * ctx_picture -> CtxPicture @+--+-- Apply a picture transformation function to the 'Picture'+-- warpped in a 'CtxPicture'.+-- mapCtxPicture :: (Picture u -> Picture u) -> CtxPicture u -> CtxPicture u mapCtxPicture pf = CtxPicture . fmap (fmap pf) . getCtxPicture ++--------------------------------------------------------------------------------++++ instance (Real u, Floating u) => Rotate (CtxPicture u) where    rotate ang = mapCtxPicture (rotate ang) @@ -226,23 +287,24 @@   -  --- Note - do not export the empty drawing. It is easier to --- pretend it doesn't exist.--- -empty_drawing :: (Real u, Floating u, FromPtSize u) => CtxPicture u-empty_drawing = drawTracing $ return ()  -- -------------------------------------------------------------------------------- -- Composition operators +-- Naming convention - Wumpus-Core already prefixes operations+-- on Pictures with pic. As the picture operators here work on a+-- different type, they merit a different naming scheme.+--+-- Unfortunately the @cxp_@ prefix is rather ugly...+--+-- Directional names seem better than positional ones (less +-- ambiguous as when used as binary operators).+-- -drawingConcat :: (Picture u -> Picture u -> Picture u) -              -> CtxPicture u -> CtxPicture u -> CtxPicture u-drawingConcat op a b = CtxPicture $ mbpostcomb op (getCtxPicture a) (getCtxPicture b)+cxpConcat :: (Picture u -> Picture u -> Picture u) +          -> CtxPicture u -> CtxPicture u -> CtxPicture u+cxpConcat op a b = CtxPicture $ mbpostcomb op (getCtxPicture a) (getCtxPicture b)   @@ -273,49 +335,39 @@           -> (a -> a -> Picture u -> Picture u)            -> CtxPicture u -> CtxPicture u           -> CtxPicture u-megaCombR qL qR trafoR = drawingConcat fn+megaCombR qL qR trafoR = cxpConcat fn   where     fn pic1 pic2 = let a    = qL pic1                        b    = qR pic2                        p2   = trafoR a b pic2                    in pic1 `picOver` p2 ------ | > a `over` b+-- | > a `oplus` b --  -- Place \'drawing\' a over b. The idea of @over@ here is in  -- terms z-ordering, nither picture a or b are actually moved. ---over    :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u-over    = drawingConcat picOver-+instance (Num u, Ord u) => OPlus (CtxPicture u) where+  oplus = cxpConcat picOver  --- | > a `under` b------ Similarly @under@ draws the first drawing behind --- the second but move neither.+-- | 'cxpBeneath' : @ ctx_picture1 * ctx_picture2 -> CtxPicture @+-- +-- > a `cxpBeneath` b ---under :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u-under = flip over------ | Move in both the horizontal and vertical.+-- Similarly @beneath@ draws the first picture behind the second +-- picture in the z-order, neither picture is moved. ---move :: (Num u, Ord u) => Vec2 u -> CtxPicture u -> CtxPicture u-move v = mapCtxPicture (\p -> p `picMoveBy` v)-+cxpBeneath :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u+cxpBeneath = flip oplus    -------------------------------------------------------------------------------- -- Composition -infixr 5 `nextToV`-infixr 6 `nextToH`, `centric`+infixr 5 `cxpDown`+infixr 6 `cxpRight`, `cxpUniteCenter`   @@ -323,51 +375,47 @@ -- | Draw @a@, move @b@ so its center is at the same center as  -- @a@, @b@ is drawn over underneath in the zorder. ----- > a `centeric` b ---+-- > a `cxpUniteCenter` b  ---centric :: (Fractional u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u-centric = megaCombR boundaryCtr boundaryCtr moveFun++cxpUniteCenter :: (Fractional u, Ord u) +               => CtxPicture u -> CtxPicture u -> CtxPicture u+cxpUniteCenter = megaCombR boundaryCtr boundaryCtr moveFun   where     moveFun p1 p2 pic =  let v = p1 .-. p2 in pic `picMoveBy` v -+--+-- Are combinator names less ambiguous if they name direction+-- rather than position?+-- --- | > a `nextToH` b+-- | > a `cxpRight` b -- --- Horizontal composition - move @b@, placing it to the right --- of @a@.+-- Horizontal composition - position picture @b@ to the right of +-- picture @a@. -- -nextToH :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u-nextToH = megaCombR boundaryRightEdge boundaryLeftEdge moveFun+cxpRight :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u+cxpRight = megaCombR boundaryRightEdge boundaryLeftEdge moveFun   where      moveFun a b pic = pic `picMoveBy` hvec (a - b)   --- | > a `nextToV` b+-- | > a `cxpDown` b ----- Vertical composition - move @b@, placing it below @a@.+-- Vertical composition - position picture @b@ /down/ from picture+-- @a@. ---nextToV :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u-nextToV = megaCombR boundaryBottomEdge boundaryTopEdge moveFun+cxpDown :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u+cxpDown = megaCombR boundaryBottomEdge boundaryTopEdge moveFun   where      moveFun a b drw = drw `picMoveBy` vvec (a - b)  --- | Place the picture at the supplied point.------ `atPoint` was previous the `at` operator.--- -atPoint :: (Num u, Ord u) => CtxPicture u -> Point2 u  -> CtxPicture u-p `atPoint` (P2 x y) = move (V2 x y) p--- -- | Center the picture at the supplied point. ---centeredAt :: (Fractional u, Ord u) => CtxPicture u -> Point2 u -> CtxPicture u-centeredAt d (P2 x y) = mapCtxPicture fn d+cxpCenteredAt :: (Fractional u, Ord u) => CtxPicture u -> Point2 u -> CtxPicture u+cxpCenteredAt d (P2 x y) = mapCtxPicture fn d   where     fn p = let bb = boundary p                dx = x - (boundaryWidth  bb * 0.5)@@ -375,29 +423,31 @@            in p `picMoveBy` vec dx dy  --- | Concatenate the list of drawings. ------ No pictures are moved. ----zconcat :: (Real u, Floating u, FromPtSize u) => [CtxPicture u] -> CtxPicture u-zconcat []     = empty_drawing-zconcat (d:ds) = foldl' over d ds ------ | Concatenate the list pictures @xs@ horizontally.+-- | 'cxpRow' : @ ctx_picture1 * [ctx_picture] -> CtxPicture @ -- -hcat :: (Real u, Floating u, FromPtSize u) => [CtxPicture u] -> CtxPicture u-hcat []     = empty_drawing-hcat (d:ds) = foldl' nextToH d ds+-- Make a row of pictures concatenating them horizontally.+-- +-- Note - this function is in /destructor form/. As Wumpus cannot+-- make a Picture from an empty list of Pictures, +-- /destructor form/ decomposes the list into the @head@ and the +-- @rest@ in the function signature, rather than take a possibly+-- empty list and have to throw an error.+-- +cxpRow :: (Real u, Floating u, FromPtSize u) +       => CtxPicture u -> [CtxPicture u] -> CtxPicture u+cxpRow = foldl' cxpRight  --- | Concatenate the list of pictures @xs@ vertically.+-- | 'cxpColumn' : @ ctx_picture1 * [ctx_picture] -> CtxPicture @+-- +-- Make a column of pictures concatenating them vertically.+-- +-- Note - this function is in /destructor form/. ---vcat :: (Real u, Floating u, FromPtSize u) => [CtxPicture u] -> CtxPicture u-vcat []     = empty_drawing-vcat (d:ds) = foldl' nextToV d ds+cxpColumn :: (Real u, Floating u, FromPtSize u) +          => CtxPicture u -> [CtxPicture u] -> CtxPicture u+cxpColumn = foldl' cxpDown   @@ -407,13 +457,13 @@   --- | > hspace n a b+-- | > cxpRightSep n a b -- -- Horizontal composition - move @b@, placing it to the right  -- of @a@ with a horizontal gap of @n@ separating the pictures. ---hspace :: (Num u, Ord u) => u -> CtxPicture u -> CtxPicture u -> CtxPicture u-hspace n = megaCombR boundaryRightEdge boundaryLeftEdge moveFun+cxpRightSep :: (Num u, Ord u) => u -> CtxPicture u -> CtxPicture u -> CtxPicture u+cxpRightSep n = megaCombR boundaryRightEdge boundaryLeftEdge moveFun   where     moveFun a b pic = pic `picMoveBy` hvec (n + a - b) @@ -421,39 +471,40 @@   --- | > vspace n a b+-- | > cxpDownSep n a b -- -- Vertical composition - move @b@, placing it below @a@ with a -- vertical gap of @n@ separating the pictures. ---vspace :: (Num u, Ord u) => u -> CtxPicture u -> CtxPicture u -> CtxPicture u-vspace n = megaCombR boundaryBottomEdge boundaryTopEdge moveFun+cxpDownSep :: (Num u, Ord u) +           => u -> CtxPicture u -> CtxPicture u -> CtxPicture u+cxpDownSep n = megaCombR boundaryBottomEdge boundaryTopEdge moveFun   where      moveFun a b pic = pic `picMoveBy`  vvec (a - b - n)   --- | > hsep n xs+-- | > picRowSep n x xs -- -- Concatenate the list of pictures @xs@ horizontally with  -- @hspace@ starting at @x@. The pictures are interspersed with  -- spaces of @n@ units. ---hsep :: (Real u, Floating u, FromPtSize u) => u -> [CtxPicture u] -> CtxPicture u-hsep _ []     = empty_drawing-hsep n (d:ds) = foldl' (hspace n) d ds+cxpRowSep :: (Real u, Floating u, FromPtSize u) +          => u -> CtxPicture u -> [CtxPicture u] -> CtxPicture u+cxpRowSep n = foldl' (cxpRightSep n)   --- | > vsep n xs+-- | > vsepPic n xs -- -- Concatenate the list of pictures @xs@ vertically with  -- @vspace@ starting at @x@. The pictures are interspersed with  -- spaces of @n@ units. ---vsep :: (Real u, Floating u, FromPtSize u) => u -> [CtxPicture u] -> CtxPicture u-vsep _ []     = empty_drawing-vsep n (d:ds) = foldl' (vspace n) d ds+cxpColumnSep :: (Real u, Floating u, FromPtSize u) +             => u -> CtxPicture u -> [CtxPicture u] -> CtxPicture u+cxpColumnSep n = foldl' (cxpDownSep n)   --------------------------------------------------------------------------------@@ -463,29 +514,32 @@ alignMove p1 p2 pic = pic `picMoveBy` (p1 .-. p2)  +-- Note - these don\'t conform to the naming convention, but using +-- /Right/ in the names would be confusing with alignment. --- | > alignH align a b++-- | > cxpAlignH align a b --  -- Horizontal composition - move @b@, placing it to the right  -- of @a@ and align it with the top, center or bottom of @a@. -- -alignH :: (Fractional u, Ord u) -       =>  HAlign -> CtxPicture u -> CtxPicture u -> CtxPicture u-alignH HTop     = megaCombR boundaryNE    boundaryNW     alignMove-alignH HCenter  = megaCombR boundaryE    boundaryW     alignMove-alignH HBottom  = megaCombR boundarySE boundarySW  alignMove+cxpAlignH :: (Fractional u, Ord u) +          =>  HAlign -> CtxPicture u -> CtxPicture u -> CtxPicture u+cxpAlignH HTop     = megaCombR boundaryNE boundaryNW  alignMove+cxpAlignH HCenter  = megaCombR boundaryE  boundaryW   alignMove+cxpAlignH HBottom  = megaCombR boundarySE boundarySW  alignMove  --- | > alignV align a b+-- | > cxpAlignV align a b --  -- Vertical composition - move @b@, placing it below @a@  -- and align it with the left, center or right of @a@. -- -alignV :: (Fractional u, Ord u) +cxpAlignV :: (Fractional u, Ord u)         => VAlign -> CtxPicture u -> CtxPicture u -> CtxPicture u-alignV VLeft    = megaCombR boundarySW  boundaryNW   alignMove-alignV VCenter  = megaCombR boundaryS   boundaryN    alignMove-alignV VRight   = megaCombR boundarySE boundaryNE  alignMove+cxpAlignV VLeft    = megaCombR boundarySW boundaryNW alignMove+cxpAlignV VCenter  = megaCombR boundaryS  boundaryN  alignMove+cxpAlignV VRight   = megaCombR boundarySE boundaryNE  alignMove   @@ -495,69 +549,67 @@   --- | > alignHSep align sep a b+-- | > cxpAlignSepH align sep a b -- --- Spacing version of alignH - move @b@ to the right of @a@ +-- Spacing version of 'cxpAlignH' - move @b@ to the right of @a@  -- separated by @sep@ units, align @b@ according to @align@. -- -alignHSep :: (Fractional u, Ord u) -          => HAlign -> u -> CtxPicture u -> CtxPicture u -> CtxPicture u-alignHSep HTop    dx = megaCombR boundaryNE boundaryNW (alignMove2 (hvec dx))-alignHSep HCenter dx = megaCombR boundaryE  boundaryW  (alignMove2 (hvec dx))-alignHSep HBottom dx = megaCombR boundarySE boundarySW (alignMove2 (hvec dx))+cxpAlignSepH :: (Fractional u, Ord u) +               => HAlign -> u -> CtxPicture u -> CtxPicture u -> CtxPicture u+cxpAlignSepH align dx = go align+  where+    go HTop    = megaCombR boundaryNE boundaryNW (alignMove2 (hvec dx))+    go HCenter = megaCombR boundaryE  boundaryW  (alignMove2 (hvec dx))+    go HBottom = megaCombR boundarySE boundarySW (alignMove2 (hvec dx))  --- | > alignVSep align sep a b+-- | > cxpAlignSepV align sep a b --  -- Spacing version of alignV - move @b@ below @a@  -- separated by @sep@ units, align @b@ according to @align@. -- -alignVSep :: (Fractional u, Ord u) -          => VAlign -> u -> CtxPicture u -> CtxPicture u -> CtxPicture u-alignVSep VLeft   dy = megaCombR boundarySW boundaryNW (alignMove2 $ vvec (-dy)) -alignVSep VCenter dy = megaCombR boundaryS  boundaryN  (alignMove2 $ vvec (-dy)) -alignVSep VRight  dy = megaCombR boundarySE boundaryNE (alignMove2 $ vvec (-dy))+cxpAlignSepV :: (Fractional u, Ord u) +               => VAlign -> u -> CtxPicture u -> CtxPicture u -> CtxPicture u+cxpAlignSepV align dy = go align+  where+    go VLeft   = megaCombR boundarySW boundaryNW (alignMove2 $ vvec (-dy)) +    go VCenter = megaCombR boundaryS  boundaryN  (alignMove2 $ vvec (-dy)) +    go VRight  = megaCombR boundarySE boundaryNE (alignMove2 $ vvec (-dy))  --- | Variant of 'hcat' that aligns the pictures as well as+-- | Variant of 'cxpRow' that aligns the pictures as well as -- concatenating them. ---hcatA :: (Real u, Floating u, FromPtSize u) -      => HAlign -> [CtxPicture u] -> CtxPicture u-hcatA _  []     = empty_drawing-hcatA ha (d:ds) = foldl' (alignH ha) d ds+cxpAlignRow :: (Real u, Floating u, FromPtSize u) +            => HAlign -> CtxPicture u-> [CtxPicture u] -> CtxPicture u+cxpAlignRow ha = foldl' (cxpAlignH ha)   --- | Variant of 'vcat' that aligns the pictures as well as+-- | Variant of 'cxpColumn' that aligns the pictures as well as -- concatenating them. ---vcatA :: (Real u, Floating u, FromPtSize u) -      => VAlign -> [CtxPicture u] -> CtxPicture u-vcatA _  []     = empty_drawing-vcatA va (d:ds) = foldl' (alignV va) d ds+cxpAlignColumn :: (Real u, Floating u, FromPtSize u) +               => VAlign -> CtxPicture u -> [CtxPicture u] -> CtxPicture u+cxpAlignColumn va = foldl' (cxpAlignV va)  --- | Variant of @hsep@ that aligns the pictures as well as+-- | Variant of 'cxpRow' that aligns the pictures as well as -- concatenating and spacing them. ---hsepA :: (Real u, Floating u, FromPtSize u) -      => HAlign -> u -> [CtxPicture u] -> CtxPicture u-hsepA _  _ []     = empty_drawing-hsepA ha n (d:ds) = foldl' op d ds-  where -    a `op` b = alignHSep ha n a b +cxpAlignRowSep :: (Real u, Floating u, FromPtSize u) +                 => HAlign -> u -> CtxPicture u -> [CtxPicture u] +                 -> CtxPicture u+cxpAlignRowSep ha n = foldl' (cxpAlignSepH ha n)  --- | Variant of @vsep@ that aligns the pictures as well as+-- | Variant of 'cxpColumn' that aligns the pictures as well as -- concatenating and spacing them. ---vsepA :: (Real u, Floating u, FromPtSize u) -      => VAlign -> u -> [CtxPicture u] -> CtxPicture u-vsepA _  _ []     = empty_drawing-vsepA va n (d:ds) = foldl' op d ds-  where -    a `op` b = alignVSep va n a b +cxpAlignColumnSep :: (Real u, Floating u, FromPtSize u) +                    => VAlign -> u -> CtxPicture u -> [CtxPicture u] +                    -> CtxPicture u+cxpAlignColumnSep va n = foldl' (cxpAlignSepV va n)    

@@ -0,0 +1,277 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Objects.Displacement+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Displacing points - often start points. +--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Objects.Displacement+  (+++  -- * Moving points and angles+    PointDisplace+  , ThetaDisplace+  , ThetaPointDisplace+++  , moveStart+  , moveStartTheta+  , moveStartThetaPoint+  , moveStartThetaAngle++  , displace+  , displaceVec+  , displaceH+  , displaceV++  , northwards+  , southwards +  , eastwards+  , westwards  ++  , northeastwards+  , northwestwards+  , southeastwards+  , southwestwards+++  , displaceParallel+  , displacePerpendicular+  , displaceOrtho++  , thetaNorthwards+  , thetaSouthwards +  , thetaEastwards+  , thetaWestwards  ++  , thetaNortheastwards+  , thetaNorthwestwards+  , thetaSoutheastwards+  , thetaSouthwestwards++  ) where+++import Wumpus.Basic.Kernel.Base.ContextFun++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space++++--------------------------------------------------------------------------------+-- Displacing points++-- | 'PointDisplace' is a type representing functions +-- @from Point to Point@.+--+-- 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 PointDisplace u = Point2 u -> Point2 u+++-- | '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@.+--+-- It is useful for building arrowheads which are constructed +-- with an implicit angle representing the direction of the line +-- at the arrow tip.+--+type ThetaPointDisplace u = Radian -> PointDisplace u++++-- | Move the start-point of a 'LocCF' with the supplied +-- displacement function.+--+moveStart :: PointDisplace u -> LocCF u a -> LocCF u a+moveStart f ma = promoteR1 $ \pt -> apply1R1 ma (f pt)++++-- | Move the start-point of a 'LocThetaCF' with the supplied +-- displacement function.+--+moveStartTheta :: ThetaPointDisplace u -> LocThetaCF u a -> LocThetaCF u a+moveStartTheta f ma = promoteR2 $ \pt theta -> let p2 = f theta pt +                                               in apply2R2 ma p2 theta+++-- | Move the start-point of a 'LocThetaCF' with the supplied +-- displacement function.+--+moveStartThetaPoint :: PointDisplace u -> LocThetaCF u a -> LocThetaCF u a+moveStartThetaPoint f ma = promoteR2 $ \pt theta -> apply2R2 ma (f pt) theta+++-- | Change the inclination of a 'LocThetaCF' with the supplied +-- displacement function.+--+moveStartThetaAngle :: ThetaDisplace -> LocThetaCF u a -> LocThetaCF u a+moveStartThetaAngle f ma = promoteR2 $ \pt theta -> apply2R2 ma pt (f theta)++++--------------------------------------------------------------------------------+-- 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)+++-- Cardinal displacement ++++northwards :: Num u => u -> PointDisplace u+northwards = displaceV+++southwards :: Num u => u -> PointDisplace u+southwards =  displaceV . negate++eastwards :: Num u => u -> PointDisplace u+eastwards = displaceH++westwards :: Num u => u -> PointDisplace u+westwards = displaceH . negate++northeastwards :: Floating u => u -> PointDisplace u+northeastwards = displaceVec . avec (0.25 * pi)++northwestwards ::  Floating u => u -> PointDisplace u+northwestwards = displaceVec . avec (0.75 * pi)++southeastwards ::  Floating u => u -> PointDisplace u+southeastwards = displaceVec . avec (1.75 * pi)++southwestwards ::  Floating u => u -> PointDisplace u+southwestwards = displaceVec . avec (1.25 * pi)+++--------------------------------------------------------------------------------+-- ThetaPointDisplace functions+++-- | 'displaceParallel' : @ 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+++-- | 'displaceParallel' : @ 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 = +    \theta pt -> pt .+^ avec (circularModulo $ theta + (0.5*pi)) d++++-- | 'displaceOrtho' : @ 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+++thetaNorthwards :: Floating u => u -> ThetaPointDisplace u+thetaNorthwards = displacePerpendicular+++thetaSouthwards :: Floating u => u -> ThetaPointDisplace u+thetaSouthwards = displacePerpendicular . negate+++thetaEastwards :: Floating u => u -> ThetaPointDisplace u+thetaEastwards = displaceParallel+++thetaWestwards :: Floating u => u -> ThetaPointDisplace u+thetaWestwards = displaceParallel . negate++thetaNortheastwards :: Floating u => u -> ThetaPointDisplace u+thetaNortheastwards d = +    \theta pt -> pt .+^ avec (circularModulo $ theta + (0.25*pi)) d+++thetaNorthwestwards :: Floating u => u -> ThetaPointDisplace u+thetaNorthwestwards d = +    \theta pt -> pt .+^ avec (circularModulo $ theta + (0.75*pi)) d+++thetaSoutheastwards :: Floating u => u -> ThetaPointDisplace u+thetaSoutheastwards d = +    \theta pt -> pt .+^ avec (circularModulo $ theta + (1.75*pi)) d+++thetaSouthwestwards :: Floating u => u -> ThetaPointDisplace u+thetaSouthwestwards d = +    \theta pt -> pt .+^ avec (circularModulo $ theta + (1.25*pi)) d+

@@ -0,0 +1,651 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeSynonymInstances       #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Objects.DrawingPrimitives+-- Copyright   :  (c) Stephen Tetley 2010-2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Graphic type - this is largely equivalent to Primitive in+-- Wumpus-Core, but drawing attributes are implicitly supplied +-- by the DrawingContext.+--+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Objects.DrawingPrimitives+  (++  -- * Paths+    locPath+  , emptyLocPath++  , openStroke+  , closedStroke+  , filledPath+  , borderedPath++  -- * Text+  , textline+  , rtextline+  , escapedline+  , rescapedline++  , hkernline+  , vkernline++  -- * Lines+  , straightLine+  , straightLineGraphic+  , curveGraphic++  -- * Circles+  , strokedCircle+  , filledCircle+  , borderedCircle++  -- * Ellipses+  , strokedEllipse+  , rstrokedEllipse+  , filledEllipse+  , rfilledEllipse++  , borderedEllipse+  , rborderedEllipse++  -- * Rectangles+  , strokedRectangle+  , filledRectangle+  , borderedRectangle++  -- * Disks  +  , strokedDisk+  , filledDisk+  , borderedDisk++  , strokedEllipseDisk+  , filledEllipseDisk+  , borderedEllipseDisk++  ) where++import Wumpus.Basic.Kernel.Base.ContextFun+import Wumpus.Basic.Kernel.Base.QueryDC+import Wumpus.Basic.Kernel.Base.WrappedPrimitive+import Wumpus.Basic.Kernel.Objects.Graphic++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space++import Control.Applicative++++-- Helper+--+graphicAns :: Primitive u -> (UNil u, PrimGraphic u)+graphicAns p = (uNil, primGraphic p)+++--------------------------------------------------------------------------------+-- Paths++-- | 'locPath' : @ [next_vector] -> (Point2 ~> PrimPath) @+--+-- Create a path 'LocCF' - 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'.+--+locPath :: Num u => [Vec2 u] -> LocCF u (PrimPath u)+locPath vs = promoteR1 $ \pt  -> pure $ vectorPath pt vs+++-- | 'emptyLocPath' : @ (Point ~> PrimPath) @+--+-- Create an empty path 'LocCF' - i.e. a functional type +-- /from Point to PrimPath/.+--+-- This is the analogue to 'emptyPath' in @Wumpus-Core@, but the+-- result is produced /within/ the 'DrawingContext'.+--+emptyLocPath :: Num u => LocCF u (PrimPath u)+emptyLocPath = locPath []+++++--+-- Drawing paths (stroke, fill, bordered)...+--++-- | '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 :: Num u => PrimPath u -> Graphic u+openStroke pp = +    withStrokeAttr $ \rgb attr -> graphicAns $ ostroke rgb attr pp+++-- | 'closedStroke' : @ 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'.+--+closedStroke :: Num u => PrimPath u -> Graphic u+closedStroke pp = +    withStrokeAttr $ \rgb attr -> graphicAns $ cstroke 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 :: Num u => PrimPath u -> Graphic u+filledPath pp = withFillAttr $ \rgb -> graphicAns $ 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'.+--+--+borderedPath :: Num u => PrimPath u -> Graphic u+borderedPath pp =+    withBorderedAttr $ \frgb attr srgb -> +      graphicAns $ fillStroke frgb attr srgb pp++++--------------------------------------------------------------------------------+-- Text++-- | 'textline' : @ string -> LocGraphic @+-- +-- Create a text 'LocGraphic' - i.e. a functional type +-- /from Point to Graphic/.+--+-- The implicit point of the LocGraphic is the baseline left.+--+-- This is the analogue to 'textlabel' in @Wumpus-core@, but the+-- text properties (font family, font size, colour) are taken from+-- the implicit 'DrawingContext'.+--+textline :: Num u => String -> LocGraphic u+textline ss = +    promoteR1 $ \pt -> +      withTextAttr $ \rgb attr -> graphicAns (textlabel rgb attr ss pt)+++++-- | 'rtextline' : @ string -> LocThetaGraphic @+-- +-- Create a text 'LocThetaGraphic' - i.e. a functional type +-- /from Point and Angle to Graphic/.+--+-- The implicit point of the LocGraphic is the baseline left, the+-- implicit angle is rotation factor of the text.+--+-- Note - rotated text often does not render well in PostScript or+-- SVG. Rotated text should be used sparingly.+-- +-- This is the analogue to 'rtextlabel' in @Wumpus-core@.+--+rtextline :: Num u => String -> LocThetaGraphic u+rtextline ss = +    promoteR2 $ \pt theta -> +      withTextAttr $ \rgb attr -> graphicAns (rtextlabel rgb attr ss theta pt)++++-- | 'escapedline' : @ escaped_text -> LocGraphic @+-- +-- Create a text 'LocGraphic' - i.e. a functional type +-- /from Point to Graphic/.+--+-- The implicit point of the LocGraphic is the baseline left.+--+-- This is the analogue to 'escapedlabel' in @Wumpus-core@, but +-- the text properties (font family, font size, colour) are taken +-- from the implicit 'DrawingContext'.+--+escapedline :: Num u => EscapedText -> LocGraphic u+escapedline ss = +    promoteR1 $ \pt -> +      withTextAttr $ \rgb attr -> graphicAns (escapedlabel rgb attr ss pt)++++-- | 'rescapedline' : @ escaped_text -> LocThetaGraphic @+-- +-- Create a text 'LocThetaGraphic' - i.e. a functional type +-- /from Point and Angle to Graphic/.+--+-- The implicit point of the LocGraphic is the baseline left, the+-- implicit angle is rotation factor of the text.+--+-- Note - rotated text often does not render well in PostScript or+-- SVG. Rotated text should be used sparingly.+-- +-- This is the analogue to 'rescapedlabel' in @Wumpus-core@, but+-- the text properties (font family, font size, colour) are taken +-- from the implicit 'DrawingContext'.+--+rescapedline :: Num u => EscapedText -> LocThetaGraphic u+rescapedline ss = +    promoteR2 $ \pt theta -> +      withTextAttr $ \rgb attr -> graphicAns (rescapedlabel rgb attr ss theta pt)+++++-- | 'hkernline' : @ [kern_char] -> LocGraphic @+-- +-- Create a horizontally kerned text 'LocGraphic' - i.e. a +-- functional type /from Point to Graphic/.+--+-- The implicit point of the LocGraphic is the baseline left.+--+-- This is the analogue to 'hkernlabel' in @Wumpus-core@, but +-- the text properties (font family, font size, colour) are taken +-- from the implicit 'DrawingContext'.+--+hkernline :: Num u => [KerningChar u] -> LocGraphic u+hkernline xs = +    promoteR1 $ \pt -> +      withTextAttr $ \rgb attr -> graphicAns (hkernlabel rgb attr xs pt)+++-- | 'vkernline' : @ [kern_char] -> LocGraphic @+-- +-- Create a vertically kerned text 'LocGraphic' - i.e. a +-- functional type /from Point to Graphic/.+--+-- The implicit point of the LocGraphic is the baseline left.+--+-- This is the analogue to 'vkernlabel' in @Wumpus-core@, but +-- the text properties (font family, font size, colour) are taken +-- from the implicit 'DrawingContext'.+--+vkernline :: Num u => [KerningChar u] -> LocGraphic u+vkernline xs = +    promoteR1 $ \pt -> +      withTextAttr $ \rgb attr -> graphicAns (vkernlabel rgb attr xs pt)+++++--------------------------------------------------------------------------------+-- Lines++-- | 'straightLine' : @ vec_to -> LocGraphic @ +--+-- Create a stright line 'LocGraphic' - i.e. a functional type +-- /from Point to Graphic/.+--+-- The implicit point of the LocGraphic is the start point, the +-- end point is calculated by displacing the start point with the +-- supplied vector.+--+-- The line properties (colour, pen thickness, etc.) are taken +-- from the implicit 'DrawingContext'.+-- +straightLine :: Fractional u => Vec2 u -> LocGraphic u+straightLine v = mf >>= (lift0R1 . openStroke)+  where+    mf = promoteR1 $ \pt -> pure $ primPath pt [lineTo $ pt .+^ v]++          +-- | 'straightLineGraphic' : @ start_point * end_point -> LocGraphic @ +-- +-- Create a straight line 'Graphic', the start and end point +-- are supplied explicitly.+-- +-- The line properties (colour, pen thickness, etc.) are taken +-- from the implicit 'DrawingContext'.+-- +straightLineGraphic :: Fractional u => Point2 u -> Point2 u -> Graphic u+straightLineGraphic p1 p2 = openStroke $ primPath p1 [lineTo p2]++++-- | 'curveGraphic' : @ start_point * control_point1 * +--        control_point2 * end_point -> Graphic @ +-- +-- Create a Bezier curve 'Graphic', all control points are +-- supplied explicitly.+-- +-- The line properties (colour, pen thickness, etc.) are taken +-- from the implicit 'DrawingContext'.+-- +curveGraphic :: Fractional u +             => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Graphic u+curveGraphic sp cp1 cp2 ep = openStroke $ primPath sp [curveTo cp1 cp2 ep]+++--------------------------------------------------------------------------------+-- Circles++-- | '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 :: Floating u => u -> LocGraphic u+strokedCircle r = promoteR1 (closedStroke . curvedPath . bezierCircle r)++++-- | 'filledCircle' : @ radius -> LocGraphic @+--+-- Create a filled circle 'LocGraphic' - the implicit point is +-- center. The circle is drawn with four Bezier curves. +-- +-- The fill colour is taken from the implicit 'DrawingContext'.+-- +filledCircle :: Floating u => u -> LocGraphic u+filledCircle r =  promoteR1 (filledPath . curvedPath . bezierCircle r)++++-- | '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 :: Floating u => u -> LocGraphic u+borderedCircle r = promoteR1 (borderedPath . curvedPath . bezierCircle r)+++--------------------------------------------------------------------------------+-- Ellipses++++-- | 'strokedEllipse' : @ x_radius * y_radius -> LocGraphic @+--+-- Create a stroked ellipse 'LocGraphic' - the implicit point is +-- center. The ellipse is drawn with four Bezier curves. +-- +-- The line properties (colour, pen thickness, etc.) are taken +-- from the implicit 'DrawingContext'.+-- +strokedEllipse :: Floating u => u -> u -> LocGraphic u+strokedEllipse rx ry =+    promoteR1 (closedStroke . curvedPath . bezierEllipse rx ry)++++-- | '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 :: (Real u, Floating u) => u -> u -> LocThetaGraphic u+rstrokedEllipse hw hh = +    promoteR2 $ \ pt theta -> +      closedStroke $ curvedPath $ rbezierEllipse hw hh theta pt +++-- | '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 :: Floating u => u -> u -> LocGraphic u+filledEllipse hw hh = +    promoteR1 (filledPath . curvedPath . bezierEllipse hw hh)+++-- | '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 :: (Real u, Floating u) => u -> u -> LocThetaGraphic u+rfilledEllipse hw hh = +    promoteR2 $ \ pt theta -> +      filledPath $ curvedPath $ rbezierEllipse hw hh theta pt ++++-- | '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 :: Floating u => u -> u -> LocGraphic u+borderedEllipse hw hh =+    promoteR1 (borderedPath . curvedPath . bezierEllipse hw hh)++++-- | 'rborderedEllipse' : @ x_radius * y_radius -> LocGraphic @+--+-- Create a bordered ellipse 'LocThetaGraphic' - the implicit point+-- is center and the angle is rotation about the center. The +-- ellipse is drawn with four Bezier curves.  +-- +-- The background fill colour and the outline stroke properties +-- are taken from the implicit 'DrawingContext'.+-- +rborderedEllipse :: (Real u, Floating u) => u -> u -> LocThetaGraphic u+rborderedEllipse hw hh = +    promoteR2 $ \ pt theta -> +      borderedPath $ curvedPath $ rbezierEllipse hw hh theta pt ++++-- Note - clipping needs a picture as well as a path, so there is+-- no analogous @clippedPath@ function.++--------------------------------------------------------------------------------+-- Rectangles++++-- | Supplied point is /bottom-left/.+--+rectanglePath :: Num u => u -> u -> Point2 u -> PrimPath u+rectanglePath w h bl = primPath bl [ lineTo br, lineTo tr, lineTo tl ]+  where+    br = bl .+^ hvec w+    tr = br .+^ vvec h+    tl = bl .+^ vvec h+++-- | 'strokedRectangle' : @ width * height -> LocGraphic @+--+-- Create a stroked rectangle 'LocGraphic' - the implicit point is +-- bottom-left. +-- +-- The line properties (colour, pen thickness, etc.) are taken +-- from the implicit 'DrawingContext'.+-- +strokedRectangle :: Fractional u => u -> u -> LocGraphic u+strokedRectangle w h = promoteR1 (closedStroke . rectanglePath w h)+++-- | '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 :: Fractional u => u -> u -> LocGraphic u+filledRectangle w h = promoteR1 (filledPath . rectanglePath w h)+++-- | '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 :: Fractional u => u -> u -> LocGraphic u+borderedRectangle w h = promoteR1 (borderedPath . rectanglePath w h)+++---------------------------------------------------------------------------+++-- | 'strokedDisk' : @ radius -> LocGraphic @+--+-- Create a stroked 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, stroked-circles do not draw well after +-- non-uniform scaling - the pen width is scaled as well as +-- the shape.+--+-- For stroked circles that can be adequately scaled, use +-- 'strokedCircle' instead.+--+-- The line properties (colour, pen thickness, etc.) are taken +-- from the implicit 'DrawingContext'.+-- +strokedDisk :: Num u => u -> LocGraphic u+strokedDisk r = strokedEllipseDisk r r+++-- | '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 :: Num u => u -> LocGraphic u+filledDisk r = filledEllipseDisk r r+++-- | '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 :: Num u => u -> LocGraphic u+borderedDisk r = borderedEllipseDisk r r+++-- | 'strokedEllipseDisk' : @ x_radius * y_radius -> LocGraphic @+--+-- Create a stroked ellipse 'LocGraphic' - the implicit point is +-- the center. +-- +-- This is a efficient representation of circles using +-- PostScript\'s @arc@ or SVG\'s @ellipse@ in the generated +-- output. However, stroked ellipses do not draw well after +-- non-uniform scaling - the pen width is scaled as well as +-- the shape.+--+-- For stroked ellipses that can be adequately scaled, use +-- 'strokedEllipse' instead.+--+-- The line properties (colour, pen thickness, etc.) are taken +-- from the implicit 'DrawingContext'.+-- +strokedEllipseDisk :: Num u => u -> u -> LocGraphic u+strokedEllipseDisk rx ry =+    promoteR1 $ \ pt -> +      withStrokeAttr $ \rgb attr -> +        graphicAns (strokeEllipse rgb attr rx ry 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 :: Num u => u -> u -> LocGraphic u+filledEllipseDisk rx ry = +    promoteR1 $ \pt ->  +      withFillAttr $ \rgb -> graphicAns (fillEllipse rgb rx ry 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 :: Num u => u -> u -> LocGraphic u+borderedEllipseDisk rx ry = +    promoteR1 $ \pt -> +      withBorderedAttr $ \frgb attr srgb -> +        graphicAns (fillStrokeEllipse frgb attr srgb rx ry pt)

@@ -5,7 +5,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.Kernel.Objects.Graphic--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2010-2011 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com@@ -37,66 +37,33 @@   , DLocThetaGraphic    -- * Functions+  , safeconcat+  , ignoreAns+  , replaceAns+  , mapAns+   , intoImage   , intoLocImage   , intoLocThetaImage -  , moveStartPoint-  , moveStartPointTheta--  , locPath-  , emptyLocPath   , emptyLocGraphic---  , openStroke-  , closedStroke-  , filledPath-  , borderedPath--  , textline-  , rtextline-  , escapedline-  , rescapedline--  , hkernline-  , vkernline--  , strokedEllipse-  , rstrokedEllipse-  , filledEllipse-  , rfilledEllipse--  , borderedEllipse-  , rborderedEllipse--  , straightLine-  , straightLineBetween-  , curveBetween--  , strokedRectangle-  , filledRectangle-  , borderedRectangle+  , emptyLocThetaGraphic  -  , strokedCircle-  , filledCircle-  , borderedCircle+  , decorate+  , sdecorate+  , adecorate   -  , strokedDisk-  , filledDisk-  , borderedDisk+  , hyperlink    ) where -import Wumpus.Basic.Kernel.Base.ContextFun import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.QueryDC+import Wumpus.Basic.Kernel.Base.ContextFun import Wumpus.Basic.Kernel.Base.WrappedPrimitive import Wumpus.Basic.Kernel.Objects.BaseObjects  import Wumpus.Core                              -- package: wumpus-core -import Data.AffineSpace                         -- package: vector-space  import Control.Applicative @@ -143,336 +110,173 @@ -- Functions  --- | Build an Image...----intoImage :: CF a -> Graphic u -> Image u a-intoImage = liftA2 (\a (_,b) -> (a,b))----- | Build a LocImage...----intoLocImage :: LocCF u a -> LocGraphic u -> LocImage u a-intoLocImage = liftA2 (\a (_,b) -> (a,b))---- | Build a LocThetaImage...----intoLocThetaImage :: LocThetaCF u a -> LocThetaGraphic u -> LocThetaImage u a-intoLocThetaImage = liftA2 (\a (_,b) -> (a,b))----- | Move the start-point of a LocImage with the supplied --- displacement function.----moveStartPoint :: PointDisplace u -> LocCF u a -> LocCF u a-moveStartPoint f ma = promoteR1 $ \pt -> apply1R1 ma (f pt)----- | Move the start-point of a LocImage with the supplied --- displacement function.----moveStartPointTheta :: PointDisplace u -> LocThetaCF u a -> LocThetaCF u a-moveStartPointTheta f ma = promoteR2 $ \pt theta -> apply2R2 ma (f pt) theta--------------------------------------------------------------------------------------graphicBody :: Primitive u -> (UNil u, PrimGraphic u)-graphicBody p = (uNil, primGraphic p)----- | This is the analogue to 'vectorPath' in @Wumpus-core@.----locPath :: Num u => [Vec2 u] -> LocCF u (PrimPath u)-locPath vs = promoteR1 $ \pt  -> pure $ vectorPath pt vs----- | This is the analogue to 'emptyPath' in @Wumpus-core@.+-- | 'safeconcat' : @ alternative * [image] -> Image@+-- +-- 'safeconcat' produces a composite 'Image' from a list of +-- @Image@\'s. If the list is empty the alternative @Image@ is +-- used. ---emptyLocPath :: Num u => LocCF u (PrimPath u)-emptyLocPath = locPath []---- | Build an empty LocGraphic - this is a path with a start--- point but no path segments. +-- This contrasts to 'oconcat' - when used for @Image@\'s, +-- @oconcat@ has the same type signature as @safeconcat@ but +-- @oconcat@ considers its arguments to be an already destructured +-- list: -- --- The 'emptyLocGraphic' It 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.+-- > oconcat (head::Image) (rest::[Image]) -- -emptyLocGraphic :: Num u => LocGraphic u-emptyLocGraphic = emptyLocPath >>= (lift0R1 . openStroke)----- | '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 :: Num u => PrimPath u -> Graphic u-openStroke pp = -    withStrokeAttr $ \rgb attr -> graphicBody $ ostroke rgb attr pp+safeconcat :: OPlus a => Image u a -> [Image u a] -> Image u a+safeconcat _   (x:xs) = oconcat x xs+safeconcat alt []     = alt  --- | 'closedStroke' : @ path -> Graphic @+-- | Ignore the answer produced by an 'Image', a 'LocImage' etc. ----- This is the analogue to 'cstroke' in @Wumpus-core@, but the --- drawing properties (colour, line width, etc.) are taken from --- the implicit 'DrawingContext'.+-- Use this function to turn an 'Image' into a 'Graphic', a +-- 'LocImage into a 'LocGraphic'. ---closedStroke :: Num u => PrimPath u -> Graphic u-closedStroke pp = -    withStrokeAttr $ \rgb attr -> graphicBody $ cstroke rgb attr pp+ignoreAns :: Functor f => f (a,b) -> f (UNil u, b)+ignoreAns = fmap (replaceL uNil)  --- | 'filledPath' : @ path -> Graphic @--- --- This is the analogue to 'fill' in @Wumpus-core@, but the --- fill colour is taken from the implicit 'DrawingContext'.-------filledPath :: Num u => PrimPath u -> Graphic u-filledPath pp = withFillAttr $ \rgb -> graphicBody $ 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'.---+-- | Replace the answer produced by an 'Image', a 'LocImage' etc. ---borderedPath :: Num u => PrimPath u -> Graphic u-borderedPath pp =-    withBorderedAttr $ \frgb attr srgb -> -      graphicBody $ fillStroke frgb attr srgb pp--+replaceAns :: Functor f => z -> f (a,b) -> f (z, b)+replaceAns = fmap . replaceL  --- | This is the analogue to 'textlabel' in @Wumpus-core@.+-- | Apply the supplied function to the answer produced by an +-- 'Image', a 'LocImage' etc. ---textline :: Num u => String -> LocGraphic u-textline ss = -    promoteR1 $ \pt -> -      withTextAttr $ \rgb attr -> graphicBody (textlabel rgb attr ss pt)--+mapAns :: Functor f => (a -> z) -> f (a,b) -> f (z,b)+mapAns f = fmap (\(a,b) -> (f a ,b))  --- | This is the analogue to 'rtextlabel' in @Wumpus-core@.+-- | 'intoImage' : @ context_function * graphic -> Image @ ---rtextline :: Num u => String -> LocThetaGraphic u-rtextline ss = -    promoteR2 $ \pt theta -> -      withTextAttr $ \rgb attr -> graphicBody (rtextlabel rgb attr ss theta pt)------ | This is the analogue to 'escapedlabel' in @Wumpus-core@.+-- Build an 'Image' from a context function ('CF') that generates +-- the answer and a 'Graphic' that draws the 'Image'. ---escapedline :: Num u => EscapedText -> LocGraphic u-escapedline ss = -    promoteR1 $ \pt -> -      withTextAttr $ \rgb attr -> graphicBody (escapedlabel rgb attr ss pt)-+intoImage :: CF a -> Graphic u -> Image u a+intoImage = liftA2 (\a (_,b) -> (a,b))  --- | This is the analogue to 'rescapedlabel' in @Wumpus-core@.+-- | 'intoLocImage' : @ loc_context_function * loc_graphic -> LocImage @ ---rescapedline :: Num u => EscapedText -> LocThetaGraphic u-rescapedline ss = -    promoteR2 $ \pt theta -> -      withTextAttr $ \rgb attr -> graphicBody (rescapedlabel rgb attr ss theta pt)------- | This is the analogue to 'hkernlabel' in @Wumpus-core@.+-- /Loc/ version of 'intoImage'. +-- +-- The 'LocImage' is built as a function from an implicit start +-- point to the answer. ---hkernline :: Num u => [KerningChar u] -> LocGraphic u-hkernline xs = -    promoteR1 $ \pt -> -      withTextAttr $ \rgb attr -> graphicBody (hkernlabel rgb attr xs pt)-+intoLocImage :: LocCF u a -> LocGraphic u -> LocImage u a+intoLocImage = liftA2 (\a (_,b) -> (a,b)) --- | This is the analogue to 'vkernlabel' in @Wumpus-core@.+-- | 'intoLocThetaImage' : @ loc_theta_cf * loc_theta_graphic -> LocThetaImage @ ---vkernline :: Num u => [KerningChar u] -> LocGraphic u-vkernline xs = -    promoteR1 $ \pt -> -      withTextAttr $ \rgb attr -> graphicBody (vkernlabel rgb attr xs pt)--------------------------------------------------------------------------------------------- | This is the analogue to 'strokeEllipse' in @Wumpus-core@.+-- /LocTheta/ version of 'intoImage'. +-- +-- The 'LocThetaImage' is built as a function from an implicit +-- start point and angle of inclination to the answer. ---strokedEllipse :: Num u => u -> u -> LocGraphic u-strokedEllipse hw hh =-    promoteR1 $ \pt -> -      withStrokeAttr $ \rgb attr -> graphicBody (strokeEllipse rgb attr hw hh pt)+intoLocThetaImage :: LocThetaCF u a -> LocThetaGraphic u -> LocThetaImage u a+intoLocThetaImage = liftA2 (\a (_,b) -> (a,b))   --- | This is the analogue to 'rstrokeEllispe' in @Wumpus-core@.----rstrokedEllipse :: Num u => u -> u -> LocThetaGraphic u-rstrokedEllipse hw hh = -    promoteR2 $ \ pt theta -> -      withStrokeAttr $ \rgb attr -> -        graphicBody (rstrokeEllipse rgb attr hw hh theta pt)----- | This is the analogue to 'fillEllispe' in @Wumpus-core@.----filledEllipse :: Num u => u -> u -> LocGraphic u-filledEllipse hw hh = -    promoteR1 $ \pt ->  -      withFillAttr $ \rgb -> graphicBody (fillEllipse rgb hw hh pt)----- | This is the analogue to 'rfillEllispe' in @Wumpus-core@.+-- | 'emptyLocGraphic' : @ LocGraphic @ ---rfilledEllipse :: Num u => u -> u -> LocThetaGraphic u-rfilledEllipse hw hh = -    promoteR2 $ \pt theta ->-      withFillAttr $ \rgb -> graphicBody (rfillEllipse rgb hw hh theta pt)+-- Build an empty 'LocGraphic' (i.e. a function +-- /from Point to Graphic/). This is a path with a start point +-- but no path segments. +-- +-- 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.+-- +emptyLocGraphic :: Num u => LocGraphic u+emptyLocGraphic = promoteR1 $ \pt -> +                    return $ (uNil, primGraphic $ zostroke $ emptyPath pt)   --- | This is the analogue to 'fillStrokeEllispe' in @Wumpus-core@.----borderedEllipse :: Num u => u -> u -> LocGraphic u-borderedEllipse hw hh =-    promoteR1 $ \pt -> -      withBorderedAttr $ \frgb attr srgb -> -        graphicBody (fillStrokeEllipse frgb attr srgb hw hh pt)---- | This is the analogue to 'rfillStrokeEllispe' in @Wumpus-core@.+-- | 'emptyLocThetaGraphic' : @ LocThetaGraphic @ ---rborderedEllipse :: Num u => u -> u -> LocThetaGraphic u-rborderedEllipse hw hh = -    promoteR2 $ \pt theta -> -      withBorderedAttr $ \frgb attr srgb -> -        graphicBody (rfillStrokeEllipse frgb attr srgb hw hh theta pt)------ Note - clipping needs a picture as well as a path, so there is--- no analogous @clippedPath@ function.--------------------------------------------------------------------------------------- | Draw a straight line formed from displacing the implicit --- start point with the supplied vector.+-- Build an empty 'LocThetaGraphic' (i.e. a function +-- /from Point and Inclination to Graphic/).  -- -straightLine :: Fractional u => Vec2 u -> LocGraphic u-straightLine v = mf >>= (lift0R1 . openStroke)-  where-    mf = promoteR1 $ \pt -> pure $ primPath pt [lineTo $ pt .+^ v]--          --- | Draw a straight line - start and end point are supplied --- explicitly.+-- 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. -- -straightLineBetween :: Fractional u => Point2 u -> Point2 u -> Graphic u-straightLineBetween p1 p2 = openStroke $ primPath p1 [lineTo p2]+emptyLocThetaGraphic :: Num u => LocThetaGraphic u+emptyLocThetaGraphic = lift1R2 emptyLocGraphic   --- | Draw a Bezier curve - all points are supplied explicitly.--- -curveBetween :: Fractional u -             => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Graphic u-curveBetween sp cp1 cp2 ep = openStroke $ primPath sp [curveTo cp1 cp2 ep] ---- This is a permuted version of the cardinal-prime combinator...--- --- > (r2 -> a) -> (a -> r1 -> ans) -> (r1 -> r2 -> ans)+-- | Decorate an Image by superimposing a Graphic. ----drawWith :: (Point2 u -> PrimPath u) -> (PrimPath u -> Graphic u) -> LocGraphic u -drawWith g mf = promoteR1 $ \pt -> mf (g pt)----- | Supplied point is /bottom-left/.+-- Note - this function has a very general type signature and+-- supports various graphic types: ---rectanglePath :: Num u => u -> u -> Point2 u -> PrimPath u-rectanglePath w h bl = primPath bl [ lineTo br, lineTo tr, lineTo tl ]-  where-    br = bl .+^ hvec w-    tr = br .+^ vvec h-    tl = bl .+^ vvec h---- | Supplied point is /bottom left/.+-- > 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 ---strokedRectangle :: Fractional u => u -> u -> LocGraphic u-strokedRectangle w h = rectanglePath w h `drawWith` closedStroke+decorate :: Monad m +         => m (ImageAns u a) -> m (ImageAns u zz) -> m (ImageAns u a) +decorate img gf = +    img >>= \(a,g1) -> gf >>= \(_,g2) -> return (a, g1 `oplus` g2)  --- | Supplied point is /bottom left/.----filledRectangle :: Fractional u => u -> u -> LocGraphic u-filledRectangle w h = rectanglePath w h `drawWith` filledPath --- | Supplied point is /bottom left/.+-- | /Anterior decorate/ - decorate an Image by superimposing it +-- on a Graphic. ---borderedRectangle :: Fractional u => u -> u -> LocGraphic u-borderedRectangle w h = rectanglePath w h `drawWith` borderedPath----- | Supplied point is center. Circle is drawn with Bezier --- curves. +-- Note - here the Graphic has access to the result produced by the +-- the Image unlike 'decorate'. ---strokedCircle :: Floating u => Int -> u -> LocGraphic u-strokedCircle n r = (curvedPath . bezierCircle n r) `drawWith` closedStroke ------ | Supplied point is center. Circle is drawn with Bezier --- curves. +-- Again, this function has a very general type signature and+-- supports various graphic types: ---filledCircle :: Floating u => Int -> u -> LocGraphic u-filledCircle n r =  (curvedPath . bezierCircle n r) `drawWith` filledPath------ | Supplied point is center. Circle is drawn with Bezier --- curves. +-- > adecorate :: Image u a -> Graphic u -> Image u a+-- > adecorate :: LocImage u a -> LocGraphic u -> LocImage u a+-- > adecorate :: LocThetaImage u a -> LocThetaGraphic u -> LocTheteImage u a ---borderedCircle :: Floating u => Int -> u -> LocGraphic u-borderedCircle n r = (curvedPath . bezierCircle n r) `drawWith` borderedPath +adecorate :: Monad m +          => m (ImageAns u a) -> (a -> m (ImageAns u zz)) -> m (ImageAns u a)+adecorate img f = +    img >>= \(a,g1) -> f a >>= \(_,g0) -> return (a, g0 `oplus` g1)  --- | 'disk' is drawn with Wumpus-Core\'s @ellipse@ primitive.+-- | /Superior decorate/ - decorate an image by superimposing a +-- graphic on top of it. ----- This is a efficient representation of circles using --- PostScript\'s @arc@ or SVG\'s @circle@ in the generated --- output. However, stroked-circles do not draw well after --- non-uniform scaling - the line width is scaled as well as --- the shape.+-- Note, here the Graphic has access to the result produced by the +-- the Image unlike 'decorate'. ----- For stroked circles that can be adequately scaled, use --- 'strokedCircle' instead.+-- Again, this function has a very general type signature and+-- supports various graphic types: ---strokedDisk :: Num u => u -> LocGraphic u-strokedDisk radius = strokedEllipse radius radius---- | Filled disk...+-- > sdecorate :: Image u a -> Graphic u -> Image u a+-- > sdecorate :: LocImage u a -> LocGraphic u -> LocImage u a+-- > sdecorate :: LocThetaImage u a -> LocThetaGraphic u -> LocTheteImage u a ---filledDisk :: Num u => u -> LocGraphic u-filledDisk radius = filledEllipse radius radius+sdecorate :: Monad m +          => m (ImageAns u a) -> (a -> m (ImageAns u zz)) -> m (ImageAns u a)+sdecorate img f = +    img >>= \(a,g1) -> f a >>= \(_,g2) -> return (a, g1 `oplus` g2) --- | bordered disk...++-- | Hyperlink a graphic object.+-- +-- This function has a very general type signature and supports +-- various graphic types: ---borderedDisk :: Num u => u -> LocGraphic u-borderedDisk radius = borderedEllipse radius radius+-- > 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+--+hyperlink :: Functor m => XLink -> m (ImageAns u a) -> m (ImageAns u a)+hyperlink hypl = +    fmap (\(a,prim) -> (a, metamorphPrim (xlink hypl) prim))+

@@ -0,0 +1,237 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Objects.PosImage+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Extended Graphic object - a rectangular /positionable/ Image.+-- +-- This graphic object has a more flexible API for positioning +-- than other graphic objects. Rather than a LocGraphic which +-- supports a single method of positioning at some start-point,+-- a @PosGraphic@ can be drawn at its center or locations on its +-- outer rectangle.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Objects.PosImage+  (++    RectPosition(..)+  , ObjectPos(..)++  -- * Positionable image++  , PosImage+  , DPosImage ++  , PosGraphic+  , DPosGraphic++  , makePosImage++  , startPos+  , atStartPos++  , objectPosBounds++  ) where+++import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Base.ContextFun+import Wumpus.Basic.Kernel.Objects.BaseObjects+import Wumpus.Basic.Kernel.Objects.Displacement++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space++-- | Datatype enumerating positions within a rectangle that can be+-- derived for a 'PosGraphic'.  +--+data RectPosition = CENTER | NN | SS | EE | WW | NE | NW | SE | SW +  deriving (Enum,Eq,Ord,Show)+++-- | Utility datatype representing orientation within a +-- rectangular /frame/. ObjectPos is useful for graphics such as +-- text where the start point is not necessarily at the center +-- (or bottom left).+--+-- > x_minor is the horizontal distance from the left to the start point+-- >+-- > x_major is the horizontal distance from the start point to the right+-- >+-- > y_minor is the vertical distance from the bottom to the start point+-- >+-- > y_major is the vertical distance from the start point to the top+--+-- Values should be not be negative!+--+-- +data ObjectPos u = ObjectPos +      { op_x_minor      :: !u+      , op_x_major      :: !u+      , op_y_minor      :: !u+      , op_y_major      :: !u+      }+  deriving (Eq,Ord,Show)++++type instance DUnit (ObjectPos u)   = u++++-- | A positionable Image.+--+type PosImage u a = CF2  (Point2 u) RectPosition (ImageAns u a)+    +-- | Version of PosImage specialized to Double for the unit type.+--+type DPosImage a = PosImage Double a++++-- | A positionable Graphic.+--+type PosGraphic u = PosImage u (UNil u) +    +-- | Version of PosGraphic specialized to Double for the unit type.+--+type DPosGraphic = PosGraphic Double+++++++--------------------------------------------------------------------------------+++instance (Fractional u, Ord u) => OPlus (ObjectPos u) where+  oplus = concatObjectPos+++-- | Concatenation here essentially turns both ObjectPos objects+-- into /center-form/ then finds the maximum rectangle.+--+concatObjectPos :: (Fractional u, Ord u) +                => ObjectPos u -> ObjectPos u -> ObjectPos u+concatObjectPos op0 op1 = ObjectPos hw hw hh hh+  where+    (hw0,hh0) = halfDists op0+    (hw1,hh1) = halfDists op1+    hw        = max hw0 hw1+    hh        = max hh0 hh1++++--------------------------------------------------------------------------------+++-- | Find the half-width and half-height of an ObjectPos.+-- +-- Essentially this is /center-form/ of an ObjectPos, but +-- in /center-form/ there is duplication: +--+-- > xminor == xmajor+-- > yminor == ymajor+-- +-- So instead, the result type is just a pair.+--+halfDists :: Fractional u => ObjectPos u -> (u,u)+halfDists (ObjectPos xmin xmaj ymin ymaj) = +    (0.5 * (xmin+xmaj), 0.5 * (ymin+ymaj))+++-- | 'makePosImage' : @ object_pos * loc_graphic -> PosGraphic @ +--+-- Create a 'PosImage' from an 'ObjectPos' describing how it+-- is orientated within a border rectangle and a 'LocImage' that +-- draws it.+--+makePosImage :: Fractional u +             => ObjectPos u -> LocImage u a -> PosImage u a+makePosImage opos gf = promoteR2 $ \start rpos -> +    let v1 = startVector rpos opos in gf `at` displaceVec v1 start++++infixr 1 `startPos`++-- | 'startPos' : @ pos_image * rect_pos -> LocImage @+--+-- /Downcast/ a 'PosImage' to a 'LocImage' by supplying it +-- with a 'RectPosition' (start position).+--  +startPos :: Floating u +         => PosImage u a -> RectPosition -> LocImage u a+startPos = apply1R2+ +-- | 'atStartPos' : @ pos_image * start_point * rect_pos -> LocImage @+--+-- /Downcast/ a 'PosGraphic' to an 'Image' by supplying it +-- with an initial point and a 'RectPosition' (start position).+--  +atStartPos ::  Floating u +           => PosImage u a -> Point2 u -> RectPosition -> Image u a+atStartPos = apply2R2++-- | The vector from some Rectangle position to the start point.+--+startVector :: Fractional u => RectPosition -> ObjectPos u -> Vec2 u+startVector rpos (ObjectPos xminor xmajor yminor ymajor) = go rpos+  where+    w         = xminor + xmajor+    h         = yminor + ymajor+    hw        = 0.5 * w+    hh        = 0.5 * h+    +    -- CENTER, NN, SS, EE, WW all go to bottomleft then add back +    -- the minors.++    go CENTER = V2 ((-hw) + xminor) ((-hh) + yminor)+    go NN     = V2 ((-hw) + xminor) ((-h)  + yminor)+    go SS     = V2 ((-hw) + xminor)  yminor+    go EE     = V2 ((-w)  + xminor) ((-hh) + yminor)+    go WW     = V2 xminor           ((-hh) + yminor)+    go NE     = V2 (-xmajor)        (-ymajor)+    go SE     = V2 (-xmajor)          yminor+    go SW     = V2 xminor           yminor+    go NW     = V2 xminor           (-ymajor)++++-- | Calculate the bounding box formed by locating the 'ObjectPos'+-- at the supplied point.+-- +objectPosBounds :: Fractional u +                => Point2 u -> RectPosition -> ObjectPos u -> BoundingBox u+objectPosBounds (P2 x y) pos (ObjectPos xmin xmaj ymin ymaj) = go pos+  where+    w         = xmin + xmaj+    h         = ymin + ymaj+    hw        = 0.5 * w+    hh        = 0.5 * h+    bbox      = \bl -> BBox bl (bl .+^ vec w h)++    go CENTER = bbox $ P2 (x-hw) (y-hh)+    go NN     = bbox $ P2 (x-hw) (y-h)+    go SS     = bbox $ P2 (x-hw)  y+    go EE     = bbox $ P2 (x-w)  (y-hh)+    go WW     = bbox $ P2  x     (y-hh)+    go NE     = bbox $ P2 (x-w)  (y-h)+    go SE     = bbox $ P2 (x-w)   y+    go SW     = bbox $ P2 x       y+    go NW     = bbox $ P2 x      (y-h)++

@@ -76,6 +76,7 @@ afm_mono_defaults_4_1 =      MonospaceDefaults { default_letter_bbox  = bbox                       , default_cap_height   = 562+                      , default_descender    = (-157)                       , default_char_width   = V2 600 0                       }   where

@@ -71,6 +71,7 @@               { afm_encoding        = getEncodingScheme info               , afm_letter_bbox     = getFontBBox       info               , afm_cap_height      = getCapHeight      info+              , afm_descender       = getDescender      info               , afm_glyph_metrics   = cms               } @@ -101,6 +102,9 @@  getCapHeight           :: GlobalInfo -> Maybe AfmUnit getCapHeight           = runQuery "CapHeight" number++getDescender           :: GlobalInfo -> Maybe AfmUnit+getDescender           = runQuery "Descender" number   charBBox :: CharParser AfmBoundingBox

@@ -46,8 +46,8 @@  import Wumpus.Core                              -- package: wumpus-core -import qualified Data.IntMap   as IntMap-import qualified Data.Map as Map+import qualified Data.IntMap   as IM+import qualified Data.Map      as M   @@ -87,7 +87,7 @@ type AfmBoundingBox     = BoundingBox AfmUnit  type AfmKey         = String-type GlobalInfo     = Map.Map AfmKey String+type GlobalInfo     = M.Map AfmKey String   @@ -106,6 +106,7 @@       { afm_encoding        :: Maybe String       , afm_letter_bbox     :: Maybe AfmBoundingBox       , afm_cap_height      :: Maybe AfmUnit+      , afm_descender       :: Maybe AfmUnit       , afm_glyph_metrics   :: [AfmGlyphMetrics]       }   deriving (Show) @@ -132,6 +133,7 @@ data MonospaceDefaults cu = MonospaceDefaults        { default_letter_bbox  :: BoundingBox cu       , default_cap_height   :: cu+      , default_descender    :: cu       , default_char_width   :: Vec2 cu       }   deriving (Eq,Show)@@ -150,8 +152,9 @@ data FontProps cu = FontProps        { fp_bounding_box        :: BoundingBox cu         , fp_default_adv_vec     :: Vec2 cu-       , fp_adv_vecs            :: IntMap.IntMap (Vec2 cu)+       , fp_adv_vecs            :: IM.IntMap (Vec2 cu)        , fp_cap_height          :: cu+       , fp_descender           :: cu        }  @@ -159,13 +162,14 @@ -- scaling function and FontProps read from a file. -- buildMetricsOps :: (cu -> PtSize) -> FontProps cu -> MetricsOps-buildMetricsOps fn (FontProps (BBox ll ur) (V2 vx vy) -                              vec_table    cap_height) = +buildMetricsOps fn font@(FontProps { fp_bounding_box = BBox ll ur+                                   , fp_default_adv_vec = V2 vx vy }) =      MetricsOps       { get_bounding_box  = \sz -> BBox (scalePt sz ll) (scalePt sz ur)       , get_cw_table      = \sz i -> -            maybe (defaultAV sz) (scaleVec sz) $ IntMap.lookup i vec_table -      , get_cap_height    = \sz -> upscale sz (fn cap_height)+            maybe (defaultAV sz) (scaleVec sz) $ IM.lookup i (fp_adv_vecs font)+      , get_cap_height    = \sz -> upscale sz (fn $ fp_cap_height font)+      , get_descender     = \sz -> upscale sz (fn $ fp_descender font)       }   where     upscale sz d            = fromPtSize $ sz * d 

@@ -164,13 +164,15 @@                   -> AfmFile                    -> FontLoadIO (FontProps AfmUnit) buildAfmFontProps defaults afm = do -    cap_height <- extractCapHeight defaults afm-    bbox       <- extractFontBBox  defaults afm +    cap_height  <- extractCapHeight defaults afm+    desc_depth  <- extractDescender defaults afm+    bbox        <- extractFontBBox  defaults afm      return $ FontProps                 { fp_bounding_box    = bbox                , fp_default_adv_vec = default_char_width defaults                , fp_adv_vecs        = char_widths                , fp_cap_height      = cap_height+               , fp_descender       = desc_depth                }     where     char_widths = foldr fn IntMap.empty $ afm_glyph_metrics afm@@ -185,6 +187,14 @@   where     errk = logLoadMsg "WARNING - Could not extract CapHeight" >>             return (default_cap_height defaults)++++extractDescender :: MonospaceDefaults AfmUnit -> AfmFile -> FontLoadIO AfmUnit+extractDescender defaults afm = maybe errk return $ afm_descender afm+  where+    errk = logLoadMsg "WARNING - Could not extract Descender" >> +           return (default_descender defaults)   extractFontBBox :: MonospaceDefaults AfmUnit -> AfmFile 

@@ -80,6 +80,7 @@ ghostscript_mono_defaults_8_54 =      MonospaceDefaults { default_letter_bbox  = bbox                       , default_cap_height   = 563+                      , default_descender    = (-186)                       , default_char_width   = V2 600 0                       }   where

@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.VersionNumber--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2010-2011 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com@@ -23,7 +23,7 @@  -- | Version number ----- > (0,15,0)+-- > (0,16,0) -- wumpus_basic_version :: (Int,Int,Int)-wumpus_basic_version = (0,15,0)+wumpus_basic_version = (0,16,0)

@@ -1,5 +1,5 @@ name:             wumpus-basic-version:          0.15.0+version:          0.16.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -30,6 +30,32 @@   .   Changelog:   .+  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 @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@.+  .   v0.14.0 to v0.15.0:   .    * Split previous @Wumpus-Basic@ package into two packages:@@ -59,7 +85,9 @@ extra-source-files:   CHANGES,   LICENSE,-  demo/FontDeltaPic.hs+  demo/FontDeltaPic.hs,+  demo/SimpleAdvGraphic.hs,+  demo/SimplePosImage.hs  library   hs-source-dirs:     src@@ -68,10 +96,14 @@                       directory       >= 1.0     && <  2.0,                        filepath        >= 1.1     && <  2.0,                       vector-space    >= 0.6     && <  1.0,-                      wumpus-core     >= 0.42.0  && <  0.43.0+                      wumpus-core     >= 0.43.0  && <  0.44.0       exposed-modules:+    Wumpus.Basic.Geometry.Base,+    Wumpus.Basic.Geometry.Intersection,+    Wumpus.Basic.Geometry.Paths,+    Wumpus.Basic.Geometry.Quadrant,     Wumpus.Basic.Kernel,     Wumpus.Basic.Kernel.Base.Anchors,     Wumpus.Basic.Kernel.Base.BaseDefs,@@ -87,7 +119,10 @@     Wumpus.Basic.Kernel.Objects.Bounded,     Wumpus.Basic.Kernel.Objects.Connector,     Wumpus.Basic.Kernel.Objects.CtxPicture,+    Wumpus.Basic.Kernel.Objects.Displacement,+    Wumpus.Basic.Kernel.Objects.DrawingPrimitives,     Wumpus.Basic.Kernel.Objects.Graphic,+    Wumpus.Basic.Kernel.Objects.PosImage,     Wumpus.Basic.Kernel.Objects.TraceDrawing,     Wumpus.Basic.System.FontLoader.Afm,     Wumpus.Basic.System.FontLoader.GhostScript,