wumpus-basic 0.10.0 → 0.11.0

raw patch · 26 files changed

+1189/−779 lines, 26 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGES +41/−0
• demo/ArrowCircuit.hs +82/−0
• demo/ClipPic.hs +5/−5
• demo/FontPic.hs +10/−10
• demo/PetriNet.hs +27/−28
• demo/Shapes.hs +0/−37
• demo/Symbols.hs +1/−1
• src/Wumpus/Basic/Arrows.hs +4/−158
• src/Wumpus/Basic/Arrows/Connectors.hs +136/−0
• src/Wumpus/Basic/Arrows/Tips.hs +57/−44
• src/Wumpus/Basic/Graphic/Base.hs +51/−19
• src/Wumpus/Basic/Graphic/Drawing.hs +37/−4
• src/Wumpus/Basic/Graphic/PrimGraphic.hs +9/−2
• src/Wumpus/Basic/Graphic/Query.hs +45/−41
• src/Wumpus/Basic/Paths/Base.hs +120/−84
• src/Wumpus/Basic/Paths/Connectors.hs +14/−14
• src/Wumpus/Basic/Paths/Construction.hs +14/−11
• src/Wumpus/Basic/Paths/RoundCorners.hs +15/−12
• src/Wumpus/Basic/SafeFonts.hs +39/−39
• src/Wumpus/Basic/Shapes.hs +29/−0
• src/Wumpus/Basic/Shapes/Base.hs +26/−41
• src/Wumpus/Basic/Shapes/Coordinate.hs +88/−0
• src/Wumpus/Basic/Shapes/Derived.hs +130/−186
• src/Wumpus/Basic/Shapes/Plaintext.hs +150/−0
• src/Wumpus/Basic/VersionNumber.hs +2/−2
• wumpus-basic.cabal +57/−41

@@ -1,5 +1,46 @@  +0.10.0 to 0.11.0:+ +  * Reworked arrowheads and connectors - connectors are now +    configurable: there are functions to make connectors with +    a left arrowhead, right arrowhead, none or both.  ++  * Reworked shapes - internally shapes now create a @Path@ rather +    than a @Graphic@ this means the path can be manipulated (e.g. +    round cornered rectangles, diamonds... can be constructed).+    @Coordinate@ is no longer a @Shape@ - it is now similar object +    but of a different type. Likewise, @FreeLabel@ has been +    replaced by @Plaintext@ which is not a @Shape@, but has some +    similar properties.++  * @Basic.Paths.Base@ - @Path@ type changed, @PathEmpty@ +    constructor removed so empty paths cannot be created. This +    allows a better API for taking points on a path. It also +    means @Path@ is no longer an instance of Monoid. Type changes +    to various functions (e.g. @tipR@, @tipL@) reflecting that as +    paths cannot now be empty, functions on them can generally be +    total. @toPrimPathU@ removed as converting to a PrimPath as +    now always /safe/. @tracePoints@ renamed @traceLinePoints@, +    @tracePointsCurve@ renamed @traceCurvePoints@, @midpoint@ +    renamed @midway@.++  * @Basic.Graphic@ - the types @ConnDrawingR@, @ConnGraphic@ etc.+    have had their names expanded to @ConnectorDrawingR@, +    @ConnectorGraphic@... ++  * @Basic.SafeFont@ - font names changed to use underscore +    separators rather than camelCase. Wumpus generally uses +    underscored names for /constants/.++  * Removed @conn@ from @Basic.Graphic.Drawing@. Connectors should +    be used instead.++  * The class @DrawingCtxM@ now has @Applicative@ as a superclass. ++  * @lineSpacing@ renamed @baselineSpacing@.++ 0.9.0 to 0.10.0:    * @Basic.Graphic.BaseClasses@ and @Basic.Graphic.BaseTypes@ 

@@ -0,0 +1,82 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}+++-- Acknowledgment - the Arrow diagram is taken from Ross +-- Paterson\'s slides /Arrows and Computation/.+++module ArrowCircuit where++import Wumpus.Basic.Anchors+import Wumpus.Basic.Arrows+import Wumpus.Basic.Graphic+import Wumpus.Basic.Paths +import Wumpus.Basic.SafeFonts+import Wumpus.Basic.Shapes++import Wumpus.Core                      -- package: wumpus-core++import Data.AffineSpace++import System.Directory+++main :: IO ()+main = do +    createDirectoryIfMissing True "./out/"+    writeEPS_latin1 "./out/arrow_circuit.eps" pic1+    writeSVG_latin1 "./out/arrow_circuit.svg" pic1 ++times_ctx :: DrawingContext+times_ctx = fontface times_roman $ standardContext 11++-- Note - quite a bit of this diagram was produced /by eye/, +-- rather than using anchors directly - e.g. the placing of the +-- ptext labels and the anchors displaced by vectors.+--+         +pic1 :: Picture Double +pic1 = liftToPictureU $ execDrawing times_ctx $ do+    a1 <- drawi $ strokedShape $ translate 0   72 $ rrectangle 12 66 30+    atext a1 "CONST 0"+    a2 <- drawi $ strokedShape $ translate 120 60 $ circle 16+    atext a2 "IF"+    a3 <- drawi $ strokedShape $ translate 240 28 $ circle 16+    atext a3 "+1"+    a4 <- drawi $ strokedShape $ translate 120  0 $ rectangle 66 30+    atext a4 "DELAY 0"+    connWith connect (east a1) (east a1 .+^ hvec 76)+    connWith connect (east a2) (east a2 .+^ hvec 180)+    connWith connect (north a2 .+^ vvec 40) (north a2)+    connWith connect (north a3 .+^ vvec 16) (north a3)  +    connWith vhconn  (south a3) (east a4)+    connWith (hvhconn (-30)) (west a4)  (southwest a2)+    ptext (P2  40  10) "next"+    ptext (P2 152 100) "reset"+    ptext (P2 252  72) "output"+    return ()+++-- Note - conn from Basic.Graphic is now questionable...++connWith :: ( TraceM m, DrawingCtxM m, u ~ MonUnit m+            , Real u, Floating u, FromPtSize u ) +         => ConnectorPath u -> Point2 u -> Point2 u -> m ()+connWith con p0 p1 = localize doublesize $ +    drawi_ $ strokeConnector (rightArrow con tri45) p0 p1+++atext :: ( CenterAnchor t, DUnit t ~ u+         , Real u, Floating u, FromPtSize u+         , TraceM m, DrawingCtxM m, u ~ MonUnit m )+      => t -> String -> m ()+atext ancr ss = let (P2 x y) = center ancr in+   drawi_ $ drawText $ translate x y $ plaintext ss+++ptext :: ( Real u, Floating u, FromPtSize u+         , TraceM m, DrawingCtxM m, u ~ MonUnit m )+      => Point2 u -> String -> m ()+ptext (P2 x y) ss = localize (fontsize 14 . fontface times_italic) $ +    drawi_ $ drawText $ translate x y $ plaintext ss

@@ -40,7 +40,7 @@ pic = pic1 `nextToV` (stackOver [cpic1, cpic2, cpic3] cpic4)  fillPath :: Num u => Path u -> Graphic u-fillPath = filledPath . toPrimPathU+fillPath = filledPath . toPrimPath  pic1 :: DPicture pic1 = liftToPictureU $ execDrawing pic_drawing_ctx $ @@ -61,16 +61,16 @@      ps = unchain (coordinateScalingContext 86 16) $ tableDown 18 8  cpic1 :: DPicture -cpic1 = clip (toPrimPathU path01) (background black)+cpic1 = clip (toPrimPath path01) (background black)    cpic2 :: DPicture -cpic2 = clip (toPrimPathU path02) (background medium_violet_red)+cpic2 = clip (toPrimPath path02) (background medium_violet_red)  cpic3 :: DPicture -cpic3 = clip (toPrimPathU path03) (background black)+cpic3 = clip (toPrimPath path03) (background black)  cpic4 :: DPicture -cpic4 = clip (toPrimPathU path04) (background black)+cpic4 = clip (toPrimPath path04) (background black)   iheartHaskell :: Num u => FromPtSize u => Point2 u -> Drawing u () 

@@ -74,18 +74,18 @@  times_pic :: Picture Double times_pic = -    fontPicture [ (steel_blue,  timesRoman)-                , (indian_red1, timesItalic)-                , (steel_blue,  timesBold)-                , (indian_red1, timesBoldItalic)+    fontPicture [ (steel_blue,  times_roman)+                , (indian_red1, times_italic)+                , (steel_blue,  times_bold)+                , (indian_red1, times_bold_italic)                 ]   helvetica_pic :: Picture Double helvetica_pic =      fontPicture [ (steel_blue,  helvetica)-                , (indian_red1, helveticaOblique)-                , (steel_blue,  helveticaBold)-                , (indian_red1, helveticaBoldOblique)+                , (indian_red1, helvetica_oblique)+                , (steel_blue,  helvetica_bold)+                , (indian_red1, helvetica_bold_oblique)                 ]   @@ -95,9 +95,9 @@ courier_pic :: Picture Double courier_pic =      fontPicture [ (steel_blue,  courier)-                , (indian_red1, courierOblique)-                , (steel_blue,  courierBold)-                , (indian_red1, courierBoldOblique)+                , (indian_red1, courier_oblique)+                , (steel_blue,  courier_bold)+                , (indian_red1, courier_bold_oblique)                 ]   

@@ -46,20 +46,20 @@               tl2    <- transition 210 0               r      <- place 280 0               tl3    <- transition 350 0-              connector (east pw)  (west tu1)              -              connector (east tu1) (west rtw)-              connector (east rtw) (west tu2)-              connector (east tu2) (west w)-              connector (east w)   (west tu3)+              connector' (east pw)  (west tu1)              +              connector' (east tu1) (west rtw)+              connector' (east rtw) (west tu2)+              connector' (east tu2) (west w)+              connector' (east w)   (west tu3)               connectorC 32 (north tu3) (north pw)-              connector (east pr)  (west tl1)              -              connector (east tl1) (west rtr)-              connector (east rtr) (west tl2)-              connector (east tl2) (west r)-              connector (east r)   (west tl3)+              connector' (east pr)  (west tl1)              +              connector' (east tl1) (west rtr)+              connector' (east rtr) (west tl2)+              connector' (east tl2) (west r)+              connector' (east r)   (west tl3)               connectorC (-32) (south tl3) (south pr)-              connector (southwest res) (northeast tl2)-              connector (northwest tl3) (southeast res)+              connector' (southwest res) (northeast tl2)+              connector' (northwest tl3) (southeast res)               connectorD 6    (southwest tu3) (northeast res)               connectorD (-6) (southwest tu3) (northeast res)                connectorD 6    (northwest res) (southeast tu2)@@ -81,33 +81,32 @@  place :: (Real u, Floating u, DrawingCtxM m, TraceM m, u ~ MonUnit m)        => u -> u -> m (Circle u)-place x y = greenFill $ drawi $ drawShape $ translate x y $ circle 14+place x y = greenFill $ drawi $ borderedShape $ translate x y $ circle 14  transition :: (Real u, Floating u, DrawingCtxM m, TraceM m, u ~ MonUnit m)             => u -> u -> m (Rectangle u)-transition x y = greenFill $ drawi $ drawShape $ translate x y $ rectangle 32 22+transition x y = greenFill $ drawi $ borderedShape $ translate x y $ rectangle 32 22 -connector :: ( Real u, Floating u, FromPtSize u-             , DrawingCtxM m, TraceM m, u ~ MonUnit m )-          => Point2 u -> Point2 u -> m ()-connector p1 p2 = do-   _ <- drawi $ arrowTri60 connect `conn` p1 $ p2-   return ()  ++connector' :: ( TraceM m, DrawingCtxM m, u ~ MonUnit m+         , Real u, Floating u, FromPtSize u ) +      => Point2 u -> Point2 u -> m ()+connector' p0 p1 = drawi_ $ strokeConnector (rightArrow connect tri45) p0 p1++ connectorC :: ( Real u, Floating u, FromPtSize u              , DrawingCtxM m, TraceM m, u ~ MonUnit m )            => u -> Point2 u -> Point2 u -> m ()-connectorC v p1 p2 = do-    _ <- drawi $ arrowTri60 (vhvconn v) `conn` p1 $ p2-    return ()+connectorC v p0 p1 = +    drawi_ $ strokeConnector (rightArrow (vhvconn v) tri45) p0 p1  connectorD :: ( Real u, Floating u, FromPtSize u              , DrawingCtxM m, TraceM m, u ~ MonUnit m )            => u -> Point2 u -> Point2 u -> m ()-connectorD u p1 p2 = do-    _ <- drawi $ arrowTri60 (joint u) `conn` p1 $ p2-    return ()+connectorD u p0 p1 = +    drawi_ $ strokeConnector (rightArrow (joint u) tri45) p0 p1   lblParensParens :: Num u => LocGraphic u@@ -118,8 +117,8 @@   lblBold' :: Num u => String -> LocGraphic u-lblBold' ss = localize (fontface helveticaBold) . textline ss+lblBold' ss = localize (fontface helvetica_bold) . textline ss   lblBold :: (Fractional u, Ord u, FromPtSize u) => String -> LocGraphic u-lblBold ss = localize (fontface helveticaBold) . centermonoTextline ss+lblBold ss = localize (fontface helvetica_bold) . centermonoTextline ss

@@ -1,37 +0,0 @@-{-# OPTIONS -Wall #-}---module Shapes where--import Wumpus.Basic.Colour.SVGColours-import Wumpus.Basic.Graphic                     -- package: wumpus-basic-import Wumpus.Basic.Shapes.Base-import Wumpus.Basic.Shapes.Derived--import Wumpus.Core                              -- package: wumpus-core---import System.Directory----main :: IO ()-main = do -    createDirectoryIfMissing True "./out/"-    writeEPS_latin1 "./out/shapes01.eps" pic1-    writeSVG_latin1 "./out/shapes01.svg" pic1-    --pic1 :: DPicture-pic1 = liftToPictureU $ execDrawing (standardContext 14) $ do-         _ <- drawi $ drawShape $ translate 220 10 $ rotate30-                                                   $ lrectangle 90 30 "Rectangle"-         _ <- drawi $ drawShape $ translate 100  0 $ lcircle 10 "C0"-   -         _ <- localize (strokeColour red) $ -                       drawi $ drawShape $ translate 220 10 $ rotate30 $ coordinate-         _ <- drawi $ drawShape $ translate 0   40 $ ldiamond 10 10 "d1"-         _ <- drawi $ drawShape $ translate 400 50 $ lrectangle 20 100 "R2"-         return ()--

@@ -29,7 +29,7 @@     writeSVG_latin1 "./out/symbols.svg" pic1  std_ctx :: DrawingContext-std_ctx = fontface timesRoman $ standardContext 12+std_ctx = fontface times_roman $ standardContext 12  pic1 :: DPicture  pic1 = liftToPictureU $ execDrawing std_ctx $ do

@@ -10,173 +10,19 @@ -- Stability   :  highly unstable -- Portability :  GHC ----- Draw arrows.------ \*\* WARNING \*\* - the types are /wrong/ here and need more --- thought.+-- Shim module for arrow connectors and arrowheads. --  --------------------------------------------------------------------------------  module Wumpus.Basic.Arrows   ( -    cline --  , arrowTri90-  , arrowTri60-  , arrowTri45-  , arrowOTri90-  , arrowOTri60-  , arrowOTri45--  , arrowBarb90-  , arrowBarb60-  , arrowBarb45-    -  , arrowPerp-  , arrowRBracket+    module Wumpus.Basic.Arrows.Tips+  , module Wumpus.Basic.Arrows.Connectors    ) where  import Wumpus.Basic.Arrows.Tips-import Wumpus.Basic.Graphic-import Wumpus.Basic.Paths-import Wumpus.Basic.Utils.Intersection ( langle )--import Wumpus.Core                      -- package: wumpus-core--import Control.Applicative-import Data.Monoid--liftConnector :: Connector u -> ConnDrawingR u (Path u)-liftConnector pF p1 p2 = pure $ pF p1 p2--cline :: Num u => Connector u -> ConnImage u (Path u)-cline pathF = intoConnImage (liftConnector pathF) (pathGraphic pathF)---- ... No - can\'t a add tips to this one.----pathGraphic :: Num u => Connector u -> ConnGraphic u-pathGraphic bpath = \p1 p2 -> openStroke $ toPrimPathU $ bpath p1 p2----- Here the path is already shortened - we have accounted for the--- points already, so it is just a graphic. -lineTipR :: Num u => Path u -> Graphic u -> Graphic u-lineTipR bpath arrtip = openStroke (toPrimPathU bpath) `mappend` arrtip-   ------ | Returns two items:--- --- 1. Shorten the line by the line width - this stops the path--- tip puncturing the arrow head (particulary visible on open --- triangle tips).--- --- 2. Calculate the direction back along the line at half the --- lower_x_height - this gets a good angle for the tip on curved--- path segments.----rightPathProps :: (Real u, Floating u, FromPtSize u) -               => Connector u -> ConnDrawingR u (Path u,Radian)-rightPathProps pathF p1 p2 = -    (\h sw -> (shortenPath h sw, calcTheta h))-      <$> markHeight <*> lineWidth-  where-    long_path          = pathF p1 p2  -    shortenPath lxh sw = shortenR (lxh + (realToFrac sw)) long_path -    calcTheta lxh      = directionR $ shortenR (0.5*lxh) long_path-----triTipRight :: (Real u, Floating u, FromPtSize u) -            => Connector u -> (Radian -> LocGraphic u) -> ConnImage u (Path u) -triTipRight pathF tipF p1 p2 =-    rightPathProps pathF p1 p2          >>= \(shortF,theta) -> -    lineTipR shortF (tipF theta p2)     >>= \arrow_pic      ->-    return (pathF p1 p2, arrow_pic)------- This version does not /retract/ the path...----barbTipRight :: (Real u, Floating u, FromPtSize u) -             => Connector u -> (Radian -> LocGraphic u) -> ConnImage u (Path u)  -barbTipRight pathF tipF p1 p2 = -    rightPathProps pathF p1 p2          >>= \(_,theta) -> -    lineTipR path_zero (tipF theta p2)  >>= \arrow_pic  ->-    return (path_zero, arrow_pic)-  where-    path_zero = pathF p1 p2----arrowTri90 :: (Real u, Floating u, FromPtSize u) -           => Connector u -> ConnImage u (Path u)-arrowTri90 pathF = triTipRight pathF tri90- -          ---arrowTri60 :: (Real u, Floating u, FromPtSize u) -           => Connector u -> ConnImage u (Path u)-arrowTri60 pathF = triTipRight pathF tri60-- -arrowTri45 :: (Real u, Floating u, FromPtSize u) -           => Connector u -> ConnImage u (Path u)-arrowTri45 pathF = triTipRight pathF tri45---arrowOTri90 :: (Real u, Floating u, FromPtSize u) -            => Connector u -> ConnImage u (Path u)-arrowOTri90 pathF = triTipRight pathF otri90-     --arrowOTri60 :: (Real u, Floating u, FromPtSize u) -            => Connector u -> ConnImage u (Path u)-arrowOTri60 pathF = triTipRight pathF otri60 ----arrowOTri45 :: (Real u, Floating u, FromPtSize u) -            => Connector u -> ConnImage u (Path u)-arrowOTri45 pathF = triTipRight pathF otri45----arrowBarb90 :: (Real u, Floating u, FromPtSize u) -            => Connector u -> ConnImage u (Path u)-arrowBarb90 pathF = barbTipRight pathF barb90--arrowBarb60 :: (Real u, Floating u, FromPtSize u) -            => Connector u -> ConnImage u (Path u)-arrowBarb60 pathF = barbTipRight pathF barb60--arrowBarb45 :: (Real u, Floating u, FromPtSize u) -            => Connector u -> ConnImage u (Path u)-arrowBarb45 pathF = barbTipRight pathF barb45---                     -arrowPerp :: (Real u, Floating u, FromPtSize u) -          => Connector u -> ConnImage u (Path u)-arrowPerp pathF p1 p2 = -    lineTipR path_zero perp_tip >>= \arrow_pic -> return (path_zero, arrow_pic)-  where-    path_zero = pathF  p1 p2-    theta     = langle p1 p2-    perp_tip  = perp theta p2+import Wumpus.Basic.Arrows.Connectors  -arrowRBracket :: (Real u, Floating u, FromPtSize u) -              => Connector u -> ConnImage u (Path u)-arrowRBracket pathF p1 p2 = -    lineTipR path_zero perp_tip >>= \arrow_pic -> return (path_zero, arrow_pic)-  where-    path_zero = pathF  p1 p2-    theta     = langle p1 p2-    perp_tip  = rbracket theta p2

@@ -0,0 +1,136 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Arrows.Connectors+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Draw arrows.+--+-- \*\* WARNING \*\* - the types are /wrong/ here and need more +-- thought.+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.Arrows.Connectors+  ( ++    Connector+  , connector+  , leftArrow+  , rightArrow+  , dblArrow+  , leftrightArrow+  , strokeConnector+++  ) where++import Wumpus.Basic.Arrows.Tips+import Wumpus.Basic.Graphic+import Wumpus.Basic.Paths++import Wumpus.Core                      -- package: wumpus-core++import Data.Monoid++-- An arrowhead always know how to draws itself (filled tri, +-- stroked barb, etc.)+--+-- A Path might will typically be drawn with openStroke,+-- eventually there might be scope for drawing +-- e.g. parallel lines  ====+--++-- A ConnectorPath gets wrapped with how it is drawn into+-- another type.+++-- larrow :: Arrowhead u -> ConnectorPath u -> WrappedConnector u+++data Connector u = Connector +      { connector_path  :: ConnectorPath u+      , opt_left_arrow  :: Maybe (Arrowhead u)+      , opt_right_arrow :: Maybe (Arrowhead u)+      }+++-- | connector with no arrow heads.+--+connector :: ConnectorPath u -> Connector u+connector cp = +    Connector { connector_path  = cp+              , opt_left_arrow  = Nothing+              , opt_right_arrow = Nothing+              }++leftArrow :: ConnectorPath u -> Arrowhead u -> Connector u+leftArrow cp la =+    Connector { connector_path  = cp+              , opt_left_arrow  = Just la+              , opt_right_arrow = Nothing+              }+++rightArrow :: ConnectorPath u -> Arrowhead u -> Connector u+rightArrow cp ra = +    Connector { connector_path  = cp+              , opt_left_arrow  = Nothing+              , opt_right_arrow = Just ra+              }++-- | Same tip both ends.+--+dblArrow :: ConnectorPath u -> Arrowhead u -> Connector u+dblArrow cp arw = leftrightArrow cp arw arw++leftrightArrow :: ConnectorPath u -> Arrowhead u -> Arrowhead u -> Connector u+leftrightArrow cp la ra =+    Connector { connector_path  = cp+              , opt_left_arrow  = Just la+              , opt_right_arrow = Just ra+              }+++strokeConnector :: (Real u, Floating u) +                => Connector u -> ConnectorImage u (Path u)+strokeConnector (Connector cpF opt_la opt_ra) = \p0 p1 ->+    let pathc = cpF p0 p1 in +    (fn pathc opt_la p0 opt_ra p1) >>= \grafic ->+    intoImage (return pathc) grafic+  where+    fn pathc ma p0 mb p1 = do +       (path1,tipl) <- applyTipL ma p0 pathc+       (path2,tipr) <- applyTipR mb p1 path1+       return $ (openStroke $ toPrimPath path2) `mappend` tipl `mappend` tipr+   +++applyTipL :: (Real u, Floating u) +          => Maybe (Arrowhead u) -> Point2 u -> Path u +          -> DrawingR (Path u, Graphic u)+applyTipL Nothing    _   pathc = return (pathc,mempty)+applyTipL (Just arw) ptL pathc = +    retract_dist arw >>= \ dx -> +    if dx > 0 then return (shortenL dx pathc, grafik) +              else return (pathc, grafik)+  where+    grafik = (arrow_draw arw) (directionL pathc) ptL++applyTipR :: (Real u, Floating u) +          => Maybe (Arrowhead u) -> Point2 u -> Path u +          -> DrawingR (Path u, Graphic u)+applyTipR Nothing    _   pathc = return (pathc,mempty)+applyTipR (Just arw) ptR pathc = +    retract_dist arw >>= \dx -> +    if dx > 0 then return (shortenR dx pathc, grafik) +              else return (pathc, grafik)+  where+    grafik = (arrow_draw arw) (directionR pathc) ptR +

@@ -20,8 +20,10 @@ module Wumpus.Basic.Arrows.Tips   (  +    Arrowhead(..)+  , arrowheadTip -    tri90+  , tri90   , tri60   , tri45   , otri90@@ -46,8 +48,15 @@  import Control.Applicative +data Arrowhead u = Arrowhead+      { retract_dist :: DrawingR u+      , arrow_draw   :: ThetaLocGraphic u +      }  +arrowheadTip :: Arrowhead u -> Radian -> LocGraphic u+arrowheadTip (Arrowhead _ gf) theta = gf theta+ -- | Tiplen is length of the tip \*along the line it follows\*.  -- -- > |\@@ -85,6 +94,7 @@     vec_to_lower = avec (circularModulo $ rtheta + halfang) hypo_len   +{- -- | This one is for triangles when the tip height and tip width -- are known. --@@ -97,8 +107,17 @@     rtheta       = pi + theta        -- theta in the opposite direction     vec_to_upper = avec (circularModulo $ rtheta - halfang) hypo_len     vec_to_lower = avec (circularModulo $ rtheta + halfang) hypo_len +-}  +++mark_height_plus_line_width :: (Fractional u, FromPtSize u) => DrawingR u+mark_height_plus_line_width = +    (\h lw -> h + realToFrac lw) <$> markHeight <*> lineWidth+++ --------------------------------------------------------------------------------  -- | Tripoints takes the \*tip length\* is the mark height.@@ -108,22 +127,22 @@ -- does it!). -- tripointsByAngle :: (Floating u, FromPtSize u)-                 => Radian -> Radian -> LocDrawingR u (Point2 u, Point2 u)+                 => Radian ->  ThetaLocDrawingR u (Point2 u, Point2 u) tripointsByAngle triang theta tip =      (\h -> let (vupper,vlower) = triVecsByAngle h (0.5*triang) theta            in  (tip .+^ vupper, tip .+^ vlower))       <$> markHeight  -+{- tripointsByDist :: (Real u, Floating u, FromPtSize u)-                => (u -> u) -> (u -> u) -> Radian -                -> LocDrawingR u (Point2 u, Point2 u)+                => (u -> u) -> (u -> u)  +                -> ThetaLocDrawingR u (Point2 u, Point2 u) tripointsByDist lenF halfwidthF theta tip =      (\h -> let (vup,vlo) = triVecsByDist (lenF h) (halfwidthF $ 0.5*h) theta            in  (tip .+^ vup, tip .+^ vlo))       <$> markHeight-+-}   @@ -131,11 +150,8 @@ -- filled with stroke colour!  triAng :: (Floating u, Real u, FromPtSize u)-      => Radian -      -> Radian-      -> (PrimPath u -> Graphic u) -      -> LocGraphic u-triAng triang theta gf pt = +       => Radian -> (PrimPath u -> Graphic u) -> ThetaLocGraphic u+triAng triang gf theta pt =      tripointsByAngle triang theta pt >>= \(u,v) ->      localize bothStrokeColour (gf $  vertexPath [pt,u,v]) @@ -143,65 +159,59 @@  -- TODO - maybe filling needs to use swapColours -tri90 :: (Floating u, Real u, FromPtSize u)-      => Radian -> LocGraphic u-tri90 theta = triAng (pi/2) theta filledPath+tri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u+tri90 = Arrowhead markHeight (triAng (pi/2) filledPath)  -tri60 :: (Floating u, Real u, FromPtSize u)-      => Radian -> LocGraphic u-tri60 theta = triAng (pi/3) theta filledPath+tri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u+tri60 = Arrowhead markHeight (triAng (pi/3) filledPath)  -tri45 :: (Floating u, Real u, FromPtSize u)-      => Radian -> LocGraphic u-tri45 theta = triAng (pi/4) theta filledPath+tri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u+tri45 = Arrowhead markHeight (triAng (pi/4) filledPath) +otri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u+otri90 = Arrowhead mark_height_plus_line_width (triAng (pi/2) closedStroke) -otri90 :: (Floating u, Real u, FromPtSize u)-      => Radian -> LocGraphic u-otri90 theta = triAng (pi/2) theta closedStroke+otri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u+otri60 = Arrowhead mark_height_plus_line_width (triAng (pi/3) closedStroke) +otri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u+otri45 = Arrowhead mark_height_plus_line_width (triAng (pi/4) closedStroke) -otri60 :: (Floating u, Real u, FromPtSize u)-      => Radian -> LocGraphic u-otri60 theta = triAng (pi/3) theta closedStroke -otri45 :: (Floating u, Real u, FromPtSize u)-      => Radian -> LocGraphic u-otri45 theta = triAng (pi/4) theta closedStroke -barbAng :: (Floating u, Real u, FromPtSize u)-      => Radian -> Radian -> LocGraphic u+barbAng :: (Floating u, Real u, FromPtSize u) => Radian -> ThetaLocGraphic u barbAng ang theta pt =      tripointsByAngle ang theta pt >>= \(u,v) ->      openStroke (vertexPath [u,pt,v])  -barb90 :: (Floating u, Real u, FromPtSize u) -       => Radian -> LocGraphic u-barb90 = barbAng (pi/2)+barb90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u+barb90 = Arrowhead (pure 0) (barbAng (pi/2)) -barb60 :: (Floating u, Real u, FromPtSize u) -       => Radian -> LocGraphic u-barb60 = barbAng (pi/3)+barb60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u+barb60 = Arrowhead (pure 0) (barbAng (pi/3)) -barb45 :: (Floating u, Real u, FromPtSize u) -       => Radian -> LocGraphic u-barb45 = barbAng (pi/4) +barb45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u+barb45 = Arrowhead (pure 0) (barbAng (pi/4))  -perp :: (Floating u, FromPtSize u) => Radian -> LocGraphic u-perp theta pt =  ++perpAng :: (Floating u, FromPtSize u) => ThetaLocGraphic u+perpAng theta pt =       markHeight >>= \ h ->      let v = makeV h in openStroke $ vertexPath [ pt .+^ v, pt .-^ v]   where     makeV h  = avec (theta + pi/2) (0.5 * h)  -rbracket :: (Floating u, FromPtSize u) => Radian -> LocGraphic u-rbracket theta pt = markHalfHeight >>= \hh -> +perp :: (Floating u, FromPtSize u) => Arrowhead u+perp = Arrowhead (pure 0) perpAng++rbracketAng :: (Floating u, FromPtSize u) => ThetaLocGraphic u+rbracketAng theta pt = markHalfHeight >>= \hh ->     runDirection theta $       displacePerp   hh  pt >>= \p1 ->      displacePara (-hh) p1 >>= \p0 ->@@ -209,3 +219,6 @@      displacePara (-hh) p2 >>= \p3 ->      return (openStroke $ vertexPath [p0,p1,p2,p3])     ++rbracket :: (Floating u, FromPtSize u) => Arrowhead u+rbracket = Arrowhead (pure 0) rbracketAng

@@ -16,9 +16,10 @@ --  -- Base classes for monadic drawing. ----- Note on suffix names. Function types suffixed @F@ are functions --- from same-to-same, e.g.:+-- Notes on prefix and suffix names: --+-- Function types suffixed @F@ are functions from same-to-same, e.g.:+-- -- > type Point2F u = Point2 u -> Point2 u -- -- Functional types subfixed @R@ are functions from some static @@ -28,6 +29,12 @@ -- -- The suffix @M@ is used for classes defining monadic actions. --+-- The prefix @Loc@ indicates a functional type +-- /from Point2 to something.../+-- +-- The prefix @ThetaLoc@ indicates a functional type +-- /from Direction (radian) then Point to something.../+-- -- \*\* WARNING \*\* - some names are expected to change. -- --------------------------------------------------------------------------------@@ -77,15 +84,22 @@   , intoLocImage   , xlinkImage -  , ConnDrawingR-  , DConnDrawingR-  , ConnGraphic-  , DConnGraphic-  , ConnImage-  , DConnImage+  , ConnectorDrawingR+  , DConnectorDrawingR+  , ConnectorGraphic+  , DConnectorGraphic+  , ConnectorImage+  , DConnectorImage -  , intoConnImage+  , intoConnectorImage +  , ThetaLocDrawingR+  , DThetaLocDrawingR+  , ThetaLocGraphic+  , DThetaLocGraphic+  , ThetaLocImage+  , DThetaLocImage+   ) where  import Wumpus.Basic.Graphic.DrawingContext@@ -114,7 +128,7 @@ class Monad m => TraceM (m :: * -> *) where   trace  :: HPrim (MonUnit m) -> m () -class Monad m => DrawingCtxM (m :: * -> *) where+class (Applicative m, Monad m) => DrawingCtxM (m :: * -> *) where   askDC    :: m DrawingContext   localize :: (DrawingContext -> DrawingContext) -> m a -> m a @@ -306,28 +320,46 @@ -------------------------------------------------------------------------------- -- -type ConnDrawingR u a = Point2 u -> Point2 u -> DrawingR a+type ConnectorDrawingR u a = Point2 u -> Point2 u -> DrawingR a -type DConnDrawingR a = ConnDrawingR Double a+type DConnectorDrawingR a = ConnectorDrawingR Double a --- | ConnGraphic is a connector drawn between two points +-- | ConnectorGraphic is a connector drawn between two points  -- contructing a Graphic. ---type ConnGraphic u = Point2 u -> Point2 u -> Graphic u+type ConnectorGraphic u = Point2 u -> Point2 u -> Graphic u -type DConnGraphic = ConnGraphic Double+type DConnectorGraphic = ConnectorGraphic Double  -- | ConImage is a connector drawn between two points  -- constructing an Image. ---type ConnImage u a = Point2 u -> Point2 u -> Image u a+type ConnectorImage u a = Point2 u -> Point2 u -> Image u a -type DConnImage a = ConnImage Double a+type DConnectorImage a = ConnectorImage Double a  -intoConnImage :: ConnDrawingR u a -> ConnGraphic u -> ConnImage u a-intoConnImage f g p1 p2 = DrawingR $ \ctx -> +intoConnectorImage :: ConnectorDrawingR u a +                   -> ConnectorGraphic u +                   -> ConnectorImage u a+intoConnectorImage f g p1 p2 = DrawingR $ \ctx ->      let a = getDrawingR (f p1 p2) ctx; o = getDrawingR (g p1 p2) ctx in (a,o)++++type ThetaLocDrawingR u a = Radian -> LocDrawingR u a ++type DThetaLocDrawingR a = ThetaLocDrawingR Double a++-- | A function from /Radian -\> Point -\> Graphic/...+--+type ThetaLocGraphic u = Radian -> LocGraphic u++type DThetaLocGraphic = ThetaLocGraphic Double++type ThetaLocImage u a = Radian -> LocImage u a++type DThetaLocImage a = ThetaLocImage Double a    

@@ -27,8 +27,10 @@   , DrawingT   , runDrawing   , execDrawing+  , evalDrawing   , runDrawingT   , execDrawingT+  , evalDrawingT    , runFdcDrawing   , execFdcDrawing@@ -42,11 +44,12 @@   , draw   , xdraw   , drawi+  , drawi_   , xdrawi+  , xdrawi_    , at   , ati-  , conn    , node   , nodei@@ -181,17 +184,36 @@ runDrawing :: DrawingContext -> Drawing u a -> (a, HPrim u) runDrawing ctx ma = getDrawing ma ctx mempty +-- | Run the drawing returning only the output it produces, drop+-- any answer from the monadic computation.+-- execDrawing :: DrawingContext -> Drawing u a -> HPrim u execDrawing ctx ma = snd $ runDrawing ctx ma +-- | Run the drawing ignoring the output it produces, return the +-- answer from the monadic computation.+--+-- Note - this useful for testing, generally one would want the +-- opposite behaviour (return the drawing, ignore than the +-- answer).+-- +evalDrawing :: DrawingContext -> Drawing u a -> a+evalDrawing ctx ma = fst $ runDrawing ctx ma  + runDrawingT :: Monad m => DrawingContext -> DrawingT u m a -> m (a, HPrim u)  runDrawingT ctx ma = getDrawingT ma ctx mempty  execDrawingT :: Monad m => DrawingContext -> DrawingT u m a -> m (HPrim u) execDrawingT ctx ma = liftM snd $ runDrawingT ctx ma ++evalDrawingT :: Monad m => DrawingContext -> DrawingT u m a -> m a+evalDrawingT ctx ma = liftM fst $ runDrawingT ctx ma+++ -- | Run the Drawing generating a Picture /within/ a  -- \"font delta context\" using the font-family and font-size  -- from the intial DrawingContext.@@ -300,6 +322,12 @@ drawi img = askDC >>= \ctx ->              let (a,o) = runImage ctx img in trace o >> return a +-- | Forgetful 'drawi'.+--+drawi_ ::  (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Image u a -> m ()+drawi_ img = drawi img >> return ()++ -- | Hyperlink version of 'drawi'. -- xdrawi ::  (TraceM m, DrawingCtxM m, u ~ MonUnit m) @@ -307,6 +335,11 @@ xdrawi xl img = drawi (xlinkImage xl img)  +-- | Forgetful 'xdrawi'.+--+xdrawi_ ::  (TraceM m, DrawingCtxM m, u ~ MonUnit m) +        => XLink -> Image u a -> m ()+xdrawi_ xl img = xdrawi xl img >> return ()   infixr 1 `at`, `ati`@@ -317,11 +350,11 @@ ati = ($)  -+{- infixl 1 `conn`-conn :: ConnImage u a -> Point2 u -> LocImage u a+conn :: ConnectorImage u a -> Point2 u -> LocImage u a conn = ($)-+-}  node :: (TraceM m, DrawingCtxM m, PointSupplyM m, u ~ MonUnit m)       => LocGraphic u -> m ()

@@ -119,6 +119,11 @@ borderedPath pp =      withBorderedAttr $ \frgb attr srgb -> singleH $ fillStroke frgb attr srgb pp ++-- Note - clipping needs a picture as well as a path, so there is+-- no analogous @clippedPath@ function.++ -------------------------------------------------------------------------------- --  @@ -142,11 +147,13 @@   --- | Point is the baseline left of the bottom line.+-- | Point is the baseline left of the bottom line, text is +-- left-aligned. -- textlineMulti :: Fractional u => [String] -> LocGraphic u textlineMulti xs baseline_left = liftM snd $ -    lineSpacing >>= \dy -> foldrM (foldStep dy) (baseline_left,mempty) xs+    baselineSpacing >>= \dy -> +    foldrM (foldStep dy) (baseline_left,mempty) xs   where     foldStep dy str (pt,gfic) = (\a -> (pt .+^ vvec dy, a `mappend` gfic))                                     <$> textline str pt

@@ -34,7 +34,7 @@   , fontSize   , markHeight   , markHalfHeight-  , lineSpacing+  , baselineSpacing    --    , monoCharWidth@@ -46,6 +46,8 @@   , monoLowerxHeight   , monoDescenderDepth   , monoTextDimensions+  , monoMultiLineTextHeight+  , monoDefaultPadding   , monoVecToCenter     ) where @@ -58,37 +60,34 @@ import Control.Applicative  -textAttr :: (Applicative m, DrawingCtxM m) => m (RGBi,FontAttr)+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 :: (Applicative m, DrawingCtxM m) -             => (RGBi -> FontAttr -> a) -> m a+withTextAttr :: DrawingCtxM m => (RGBi -> FontAttr -> a) -> m a withTextAttr fn = fn <$> asksDC stroke_colour <*> asksDC font_props  -strokeAttr :: (Applicative m, DrawingCtxM m) => m (RGBi, StrokeAttr)+strokeAttr :: DrawingCtxM m => m (RGBi, StrokeAttr) strokeAttr = (,) <$> asksDC stroke_colour <*> asksDC stroke_props -withStrokeAttr :: (Applicative m, DrawingCtxM m) -               => (RGBi -> StrokeAttr -> a) -> m a+withStrokeAttr :: DrawingCtxM m => (RGBi -> StrokeAttr -> a) -> m a withStrokeAttr fn = fn <$> asksDC stroke_colour <*> asksDC stroke_props  -fillAttr :: (Applicative m, DrawingCtxM m) => m RGBi+fillAttr :: DrawingCtxM m => m RGBi fillAttr = asksDC fill_colour -withFillAttr :: (Applicative m, DrawingCtxM m) => (RGBi -> a) -> m a+withFillAttr :: DrawingCtxM m => (RGBi -> a) -> m a withFillAttr fn = fn <$> asksDC fill_colour -borderedAttr :: (Applicative m, DrawingCtxM m) => m (RGBi, StrokeAttr, RGBi)+borderedAttr :: DrawingCtxM m => m (RGBi, StrokeAttr, RGBi) borderedAttr = (,,) <$> asksDC fill_colour <*> asksDC stroke_props                                             <*> asksDC stroke_colour -withBorderedAttr :: (Applicative m, DrawingCtxM m) -                 => (RGBi -> StrokeAttr -> RGBi -> a) -> m a+withBorderedAttr :: DrawingCtxM m => (RGBi -> StrokeAttr -> RGBi -> a) -> m a withBorderedAttr fn =      fn <$> asksDC fill_colour <*> asksDC stroke_props                                <*> asksDC stroke_colour@@ -96,28 +95,21 @@   -lineWidth :: (Applicative m, DrawingCtxM m) => m Double+lineWidth :: DrawingCtxM m => m Double lineWidth = line_width <$> asksDC stroke_props -fontSize :: (Applicative m, DrawingCtxM m) => m Int+fontSize :: DrawingCtxM m => m Int fontSize = font_size <$> asksDC font_props    --- Maybe these functions are better as queries - i.e. functions--- of type DrawingR, e.g.--- --- > lineSpacing :: Fractional u => DrawingR u--- --- Then the /client/ can just bound the answer directly--- rather than using ------ > askDF lineSpacing >>= \u -> ...--- -lineSpacing :: (Applicative m, DrawingCtxM m, Fractional u) => m u-lineSpacing = +-- | 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 @@ -127,12 +119,11 @@ -- Arrowheads, dots etc. should generally be drawn at the mark  -- height. -- -markHeight :: (Applicative m, DrawingCtxM m, FromPtSize u) => m u+markHeight :: (DrawingCtxM m, FromPtSize u) => m u markHeight = (fromPtSize . xcharHeight . font_size) <$> asksDC font_props  -markHalfHeight :: (Applicative m, DrawingCtxM m, Fractional u, FromPtSize u) -               => m u+markHalfHeight :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u markHalfHeight = (0.5*) <$> markHeight  @@ -146,28 +137,28 @@  -------------------------------------------------------------------------------- -withFontSize :: (Applicative m, DrawingCtxM m) => (FontSize -> u) -> m u+withFontSize :: DrawingCtxM m => (FontSize -> u) -> m u withFontSize fn = (fn . font_size) <$> asksDC font_props -monoCharWidth :: (Applicative m, DrawingCtxM m, FromPtSize u) => m u+monoCharWidth :: (DrawingCtxM m, FromPtSize u) => m u monoCharWidth = withFontSize (fromPtSize . charWidth) -monoSpacerWidth :: (Applicative m, DrawingCtxM m, FromPtSize u) => m u+monoSpacerWidth :: (DrawingCtxM m, FromPtSize u) => m u monoSpacerWidth = withFontSize (fromPtSize . spacerWidth)  -monoTextWidth :: (Applicative m, DrawingCtxM m, FromPtSize u) => Int -> m u+monoTextWidth :: (DrawingCtxM m, FromPtSize u) => Int -> m u monoTextWidth n = withFontSize $ \sz -> fromPtSize $ textWidth sz n  -monoTextLength :: (Applicative m, DrawingCtxM m, FromPtSize u) => String -> m u+monoTextLength :: (DrawingCtxM m, FromPtSize u) => String -> m u monoTextLength ss = monoTextWidth $ charCount ss  -monoTextHeight :: (Applicative m, DrawingCtxM m, FromPtSize u) => m u+monoTextHeight :: (DrawingCtxM m, FromPtSize u) => m u monoTextHeight = withFontSize (fromPtSize . textHeight) -monoNumeralHeight :: (Applicative m, DrawingCtxM m, FromPtSize u) => m u+monoNumeralHeight :: (DrawingCtxM m, FromPtSize u) => m u monoNumeralHeight = withFontSize (fromPtSize . numeralHeight)  @@ -175,10 +166,10 @@ --   -- \'x\' has no ascenders or descenders.  -- -monoLowerxHeight :: (Applicative m, DrawingCtxM m, FromPtSize u) => m u+monoLowerxHeight :: (DrawingCtxM m, FromPtSize u) => m u monoLowerxHeight = withFontSize (fromPtSize . xcharHeight) -monoDescenderDepth :: (Applicative m, DrawingCtxM m, FromPtSize u) => m u+monoDescenderDepth :: (DrawingCtxM m, FromPtSize u) => m u monoDescenderDepth = withFontSize (fromPtSize . descenderDepth)  @@ -188,7 +179,7 @@ -- Note - the width will generally be a over-estimate for  -- non-monospaced fonts. -- -monoTextDimensions :: (Applicative m, DrawingCtxM m, Num u, Ord u, FromPtSize u)+monoTextDimensions :: (DrawingCtxM m, Num u, Ord u, FromPtSize u)                    => String -> m (u,u) monoTextDimensions ss =      (\sz -> post $ textBounds sz zeroPt ss) @@ -197,9 +188,22 @@     post bb = (boundaryWidth bb, boundaryHeight bb)  +monoMultiLineTextHeight :: (DrawingCtxM m, Fractional u, FromPtSize u) +                        => Int -> m u+monoMultiLineTextHeight n | n < 0   = pure 0+monoMultiLineTextHeight n           = +    (\h lsf -> h + (fromIntegral $ n-1) * (h * realToFrac lsf))+      <$> monoTextHeight <*> asksDC line_spacing_factor+ ++-- | The default padding is half of the /char width/.+--+monoDefaultPadding :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u+monoDefaultPadding = (0.5*) <$> monoCharWidth+ -- | Vector from baseline left to center-monoVecToCenter :: ( Applicative m, DrawingCtxM m-                   , Fractional u, Ord u, FromPtSize u ) +--+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

@@ -26,15 +26,16 @@     Path   , DPath   , length+  , append+  , pconcat   , line   , curve-  , tracePoints+  , traceLinePoints+  , traceCurvePoints   , curveByAngles    , toPrimPath -  , toPrimPathU -   , tipL   , tipR @@ -44,7 +45,12 @@   , directionL   , directionR -  , midpoint+  , midway+  , midway_+  , atstart+  , atstart_+  , atend+  , atend_    , PathViewL(..)   , DPathViewL@@ -63,16 +69,14 @@ import Data.AffineSpace import Data.VectorSpace -import Data.Maybe-import Data.Monoid+import Data.List ( foldl' )  import Data.Sequence ( Seq, (><), ViewL(..), viewl                      , ViewR(..), viewr, (<|) , (|>) ) import qualified Data.Sequence as S  import Prelude hiding ( length ) -data Path u = PathEmpty -            | Path { _path_length   :: u +data Path u = Path { _path_length   :: u                     , _path_start    :: Point2 u                    , _path_elements :: Seq (PathSeg u)                    , _path_end      :: Point2 u@@ -82,7 +86,7 @@ type DPath = Path Double  -- Annotating each segment with length is \*\* good \*\*.--- Makes it much more efficient to find the midpoint.+-- Makes it much more efficient to find the midway point. -- -- But what do we do about the start point: --@@ -116,24 +120,17 @@   length :: Num u => Path u -> u-length PathEmpty      = 0 length (Path u _ _ _) = u  append :: Floating u => Path u -> Path u -> Path u-append PathEmpty b         = b-append a         PathEmpty = a append (Path len1 start1 se1 end1) (Path len2 start2 se2 end2)      | end1 == start2 = Path (len1+len2) start1 (se1 >< se2) end2      | otherwise      = let join      = lineSegment end1 start2                            total_len = len1 + len2 + segmentLength join                        in Path total_len start1 (se1 >< (join <| se2)) end2  --instance Floating u => Monoid (Path u) where-  mempty  = PathEmpty-  mappend = append--+pconcat :: Floating u => Path u -> [Path u] -> Path u+pconcat p0 ps = foldl' append p0 ps  segmentLength :: PathSeg u -> u segmentLength (LineSeg u _ _)       = u@@ -164,16 +161,35 @@ curve p0 p1 p2 p3 = let v = curveLength p0 p1 p2 p3                     in Path v p0 (S.singleton $ CurveSeg v p0 p1 p2 p3) p3 --tracePoints :: Floating u => [Point2 u] -> Path u-tracePoints []       = PathEmpty-tracePoints [a]      = line a a-tracePoints (a:b:xs) = step (line a b) b xs+-- | 'traceLinePoints' throws a runtime error if the supplied list+-- is empty. +--+traceLinePoints :: Floating u => [Point2 u] -> Path u+traceLinePoints []       = error "traceLinePoints - empty point list."+traceLinePoints [a]      = line a a+traceLinePoints (a:b:xs) = step (line a b) b xs   where     step acc _ []     = acc-    step acc e (y:ys) = step (acc `mappend` line e y) y ys+    step acc e (y:ys) = step (acc `append` line e y) y ys  +-- | 'traceCurvePoints' consumes 4 points from the list on the +-- intial step (start, control1, control2, end) then steps +-- through the list taking 3 points at a time thereafter+-- (control1,control2, end). Leftover points are discarded.    +-- +-- 'traceCurvePoints' throws a runtime error if the supplied list+-- is has less than 4 elements (start, control1, control2, end). +--+traceCurvePoints :: (Floating u, Ord u) => [Point2 u] -> Path u+traceCurvePoints (a:b:c:d:xs) = step (curve a b c d) d xs+  where+    step acc p0 (x:y:z:zs) = step (acc `append` curve p0 x y z) z zs+    step acc _  _          = acc++traceCurvePoints _            = error "tracePointsCurve - less than 4 elems."++ curveByAngles :: (Floating u, Ord u)                => Point2 u -> Radian -> Radian -> Point2 u -> Path u curveByAngles start cin cout end = curve start (start .+^ v1) (end .+^ v2) end@@ -186,21 +202,16 @@  -- | Turn a Path into an ordinary PrimPath. ----- An empty path returns Nothing - the path representation in --- Wumpus-Core does not allow empty paths - a path must always--- have at least start point.--- -- Assumes path is properly formed - i.e. end point of one  -- segment is the same point as the start point of the next -- segment. ---toPrimPath :: Path u -> Maybe (PrimPath u)-toPrimPath PathEmpty         = Nothing+toPrimPath :: Path u -> PrimPath u toPrimPath (Path _ _ segs _) = step1 $ viewl segs   where-    step1 EmptyL                  = Nothing+    step1 EmptyL                  = error "toPrimPath - (not) unreachable."     step1 (e :< se)               = let (start,a) = seg1 e in -                                    Just $ path start $ a : step2 (viewl se)+                                    path start $ a : step2 (viewl se)      step2 EmptyL                  = []     step2 (e :< se)               = seg2 e : step2 (viewl se)@@ -210,11 +221,6 @@       seg2 (LineSeg  _ _  p1)       = lineTo p1     seg2 (CurveSeg _ _  p1 p2 p3) = curveTo p1 p2 p3- -toPrimPathU :: Path u -> PrimPath u-toPrimPathU = fromMaybe errK . toPrimPath-  where-    errK = error "toPathU - empty Path"   @@ -250,7 +256,7 @@ cordLength (Curve p0 _ _ p3) = vlength $ pvec p0 p3  --- | midpoint between two points+-- | mid-point between two points -- pointMidpoint :: Fractional u => Point2 u -> Point2 u -> Point2 u pointMidpoint p0 p1 = p0 .+^ v1 ^/ 2 where v1 = p1 .-. p0@@ -290,31 +296,34 @@ -------------------------------------------------------------------------------- -- tips  -tipL :: Path u -> Maybe (Point2 u)-tipL PathEmpty       = Nothing-tipL (Path _ sp _ _) = Just sp+tipL :: Path u -> Point2 u+tipL (Path _ sp _ _) = sp  -tipR :: Path u -> Maybe (Point2 u)-tipR PathEmpty       = Nothing-tipR (Path _ _ _ ep) = Just ep+tipR :: Path u -> Point2 u+tipR (Path _ _ _ ep) = ep   -- | Shorten both ends... --+-- u should be less-than half the path length+-- shortenBoth :: (Real u, Floating u) => u -> Path u -> Path u shortenBoth u p = shortenL u $ shortenR u p  -------------------------------------------------------------------------------- -- shorten from the left... +-- | Note - shortening a line from the left by +-- greater-than-or-equal its length is operationally equivalent +-- to making a zero-length line at the end point.+-- shortenL :: (Real u, Floating u) => u -> Path u -> Path u-shortenL _ PathEmpty          = PathEmpty shortenL n (Path u _ segs ep) -    | n >= u                  = PathEmpty+    | n >= u                  = line ep ep     | otherwise               = step n (viewl segs)   where-    step _ EmptyL     = PathEmpty+    step _ EmptyL     = line ep ep      -- should be unreachable     step d (e :< se)  = let z  = segmentLength e in                         case compare d z of                           GT -> step (d-z) (viewl se)@@ -323,10 +332,10 @@                                 in Path (u-n) (segmentStart e1) (e1 <| se) ep  -makeLeftPath :: u -> Seq (PathSeg u) -> Point2 u -> Path u+makeLeftPath :: Floating u => u -> Seq (PathSeg u) -> Point2 u -> Path u makeLeftPath u se ep =      case viewl se of-      EmptyL   -> PathEmpty +      EmptyL   -> line ep ep       (e :< _) -> Path u (segmentStart e) se ep  @@ -351,13 +360,16 @@ -------------------------------------------------------------------------------- -- shorten from the right ...  +-- | Note - shortening a line from the right by +-- greater-than-or-equal its length is operationally equivalent +-- to making a zero-length line at the start point.+-- shortenR :: (Real u, Floating u) => u -> Path u -> Path u-shortenR _ PathEmpty          = PathEmpty shortenR n (Path u sp segs _) -    | n >= u                  = PathEmpty+    | n >= u                  = line sp sp     | otherwise               = step n (viewr segs)   where-    step _ EmptyR     = PathEmpty+    step _ EmptyR     = line sp sp      -- should be unreachable     step d (se :> e)  = let z = segmentLength e in                         case compare d z of                           GT -> step (d-z) (viewr se)@@ -366,10 +378,10 @@                                 in Path (u-n) sp (se |> e1) (segmentEnd e1)                           -makeRightPath :: u -> Point2 u -> Seq (PathSeg u) -> Path u+makeRightPath :: Floating u => u -> Point2 u -> Seq (PathSeg u) -> Path u makeRightPath u sp se =      case viewr se of-      EmptyR   -> PathEmpty +      EmptyR   -> line sp sp       (_ :> e) -> Path u sp se (segmentEnd e)  @@ -399,33 +411,22 @@ -- | Direction of empty path is considered to be 0. -- directionL :: (Real u, Floating u) => Path u -> Radian-directionL PathEmpty        = 0 directionL (Path _ _ se _)  = step $ viewl se   where     step (LineSeg  _ p0 p1 :< _)      = lineDirection p1 p0  -- 1-to-0     step (CurveSeg _ p0 p1 _ _ :< _)  = lineDirection p1 p0-    step _                            = 0+    step _                            = 0       -- should be unreachable   -- | Direction of empty path is considered to be 0. -- directionR :: (Real u, Floating u) => Path u -> Radian-directionR PathEmpty       = 0 directionR (Path _ _ se _) = step $ viewr se   where     step (_ :> LineSeg  _ p0 p1)      = lineDirection p0 p1     step (_ :> CurveSeg _ _  _ p2 p3) = lineDirection p2 p3-    step _                            = 0+    step _                            = 0       -- should be unreachable              -{---- Note - previously Paths were using this version of --- lineDirection--- --- Needs testing as to whether the new one does what is expected. ----lineDirection :: (Real u, Floating u) => Point2 u -> Point2 u -> Radian-lineDirection p0 p1 = direction (pvec p0 p1)--}   @@ -434,22 +435,44 @@  -- Return direction as well because the calculation is expensive... ---midpoint :: (Real u, Floating u) => Path u -> Maybe (Point2 u, Radian)-midpoint pa = let u = length pa in-  if u == 0 then Nothing -            else let pa1 = shortenR (u/2) pa -                 in fmap (\a -> (a,directionR pa1)) $ tipR pa1+midway :: (Real u, Floating u) => Path u -> (Point2 u, Radian)+midway pa@(Path u sp _ _) +    | u == 0    = (sp,0)+    | otherwise = let pa1 = shortenR (u/2) pa in (tipR pa1, directionR pa1) +-- Just the midway point.+--+midway_ :: (Real u, Floating u) => Path u -> Point2 u+midway_ = fst . midway ++atstart :: (Real u, Floating u) => Path u -> (Point2 u, Radian)+atstart pa@(Path _ sp _ _) = (sp, directionL pa)++atstart_ :: Path u -> Point2 u+atstart_ (Path _ sp _ _) = sp+++atend :: (Real u, Floating u) => Path u -> (Point2 u, Radian)+atend pa@(Path _ _ _ ep) = (ep, directionR pa)+ ++atend_ :: Path u -> Point2 u+atend_ (Path _ _ _ ep) = ep+++-- nearstart, nearend, verynear ...++ -------------------------------------------------------------------------------- -data PathViewL u = EmptyPathL+data PathViewL u = PathOneL (PathSegment u)                  | PathSegment u :<< Path u   deriving (Eq,Ord,Show)   type DPathViewL = PathViewL Double -data PathViewR u = EmptyPathR+data PathViewR u = PathOneR (PathSegment u)                  | Path u :>> PathSegment u   deriving (Eq,Ord,Show)  @@ -467,16 +490,29 @@ type instance DUnit (PathSegment u) = u  pathViewL :: Num u => Path u -> PathViewL u-pathViewL PathEmpty          = EmptyPathL-pathViewL (Path u _ segs ep) = case viewl segs of-    EmptyL                         -> EmptyPathL -    (LineSeg v p0 p1 :< se)        -> Line1 p0 p1 :<< Path (u-v) p1 se ep-    (CurveSeg v p0 p1 p2 p3 :< se) -> Curve1 p0 p1 p2 p3 :<< Path (u-v) p3 se ep+pathViewL (Path u _ segs ep) = go (viewl segs)+  where+    go EmptyL                   = error "pathViewL - (not) unreachable."+     +    go (LineSeg v p0 p1 :< se)+        | S.null se             = PathOneL (Line1 p0 p1)+        | otherwise             = Line1 p0 p1 :<< Path (u-v) p1 se ep +    go (CurveSeg v p0 p1 p2 p3 :< se) +        | S.null se             = PathOneL (Curve1 p0 p1 p2 p3)+        | otherwise             = Curve1 p0 p1 p2 p3 :<< Path (u-v) p3 se ep + pathViewR :: Num u => Path u -> PathViewR u-pathViewR PathEmpty          = EmptyPathR-pathViewR (Path u _ segs ep) = case viewr segs of-    EmptyR                         -> EmptyPathR-    (se :> LineSeg v p0 p1)        -> Path (u-v) p1 se ep :>> Line1 p0 p1-    (se :> CurveSeg v p0 p1 p2 p3) -> Path (u-v) p3 se ep :>> Curve1 p0 p1 p2 p3+pathViewR (Path u _ segs ep) = go (viewr segs)+  where+    go EmptyR                   = error "pathViewR - (not) unreachable."++    go (se :> LineSeg v p0 p1) +        | S.null se             = PathOneR (Line1 p0 p1)+        | otherwise             = Path (u-v) p1 se ep :>> Line1 p0 p1++    go (se :> CurveSeg v p0 p1 p2 p3) +        | S.null se             = PathOneR (Curve1 p0 p1 p2 p3)+        | otherwise             = Path (u-v) p3 se ep :>> Curve1 p0 p1 p2 p3+

@@ -20,7 +20,7 @@ module Wumpus.Basic.Paths.Connectors    (  -    Connector+    ConnectorPath   , connect   , vhconn   , hvconn@@ -41,39 +41,39 @@  import Prelude hiding ( length ) -type Connector u = Point2 u -> Point2 u -> Path u+type ConnectorPath u = Point2 u -> Point2 u -> Path u -connect :: Floating u => Connector u+connect :: Floating u => ConnectorPath u connect = line -vhconn :: Floating u => Connector u+vhconn :: Floating u => ConnectorPath u vhconn p1@(P2 x1 _) p2@(P2 _ y2) = -    let mid = P2 x1 y2 in tracePoints [p1, mid, p2]+    let mid = P2 x1 y2 in traceLinePoints [p1, mid, p2] -hvconn :: Floating u => Connector u+hvconn :: Floating u => ConnectorPath u hvconn p1@(P2 _ y1) p2@(P2 x2 _) = -    let mid = P2 x2 y1 in tracePoints [p1, mid, p2]+    let mid = P2 x2 y1 in traceLinePoints [p1, mid, p2] -vhvconn :: Floating u => u -> Connector u-vhvconn v p1@(P2 x1 _) p2@(P2 x2 _) = tracePoints [p1, a1, a2, p2]+vhvconn :: Floating u => u -> ConnectorPath u+vhvconn v p1@(P2 x1 _) p2@(P2 x2 _) = traceLinePoints [p1, a1, a2, p2]   where     a1 = p1 .+^ vvec v     a2 = a1 .+^ hvec (x2 - x1)  -hvhconn :: Floating u => u -> Connector u-hvhconn h p1@(P2 _ y1) p2@(P2 _ y2) = tracePoints [p1,a1,a2,p2]+hvhconn :: Floating u => u -> ConnectorPath u+hvhconn h p1@(P2 _ y1) p2@(P2 _ y2) = traceLinePoints [p1,a1,a2,p2]   where     a1 = p1 .+^ hvec h     a2 = a1 .+^ vvec (y2 - y1) -curveconn :: (Floating u, Ord u) => Radian -> Radian -> Connector u+curveconn :: (Floating u, Ord u) => Radian -> Radian -> ConnectorPath u curveconn r1 r2 p1 p2 = curveByAngles p1 r1 r2 p2  -joint :: (Real u, Floating u) => u -> Connector u +joint :: (Real u, Floating u) => u -> ConnectorPath u  joint u p1@(P2 x1 y1) p2@(P2 x2 y2) = -    tracePoints [p1, mid_pt .+^ avec perp_ang u, p2]+    traceLinePoints [p1, mid_pt .+^ avec perp_ang u, p2]   where     mid_pt    = P2 (x1 + 0.5*(x2-x1)) (y1 + 0.5*(y2-y1))     perp_ang  = (pi*0.5) + direction (pvec p2 p1) 

@@ -42,14 +42,14 @@   ) where  import Wumpus.Basic.Paths.Base+import Wumpus.Basic.Utils.HList  import Wumpus.Core                              -- package: wumpus-core  import Data.AffineSpace                         -- package: vector-space  import Control.Applicative-import Data.Maybe-import Data.Monoid+import Data.List   -- Are connectors and paths quite different things?@@ -60,11 +60,11 @@   -- State monad version is quite good - it ameliorates the problem--- of joing to the end point of an empty path...+-- of joining to the end point of an empty path...  data St u = St       { current_point :: Point2 u -      , path_acc      :: Path u+      , path_acc      :: H (Path u)       }  @@ -91,18 +91,21 @@ -- Running the path is (probably) agnostic to the DrawingCtx. -- runPath :: Floating u => Point2 u -> PathM u a -> (a, Path u)-runPath start mf = let (a,s') = getPathM mf s in (a, path_acc s')+runPath start mf = +    let (a,s') = getPathM mf s in (a, post $ toListH $ path_acc s')   where     s = St { current_point = start-           , path_acc      = mempty+           , path_acc      = emptyH            }+    post []     = line start start+    post (x:xs) = foldl' append x xs    execPath :: Floating u => Point2 u -> PathM u a -> Path u execPath start mf = snd $ runPath start mf  snocline :: Floating u => Vec2 u -> PathM u () snocline v = PathM $ \(St pt ac) -> let ep = pt .+^ v -                                    in ((), St ep (ac `mappend` line pt ep))+                                    in ((), St ep (ac `snocH` line pt ep))   tip :: PathM u (Point2 u)@@ -110,7 +113,7 @@   lineto :: Floating u => Point2 u -> PathM u ()-lineto pt = PathM $ \(St p0 ac) -> ((), St pt (ac `mappend` line p0 pt))+lineto pt = PathM $ \(St p0 ac) -> ((), St pt (ac `snocH` line p0 pt))  rlineto :: Floating u => Vec2 u -> PathM u () rlineto (V2 dx dy) = tip >>= \(P2 x y) -> lineto (P2 (x+dx) (y+dy))@@ -127,7 +130,7 @@ bezierto :: (Floating u, Ord u)           => Point2 u -> Point2 u -> Point2 u -> PathM u () bezierto c1 c2 ep = PathM $ \(St p0 ac) -> -    ((), St ep (ac `mappend` curve p0 c1 c2 ep))+    ((), St ep (ac `snocH` curve p0 c1 c2 ep))   @@ -140,8 +143,8 @@         => Radian -> Radian -> Point2 u -> PathM u () curveto cin cout end = PathM $ \(St p0 ac) ->      let seg  = curveByAngles p0 cin cout end -        ac1  = ac `mappend` seg-        end1 = fromMaybe end $ tipR ac1+        ac1  = ac `snocH` seg+        end1 = tipR seg     in ((), St end1 ac1)   

@@ -34,7 +34,6 @@  import Data.Monoid - -- | The length of the control-point vector wants to be slighly  -- longer than half of /d/ (d - being the distance between the  -- /truncated/ points and the corner).@@ -49,22 +48,26 @@     cp2  = p3 .+^ (avec (langle p3 p2) len2)  +-- | 'roundEvery' throws a runtime error if the input list has+-- less than 3 eleemnts.+-- roundEvery :: (Real u, Floating u)             => u -> [Point2 u] -> Path u  roundEvery u (start:b:c:xs) = step (twoParts u start b c) (b:c:xs)   where-    step acc (m:n:o:ps)     = step (acc `mappend` twoParts u m n o) (n:o:ps)-    step acc [n,o]          = acc `mappend` twoParts u n o start-                                  `mappend` twoParts u o start b +    step acc (m:n:o:ps)     = step (acc `append` twoParts u m n o) (n:o:ps)+    step acc [n,o]          = acc `append` twoParts u n o start+                                  `append` twoParts u o start b      step acc _              = acc-roundEvery _ _              = mempty +roundEvery _ _              = error "roundEvery - input list too short." + -- | Two parts - line and corner curve... -- twoParts :: (Real u, Floating u)           => u ->  Point2 u -> Point2 u -> Point2 u -> Path u-twoParts u a b c = line p1 p2 `mappend` cornerCurve p2 b p3+twoParts u a b c = line p1 p2 `append` cornerCurve p2 b p3   where     p1 = a .+^ (avec (direction $ pvec a b) u)     p2 = b .+^ (avec (direction $ pvec b a) u)@@ -84,11 +87,11 @@ illustratePath :: Fractional u => Path u -> Graphic u illustratePath = localize (strokeColour black) . step1 . pathViewL   where-    step1 EmptyPathL = mempty-    step1 (e :<< se) = drawPathBoth e `mappend` rest (pathViewL se)+    step1 (PathOneL e)  = drawPath1 e+    step1 (e :<< se)    = drawPathBoth e `mappend` rest (pathViewL se) -    rest EmptyPathL = mempty-    rest (e :<< se) = drawPath1 e `mappend` rest (pathViewL se)+    rest (PathOneL e)   = drawPath1 e+    rest (e :<< se)     = drawPath1 e `mappend` rest (pathViewL se)  drawPathBoth :: Fractional u => PathSegment u -> Graphic u drawPathBoth pa@(Line1 p1 _)      = drawPath1 pa `mappend` pathPoint p1@@ -99,8 +102,8 @@     straightLineBetween p1 p2 `mappend` pathPoint p2  drawPath1 (Curve1 p1 p2 p3 p4) =  -    mconcat [ bezierCtrl p1 p2, bezierCtrl p4 p3, curveBetween p1 p2 p3 p4-            , pathPoint p4]+    mconcat [bezierCtrl p1 p2, bezierCtrl p4 p3, curveBetween p1 p2 p3 p4+                             , pathPoint p4 ]   bezierCtrl :: Fractional u => Point2 u -> Point2 u -> Graphic u

@@ -18,22 +18,22 @@ module Wumpus.Basic.SafeFonts   (    -- * Times Roman-    timesRoman-  , timesItalic-  , timesBold-  , timesBoldItalic+    times_roman+  , times_italic+  , times_bold+  , times_bold_italic    -- * Helvetica   , helvetica-  , helveticaOblique-  , helveticaBold-  , helveticaBoldOblique+  , helvetica_oblique+  , helvetica_bold+  , helvetica_bold_oblique    -- * Courier   , courier-  , courierOblique-  , courierBold-  , courierBoldOblique+  , courier_oblique+  , courier_bold+  , courier_bold_oblique    -- * Symbol   , symbol@@ -56,29 +56,29 @@  -- | Times-Roman -- -timesRoman :: FontFace-timesRoman = +times_roman :: FontFace+times_roman =      FontFace "Times-Roman" "Times New Roman" SVG_REGULAR latin1_font_encoder  -- | Times Italic ---timesItalic :: FontFace-timesItalic = +times_italic :: FontFace+times_italic =      FontFace "Times-Italic" "Times New Roman" SVG_ITALIC latin1_font_encoder                         -- | Times Bold ---timesBold :: FontFace-timesBold = +times_bold :: FontFace+times_bold =      FontFace "Times-Bold" "Times New Roman" SVG_BOLD latin1_font_encoder  -- | Times Bold Italic ---timesBoldItalic :: FontFace-timesBoldItalic = FontFace "Times-BoldItalic" -                           "Times New Roman" -                           SVG_BOLD_ITALIC -                           latin1_font_encoder+times_bold_italic :: FontFace+times_bold_italic = FontFace "Times-BoldItalic" +                             "Times New Roman" +                             SVG_BOLD_ITALIC +                             latin1_font_encoder   --------------------------------------------------------------------------------@@ -92,24 +92,24 @@  -- | Helvetica Oblique ---helveticaOblique :: FontFace-helveticaOblique = +helvetica_oblique :: FontFace+helvetica_oblique =      FontFace "Helvetica-Oblique" "Helvetica" SVG_OBLIQUE latin1_font_encoder  -- | Helvetica Bold -- -helveticaBold :: FontFace-helveticaBold = +helvetica_bold :: FontFace+helvetica_bold =      FontFace "Helvetica-Bold" "Helvetica" SVG_BOLD latin1_font_encoder   -- | Helvetica Bold Oblique ---helveticaBoldOblique :: FontFace-helveticaBoldOblique = FontFace "Helvetica-Bold-Oblique" -                                "Helvetica" -                                SVG_BOLD_OBLIQUE -                                latin1_font_encoder+helvetica_bold_oblique :: FontFace+helvetica_bold_oblique = FontFace "Helvetica-Bold-Oblique" +                                  "Helvetica" +                                  SVG_BOLD_OBLIQUE +                                  latin1_font_encoder   @@ -122,24 +122,24 @@  -- | Courier Oblique -- -courierOblique :: FontFace-courierOblique = +courier_oblique :: FontFace+courier_oblique =      FontFace "Courier-Oblique" "Courier New" SVG_OBLIQUE latin1_font_encoder  -- | Courier Bold -- -courierBold :: FontFace-courierBold = +courier_bold :: FontFace+courier_bold =      FontFace "Courier-Bold" "Courier New" SVG_BOLD latin1_font_encoder   -- | Courier Bold Oblique -- -courierBoldOblique :: FontFace-courierBoldOblique = FontFace "Courier-Bold-Oblique" -                              "Courier New" -                              SVG_BOLD_OBLIQUE -                              latin1_font_encoder+courier_bold_oblique :: FontFace+courier_bold_oblique = FontFace "Courier-Bold-Oblique" +                                "Courier New" +                                SVG_BOLD_OBLIQUE +                                latin1_font_encoder  -------------------------------------------------------------------------------- -- Symbol

@@ -0,0 +1,29 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Shapes+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Shim module for Shapes.+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.Shapes+  ( +    module Wumpus.Basic.Shapes.Base+  , module Wumpus.Basic.Shapes.Coordinate+  , module Wumpus.Basic.Shapes.Derived+  , module Wumpus.Basic.Shapes.Plaintext++  ) where++import Wumpus.Basic.Shapes.Base+import Wumpus.Basic.Shapes.Coordinate+import Wumpus.Basic.Shapes.Derived hiding ( mkRectangle )+import Wumpus.Basic.Shapes.Plaintext

@@ -14,6 +14,9 @@ -- -- Common core for shapes -- +-- \*\* WARNING \*\* - the types of Shapes and Plaintext are not+-- ideal and are pending revision.+-- --------------------------------------------------------------------------------  module Wumpus.Basic.Shapes.Base@@ -21,8 +24,11 @@       Shape(..)+  , ShapeConstructor -  , drawShape+  , borderedShape+  , filledShape+  , strokedShape    -- * ShapeCTM    , ShapeCTM(..)@@ -31,23 +37,16 @@   , ctmDisplace   , ctmCenter -  , ShapeLabel-  , runShapeLabel-  , nolabel-  , shapelabel    ) where  import Wumpus.Basic.Graphic-+import Wumpus.Basic.Paths  import Wumpus.Core                              -- package: wumpus-core -import Data.AffineSpace                         -- package: vector-space - import Control.Applicative-import Data.Monoid   -- | Note - this formulation prevents rounded corner shapes...@@ -65,21 +64,32 @@ -- DrawingContext for the /shape/ -- -data Shape u sh =  Shape -      { src_ctm :: ShapeCTM u -      , out_fun :: ShapeCTM u -> Image u sh+data Shape u t =  Shape +      { src_ctm   :: ShapeCTM u +      , path_fun  :: ShapeCTM u -> Path u+      , cons_fun   :: ShapeCTM u -> t u       }  type instance DUnit (Shape u sh) = u  +type ShapeConstructor u t = ShapeCTM u -> t u    -drawShape :: Shape u sh -> Image u sh-drawShape (Shape { src_ctm = ctm, out_fun = fn }) = fn ctm +borderedShape :: Num u => Shape u t -> Image u (t u)+borderedShape (Shape { src_ctm = ctm, path_fun = pf, cons_fun = objf }) = +   intoImage (pure $ objf ctm) (borderedPath $ toPrimPath $ pf ctm) +filledShape :: Num u => Shape u t -> Image u (t u)+filledShape (Shape { src_ctm = ctm, path_fun = pf, cons_fun = objf }) = +   intoImage (pure $ objf ctm) (filledPath $ toPrimPath $ pf ctm) +strokedShape :: Num u => Shape u t -> Image u (t u)+strokedShape (Shape { src_ctm = ctm, path_fun = pf, cons_fun = objf }) = +   intoImage (pure $ objf ctm) (closedStroke $ toPrimPath $ pf ctm)++ instance (Real u, Floating u) => Rotate (Shape u sh) where   rotate r = updateCTM (rotateCTM r) @@ -90,7 +100,7 @@   translate x y = updateCTM (translateCTM x y)  updateCTM :: (ShapeCTM u -> ShapeCTM u) -> Shape u sh -> Shape u sh-updateCTM fn (Shape ctm out) = Shape (fn ctm) out+updateCTM fn (Shape ctm pf mkf) = Shape (fn ctm) pf mkf  -------------------------------------------------------------------------------- -- CTM@@ -106,7 +116,7 @@       , ctm_scale_y             :: !u       , ctm_rotation            :: Radian       }-  deriving (Eq,Show)+  deriving (Eq,Ord,Show)  type instance DUnit (ShapeCTM u) = u @@ -150,28 +160,3 @@ ctmCenter = ctmDisplace zeroPt  -newtype ShapeLabel u = ShapeLabel { getShapeLabel :: ShapeCTM u -> Graphic u }--runShapeLabel :: ShapeCTM u -> ShapeLabel u -> Graphic u-runShapeLabel ctm sl = getShapeLabel sl ctm--nolabel :: ShapeLabel u-nolabel = ShapeLabel $ \_ -> mempty---- | No scaling - change font size if needed.----shapelabel :: (Real u, Floating u, FromPtSize u) -             => String -> ShapeLabel u-shapelabel text = -   ShapeLabel $ \(ShapeCTM { ctm_trans_x=dx, ctm_trans_y=dy-                           , ctm_rotation = ang }) ->-                   monoVecToCenter text >>= \v -> -                   let ctr = P2 dx dy; bl = ctr .-^ v in -                   rotTextline ang text (rotateAbout ang ctr bl)---rotTextline :: (Real u, Floating u) => Radian -> String -> LocGraphic u-rotTextline theta ss baseline_left = -    withTextAttr $ \rgb attr -> -        singleH $ rotatePrim theta $ textlabel rgb attr ss baseline_left-     

@@ -0,0 +1,88 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Shapes.Coordinate+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Coordinate is a bit like a shape but does not generate a path +-- and cannot be scaled or rotated (it can be translated).+-- +-- \*\* WARNING \*\* - the types of Shapes and Coordinate are not+-- ideal and are pending revision.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Shapes.Coordinate+  (+    CoordinateAnchor+  , DCoordinateAnchor+  , Coordinate+  , DCoordinate+  , coordinate++  , coordinateMark++  ) where++import Wumpus.Basic.Anchors+import Wumpus.Basic.Graphic++import Wumpus.Core                              -- package: wumpus-core++++++--------------------------------------------------------------------------------+-- | Coordinate++data CoordinateAnchor u = CoordinateAnchor+      { coord_x   :: !u+      , coord_y   :: !u+      }+  deriving (Eq,Ord,Show)++type DCoordinateAnchor = CoordinateAnchor Double++type instance DUnit (CoordinateAnchor u) = u++newtype Coordinate u = Coordinate { getCoordinate :: CoordinateAnchor u }+  deriving (Eq,Ord,Show)++type DCoordinate = Coordinate Double++type instance DUnit (Coordinate u) = u+++instance (Real u, Floating u) => CenterAnchor (CoordinateAnchor u) where+  center (CoordinateAnchor x y) = P2 x y++instance Num u => Translate (Coordinate u) where+  translate dx dy = Coordinate . fn . getCoordinate +    where +      fn (CoordinateAnchor x y) = CoordinateAnchor (x+dx) (y+dy)++-- Need a differentiation at the type level between a coord+-- that can be translated (moved) and a coord that anchors...++coordinate :: Num u => Point2 u -> Coordinate u+coordinate (P2 x y) = Coordinate $ CoordinateAnchor { coord_x = x, coord_y = y }++-- Note - should @coordinate@ take a point, Shapes don\'t.+++coordinateMark :: (Real u, Floating u) +               => Coordinate u -> Image u (CoordinateAnchor u)+coordinateMark x = intoImage (return $ getCoordinate x) (drawCoord x)++drawCoord :: (Real u, Floating u) => Coordinate u -> Graphic u+drawCoord coord = +   localize bothStrokeColour $ filledEllipse 2 2 (center $ getCoordinate coord)+

@@ -13,7 +13,10 @@ -- Stability   :  highly unstable -- Portability :  GHC --+-- Simple shapes - rectangle, circle diamond, ellipse. -- +-- \*\* WARNING \*\* - the types of Shapes and Plaintext are not+-- ideal and are pending revision. --  -------------------------------------------------------------------------------- @@ -22,35 +25,31 @@     Rectangle   , DRectangle   , rectangle-  , lrectangle+  , rrectangle +  , mkRectangle   -- hidden in Shim module+   , Circle   , DCircle   , circle-  , lcircle -  , Coordinate-  , DCoordinate-  , coordinate    , Diamond   , DDiamond   , diamond-  , ldiamond+  , rdiamond +   , Ellipse   , DEllipse   , ellipse-  , lellipse -  , FreeLabel-  , DFreeLabel-  , freelabel    ) where  import Wumpus.Basic.Anchors-import Wumpus.Basic.Graphic+import Wumpus.Basic.Paths+import Wumpus.Basic.Paths.RoundCorners import Wumpus.Basic.Shapes.Base import Wumpus.Basic.Utils.Intersection @@ -58,9 +57,11 @@  import Data.AffineSpace                         -- package: vector-space  -import Data.Monoid +remapPoints :: (Real u, Floating u) => [Point2 u] -> ShapeCTM u -> [Point2 u]+remapPoints xs ctm = map (ctmDisplace `flip` ctm) xs + -------------------------------------------------------------------------------- -- Rectangle @@ -69,7 +70,7 @@       , rect_hw     :: !u       , rect_hh     :: !u        }-  deriving (Eq,Show)+  deriving (Eq,Ord,Show)  type DRectangle = Rectangle Double @@ -104,37 +105,43 @@     where        ctr = ctmCenter $ rect_ctm rect -rectangle :: (Real u, Floating u) => u -> u -> Shape u (Rectangle u)-rectangle w h = Shape { src_ctm = identityCTM-                      , out_fun = outputRect (0.5*w) (0.5*h) nolabel-                      } +-- | 'rectangle'  : @ width * height -> shape @+--+rectangle :: (Real u, Floating u) => u -> u -> Shape u Rectangle+rectangle w h = +    Shape { src_ctm   = identityCTM+          , path_fun  = traceLinePoints . rectanglePoints (0.5*w) (0.5*h)+          , cons_fun  = mkRectangle (0.5*w) (0.5*h)  +          } -lrectangle :: (Real u, Floating u, FromPtSize u) -           => u -> u -> String -> Shape u (Rectangle u)-lrectangle w h ss = Shape { src_ctm = identityCTM-                          , out_fun = outputRect (0.5*w) (0.5*h) (shapelabel ss)-                          }+-- | 'rectangle'  : @ round_length * width * height -> shape @+--+rrectangle :: (Real u, Floating u) => u -> u -> u -> Shape u Rectangle+rrectangle round_dist w h = +    Shape { src_ctm   = identityCTM+          , path_fun  = roundEvery round_dist . rectanglePoints (0.5*w) (0.5*h)+          , cons_fun  = mkRectangle (0.5*w) (0.5*h)  +          }  -outputRect :: (Real u, Floating u) -           => u -> u -> ShapeLabel u -> ShapeCTM u -> Image u (Rectangle u)-outputRect hw hh shl ctm = intoImage (return a) (drawRect a `mappend` label) -  where-    a     = Rectangle { rect_ctm = ctm, rect_hw = hw, rect_hh = hh }-    label = runShapeLabel ctm shl +mkRectangle :: u -> u -> ShapeConstructor u Rectangle+mkRectangle hw hh = \ctm -> +    Rectangle { rect_ctm = ctm, rect_hw = hw, rect_hh = hh } -drawRect :: (Real u, Floating u) => Rectangle u -> Graphic u-drawRect = borderedPath . rectPath  -rectPath :: (Real u, Floating u) => Rectangle u -> PrimPath u-rectPath rect = vertexPath [ southwest rect-                           , southeast rect-                           , northeast rect-                           , northwest rect-                           ]+-- Note - the Paths modules should define a function for building+-- rectangles (and polygons, bezier curves / ellipses ...)+--+rectanglePoints :: (Real u, Floating u) => u -> u -> ShapeCTM u -> [Point2 u]+rectanglePoints hw hh = remapPoints [ se, ne, nw, sw ]+  where+    se = P2   hw  (-hh)+    ne = P2   hw    hh+    nw = P2 (-hw)   hh+    sw = P2 (-hw) (-hh)    @@ -162,86 +169,46 @@ calcCircPoint f (Circle { circ_ctm = ctm, circ_radius = rad }) =     let pt = f rad in ctmDisplace pt ctm -instance (Real u, Floating u) => CardinalAnchor (Circle u) where-  north = calcCircPoint $ \ r -> P2 0  r-  south = calcCircPoint $ \ r -> P2 0 (-r)-  east  = calcCircPoint $ \ r -> P2 r  0-  west  = calcCircPoint $ \ r -> P2 (-r) 0 + instance (Real u, Floating u) => RadialAnchor (Circle u) where   radialAnchor theta = calcCircPoint $ \r -> zeroPt .+^ avec theta r +instance (Real u, Floating u) => CardinalAnchor (Circle u) where+  north = calcCircPoint $ \r -> P2 0    r+  south = calcCircPoint $ \r -> P2 0  (-r)+  east  = calcCircPoint $ \r -> P2 r    0+  west  = calcCircPoint $ \r -> P2 (-r) 0 + instance (Real u, Floating u) => CardinalAnchor2 (Circle u) where   northeast = radialAnchor (0.25*pi)   southeast = radialAnchor (1.75*pi)   southwest = radialAnchor (1.25*pi)   northwest = radialAnchor (0.75*pi) --circle :: (Real u, Floating u) => u -> Shape u (Circle u)-circle radius = Shape { src_ctm = identityCTM-                      , out_fun = outputCirc radius nolabel-                      }---lcircle :: (Real u, Floating u, FromPtSize u) -        => u -> String -> Shape u (Circle u)-lcircle radius ss = Shape { src_ctm = identityCTM-                          , out_fun = outputCirc radius (shapelabel ss)-                          }--outputCirc :: (Real u, Floating u) -           => u -> ShapeLabel u -> ShapeCTM u -> Image u (Circle u)-outputCirc rad shl ctm = intoImage (return a) (drawCirc a `mappend` label) -  where-    a     = Circle { circ_ctm = ctm, circ_radius = rad }-    label = runShapeLabel ctm shl+-- | 'circle'  : @ radius -> shape @+--+circle :: (Real u, Floating u) => u -> Shape u Circle+circle radius = +    Shape { src_ctm  = identityCTM+          , path_fun = traceCurvePoints . circlePoints radius+          , cons_fun = mkCircle radius+          }  -drawCirc :: (Real u, Floating u) => Circle u -> Graphic u-drawCirc = borderedPath . circlePath+mkCircle :: u -> ShapeConstructor u Circle+mkCircle radius = \ctm -> Circle { circ_ctm = ctm, circ_radius = radius }  -circlePath :: (Real u, Floating u) => Circle u -> PrimPath u-circlePath = curvedPath . circlePoints --circlePoints :: (Real u, Floating u) => Circle u -> [Point2 u]-circlePoints (Circle { circ_ctm=ctm, circ_radius=radius }) = map fn all_points+circlePoints :: (Real u, Floating u) => u -> ShapeCTM u -> [Point2 u]+circlePoints radius ctm = map fn all_points   where     fn pt       = ctmDisplace pt ctm     all_points  = bezierCircle 2 radius zeroPt   ------------------------------------------------------------------------------------ | Coordinate -data Coordinate u = Coordinate-      { coord_ctm   :: ShapeCTM u -      }--type DCoordinate = Coordinate Double--type instance DUnit (Coordinate u) = u--instance (Real u, Floating u) => CenterAnchor (Coordinate u) where-  center = ctmCenter . coord_ctm---coordinate :: (Real u, Floating u) => Shape u (Coordinate u)-coordinate = Shape { src_ctm = identityCTM-                   , out_fun = outputCoord-                   }--outputCoord :: (Real u, Floating u) => ShapeCTM u -> Image u (Coordinate u)-outputCoord ctm = intoImage (return a) (drawCoord a) -  where-    a = Coordinate { coord_ctm = ctm }---drawCoord :: (Real u, Floating u) => Coordinate u -> Graphic u-drawCoord coord = localize swapColours $ filledEllipse 2 2 (center coord)- -------------------------------------------------------------------------------- -- Diamond @@ -261,6 +228,10 @@   center = ctmCenter . dia_ctm  ++++ calcDiaPoint :: (Real u, Floating u)               => (u -> u -> Point2 u) -> Diamond u -> Point2 u calcDiaPoint f (Diamond { dia_ctm = ctm, dia_hw = hw, dia_hh = hh }) =@@ -272,35 +243,47 @@   east  = calcDiaPoint $ \ hw _  -> P2 hw 0   west  = calcDiaPoint $ \ hw _  -> P2 (-hw) 0 -diamond :: (Real u, Floating u) => u -> u -> Shape u (Diamond u)-diamond hw hh = Shape { src_ctm = identityCTM-                      , out_fun = outputDia hw hh nolabel-                      }  -ldiamond :: (Real u, Floating u, FromPtSize u) -         => u -> u -> String -> Shape u (Diamond u)-ldiamond hw hh ss = Shape { src_ctm = identityCTM-                          , out_fun = outputDia hw hh (shapelabel ss)-                          } +-- | 'diamond'  : @ half_width * half_height -> shape @+--+-- Note - args might change to tull_width and full_height...+--+diamond :: (Real u, Floating u) => u -> u -> Shape u Diamond+diamond hw hh = +    Shape { src_ctm  = identityCTM+          , path_fun = traceLinePoints . diamondPoints hw hh+          , cons_fun = mkDiamond hw hh+          } +-- | 'rdiamond'  : @ round_length * half_width * half_height -> shape @+--+-- Note - args might change to full_width and full_height...+--+rdiamond :: (Real u, Floating u) => u -> u -> u -> Shape u Diamond+rdiamond round_dist hw hh = +    Shape { src_ctm  = identityCTM+          , path_fun = roundEvery round_dist . diamondPoints hw hh+          , cons_fun = mkDiamond hw hh+          } -outputDia :: (Real u, Floating u) -          => u -> u -> ShapeLabel u -> ShapeCTM u -> Image u (Diamond u)-outputDia hw hh shl ctm = intoImage (return a) (drawDia a `mappend` label) -  where-    a     = Diamond { dia_ctm = ctm, dia_hw = hw, dia_hh = hh }-    label = runShapeLabel ctm shl -drawDia :: (Real u, Floating u) => Diamond u -> Graphic u-drawDia = borderedPath . diamondPath  -diamondPath :: (Real u, Floating u) => Diamond u -> PrimPath u-diamondPath dia = vertexPath [ south dia, east dia, north dia, west dia ]+mkDiamond :: (Real u, Floating u) => u -> u -> ShapeConstructor u Diamond+mkDiamond hw hh = \ctm -> Diamond { dia_ctm = ctm, dia_hw = hw, dia_hh = hh }  +diamondPoints :: (Real u, Floating u) => u -> u -> ShapeCTM u -> [Point2 u]+diamondPoints hw hh = remapPoints [ s, e, n, w ]+  where+    s = P2   0  (-hh)+    e = P2   hw    0+    n = P2   0    hh+    w = P2 (-hw)   0 ++ -------------------------------------------------------------------------------- -- Ellipse @@ -321,91 +304,52 @@   center = ctmCenter . ell_ctm  -ellipse :: (Real u, Floating u) => u -> u -> Shape u (Ellipse u)-ellipse rx ry = Shape { src_ctm = identityCTM-                      , out_fun = outputEll rx ry nolabel-                      }--lellipse :: (Real u, Floating u, FromPtSize u) -         => u -> u -> String -> Shape u (Ellipse u)-lellipse rx ry ss = Shape { src_ctm = identityCTM-                          , out_fun = outputEll rx ry (shapelabel ss)-                          }-+calcEllPoint :: (Real u, Floating u) +              => (u -> Point2 u) -> Ellipse u -> Point2 u+calcEllPoint f (Ellipse { ell_ctm = ctm, ell_rx = rx, ell_ry = ry }) =+    let p   = f rx; p'  = scaleEll rx ry p+    in ctmDisplace p' ctm -outputEll :: (Real u, Floating u) -          => u -> u -> ShapeLabel u -> ShapeCTM u -> Image u (Ellipse u)-outputEll rx ry shl ctm = intoImage (return a) (drawEll a `mappend` label)-  where-    a     = Ellipse { ell_ctm = ctm, ell_rx = rx, ell_ry = ry }-    label = runShapeLabel ctm shl+instance (Real u, Floating u) => RadialAnchor (Ellipse u) where+  radialAnchor theta = calcEllPoint $ \rx -> zeroPt .+^ avec theta rx  -drawEll :: (Real u, Floating u) => Ellipse u -> Graphic u-drawEll = borderedPath . ellipsePath+instance (Real u, Floating u) => CardinalAnchor (Ellipse u) where+  north = radialAnchor (0.5*pi)+  south = radialAnchor (1.5*pi)+  east  = radialAnchor  0+  west  = radialAnchor  pi  -ellipsePath :: (Real u, Floating u) => Ellipse u -> PrimPath u-ellipsePath = curvedPath . ellipsePoints--ellipsePoints :: (Real u, Floating u) => Ellipse u -> [Point2 u]-ellipsePoints (Ellipse { ell_ctm=ctm, ell_rx=rx, ell_ry=ry }) = -    map (ctmDisplace `flip` ctm) all_points-  where-    all_points  = map (rescale rx ry) $ bezierCircle 2 rx zeroPt +instance (Real u, Floating u) => CardinalAnchor2 (Ellipse u) where+  northeast = radialAnchor (0.25*pi)+  southeast = radialAnchor (1.75*pi)+  southwest = radialAnchor (1.25*pi)+  northwest = radialAnchor (0.75*pi)  --- | x_radius is the unit length.+-- | 'ellipse'  : @ x_radii * y_radii -> shape @ ---rescale :: (Scale t, Fractional u, u ~ DUnit t) => u -> u -> t -> t-rescale rx ry = scale 1 (ry/rx) +ellipse :: (Real u, Floating u) => u -> u -> Shape u Ellipse+ellipse rx ry = +    Shape { src_ctm  = identityCTM+          , path_fun = traceCurvePoints . ellipsePoints rx ry+          , cons_fun = mkEllipse rx ry  +          }  ------------------------------------------------------------------------------------ Free label --- Free label is a rectangle that /is not drawn/, the --- constructor should always create some text.--newtype FreeLabel u = FreeLabel { getFreeLabel :: Rectangle u }---type DFreeLabel = FreeLabel Double+mkEllipse :: (Real u, Floating u) => u -> u -> ShapeConstructor u Ellipse+mkEllipse rx ry = \ctm -> Ellipse { ell_ctm = ctm, ell_rx = rx, ell_ry = ry } -type instance DUnit (FreeLabel u) = u+ellipsePoints :: (Real u, Floating u) => u -> u -> ShapeCTM u -> [Point2 u]+ellipsePoints rx ry ctm = +    map ((ctmDisplace `flip` ctm) . scaleEll rx ry) $ bezierCircle 2 rx zeroPt   -instance (Real u, Floating u) => CenterAnchor (FreeLabel u) where-  center = center . getFreeLabel+-- | x_radius is the unit length.+--+scaleEll :: (Scale t, Fractional u, u ~ DUnit t) => u -> u -> t -> t+scaleEll rx ry = scale 1 (ry/rx)   -instance (Real u, Floating u) => CardinalAnchor (FreeLabel u) where-  north = north . getFreeLabel-  south = south . getFreeLabel-  east  = east . getFreeLabel-  west  = west . getFreeLabel--instance (Real u, Floating u) => CardinalAnchor2 (FreeLabel u) where-  northeast = northeast . getFreeLabel-  southeast = southeast . getFreeLabel-  southwest = southwest . getFreeLabel-  northwest = northwest . getFreeLabel--instance (Real u, Floating u) => RadialAnchor (FreeLabel u) where-  radialAnchor theta = radialAnchor theta . getFreeLabel--freelabel :: (Real u, Floating u, FromPtSize u) -          => String -> Shape u (FreeLabel u)-freelabel ss = Shape { src_ctm = identityCTM-                     , out_fun = outputStringLbl ss-                     }--outputStringLbl :: (Real u, Floating u, FromPtSize u) -                => String -> ShapeCTM u -> Image u (FreeLabel u)-outputStringLbl ss ctm = -    intoImage (monoTextDimensions ss >>= \(w,h) -> return (mkrect w h)) label-  where-    mkrect w h = FreeLabel $ Rectangle { rect_ctm = ctm-                                       , rect_hw  = 0.5*w-                                       , rect_hh  = 0.5*h }-    label = runShapeLabel ctm (shapelabel ss)

@@ -0,0 +1,150 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Shapes.Plaintext+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Plaintext is a bit like a shape but does not generate a path +-- and cannot be scaled (it can be rotated or translated).+--+-- \*\* WARNING \*\* - the types of Shapes and Plaintext are not+-- ideal and are pending revision.+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.Shapes.Plaintext+  (++    PlaintextAnchor+  , DPlaintextAnchor+  , Plaintext+  , DPlaintext++  , plaintext+  , drawText++  ) where++import Wumpus.Basic.Anchors+import Wumpus.Basic.Graphic+import Wumpus.Basic.Shapes.Base+import Wumpus.Basic.Shapes.Derived++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space++import Control.Applicative+++++--------------------------------------------------------------------------------+-- Free label++-- Free label is a rectangle that /is not drawn/, the +-- constructor should always create some text.++newtype PlaintextAnchor u = PlaintextAnchor  { getPlaintext :: Rectangle u }+++type DPlaintextAnchor = PlaintextAnchor Double++type instance DUnit (PlaintextAnchor u) = u+++data Plaintext u = Plaintext+      { text_text :: String     -- Note - generalize this for multi-line...+      , text_x    :: !u+      , text_y    :: !u+      , text_ang  :: !Radian+      }+  deriving (Eq,Ord,Show)++type DPlaintext = Plaintext Double++type instance DUnit (Plaintext u) = u+++instance (Real u, Floating u) => CenterAnchor (PlaintextAnchor u) where+  center = center . getPlaintext+++instance (Real u, Floating u) => CardinalAnchor (PlaintextAnchor u) where+  north = north . getPlaintext+  south = south . getPlaintext+  east  = east . getPlaintext+  west  = west . getPlaintext++instance (Real u, Floating u) => CardinalAnchor2 (PlaintextAnchor u) where+  northeast = northeast . getPlaintext+  southeast = southeast . getPlaintext+  southwest = southwest . getPlaintext+  northwest = northwest . getPlaintext++instance (Real u, Floating u) => RadialAnchor (PlaintextAnchor u) where+  radialAnchor theta = radialAnchor theta . getPlaintext++++instance Rotate (Plaintext u) where+  rotate dr = (\s i -> s { text_ang = i+dr }) <*> text_ang++-- Note - cannot scale Plaintext+++instance Num u => Translate (Plaintext u) where+  translate dx dy = (\s x y -> s { text_x = x+dx, text_y = y+dy }) +                      <*> text_x <*> text_y++++plaintext :: Num u => String -> Plaintext u+plaintext ss = Plaintext { text_text  = ss+                         , text_x     = 0+                         , text_y     = 0+                         , text_ang   = 0 }+++++drawText :: (Real u, Floating u, FromPtSize u)+         => Plaintext u -> Image u (PlaintextAnchor u)+drawText x = intoImage (oneLineRect x) (drawOneLine x)++++oneLineRect :: (Fractional u, Ord u, FromPtSize u) +        => Plaintext u -> DrawingR (PlaintextAnchor u)+oneLineRect ptext = +    monoTextDimensions (text_text ptext) >>= \(w,h) -> +    return (PlaintextAnchor $ mkRectangle (0.5*w) (0.5*h) ctm)+  where+    ctm = ShapeCTM { ctm_trans_x    = text_x ptext+                   , ctm_trans_y    = text_y ptext+                   , ctm_scale_x    = 1+                   , ctm_scale_y    = 1+                   , ctm_rotation   = text_ang ptext+                   }++drawOneLine :: (Real u, Floating u, FromPtSize u) +            => Plaintext u -> Graphic u +drawOneLine (Plaintext { text_text = ss, text_x=dx, text_y=dy+                       , text_ang = ang }) =+    monoVecToCenter ss >>= \v -> +    let ctr = P2 dx dy; bl = ctr .-^ v in +    rotTextline ang ss (rotateAbout ang ctr bl)++++rotTextline :: (Real u, Floating u) => Radian -> String -> LocGraphic u+rotTextline theta ss baseline_left = +    withTextAttr $ \rgb attr -> +        singleH $ rotatePrim theta $ textlabel rgb attr ss baseline_left

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

@@ -1,5 +1,5 @@ name:             wumpus-basic-version:          0.10.0+version:          0.11.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -16,55 +16,67 @@   .   Some of the modules (SafeFonts, SVGColours, X11Colours) are   relatively stable. The core modules of @Basic.Graphic@ (@Base@,-  @PrimGraphic@, @DrawingContext@) are quite weather-beaten if -  not exactly stable, although the newer modules -  (@ScalingContext@, @DirectionContext@) are still quite green.-  Other modules (Paths, Chains, Shapes) are essentially sketches -  and may be radically different in subsequent updates.+  @PrimGraphic@, @DrawingContext@) seem to support a good set+  primitive functions, but the exact types of drawing objects do +  not feel right at the moment. Other modules (Paths, Chains, +  Shapes) are essentially sketches and are expected to be+  substantially revised in subsequent updates.   .+  Version 0.11.0 is an interim release. It is expected that the +  next release will substantially rework Shapes and likely change+  the @Graphic.Base@ types. As quite a large amount of code has +  already changed since version 0.10.0 (to support better +  arrowheads and connectors) it seems sensible to release 0.11.0 +  now, rather than have a huge delta after Shapes have been +  reworked again. The current versions of @Wumpus-Tree@ and +  @Wumpus-Microprint@ will work with version 0.11.0 if their +  respective @.cabal@ files are edited to bump the version number. +  There will be no matching releases to work automatically with +  version 0.11.0 of Wumpus-Basic.   .   Changelog:   .-  0.9.0 to 0.10.0:-  .-  * @Basic.Graphic.BaseClasses@ and @Basic.Graphic.BaseTypes@ -    merged into same module so they can depend on each other -    without orphans instances.+  0.10.0 to 0.11.0:+  . +  * Reworked arrowheads and connectors - connectors are now +    configurable: there are functions to make connectors with +    a left arrowhead, right arrowhead, none or both.     .-  * @DrawingF@ renamed to @DrawingR@, the related type synonyms-    have also been changed, e.g. @LocDrawingF@ is now -    @LocDrawingR@.+  * Reworked shapes - internally shapes now create a @Path@ rather +    than a @Graphic@ this means the path can be manipulated (e.g. +    round cornered rectangles, diamonds... can be constructed).+    @Coordinate@ is no longer a @Shape@ - it is now similar object +    but of a different type. Likewise, @FreeLabel@ has been +    replaced by @Plaintext@ which is not a @Shape@, but has some +    similar properties. Unfortunately, the Shape types are still +    difficult to work with and a larger reworking is still +    necessary.   .-  * Method names in the @DrawingCtxM@ class changed - @askCtx@ is-    now @askDC@, @localCtx@ is now @localize@. Removed the -    functions @askDF@, @asksDF@, @pureDF@ that worked for -    @DrawingF@ (now @DrawingR@), @DrawingR@ now uses the -    Applicative\'s @pure@ and the @DrawingCtxM@ class for these -    functionalities.+  * @Basic.Paths.Base@ - @Path@ type changed, @PathEmpty@ +    constructor removed so empty paths cannot be created. This +    allows a better API for taking points on a path. It also +    means @Path@ is no longer an instance of Monoid. Type changes +    to various functions (e.g. @tipR@, @tipL@) reflecting that as +    paths cannot now be empty, functions on them can generally be +    total. @toPrimPathU@ removed as converting to a PrimPath as +    now always /safe/. @tracePoints@ renamed @traceLinePoints@, +    @tracePointsCurve@ renamed @traceCurvePoints@, @midpoint@ +    renamed @midway@.   .-  * @Basic.Graphic.DrawingContext@ - renamed @primary_colour@ to-    @stroke_colour@ and @secondary_colour@ to @fill_colour@. The -    setter functions has been similarly renamed.+  * @Basic.Graphic@ - the types @ConnDrawingR@, @ConnGraphic@ etc.+    have had their names expanded to @ConnectorDrawingR@, +    @ConnectorGraphic@...    .-  * Added the type synonym @DrawingContextF@ to -    @Basic.Graphic.DrawingContext@. Changed relevant function-    signatures to use it.+  * @Basic.SafeFont@ - font names changed to use underscore +    separators rather than camelCase. Wumpus generally uses +    underscored names for /constants/.   .-  * Re-worked the Path modules - base types entirely different,-    connectors entirely different, monadic path construction -    largely the same.+  * Removed @conn@ from @Basic.Graphic.Drawing@. Connectors should +    be used instead.   .-  * Initial work on round cornered paths.-  . -  * Removed the type class @TextAnchor@ from @Basic.Anchors@. -    This was a left-over from a previous implementation of -    Shapes and is not relevant to the current implementation.-  . -  * Added @DirectionContext@ to @Basic.Graphic@.+  * The class @DrawingCtxM@ now has @Applicative@ as a superclass.    .-  * @localLG@ removed it can be acheived with composition --    @localize upd . loc_graphic_function@. @lgappend@ is also -    removed - it can be recreated applicatively.+  * @lineSpacing@ renamed @baselineSpacing@.   .   . build-type:         Simple@@ -74,14 +86,14 @@ extra-source-files:   CHANGES,   LICENSE,-  demo/DotPic.hs,+  demo/ArrowCircuit.hs,   demo/ClipPic.hs,   demo/ColourCharts.hs,   demo/ColourDefns.hs,+  demo/DotPic.hs,   demo/FontPic.hs,   demo/PetriNet.hs,   demo/Picture.hs,-  demo/Shapes.hs,   demo/Symbols.hs  library@@ -95,6 +107,7 @@   exposed-modules:     Wumpus.Basic.Anchors,     Wumpus.Basic.Arrows,+    Wumpus.Basic.Arrows.Connectors,     Wumpus.Basic.Arrows.Tips,     Wumpus.Basic.Chains,     Wumpus.Basic.Chains.Base,@@ -119,8 +132,11 @@     Wumpus.Basic.Paths.Construction,     Wumpus.Basic.Paths.RoundCorners,     Wumpus.Basic.SafeFonts,+    Wumpus.Basic.Shapes,     Wumpus.Basic.Shapes.Base,+    Wumpus.Basic.Shapes.Coordinate,     Wumpus.Basic.Shapes.Derived,+    Wumpus.Basic.Shapes.Plaintext,     Wumpus.Basic.Text.LRSymbol,     Wumpus.Basic.Text.LRText,     Wumpus.Basic.Utils.HList,