wumpus-basic 0.16.0 → 0.17.0

raw patch · 61 files changed

+7435/−4089 lines, 61 filesdep ~wumpus-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: wumpus-core

API changes (from Hackage documentation)

Files

• demo/AltUnits.hs +77/−0
• demo/FontDeltaPic.hs +9/−10
• demo/SimpleAdvGraphic.hs +29/−13
• demo/SimplePosImage.hs +0/−98
• demo/SimplePosObject.hs +108/−0
• src/Wumpus/Basic/Geometry.hs +31/−0
• src/Wumpus/Basic/Geometry/Base.hs +14/−14
• src/Wumpus/Basic/Geometry/Intersection.hs +14/−22
• src/Wumpus/Basic/Geometry/Paths.hs +214/−9
• src/Wumpus/Basic/Kernel.hs +26/−15
• src/Wumpus/Basic/Kernel/Base/Anchors.hs +0/−222
• src/Wumpus/Basic/Kernel/Base/BaseDefs.hs +193/−33
• src/Wumpus/Basic/Kernel/Base/ContextFun.hs +126/−371
• src/Wumpus/Basic/Kernel/Base/DrawingContext.hs +280/−74
• src/Wumpus/Basic/Kernel/Base/FontSupport.hs +256/−0
• src/Wumpus/Basic/Kernel/Base/GlyphMetrics.hs +0/−120
• src/Wumpus/Basic/Kernel/Base/QueryDC.hs +172/−160
• src/Wumpus/Basic/Kernel/Base/ScalingContext.hs +0/−104
• src/Wumpus/Basic/Kernel/Base/Units.hs +163/−0
• src/Wumpus/Basic/Kernel/Base/UpdateDC.hs +516/−139
• src/Wumpus/Basic/Kernel/Base/WrappedPrimitive.hs +62/−70
• src/Wumpus/Basic/Kernel/Objects/AdvObject.hs +230/−0
• src/Wumpus/Basic/Kernel/Objects/AdvanceGraphic.hs +0/−166
• src/Wumpus/Basic/Kernel/Objects/Anchors.hs +233/−0
• src/Wumpus/Basic/Kernel/Objects/BaseObjects.hs +0/−186
• src/Wumpus/Basic/Kernel/Objects/Basis.hs +564/−0
• src/Wumpus/Basic/Kernel/Objects/Bounded.hs +66/−30
• src/Wumpus/Basic/Kernel/Objects/Chain.hs +228/−0
• src/Wumpus/Basic/Kernel/Objects/Concat.hs +188/−0
• src/Wumpus/Basic/Kernel/Objects/Connector.hs +76/−49
• src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs +140/−342
• src/Wumpus/Basic/Kernel/Objects/Displacement.hs +202/−72
• src/Wumpus/Basic/Kernel/Objects/DrawingPrimitives.hs +287/−157
• src/Wumpus/Basic/Kernel/Objects/Graphic.hs +0/−282
• src/Wumpus/Basic/Kernel/Objects/Image.hs +105/−0
• src/Wumpus/Basic/Kernel/Objects/LocImage.hs +199/−0
• src/Wumpus/Basic/Kernel/Objects/LocThetaImage.hs +367/−0
• src/Wumpus/Basic/Kernel/Objects/Orientation.hs +500/−0
• src/Wumpus/Basic/Kernel/Objects/PosImage.hs +0/−237
• src/Wumpus/Basic/Kernel/Objects/PosObject.hs +446/−0
• src/Wumpus/Basic/Kernel/Objects/TraceDrawing.hs +193/−56
• src/Wumpus/Basic/System/FontLoader.hs +141/−0
• src/Wumpus/Basic/System/FontLoader/Afm.hs +0/−83
• src/Wumpus/Basic/System/FontLoader/AfmParserBase.hs +214/−0
• src/Wumpus/Basic/System/FontLoader/AfmTopLevel.hs +111/−0
• src/Wumpus/Basic/System/FontLoader/AfmV2Parser.hs +65/−0
• src/Wumpus/Basic/System/FontLoader/AfmV4Dot1Parser.hs +63/−0
• src/Wumpus/Basic/System/FontLoader/Base/AfmParserBase.hs +0/−214
• src/Wumpus/Basic/System/FontLoader/Base/AfmV2Parser.hs +0/−65
• src/Wumpus/Basic/System/FontLoader/Base/AfmV4Dot1Parser.hs +0/−63
• src/Wumpus/Basic/System/FontLoader/Base/Datatypes.hs +0/−182
• src/Wumpus/Basic/System/FontLoader/Base/FontLoadMonad.hs +0/−215
• src/Wumpus/Basic/System/FontLoader/Base/GSFontMap.hs +0/−108
• src/Wumpus/Basic/System/FontLoader/Datatypes.hs +158/−0
• src/Wumpus/Basic/System/FontLoader/FontLoadMonad.hs +200/−0
• src/Wumpus/Basic/System/FontLoader/GSTopLevel.hs +108/−0
• src/Wumpus/Basic/System/FontLoader/GhostScript.hs +0/−87
• src/Wumpus/Basic/Utils/HList.hs +4/−0
• src/Wumpus/Basic/Utils/JoinList.hs +1/−1
• src/Wumpus/Basic/VersionNumber.hs +2/−2
• wumpus-basic.cabal +54/−18

@@ -0,0 +1,77 @@+{-# OPTIONS -Wall #-}+++module AltUnits 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/alt_units01.eps" pic1+    writeSVG "./out/alt_units01.svg" pic1+++std_attr :: DrawingContext+std_attr = (stroke_colour firebrick . fill_colour linen) $ standardContext 12+++drawing01 :: CtxPicture+drawing01 = drawTracing $ combined+++mf1 :: TraceDrawing Double ()+mf1 = do+    draw $ dblLocGraphic `at` P2 12 0++mf2 :: TraceDrawing Em ()+mf2 = do+    draw $ emLocGraphic `at` P2 1 0++combined :: TraceDrawing Double ()+combined = do +    draw $ dblLocGraphic `at` P2 12 108+    drawl (P2 12 72) $ uconvLocImageF emLocGraphic+    draw $ uconvImageF $ emLocGraphic `at` P2 1 3+    drawl (P2 12 0) $ uconvLocImageF $ pushR1 (hyperlink haskell_org) enLocGraphic++dblLocGraphic :: LocGraphic Double+dblLocGraphic = rect1 `oplus` rect2  +  where+    rect1 = borderedRectangle 36 24 +    rect2 = moveStart (displaceH 36) $ borderedRectangle 60 24 ++++emLocGraphic :: LocGraphic Em+emLocGraphic = localize swap_colours $  rect1 `oplus` rect2  +  where+    rect1 = borderedRectangle 3 2 +    rect2 = moveStart (displaceH 3) $ borderedRectangle 5 2 +++enLocGraphic :: LocGraphic En+enLocGraphic = localize (fill_colour lemon_chiffon) $  rect1 `oplus` rect2  +  where+    rect1 = borderedRectangle 6 4+    rect2 = moveStart (displaceH 6) $ borderedRectangle 10 4+++haskell_org :: XLink+haskell_org = xlinkhref "http://www.haskell.org"++firebrick               :: RGBi+firebrick               = RGBi 0xb2 0x22 0x22++lemon_chiffon           :: RGBi+lemon_chiffon           = RGBi 0xff 0xfa 0xcd++linen                   :: RGBi+linen                   = RGBi 0xfa 0xf0 0xe6++

@@ -16,8 +16,7 @@ main :: IO () main = do      createDirectoryIfMissing True "./out/"-    putStrLn $ "Note - the SVG optimization that should be used here"-    putStrLn $ "has bit-rotted and is not currently in use.."+    putStrLn $ "Check the generated SVG to verify the font attrs are grouped..."     --     let pic1 = runCtxPictureU std_attr drawing01     writeEPS "./out/font_delta01.eps" pic1@@ -28,23 +27,23 @@ std_attr = standardContext 24  -drawing01 :: DCtxPicture+drawing01 :: CtxPicture drawing01 = drawTracing $ mf   -mf :: (Floating u, FromPtSize u) => TraceDrawing u ()-mf = do +mf :: TraceDrawing Double ()+mf = fontDelta $ do     draw $ line1 `at` (P2 0 100)     draw $ line2 `at` (P2 0  75)     draw $ line3 `at` (P2 0  50)     draw $ line4 `at` (P2 0  25)     draw $ line5 `at` (P2 0   0)    where-    line1 = textline "All the lines of this drawing" -    line2 = textline "should be grouped within a SVG"-    line3 = textline "g-element, from where they"-    line4 = textline "inherit the font-family and"-    line5 = textline "font-size attributes."+    line1 = plainTextLine "All the lines of this drawing" +    line2 = plainTextLine "should be grouped within a SVG"+    line3 = plainTextLine "g-element, from where they"+    line4 = plainTextLine "inherit the font-family and"+    line5 = plainTextLine "font-size attributes."   

@@ -7,6 +7,7 @@  import Wumpus.Core                      -- package: wumpus-core +import Control.Applicative import System.Directory  main :: IO ()@@ -21,31 +22,46 @@ std_attr = standardContext 24  -drawing01 :: DCtxPicture-drawing01 = drawTracing $ mf +drawing01 :: CtxPicture+drawing01 = drawTracing mf   -mf :: (Floating u, FromPtSize u) => TraceDrawing u ()++-- Although TraceDrawing can be fully unit polymorphic, it seems +-- always best to specialize as we are stating concrete values+-- (and they will be in some unit).+--++mf :: TraceDrawing Double () 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 +    drawl (P2 0 120) $ +        runAdvObjectR1 $ evenspace (hvec 10) [text01, text02, text01] +    drawl (P2 0 80) $ +        runAdvObjectR1 $ advances [text01, text02, text01] +    drawl (P2 0 40) $ +        runAdvObjectR1 (miniDisk `advance` text01 `advance` miniDisk)++    drawl (P2 0 0) $+        runAdvObjectR1 (miniDisk `advance` text02 `advance` miniDisk)++ -- Normally, text calculate the advance vector from the font  -- metrics... ---text01 :: Num u => AdvGraphic u -text01 = replaceAns (hvec 84) $ textline "text01"+text01 :: AdvObject Double+text01 = makeAdvObject (pure $ hvec 84) $ plainTextLine "text01"      -text02 :: Num u => AdvGraphic u -text02 = replaceAns (hvec 210) $ textline "text number two"+text02 :: AdvObject Double+text02 = makeAdvObject (pure $ hvec 210) $ plainTextLine "text number two"  -miniDisk :: Num u => AdvGraphic u-miniDisk = replaceAns (V2 0 0) $ localize (fillColour sienna) $ filledDisk 3+miniDisk :: AdvObject Double+miniDisk = makeAdvObject (pure $ V2 0 0) disk1 +  where+    disk1 = localize (fill_colour sienna) $ filledDisk 3   sienna :: RGBi

@@ -1,98 +0,0 @@-{-# 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,108 @@+{-# OPTIONS -Wall #-}+++module SimplePosObject 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_ctx drawing01+    writeEPS "./out/simple_pos_object01.eps" pic1+    writeSVG "./out/simple_pos_object01.svg" pic1+++std_ctx :: DrawingContext+std_ctx = standardContext 24+++drawing01 :: CtxPicture+drawing01 = drawTracing $ localize (fill_colour red) $ mf +++mf :: TraceDrawing Double ()+mf = do+    draw $ testDrawMinor NN     `at` (P2   0 400)+    draw $ testDrawMinor SS     `at` (P2  75 400)+    draw $ testDrawMinor EE     `at` (P2 150 400)+    draw $ testDrawMinor WW     `at` (P2 225 400)+    draw $ testDrawMinor NE     `at` (P2   0 325)+    draw $ testDrawMinor SE     `at` (P2  75 325)+    draw $ testDrawMinor SW     `at` (P2 150 325)+    draw $ testDrawMinor NW     `at` (P2 225 325)+    draw $ testDrawMinor CENTER `at` (P2   0 250)+    draw $ testDrawMinor BLL    `at` (P2  75 250)+    draw $ testDrawMinor BLC    `at` (P2 150 250)+    draw $ testDrawMinor BLR    `at` (P2 225 250)+++    draw $ testDrawBl    NN     `at` (P2   0 150)+    draw $ testDrawBl    SS     `at` (P2  75 150)+    draw $ testDrawBl    EE     `at` (P2 150 150)+    draw $ testDrawBl    WW     `at` (P2 225 150)+    draw $ testDrawBl    NE     `at` (P2   0 75)+    draw $ testDrawBl    SE     `at` (P2  75 75)+    draw $ testDrawBl    SW     `at` (P2 150 75)+    draw $ testDrawBl    NW     `at` (P2 225 75)+    draw $ testDrawBl    CENTER `at` (P2   0  0)+    draw $ testDrawBl    BLL    `at` (P2  75  0)+    draw $ testDrawBl    BLC    `at` (P2 150  0)+    draw $ testDrawBl    BLR    `at` (P2 225  0)+    ++testDrawBl :: (Floating u, InterpretUnit u) => RectAddress -> LocGraphic u+testDrawBl rpos = +    filledDisk 2 `oplus` (pushR1 ignoreAns $ rectBl `startAddr` rpos)++rectBl :: (Fractional u, InterpretUnit u) => BoundedLocRectGraphic u+rectBl = runPosObjectR2 $ makePosObject (return ortt) (mkRectBl w h)+  where+    w    = 40 +    h    = 30+    ortt = Orientation { or_x_minor = 0+                       , or_x_major = w+                       , or_y_minor = 0+                       , or_y_major = h }+ ++-- start-point - bottom left+mkRectBl :: InterpretUnit u => u -> u -> LocGraphic u+mkRectBl w h = strokedRectangle w h++++testDrawMinor :: (Floating u, InterpretUnit u) => RectAddress -> LocGraphic u+testDrawMinor rpos = +    filledDisk 2 `oplus` (pushR1 ignoreAns $ rectMinor `startAddr` rpos)+++rectMinor :: (Fractional u, InterpretUnit u) => BoundedLocRectGraphic u +rectMinor = +    runPosObjectR2 $ makePosObject (return ortt) (mkRectMinor m w h)+  where+    m    = 10+    w    = 40 +    h    = 30+    ortt = Orientation { or_x_minor = m+                       , or_x_major = (w-m)+                       , or_y_minor = m+                       , or_y_major = (h-m) }+ ++-- start-point - +10 +10+mkRectMinor :: InterpretUnit u => u -> u -> u -> LocGraphic u+mkRectMinor m w h = promoteR1 $ \pt -> +    let bl = displaceVec (vec (-m) (-m)) pt+        br = displaceH w bl+        tr = displaceV h br+        tl = displaceV h bl+    in vertexPP [bl, br, tr, tl] >>= closedStroke+

@@ -0,0 +1,31 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Import shim for @Wumpus.Basic.Geometry@ modules.+--+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Geometry+  (+    module Wumpus.Basic.Geometry.Base+  , module Wumpus.Basic.Geometry.Intersection+  , module Wumpus.Basic.Geometry.Paths+  , module Wumpus.Basic.Geometry.Quadrant++  ) where+++import Wumpus.Basic.Geometry.Base+import Wumpus.Basic.Geometry.Intersection+import Wumpus.Basic.Geometry.Paths+import Wumpus.Basic.Geometry.Quadrant

@@ -1,4 +1,3 @@-{-# LANGUAGE TypeFamilies               #-} {-# OPTIONS -Wall #-}  --------------------------------------------------------------------------------@@ -19,7 +18,8 @@   (     -- * constants-    half_pi+    quarter_pi+  , half_pi   , two_pi    -- * 2x2 Matrix@@ -75,13 +75,18 @@   -half_pi :: Floating u => u-half_pi = 0.5*pi -two_pi  :: Floating u => u-two_pi  = 2*pi +quarter_pi      :: Floating u => u+quarter_pi      = 0.25 * pi +half_pi         :: Floating u => u+half_pi         = 0.5 * pi++two_pi          :: Floating u => u+two_pi          = 2.0 * pi++ -------------------------------------------------------------------------------- -- 2x2 matrix @@ -99,9 +104,7 @@ 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) @@ -166,7 +169,6 @@  type DLineEquation = LineEquation Double -type instance DUnit (LineEquation u) = u  -- | 'lineEquation' : @ point1 * point2 -> LineEquation @ -- @@ -230,7 +232,6 @@  type DLineSegment = LineSegment Double -type instance DUnit (LineSegment u) = u   @@ -276,7 +277,6 @@  type DBezierCurve = BezierCurve Double -type instance DUnit (BezierCurve u) = u   @@ -291,9 +291,9 @@ -- The result is found through repeated subdivision so the  -- calculation is potentially costly. ---bezierLength :: (Floating u, Ord u, FromPtSize u)      +bezierLength :: (Floating u, Ord u, Tolerance u)              => BezierCurve u -> u-bezierLength = gravesenLength (fromPtSize 0.1)+bezierLength = gravesenLength length_tolerance    @@ -408,7 +408,7 @@ -- > ang should be in the range 0 < ang <= 90deg. -- bezierMinorArc :: Floating u -                 => Radian -> u -> Radian -> Point2 u -> BezierCurve 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)

@@ -20,16 +20,13 @@ module Wumpus.Basic.Geometry.Intersection   (  -    LineSegment-  , interLineLine+    interLineLine   , interLinesegLineseg   , interLinesegLine   , interCurveLine    , findIntersect   , makePlane-  , rectangleLineSegments-  , polygonLineSegments     ) @@ -85,7 +82,7 @@ -- An answer of @Nothing@ indicates that the line segments  -- coincide, or that there is no intersection. ---interLinesegLineseg :: (Fractional u, Ord u, FromPtSize u)+interLinesegLineseg :: (Fractional u, Ord u, Tolerance u)                     => LineSegment u -> LineSegment u -> Maybe (Point2 u) interLinesegLineseg a@(LineSegment p q) b@(LineSegment s t) =      interLineLine (p,q) (s,t) >>= segcheck@@ -101,7 +98,7 @@ -- 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)+interLinesegLine :: (Fractional u, Ord u, Tolerance u)                  => LineSegment u -> (Point2 u, Point2 u) -> Maybe (Point2 u) interLinesegLine a@(LineSegment p q) line =      interLineLine (p,q) line >>= segcheck@@ -117,30 +114,28 @@ -- 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 :: (Ord u, Fractional u, Tolerance 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 -+pve :: (Fractional u, Ord u, Tolerance u) => u -> Bool+pve a = a > eq_tolerance +nve :: (Fractional u, Ord u, Tolerance u) => u -> Bool+nve a = a < (negate eq_tolerance)    -------------------------------------------------------------------------------- -- intersection of line and Bezier curve -interCurveLine :: (Floating u , Ord u, FromPtSize u)+interCurveLine :: (Floating u , Ord u, Tolerance u)                => BezierCurve u -> (Point2 u, Point2 u) -> Maybe (Point2 u) interCurveLine c0 (p,q) = step c0   where@@ -159,16 +154,13 @@ -- as it saves performing a subdivision. But make the return type -- a bit involved. ---cut :: (Floating u , Ord u, FromPtSize u)+cut :: (Floating u , Ord u, Tolerance 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 @@ -190,9 +182,9 @@ -- 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 :: (Floating u, Real u, Ord u, Tolerance u)+              => Point2 u -> Radian -> [LineSegment u] +              -> Maybe (Point2 u) findIntersect radial_ogin ang = step    where     plane       = makePlane radial_ogin ang

@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies               #-} {-# OPTIONS -Wall #-}  --------------------------------------------------------------------------------@@ -18,7 +19,24 @@  module Wumpus.Basic.Geometry.Paths   ( -    LocCoordPath++    PathAlg+  , runPathAlgPoint+  , runPathAlgVec+  , pathStartIsStart+  , pathStartIsLocus+  , pathIterateLocus++  , rectanglePathAlg+  , blRectanglePathAlg++  , diamondPathAlg+  , polygonPathAlg++  , arcPathAlg+  , circlePathAlg++  , LocCoordPath   , coordinatePrimPath    , rectangleCoordPath@@ -31,14 +49,202 @@   )    where +import Wumpus.Basic.Geometry.Base+import Wumpus.Basic.Kernel+ import Wumpus.Core                              -- package: wumpus-core  import Data.AffineSpace                         -- package: vector-space-+import Data.VectorSpace  import Data.List ( unfoldr )  +data PathAlgScheme = START_IS_START | START_IS_LOCUS +  deriving (Enum,Eq,Ord,Show)+++-- | A vector chain building a path.+--+-- The vectors are relative to the predecessor, so the+-- rendering of a 'PathAlg' iterates the start point.+--+-- A polygon PathAlg should have steps for all sides of the +-- polygon with the end point generated by the last vector +-- coinciding with thet start point.+-- +data PathAlg u = PathAlg { path_alg_scheme  :: PathAlgScheme+                         , path_alg_steps   :: [Vec2 u]+                         }+++type instance DUnit (PathAlg u) = u++runPathAlgPoint :: Num u => Point2 u -> PathAlg u -> [Point2 u]+runPathAlgPoint _  (PathAlg _   [])       = []+runPathAlgPoint p0 (PathAlg scm (v0:xs)) +    | scm == START_IS_START = p0 : step (p0 .+^ v0) xs+    | otherwise             = step (p0 .+^ v0) xs+  where+    step pt []      = [pt]+    step pt (v:vs)  = pt : step (pt .+^ v) vs+++runPathAlgVec :: PathAlg u -> (Maybe (Vec2 u), [Vec2 u]) +runPathAlgVec (PathAlg START_IS_LOCUS (v:vs)) = (Just v, vs)+runPathAlgVec (PathAlg _ vs)                  = (Nothing, vs)++++-- TO CLARIFY - should all four side paths of a rectangle be +-- generated, or three sides with the implication that close forms+-- the fourth?+--++pathStartIsStart :: [Vec2 u] -> PathAlg u+pathStartIsStart vs = PathAlg { path_alg_scheme = START_IS_START+                              , path_alg_steps  = vs }++++pathStartIsLocus :: [Vec2 u] -> PathAlg u+pathStartIsLocus vs = PathAlg { path_alg_scheme = START_IS_LOCUS+                              , path_alg_steps  = vs }++-- | Note this creates a path very the first vector represents a+-- @moveto@, then the subsequence vectors represent @linetos@.+-- +pathIterateLocus :: Num u => [Vec2 u] -> PathAlg u+pathIterateLocus []      = pathStartIsLocus []+pathIterateLocus (v0:xs) = pathStartIsLocus $ v0 : step v0 xs+  where+    step v1 []      = [v0 ^-^ v1]+    step v1 (v2:vs) = (v2 ^-^ v1) : step v2 vs+++++-- | Supplied point is /center/, the genearated points are +-- counter-clockwise so [ bl, br, tr, tl ] .+--+rectanglePathAlg :: Fractional u => u -> u -> PathAlg u+rectanglePathAlg w h = pathStartIsLocus [ vbl, vbr, vtr, vtl ]+  where+    vbl = vec (negate $ 0.5*w) (negate $ 0.5*h)+    vbr = hvec w+    vtr = vvec h+    vtl = hvec (-w) ++-- | Supplied point is /bottom-left/, subsequent points are +-- counter-clockwise so [ bl, br, tr, tl ] .+--+blRectanglePathAlg :: Num u => u -> u -> PathAlg u+blRectanglePathAlg w h = pathStartIsStart [ vbr, vtr, vtl, vbl ]+  where+    vbr = hvec w+    vtr = vvec h+    vtl = hvec (-w) +    vbl = vvec (-h)+++++-- | 'diamondPathAlg' : @ half_width * half_height -> PathAlg @+--+diamondPathAlg :: Num u => u -> u -> PathAlg u+diamondPathAlg hw hh = pathIterateLocus [ vs,ve,vn,vw ]+  where+    vs = vvec (-hh)+    ve = hvec hw+    vn = vvec hh+    vw = hvec (-hw)+    ++-- | 'polygonPathAlg' : @ num_points * radius -> PathAlg @ +--+polygonPathAlg :: Floating u => Int -> u -> PathAlg u+polygonPathAlg n radius = pathIterateLocus $ unfoldr phi (0,top)+  where+    top                     = 0.5*pi+    theta                   = (2*pi) / fromIntegral n+    +    phi (i,ang) | i < n     = Just (avec ang radius, (i+1,ang+theta))+                | otherwise = Nothing+++arcPathAlg :: Floating u => u -> Radian -> Radian -> PathAlg u+arcPathAlg r ang1 ang2 = pathStartIsLocus $ step1 $ arcdiv ang1 ang2+  where+    step1 []         = []+    step1 ((a,b):xs) = let (v0,v1,v2,v3) = minorArcQuadVec r a b+                       in v0 : v1: v2: v3 : step xs++    step []         = []+    step ((a,b):xs)  = let (_,v1,v2,v3) = minorArcQuadVec r a b+                       in v1: v2: v3 : step xs+++    +-- | Helper - generate four vectors building a minor (<90 deg) +-- arc.+--+-- The first vec is from center - for cumulative arcs this should +-- only taken once.+--+minorArcQuadVec :: Floating u +                => u -> Radian -> Radian -> (Vec2 u, Vec2 u, Vec2 u, Vec2 u)+minorArcQuadVec r ang1 ang2 = (v0, v1, v2, v3)+  where+    (p1,p2,p3,p4) = bezierArc r ang1 ang2 zeroPt+    v0            = pvec zeroPt p1 +    v1            = pvec p1 p2+    v2            = pvec p2 p3+    v3            = pvec p3 p4+++circlePathAlg :: (Fractional u, Floating u) +              => u -> PathAlg u+circlePathAlg r = pathStartIsLocus vs+  where+    vs = hvec r : diff (flip pvec) (bezierCircle r zeroPt)+++++-- | Helper - diff +-- +-- Note diff relies on the pointlist cycling the endpoint+-- +-- > [p0, ..., p0]+--+-- This is how Wumpus-Core generates Bezier circles.+-- +diff :: (a -> a -> b) -> [a] -> [b]+diff _  [] = []+diff op (x:xs) = step x xs+  where+    step _ []     = []+    step a (b:bs) = b `op` a : step b bs++-- | Helper - divide an arc into quadrants plus remainder.+--+arcdiv :: Radian -> Radian -> [(Radian,Radian)]+arcdiv ang1 ang2 | ang1 >  ang2 = step ang1 (ang2 + 2 * pi) +                 | otherwise    = step ang1 ang2+  where+    step a1 a2 | a1 == a2 = []+    step a1 a2 | a2 - a1 > half_pi = norm (a1,a1+half_pi) : step (a1+half_pi) a2+               | otherwise         = [(a1,a2)]++    norm (a,b) = (circularModulo a, circularModulo b)++++-- arcs - wedges - circles...++---------------------------------------------------------------------------+-- OLD ...+ -- | A functional type from /initial point/ to point list. -- type LocCoordPath u = Point2 u -> [Point2 u]@@ -51,17 +257,16 @@ -- 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+-- | Relative unit version of 'coordinatePrimPathAU'.+--+coordinatePrimPath :: InterpretUnit u +                   => LocCoordPath u -> Point2 u -> Query PrimPath+coordinatePrimPath fn pt = vertexPP $ fn pt  --- NOTE - These functions need changing to generate LocCoordPaths...  -- | Supplied point is /bottom-left/, subsequenct points are --- counter-clockise so [ bl, br, tr, tl ] .+-- counter-clockwise so [ bl, br, tr, tl ] . -- rectangleCoordPath :: Num u => u -> u -> LocCoordPath u rectangleCoordPath w h bl = [ bl, br, tr, tl ]

@@ -17,43 +17,54 @@  module Wumpus.Basic.Kernel   (-    module Wumpus.Basic.Kernel.Base.Anchors-  , module Wumpus.Basic.Kernel.Base.BaseDefs+    module Wumpus.Basic.Kernel.Base.BaseDefs   , module Wumpus.Basic.Kernel.Base.ContextFun   , module Wumpus.Basic.Kernel.Base.DrawingContext-  , module Wumpus.Basic.Kernel.Base.GlyphMetrics+  , module Wumpus.Basic.Kernel.Base.FontSupport   , module Wumpus.Basic.Kernel.Base.QueryDC-  , module Wumpus.Basic.Kernel.Base.ScalingContext+  , module Wumpus.Basic.Kernel.Base.Units   , module Wumpus.Basic.Kernel.Base.UpdateDC   , module Wumpus.Basic.Kernel.Base.WrappedPrimitive-  , module Wumpus.Basic.Kernel.Objects.AdvanceGraphic-  , module Wumpus.Basic.Kernel.Objects.BaseObjects+  , module Wumpus.Basic.Kernel.Objects.AdvObject+  , module Wumpus.Basic.Kernel.Objects.Anchors+  , module Wumpus.Basic.Kernel.Objects.Basis   , module Wumpus.Basic.Kernel.Objects.Bounded+  , module Wumpus.Basic.Kernel.Objects.Chain+  , module Wumpus.Basic.Kernel.Objects.Concat   , 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.Image+  , module Wumpus.Basic.Kernel.Objects.LocImage+  , module Wumpus.Basic.Kernel.Objects.LocThetaImage+  , module Wumpus.Basic.Kernel.Objects.Orientation+  , module Wumpus.Basic.Kernel.Objects.PosObject   , module Wumpus.Basic.Kernel.Objects.TraceDrawing+   ) where -import Wumpus.Basic.Kernel.Base.Anchors import Wumpus.Basic.Kernel.Base.BaseDefs import Wumpus.Basic.Kernel.Base.ContextFun import Wumpus.Basic.Kernel.Base.DrawingContext-import Wumpus.Basic.Kernel.Base.GlyphMetrics+import Wumpus.Basic.Kernel.Base.FontSupport import Wumpus.Basic.Kernel.Base.QueryDC-import Wumpus.Basic.Kernel.Base.ScalingContext+import Wumpus.Basic.Kernel.Base.Units  import Wumpus.Basic.Kernel.Base.UpdateDC import Wumpus.Basic.Kernel.Base.WrappedPrimitive-import Wumpus.Basic.Kernel.Objects.AdvanceGraphic-import Wumpus.Basic.Kernel.Objects.BaseObjects+import Wumpus.Basic.Kernel.Objects.AdvObject+import Wumpus.Basic.Kernel.Objects.Anchors+import Wumpus.Basic.Kernel.Objects.Basis import Wumpus.Basic.Kernel.Objects.Bounded+import Wumpus.Basic.Kernel.Objects.Chain+import Wumpus.Basic.Kernel.Objects.Concat 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.Image+import Wumpus.Basic.Kernel.Objects.LocImage+import Wumpus.Basic.Kernel.Objects.LocThetaImage+import Wumpus.Basic.Kernel.Objects.Orientation+import Wumpus.Basic.Kernel.Objects.PosObject import Wumpus.Basic.Kernel.Objects.TraceDrawing

@@ -1,222 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Kernel.Base.Anchors--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Anchor points on shapes, bounding boxes, etc.------ Anchors are addressable positions, an examplary use is taking--- anchors on node shapes to get the start and end points for --- connectors in a network (graph) diagram.--- --- \*\* 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-  ( --  -- * Anchors-    CenterAnchor(..)-  , ApexAnchor(..)-  , CardinalAnchor(..)-  , CardinalAnchor2(..)-  , RadialAnchor(..)-  , TopCornerAnchor(..)-  , BottomCornerAnchor(..)-  , SideMidpointAnchor(..)---  -- * Extended anchor points-  , projectAnchor--  , radialConnectorPoints--  ) where--import Wumpus.Core                      -- package: wumpus-core--import Data.AffineSpace                 -- package: vector-space----- | Center of an object.----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--- equivalent radial position, for instance reactangle north-east--- is the top-right corner whether or not this is incident at --- 45deg.------ Wumpus generally follows the TikZ convention.----class CardinalAnchor t where-  north :: DUnit t ~ u => t -> Point2 u-  south :: DUnit t ~ u => t -> Point2 u-  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 --- problematic, hence the compass points are split into two --- classes.----class CardinalAnchor2 t where-  northeast :: DUnit t ~ u => t -> Point2 u-  southeast :: DUnit t ~ u => t -> Point2 u-  southwest :: DUnit t ~ u => t -> Point2 u-  northwest :: DUnit t ~ u => t -> Point2 u----- | Anchor on a border that can be addressed by an angle.------ The angle is counter-clockwise from the right-horizontal, i.e.--- 0 is /east/.----class RadialAnchor t where-  radialAnchor :: DUnit t ~ u => Radian -> t -> Point2 u----- | Anchors at the top left and right corners of a shape.------ 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...----class TopCornerAnchor t where-  topLeftCorner  :: DUnit t ~ u => t -> Point2 u-  topRightCorner :: DUnit t ~ u => t -> Point2 u----- | Anchors at the bottom left and right corners of a shape.----class BottomCornerAnchor t where-  bottomLeftCorner  :: DUnit t ~ u => t -> Point2 u-  bottomRightCorner :: DUnit t ~ u => t -> Point2 u----- | Anchors in the center of a side.--- --- 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.--- --- Implementations are also expected to modulo the side number, --- rather than throw an out-of-bounds error.----class SideMidpointAnchor t where-  sideMidpoint :: DUnit t ~ u => Int -> t -> Point2 u---------------------------------------------------------------------------------------- | 'projectAnchor' : @ extract_func * 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@.--- --- E.g. take the north of a rectangle and project it 10 units --- further on:---  --- > projectAnchor north 10 my_rect------ If the distance is zero the answer with be whatever point the --- the extraction function produces.------ 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-     --------------------------------------------------------------------------------------- | 'radialConnectorPoints' : @ object_a * object_b -> (Point_a, Point_b) @------ Find the radial connectors points for objects @a@ and @b@ along--- the line joining their centers.----radialConnectorPoints :: ( Real u, Floating u-                         , CenterAnchor t1, RadialAnchor t1-                         , CenterAnchor t2, RadialAnchor t2-                         , u ~ DUnit t1, DUnit t1 ~ DUnit t2 ) -                      => t1 -> t2 -> (Point2 u, Point2 u) -radialConnectorPoints a b = (radialAnchor theta a, radialAnchor (theta+pi) b)-  where-    theta = vdirection $ pvec (center a) (center b)-    ------------------------------------------------------------------------------------- Instances --instance Fractional u => CenterAnchor (BoundingBox u) where-  center (BBox (P2 xl ylo) (P2 xr yhi)) = P2 x y -     where-       x = xl+0.5*(xr-xl)-       y = ylo+0.5*(yhi-ylo)-       --instance Fractional u => CardinalAnchor (BoundingBox u) where-  north (BBox (P2 xl _  ) (P2 xr yhi)) = P2 (xl+0.5*(xr-xl)) yhi-  south (BBox (P2 xl ylo) (P2 xr _  )) = P2 (xl+0.5*(xr-xl)) ylo-  east  (BBox (P2 _  ylo) (P2 xr yhi)) = P2 xr (ylo+0.5*(yhi-ylo))-  west  (BBox (P2 xl ylo) (P2 _  yhi)) = P2 xl (ylo+0.5*(yhi-ylo))---instance Fractional u => CardinalAnchor2 (BoundingBox u) where-  northeast (BBox _ ur)                 = ur-  southeast (BBox (P2 _ ylo) (P2 xr _)) = P2 xr ylo-  southwest (BBox ll _)                 = ll-  northwest (BBox (P2 xl _) (P2 _ yhi)) = P2 xl yhi -

@@ -1,13 +1,10 @@ {-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeSynonymInstances       #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE FlexibleContexts           #-} {-# OPTIONS -Wall #-}  -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.Kernal.Base.BaseDefs--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2010-2011 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com@@ -21,16 +18,35 @@  module Wumpus.Basic.Kernel.Base.BaseDefs   (+  +    MonUnit     -- * A semigroup class-    OPlus(..)+  , OPlus(..)   , oconcat+  , altconcat +   -- * A bifunctor class   , Bimap(..)   , replaceL   , replaceR +  -- * Unit phantom type+  , UNil(..)++  -- * Non-contextual unit conversion.+  , ScalarUnit(..)++  -- * Unit interpretation with respect to the current Point size+  , InterpretUnit(..)+  , dinterpF+  , normalizeF+  , uconvert1+  , uconvertF+  , intraMapPoint+  , intraMapFunctor+   -- * Alignment   , HAlign(..)   , VAlign(..)  @@ -43,18 +59,29 @@   , advanceH   , advanceV --  -- * Monadic drawing-  , MonUnit--  , PointSupplyM(..)-   ) where  import Wumpus.Core                              -- package: wumpus-core  import Data.VectorSpace                         -- package: vector-space +import Control.Applicative+import Data.Monoid++++++-- | Type family to access the unit parameter of a TraceDrawing+-- or a promoted TraceDrawingT transformer.+--+type family MonUnit m :: *++++++ infixr 6 `oplus`  -- | A Semigroup class.@@ -66,6 +93,17 @@ class OPlus t where   oplus :: t -> t -> t +-- | 'oconcat' : @ list_head * [rest] -> Ans @+-- +-- Semigroup version of @mconcat@ from the module @Data.Monoid@.+--+-- As a semigroup cannot build a zero value, /concat/ cannot +-- handle the empty list. So to make 'oconcat' a safe function+-- the input list is already destructured by one cons cell.+-- +-- Effectively this means that client code must handle the +-- empty list case, before calling 'oconcat'.+--  oconcat :: OPlus t => t -> [t] -> t oconcat t = step t   where@@ -74,16 +112,35 @@   +-- | 'altconcat' : @ alternative * [list] -> Ans@+-- +-- 'altconcat' uses 'oplus' to create a summary value from a list+-- of values. +--+-- When supplied the empty list 'altconcat' returns the supplied +-- /alternative/ value. If the list is inhabited, the alternative+-- value is discarded.+--+-- This contrasts to 'oconcat' where the single value represents +-- the head of an already destructured list.+-- +altconcat :: OPlus a => a -> [a] -> a+altconcat _   (x:xs) = oconcat x xs+altconcat alt []     = alt++ instance OPlus () where   _ `oplus` _ = () -instance OPlus (UNil u) where-  _ `oplus` _ = uNil +instance OPlus a => OPlus (Const a b) where+  Const a0 `oplus` Const a1 = Const $ a0 `oplus` a1 ++ instance Ord u => OPlus (BoundingBox u) where   oplus = boundaryUnion -instance OPlus (Primitive u) where+instance OPlus Primitive where   a `oplus` b = primGroup [a,b]  instance (OPlus a, OPlus b) => OPlus (a,b) where@@ -144,7 +201,129 @@   --------------------------------------------------------------------------------+-- Simple objects wrapped with unit phatom type  ++-- | The empty data type - i.e. @()@ - wrapped with a phantom unit +-- parameter.+--+data UNil   u = UNil          deriving (Eq,Ord,Read,Show)++type instance DUnit (UNil u) = u++instance Functor UNil where+  fmap _ UNil= UNil+++instance Monoid (UNil u) where+  mempty        = UNil+  _ `mappend` _ = UNil++instance OPlus (UNil u) where+  _ `oplus` _ = UNil+++++instance Rotate (UNil u) where+  rotate _              = id++instance RotateAbout (UNil u) where+  rotateAbout _ _       = id++instance Scale (UNil u) where+  scale _ _             = id++instance Translate (UNil u) where+  translate _ _         = id++--------------------------------------------------------------------------------+-- Non-contextual units++class ScalarUnit a where+  fromPsPoint :: Double -> a +  toPsPoint   :: a -> Double++instance ScalarUnit Double where+  fromPsPoint = id+  toPsPoint   = id ++++--------------------------------------------------------------------------------+-- Interpreting units ++-- Units may or may not depend on current font size+--++class Num u => InterpretUnit u where+  normalize :: FontSize -> u -> Double+  dinterp   :: FontSize -> Double -> u++instance InterpretUnit Double where+  normalize _ = id+  dinterp   _ = id ++instance InterpretUnit AfmUnit where+  normalize sz = afmValue sz +  dinterp   sz = afmUnit sz+++-- | 'dinterp' an object that gives access to its unit at the +-- functor position.+--+dinterpF :: (Functor t, InterpretUnit u) => FontSize -> t Double -> t u+dinterpF sz = fmap (dinterp sz)+++-- | 'normalize' an object that gives access to its unit at the +-- functor position.+--+normalizeF :: (Functor t, InterpretUnit u) => FontSize -> t u -> t Double+normalizeF sz = fmap (normalize sz)+++-- | Convert a scalar value from one unit to another.+--+uconvert1 :: (InterpretUnit u, InterpretUnit u1) => FontSize -> u -> u1+uconvert1 sz = dinterp sz . normalize sz++-- | Unit convert an object that gives access to its unit at the+-- Functor position.+--+-- In practive this will be \*all\* Image answers.+--+uconvertF :: (Functor t, InterpretUnit u, InterpretUnit u1) +          => FontSize -> t u -> t u1+uconvertF sz = fmap (uconvert1 sz)++++-- Helper for defining Affine instances. This function allows +-- scaling etc to be applied on a Point coerced to a Double then+-- converted back to the original unit. Thus transformations can +-- work in contextual units.+--+intraMapPoint :: InterpretUnit u +              => FontSize -> (DPoint2 -> DPoint2) -> Point2 u -> Point2 u+intraMapPoint sz fn (P2 x y) = +    let P2 x' y' = fn $ P2 (normalize sz x) (normalize sz y)+    in  P2 (dinterp sz x') (dinterp sz y')++++-- Helper for defining Affine instances. This function allows +-- scaling etc to be applied on a Point coerced to a Double then+-- converted back to the original unit. Thus transformations can +-- work in contextual units.+--+intraMapFunctor :: (Functor f, InterpretUnit u)+                => FontSize -> (f Double -> f Double) -> f u -> f u+intraMapFunctor sz fn ma = dinterpF sz $ fn $ normalizeF sz ma+++--------------------------------------------------------------------------------+ -- Alignment  -- | Horizontal alignment - align to the top, center or bottom.@@ -195,22 +374,3 @@ advanceV (V2 _ h)  = h  -------------------------------------------------------------------------------------- Monadic drawing---- | DUnit is always for fully saturated type constructors, so --- (seemingly) an equivalent type family is needed for monads.--type family MonUnit m :: * ----- | A monad that supplies points, e.g. a turtle monad. ------ \*\* WARNING \*\* - the idea behind this class is somewhat--- half-baked. It may be revised or even dropped in subsequent--- versions of Wumpus-Basic.----class Monad m => PointSupplyM (m :: * -> *) where-  position :: MonUnit m ~ u => m (Point2 u)

@@ -1,9 +1,11 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleInstances          #-} {-# OPTIONS -Wall #-}  -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.Kernel.Base.ContextFun--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2010-2011 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com@@ -18,57 +20,42 @@ module Wumpus.Basic.Kernel.Base.ContextFun   ( -  -- * /Context functional/ types+  -- * /Context functional/ type     CF     -  , CF1-  , CF2 -  , LocCF-  , LocThetaCF-  , ConnectorCF-  , DLocCF-  , DLocThetaCF-  , DConnectorCF+  -- * Alias+  , Query +  -- * Run function+  , runCF +  -- * Construction+  , consCF -  -- * Run functions-  , runCF-  , runCF1 -  , runCF2+  , domMap1+  , domMap2 -  -- * Lift functions-  , lift0R1-  , lift0R2-  , lift1R2-    , promoteR1   , promoteR2 +  , pushR0+  , pushR1+  , pushR2    , apply1R1-  , apply2R2   , apply1R2+  , apply2R2 -  -- * Extractors-  , drawingCtx-  , queryCtx-  , locCtx-  , locPoint-  , locThetaCtx-  , locThetaPoint-  , locThetaAng-  , connCtx-  , connStart-  , connEnd+  , lift0R1+  , lift0R2+  , lift1R2 -  -- * Combinators-  , at-  , rot-  , atRot-  , connect-  , chain1+  , uconvR0+  , uconvR1+  , uconvR2a+  , uconvR2ab +  , drawingCtx    ) where @@ -85,6 +72,9 @@ -------------------------------------------------------------------------------- -- +-- NOTE - 31.03.11 - is there an advantage to adding a phantom+-- unit param to the CF functions?+ -- | Most drawing operations in Wumpus-Basic have an implicit  -- /graphics state/ the 'DrawingContext', so the most primitive  -- building block is a function from the DrawingContext to some @@ -95,121 +85,46 @@ --  -- > CF :: DrawingContext -> a  ---newtype CF a            = CF  { unCF :: DrawingContext -> a }+newtype CF a            = CF  { getCF :: DrawingContext -> a } +type instance DUnit (CF a) = DUnit a --- | Variation of 'CF' with one parametric /static argument/.------ The static argument is commonly a point representing the start --- point / origin of a drawing.--- --- > CF1 :: DrawingContext -> r1 -> a ----newtype CF1 r1 a        = CF1 { unCF1 :: DrawingContext -> r1 -> a }  --- | Variation of 'CF' with two parametric /static arguments/.------ The first argument is commonly a point representing the start --- point / origin of a drawing. The second argument might --- typically be the angle of displacement (for drawing arrowheads) --- or an end point (for drawing connectors between two points).+-- | Alias for 'CF'. Wumpus considers Context functions that+-- don\'t produce graphics to be /queries/. -- --- > CF2 :: DrawingContext -> r1 -> r2 -> a +-- > Query :: DrawingContext -> a  ---newtype CF2 r1 r2 a     = CF2 { unCF2 :: DrawingContext -> r1 -> r2 -> a }-+-- 'Query' has no unit type parameter.+-- +type Query a            = CF a   --- | Type specialized verison of 'CF1' where the /static argument/--- is the /start point/.--- --- > LocCF :: DrawingContext -> Point2 u -> a ----type LocCF          u a = CF1 (Point2 u) a  --- | Type specialized verison of 'CF2' where the /static arguments/--- are the /start point/ and the /angle of displacement/.--- --- > LocThetaCF :: DrawingContext -> Point2 u -> Radian -> a ----type LocThetaCF     u a = CF2 (Point2 u) Radian a  --- | Type specialized verison of 'CF2' where the /static arguments/--- are the /start point/ and the /end point/.--- --- > ConnectorCF :: DrawingContext -> Point2 u -> Point2 u -> a ----type ConnectorCF    u a = CF2 (Point2 u) (Point2 u) a----- | Alias of 'LocCF' where the unit type is specialized to --- @Double@.----type DLocCF a           = LocCF       Double a----- | Alias of 'LocThetaCF' where the unit type is specialized to --- @Double@.----type DLocThetaCF a      = LocThetaCF  Double a---- | Alias of 'ConnectorCF' where the unit type is specialized to --- @Double@.----type DConnectorCF a     = ConnectorCF Double a--- -------------------------------------------------------------------------------- -- CF instances  -- OPlus  instance OPlus a => OPlus (CF a)  where-  fa `oplus` fb = CF $ \ctx -> unCF fa ctx `oplus` unCF fb ctx--instance OPlus a => OPlus (CF1 r1 a)  where-  fa `oplus` fb = CF1 $ \ctx r1 -> unCF1 fa ctx r1 `oplus` unCF1 fb ctx r1--instance OPlus a => OPlus (CF2 r1 r2 a)  where-  fa `oplus` fb = CF2 $ \ctx r1 r2 -> -                          unCF2 fa ctx r1 r2 `oplus` unCF2 fb ctx r1 r2+  fa `oplus` fb = CF $ \ctx -> getCF fa ctx `oplus` getCF fb ctx   -- Monoid  --- Nothing is stopping monoid instances, though in practice there--- might be few useful types (more in Semgigroup / OPlus)...- instance Monoid a => Monoid (CF a) where    mempty          = CF $ \_   -> mempty-  fa `mappend` fb = CF $ \ctx -> unCF fa ctx `mappend` unCF fb ctx--instance Monoid a => Monoid (CF1 r1 a) where -  mempty          = CF1 $ \_   _  -> mempty-  fa `mappend` fb = CF1 $ \ctx r1 -> unCF1 fa ctx r1 `mappend` unCF1 fb ctx r1--instance Monoid a => Monoid (CF2 r1 r2 a) where -  mempty          = CF2 $ \_   _  _  -> mempty-  fa `mappend` fb = CF2 $ \ctx r1 r2 -> -                            unCF2 fa ctx r1 r2 `mappend` unCF2 fb ctx r1 r2-+  fa `mappend` fb = CF $ \ctx -> getCF fa ctx `mappend` getCF fb ctx   -- Functor  instance Functor CF where-  fmap f ma = CF $ \ctx -> f $ unCF ma ctx ---instance Functor (CF1 r1) where-  fmap f ma = CF1 $ \ctx r1 -> f $ unCF1 ma ctx r1 --instance Functor (CF2 r1 r2) where-  fmap f ma = CF2 $ \ctx r1 r2 -> f $ unCF2 ma ctx r1 r2+  fmap f ma = CF $ \ctx -> f $ getCF ma ctx    @@ -217,69 +132,46 @@  instance Applicative CF where   pure a    = CF $ \_   -> a-  mf <*> ma = CF $ \ctx -> let f = unCF mf ctx-                               a = unCF ma ctx+  mf <*> ma = CF $ \ctx -> let f = getCF mf ctx+                               a = getCF ma ctx                            in f a  -instance Applicative (CF1 r1) where-  pure a    = CF1 $ \_   _  -> a-  mf <*> ma = CF1 $ \ctx r1 -> let f = unCF1 mf ctx r1 -                                   a = unCF1 ma ctx r1-                               in f a --instance Applicative (CF2 r1 r2) where-  pure a    = CF2 $ \_   _  _  -> a-  mf <*> ma = CF2 $ \ctx r1 r2 -> let f = unCF2 mf ctx r1 r2-                                      a = unCF2 ma ctx r1 r2-                                  in f a---- -- Monad   instance Monad CF where   return a  = CF $ \_   -> a-  ma >>= k  = CF $ \ctx -> let a = unCF ma ctx in (unCF . k) a ctx --instance Monad (CF1 r1) where-  return a  = CF1 $ \_   _  -> a-  ma >>= k  = CF1 $ \ctx r1 -> let a = unCF1 ma ctx  r1 in (unCF1 . k) a ctx r1 --instance Monad (CF2 r1 r2) where-  return a  = CF2 $ \_   _  _  -> a-  ma >>= k  = CF2 $ \ctx r1 r2 -> -                      let a = unCF2 ma ctx r1 r2 in (unCF2 . k) a ctx r1 r2-+  ma >>= k  = CF $ \ctx -> let a = getCF ma ctx in (getCF . k) a ctx    -- DrawingCtxM   instance DrawingCtxM CF where   askDC           = CF $ \ctx -> ctx-  localize upd df = CF $ \ctx -> unCF df (upd ctx)+  localize upd df = CF $ \ctx -> getCF df (upd ctx)    -instance DrawingCtxM (CF1 r1) where-  askDC           = CF1 $ \ctx _  -> ctx-  localize upd df = CF1 $ \ctx r1 -> unCF1 df (upd ctx) r1 +--------------------------------------------------------------------------------+-- Affine instances -instance DrawingCtxM (CF2 r1 r2) where-  askDC           = CF2 $ \ctx _  _  -> ctx-  localize upd df = CF2 $ \ctx r1 r2 -> unCF2 df (upd ctx) r1 r2  --- Note - there is nothing determining a DUnit for the CF types, --- so it seems appropriate not to define affine instances.------ However affine instances can be made for the Image type in --- Objects.BaseObjects.---+instance Rotate a => Rotate (CF a) where+  rotate ang            = fmap (rotate ang) +instance RotateAbout a => RotateAbout (CF a) where+  rotateAbout ang pt    = fmap (rotateAbout ang pt) +instance Scale a => Scale (CF a) where+  scale sx sy           = fmap (scale sx sy)++instance Translate a => Translate (CF a) where+  translate dx dy       = fmap (translate dx dy)+++ -------------------------------------------------------------------------------- -- Run functions @@ -287,264 +179,127 @@ -- /DrawingContext/. -- runCF :: DrawingContext -> CF a -> a-runCF ctx df = unCF df ctx+runCF ctx cf = getCF cf ctx  --- | Run a /CF1/ (context function) with the supplied --- /DrawingContext/ and static argument.----runCF1 :: DrawingContext -> r1 -> CF1 r1 a -> a-runCF1 ctx r1 df = unCF1 df ctx r1 ---- | Run a /CF1/ (context function) with the supplied --- /DrawingContext/ and two static arguments.+-- | Construction function. ---runCF2 :: DrawingContext -> r1 -> r2 -> CF2 r1 r2 a -> a-runCF2 ctx r1 r2 df = unCF2 df ctx r1 r2+consCF :: (DrawingContext -> a) -> CF a+consCF fn = CF $ \ctx -> fn ctx   ------------------------------------------------------------------------------------ lift functions  --- | Lift a zero-arity context function 'CF' to an arity one --- context function 'CF1'.--- -lift0R1             :: CF a -> CF1 r1 a-lift0R1 mf          = CF1 $ \ctx _ -> unCF mf ctx+domMap1 :: (r1 -> r1) -> CF (r1 -> a) -> CF (r1 -> a)+domMap1 f ma = CF $ \ctx -> +    (\r1 -> let f1 = getCF ma ctx in f1 (f r1)) --- | Lift a zero-arity context function 'CF' to an arity two --- context function 'CF2'.--- -lift0R2             :: CF a -> CF2 r1 r2 a-lift0R2 mf          = CF2 $ \ctx _ _ -> unCF mf ctx+domMap2 :: (r1 -> r1) -> (r2 -> r2) -> CF (r1 -> r2 -> a) -> CF (r1 -> r2 -> a)+domMap2 f g ma = CF $ \ctx -> +    (\r1 r2 -> let f1 = getCF ma ctx in f1 (f r1) (g r2)) --- | Lift an arity one context function 'CF1' to an arity two--- context function 'CF2'.--- -lift1R2             :: CF1 r1 a -> CF2 r1 r2 a-lift1R2 mf          = CF2 $ \ctx r1 _ -> unCF1 mf ctx r1  +promoteR1 :: (r1 -> CF a) -> CF (r1 -> a)+promoteR1 mf = CF $ \ctx r1 -> getCF (mf r1) ctx --- | Promote a function @from one argument to a Context Function@ --- to an arity one @Context Function@.------ The type signature is as explanatory as a description:------ > promoteR1 :: (r1 -> CF a) -> CF1 r1 a--- -promoteR1           :: (r1 -> CF a) -> CF1 r1 a-promoteR1 mf        = CF1 $ \ctx r1 -> unCF (mf r1) ctx+promoteR2 :: (r1 -> r2 -> CF a) -> CF (r1 -> r2 -> a)+promoteR2 mf = CF $ \ctx r1 r2 -> getCF (mf r1 r2) ctx --- | Promote a function @from two arguments to a Context Function@ --- to an arity two @Context Function@.+-- | Apply the value transformer to the answer of the context +-- function. Figuratively /push it right/ so it works on the +-- answer. ----- The type signature is as explanatory as a description:+-- > pushR0 = fmap ----- > promoteR2 :: (r1 -> r2 -> CF a) -> CF2 r1 r2 a--- -promoteR2           :: (r1 -> r2 -> CF a) -> CF2 r1 r2 a-promoteR2 mf        = CF2 $ \ctx r1 r2 -> unCF (mf r1 r2) ctx-+pushR0 :: (a -> a1) -> CF a -> CF a1+pushR0 = fmap  --- | Apply an arity-one Context Function to a single argument, --- downcasting it by one level, making an arity-zero Context --- function. --- --- The type signature is as explanatory as a description:------ > apply1R1 :: CF1 r1 a -> r1 -> CF a+-- | Apply the value transformer to the answer of the context +-- function. Figuratively /push it right/ so it works on the +-- answer. ---apply1R1            :: CF1 r1 a -> r1 -> CF a-apply1R1 mf r1      = CF $ \ctx -> unCF1 mf ctx r1----- | Apply an arity-two Context Function to two arguments, --- downcasting it by two levels, making an arity-zero Context --- function. --- --- The type signature is as explanatory as a description:+-- > pushR1 = fmap . fmap ----- > apply2R2 :: CF2 r1 r2 a -> r1 -> r2 -> CF a--- -apply2R2            :: CF2 r1 r2 a -> r1 -> r2 -> CF a-apply2R2 mf r1 r2   = CF $ \ctx -> unCF2 mf ctx r1 r2+pushR1 :: (a -> a1) -> CF (r1 -> a) -> CF (r1 -> a1)+pushR1 = fmap . fmap --- | Apply an arity-two Context Function to one argument, --- downcasting it by one level, making an arity-one Context --- function. --- --- The type signature is as explanatory as a description:+-- | Apply the value transformer to the answer of the context +-- function. Figuratively /push it right/ so it works on the +-- answer. ----- > apply1R2 :: CF2 r1 r2 a -> r2 -> CF1 r1 a+-- > pushR2 = fmap . fmap . fmap  ---apply1R2            :: CF2 r1 r2 a -> r2 -> CF1 r1 a-apply1R2 mf r2      = CF1 $ \ctx r1 -> unCF2 mf ctx r1 r2+pushR2 :: (a -> a1) -> CF (r1 -> r2 -> a) -> CF (r1 -> r2 -> a1)+pushR2 = fmap . fmap . fmap  ------------------------------------------------------------------------------------ extractors  --- | Extract the drawing context from a CtxFun.------ > (ctx -> ctx)--- -drawingCtx      :: CF DrawingContext-drawingCtx      = CF $ \ctx -> ctx --- | Apply the projection function to the drawing context.------ > (ctx -> a) -> (ctx -> a)----queryCtx        :: (DrawingContext -> a) -> CF a-queryCtx f      = CF $ \ctx -> f ctx+apply1R1 :: CF (r1 -> a) -> r1 -> CF a+apply1R1 mf r1 = CF $ \ctx -> getCF mf ctx r1  --- | Extract the drawing context from a LocCF.------ > (ctx -> pt -> ctx)----locCtx          :: LocCF u DrawingContext-locCtx          = CF1 $ \ctx _  -> ctx+apply1R2 :: CF (r1 -> r2 -> a) -> r2 -> CF (r1 -> a)+apply1R2 mf r2 = CF $ \ctx r1 -> getCF mf ctx r1 r2 --- | Extract the /start/ point from a LocCF.------ > (ctx -> pt -> pt)----locPoint        :: LocCF u (Point2 u)-locPoint        = CF1 $ \_ pt -> pt +apply2R2 :: CF (r1 -> r2 -> a) -> r1 -> r2 -> CF a+apply2R2 mf r1 r2 = CF $ \ctx -> getCF mf ctx r1 r2 --- | Extract the drawing context from a LocThetaCF.------ > (ctx -> pt -> ang -> ctx)----locThetaCtx     :: LocThetaCF u DrawingContext-locThetaCtx     = CF2 $ \ctx _ _ -> ctx +lift0R1             :: CF a -> CF (r1 -> a)+lift0R1 mf          = CF $ \ctx _ -> getCF mf ctx --- | Extract the /start/ point from a LocThetaCF.------ > (ctx -> pt -> ang -> pt)----locThetaPoint   :: LocThetaCF u (Point2 u)-locThetaPoint   = CF2 $ \_ pt _ -> pt+lift0R2             :: CF a -> CF (r1 -> r2 -> a)+lift0R2 mf          = CF $ \ctx _ _ -> getCF mf ctx --- | Extract the angle from a LocThetaCF.------ > (ctx -> pt -> ang -> ang)----locThetaAng     :: LocThetaCF u Radian-locThetaAng     = CF2 $ \_ _ ang -> ang+lift1R2             :: CF (r1 -> a) -> CF (r1 -> r2 -> a)+lift1R2 mf          = CF $ \ctx r1 _ -> getCF mf ctx r1 --- | Extract the drawing context from a ConnectorCF.------ > (ctx -> pt1 -> pt2 -> ctx)----connCtx         :: ConnectorCF u DrawingContext-connCtx         = CF2 $ \ctx _ _ -> ctx --- | Extract the start point from a ConnectorCF.------ > (ctx -> pt1 -> pt2 -> pt1)----connStart       :: ConnectorCF u (Point2 u) -connStart       = CF2 $ \_ pt _ -> pt --- | Extract the end point from a ConnectorCF.------ > (ctx -> pt1 -> pt2 -> pt2)----connEnd         :: ConnectorCF u (Point2 u) -connEnd         = CF2 $ \_ _ pt -> pt +uconvR0 :: (FontSize -> ans -> ans1)  -> CF ans -> CF ans1+uconvR0 post df = CF $ \ctx ->+    let sz = dc_font_size ctx +    in post sz $ getCF df ctx  +uconvR1 :: (Functor t, InterpretUnit u, InterpretUnit u1) +        => (FontSize -> ans -> ans1) +        -> CF (t u -> ans) -> CF (t u1 -> ans1)+uconvR1 post df = CF $ \ctx r1 -> +    let sz = dc_font_size ctx +    in post sz $ getCF df ctx (uconvertF sz r1)  ------------------------------------------------------------------------------------ Combinators+uconvR2a :: (Functor t, InterpretUnit u, InterpretUnit u1) +         => (FontSize -> ans -> ans1)+         -> CF (t u -> r2 -> ans) -> CF (t u1 -> r2 -> ans1)+uconvR2a post df = CF $ \ctx r1 r2 -> +    let sz = dc_font_size ctx +    in post sz $ getCF df ctx (uconvertF sz r1) r2   -infixr 1 `at`----- | Downcast a 'LocCF' function by applying it to the supplied --- point, making an arity-zero Context Function. --- --- Remember a 'LocCF' function is a 'CF1' context function where--- the /static argument/ is specialized to a start point.----at :: LocCF u a -> Point2 u -> CF a-at = apply1R1---infixr 1 `rot`----- | Downcast a 'LocThetaCF' function by applying it to the --- supplied angle, making an arity-one Context Function (a --- 'LocCF'). --- --rot :: LocThetaCF u a -> Radian -> LocCF u a-rot = apply1R2----- | Downcast a 'LocThetaCF' function by applying it to the --- supplied point and angle, making an arity-zero Context --- Function (a 'CF'). ----atRot :: LocThetaCF u a -> Point2 u -> Radian -> CF a-atRot = apply2R2----- | Downcast a 'ConnectorCF' function by applying it to the --- start and end point, making an arity-zero Context Function --- (a 'CF'). --- -connect :: ConnectorCF u a -> Point2 u -> Point2 u -> CF a-connect = apply2R2+uconvR2ab :: (Functor t1, Functor t2, InterpretUnit u, InterpretUnit u1) +          => (FontSize -> ans -> ans1)+          -> CF (t1 u -> t2 u ->  ans) -> CF (t1 u1 -> t2 u1 -> ans1)+uconvR2ab post df = CF $ \ctx r1 r2 -> +    let sz = dc_font_size ctx +    in post sz $ getCF df ctx (uconvertF sz r1) (uconvertF sz r2)   -infixr 6 `chain1`---- | /Chaining/ combinator - the /answer/ of the --- first Context Function is feed to the second Context Function. ------ This contrasts with the usual idiom in @Wumpus-Basic@ where --- composite graphics are built by applying both functions to the --- same initial /static argument/.------ Desciption:------ Evaluate the first Context Function with the drawing context --- and the /initial state/ @st0@. The result of the evaluation is --- a new /state/ @st1@ and and answer @a1@. ------ Evaluate the second Context Function with the drawing context --- and the new state @st1@, producing a new state @s2@ and an --- answer @a2@.------ Return the result of combining the answers with --- @op :: (ans -> ans -> ans)@ and the second state @s2@.------ @ (ctx -> s1 -> (w,s1)) -> (ctx -> s1 -> (w,s1)) -> (ctx -> s1 -> (w,s1)) @+-- | Extract the drawing context from a CtxFun. ----- This models chaining start points together, which is the model--- PostScript uses for text output when successively calling the --- @show@ operator.+-- > (ctx -> ctx) -- -chain1 :: OPlus w -            => CF1 s1 (s1,w) -> CF1 s1 (s1,w) -> CF1 s1 (s1,w)-chain1 f g = CF1 $ \ctx s -> let (s1,a1) = unCF1 f ctx s-                                 (s2,a2) = unCF1 g ctx s1-                             in (s2, a1 `oplus` a2)+drawingCtx      :: Query DrawingContext+drawingCtx      = CF $ \ctx -> ctx  

@@ -4,7 +4,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.Kernel.Base.DrawingContext--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2010-2011 -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>@@ -24,22 +24,24 @@ module Wumpus.Basic.Kernel.Base.DrawingContext   (  -  -- * Drawing context+  -- * Drawing context types     DrawingContext(..)-  , DrawingContextF +  , DrawingContextF   , TextMargin(..)+  , ConnectorProps(..) +  -- * Construction   , standardContext   , metricsContext+  , addFontTables -  , default_drawing_context+  , reset_drawing_properties+  , reset_drawing_metrics    -- * DrawingCtxM (reader) monad   , DrawingCtxM(..)-  , asksDC -   -- * Glyph metrics   , withFontMetrics @@ -47,13 +49,15 @@   ) where  -import Wumpus.Basic.Kernel.Base.GlyphMetrics+import Wumpus.Basic.Kernel.Base.FontSupport+import Wumpus.Basic.Kernel.Base.Units  import Wumpus.Core                              -- package: wumpus-core import Wumpus.Core.Text.StandardEncoding  import Control.Applicative import Data.Maybe+import Data.Monoid  -- | 'DrawingContext' - the \"graphics state\" of Wumpus-Basic.  -- DrawingContext is operated on within a Reader monad rather than @@ -61,29 +65,31 @@ -- operation (called @localize@ in Wumpus), rather than permanent -- until overridden as per @set@ of a State monad. -- --- Note - @round_corner_factor@ is only accounted for by some --- graphic objects (certain Path objects and Shapes in --- Wumpus-Drawing for instance). There many be many objects that --- ignore it and are drawn only with angular corners.--- --- Also note - in contrast to most other drawing objects in --- Wumpus, none of the measurement values are parameteric - --- usually notated with the type variable @u@ in Wumpus. This is --- so Wumpus can (potentially) support different units e.g. --- centimeters rather than just Doubles (represening printers --- points), though adding support for other units has a very low --- priority.--- +-- Note - in contrast to most other drawing objects in Wumpus, +-- none of the types of measurement values are parameteric  +-- (usually notated with the type variable @u@ in Wumpus). Types +-- are either 'Double' representing PostScript points or Em - a +-- contextual size that is interpreted according to the current +-- font size.+--+-- It is easier to specialize all the measurement types and +-- within the 'DrawingContext' and add parametricity to the +-- /getters/ and /setters/ instead.+-- data DrawingContext = DrawingContext-      { glyph_tables          :: GlyphMetrics-      , fallback_metrics      :: MetricsOps-      , stroke_props          :: StrokeAttr-      , font_props            :: FontAttr-      , stroke_colour         :: RGBi      -- also text colour...-      , fill_colour           :: RGBi      -      , line_spacing_factor   :: Double-      , round_corner_factor   :: Double -      , text_margin           :: TextMargin+      { dc_font_metrics_table   :: FontTable+      , dc_font_load_log        :: FontLoadLog+      , dc_fallback_metrics     :: FontMetrics+      , dc_font_face            :: FontFace+      , dc_font_size            :: !FontSize+      , dc_snap_grid_factors    :: (Double,Double)+      , dc_stroke_props         :: StrokeAttr+      , dc_stroke_colour        :: RGBi+      , dc_fill_colour          :: RGBi      +      , dc_text_colour          :: RGBi+      , dc_line_spacing_factor  :: Double+      , dc_text_margin          :: TextMargin+      , dc_connector_props      :: ConnectorProps       }  -- TODO - what parts of the Drawing Context should be strict? @@ -93,43 +99,240 @@ -- type DrawingContextF = DrawingContext -> DrawingContext --- | The unit of Margin is always Double representing Points, e.g.--- 1.0 is 1 Point. Margins are not scaled relative to the current--- font size.+-- | The text margin is measured in 'Em' so it is relative to the+-- current font size. -- --- The default value is 2 point.+-- The default value is 0.5. -- data TextMargin = TextMargin-       { text_margin_x          :: !Double-       , text_margin_y          :: !Double+       { text_margin_x          :: !Em+       , text_margin_y          :: !Em        }  +-- | ConnectorProps control the drawing of connectors in +-- Wumpus-Drawing.+--+-- > conn_src_space     :: Em+-- > conn_dst_space     :: Em+--+-- Source and destination spacers - these add spacing between the +-- respective connector points and the tips of the drawn connector.+-- +-- > conn_src_offset    :: Em+-- > conn_dst_offset    :: Em+--+-- Source and destination offsets - these offset the drawing of+-- the connector perpendicular to the direction of line formed +-- between the connector points (a positive offset is drawn above, +-- a negative offset below). The main use of offsets is to draw+-- parallel line connectors.+--+-- > conn_arc_ang       :: Radian +--+-- Control the /bend/ of an arc connector.+-- +-- > conn_src_arm       :: Em+-- > conn_dst_arm       :: Em +--+-- Control the /arm/ length of a jointed connector - arms are the +-- initial segments of the connector. +--+-- > conn_loop_size     :: Em+--+-- Control the /height/ of a loop connector. +--+-- > conn_box_halfsize  :: Em+-- +-- Control the size of a connector box. Connector boxes are +-- drawn with the exterior lines projected out from the connector+-- points a halfsize above and below.+-- +data ConnectorProps = ConnectorProps+      { dc_conn_src_space       :: !Em+      , dc_conn_dst_space       :: !Em+      , dc_conn_src_offset      :: !Em+      , dc_conn_dst_offset      :: !Em+      , dc_conn_arc_ang         :: !Radian+      , dc_conn_src_arm         :: !Em+      , dc_conn_dst_arm         :: !Em+      , dc_conn_loop_size       :: !Em+      , dc_conn_box_halfsize    :: !Em+      } +++-- | 'standardContext' : @ font_size -> DrawingContext @  +--+-- Create a 'DrawingContext'.+-- +-- Note - @font_size@ is used for sizing more than just text +-- labels. Arrowheads, plot marks and other elements have their+-- metrics derived from the font size.+-- +-- No real font metrics are present in the 'DrawingContext' +-- created by 'standardContext'. Static, hard-coded fallback +-- metrics derived from the @Courier@ font are available but+-- these metrics might not accurately correspond to the +-- @Courier@ available to the the final renderer (GhostScript,+-- an SVG viewer, etc.).+-- +-- Use this constructor for drawings that make primitive use of+-- text.+-- +-- > font_metrics_table:  empty+-- > font_load_log:       empty+-- > fallback_metrics:    monospace_metrics+-- > font_face:           Courier+-- > font_size:           @supplied_font_size@+-- > stroke_props:        line_width 1, no dash_pattern, cap-butt, join-miter. +-- > stroke_colour:       black+-- > fill_colour:         light_gray+-- > text_colour:         black+-- > line_spacing_factor: 0.2+-- > round_corner_factor: 0+-- > text_margin:         (0.5 em, 0.5 em) +--+-- > conn_src_sep:        0+-- > conn_dst_sep:        0+-- > conn_src_offset:     0+-- > conn_dst_offset:     0+-- > conn_arc_ang:        pi / 12+-- > conn_src_arm:        1+-- > conn_dst_arm:        1+-- > conn_loop_size:      2 +-- +-- standardContext :: FontSize -> DrawingContext standardContext sz = -    DrawingContext { glyph_tables         = emptyGlyphMetrics-                   , fallback_metrics     = monospace_metrics-                   , stroke_props         = default_stroke_attr-                   , font_props           = FontAttr sz wumpus_courier-                   , stroke_colour        = wumpus_black-                   , fill_colour          = wumpus_light_gray-                   , line_spacing_factor  = 1.2  -                   , round_corner_factor  = 0-                   , text_margin          = standardTextMargin+    DrawingContext { dc_font_metrics_table   = emptyFontTable+                   , dc_font_load_log        = mempty+                   , dc_fallback_metrics     = monospace_metrics+                   , dc_font_face            = wumpus_courier+                   , dc_font_size            = sz+                   , dc_stroke_props         = default_stroke_attr+                   , dc_snap_grid_factors    = (50.0, 50.0)+                   , dc_stroke_colour        = wumpus_black+                   , dc_fill_colour          = wumpus_light_gray+                   , dc_text_colour          = wumpus_black+                   , dc_line_spacing_factor  = default_line_spacing  +                   , dc_text_margin          = default_text_margin+                   , dc_connector_props      = default_connector_props                    } -standardTextMargin :: TextMargin-standardTextMargin = TextMargin { text_margin_x = 2.0, text_margin_y = 2.0 } --- out-of-date - should be adding loaded fonts, not replacing the --- GlyphMetrics Map wholesale.+-- | 'metricsContext' : @ font_size * font_metrics -> DrawingContext @   ---metricsContext :: FontSize -> GlyphMetrics -> DrawingContext-metricsContext sz bgm = -    let env = standardContext sz in env { glyph_tables = bgm }+-- Create a 'DrawingContext' with font metrics loaded from the +-- file system.+-- +-- Note - @font_size@ is used for sizing more than just text +-- labels. Arrowheads, plot marks and other elements have their+-- metrics derived from the font size.+-- +-- Use this constructor for drawings that make use of the text +-- objects provided by @Wumpus-Drawing@ (DocText and RotText).+-- +metricsContext :: FontSize -> FontLoadResult -> DrawingContext+metricsContext sz res = +    let env = standardContext sz +    in env { dc_font_metrics_table = loaded_font_table res+           , dc_font_load_log      = loader_errors res+           }  ++-- | 'addFontTables' : @ font_load_result -> DrawinContextUpdate @+--+-- Add the font metrics from the FontLoadResult, if a font with +-- the same name alreay exists in the 'DrawingContext' it will be +-- replaced. Error and warning messages in the @font_load_result@ +-- will be appended to the 'font_load_log'.+--+addFontTables :: FontLoadResult -> DrawingContextF+addFontTables (FontLoadResult table msgs) = +    (\s i j -> s { dc_font_metrics_table = i `mappend` table+                 , dc_font_load_log      = j `mappend` msgs }) +      <*> dc_font_metrics_table <*> dc_font_load_log++++-- | 'reset_drawing_properties' : @ DrawingContextF @  +--+-- Reset the drawing properties in the 'DrawingContext' to their +-- default values. This changes the following fields:+--+-- > stroke_props:        line_width 1, no dash_pattern, cap-butt, join-miter. +-- > stroke_colour:       black+-- > fill_colour:         light_gray+-- > text_colour:         black+-- > line_spacing_factor: 0.2+-- > round_corner_factor: 0+-- > text_margin:         (0.5 em, 0.5 em) +--+reset_drawing_properties :: DrawingContextF +reset_drawing_properties dcxt = +    dcxt { dc_stroke_props          = default_stroke_attr+         , dc_stroke_colour         = wumpus_black+         , dc_fill_colour           = wumpus_light_gray+         , dc_text_colour           = wumpus_black+         , dc_line_spacing_factor   = default_line_spacing+         , dc_text_margin           = default_text_margin+         , dc_connector_props       = default_connector_props+         }++-- Ideally @reset_drawing_properties@ would be in the UpdateDC +-- module, but that would mean exporting @default_line_spacing@ +-- etc.+--++++-- | 'reset_drawing_metrics' : @ DrawingContextF @  +--+-- Reset the drawing metrics in the 'DrawingContext' to their +-- default values. This is a more limited version of+-- 'reset_drawing_properties' and changes the following fields:+--+-- > stroke_props:        line_width 1, no dash_pattern, cap-butt, join-miter. +-- > line_spacing_factor: 0.2+-- > round_corner_factor: 0+-- > text_margin:         (0.5 em, 0.5 em) +--+reset_drawing_metrics :: DrawingContextF +reset_drawing_metrics dcxt = +    dcxt { dc_stroke_props          = default_stroke_attr+         , dc_line_spacing_factor   = default_line_spacing+         , dc_text_margin           = default_text_margin+         }++++-- Helpers - not exported++default_text_margin :: TextMargin+default_text_margin = TextMargin { text_margin_x = 0.5, text_margin_y = 0.5 }+++-- Arc angle is 15deg - quite shallow.+--+default_connector_props :: ConnectorProps+default_connector_props = +    ConnectorProps { dc_conn_src_space    = 0+                   , dc_conn_dst_space    = 0+                   , dc_conn_src_offset   = 0+                   , dc_conn_dst_offset   = 0+                   , dc_conn_arc_ang      = pi / 12+                   , dc_conn_src_arm      = 1+                   , dc_conn_dst_arm      = 1+                   , dc_conn_loop_size    = 2 +                   , dc_conn_box_halfsize = 2 +                   }+++default_line_spacing :: Double+default_line_spacing = 0.2+ wumpus_black            :: RGBi wumpus_black            = RGBi 0 0 0  @@ -144,26 +347,27 @@     FontFace "Courier" "Courier New" SVG_REGULAR standard_encoding  --default_drawing_context :: DrawingContext-default_drawing_context = -    standardContext (font_size wumpus_default_font)--- -------------------------------------------------------------------------------- --class (Applicative m, Monad m) => DrawingCtxM (m :: * -> *) where-  askDC    :: m DrawingContext-  localize :: (DrawingContext -> DrawingContext) -> m a -> m a----- | Project a value out of a context.+-- | 'DrawingCtxM' is equivalent to the to the @MonadReader@ +-- class, but the environment type is fixed to 'DrawingContext'. ---asksDC :: DrawingCtxM m => (DrawingContext -> a) -> m a-asksDC f = askDC >>= (return . f)+-- To avoid name clashes with @mtl@ this scheme is used:+--+-- > askDC    = ask+-- > asksDC   = asks+-- > localize = local+--+-- Note, because the derived operation 'query' (aka @asks@) is+-- expected to be used more often than queryCtx (aka @ask@) it +-- gets the more convenient name.+--+class (Applicative m, Monad m) => DrawingCtxM (m :: * -> *) where+  askDC     :: m DrawingContext+  asksDC    :: (DrawingContext -> a) -> m a+  localize  :: (DrawingContext -> DrawingContext) -> m a -> m a +  asksDC f  = f <$> askDC   --------------------------------------------------------------------------------@@ -173,13 +377,15 @@   -withFontMetrics :: (MetricsOps -> PtSize -> u) -> DrawingContext -> u-withFontMetrics fn ctx@(DrawingContext { font_props = font_stats }) = -      fn metric_set point_sz+withFontMetrics :: (FontMetrics -> FontSize -> u) -> DrawingContext -> u+withFontMetrics fn ctx@(DrawingContext { dc_font_face = fface+                                       , dc_font_size = ftsize }) = +      fn metric_set ftsize   where -    ps_name     = ps_font_name $ font_face font_stats-    point_sz    = fromIntegral $ font_size font_stats -    metric_set  = fromMaybe (fallback_metrics ctx) $ -                    lookupFont ps_name (glyph_tables ctx) +    ps_name     = ps_font_name fface+    metric_set  = fromMaybe (dc_fallback_metrics ctx) $ +                    lookupFont ps_name (dc_font_metrics_table ctx)++  

@@ -0,0 +1,256 @@+{-# LANGUAGE RankNTypes                 #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Base.FontSupport+-- Copyright   :  (c) Stephen Tetley 2010-2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Data types representing font metrics.+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Base.FontSupport+  ( ++    FontName+  , CodePoint+  , FontDef(..)+  , FontFamily(..)+  , regularWeight+  , boldWeight+  , italicWeight+  , boldItalicWeight++  , CharWidthLookup++  , FontMetrics(..)++  , FontTable+  , emptyFontTable+  , lookupFont+  , insertFont++  , FontLoadMsg+  , FontLoadLog+  , fontLoadMsg++  , FontLoadResult(..)+  , printLoadErrors++  , monospace_metrics++  +  ) where++import Wumpus.Basic.Utils.HList++import Wumpus.Core                              -- package: wumpus-core++import qualified Data.Map      as Map+import Data.Monoid++++type FontName = String++-- | A Unicode code-point.+--+type CodePoint = Int++-- | FontDef wraps @FontFace@ from Wumpus-Core with file name+-- information for the font loaders.+--+data FontDef = FontDef+      { font_def_face   :: FontFace+      , gs_file_name    :: String+      , afm_file_name   :: String+      }+  deriving (Eq,Ord,Show)++++-- | A family group of FontDefs (regular, bold, italic and +-- bold-italic).+--+-- It is convenient for some higher-level text objects in Wumpus +-- (particularly @Doc@ in Wumpus-Drawing) to treat a font and its+-- standard weights as the same entity. This allows @Doc@ API to +-- provide a @bold@ operation to simply change to the the bold+-- weight of the current family, rather than use the primitive +-- @set_font@ operation to change to an explicitly named font.+--+--+data FontFamily = FontFamily+      { ff_regular      :: FontDef+      , ff_bold         :: Maybe FontDef+      , ff_italic       :: Maybe FontDef+      , ff_bold_italic  :: Maybe FontDef  +      }++-- | Extract the regular weight 'FontDef' from a 'FontFamily'.+--+regularWeight :: FontFamily -> FontDef+regularWeight = ff_regular+++-- | Extract the bold weight 'FontDef' from a 'FontFamily'.+--+-- Note - this falls back to the regular weight if the font family +-- has no bold weight. To get the bold weight or @Nothing@ if it+-- is not present use the record selector @ff_bold@.+--+boldWeight :: FontFamily -> FontDef+boldWeight s = maybe (ff_regular s) id $ ff_bold s+++-- | Extract the @italic@ weight 'FontDef' from a 'FontFamily'.+--+-- Note - this falls back to the regular weight if the font family +-- has no italic weight. To get the italic weight or @Nothing@ if +-- it is not present use the record selector @ff_italic@.+--+italicWeight :: FontFamily -> FontDef+italicWeight s = maybe (ff_regular s) id $ ff_italic s+++-- | Extract the @bold-italic@ weight 'FontDef' from a +-- 'FontFamily'.+--+-- Note - this falls back to the regular weight if the font family +-- has no bold-italic weight. To get the bold-italic weight or +-- @Nothing@ if it is not present use the record selector +-- @ff_bold_italic@.+--+boldItalicWeight :: FontFamily -> FontDef+boldItalicWeight s = maybe (ff_regular s) id $ ff_bold_italic s++++-- | A lookup function from code point to /width vector/.+--+-- The unit is always stored as a Double representing PostScript+-- points.+--+-- Note - in PostScript terminology a width vector is not obliged+-- to be left-to-right (writing direction 0). It could be +-- top-to-bottom (writing direction 1).+--+type CharWidthLookup = CodePoint -> Vec2 Double++++-- | 'FontMetrics' store a subset of the properties available in +-- a font file - enough to calculate accurate bounding boxes and+-- positions for text.+--+-- > Bounding box representing the maximum glyph area.+-- > Width vectors for each character.+-- > Cap height+-- > Descender depth.+--+-- Because Wumpus always needs font metrics respective to the +-- current point size, the actual fields are all functions.+--+data FontMetrics = FontMetrics+    { get_bounding_box :: FontSize -> BoundingBox Double+    , get_cw_table     :: FontSize -> CharWidthLookup+    , get_cap_height   :: FontSize -> Double+    , get_descender    :: FontSize -> Double+    }+++-- | A map between a font name and the respective FontMetrics.+--+newtype FontTable = FontTable { +          getFontTable :: Map.Map FontName FontMetrics }++++instance Monoid FontTable where+  mempty        = emptyFontTable+  a `mappend` b = FontTable $ getFontTable a `mappend` getFontTable b+++emptyFontTable :: FontTable+emptyFontTable = FontTable $ Map.empty+++-- | 'FontLoadMsg' - type synonym for String.+--+type FontLoadMsg        = String++-- | 'FontLoadLog' is a Hughes list of Strings, so it supports +-- efficient append.+--+newtype FontLoadLog     = FontLoadLog { getFontLoadLog :: H FontLoadMsg }+++instance Monoid FontLoadLog where+  mempty        = FontLoadLog $ emptyH+  a `mappend` b = FontLoadLog $ getFontLoadLog a `appendH` getFontLoadLog b+++fontLoadMsg :: String -> FontLoadLog +fontLoadMsg = FontLoadLog . wrapH+++-- Need a synonym for @FontLoading@...+data FontLoadResult = FontLoadResult+      { loaded_font_table    :: FontTable+      , loader_errors        :: FontLoadLog+      }+++-- | Print the loader errors from the 'FontLoadResult' to std-out.+--+printLoadErrors :: FontLoadResult -> IO ()+printLoadErrors = mapM_ putStrLn . toListH . getFontLoadLog . loader_errors++--------------------------------------------------------------------------------+++-- | 'lookupFont' : @ name * font_table -> Maybe FontMetrics @ +-- +-- Lookup a font in the font_table.+-- +lookupFont :: FontName -> FontTable -> Maybe FontMetrics+lookupFont name = Map.lookup name . getFontTable++-- | 'insertFont' : @ name * font_metrics * font_table -> FontTable @ +-- +-- Insert a named font into the font_table.+-- +insertFont :: FontName -> FontMetrics -> FontTable -> FontTable+insertFont name ops = +    FontTable . Map.insert name ops . getFontTable++-- | This ignores the Char code lookup and just returns the +-- default advance vector.+--+monospace_metrics :: FontMetrics+monospace_metrics = FontMetrics+    { 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+    descender       = (-157) / 1000++    upscale sz d    = d * fromIntegral sz+    lowerLeft sz    = P2 (upscale sz llx) (upscale sz lly) +    upperRight sz   = P2 (upscale sz urx) (upscale sz ury) ++

@@ -1,120 +0,0 @@-{-# LANGUAGE RankNTypes                 #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Kernel.Base.GlyphMetrics--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Data types representing glyph metrics loaded from font files.--- -----------------------------------------------------------------------------------module Wumpus.Basic.Kernel.Base.GlyphMetrics-  ( --    FontName-  , CodePoint-  , CharWidthTable-  , MetricsOps(..)-  , FontMetricsOps(..)--  , GlyphMetrics-  , emptyGlyphMetrics-  , lookupFont-  , insertFont--  , monospace_metrics--  -  ) where--import Wumpus.Core                              -- package: wumpus-core--import qualified Data.Map      as Map-import Data.Monoid----type FontName = String---- | A Unicode code-point.----type CodePoint = Int---- | A lookup from code point to /width vector/.------ Note - in PostScript terminology a width vector is not obliged--- to be left-to-right (writing direction 0). It could be --- top-to-bottom (writing direction 1).----type CharWidthTable u = CodePoint -> Vec2 u------ | Operations on the metrics set of a font.------ The is the internal representation used by Wumpus-Basic after--- parsing the font file.----data MetricsOps = MetricsOps-      { 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' for a particular named font.--- -data FontMetricsOps = FontMetricsOps FontName MetricsOps----- | A map between a font name and MetricsOps.----newtype GlyphMetrics = GlyphMetrics { -          getGlyphMetrics :: Map.Map FontName MetricsOps }--instance Monoid GlyphMetrics where-  mempty        = emptyGlyphMetrics-  a `mappend` b = GlyphMetrics $ getGlyphMetrics a `mappend` getGlyphMetrics b---emptyGlyphMetrics :: GlyphMetrics-emptyGlyphMetrics = GlyphMetrics $ Map.empty--lookupFont :: FontName -> GlyphMetrics -> Maybe MetricsOps-lookupFont name = Map.lookup name . getGlyphMetrics--insertFont :: FontMetricsOps -> GlyphMetrics -> GlyphMetrics-insertFont (FontMetricsOps name ops) = -    GlyphMetrics . Map.insert name ops . getGlyphMetrics---- | This ignores the Char code lookup and just returns the --- default advance vector.----monospace_metrics :: MetricsOps-monospace_metrics = MetricsOps-    { 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-    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) --

@@ -21,55 +21,61 @@ module Wumpus.Basic.Kernel.Base.QueryDC   (  -    -    textAttr-  , withTextAttr+    normalizeCtx+  , normalizeCtxF+  , dinterpCtx+  , dinterpCtxF -  , strokeAttr-  , withStrokeAttr+  , uconvertCtx1+  , uconvertCtxF -  , fillAttr-  , withFillAttr+  , pointSize +  , strokeAttr+  , fillAttr   , borderedAttr-  , withBorderedAttr+  , textAttr -  , getRoundCornerSize-  , getTextMargin+  , position+  , snapmove +  , textMargin+   , getLineWidth   , getFontAttr   , getFontSize   , getFontFace+  , getTextColour+   , markHeight   , markHalfHeight-  , baselineSpacing+  , textlineSpace    -- * Glyph metrics   , glyphBoundingBox-  , glyphCapHeight-  , glyphDescender-  , glyphVerticalSpan+  , capHeight+  , descender+  , verticalSpan+   , cwLookupTable -  -- * Default monospace metrics -  , monoFontPointSize-  , monoCharWidth-  , monoTextWidth-  , monoTextLength-  , monoCapHeight-  , monoLowerxHeight-  , monoDescenderDepth-  , monoAscenderHeight-  , monoTextDimensions-  , monoMultiLineHeight-  , monoDefaultPadding-  , monoVecToCenter  +  -- * Connector props+  , connectorSrcSpace+  , connectorDstSpace+  , connectorSrcOffset+  , connectorDstOffset+  , connectorArcAngle+  , connectorSrcArm+  , connectorDstArm+  , connectorLoopSize+  , connectorBoxHalfSize+   ) where +import Wumpus.Basic.Kernel.Base.BaseDefs import Wumpus.Basic.Kernel.Base.DrawingContext-import Wumpus.Basic.Kernel.Base.GlyphMetrics+import Wumpus.Basic.Kernel.Base.FontSupport  import Wumpus.Core                              -- package: wumpus-core import qualified Wumpus.Core.FontSize   as FS@@ -77,225 +83,231 @@ import Control.Applicative  -textAttr :: DrawingCtxM m => m (RGBi,FontAttr)-textAttr = (,) <$> asksDC stroke_colour <*> asksDC font_props --- | Because @textAttr@ is so commonly used here is a functional--- version that avoids tupling.----withTextAttr :: DrawingCtxM m => (RGBi -> FontAttr -> a) -> m a-withTextAttr fn = fn <$> asksDC stroke_colour <*> asksDC font_props +normalizeCtx :: (DrawingCtxM m, InterpretUnit u) => u -> m Double+normalizeCtx u = (\sz -> normalize sz u) <$> pointSize -strokeAttr :: DrawingCtxM m => m (RGBi, StrokeAttr)-strokeAttr = (,) <$> asksDC stroke_colour <*> asksDC stroke_props+normalizeCtxF :: (DrawingCtxM m, Functor t, InterpretUnit u) +             => t u -> m (t Double)+normalizeCtxF t = (\sz -> fmap (normalize sz) t) <$> pointSize -withStrokeAttr :: DrawingCtxM m => (RGBi -> StrokeAttr -> a) -> m a-withStrokeAttr fn = fn <$> asksDC stroke_colour <*> asksDC stroke_props+dinterpCtx :: (DrawingCtxM m, InterpretUnit u) => Double -> m u+dinterpCtx u = (\sz -> dinterp sz u) <$> pointSize +dinterpCtxF :: (DrawingCtxM m, Functor t, InterpretUnit u) => t Double -> m (t u)+dinterpCtxF u = (\sz -> fmap (dinterp sz) u) <$> pointSize +uconvertCtx1 :: (DrawingCtxM m, InterpretUnit u, InterpretUnit u1) +             => u -> m u1+uconvertCtx1 t = (\sz -> uconvert1 sz t) <$> pointSize++uconvertCtxF :: (DrawingCtxM m, Functor t, InterpretUnit u, InterpretUnit u1) +            => t u -> m (t u1)+uconvertCtxF t = (\sz -> uconvertF sz t) <$> pointSize+++pointSize :: DrawingCtxM m => m FontSize+pointSize = asksDC dc_font_size++strokeAttr :: DrawingCtxM m => m (RGBi, StrokeAttr)+strokeAttr = (,) <$> asksDC dc_stroke_colour <*> asksDC dc_stroke_props+ fillAttr :: DrawingCtxM m => m RGBi-fillAttr = asksDC fill_colour+fillAttr = asksDC dc_fill_colour -withFillAttr :: DrawingCtxM m => (RGBi -> a) -> m a-withFillAttr fn = fn <$> asksDC fill_colour  borderedAttr :: DrawingCtxM m => m (RGBi, StrokeAttr, RGBi)-borderedAttr = (,,) <$> asksDC fill_colour <*> asksDC stroke_props -                                           <*> asksDC stroke_colour+borderedAttr = (,,) <$> asksDC dc_fill_colour +                    <*> asksDC dc_stroke_props +                    <*> asksDC dc_stroke_colour -withBorderedAttr :: DrawingCtxM m => (RGBi -> StrokeAttr -> RGBi -> a) -> m a-withBorderedAttr fn = -    fn <$> asksDC fill_colour <*> asksDC stroke_props -                              <*> asksDC stroke_colour  +textAttr :: DrawingCtxM m => m (RGBi,FontAttr)+textAttr = +    (\a b c -> (a, FontAttr b c)) +      <$> asksDC dc_text_colour <*> asksDC dc_font_size <*> asksDC dc_font_face --- | Size of the round corner factor.++++-- | Get the Point corresponding the grid coordinates scaled by+-- the snap-grid scaling factors. ---getRoundCornerSize :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u-getRoundCornerSize = (\factor -> (realToFrac factor) * fromPtSize 1)-                    <$> asksDC round_corner_factor+position :: (DrawingCtxM m, Fractional u) => (Int, Int) -> m (Point2 u)+position (x,y) = post <$> asksDC dc_snap_grid_factors+  where+    post (sx,sy) = P2 (realToFrac $ sx * fromIntegral x) +                      (realToFrac $ sy * fromIntegral y)   ++-- | Scale a vector coordinate by the snap-grid scaling factors.+--+-- Absolute units.+--+snapmove :: (DrawingCtxM m, Fractional u) => (Int,Int) -> m (Vec2 u)+snapmove (x,y) = post <$> asksDC dc_snap_grid_factors+  where+    post (sx,sy) = V2 (realToFrac $ sx * fromIntegral x) +                      (realToFrac $ sy * fromIntegral y)+++ -- | 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+textMargin :: (DrawingCtxM m, InterpretUnit u) => m (u,u)+textMargin = post <$> asksDC dc_font_size <*> asksDC dc_text_margin   where-    fn d = (realToFrac d) * fromPtSize 1+    post sz (TextMargin xem yem) = (uconvert1 sz xem, uconvert1 sz yem)   ++ getLineWidth :: DrawingCtxM m => m Double-getLineWidth = line_width <$> asksDC stroke_props+getLineWidth = line_width <$> asksDC dc_stroke_props  getFontAttr :: DrawingCtxM m => m FontAttr-getFontAttr = asksDC font_props+getFontAttr = FontAttr <$> asksDC dc_font_size <*> asksDC dc_font_face -getFontSize :: DrawingCtxM m => m Int-getFontSize = font_size <$> asksDC font_props -getFontFace :: DrawingCtxM m => m FontFace-getFontFace = font_face <$> asksDC font_props+getFontSize     :: DrawingCtxM m => m Int+getFontSize     = asksDC dc_font_size +getFontFace     :: DrawingCtxM m => m FontFace+getFontFace     = asksDC dc_font_face +getTextColour   :: DrawingCtxM m => m RGBi+getTextColour   = asksDC dc_text_colour  --- | Vertical distance between baselines of consecutive text --- lines.----baselineSpacing :: (DrawingCtxM m, Fractional u) => m u-baselineSpacing = -    (\sz factor -> realToFrac $ factor * fromIntegral sz)-      <$> asksDC (font_size . font_props) <*> asksDC line_spacing_factor- -- | The /mark/ height is the height of a lowercase letter in the --- current font.+-- Courier font at the current point size. -- -- Arrowheads, dots etc. should generally be drawn at the mark  -- height. -- -markHeight :: (DrawingCtxM m, FromPtSize u) => m u-markHeight = (fromPtSize . FS.xcharHeight . font_size) <$> asksDC font_props+markHeight :: (DrawingCtxM m, InterpretUnit u) => m u+markHeight = post <$> asksDC dc_font_size +  where+    post sz = dinterp sz (FS.xcharHeight sz)  -markHalfHeight :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u++markHalfHeight :: (Fractional u, DrawingCtxM m, InterpretUnit u) => m u markHalfHeight = (0.5*) <$> markHeight  --- Note - there are probably enough functions that use just --- markHeight to merit a withMarkHeight function. +-- | Vertical distance between descender of a line and the +-- cap-height of the line below. +-- +textlineSpace :: (DrawingCtxM m, Fractional u, InterpretUnit u) => m u+textlineSpace = +    post <$> asksDC dc_font_size <*> asksDC dc_line_spacing_factor+  where+    post sz factor = dinterp sz ((fromIntegral sz) * (realToFrac factor))  -------------------------------------------------------------------------------- -glyphQuery :: DrawingCtxM m => (MetricsOps -> PtSize -> u) -> m u++glyphQuery :: DrawingCtxM m => (FontMetrics -> FontSize -> a) -> m a 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+glyphBoundingBox :: (DrawingCtxM m, InterpretUnit u) => m (BoundingBox u)+glyphBoundingBox = +    uconvertF <$> asksDC dc_font_size <*> glyphQuery get_bounding_box   +-- | Height of a capital letter.+--+capHeight :: (DrawingCtxM m, InterpretUnit u) => m u+capHeight = dinterp <$> asksDC dc_font_size <*> glyphQuery get_cap_height  -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+descender :: (DrawingCtxM m, InterpretUnit u) => m u+descender = dinterp <$> asksDC dc_font_size <*> 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+verticalSpan :: (DrawingCtxM m, InterpretUnit u) => m u+verticalSpan = +    (\ch dd -> ch - dd) <$> capHeight <*> descender  -cwLookupTable :: (FromPtSize u, DrawingCtxM m) => m (CharWidthTable u)-cwLookupTable = glyphQuery get_cw_table +-- | Note the CharWidthLookup is not parameteric on units.+--+-- /CharWidth/ is always Double representing PostScript points.+-- Client code must convert this value accordingly.+--+cwLookupTable :: DrawingCtxM m => m CharWidthLookup+cwLookupTable = glyphQuery get_cw_table  --------------------------------------------------------------------------------+-- Connector props -withFontSize :: DrawingCtxM m => (FontSize -> u) -> m u-withFontSize fn = (fn . font_size) <$> asksDC font_props+-- helper +connectorAsks :: DrawingCtxM m => (ConnectorProps -> a) -> m a+connectorAsks f = f <$> asksDC dc_connector_props  --- NOTE - textHeight in Wumpus-Core should be renamed as it is--- (probably) more indiactive of Cap height than /font point size/--- -monoFontPointSize :: (DrawingCtxM m, FromPtSize u) => m u-monoFontPointSize = withFontSize (fromPtSize . fromIntegral)+connectorSrcSpace :: (DrawingCtxM m, InterpretUnit u) => m u +connectorSrcSpace = (\sz u -> uconvert1 sz u) +                      <$> pointSize <*> connectorAsks dc_conn_src_space -monoCharWidth :: (DrawingCtxM m, FromPtSize u) => m u-monoCharWidth = withFontSize (fromPtSize . FS.charWidth) +connectorDstSpace :: (DrawingCtxM m, InterpretUnit u) => m u +connectorDstSpace = (\sz u -> uconvert1 sz u) +                      <$> pointSize <*> connectorAsks dc_conn_dst_space -monoTextWidth :: (DrawingCtxM m, FromPtSize u) => Int -> m u-monoTextWidth n = withFontSize $ \sz -> fromPtSize $ FS.textWidth sz n+connectorSrcOffset :: (DrawingCtxM m, InterpretUnit u) => m u +connectorSrcOffset = (\sz u -> uconvert1 sz u) +                       <$> pointSize <*> connectorAsks dc_conn_src_offset  -monoTextLength :: (DrawingCtxM m, FromPtSize u) => String -> m u-monoTextLength ss = monoTextWidth $ charCount ss+connectorDstOffset :: (DrawingCtxM m, InterpretUnit u) => m u +connectorDstOffset = (\sz u -> uconvert1 sz u) +                       <$> pointSize <*> connectorAsks dc_conn_dst_offset  -monoCapHeight :: (DrawingCtxM m, FromPtSize u) => m u-monoCapHeight = withFontSize (fromPtSize . FS.capHeight)--monoTotalCharHeight :: (DrawingCtxM m, FromPtSize u) => m u-monoTotalCharHeight = withFontSize (fromPtSize . FS.totalCharHeight)-+connectorArcAngle :: DrawingCtxM m => m Radian+connectorArcAngle = connectorAsks dc_conn_arc_ang  --- | Height of a lower case \'x\' in Courier.---  --- \'x\' has no ascenders or descenders. --- -monoLowerxHeight :: (DrawingCtxM m, FromPtSize u) => m u-monoLowerxHeight = withFontSize (fromPtSize . FS.xcharHeight)--monoDescenderDepth :: (DrawingCtxM m, FromPtSize u) => m u-monoDescenderDepth = withFontSize (fromPtSize . FS.descenderDepth)--monoAscenderHeight :: (DrawingCtxM m, FromPtSize u) => m u-monoAscenderHeight = withFontSize (fromPtSize . FS.ascenderHeight)+connectorSrcArm :: (DrawingCtxM m, InterpretUnit u) => m u +connectorSrcArm = (\sz u -> uconvert1 sz u) +                    <$> pointSize <*> connectorAsks dc_conn_src_arm  --- | Query the dimensions of the text using the current font size--- but using metrics derived from Courier.------ Note - the width will generally be a over-estimate for --- non-monospaced fonts.--- -monoTextDimensions :: (DrawingCtxM m, Num u, Ord u, FromPtSize u)-                   => String -> m (u,u)-monoTextDimensions ss = -    (\sz -> post $ textBounds sz zeroPt ss) -      <$> asksDC (font_size . font_props)-  where-    post bb = (boundaryWidth bb, boundaryHeight bb)+connectorDstArm :: (DrawingCtxM m, InterpretUnit u) => m u +connectorDstArm = (\sz u -> uconvert1 sz u) +                    <$> pointSize <*> connectorAsks dc_conn_dst_arm  --- | The heigth of @n@ lines of text, which is --- @n lines + n-1 line spacers@----monoMultiLineHeight :: (DrawingCtxM m, Fractional u, FromPtSize u) -                        => Int -> m u-monoMultiLineHeight n | n < 0   = pure 0-monoMultiLineHeight n           = -    (\h lsf -> h + (fromIntegral $ n-1) * (h * realToFrac lsf))-      <$> monoTotalCharHeight <*> asksDC line_spacing_factor- -    -- Note as the height calculation has changed in Wumpus-Core this-    -- 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-+connectorLoopSize :: (DrawingCtxM m, InterpretUnit u) => m u +connectorLoopSize = (\sz u -> uconvert1 sz u) +                      <$> pointSize <*> connectorAsks dc_conn_loop_size  --- | Vector from baseline left to center----monoVecToCenter :: (DrawingCtxM m, Fractional u, Ord u, FromPtSize u) -                => String -> m (Vec2 u)-monoVecToCenter ss = (\(w,h) dy -> vec (0.5*w) (0.5*h - dy)) -                       <$> monoTextDimensions ss <*> monoDescenderDepth+connectorBoxHalfSize :: (DrawingCtxM m, InterpretUnit u) => m u +connectorBoxHalfSize = +    (\sz u -> uconvert1 sz u) +      <$> pointSize <*> connectorAsks dc_conn_box_halfsize

@@ -1,104 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Kernel.Base.ScalingContext--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC------ Scaling in X and Y------ \*\* WARNING \*\* - half baked.--- -----------------------------------------------------------------------------------module Wumpus.Basic.Kernel.Base.ScalingContext-  (--    ScalingContext(..)--  , scaleX-  , scaleY-  , scalePt-  , scaleVec--  , unitX-  , unitY--  , uniformScaling-  , coordinateScaling--  ) where---import Wumpus.Core				-- package: wumpus-core------ | ScalingContext is a dictionary of two functions for scaling --- in X and Y.----data ScalingContext ux uy u = ScalingContext-      { scale_in_x  :: ux -> u-      , scale_in_y  :: uy -> u-      }---scaleX              :: ScalingContext ux uy u -> ux -> u-scaleX ctx ux       = (scale_in_x ctx) ux--scaleY              :: ScalingContext ux uy u -> uy -> u-scaleY ctx uy       = (scale_in_y ctx) uy---scalePt             :: ScalingContext ux uy u -> ux -> uy -> Point2 u-scalePt ctx ux uy   = P2 (scale_in_x ctx ux) (scale_in_y ctx uy)--scaleVec            :: ScalingContext ux uy u -> ux -> uy -> Vec2 u-scaleVec ctx ux uy  = V2 (scale_in_x ctx ux) (scale_in_y ctx uy)---unitX               :: Num ux => ScalingContext ux uy u -> u-unitX ctx           = scaleX ctx 1- -unitY               :: Num uy => ScalingContext ux uy u -> u-unitY ctx           = scaleY ctx 1---------------------------------------------------------------------------------------- constructors for scaling context----- | Build a ScalingContext where both X and Y are scaled by the --- same uniform step.------ The dimensions (types) of the ScalingContext are unified - the --- output type and the input types are all the same.----uniformScaling :: Num u => u -> ScalingContext u u u-uniformScaling u = ScalingContext-      { scale_in_x  = (\x -> u*x)-      , scale_in_y  = (\y -> u*y)-      }------ | Build a ScalingContext for scaling Int coordinates.------ The scaling factors in X and Y can be different sizes.-----coordinateScaling :: Num u => u -> u -> ScalingContext Int Int u-coordinateScaling sx sy = ScalingContext-      { scale_in_x  = (\x -> sx * fromIntegral x)-      , scale_in_y  = (\y -> sy * fromIntegral y)-      }---

@@ -0,0 +1,163 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Base.Units+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Units @cm@, @pica@ and \"contextual\" units - @em@, @en@.+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Base.Units+  (+++  -- * Centimeter+    Centimeter+  , cm+  , dcm++  -- * Pica+  , Pica+  , pica+  , dpica++  -- * Em+  , Em++  -- * En+  , En++  ) where+++import Wumpus.Basic.Kernel.Base.BaseDefs++import Wumpus.Core                              -- package: wumpus-core+++--------------------------------------------------------------------------------++-- | Wrapped Double representing Centimeter.+-- +newtype Centimeter = Centimeter { getCentimeter :: Double } +  deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat)+++instance Show Centimeter where+  showsPrec p d = showsPrec p (getCentimeter d)++-- | Cast a value in Centimeters to some Fractional type.+-- +-- Note - this casting should only be used for non-contextual+-- units such as Double.+--+cm :: Fractional u => Centimeter -> u +cm = realToFrac . (28.45275619 *) . getCentimeter++-- | Convert Double to Centimer.+-- +dcm :: Double -> Centimeter+dcm = Centimeter . (0.03514598 *)++instance ScalarUnit Centimeter where+  fromPsPoint = dcm+  toPsPoint   = cm ++instance InterpretUnit Centimeter where+  normalize _ = cm +  dinterp   _ = dcm+++-- | Wrapped Double /Pica/ unit type.+-- +-- Pica is 12 Points.+--+newtype Pica = Pica { getPica :: Double } +  deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat)+++instance Show Pica where+  showsPrec p d = showsPrec p (getPica d)++                            +-- | Cast a value in Pica to some Fractional type.+-- +-- Note - this casting should only be used for non-contextual+-- units such as Double.+--+pica :: Fractional u => Pica -> u +pica = realToFrac . (* 12.0) . getPica++-- | Convert a Double to a Pica.+--+dpica :: Double -> Pica+dpica = Pica . (\x -> x / 12.0)+++instance Tolerance Pica where +  eq_tolerance     = 0.001+  length_tolerance = 0.01+++instance ScalarUnit Pica where+  fromPsPoint = dpica+  toPsPoint   = pica++instance InterpretUnit Pica where+  normalize _ = pica+  dinterp   _ = dpica++++--------------------------------------------------------------------------------+-- Contextual units++-- | Wrapped Double representing an Em. +-- +newtype Em = Em { getEm :: Double } +  deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat)++instance Show Em where+  showsPrec p d = showsPrec p (getEm d)++++instance InterpretUnit Em where+  normalize sz a = fromIntegral sz * realToFrac a+  dinterp sz d   = realToFrac d / fromIntegral sz++instance Tolerance Centimeter where +  eq_tolerance     = 0.001+  length_tolerance = 0.01+++-- | Wrapped Double representing an En.+-- +newtype En = En { getEn :: Double } +  deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat)++instance Show En where+  showsPrec p d = showsPrec p (getEn d)+++instance InterpretUnit En where+  normalize sz a = (realToFrac  a) * 0.5 * fromIntegral sz+  dinterp sz d   = 2 * (realToFrac d) / (fromIntegral sz)++++instance Tolerance Em where +  eq_tolerance     = 0.001+  length_tolerance = 0.01++instance Tolerance En where+  eq_tolerance     = 0.001 +  length_tolerance = 0.01

@@ -3,263 +3,640 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.Kernel.Base.UpdateDC--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2010-2011 -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com> -- Stability   :  highly unstable -- Portability :  GHC ----- Customize drawing attributes------ \*\* WARNING \*\* - this module needs systematic naming --- schemes both for update functions (primaryColour, ...) and --- for synthesized selectors (e.g. lowerxHeight). The current --- names will change.+-- Customize drawing attributes. The functions here are +-- @DrawingContext@ modifiers to be run within a the scope of a +-- @localize@ block (cf. @local@ of the Reader monad). --+-- By convention, underscore-separated names are used for +-- DrawingContext modifiers in this module. This is because the +-- modifiers defined here are expected to be used mostly as static +-- \"properties\" resembling constants in drawings. --  --------------------------------------------------------------------------------  module Wumpus.Basic.Kernel.Base.UpdateDC   (  -  -- * Modifiers -  -    roundCornerFactor-  , textMargin+  -- * Modifiers       +    snap_grid_factors    -- ** Line widths-  , lineWidth-  , thick-  , ultrathick-  , thin+  , set_line_width +  , line_default+  , line_thin+  , line_thick+  , line_ultra_thick+   -- ** Line caps-  , capButt-  , capRound-  , capSquare+  , cap_default+  , cap_butt+  , cap_round+  , cap_square    -- ** Line joins-  , joinMiter-  , joinRound-  , joinBevel+  , join_default+  , join_miter+  , join_round+  , join_bevel    -- ** Dash Pattern-  , dashPattern-  , unit_dash_pattern-  , phase-  , dphase-  , doublegaps-  , doubledashes+  , set_dash_pattern +  , solid_line+  , dotted_line+  , packed_dotted+  , loose_dotted+  +  , dashed_line+  , packed_dashed+  , loose_dashed+     -- * Font properties-  , fontAttr-  , fontSize-  , fontFace+  , font_attr+  , set_font+  , set_font_size +   -- * Font / mark drawing size-  , scalesize-  , doublesize-  , halfsize+  , scale_point_size +  , double_point_size+  , half_point_size++  , text_margin+  , text_margin_none+  , text_margin_tight+  , text_margin_default+  , text_margin_loose++   -- * Colour-  , swapColours-  , bothStrokeColour-  , bothFillColour-  , strokeColour-  , fillColour +  , stroke_colour+  , fill_colour +  , text_colour+  , single_colour +  , swap_colours+  , fill_use_stroke_colour+  , stroke_use_fill_colour -  +  , fill_use_text_colour+  , stroke_use_text_colour++  , text_use_stroke_colour+  , text_use_fill_colour++  -- * Connector Props+  , source_space+  , dest_space+  , source_offset+  , dest_offset+  , uniform_conn_space+  , conn_arc_angle+  , source_arm_len+  , dest_arm_len+  , uniform_arm_len+  , conn_loop_size+  , conn_box_halfsize+   ) where  +import Wumpus.Basic.Kernel.Base.BaseDefs import Wumpus.Basic.Kernel.Base.DrawingContext+import Wumpus.Basic.Kernel.Base.FontSupport+import Wumpus.Basic.Kernel.Base.Units  import Wumpus.Core                              -- package: wumpus-core  import Control.Applicative -import Data.Ratio  --------------------------------------------------------------------------------+-- helpers   updateStrokeProps :: (StrokeAttr -> StrokeAttr) -> DrawingContextF-updateStrokeProps fn = (\s i -> s { stroke_props = fn i }) <*> stroke_props--updateFontProps :: (FontAttr -> FontAttr) -> DrawingContextF-updateFontProps fn = (\s i -> s { font_props = fn i }) <*> font_props+updateStrokeProps fn = +    (\s i -> s { dc_stroke_props = fn i }) <*> dc_stroke_props  +withFontSize :: (FontSize -> DrawingContextF) -> DrawingContextF+withFontSize fn = (\s i -> fn i s) <*> dc_font_size  -------------------------------------------------------------------------------- -roundCornerFactor   :: Double -> DrawingContextF-roundCornerFactor d = (\s -> s { round_corner_factor = d }) --- | 'textMargin' : @ xsep * ysep -> DrawingContextF @++-- | 'snap_grid_factors' : @ x_unit * y_unit -> DrawingContextF @+-- +-- Set the @snap grid factors@ - a snap grid is an alternative +-- coordinate space, it can be convenient for drawing +-- \"box and arrow\" diagrams. ---textMargin   :: Double -> Double -> DrawingContextF-textMargin xsep ysep = (\s -> s { text_margin = TextMargin xsep ysep })+snap_grid_factors   :: Double -> Double -> DrawingContextF+snap_grid_factors xu yu = \s -> s { dc_snap_grid_factors = (xu, yu) }   -------------------------------------------------------------------------------- -- line widths --- Note - some care might be needed if we ever define other unit --- types... -lineWidth       :: Double -> DrawingContextF-lineWidth d      = updateStrokeProps (\s -> s { line_width = d })+-- | set_line_width : @ width_in_points -> DrawingContextF @+--+-- Set the line_width to the supplied point size.+--+-- Initially the line width is 1.0.+--+-- /Constant/ variations of the function maybe be more +-- convenient:+--+-- > line_default, line_thin, line_thick, line_ultra_thick+--+set_line_width      :: Double -> DrawingContextF+set_line_width d    = updateStrokeProps (\s -> s { line_width = d })  --- std_line_width      :: Double--- std_line_width      = 1.0+-- | Set the line_width to @default@ - 1.0.+--+line_default        :: DrawingContextF+line_default        = set_line_width 1.0 -thick_line          :: Double-thick_line          = 2.0 -ultra_thick_line    :: Double-ultra_thick_line    = 4.0--thin_line           :: Double-thin_line           = 0.5+-- | Set the line_width to @thin@ - 0.5.+--+line_thin           :: DrawingContextF+line_thin           = set_line_width 0.5  --- | Set the line width to a /thick/.+-- | Set the line_width to @thick@ - 2.0. ----- Note this context update is /oblivious/ - operationally the --- line width is set to exactly @2.0@.+line_thick          :: DrawingContextF+line_thick          = set_line_width 2.0++-- | Set the line_width to @ultra_thick@ - 4.0. ---thick               :: DrawingContextF-thick               = lineWidth thick_line+line_ultra_thick    :: DrawingContextF+line_ultra_thick    = set_line_width 4.0 -ultrathick          :: DrawingContextF-ultrathick          = lineWidth ultra_thick_line -thin                :: DrawingContextF-thin                = lineWidth thin_line+--+-- All options share the prefix so the enumeration is obvious...+--   --------------------------------------------------------------------------------+-- Line props  setLineCap          :: LineCap -> DrawingContextF setLineCap d        = updateStrokeProps (\s -> s { line_cap = d }) +setLineJoin         :: LineJoin -> DrawingContextF+setLineJoin d       = updateStrokeProps (\s -> s { line_join = d }) -capButt             :: DrawingContextF-capButt             = setLineCap CapButt -capRound            :: DrawingContextF-capRound            = setLineCap CapRound+-- | Set the line_cap to the default which is @butt@.+--+-- This is a synonym for 'cap_butt'.+--+cap_default         :: DrawingContextF+cap_default         = cap_butt -capSquare           :: DrawingContextF-capSquare           = setLineCap CapSquare+-- | Set the line_cap to @butt@.+--+-- Butt squares of the stroke at the end point.+--+-- This is the default.+--+cap_butt            :: DrawingContextF+cap_butt            = setLineCap CapButt +-- | Set the line_cap to @round@.+--+-- This rounds the end of the stroke and the visually the +-- rounding slightly extends the length of the line.+--+cap_round           :: DrawingContextF+cap_round           = setLineCap CapRound -setLineJoin         :: LineJoin -> DrawingContextF-setLineJoin d       = updateStrokeProps (\s -> s { line_join = d }) +-- | Set the line_cap to @square@.+--+-- This squares off the end of the stroke, visually extending +-- the stroke by half the line width.+--+cap_square          :: DrawingContextF+cap_square          = setLineCap CapSquare -joinMiter           :: DrawingContextF-joinMiter           = setLineJoin JoinMiter -joinRound           :: DrawingContextF-joinRound           = setLineJoin JoinRound -joinBevel           :: DrawingContextF-joinBevel           = setLineJoin JoinBevel+-- | Set the line_join to the default which is @miter@.+--+-- This is a synonym for 'join_miter'.+--+join_default        :: DrawingContextF+join_default        = join_miter  +-- | Set the line_join to @miter@.+--+-- This extends the joining line segments to form a sharp miter.+--+-- This is the default.+--+join_miter          :: DrawingContextF+join_miter          = setLineJoin JoinMiter+++-- | Set the line_join to @round@.+--+-- This rounds off the corner of the joined line segments.+--+join_round          :: DrawingContextF+join_round          = setLineJoin JoinRound+++-- | Set the line_join to @round@.+--+-- This bevels off the corner of the joined line segments with a +-- notch.+--+join_bevel          :: DrawingContextF+join_bevel          = setLineJoin JoinBevel++ -------------------------------------------------------------------------------- -dashPattern         :: DashPattern -> DrawingContextF-dashPattern d       = updateStrokeProps (\s -> s { dash_pattern = d })        + +-- | Set the dash pattern.+--+-- Initially the dash pattern is 'Solid'.+--+set_dash_pattern    :: DashPattern -> DrawingContextF+set_dash_pattern d  = updateStrokeProps (\s -> s { dash_pattern = d })         -unit_dash_pattern   :: DashPattern-unit_dash_pattern   = Dash 0 [(1,1)] --- oblivious-phase               :: Int -> DashPattern -> DashPattern-phase _ Solid       = Solid-phase i (Dash _ xs) = Dash i xs+-- | Set the dash_pattern to @solid@ - i.e. no dash pattern.+--+-- This is the default.+--+solid_line          :: DrawingContextF +solid_line          = set_dash_pattern Solid --- non-oblivious-dphase               :: Int -> DashPattern -> DashPattern-dphase _ Solid       = Solid-dphase d (Dash i xs) = Dash (i+d) xs+-- | Set the dash pattern to draw a dotted line.+-- +-- A dot is actually a square - side length is equal to the line +-- width.+-- +-- The spacing between dots is 2 times the dot width.+--+dotted_line         :: DrawingContextF +dotted_line         = set_dash_pattern $ Dash 0 [(1,2)] -doublegaps              :: DashPattern -> DashPattern-doublegaps Solid        = Solid-doublegaps (Dash i xs)  = Dash i (map fn xs)-  where-    fn (a,b) = (a,2*b)+-- | Set the dash pattern to draw a tightly packed dotted line.+-- +-- A dot is actually a square - side length is equal to the line +-- width.+-- +-- The spacing between dots is equal to the dot width.+--+packed_dotted       :: DrawingContextF +packed_dotted       = set_dash_pattern $ Dash 0 [(1,1)] -doubledashes              :: DashPattern -> DashPattern-doubledashes Solid        = Solid-doubledashes (Dash i xs)  = Dash i (map fn xs)-  where-    fn (a,b) = (a*2,b) +-- | Set the dash pattern to draw a loosely dotted line.+-- +-- A dot is actually a square - side length is equal to the line +-- width.+-- +-- The spacing between dots is 4 times the dot width.+--+loose_dotted        :: DrawingContextF +loose_dotted        = set_dash_pattern $ Dash 0 [(1,4)] --------------------------------------------------------------------------------- -fontAttr            :: FontFace -> Int -> DrawingContextF-fontAttr ff sz      = (\s -> s { font_props = FontAttr sz ff }) -fontFace            :: FontFace -> DrawingContextF-fontFace ff         = updateFontProps (\(FontAttr sz _) -> FontAttr sz ff)+-- | Set the dash pattern to draw a dashed line.+-- +-- The dash length is 3 times the line width, the spacing is 2+-- times the line width.+--+dashed_line        :: DrawingContextF+dashed_line        = set_dash_pattern $ Dash 0 [(3,2)] -fontSize            :: Int -> DrawingContextF-fontSize sz         = updateFontProps (\(FontAttr _ ff) -> FontAttr sz ff) +-- | Set the dash pattern to draw a tightly packed, dashed line.+-- +-- The dash length is 3 times the line width, the spacing is +-- equal to the line width.+--+packed_dashed      :: DrawingContextF+packed_dashed      = set_dash_pattern $ Dash 0 [(3,1)] ++-- | Set the dash pattern to draw a loosely dashed line.+-- +-- The dash length is 3 times the line width, the spacing is 4+-- times the line width.+--+loose_dashed      :: DrawingContextF+loose_dashed      = set_dash_pattern $ Dash 0 [(3,4)]+++ -------------------------------------------------------------------------------- -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 attributes, point size and font face.+--+font_attr               :: FontDef -> Int -> DrawingContextF+font_attr ft sz         = \s -> s { dc_font_size = sz+                                  , dc_font_face = font_def_face ft } --- | Set the font size to double the current size, note the font--- size also controls the size of dots, arrowsheads etc.+-- | Set the font face.+--+set_font                :: FontDef -> DrawingContextF+set_font ft             = \s -> s { dc_font_face = font_def_face ft }+++-- | Set the point size.+--+-- This controls the drawing size of both +-- text labels and marks (e.g. dots and arrowheads).+--+set_font_size           :: Int -> DrawingContextF+set_font_size sz        = \s -> s { dc_font_size = sz }+++-- | Scale the current point size by the supplied ratio. -- -doublesize          :: DrawingContextF-doublesize          = scalesize 2 +-- Note - as fonts can only be drawn at integral sizes this +-- operation is not exact - for instance scaling 15pt by (1%2) +-- results in 7pt.+-- +scale_point_size    :: Double -> DrawingContextF+scale_point_size a  = (\s sz -> set_font_size (floor $ a * fromIntegral sz) s) +                         <*> dc_font_size +-- | Set the point size (font and mark size) to double the current +-- size.+--+double_point_size   :: DrawingContextF+double_point_size   = scale_point_size 2  --- | Set the font size to half the current size, note the font++-- | Set the point size to half the current size, note the point -- size also controls the size of dots, arrowsheads etc. -- --- As fontsize is an integer this is not exact - half size of--- 15pt type is 7pt.+-- Note - as fonts can only be drawn at integral sizes this +-- operation is not exact - half size of 15pt type is 7pt. -- -halfsize            :: DrawingContextF-halfsize            = scalesize (1%2)+half_point_size     :: DrawingContextF+half_point_size     = scale_point_size 0.5  +-- | 'text_margin' : @ x_sep * y_sep -> DrawingContextF @+--+-- NOTE - ideally this would use Em or En rather thn Double...+--+text_margin   :: Em -> Em -> DrawingContextF+text_margin xsep ysep = \s -> +    s { dc_text_margin = TextMargin xsep ysep }+++-- | Set the text margin to (0,0).+-- +-- This produces a tight box around the text vertically measured +-- to the cap-height and descender. Therefore some characters may +-- extend outside the margin (e.g. accented capitals like +-- A-grave).+--+text_margin_none    :: DrawingContextF+text_margin_none    = text_margin 0 0 ++++-- | Set the text margin to (0.25 em, 0.25 em).+-- +text_margin_tight       :: DrawingContextF+text_margin_tight       = text_margin 0.25 0.25++-- | Set the text margin to (0.5 em, 0.5 em).+-- +text_margin_default :: DrawingContextF+text_margin_default = text_margin 0.5 0.5++-- | Set the text margin to (1.0 em, 1.0 em).+-- +text_margin_loose   :: DrawingContextF+text_margin_loose = text_margin 1.0 1.0++ -------------------------------------------------------------------------------- -swapColours :: DrawingContextF-swapColours = -    (\s a b -> s { stroke_colour = b, fill_colour = a })-        <*> stroke_colour <*> fill_colour+-- | Set the stroke colour.+--+stroke_colour :: RGBi -> DrawingContextF+stroke_colour rgb = \s -> s { dc_stroke_colour = rgb }  -bothStrokeColour :: DrawingContextF-bothStrokeColour = (\s a -> s { fill_colour = a }) <*> stroke_colour -bothFillColour :: DrawingContextF-bothFillColour = (\s a -> s { stroke_colour = a }) <*> fill_colour+-- | Set the fill colour.+--+fill_colour :: RGBi -> DrawingContextF+fill_colour rgb = \s -> s { dc_fill_colour = rgb }   +-- | Set the text colour.+--+text_colour          :: RGBi -> DrawingContextF+text_colour rgb      = (\s -> s { dc_text_colour = rgb}) -strokeColour :: RGBi -> DrawingContextF-strokeColour rgb = \s -> s { stroke_colour = rgb }   -fillColour :: RGBi -> DrawingContextF-fillColour rgb = \s -> s { fill_colour = rgb } +-- | Set the stroke, fill and text colours to a single colour.+--+single_colour :: RGBi -> DrawingContextF+single_colour rgb = stroke_colour rgb . fill_colour rgb . text_colour rgb   +-- | Swap the stroke colour and fill colours.+--+swap_colours :: DrawingContextF+swap_colours = +    (\s a b -> s { dc_stroke_colour = b, dc_fill_colour = a })+        <*> dc_stroke_colour <*> dc_fill_colour ++-- | Set the fill colour to use the current stroke colour.+--+fill_use_stroke_colour :: DrawingContextF+fill_use_stroke_colour = +    (\s a -> s { dc_fill_colour = a }) <*> dc_stroke_colour+++-- | Set the stroke colour to use the current fill colour.+--+stroke_use_fill_colour :: DrawingContextF+stroke_use_fill_colour = +    (\s a -> s { dc_stroke_colour = a }) <*> dc_fill_colour+++-- | Set the fill colour to use the current text colour.+--+fill_use_text_colour :: DrawingContextF+fill_use_text_colour = +    (\s a -> s { dc_fill_colour = a }) <*> dc_text_colour+++-- | Set the stroke colour to use the current fill colour.+--+stroke_use_text_colour :: DrawingContextF+stroke_use_text_colour = +    (\s a -> s { dc_stroke_colour = a }) <*> dc_text_colour++++-- | Set the text colour to use the current stroke colour.+--+text_use_stroke_colour :: DrawingContextF+text_use_stroke_colour = +    (\s a -> s { dc_text_colour = a }) <*> dc_stroke_colour+++-- | Set the text colour to use the current fill colour.+--+text_use_fill_colour :: DrawingContextF+text_use_fill_colour = +    (\s a -> s { dc_text_colour = a }) <*> dc_fill_colour++++--------------------------------------------------------------------------------+-- Connector props++-- helper +connectorUpd :: (ConnectorProps -> ConnectorProps) -> DrawingContextF+connectorUpd f = +   (\s a -> s { dc_connector_props = f a }) <*> dc_connector_props++-- | Normalize to zero if negative.+--+normZero :: (Num u, Ord u) => u -> u+normZero u = if u < 0 then 0 else u++-- | Set the connector source spacing.+--+-- The spacing is used as a projection along the line formed +-- between connector points making the connection /looser/ if +-- required.+-- +-- The default value is 0. Negative values are not allowed, they+-- are normalized to 0.+--+source_space :: (Ord u, InterpretUnit u) => u -> DrawingContextF+source_space u = withFontSize $ \sz -> +    connectorUpd (\s -> s { dc_conn_src_space = uconvert1 sz $ normZero u })+++-- | Set the connector destination spacing.+--+-- The spacing is used as a projection along the line formed +-- between connector points making the connection /looser/ if +-- required.+-- +-- The default value is 0. Negative values are not allowed, they+-- are normalized to 0.+--+dest_space :: (Ord u, InterpretUnit u) => u -> DrawingContextF+dest_space u = withFontSize $ \sz -> +    connectorUpd (\s -> s { dc_conn_dst_space = uconvert1 sz $ normZero u })++++-- | Set the connector source and destination spacings to the +-- same length.+--+uniform_conn_space :: (Ord u, InterpretUnit u) => u -> DrawingContextF+uniform_conn_space u = withFontSize $ \sz -> +    connectorUpd (\s -> s { dc_conn_src_space = uconvert1 sz $ normZero u+                          , dc_conn_dst_space = uconvert1 sz $ normZero u })++++-- | Set the connector source offset.+--+-- The offset is used to shift the start point /upwards/ +-- perpendicular to its true origin (negative values are +-- downwards). This can be used to draw a connector with two +-- parallel lines, for example.+--+-- Upwards and downwards in this description are dependent on the+-- direction of the line, of course. Generally the documentations +-- consider lines are left-to-right unless specifically noted.+--+source_offset :: (Ord u, InterpretUnit u) => u -> DrawingContextF+source_offset u = withFontSize $ \sz -> +    connectorUpd (\s -> s { dc_conn_src_offset = uconvert1 sz u })+++-- | Set the connector destination offset.+--+-- See 'source_offset' for an explanation.+--+dest_offset :: (Ord u, InterpretUnit u) => u -> DrawingContextF+dest_offset u = withFontSize $ \sz -> +    connectorUpd (\s -> s { dc_conn_dst_offset = uconvert1 sz u })+++-- | Set the connector arc angle.+--+conn_arc_angle :: Radian -> DrawingContextF+conn_arc_angle ang = +    connectorUpd (\s -> s { dc_conn_arc_ang = ang })+++-- | Set the connector source arm length.+--+source_arm_len :: InterpretUnit u => u -> DrawingContextF+source_arm_len u = withFontSize $ \sz -> +    connectorUpd (\s -> s { dc_conn_src_arm = uconvert1 sz u })+                       ++++-- | Set the connector destination arm length.+--+dest_arm_len :: InterpretUnit u => u -> DrawingContextF+dest_arm_len u = withFontSize $ \sz -> +    connectorUpd (\s -> s { dc_conn_dst_arm = uconvert1 sz u })+++++-- | Set the connector source and destination arms to the same +-- length.+--+uniform_arm_len :: InterpretUnit u => u -> DrawingContextF+uniform_arm_len u = withFontSize $ \sz -> +    connectorUpd (\s -> s { dc_conn_src_arm = uconvert1 sz u+                          , dc_conn_dst_arm = uconvert1 sz u })+++-- | Set the connector loop size.+--+conn_loop_size :: InterpretUnit u => u -> DrawingContextF+conn_loop_size u = withFontSize $ \sz -> +    connectorUpd (\s -> s { dc_conn_loop_size = uconvert1 sz u })++-- | Set the connector box halfsize.+--+conn_box_halfsize :: InterpretUnit u => u -> DrawingContextF+conn_box_halfsize u = withFontSize $ \sz -> +    connectorUpd (\s -> s { dc_conn_box_halfsize = uconvert1 sz u })

@@ -1,39 +1,36 @@ {-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeSynonymInstances       #-}-{-# LANGUAGE FlexibleInstances          #-} {-# OPTIONS -Wall #-}  -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.Kernel.Base.WrappedPrimitive--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2010-2011 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com -- Stability   :  highly unstable -- Portability :  GHC  ----- Two /warpped/ versions of the Primitive type from Wumpus-Core.+-- Wrapped versions of the @Primitive@ type from Wumpus-Core. -- --------------------------------------------------------------------------------  module Wumpus.Basic.Kernel.Base.WrappedPrimitive   ( ++   -- * Primitives-    HPrim+    CatPrim+  , prim1+  , cpmap++  , HPrim   , hprimToList   , singleH -  -- * Collect primitives (writer monad) -  , TraceM(..) -  , PrimGraphic -  , getPrimGraphic-  , primGraphic-  , metamorphPrim-  , collectH    ) where @@ -47,24 +44,57 @@   --- As of version 0.36.0, Wumpus-Core supports grouping primitives--- together (a common operation in vector drawing editors). ------ For Wumpus-Basic this means e.g. a line with arrowheads can --- still be a primitive.------ Still, we wrap Primitive as a newtype...+-- | CatPrim could probably manage happily just being a+-- Primitive, but it is wrapped as a newtype... --+data CatPrim = CZero+             | Cat1 Primitive -newtype PrimGraphic u = PrimGraphic { getPrimGraphic :: Primitive u }-  deriving (Eq,Show)+type instance DUnit CatPrim = Double +instance OPlus CatPrim where+  CZero  `oplus` b      = b+  a      `oplus` CZero  = a+  Cat1 a `oplus` Cat1 b = Cat1 $ a `primCat` b -type instance DUnit (PrimGraphic u) = u +instance Monoid CatPrim where+  mempty                  = CZero+  CZero  `mappend` b      = b+  a      `mappend` CZero  = a+  Cat1 a `mappend` Cat1 b = Cat1 $ a `primCat` b  + --------------------------------------------------------------------------------++instance Rotate CatPrim where+  rotate _   CZero              = CZero+  rotate ang (Cat1 a)           = Cat1 $ rotate ang a++instance RotateAbout CatPrim where+  rotateAbout _   _  CZero      = CZero+  rotateAbout ang pt (Cat1 a)   = Cat1 $ rotateAbout ang pt a++instance Scale CatPrim where+  scale _  _  CZero             = CZero+  scale sx sy (Cat1 a)          = Cat1 $ scale sx sy a++instance Translate CatPrim where+  translate _  _  CZero         = CZero+  translate dx dy (Cat1 a)      = Cat1 $ translate dx dy a+++--------------------------------------------------------------------------------++prim1 :: Primitive -> CatPrim +prim1 = Cat1++cpmap :: (Primitive -> Primitive) -> CatPrim -> CatPrim+cpmap _ CZero    = CZero+cpmap f (Cat1 a) = Cat1 $ f a++-------------------------------------------------------------------------------- -- Lists of primitives...  -- | Graphics objects, even simple ones (line, arrow, dot) might @@ -81,8 +111,13 @@ -- representation, and a Hughes list which supports -- efficient concatenation is wise. ---newtype HPrim u = HPrim { getHPrim :: H (Primitive u) }+-- NOTE - currently HPrim has a phantom unit @u@, this is so +-- trace drawings can have a unit type, but this may change as +-- perhaps trace drawings don\'t benefit from having units.+-- +newtype HPrim u = HPrim { getHPrim :: H Primitive }+ -- Note - only a Monoid instance for HPrim - they cannot be  -- shown, fmapped etc. @@ -91,59 +126,16 @@   ha `mappend` hb = HPrim $ getHPrim ha `appendH` getHPrim hb  -hprimToList :: HPrim u -> [Primitive u]+hprimToList :: HPrim u -> [Primitive] hprimToList = toListH . getHPrim  -singleH :: Primitive u -> HPrim u-singleH = HPrim . wrapH --------------------------------------------------------------------------------------- | Collect elementary graphics as part of a larger drawing.------ TraceM works much like a writer monad.----class TraceM (m :: * -> *) where-  trace  :: MonUnit m ~ u => HPrim u -> m ()+singleH :: CatPrim -> HPrim u+singleH CZero    = HPrim emptyH+singleH (Cat1 a) = HPrim $ wrapH a     ------------------------------------------------------------------------------------ instances--instance OPlus (PrimGraphic u) where-  oplus a b = PrimGraphic $ getPrimGraphic a `oplus` getPrimGraphic b----- Affine transformations--instance (Real u, Floating u) => Rotate (PrimGraphic u) where-  rotate ang = PrimGraphic . rotate ang . getPrimGraphic---instance (Real u, Floating u) => RotateAbout (PrimGraphic u) where-  rotateAbout ang pt = PrimGraphic . rotateAbout ang pt . getPrimGraphic---instance Num u => Scale (PrimGraphic u) where-  scale sx sy = PrimGraphic . scale sx sy . getPrimGraphic---instance Num u => Translate (PrimGraphic u) where-  translate dx dy = PrimGraphic . translate dx dy . getPrimGraphic------------------------------------------------------------------------------------primGraphic :: Primitive u -> PrimGraphic u -primGraphic = PrimGraphic--metamorphPrim :: (Primitive u -> Primitive u) -> PrimGraphic u -> PrimGraphic u-metamorphPrim f = primGraphic . f . getPrimGraphic--collectH :: PrimGraphic u -> HPrim u-collectH = singleH . getPrimGraphic 

@@ -0,0 +1,230 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Objects.AdvObject+-- Copyright   :  (c) Stephen Tetley 2010-2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Extended Graphic object - an AdvanceGraphic is a Graphic +-- twinned with and advance vector.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Objects.AdvObject+  (++  -- * Advance-vector object and graphic+    AdvObject+  , DAdvObject+  +  , AdvGraphic+  , DAdvGraphic++  , makeAdvObject+  , emptyAdvObject++  , runAdvObjectR0+  , runAdvObjectR1+++  -- * Composition+  , advance+  , advances+  , advspace+  , evenspace++  , advrepeat+  , punctuate+  , advfill++  ) where++import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Base.ContextFun+import Wumpus.Basic.Kernel.Objects.Basis+import Wumpus.Basic.Kernel.Objects.Displacement+import Wumpus.Basic.Kernel.Objects.Image+import Wumpus.Basic.Kernel.Objects.LocImage++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space+import Data.VectorSpace++import Control.Applicative+import Data.Monoid++++type AdvDraw u = Point2 u -> GraphicAns u+++-- | /Advance vector/ graphic - this partially models the +-- PostScript @show@ command which moves the /current point/ by the+-- advance (width) vector as each character is drawn.+--+newtype AdvObject u = AdvObject { getAdvObject :: CF (Vec2 u, AdvDraw u) }++type instance DUnit (AdvObject u) = u++type DAdvObject     = AdvObject Double+++type AdvGraphic u       = LocImage u (Vec2 u)+type DAdvGraphic        = AdvGraphic Double+++--------------------------------------------------------------------------------++instance (InterpretUnit u) => Monoid (AdvObject u) where+  mempty  = emptyAdvObject+  mappend = advplus+++-- | 'makeAdvObject' : @ loc_context_function * graphic -> AdvObject @+--+-- Build an 'AdvObject' from a context function ('CF') that +-- generates the answer displacement vector and a 'LocGraphic' +-- that draws the 'AdvObject'.+--+makeAdvObject :: Query (Vec2 u) -> LocGraphic u -> AdvObject u+makeAdvObject qvec gf = AdvObject body+  where+    body = drawingCtx >>= \ctx -> +           let v1   = runCF ctx qvec+               pf   = runCF ctx gf+           in return (v1,pf)++++-- | 'emptyAdvObjectAU' : @ AdvObject @+--+-- Build an empty 'AdvObject'.+-- +-- The 'emptyAdvObject' is treated as a /null primitive/ by +-- @Wumpus-Core@ and is not drawn, the answer vector generated is+-- the zero vector @(V2 0 0)@.+-- +emptyAdvObject :: InterpretUnit u => AdvObject u+emptyAdvObject = makeAdvObject (pure $ V2 0 0) emptyLocGraphic++++runAdvObjectR0 :: Point2 u -> AdvObject u -> Image u (Vec2 u)+runAdvObjectR0 pt (AdvObject mf) =  +   (\(v1,pf) -> replaceAns v1 $ pf pt) <$> mf+++runAdvObjectR1 :: AdvObject u -> AdvGraphic u+runAdvObjectR1 (AdvObject mf) = promoteR1 $ \pt -> +   (\(v1,pf) -> replaceAns v1 $ pf pt) <$> mf+++--------------------------------------------------------------------------------+-- Combining AdvObjects++++-- | Primitive combination.+-- +-- Move second object by the advance vector of the first. Sum +-- both advance vecots.+--+advplus :: Num u => AdvObject u -> AdvObject u -> AdvObject u+advplus a b = AdvObject body+  where +    body = drawingCtx >>= \ctx ->+           let (v0,pf0) = runCF ctx (getAdvObject a)+               (v1,pf1) = runCF ctx (getAdvObject b)+               pf       = \pt -> pf0 pt `oplus` pf1 (pt .+^ v0)+           in return (v0 ^+^ v1, pf)++-- Helper for list concatenation.+-- +listcat :: InterpretUnit u +        => (AdvObject u -> AdvObject u -> AdvObject u)+        -> [AdvObject u] -> AdvObject u+listcat _ []     = emptyAdvObject+listcat op (x:xs) = go x xs+  where+    go acc []     = acc+    go acc (b:bs) = go (acc `op` b) bs++++-- AdvObject does not have the same ability to be concatenated+-- as PosObject - all the advance vector says is \"where to go +-- next\". Nothing in the AdvObject tracks the boundary so we+-- cannot implement the Concat classes.++infixr 6 `advance`+++-- | Draw the first AdvObject and use the advance vector to +-- displace the second AdvObject.+--+-- The final answer is the sum of both advance vectors.+--+advance :: Num u => AdvObject u -> AdvObject u -> AdvObject u+advance = advplus+  ++-- | Concatenate the list of AdvObjects with 'advance'.+--+advances :: InterpretUnit u => [AdvObject u] -> AdvObject u+advances = listcat advance+++-- | Combine the AdvObjects using the answer vector of the +-- first object plus the separator to move the start of the second+-- object. +--+advspace :: Num u => Vec2 u -> AdvObject u -> AdvObject u -> AdvObject u+advspace sep a b = AdvObject body+  where +    body = drawingCtx >>= \ctx ->+           let (v0,pf0) = runCF ctx (getAdvObject a)+               (v1,pf1) = runCF ctx (getAdvObject b)+               pf       = \pt -> pf0 pt `oplus` pf1 (displaceVec (sep ^+^ v0) pt)+           in return (v0 ^+^ sep ^+^ v1, pf)++-- | List version of 'nextSpace'.+--+evenspace :: InterpretUnit u => Vec2 u -> [AdvObject u] -> AdvObject u+evenspace v = listcat (advspace v)++++-- | Repeat the AdvObject @n@ times, moving each time with +-- 'advance'.+--+advrepeat :: InterpretUnit u => Int -> AdvObject u -> AdvObject u+advrepeat n = advances . replicate n+++-- | Concatenate the list of AdvObjects, going next and adding+-- the separator at each step.+--+punctuate :: InterpretUnit u => AdvObject u -> [AdvObject u] -> AdvObject u+punctuate sep =  listcat (\a b -> a `advance` sep `advance` b)++++-- | Render the supplied AdvObject, 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 -> AdvObject u -> AdvObject u+advfill sv a = AdvObject body+  where +    body = drawingCtx >>= \ctx ->+           let (_,pf) = runCF ctx (getAdvObject a) in return (sv, pf)+++

@@ -1,166 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeSynonymInstances       #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Kernel.Objects.AdvanceGraphic--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  highly unstable--- Portability :  GHC ------ Extended Graphic object - an AdvanceGraphic is a Graphic --- twinned with and advance vector.--------------------------------------------------------------------------------------module Wumpus.Basic.Kernel.Objects.AdvanceGraphic-  (--  -- * Advance-vector graphic-    AdvGraphic-  , DAdvGraphic---  , intoAdvGraphic-  , emptyAdvGraphic---  -- * Composition-  , advcat-  , advsep-  , advconcat-  , advspace-  , advpunctuate-  , advfill--  ) 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 Data.AffineSpace                         -- package: vector-space-import Data.VectorSpace------ | /Advance vector/ graphic - this partially models the --- PostScript @show@ command which moves the /current point/ by the--- advance (width) vector as each character is drawn.----type AdvGraphic u      = LocImage u (Vec2 u)--type DAdvGraphic       = AdvGraphic Double------------------------------------------------------------------------------------------- | 'intoAdvGraphic' : @ loc_context_function * graphic -> Image @------ 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-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------ runAdvGraphic :: DrawingContext  -> Point2 u -> AdvGraphic u ---               -> (Point2 u, PrimGraphic u)--- runAdvGraphic ctx pt df = runCF1 ctx pt df--------------------------------------------------------------------------------------- composition---- Note there are opportunities for extra composition operators--- like the /picture language/...----- Naming convention - binary functions are favoured for shorter names.--infixr 6 `advcat`-infixr 5 `advsep`---- | Concatenate the two AdvGraphics.----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 []     = 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

@@ -0,0 +1,233 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE KindSignatures             #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Objects.Anchors+-- Copyright   :  (c) Stephen Tetley 2010-2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Anchor points on shapes, bounding boxes, etc.+--+-- Anchors are addressable positions, an examplary use is taking+-- anchors on node shapes to get the start and end points for +-- connectors in a network (graph) diagram.+-- +-- \*\* 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.Objects.Anchors+  ( ++  -- * Anchors+    Anchor++  -- * Anchor classes+  , CenterAnchor(..)+  , ApexAnchor(..)+  , CardinalAnchor(..)+  , CardinalAnchor2(..)+  , RadialAnchor(..)+  , TopCornerAnchor(..)+  , BottomCornerAnchor(..)+  , SideMidpointAnchor(..)+++  -- * Extended anchor points+  , projectAnchor++  , radialConnectorPoints++  ) where+++import Wumpus.Core                      -- package: wumpus-core++import Data.AffineSpace                 -- package: vector-space+++-- | Note an Anchor is just a Point2.+--+type Anchor u = Point2 u+++-- | Center of an object.+--+class CenterAnchor a where+  center :: u ~ DUnit a => a -> Anchor u+++-- | Apex of an object.+--+class ApexAnchor a where+  apex :: u ~ DUnit a => a -> Anchor u+++-- | Cardinal (compass) positions on an object. +-- +-- Cardinal anchors should be at their equivalent radial position.+-- However, some shapes may not be able to easily define radial +-- positions or may be able to provide more efficient definitions +-- for the cardinal anchors. Hence the redundancy seems justified. +--+class CardinalAnchor a where+  north :: u ~ DUnit a => a -> Anchor u+  south :: u ~ DUnit a => a -> Anchor u+  east  :: u ~ DUnit a => a -> Anchor u+  west  :: u ~ DUnit a => a -> Anchor 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+-- for the diagonal positions. +-- +-- 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 +-- problematic, hence the compass points are split into two +-- classes.+--+class CardinalAnchor2 a where+  northeast :: u ~ DUnit a => a -> Anchor u+  southeast :: u ~ DUnit a => a -> Anchor u+  southwest :: u ~ DUnit a => a -> Anchor u+  northwest :: u ~ DUnit a => a -> Anchor u+++-- | Anchor on a border that can be addressed by an angle.+--+-- The angle is counter-clockwise from the right-horizontal, i.e.+-- 0 is /east/.+--+class RadialAnchor a where+  radialAnchor :: Radian -> u ~ DUnit a => a -> Anchor u+++-- | Anchors at the top left and right corners of a shape.+--+-- 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...+--+class TopCornerAnchor a where+  topLeftCorner  :: u ~ DUnit a => a -> Anchor u+  topRightCorner :: u ~ DUnit a => a -> Anchor u+++-- | Anchors at the bottom left and right corners of a shape.+--+class BottomCornerAnchor a where+  bottomLeftCorner  :: u ~ DUnit a => a -> Anchor u+  bottomRightCorner :: u ~ DUnit a => a -> Anchor u+++-- | Anchors in the center of a side.+-- +-- 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.+-- +-- Implementations are also expected to modulo the side number, +-- rather than throw an out-of-bounds error.+--+class SideMidpointAnchor a where+  sideMidpoint :: Int -> u ~ DUnit a => a -> Anchor u++++--------------------------------------------------------------------------------++-- | 'projectAnchor' : @ extract_func * 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@.+-- +-- E.g. take the north of a rectangle and project it 10 units +-- further on:+--  +-- > projectAnchor north 10 my_rect+--+-- If the distance is zero the answer with be whatever point the +-- the extraction function produces.+--+-- 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, CenterAnchor a, u ~ DUnit a) +              => (a -> Anchor u) -> u -> a -> Anchor u+projectAnchor fn d a = p1 .+^ (avec (vdirection v) d)+  where+    p1  = fn a +    v   = pvec (center a) p1 +     +++--------------------------------------------------------------------------------++-- | 'radialConnectorPoints' : @ object_a * object_b -> (Point_a, Point_b) @+--+-- Find the radial connectors points for objects @a@ and @b@ along+-- the line joining their centers.+--+radialConnectorPoints :: ( Real u, Floating u+                         , CenterAnchor a, RadialAnchor a+                         , CenterAnchor b, RadialAnchor b+                         , u ~ DUnit a, u ~ DUnit b) +                      => a -> b -> (Point2 u, Point2 u) +radialConnectorPoints a b = (radialAnchor ang a, radialAnchor (ang+pi) b)+  where+    ang = vdirection $ pvec (center a) (center b)+     +    ++--------------------------------------------------------------------------------+-- Instances ++instance Fractional u => CenterAnchor (BoundingBox u) where+  center (BBox (P2 xl ylo) (P2 xr yhi)) = P2 x y +     where+       x = xl+0.5*(xr-xl)+       y = ylo+0.5*(yhi-ylo)+       ++instance Fractional u => CardinalAnchor (BoundingBox u) where+  north (BBox (P2 xl _  ) (P2 xr yhi)) = P2 (xl+0.5*(xr-xl)) yhi+  south (BBox (P2 xl ylo) (P2 xr _  )) = P2 (xl+0.5*(xr-xl)) ylo+  east  (BBox (P2 _  ylo) (P2 xr yhi)) = P2 xr (ylo+0.5*(yhi-ylo))+  west  (BBox (P2 xl ylo) (P2 _  yhi)) = P2 xl (ylo+0.5*(yhi-ylo))+++instance Fractional u => CardinalAnchor2 (BoundingBox u) where+  northeast (BBox _ ur)                 = ur+  southeast (BBox (P2 _ ylo) (P2 xr _)) = P2 xr ylo+  southwest (BBox ll _)                 = ll+  northwest (BBox (P2 xl _) (P2 _ yhi)) = P2 xl yhi +

@@ -1,186 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeSynonymInstances       #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Kernel.Objects.BaseObjects--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  highly unstable--- Portability :  GHC ------ Aliases for ContextFun types.--- -----------------------------------------------------------------------------------module Wumpus.Basic.Kernel.Objects.BaseObjects-  (--  -- * Drawing info-    DrawingInfo-  , LocDrawingInfo-  , LocThetaDrawingInfo---  -  -- * Drawing objects-  , ImageAns-  , GraphicAns--  , Image-  , LocImage-  , LocThetaImage--  , DImage-  , DLocImage-  , DLocThetaImage--  ) where--import Wumpus.Basic.Kernel.Base.ContextFun-import Wumpus.Basic.Kernel.Base.WrappedPrimitive--import Wumpus.Core                              -- package: wumpus-core------------------------------------------------------------------------------------- DrawingInfo---- | A query on the DrawingContext.------ Alias for 'CF'.--- -type DrawingInfo a      = CF a----- | A query on the DrawingContext respective to the supplied---  point.------ Alias for 'LocCF'.--- -type LocDrawingInfo u a   = LocCF u a----- | A query on the DrawingContext respective to the supplied---  point and angle.------ Alias for 'LocCF'.--- -type LocThetaDrawingInfo u a   = LocThetaCF u a---------------------------------------------------------------------------------------- Image----- | An Image always returns a pair of some polymorphic answer @a@--- and a PrimGraphic.------ Note a PrimGraphic cannot be empty.--- -type ImageAns u a       = (a, PrimGraphic u)---type GraphicAns u       = ImageAns u (UNil u)----- | Draw a PrimGraphic repsective to the 'DrawingContext' and --- return some answer @a@.--- -type Image u a      = CF (ImageAns u a)----- | Draw a PrimGraphic respective to the 'DrawingContext' and --- the supplied point, return some answer @a@.--- -type LocImage u a   = LocCF u (ImageAns u a)----- | Draw a PrimGraphic respective to the 'DrawingContext' and--- the supplied point and angle.--- -type LocThetaImage u a   = LocThetaCF u (ImageAns u a)----type DImage a            = Image Double a-type DLocImage a         = LocImage Double a-type DLocThetaImage a    = LocThetaImage Double a---type instance DUnit (Image u a) = u -- GuardEq (DUnit a) (DUnit (PrimGraphic u))--type instance DUnit (LocImage u a) = u --  GuardEq (DUnit a) (DUnit (PrimGraphic u))--type instance DUnit (LocThetaImage u a) = u--------------------------------------------------------------------------------------- Affine instances---- Note - it seems better to have these instances for Image (even --- though Image is a type synonym) rather than more general --- instances on a CF.------ There is nothing determining a DUnit for the CF types.------ The downside is these instances are effectively orphan --- instances.-----instance (Real u, Floating u, Rotate a, DUnit a ~ u) => -    Rotate (Image u a) where-  rotate ang = fmap (rotate ang)---instance (Real u, Floating u, RotateAbout a, DUnit a ~ u) => -    RotateAbout (Image u a) where-  rotateAbout ang pt = fmap (rotateAbout ang pt)---instance (Num u, Scale a, DUnit a ~ u) => Scale (Image u a) where-  scale sx sy = fmap (scale sx sy)---instance (Num u, Translate a, DUnit a ~ u) => Translate (Image u a) where-  translate dx dy = fmap (translate dx dy)----- \*\* WARNING \*\* - I am not sure having affine instances for --- LocImage makes sense...------ Particularly, what is a rotateAbout on a function from Point to --- Graphic? Is it just a post-transformation, or should the start --- point be transformed as well.-----instance (Real u, Floating u, Rotate a, DUnit a ~ u) => -    Rotate (LocImage u a) where-  rotate ang = fmap (rotate ang)--instance (Real u, Floating u, RotateAbout a, DUnit a ~ u) => -    RotateAbout (LocImage u a) where-  rotateAbout ang pt = fmap (rotateAbout ang pt)---instance (Num u, Scale a, DUnit a ~ u) => Scale (LocImage u a) where-  scale sx sy = fmap (scale sx sy)---instance (Num u, Translate a, DUnit a ~ u) => Translate (LocImage u a) where-  translate dx dy = fmap (translate dx dy)------------------------------------------------------------------------------------------

@@ -0,0 +1,564 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Objects.Basis+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Common types and operations.+-- +--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Objects.Basis+  (++    LocQuery+  , LocThetaQuery+  , ConnectorQuery ++  , GraphicAns+  , ImageAns(..)++  , graphicAns+  , mapAns+  , replaceAns+  , ignoreAns+  , answer+  , hyperlink  +  , clipObject +  +  , szconvAnsF+  , szconvAnsZ+++  , at+  , incline+  , atIncline+  , connect++  , replaceAnsR0+  , replaceAnsR1+  , replaceAnsR2++  , decorateR0+  , decorateR1+  , decorateR2++  , elaborateR0+  , elaborateR1+  , elaborateR2+  ++  ) where++import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Base.ContextFun+import Wumpus.Basic.Kernel.Base.WrappedPrimitive++import Wumpus.Core                              -- package: wumpus-core+++import Control.Applicative+import Data.Monoid+++type LocQuery u a               = CF (Point2 u -> a)+type LocThetaQuery u a          = CF (Point2 u -> Radian -> a)+type ConnectorQuery u a         = CF (Point2 u -> Point2 u -> a)+++-- Design note - GraphicAns needs a unit for consistency even +-- though it is never scrutinized.+-- +++data ImageAns u a = Ans CatPrim a++type GraphicAns u = ImageAns u (UNil u)++++type instance DUnit (ImageAns u a) = u+++--------------------------------------------------------------------------------+-- OPlus and monoid+++instance OPlus a => OPlus (ImageAns u a) where+  Ans cp0 a `oplus` Ans cp1 b = Ans (cp0 `oplus` cp1) (a `oplus` b)+++instance Monoid a => Monoid (ImageAns u a) where+  mempty                        = Ans mempty mempty+  Ans cp0 a `mappend` Ans cp1 b = Ans (cp0 `mappend` cp1) (a `mappend` b)+++--------------------------------------------------------------------------------+-- Affine instances ++-- +-- Design Note+--+-- Translate and RotateAbout require the unit to be /scalar/ +-- e.g. Double, Centimeter, Pica.+--+-- This is annoying and a limitation, but an alternative would+-- need access to current-font-size which cannot be a pure +-- function.+-- ++instance Rotate a => Rotate (ImageAns u a) where+  rotate ang (Ans cp a) = Ans (rotate ang cp) (rotate ang a)+++instance (RotateAbout a, ScalarUnit u, u ~ DUnit a) => +    RotateAbout (ImageAns u a) where+  rotateAbout ang pt@(P2 x y) (Ans cp a) = +    Ans (rotateAbout ang (P2 (toPsPoint x) (toPsPoint y)) cp)+        (rotateAbout ang pt a) +        +++instance Scale a => Scale (ImageAns u a) where+  scale sx sy (Ans cp a) = Ans (scale sx sy cp) (scale sx sy a)+++instance (Translate a, ScalarUnit u, u ~ DUnit a) => +    Translate (ImageAns u a) where+  translate dx dy (Ans cp a) = +    Ans (translate (toPsPoint dx) (toPsPoint dy) cp) (translate dx dy a) +++--------------------------------------------------------------------------------++++-- | Map the answer produced by a graphic object.+--+-- Note - the new answer must share the same unit type as the+-- initial answer, although it does not need to have the same+-- wrapper type.+--+mapAns :: (a -> a1) -> ImageAns u a -> ImageAns u a1+mapAns f (Ans cp a) = Ans cp (f a) ++++-- | Replace the answer produced by a graphic object.+--+-- Note - the new answer must share the same unit type as the+-- initial answer, although it does not need to have the same+-- wrapper type.+--+replaceAns :: ans -> ImageAns u a -> ImageAns u ans+replaceAns ans (Ans prim _) = Ans prim ans+++-- | Turn an imageAns into a GraphicAns by ignoring the +-- result.+-- +-- Usually this function will be used with one of the @push@ +-- family of combinators.+--+-- > LocImage-to-LocGraphic = pushR1 ignoreAns +--+ignoreAns :: ImageAns u a -> GraphicAns u+ignoreAns(Ans prim _) = Ans prim UNil++++graphicAns :: CatPrim -> GraphicAns u+graphicAns prim = Ans prim UNil++-- | Extractor for the answer part of an image.+--+answer :: ImageAns u a -> a+answer (Ans _ a) = a+++-- | Note - maybe this requires an arity family instead?+--+hyperlink :: XLink -> ImageAns u a -> ImageAns u a+hyperlink hypl (Ans prim a) = Ans (cpmap (xlinkPrim hypl) prim) a+++-- | Clip a graphic object.+-- +-- Note - maybe this requires an arity family instead?+--+clipObject :: PrimPath -> ImageAns t u -> ImageAns t u+clipObject pp (Ans prim a) =  Ans (cpmap (clip pp) prim) a+++--------------------------------------------------------------------------------+-- Helpers for unit conversion...++++szconvAnsF :: (Functor t, InterpretUnit u, InterpretUnit u1) +                => FontSize -> ImageAns u (t u) -> ImageAns u1 (t u1)+szconvAnsF sz (Ans prim a) = Ans prim (uconvertF sz a)++szconvAnsZ :: FontSize -> ImageAns u a -> ImageAns u1 a+szconvAnsZ _ (Ans prim a) = Ans prim a++++infixr 1 `at`+++-- | Downcast a 'LocCF' function by applying it to the supplied +-- point, making an arity-zero Context Function. +-- +-- Remember a 'LocCF' function is a 'CF1' context function where+-- the /static argument/ is specialized to a start point.+--+at :: LocQuery u a -> Point2 u -> CF a+at = apply1R1++++infixr 1 `incline`+++-- | Downcast a 'LocThetaQuery' function by applying it to the +-- supplied angle, making an arity-one Context Function (a +-- 'LocCF'). +-- +incline :: LocThetaQuery u a -> Radian -> LocQuery u a+incline = apply1R2+++-- | Downcast a LocThetaQuery function by applying it to the +-- supplied point and angle, making an arity-zero Context Function +-- (a CF). +--+atIncline :: LocThetaQuery u a -> Point2 u -> Radian -> CF a+atIncline = apply2R2+++-- | Downcast a 'ConnectorQuery' function by applying it to the +-- start and end point, making an arity-zero Context Function +-- (a 'CF'). +-- +connect :: ConnectorQuery u a -> Point2 u -> Point2 u -> CF a+connect = apply2R2++++-- | Replace the ans - arity 0.+-- +replaceAnsR0 :: ans -> CF (ImageAns u a) -> CF (ImageAns u ans)+replaceAnsR0 ans = fmap (replaceAns ans)+++-- | Replace the ans - arity 1.+--+replaceAnsR1 :: ans -> CF (r1 -> ImageAns u a) -> CF (r1 -> ImageAns u ans)+replaceAnsR1 ans = fmap $ fmap (replaceAns ans)+++-- | Replace the ans - arity 2.+--+replaceAnsR2 :: ans +             -> CF (r1 -> r2 -> ImageAns u a) +             -> CF (r1 -> r2 -> ImageAns u ans)+replaceAnsR2 ans = fmap $ fmap $ fmap (replaceAns ans) +++-- | Decorate an Image by superimposing a Graphic.+--+-- Note - this function has a very general type signature and+-- supports various graphic types:+--+decorateR0 :: CF (ImageAns u a) -> CF (GraphicAns u) -> CF (ImageAns u a) +decorateR0 img gf = op <$> img <*> gf+  where+    op (Ans cp a) (Ans cp1 _) = Ans (cp `oplus` cp1) a+++decorateR1 :: CF (r1 -> ImageAns u a) +           -> CF (r1 -> GraphicAns u) +           -> CF (r1 -> ImageAns u a) +decorateR1 img gf = promoteR1 $ \r1 ->+    op <$> apply1R1 img r1 <*> apply1R1 gf r1+  where+    op (Ans cp a) (Ans cp1 _) = Ans (cp `oplus` cp1) a+++decorateR2 :: CF (r1 -> r2 -> ImageAns u a) +           -> CF (r1 -> r2 -> GraphicAns u) +           -> CF (r1 -> r2 -> ImageAns u a) +decorateR2 img gf = promoteR2 $ \r1 r2 ->+    op <$> apply2R2 img r1 r2 <*> apply2R2 gf r1 r2+  where+    op (Ans cp a) (Ans cp1 _) = Ans (cp `oplus` cp1) a+++-- | Decorate an Image by superimposing a Graphic.+--+-- Note - this function has a very general type signature and+-- supports various graphic types:+--+elaborateR0 :: CF (ImageAns u a) -> (a -> CF (GraphicAns u)) -> CF (ImageAns u a) +elaborateR0 img gf = +    img  >>= \(Ans p1 a) ->+    gf a >>= \(Ans p2 _) -> +    return $ Ans (p1 `oplus` p2) a+++++-- | Decorate an Image by superimposing a Graphic.+--+-- Note - this function has a very general type signature and+-- supports various graphic types:+--+elaborateR1 :: CF (r1 -> ImageAns u a) +            -> (a -> CF (r1 -> GraphicAns u)) +            -> CF (r1 -> ImageAns u a) +elaborateR1 img gf = promoteR1 $ \r1 -> +    apply1R1 img r1    >>= \(Ans p1 a) ->+    apply1R1 (gf a) r1 >>= \(Ans p2 _) -> +    return $ Ans (p1 `oplus` p2) a++++elaborateR2 :: CF (r1 -> r2 -> ImageAns u a) +            -> (a -> CF (r1 -> r2 -> GraphicAns u)) +            -> CF (r1 -> r2 -> ImageAns u a) +elaborateR2 img gf = promoteR2 $ \r1 r2 -> +    apply2R2 img r1 r2    >>= \(Ans p1 a) ->+    apply2R2 (gf a) r1 r2 >>= \(Ans p2 _) -> +    return $ Ans (p1 `oplus` p2) a+++++{-++-- Not exported - thanks to Max Bollingbroke.+--+type family   GuardEqAns a b :: *+type instance GuardEqAns a a = a++-- | An Image always returns a pair of some polymorphic answer @a@+-- and a PrimGraphic.+--+data ImageAns t u       = Ans (t u) CatPrim++type instance DUnit (ImageAns t u) = GuardEqAns u (DUnit (t u))++type GraphicAns u       = ImageAns UNil u+++instance Functor t => Functor (ImageAns t) where+  fmap f (Ans a prim) = Ans (fmap f a) prim++instance OPlus (t u) => OPlus (ImageAns t u) where+  Ans a p1 `oplus` Ans b p2 = Ans (a `oplus` b) (p1 `oplus` p2)+++--------------------------------------------------------------------------------+-- Affine instances ++-- +-- Design Note+--+-- Translate and RotateAbout require the unit to be /scalar/ +-- e.g. Double, Centimeter, Pica.+--+-- This is annoying and a limitation, but an alternative would+-- need access to current-font-size which cannot be a pure +-- function.+-- ++instance Rotate (t u) => Rotate (ImageAns t u) where+  rotate ang (Ans a p) = Ans (rotate ang a) (rotate ang p)+++instance (RotateAbout (t u), ScalarUnit u, u ~ DUnit (t u)) => +    RotateAbout (ImageAns t u) where+  rotateAbout ang pt@(P2 x y) (Ans a p) = +    Ans (rotateAbout ang pt a) +        (rotateAbout ang (P2 (toPsPoint x) (toPsPoint y)) p)+++instance Scale (t u) => Scale (ImageAns t u) where+  scale sx sy (Ans a p) = Ans (scale sx sy a) (scale sx sy p)+++instance (Translate (t u), ScalarUnit u, u ~ DUnit (t u)) => +    Translate (ImageAns t u) where+  translate dx dy (Ans a p) = +    Ans (translate dx dy a) (translate (toPsPoint dx) (toPsPoint dy) p)+++--------------------------------------------------------------------------------+++-- | Ignore the answer produced by an Image (or LocImage, etc.)+-- and form a Graphic instead.+--+ignoreAns :: Functor f+          => cf (ImageAns t u) -> cf (GraphicAns u)+ignoreAns = fmap (\(Ans _ prim) -> Ans UNil prim)++++-- | Replace the answer produced by a graphic object.+--+-- Note - the new answer must share the same unit type as the+-- initial answer, although it does not need to have the same+-- wrapper type.+--+replaceAns :: Functor cf+          => t1 u -> cf (ImageAns t u) -> cf (ImageAns t1 u)+replaceAns ans = fmap (\(Ans _ prim) -> Ans ans prim)+++-- | Map the answer produced by a graphic object.+--+-- Note - the new answer must share the same unit type as the+-- initial answer, although it does not need to have the same+-- wrapper type.+--+mapAns :: Functor cf+       => (t u -> t1 u) -> cf (ImageAns t u) -> cf (ImageAns t1 u)+mapAns f = fmap (trafoImageAns f id) ++++-- | Transform both the answer produced by a graphic object and +-- transform the primitive drawing.+--+-- Note - the new answer must share the same unit type as the+-- initial answer, although it does not need to have the same+-- wrapper type. Also this function is specifically exposed to+-- enable affine transofrmations - it is not expected to be +-- generally useful.+--+trafoImageAns :: (t u -> t1 u) -> (CatPrim -> CatPrim) +              -> ImageAns t u -> ImageAns t1 u+trafoImageAns f g (Ans a prim) = Ans (f a) (g prim)+++-- | Decorate an Image by superimposing a Graphic.+--+-- Note - this function has a very general type signature and+-- supports various graphic types:+--+-- > decorate :: Image u a -> Graphic u -> Image u a+-- > decorate :: LocImage u a -> LocGraphic u -> LocImage u a+-- > decorate :: LocThetaImage u a -> LocThetaGraphic u -> LocTheteImage u a+--+decorate :: Monad cf+         => cf (ImageAns t u) -> cf (GraphicAns u) -> cf (ImageAns t u) +decorate img gf = combind const img (const gf) +++-- | Ante-decorate - version of 'decorate' where the decoration is +-- drawn behind the Image.+--+adecorate :: Monad cf+          => cf (ImageAns t u) -> cf (GraphicAns u) -> cf (ImageAns t u) +adecorate img gf = acombind const img (const gf)+++-- | Version of 'elaborate' where the decorating Graphic has access +-- to the result produced by the Image.+--+-- Again, this function has a very general type signature and+-- supports various graphic types:+--+-- > elaborate :: Image u a -> Graphic u -> Image u a+-- > elaborate :: LocImage u a -> LocGraphic u -> LocImage u a+-- > elaborate :: LocThetaImage u a -> LocThetaGraphic u -> LocTheteImage u a+--+elaborate :: Monad cf +          => cf (ImageAns t u) +          -> (t u -> cf (GraphicAns u)) +          -> cf (ImageAns t u)+elaborate img gf = combind const img gf++-- | Ante-elaborate - version of 'elaborate' where the decoration +-- is drawn behind the Image.+--+aelaborate :: Monad cf +           => cf (ImageAns t u) -> (t u -> cf (GraphicAns u)) -> cf (ImageAns t u)+aelaborate img gf = acombind const img gf+++-- | Hyperlink a graphic object.+-- +-- This function has a very general type signature and supports +-- various graphic types:+--+-- > hyperlink :: XLink -> Graphic u -> Graphic u+-- > hyperlink :: XLink -> Image u a -> Image u a+-- > hyperlink :: XLink -> LocImage u a -> LocImage u a+-- > hyperlink :: XLink -> LocThetaImage u a -> LocThetaImage u a+--+hyperlink :: Functor cf +          => XLink -> cf (ImageAns t u) -> cf (ImageAns t u)+hyperlink hypl = +    fmap (\(Ans a prim) -> Ans a (cpmap (xlinkPrim hypl) prim))+++-- | Clip a graphic object.+-- +clipObject :: Functor cf +           => PrimPath -> cf (ImageAns t u) -> cf (ImageAns t u)+clipObject pp = +    fmap (\(Ans a prim) -> Ans a (cpmap (clip pp) prim))+++++-- | This is a very general monadic combiner.+-- +-- The first argument is a pure combiner cf. @liftM2@, @liftA2@+-- +-- The second argument is an Image to be evaluated.+--+-- The third argument, uses the ouput from the first Image to +-- build a second Image.+-- +-- The function concatenates the CatPrims formed by both Images+-- and uses the pure combiner to build an answer from the+-- intermediate answers.+--+-- NOTE - note useful with CF representation change.+--+combind :: Monad cf +        => (t1 u -> t2 u -> t3 u)+        -> cf (ImageAns t1 u) +        -> (t1 u -> cf (ImageAns t2 u)) +        -> cf (ImageAns t3 u) +combind op gf fn = gf   >>= \(Ans a p1) -> +                   fn a >>= \(Ans b p2) -> +                   return $ Ans (a `op` b) (p1 `oplus` p2)+++-- | Version of combind where the drawing order is flipped.+--+acombind :: Monad cf +         => (t1 u -> t2 u -> t3 u)+         -> cf (ImageAns t1 u) +         -> (t1 u -> cf (ImageAns t2 u)) +         -> cf (ImageAns t3 u) +acombind op gf fn = gf   >>= \(Ans a p1) -> +                    fn a >>= \(Ans b p2) -> +                    return $ Ans (a `op` b) (p2 `oplus` p1)++-}

@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.Kernel.Objects.Bounded--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2010-2011 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com@@ -14,6 +14,8 @@ -- -- Bounded meaning they are actually Images that return the  -- bounding box of the Graphic.+-- +-- These abojects are type synonyms. -- -------------------------------------------------------------------------------- @@ -29,10 +31,12 @@   , BoundedLocThetaGraphic   , DBoundedLocThetaGraphic +   , emptyBoundedLocGraphic   , emptyBoundedLocThetaGraphic    , centerOrthoBBox+   , illustrateBoundedGraphic   , illustrateBoundedLocGraphic   , illustrateBoundedLocThetaGraphic@@ -45,13 +49,14 @@ import Wumpus.Basic.Kernel.Base.ContextFun import Wumpus.Basic.Kernel.Base.DrawingContext import Wumpus.Basic.Kernel.Base.UpdateDC-import Wumpus.Basic.Kernel.Objects.BaseObjects+import Wumpus.Basic.Kernel.Objects.Basis import Wumpus.Basic.Kernel.Objects.DrawingPrimitives-import Wumpus.Basic.Kernel.Objects.Graphic+import Wumpus.Basic.Kernel.Objects.Image+import Wumpus.Basic.Kernel.Objects.LocImage+import Wumpus.Basic.Kernel.Objects.LocThetaImage  import Wumpus.Core                              -- package: wumpus-core -import Control.Applicative  -------------------------------------------------------------------------------- @@ -84,6 +89,9 @@   +++ -- | 'centerOrthoBBox' : @ theta * bbox -> BBox @ --  -- Rotate a bounding box by @theta@ about its center. Take the @@ -93,15 +101,13 @@ -- so the dimensions as well as the positions may change under  -- rotation.  ---centerOrthoBBox :: (Real u, Floating u) ++centerOrthoBBox :: (Real u, Floating u, Ord u)                 => Radian -> BoundingBox u -> BoundingBox u-centerOrthoBBox theta bb = -    traceBoundary $ map (rotateAbout theta ctr) ps+centerOrthoBBox theta bb = traceBoundary $ map (rotateAbout theta ctr) ps   where-    ps  = boundaryCornerList bb     ctr = boundaryCenter bb--+    ps  = boundaryCornerList bb   -- | 'emptyBoundedLocGraphic' : @ BoundedLocGraphic @@@ -113,12 +119,14 @@ -- the minimum bounding box with both the bottom-left and  -- upper-right corners at the implicit start point. ---emptyBoundedLocGraphic :: Num u => BoundedLocGraphic u+emptyBoundedLocGraphic :: InterpretUnit u => BoundedLocGraphic u emptyBoundedLocGraphic = intoLocImage fn emptyLocGraphic   where-    fn = promoteR1 $ \pt -> pure (BBox pt pt)+    fn = promoteR1 $ \pt -> return $ BBox pt pt  ++ -- | 'emptyBoundedLocThetaGraphic' : @ BoundedLocThetaGraphic @ -- -- Build an empty 'BoundedLocThetaGraphic'.@@ -129,40 +137,68 @@ -- upper-right corners at the implicit start point (the implicit  -- inclination can be ignored). ---emptyBoundedLocThetaGraphic :: Num u => BoundedLocThetaGraphic u-emptyBoundedLocThetaGraphic = lift1R2 emptyBoundedLocGraphic+emptyBoundedLocThetaGraphic :: InterpretUnit u => BoundedLocThetaGraphic u+emptyBoundedLocThetaGraphic = intoLocThetaImage fn emptyLocThetaGraphic+  where+    fn = promoteR2 $ \pt _ -> return $ BBox pt pt ++--+-- NOTE - CONCATENATION+--+-- Because there is no tangible relation between the start point +-- and answer BoundingBox, LocBoundedGraphic supports exactly the+-- same concatenation as LocImage.+--+-- PosImage and AdvGraphic are the objects that support more +-- sophisticated concatenation.+--+ ++ -------------------------------------------------------------------------------- --  --- This is a common pattern so needs a name... -illustrateBoundedGraphic :: Fractional u => BoundedGraphic u -> BoundedGraphic u-illustrateBoundedGraphic mf = -    mf >>= \(bb,g1) -> bbrectangle bb >>= \(_,g0) -> return (bb, g0 `oplus` g1)+-- | Draw a BoundedGraphic, illustrating the bounding box.+--+illustrateBoundedGraphic :: InterpretUnit u+                         => BoundedGraphic u -> BoundedGraphic u+illustrateBoundedGraphic gf = elaborateR0 gf bbrectangle  -illustrateBoundedLocGraphic :: Fractional u ++-- | Draw a BoundedLocGraphic, illustrating the bounding box.+--+illustrateBoundedLocGraphic :: InterpretUnit u                             => BoundedLocGraphic u -> BoundedLocGraphic u-illustrateBoundedLocGraphic mf = -    promoteR1 $ \pt -> illustrateBoundedGraphic $ apply1R1 mf pt+illustrateBoundedLocGraphic gf = elaborateR1 gf fn+  where+    fn bb = lift0R1 (bbrectangle bb)  -illustrateBoundedLocThetaGraphic :: Fractional u -    => BoundedLocThetaGraphic u -> BoundedLocThetaGraphic u-illustrateBoundedLocThetaGraphic mf = -    promoteR2 $ \pt theta-> illustrateBoundedGraphic $ apply2R2 mf pt theta  --- -bbrectangle :: Fractional u => BoundingBox u -> Graphic u+-- | Draw a BoundedLocThetaGraphic, illustrating the bounding box.+--+illustrateBoundedLocThetaGraphic :: InterpretUnit u+                                 => BoundedLocThetaGraphic u +                                 -> BoundedLocThetaGraphic u+illustrateBoundedLocThetaGraphic gf = elaborateR2 gf fn+  where+    fn bb = lift0R2 (bbrectangle bb)+++++bbrectangle :: InterpretUnit u => BoundingBox u -> Graphic u bbrectangle (BBox p1@(P2 llx lly) p2@(P2 urx ury))     | llx == urx && lly == ury = emptyLocGraphic `at` p1     | otherwise                =          localize drawing_props $ rect1 `oplus` cross   where-    drawing_props = capRound . dashPattern (Dash 0 [(1,2)])+    drawing_props = cap_round . dotted_line     rect1         = strokedRectangle (urx-llx) (ury-lly) `at` p1-    cross         = straightLineGraphic p1 p2 -                      `oplus` straightLineGraphic (P2 llx ury) (P2 urx lly)+    cross         = straightLine p1 p2 +                      `oplus` straightLine (P2 llx ury) (P2 urx lly) 

@@ -0,0 +1,228 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Objects.Chain+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Chaining moveable LocGraphics.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Objects.Chain+  (+    ChainAlg+  , IterationScheme+  +  , chain+  , chain_+  +  , linear+  , prefix+  , iterationScheme++  , chainIterate+  , chainH+  , chainV++  , tableRight  +  , tableDown++  , radialChain++  ) where+++import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Base.ContextFun+import Wumpus.Basic.Kernel.Objects.Basis+import Wumpus.Basic.Kernel.Objects.Displacement+import Wumpus.Basic.Kernel.Objects.LocImage+import Wumpus.Basic.Kernel.Objects.Image+import Wumpus.Basic.Utils.HList++import Wumpus.Core                              -- package: wumpus-core++++-- In TikZ chains are finite node list and iterated (infite) points+++-- | Chain algorithm.+-- +-- @Linear@ simply iterates points.+--+-- @Prefix@ runs the left chain @n@ times then runs the right +-- chain from the end point of the left chain.+-- +data ChainAlg u = L1 (IterationScheme u)+                | PX Int (ChainAlg u) (ChainAlg u)+++++type instance DUnit (ChainAlg u) = u++++data IterationScheme u = forall st. Scheme +      { scheme_start    :: Point2 u -> st+      , scheme_step     :: st -> (st, Point2 u)+      }++type instance DUnit (IterationScheme u) = u+++++-- | Note the tail of of result list is infinite.+-- +-- As any prefixes will be generated fully. This potentially+-- produces a /space bubble/ where a long prefix has to be +-- generated without the streaming of lazy evaluation. However,+-- chains that are long enough to cause this problem will be +-- problematic for a PostScript or SVG renderer.+--+-- In short - don'\t make long chains.+--+interpChainAlg :: ChainAlg u -> Point2 u -> [Point2 u]+interpChainAlg ch start = go start ch+  where+    go pt (L1 (Scheme mk run)) = let st = mk pt in runInf run st+    go pt (PX n chl chr)       = let (af,end) = takeAndLast n (go pt chl)+                                 in prefixListH af $ go end chr+++runInf :: (st -> (st,Point2 u)) -> st -> [Point2 u]+runInf fn = \st -> go (fn st) +  where+    go (st,a) = a : go (fn st)+++++-- | Take n elements - also return the last of element in the +-- tuple so it can be accessed without a second traversal.+--+-- Note @(n > 0)@ +-- +takeAndLast :: Int -> [a] -> (H a,a)+takeAndLast _ []      = error "takeAndLast - empty list (unreachable?)"+takeAndLast n (a:as)  = go (wrapH a,a) (n-1) as+  where+    go (af,_) i (x:xs) | i > 0     = go (af `snocH` x, x) (i-1) xs+    go acc    _ _                  = acc++++-- | Returns the end point...+--+chain :: InterpretUnit u +      => ChainAlg u -> [LocImage u a] -> LocImage u (Point2 u)+chain _   []      = promoteR1 $ \pt -> +    fmap (replaceAns pt) $ emptyLocGraphic `at` pt++chain alg fs = promoteR1 $ \pt -> +    let ps = interpChainAlg  alg pt in go1 fs pt ps +  where+    go1 (gf:gs) _  (p:ps)     = go (graphic_ $ gf `at` p) gs p ps+    go1 _       p0 _          = fmap (replaceAns p0) $ emptyLocGraphic `at` p0++    go acc (gf:gs) _  (p:ps)  = let g1 = graphic_ $ gf `at` p+                                in go (acc `oplus` g1) gs  p ps+    go acc _       p0 _       = fmap (replaceAns p0) acc+++-- | Returns no answer, just a 'LocGraphic'.+chain_ :: InterpretUnit u => ChainAlg u -> [LocImage u a] -> LocGraphic u+chain_ alg xs = locGraphic_ $ chain alg xs+++linear :: IterationScheme u -> ChainAlg u+linear = L1++prefix :: Int -> ChainAlg u -> ChainAlg u -> ChainAlg u+prefix n c1 c2 | n < 1     = c2+               | otherwise = PX n c1 c2+++iterationScheme :: (Point2 u -> st) +                -> (st -> (st, Point2 u)) +                -> IterationScheme u+iterationScheme start stepper = Scheme start stepper+++++chainIterate :: (Point2 u -> Point2 u) -> ChainAlg u+chainIterate fn = L1 $ Scheme { scheme_start = id+                              , scheme_step  = \pt -> (fn pt, pt)+                              }+++chainH :: Num u => u -> ChainAlg u+chainH = L1 . scHorizontal++scHorizontal :: Num u => u -> IterationScheme u+scHorizontal dx = Scheme { scheme_start = id+                         , scheme_step  = \pt -> (displaceH dx pt, pt)+                         }+   +++chainV :: Num u => u -> ChainAlg u+chainV = L1 . scVertical++scVertical :: Num u => u -> IterationScheme u+scVertical dy = Scheme { scheme_start = id+                       , scheme_step  = \pt -> (displaceV dy pt, pt)+                       }+++tableRight :: Num u => Int -> (u,u) -> ChainAlg u+tableRight num_cols (col_width,row_height) = +    L1 $ scStepper downF num_cols rightF+  where+    downF   = displaceV $ negate row_height+    rightF  = displaceH col_width++tableDown :: Num u => Int -> (u,u) -> ChainAlg u+tableDown num_rows (col_width,row_height) = +    L1 $ scStepper rightF num_rows downF+  where+    downF   = displaceV $ negate row_height+    rightF  = displaceH col_width+++-- | Outer and inner steppers.+--+scStepper :: PointDisplace u -> Int -> PointDisplace u -> IterationScheme u+scStepper outF n innF = Scheme start step+  where+    start pt                      = (pt,pt,0)+    step  (ogin,pt,i) | i < n     = ((ogin, innF pt, i+1), pt)+                      | otherwise = let o1 = outF ogin +                                    in ((o1, innF o1,1), o1) +++++radialChain :: Floating u => u -> Radian -> Radian -> ChainAlg u+radialChain radius start step = L1 $ scCircular radius start step++   +scCircular :: Floating u => u -> Radian -> Radian -> IterationScheme u+scCircular radius angstart angseg = Scheme start step +  where+    start pt        = (pt,angstart)+    step (ogin,ang) = ((ogin,ang + angseg), displaceVec (avec ang radius) ogin)++