wumpus-basic 0.8.0 → 0.9.0

raw patch · 34 files changed

+3204/−812 lines, 34 filesdep ~wumpus-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: wumpus-core

API changes (from Hackage documentation)

Files

• demo/ClipPic.hs +101/−0
• demo/ColourCharts.hs +19/−28
• demo/FontPic.hs +54/−76
• demo/Shapes.hs +141/−0
• demo/Symbols.hs +261/−0
• src/Wumpus/Basic/Anchors.hs +77/−0
• src/Wumpus/Basic/Arrows.hs +18/−19
• src/Wumpus/Basic/Arrows/Tips.hs +4/−3
• src/Wumpus/Basic/Chains.hs +29/−0
• src/Wumpus/Basic/Chains/Base.hs +161/−0
• src/Wumpus/Basic/Chains/Derived.hs +129/−0
• src/Wumpus/Basic/Dots.hs +4/−4
• src/Wumpus/Basic/Dots/Primitive.hs +8/−9
• src/Wumpus/Basic/Graphic.hs +4/−2
• src/Wumpus/Basic/Graphic/BaseClasses.hs +17/−2
• src/Wumpus/Basic/Graphic/Chain.hs +0/−87
• src/Wumpus/Basic/Graphic/Drawing.hs +3/−1
• src/Wumpus/Basic/Graphic/DrawingContext.hs +85/−44
• src/Wumpus/Basic/Graphic/PrimGraphic.hs +73/−28
• src/Wumpus/Basic/Graphic/Query.hs +192/−0
• src/Wumpus/Basic/Graphic/ScalingContext.hs +173/−0
• src/Wumpus/Basic/Monads/TurtleClass.hs +6/−45
• src/Wumpus/Basic/Monads/TurtleMonad.hs +35/−106
• src/Wumpus/Basic/Paths.hs +5/−140
• src/Wumpus/Basic/Paths/Base.hs +2/−4
• src/Wumpus/Basic/Paths/Connectors.hs +211/−0
• src/Wumpus/Basic/Paths/Construction.hs +53/−27
• src/Wumpus/Basic/Shapes/Base.hs +162/−0
• src/Wumpus/Basic/Shapes/Derived.hs +411/−0
• src/Wumpus/Basic/Text/LRSymbol.hs +647/−114
• src/Wumpus/Basic/Text/LRText.hs +70/−66
• src/Wumpus/Basic/Utils/Intersection.hs +2/−1
• src/Wumpus/Basic/VersionNumber.hs +2/−2
• wumpus-basic.cabal +45/−4

@@ -0,0 +1,101 @@+{-# OPTIONS -Wall #-}++-- Note - how the background is built in this example is very +-- expensive, i.e. it generates large PostScript and SVG files+-- because the text elements are drawn many more times than they+-- are actually seen.+--+-- This example just illustrates that clipping-paths work and +-- uses a complicated background to make that point.+--+++module ClipPic where++import Wumpus.Basic.Chains+import Wumpus.Basic.Colour.SVGColours+import Wumpus.Basic.Graphic+import Wumpus.Basic.Paths+import Wumpus.Basic.PictureLanguage+import Wumpus.Basic.Text.LRSymbol+import Wumpus.Basic.Text.LRText++import Wumpus.Core                              -- package: wumpus-core++import System.Directory+++main :: IO ()+main = do +    createDirectoryIfMissing True "./out/"+    >> writeEPS_latin1 "./out/clip_pic.eps" pic+    >> writeSVG_latin1 "./out/clip_pic.svg" pic+++pic_drawing_ctx :: DrawingContext+pic_drawing_ctx = standardContext 14+++pic :: DPicture+pic = pic1 `nextToV` (stackOver [cpic1, cpic2, cpic3] cpic4)+++pic1 :: DPicture+pic1 = liftToPictureU $ execDrawing pic_drawing_ctx $ +         localCtx (secondaryColour medium_slate_blue) $ do+            draw $ fillPath path01+            localCtx (secondaryColour powder_blue) $ +                     draw $ fillPath path02+            draw $ fillPath path03+            draw $ fillPath path04+++background :: RGBi -> DPicture +background rgb = liftToPictureU $ execDrawing pic_drawing_ctx $ +                   localCtx (primaryColour rgb) $ do                  +                     mapM_ iheartHaskell ps++   where+     ps = unchain (coordinateScalingContext 86 16) $ tableDown 18 8++cpic1 :: DPicture +cpic1 = clip (toPrimPathU path01) (background black)+  +cpic2 :: DPicture +cpic2 = clip (toPrimPathU path02) (background medium_violet_red)++cpic3 :: DPicture +cpic3 = clip (toPrimPathU path03) (background black)++cpic4 :: DPicture +cpic4 = clip (toPrimPathU path04) (background black)+++iheartHaskell :: Num u => FromPtSize u => Point2 u -> Drawing u () +iheartHaskell pt = +    draw $ (execLRText $ char 'I' >> heart >> mapM_ char "Haskell") `at` pt+++path01 :: Floating u => Path u+path01 = execPath zeroPt $ hline 80 >> rlineto (vec 112 160) +                                    >> rlineto (vec (-112) 160)+                                    >> hline (-80)+                                    >> rlineto (vec 112 (-160))+                                    >> rlineto (vec (-112) (-160))+ ++path02 :: Floating u => Path u+path02 = execPath (P2 112 0) $ hline 80 >> rlineto (vec 72 112)+                                        >> rlineto (vec 72 (-112))+                                        >> hline 80+                                        >> rlineto (vec (-224) 320)+                                        >> hline (-80)+                                        >> rlineto (vec 112 (-160))+                                        >> rlineto (vec (-112) (-160))++path03 :: Floating u => Path u+path03 = execPath (P2 384 96) $ hline 96 >> vline 56 >> hline (-136) ++path04 :: Floating u => Path u+path04 = execPath (P2 328 192) $ hline 152 >> vline 56 >> hline (-192) +

@@ -4,10 +4,12 @@  import ColourDefns +import Wumpus.Basic.Chains import Wumpus.Basic.Graphic  import Wumpus.Core                              -- package: wumpus-core +import Control.Monad import System.Directory  @@ -20,40 +22,29 @@     writeSVG_latin1 "./out/X11colours.svg" x11_landscape  svg :: Picture Double-svg = makePicture 60 160 all_svg_colours+svg = makePicture 52 all_svg_colours  x11_landscape :: Picture Double-x11_landscape = makePicture 60 140 all_x11_colours+x11_landscape = makePicture 52 all_x11_colours  x11_portrait :: Picture Double-x11_portrait = makePicture 72 140 all_x11_colours     --makePicture :: Int -> Double -> [(String,RGBi)] -> DPicture -makePicture row_count unit_width xs = -    liftToPictureU $ execDrawing (standardContext 10) $ -        downLeftRight row_count unit_width $ mapM_ fn xs-   where-     fn (name,rgb) = colourSample name rgb-+x11_portrait = makePicture 72 all_x11_colours      --- Note - cannot use node twice as it increments the point supply.----colourSample :: String -> RGBi -> ChainT Double (Drawing Double) ()-colourSample name rgb = localCtx (secondaryColour rgb) $ do -    { pt <- position -    ; draw $ borderedRectangle 15 10 `at` pt-    ; draw $ textline name `at` displace 20 2 pt -    }    +makePicture :: Int -> [(String,RGBi)] -> DPicture +makePicture row_count xs = +    liftToPictureU $ execDrawing (standardContext 9) $ +        tableGraphic row_count xs +tableGraphic :: Int -> [(String,RGBi)] -> Drawing Double ()+tableGraphic row_count xs = +    zipWithM_ (\(name,rgb) pt -> colourSample name rgb pt) xs ps+  where+    ps = unchain (coordinateScalingContext 152 11) $ tableDown row_count 10   -downLeftRight :: (Monad m, Num u, Ord u) -              => Int -> u -> ChainT u m a -> m a-downLeftRight row_count width ma = runChainT fn start_pt ma-  where-    y_top       = 12 * fromIntegral row_count-    start_pt    = P2 0 y_top-    -    fn (P2 x y) | y < 0     = P2 (x+width) y_top-                | otherwise = P2 x (y - 12)   +colourSample :: String -> RGBi -> DPoint2 -> Drawing Double ()+colourSample name rgb pt = localCtx (secondaryColour rgb) $ do +    draw $ borderedRectangle 15 10 `at` pt+    draw $ textline name `at` displace 20 2 pt +         

@@ -2,17 +2,15 @@  module FontPic where -import Wumpus.Basic.SafeFonts+import Wumpus.Basic.Chains+import Wumpus.Basic.Graphic import Wumpus.Basic.Colour.SVGColours ( steel_blue ) import Wumpus.Basic.Colour.X11Colours ( indian_red1 )-import Wumpus.Basic.PictureLanguage+import Wumpus.Basic.SafeFonts  import Wumpus.Core                              -- package: wumpus-core -import Data.AffineSpace                         -- package: vector-space-import Data.VectorSpace--import Data.List ( unfoldr )+import Control.Monad  import System.Directory @@ -29,103 +27,83 @@     writeSVG_latin1 "./out/font_symbol.svg"    symbol_pic  -makeFontLabel :: RGBi -> FontAttr -> DPoint2 -> DPrimElement-makeFontLabel rgb fa = textlabel rgb fa msg+fontMsg :: FontFace -> Int -> String+fontMsg ff sz = msgF []   where-    msg = unwords [ font_name $ font_face fa, (show $ font_size fa) ++ "pt"]+    msgF = showString (font_name ff) . showChar ' ' . shows sz . showString "pt" -blueLabel :: FontFace -> Int -> DPoint2 -> DPrimElement-blueLabel ff i = makeFontLabel steel_blue (FontAttr i ff) -redLabel :: FontFace -> Int -> DPoint2 -> DPrimElement-redLabel ff i = makeFontLabel indian_red1 (FontAttr i ff)+makeLabel :: RGBi -> FontFace -> Int -> DLocGraphic+makeLabel rgb ff sz = +    localLG (primaryColour rgb . fontsize sz . fontface ff) +            (textline $ fontMsg ff sz) +-- indian_red1+-- steel_blue  point_sizes :: [Int] point_sizes = [10, 12, 18, 24, 36, 48] ------------------------------------------------------------------------------------ Times+positions :: [Int]+positions = [0, 12, 27, 49, 78, 122]  -times_pic :: Picture Double-times_pic = timesroman_pic `nextToV` timesitalic_pic     `nextToV` timesbold_pic-                           `nextToV` timesbolditalic_pic +pointChain :: LocChain Int Int Double+pointChain = verticals positions +fontGraphic :: RGBi -> FontFace -> DPoint2 -> Drawing Double ()+fontGraphic rgb ff pt = +    let ps = unchain (coordinateScalingContext 1 1) $ pointChain pt in +      zipWithM_ (\p1 sz -> draw $ makeLabel rgb ff sz `at` p1) ps point_sizes -timesroman_pic :: Picture Double-timesroman_pic = -    frame $ zipWith (blueLabel timesRoman) point_sizes (mkPoints 1.5) -timesitalic_pic :: Picture Double-timesitalic_pic = -    frame $ zipWith (redLabel timesItalic) point_sizes (mkPoints 1.5)+std_ctx :: DrawingContext+std_ctx = standardContext 10 -timesbold_pic :: Picture Double-timesbold_pic = -    frame $ zipWith (blueLabel timesBold) point_sizes (mkPoints 1.5) -timesbolditalic_pic :: Picture Double-timesbolditalic_pic = -    frame $ zipWith (redLabel timesBoldItalic) point_sizes (mkPoints 1.5)+fontPicture :: [(RGBi,FontFace)] -> DPicture+fontPicture xs = liftToPictureU $ execDrawing std_ctx $  +                   zipWithM (\(rgb,ff) pt -> fontGraphic rgb ff pt) xs ps+  where+    ps = unchain (coordinateScalingContext 1 180) $ tableDown 4 1 ++ --------------------------------------------------------------------------------+-- Times++times_pic :: Picture Double+times_pic = +    fontPicture [ (steel_blue,  timesRoman)+                , (indian_red1, timesItalic)+                , (steel_blue,  timesBold)+                , (indian_red1, timesBoldItalic)+                ] + helvetica_pic :: Picture Double-helvetica_pic = vcat helvetica_pic1 [ helveticaoblique_pic  -                                    , helveticabold_pic-                                    , helveticaboldoblique_pic ]-                     +helvetica_pic = +    fontPicture [ (steel_blue,  helvetica)+                , (indian_red1, helveticaOblique)+                , (steel_blue,  helveticaBold)+                , (indian_red1, helveticaBoldOblique)+                ]  -helvetica_pic1 :: Picture Double-helvetica_pic1 = -    frame $ zipWith (blueLabel helvetica) point_sizes (mkPoints 1.5) -helveticaoblique_pic :: Picture Double-helveticaoblique_pic = -    frame $ zipWith (redLabel helveticaOblique) point_sizes (mkPoints 1.5)-    -helveticabold_pic :: Picture Double-helveticabold_pic = -    frame $ zipWith (blueLabel helveticaBold) point_sizes (mkPoints 1.5)-    -helveticaboldoblique_pic :: Picture Double-helveticaboldoblique_pic = -    frame $ zipWith (redLabel helveticaBoldOblique) point_sizes (mkPoints 1.5)  --------------------------------------------------------------------------------  courier_pic :: Picture Double-courier_pic = vcat courier_pic1 [ courieroblique_pic-                                , courierbold_pic-                                , courierboldoblique_pic ]-    -courier_pic1 :: Picture Double-courier_pic1 = -    frame $ zipWith (blueLabel courier) point_sizes (mkPoints 1.5)-    -courieroblique_pic :: Picture Double-courieroblique_pic = -    frame $ zipWith (redLabel courierOblique) point_sizes (mkPoints 1.5)-    -courierbold_pic :: Picture Double-courierbold_pic = -    frame $ zipWith (blueLabel courierBold) point_sizes (mkPoints 1.5)-    -courierboldoblique_pic :: Picture Double-courierboldoblique_pic = -    frame $ zipWith (redLabel courierBoldOblique) point_sizes (mkPoints 1.5)+courier_pic = +    fontPicture [ (steel_blue,  courier)+                , (indian_red1, courierOblique)+                , (steel_blue,  courierBold)+                , (indian_red1, courierBoldOblique)+                ]  + --------------------------------------------------------------------------------       symbol_pic :: Picture Double symbol_pic = -    frame $ zipWith (blueLabel symbol) point_sizes (mkPoints 1.5)--------------------------------------------------------------------------------------mkPoints :: Num u => u -> [Point2 u]-mkPoints n = unfoldr phi zeroPt where-  phi pt = Just (pt, pt .+^ (V2 0 15 ^* n))+    fontPicture [ (steel_blue, symbol) ]

@@ -0,0 +1,141 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++-- Acknowledgment - the petri net is taken from Claus Reinke\'s+-- paper /Haskell-Coloured Petri Nets/.+++module Shapes where++import Wumpus.Basic.Anchors+import Wumpus.Basic.Arrows+import Wumpus.Basic.Colour.SVGColours+import Wumpus.Basic.Graphic                     -- package: wumpus-basic+import Wumpus.Basic.Paths+import Wumpus.Basic.Shapes.Base+import Wumpus.Basic.Shapes.Derived+import Wumpus.Basic.SafeFonts++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+    writeEPS_latin1 "./out/petri_net.eps" petri_net+    writeSVG_latin1 "./out/petri.svg" petri_net+    ++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"+   +         _ <- localCtx (primaryColour 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 ()+++++petri_net :: DPicture+petri_net = liftToPictureU $ execDrawing (standardContext 14) $ do+              pw     <- place 0 140+              tu1    <- transition 70 140+              rtw    <- place 140 140+              tu2    <- transition 210 140+              w      <- place 280 140+              tu3    <- transition 350 140+              res    <- place 280 70+              pr     <- place 0 0+              tl1    <- transition 70 0+              rtr    <- place 140 0+              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)+              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)+              connectorC (-32) (south tl3) (south pr)+              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)+              connectorD (-6) (northwest res) (southeast tu2) +              draw $ lblParensParens `at` (P2 (-36) 150)+              draw $ lblParensParens `at` (P2 300 60)+              draw $ lblParensParensParens `at` (P2 (-52) (-14))+              draw $ lblBold "processing_w"   `at` (southwards 12 pw)+              draw $ lblBold "ready_to_write" `at` (southwards 12 rtw)+              draw $ lblBold "writing"        `at` (southwards 12 w)+              draw $ lblBold' "resource"      `at` (P2 300 72)+              draw $ lblBold "processing_r"   `at` (northwards 12 pr)+              draw $ lblBold "ready_to_read"  `at` (northwards 12 rtr)+              draw $ lblBold "reading"        `at` (northwards 12 r)+              return ()++greenFill :: DrawingCtxM m => m a -> m a+greenFill = localCtx (secondaryColour lime_green)++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++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++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 connectS `conn` p1 $ p2+   return ()+++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 (arbv v) `conn` p1 $ p2+    return ()++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 ()+++lblParensParens :: Num u => LocGraphic u+lblParensParens = localLG (fontface helvetica) $ textline "(),()"++lblParensParensParens :: Num u => LocGraphic u+lblParensParensParens = localLG (fontface helvetica) $ textline "(),(),()"+++lblBold' :: Num u => String -> LocGraphic u+lblBold' ss = localLG (fontface helveticaBold) $ textline ss+++lblBold :: (Fractional u, Ord u, FromPtSize u) => String -> LocGraphic u+lblBold ss = localLG (fontface helveticaBold) $ centermonoTextline ss

@@ -0,0 +1,261 @@+{-# OPTIONS -Wall #-}++module Symbols where++import Wumpus.Basic.Graphic+import Wumpus.Basic.SafeFonts+import Wumpus.Basic.Text.LRSymbol+import Wumpus.Basic.Text.LRText+++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space++import Control.Monad+import Prelude hiding ( pi, product )++import System.Directory++main :: IO ()+main = do +    createDirectoryIfMissing True "./out/"+    demo01+++demo01 :: IO ()+demo01 = do +    writeEPS_latin1 "./out/symbols.eps" pic1+    writeSVG_latin1 "./out/symbols.svg" pic1++std_ctx :: DrawingContext+std_ctx = fontface timesRoman $ standardContext 12++pic1 :: DPicture +pic1 = liftToPictureU $ execDrawing std_ctx $ do+         zipWithM_ mdraw letters_01 column_01+         zipWithM_ sdraw letters_01 column_01+         zipWithM_ mdraw letters_02 column_02+         zipWithM_ sdraw letters_02 column_02+         zipWithM_ mdraw letters_03 column_03+         zipWithM_ sdraw letters_03 column_03+         zipWithM_ mdraw letters_04 column_04+         zipWithM_ sdraw letters_04 column_04+         zipWithM_ mdraw letters_05 column_05+         zipWithM_ sdraw letters_05 column_05+         zipWithM_ mdraw letters_06 column_06+         zipWithM_ sdraw letters_06 column_06++  where+    mdraw (_,ma) pt = draw $ execLRText ma `at` pt+    sdraw (s,_)  pt = draw $ textline s `at` pt .+^ hvec 16++letters_01 :: [(String, LRText Double ())]+letters_01 = +    [ ("uAlpha",                uAlpha) +    , ("uBeta",                 uBeta)+    , ("uChi",                  uChi)+    , ("uDelta",                uDelta)+    , ("uEpsilon",              uEpsilon)+    , ("uEta",                  uEta)+    , ("uEuro",                 uEuro)+    , ("uGamma",                uGamma)+    , ("uIfraktur",             uIfraktur)+    , ("uIota",                 uIota)+    , ("uKappa",                uKappa)+    , ("uLambda",               uLambda)+    , ("uMu",                   uMu)+    , ("uNu",                   uNu)+    , ("uOmega",                uOmega)+    , ("uOmicron",              uOmicron)+    , ("uPhi",                  uPhi)+    , ("uPi",                   uPi)+    , ("uPsi",                  uPsi)+    , ("uRfraktur",             uRfraktur)+    , ("uRho",                  uRho)+    , ("uSigma",                uSigma)+    , ("uTau",                  uTau)+    , ("uTheta",                uTheta)+    , ("uUpsilon",              uUpsilon)+    , ("uUpsilon1",             uUpsilon1)+    , ("uXi",                   uXi)+    , ("uZeta",                 uZeta)+    , ("aleph",                 aleph)+    , ("alpha",                 alpha)+    , ("ampersand",             ampersand)+    , ("angle",                 angle)+    , ("angleleft",             angleleft)+    , ("angleright",            angleright)+    , ("approxequal",           approxequal)+    ]++letters_02 :: [(String, LRText Double ())]+letters_02 = +    [ ("arrowboth",             arrowboth) +    , ("arrowdblboth",          arrowdblboth)+    , ("arrowdbldown",          arrowdbldown)+    , ("arrowdblleft",          arrowdblleft)+    , ("arrowdblright",         arrowdblright)+    , ("arrowdblup",            arrowdblup)+    , ("arrowdown",             arrowdown)+    , ("arrowleft",             arrowleft)+    , ("arrowright",            arrowright)+    , ("arrowup",               arrowup)+    , ("asteriskmath",          asteriskmath)+    , ("bar",                   bar)+    , ("beta",                  beta)+    , ("braceleft",             braceleft)+    , ("braceright",            braceright)+    , ("bracketleft",           bracketleft)+    , ("bracketright",          bracketright)+    , ("bullet",                bullet)+    , ("carriagereturn",        carriagereturn)+    , ("chi",                   chi)+    ]++letters_03 :: [(String, LRText Double ())]+letters_03 = +    [ ("circlemultiply",        circlemultiply) +    , ("circleplus",            circleplus)+    , ("club",                  club)+    , ("colon",                 colon)+    , ("comma",                 comma)+    , ("congruent",             congruent)+    , ("copyrightsans",         copyrightsans)+    , ("copyrightserif",        copyrightserif)+    , ("degree",                degree)+    , ("delta",                 delta)+    , ("diamond",               diamond)+    , ("divide",                divide)+    , ("dotmath",               dotmath)+    , ("eight",                 eight)+    , ("element",               element)+    , ("ellipsis",              ellipsis)+    , ("emptyset",              emptyset)+    , ("epsilon",               epsilon)+    , ("equal",                 equal)+    , ("equivalence",           equivalence)+    , ("eta",                   eta)+    , ("exclam",                exclam)+    , ("existential",           existential)+    , ("five",                  five)+    , ("florin",                florin)+    , ("four",                  four)+    , ("fraction",              fraction)+    , ("gamma",                 gamma)+    , ("gradient",              gradient)+    , ("greater",               greater)+    , ("greaterequal",          greaterequal)+    , ("heart",                 heart)+    , ("infinity",              infinity)+    , ("integral",              integral)+    ]+++letters_04 :: [(String, LRText Double ())]+letters_04 = +    [ ("intersection",          intersection)+    , ("iota",                  iota)+    , ("kappa",                 kappa)+    , ("lambda",                lambda)+    , ("less",                  less)+    , ("lessequal",             lessequal)+    , ("logicaland",            logicaland)+    , ("logicalnot",            logicalnot)+    , ("logicalor",             logicalor)+    , ("lozenge",               lozenge)+    , ("minus",                 minus)+    , ("minute",                minute)+    , ("mu",                    mu)+    , ("multiply",              multiply)+    , ("nine",                  nine)+    , ("notelement",            notelement)+    , ("notequal",              notequal)+    , ("notsubset",             notsubset)+    , ("nu",                    nu)+    , ("numbersign",            numbersign)+    , ("omega",                 omega)+    , ("omega1",                omega1)+    , ("omicron",               omicron)+    , ("one",                   one)+    , ("parenleft",             parenleft)+    , ("parenright",            parenright)+    ]++letters_05 :: [(String, LRText Double ())]+letters_05 = +    [ ("partialdiff",           partialdiff)+    , ("percent",               percent)+    , ("period",                period)+    , ("perpendicular",         perpendicular)+    , ("phi",                   phi)+    , ("phi1",                  phi1)+    , ("pi",                    pi)+    , ("plus",                  plus)+    , ("plusminus",             plusminus)+    , ("product",               product)+    , ("propersubset",          propersubset)+    , ("propersuperset",        propersuperset)+    , ("proportional",          proportional)+    , ("psi",                   psi)+    , ("question",              question)+    , ("radical",               radical)+    , ("radicalex",             radicalex)+    , ("reflexsubset",          reflexsubset)+    , ("reflexsuperset",        reflexsuperset)+    , ("registersans",          registersans)+    , ("registerserif",         registerserif)+    , ("rho",                   rho)+    ]++letters_06 :: [(String, LRText Double ())]+letters_06 = +    [ ("second",                second)+    , ("semicolon",             semicolon)+    , ("seven",                 seven)+    , ("sigma",                 sigma)+    , ("sigma1",                sigma1)+    , ("similar",               similar)+    , ("six",                   six)+    , ("slash",                 slash)+    , ("space",                 space)+    , ("spade",                 spade)+    , ("suchthat",              suchthat)+    , ("summation",             summation)+    , ("tau",                   tau)+    , ("therefore",             therefore)+    , ("theta",                 theta)+    , ("theta1",                theta1)+    , ("three",                 three)+    , ("trademarksans",         trademarksans)+    , ("trademarkserif",        trademarkserif)+    , ("two",                   two)+    , ("underscore",            underscore)+    , ("union",                 union)+    , ("universal",             universal)+    , ("upsilon",               upsilon)+    , ("weierstrass",           weierstrass)+    , ("xi",                    xi)+    , ("zero",                  zero)+    , ("zeta",                  zeta)+    ]++-- TODO - this should use a chain when the Chain API stablizes.++column_01 :: Num u => [Point2 u]+column_01 = iterate (.+^ vvec (-16)) (P2 0 600)++column_02 :: Num u => [Point2 u]+column_02 = iterate (.+^ vvec (-16)) (P2 100 600)++column_03 :: Num u => [Point2 u]+column_03 = iterate (.+^ vvec (-16)) (P2 200 600)++column_04 :: Num u => [Point2 u]+column_04 = iterate (.+^ vvec (-16)) (P2 300 600)++column_05 :: Num u => [Point2 u]+column_05 = iterate (.+^ vvec (-16)) (P2 400 600)++column_06 :: Num u => [Point2 u]+column_06 = iterate (.+^ vvec (-16)) (P2 500 600)

@@ -28,10 +28,23 @@   , TextAnchor(..)   , RadialAnchor(..) +  -- * extended anchor points+  , northwards+  , southwards+  , eastwards+  , westwards+  , northeastwards+  , southeastwards+  , southwestwards+  , northwestwards++  , radialConnectorPoints+   ) where  import Wumpus.Core                      -- package: wumpus-core +import Data.AffineSpace                 -- package: vector-space  class CenterAnchor t where   center :: DUnit t ~ u => t -> Point2 u@@ -66,3 +79,67 @@ class RadialAnchor t where   radialAnchor :: DUnit t ~ u => Radian -> t -> Point2 u ++extendPtDist :: (Real u, Floating u) => u -> Point2 u -> Point2 u -> Point2 u+extendPtDist d p1 p2 = let v   = pvec p1 p2+                           ang = direction v+                           len = vlength v+                       in p1 .+^ avec ang (len+d)++++northwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t+              , u ~ DUnit t ) +           => u -> t -> Point2 u+northwards u a = extendPtDist u (center a) (north a)+++southwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t+              , u ~ DUnit t ) +           => u -> t -> Point2 u+southwards u a = extendPtDist u (center a) (south a)++eastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t+             , u ~ DUnit t ) +          => u -> t -> Point2 u+eastwards u a = extendPtDist u (center a) (east a)++westwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t+             , u ~ DUnit t ) +          => u -> t -> Point2 u+westwards u a = extendPtDist u (center a) (west a)+++northeastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t+                  , u ~ DUnit t ) +               => u -> t -> Point2 u+northeastwards u a = extendPtDist u (center a) (northeast a)+++southeastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t+                  , u ~ DUnit t ) +               => u -> t -> Point2 u+southeastwards u a = extendPtDist u (center a) (southeast a)++southwestwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t+                  , u ~ DUnit t ) +               => u -> t -> Point2 u+southwestwards u a = extendPtDist u (center a) (southwest a)++northwestwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t+                  , u ~ DUnit t ) +               => u -> t -> Point2 u+northwestwards u a = extendPtDist u (center a) (northwest a)+++--------------------------------------------------------------------------------++radialConnectorPoints :: ( Real u, Floating u+                         , CenterAnchor t1, RadialAnchor t1+                         , CenterAnchor t2, RadialAnchor t2+                         , u ~ DUnit t1, DUnit t1 ~ DUnit t2 ) +                      => t1 -> t2 -> (Point2 u, Point2 u) +radialConnectorPoints a b = (radialAnchor theta a, radialAnchor (theta+pi) b)+  where+    theta = direction $ pvec (center a) (center b)+    

@@ -40,7 +40,6 @@ import Wumpus.Basic.Arrows.Tips import Wumpus.Basic.Graphic import Wumpus.Basic.Paths-import Wumpus.Basic.Paths.Base import Wumpus.Basic.Utils.Intersection ( langle )  import Wumpus.Core                      -- package: wumpus-core@@ -48,11 +47,11 @@ import Control.Applicative import Data.Monoid -liftPathF :: PathF u -> ConnDrawingF u (Path u)-liftPathF pF p1 p2 = pureDF $ pF p1 p2+liftConnPath :: ConnPath u -> ConnDrawingF u (Path u)+liftConnPath pF p1 p2 = pureDF $ pF p1 p2 -line :: Num u => PathF u -> ConnImage u (Path u)-line pathF = intoConnImage (liftPathF pathF) (pathGraphic pathF)+line :: Num u => ConnPath u -> ConnImage u (Path u)+line pathF = intoConnImage (liftConnPath pathF) (pathGraphic pathF)   -- Here the path is already shortened - we have accounted for the@@ -74,10 +73,10 @@ -- path segments. -- rightPathProps :: (Real u, Floating u, FromPtSize u) -               => PathF u -> ConnDrawingF u (Path u,Radian)+               => ConnPath u -> ConnDrawingF u (Path u,Radian) rightPathProps pathF p1 p2 =      (\h sw -> (shortenPath h sw, calcTheta h))-      <$> asksDF lowerxHeight <*> asksDF (line_width . stroke_props)  +      <$> markHeight <*> lineWidth   where     long_path          = pathF p1 p2       shortenPath lxh sw = shortenR (lxh + (realToFrac sw)) long_path @@ -87,7 +86,7 @@   triTipRight :: (Real u, Floating u, FromPtSize u) -            => PathF u -> (Radian -> LocGraphic u) -> ConnImage u (Path u) +            => ConnPath 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      ->@@ -99,7 +98,7 @@ -- This version does not /retract/ the path... -- barbTipRight :: (Real u, Floating u, FromPtSize u) -             => PathF u -> (Radian -> LocGraphic u) -> ConnImage u (Path u)  +             => ConnPath 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  ->@@ -110,55 +109,55 @@   arrowTri90 :: (Real u, Floating u, FromPtSize u) -           => PathF u -> ConnImage u (Path u)+           => ConnPath u -> ConnImage u (Path u) arrowTri90 pathF = triTipRight pathF tri90                arrowTri60 :: (Real u, Floating u, FromPtSize u) -           => PathF u -> ConnImage u (Path u)+           => ConnPath u -> ConnImage u (Path u) arrowTri60 pathF = triTipRight pathF tri60    arrowTri45 :: (Real u, Floating u, FromPtSize u) -           => PathF u -> ConnImage u (Path u)+           => ConnPath u -> ConnImage u (Path u) arrowTri45 pathF = triTipRight pathF tri45   arrowOTri90 :: (Real u, Floating u, FromPtSize u) -            => PathF u -> ConnImage u (Path u)+            => ConnPath u -> ConnImage u (Path u) arrowOTri90 pathF = triTipRight pathF otri90        arrowOTri60 :: (Real u, Floating u, FromPtSize u) -            => PathF u -> ConnImage u (Path u)+            => ConnPath u -> ConnImage u (Path u) arrowOTri60 pathF = triTipRight pathF otri60     arrowOTri45 :: (Real u, Floating u, FromPtSize u) -            => PathF u -> ConnImage u (Path u)+            => ConnPath u -> ConnImage u (Path u) arrowOTri45 pathF = triTipRight pathF otri45    arrowBarb90 :: (Real u, Floating u, FromPtSize u) -            => PathF u -> ConnImage u (Path u)+            => ConnPath u -> ConnImage u (Path u) arrowBarb90 pathF = barbTipRight pathF barb90  arrowBarb60 :: (Real u, Floating u, FromPtSize u) -            => PathF u -> ConnImage u (Path u)+            => ConnPath u -> ConnImage u (Path u) arrowBarb60 pathF = barbTipRight pathF barb60  arrowBarb45 :: (Real u, Floating u, FromPtSize u) -            => PathF u -> ConnImage u (Path u)+            => ConnPath u -> ConnImage u (Path u) arrowBarb45 pathF = barbTipRight pathF barb45                         arrowPerp :: (Real u, Floating u, FromPtSize u) -          => PathF u -> ConnImage u (Path u)+          => ConnPath u -> ConnImage u (Path u) arrowPerp pathF p1 p2 =      lineTipR path_zero perp_tip >>= \arrow_pic -> return (path_zero, arrow_pic)   where

@@ -51,7 +51,7 @@ tripoints triang theta tip =      (\h -> let d = h / (fromRadian $ cos halfang)             in (tip .-^ v1 d, tip .-^ v2 d))-      <$> asksDF lowerxHeight+      <$> markHeight   where     halfang = 0.5 * triang     v1 d    = avec (theta + halfang) d@@ -68,7 +68,8 @@       -> (PrimPath u -> Graphic u)        -> LocGraphic u triAng triang theta gf pt = -    tripoints triang theta pt >>= \(u,v) -> gf (vertexPath [pt,u,v])+    tripoints triang theta pt >>= \(u,v) -> +    localDF bothPrimary (gf $  vertexPath [pt,u,v])   @@ -124,7 +125,7 @@  perp :: (Floating u, FromPtSize u) => Radian -> LocGraphic u perp theta pt =  -    asksDF lowerxHeight >>= \ h -> +    markHeight >>= \ h ->      let v = makeV h in openStroke $ vertexPath [ pt .+^ v, pt .-^ v]   where     makeV h  = avec (theta + pi/2) (0.5 * h)

@@ -0,0 +1,29 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Chains+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC +--+-- Shim module.+--+-- WARNING - very unstable.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Chains+  (+    module Wumpus.Basic.Chains.Base+  , module Wumpus.Basic.Chains.Derived+  ++  ) where+++import Wumpus.Basic.Chains.Base+import Wumpus.Basic.Chains.Derived

@@ -0,0 +1,161 @@+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE RankNTypes                 #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Chains.Base+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC +--+-- Generate points in an iterated chain.+--+-- WARNING - very unstable.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Chains.Base+  (+++    Chain+  , LocChain+  , chain+  , chainFrom+  , unchain+++  , AnaAlg(..)+  , IterAlg(..)++  , BivariateAlg+  , bivariate+  +  , SequenceAlg+  , iteration++  , bounded+  , pairOnXs+  , pairOnYs++  ) where++import Wumpus.Basic.Graphic++import Wumpus.Core                              -- package: wumpus-core+++-- Chain uses the Scaling monad, but it is not itself a monad.+++newtype Chain ux uy u = Chain { getChain :: Scaling ux uy u [Point2 u] }+++type LocChain ux uy u = Point2 u -> Chain ux uy u++++chain :: BivariateAlg ux uy -> Chain ux uy u+chain alg = Chain (scaledBivariatePt alg)++chainFrom :: Num u => BivariateAlg ux uy -> LocChain ux uy u+chainFrom alg start = Chain (scaledBivariateVec alg start)+++unchain :: ScalingContext ux uy u -> Chain ux uy u -> [Point2 u]+unchain ctx ch = runScaling ctx $ getChain ch+ ++-- | Chains are built as unfolds - AnaAlg avoids the pair +-- constructor in the usual definition of unfoldr and makes the+-- state strict.+--+-- It is expected that all Chains built on unfolds will terminate. +--+data AnaAlg st a = Done | Step a !st+++-- | IterAlg is a variant of AnaAlg that builds infinite +-- sequences (iterations).+-- +-- When lifted to a Chain an iteration is bounded by a count so+-- it will terminate.+--+data IterAlg st a = IterStep a !st +++data BivariateAlg ux uy = forall st. BivariateAlg+      { st_zero     :: st+      , gen_step    :: st -> AnaAlg st (ux,uy)+      }++bivariate :: st -> (st -> AnaAlg st (ux,uy)) -> BivariateAlg ux uy+bivariate st0 step_alg = BivariateAlg { st_zero = st0+                                      , gen_step = step_alg }+++scaledBivariatePt :: BivariateAlg ux uy -> Scaling ux uy u [Point2 u]+scaledBivariatePt (BivariateAlg { st_zero = st0, gen_step = step}) = +    go (step st0)   +  where+    go Done              = return []+    go (Step (x,y) next) = scalePt x y    >>= \pt   ->+                           go (step next) >>= \rest ->  +                           return  (pt:rest)++-- Note - cannot encode this with (.+^) from Data.AffineSpace.+-- The u (u ~ MonUnit m) extracted from the Scaling Context is +-- not compatible with the u that forms Points (u ~ Diff (Point2 u)).++scaledBivariateVec :: Num u +                   => BivariateAlg ux uy +                   -> Point2 u +                   -> Scaling ux uy u [Point2 u]+scaledBivariateVec (BivariateAlg { st_zero = st0, gen_step = step}) (P2 x0 y0) = +    go (step st0)   +  where+    go Done              = return []+    go (Step (x,y) next) = scaleVec x y   >>= \(V2 dx dy)   ->+                           go (step next) >>= \rest ->  +                           return (P2 (x0+dx) (y0+dy):rest)+++data SequenceAlg a = forall st. SequenceAlg+      { initial_st  :: st+      , iter_step   :: st -> IterAlg st a+      }++iteration :: (a -> a) -> a -> SequenceAlg a+iteration fn s0 = SequenceAlg { initial_st = s0, iter_step = step }+  where+    step s = IterStep s (fn s)+++bounded :: Int -> SequenceAlg (ux,uy) -> BivariateAlg ux uy+bounded n (SequenceAlg a0 fn) =+    BivariateAlg { st_zero     = (0,a0)+                 , gen_step    = gstep  }+  where+    gstep (i,s) | i < n = let (IterStep ans next) = fn s in Step ans (i+1,next)+    gstep _             = Done+++++pairOnXs :: (ux -> uy) -> SequenceAlg ux -> SequenceAlg (ux,uy)+pairOnXs fn (SequenceAlg { initial_st = s0, iter_step = step }) = +    SequenceAlg s0 step2+  where+    step2 s = let (IterStep a s') = step s in IterStep (a, fn a) s'+++pairOnYs :: (r -> l) -> SequenceAlg r -> SequenceAlg (l,r) +pairOnYs fn (SequenceAlg { initial_st = s0, iter_step = step }) = +    SequenceAlg  s0 step2+  where+    step2 s = let (IterStep a s') = step s in IterStep (fn a, a) s'+

@@ -0,0 +1,129 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Chains.Derived+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC +--+-- Generate points in an iterated chain.+--+-- WARNING - very unstable.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Chains.Derived+  (+    +    univariateX+  , univariateY++  , tableDown+  , tableRight++  , horizontal+  , vertical++  , horizontals+  , verticals++  , rescale++  ) where++import Wumpus.Basic.Chains.Base+++++univariateX :: (Fractional uy, Num ux, Num u) +            => [ux] -> LocChain ux uy u+univariateX zs = chainFrom $ bivariate (0,zs) gstep+  where+    gstep (_,[])     = Done +    gstep (n,x:xs)   = Step (x,n) (n+i,xs)+    len              = length zs+    i                = rescale 0 1 0 (fromIntegral $ len-1) 1+++univariateY :: (Fractional ux, Num uy, Num u) +            => [uy] -> LocChain ux uy u+univariateY zs = chainFrom $ bivariate (0,zs) gstep+  where+    gstep (_,[])     = Done +    gstep (n,y:ys)   = Step (n,y) (n+i,ys)+    len              = length zs+    i                = rescale 0 1 0 (fromIntegral $ len-1) 1++++--------------------------------------------------------------------------------+-- Tables+++tableDown :: Int -> Int -> Chain Int Int u+tableDown rows cols = +    chain $ bounded (rows*cols) (iteration (downstep rows) (0,rows-1))++++downstep :: Int -> (Int,Int) -> (Int,Int)+downstep row_count (x,y) | y == 0 = (x+1,row_count-1)+downstep _         (x,y)          = (x,y-1)++++tableRight :: Num u => Int -> Int -> Chain Int Int u+tableRight rows cols = +    chain $ bounded (rows*cols) (iteration (rightstep cols) (0,rows-1))+++rightstep :: Int -> (Int,Int) -> (Int,Int)+rightstep col_count (x,y) | x == (col_count-1) = (0,y-1)+rightstep _         (x,y)                      = (x+1,y)+++horizontal :: Int -> Chain Int Int u+horizontal count = chain $ bivariate 0 alg+  where+    alg st | st == count = Done+    alg st               = Step (st,0) (st+1)+++vertical :: Int -> Chain Int Int u+vertical count = chain $ bivariate 0 alg+  where+    alg st | st == count = Done+    alg st               = Step (0,st) (st+1)++++horizontals :: (Num ua, Num u) => [ua] -> LocChain ua ua u+horizontals xs0 = chainFrom $ bivariate xs0 alg+  where+    alg []     = Done+    alg (x:xs) = Step (x,0) xs+++verticals :: (Num ua, Num u)  => [ua] -> LocChain ua ua u+verticals ys0 = chainFrom $ bivariate ys0 alg+  where+    alg []     = Done+    alg (y:ys) = Step (0,y) ys+++--------------------------------------------------------------------------------+-- general helpers++rescale :: Fractional a => a -> a -> a -> a -> a -> a+rescale outmin outmax innmin innmax a = +    outmin + innpos * (outrange / innrange)  +  where+    outrange = outmax - outmin+    innrange = innmax - innmin+    innpos   = a - innmin +

@@ -149,7 +149,7 @@                                  (radialCardinal rad ctr)  circleLDO :: (Floating u, FromPtSize u) => LocDrawingF u (DotAnchor u)-circleLDO pt = (\diam -> circleAnchor (diam * 0.5) pt) <$> asksDF markHeight +circleLDO pt = (\diam -> circleAnchor (diam * 0.5) pt) <$> markHeight    @@ -161,13 +161,13 @@  dotChar :: (Floating u, Real u, FromPtSize u)          => Char -> DotLocImage u-dotChar ch pt = asksDF (textDimensions [ch]) >>= \(w,h) -> +dotChar ch pt = monoTextDimensions [ch] >>= \(w,h) ->                  intoLocImage (rectangleLDO w h) (markChar ch) pt   dotText :: (Floating u, Real u, FromPtSize u)          => String -> DotLocImage u -dotText ss pt = asksDF (textDimensions ss) >>= \(w,h) -> +dotText ss pt = monoTextDimensions ss >>= \(w,h) ->                  intoLocImage (rectangleLDO w h) (markText ss) pt  @@ -201,7 +201,7 @@   dotSquare :: (Floating u, Real u, FromPtSize u) => DotLocImage u-dotSquare pt = asksDF markHeight >>= \ h ->+dotSquare pt = markHeight >>= \ h ->                intoLocImage (rectangleLDO h h) markSquare pt  

@@ -82,18 +82,18 @@ -- | A mark is the height of a lowercase \'x\'. --  standardSize :: FromPtSize u => (u -> LocGraphic u) -> LocGraphic u-standardSize f = \pt -> asksDF markHeight >>= \h -> f h pt+standardSize f = \pt -> markHeight >>= \h -> f h pt  halfHeightSize :: (Fractional u, FromPtSize u)                 => (u -> LocGraphic u) -> LocGraphic u-halfHeightSize f = \pt -> asksDF markHeight >>= \h -> f (h * 0.5) pt+halfHeightSize f = \pt -> markHeight >>= \h -> f (h * 0.5) pt    shiftOrigin :: Num u => u -> u -> LocGraphic u -> LocGraphic u shiftOrigin dx dy f = \pt -> f (displace dx dy pt) -markChar :: (Fractional u, FromPtSize u) => Char -> LocGraphic u+markChar :: (Fractional u, Ord u, FromPtSize u) => Char -> LocGraphic u markChar ch = markText [ch]  @@ -101,9 +101,8 @@  -- Note - eta-expanded (?) ---markText :: (Fractional u, FromPtSize u) => String -> LocGraphic u-markText ss pt = asksDF (textDimensions ss) >>= \(w,h) -> -                 shiftOrigin (0.5 * (-w)) (0.5 * (-h)) (textline ss) pt+markText :: (Fractional u, Ord u, FromPtSize u) => String -> LocGraphic u+markText ss = centermonoTextline ss   @@ -148,7 +147,7 @@             => Point2 u -> DrawingF (PrimPath u) pathDiamond pt = (\h -> let hh    = 0.66 * h; hw = 0.5 * h                          in vertexPath [dvs hh, dve hw,dvn hh, dvw hw])-                   <$> asksDF markHeight+                   <$> markHeight   where     dvs hh = pt .+^ vvec (-hh)     dve hw = pt .+^ hvec hw@@ -190,14 +189,14 @@   markPentagon :: (Floating u, FromPtSize u) => LocGraphic u-markPentagon pt = asksDF markHeight >>= \h ->+markPentagon pt = markHeight >>= \h ->                   closedStroke $ vertexPath $ polygonPoints 5 (0.5*h) pt      markStar :: (Floating u, FromPtSize u) => LocGraphic u -markStar pt = asksDF markHeight >>= \h -> +markStar pt = markHeight >>= \h ->                let ps = polygonPoints 5 (0.5*h) pt in mconcat $ map fn ps   where     fn p1  = openStroke $ path pt [lineTo p1] 

@@ -19,15 +19,17 @@   (     module Wumpus.Basic.Graphic.BaseClasses   , module Wumpus.Basic.Graphic.BaseTypes-  , module Wumpus.Basic.Graphic.Chain   , module Wumpus.Basic.Graphic.Drawing   , module Wumpus.Basic.Graphic.DrawingContext   , module Wumpus.Basic.Graphic.PrimGraphic+  , module Wumpus.Basic.Graphic.Query+  , module Wumpus.Basic.Graphic.ScalingContext   ) where  import Wumpus.Basic.Graphic.BaseClasses import Wumpus.Basic.Graphic.BaseTypes-import Wumpus.Basic.Graphic.Chain import Wumpus.Basic.Graphic.Drawing import Wumpus.Basic.Graphic.DrawingContext import Wumpus.Basic.Graphic.PrimGraphic+import Wumpus.Basic.Graphic.Query+import Wumpus.Basic.Graphic.ScalingContext

@@ -28,6 +28,8 @@   , DrawingCtxM(..)   , asksCtx   +  , ScalingM(..)+    , PointSupplyM(..)    ) where@@ -41,8 +43,8 @@   --- DUnit is always for fully saturated types, so (seemingly) an equivalent--- type family is needed.+-- DUnit is always for fully saturated type constructors, so +-- (seemingly) an equivalent type family is needed for monads.  type family MonUnit m :: *  @@ -63,6 +65,19 @@ -- asksCtx :: DrawingCtxM m => (DrawingContext -> a) -> m a asksCtx f = askCtx >>= (return . f)+++-- | Scaling...+--+class ScalingM m where+  type XDim m :: *+  type YDim m :: *+  scaleX :: (u ~ MonUnit m, ux ~ XDim m) => ux -> m u+  scaleY :: (u ~ MonUnit m, uy ~ YDim m) => uy -> m u+  scalePt  :: (u ~ MonUnit m, ux ~ XDim m, uy ~ YDim m) +           => ux -> uy -> m (Point2 u)+  scaleVec :: (u ~ MonUnit m, ux ~ XDim m, uy ~ YDim m) +           => ux -> uy -> m (Vec2 u)   -- | A monad that supplies points, e.g. a turtle monad. 

@@ -1,87 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Graphic.Chain--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC ------ Supply points in an iterated chain.--------------------------------------------------------------------------------------module Wumpus.Basic.Graphic.Chain-  (--    ChainT-  , runChainT-  , horizontal--  ) where--import Wumpus.Basic.Graphic.BaseClasses-import Wumpus.Basic.Graphic.BaseTypes--import Wumpus.Core                              -- package: wumpus-core-       -import Control.Applicative-import Control.Monad----newtype ChainT u m a = ChainT { -          getChainT :: Point2F u -> Point2 u -> m (a, Point2 u) }---type instance MonUnit (ChainT u m) = u----instance Monad m => Functor (ChainT u m) where-  fmap f ma = ChainT $ \rf s -> -                getChainT ma rf s >>= \(a,s1) -> return (f a, s1)---instance Monad m => Applicative (ChainT u m) where-  pure a    = ChainT $ \_  s -> return (a,s)-  mf <*> ma = ChainT $ \rf s -> getChainT mf rf s  >>= \(f,s1) ->-                                getChainT ma rf s1 >>= \(a,s2) ->-                                return (f a, s2)---instance Monad m => Monad (ChainT u m) where-  return a = ChainT $ \_  s -> return (a,s)-  m >>= k  = ChainT $ \rf s -> getChainT m rf s >>= \(a,s1) ->-                               (getChainT . k) a rf s1-                                     ---instance Monad m => PointSupplyM (ChainT u m) where-  position = ChainT $ \rf s -> return (s, rf s)--runChainT :: Monad m -          => Point2F u -> Point2 u -> ChainT u m a -> m a-runChainT f pt0 ma = liftM fst $ getChainT ma f pt0--horizontal :: (Num u, Monad m)-           => Point2 u -> u -> ChainT u m a -> m a-horizontal pt0 dx ma = runChainT f pt0 ma-  where-    f (P2 x y) = P2 (x+dx) y---instance (Monad m, TraceM m, u ~ MonUnit m) => TraceM (ChainT u m) where-  trace a = ChainT $ \_ s -> trace a >> return ((), s)---instance (Monad m, DrawingCtxM m) => DrawingCtxM (ChainT u m) where-  askCtx         = ChainT $ \_ s -> askCtx >>= \ctx -> return (ctx, s)-  localCtx cF ma = ChainT $ \r s -> localCtx cF (getChainT ma r s)

@@ -269,7 +269,9 @@ mbPictureU Nothing  = error "mbPictureU - empty picture." mbPictureU (Just a) = a -+-- Note - need an equivalent to Parsec\`s parseTest that provides+-- a very simple way to run graphics without concern for return +-- type or initial drawing context.  -------------------------------------------------------------------------------- 

@@ -2,7 +2,7 @@  -------------------------------------------------------------------------------- -- |--- Module      :  Wumpus.Basic.Graphic.DrawingAttr+-- Module      :  Wumpus.Basic.Graphic.DrawingContext -- Copyright   :  (c) Stephen Tetley 2010 -- License     :  BSD3 --@@ -27,10 +27,6 @@     DrawingContext(..)    , standardContext-  , textAttr-  , markHeight-  , lowerxHeight-  , textDimensions    -- * Modifiers    -- ** Line widths@@ -40,13 +36,24 @@    -- ** Dash Pattern   , dashPattern+  , unit_dash_pattern+  , phase+  , dphase+  , doublegaps+  , doubledashes    -- ** Font properties   , fontsize   , fontface +  -- ** Mark drawing size+  , doublesize+  , halfsize+   -- ** Colour   , swapColours+  , bothPrimary+  , bothSecondary   , primaryColour   , secondaryColour  @@ -64,53 +71,28 @@ import Control.Applicative  data DrawingContext = DrawingContext-      { stroke_props       :: StrokeAttr-      , font_props         :: FontAttr-      , primary_colour     :: RGBi      -- usually the stroke colour-      , secondary_colour   :: RGBi      -- usually the fill colour+      { stroke_props          :: StrokeAttr+      , font_props            :: FontAttr+      , primary_colour        :: RGBi      -- usually the stroke colour+      , secondary_colour      :: RGBi      -- usually the fill colour+      , line_spacing_factor   :: Double       }   deriving (Eq,Show) + standardContext :: FontSize -> DrawingContext-standardContext sz = DrawingContext { stroke_props      = default_stroke_attr-                                    , font_props        = FontAttr sz courier-                                    , primary_colour    = black-                                    , secondary_colour  = light_gray  }+standardContext sz = +    DrawingContext { stroke_props           = default_stroke_attr+                   , font_props             = FontAttr sz courier+                   , primary_colour         = black+                   , secondary_colour       = light_gray+                   , line_spacing_factor    = 1.2  +                   }   -textAttr :: DrawingContext -> (RGBi,FontAttr)-textAttr = liftA2 (,) primary_colour font_props  --- | A Mark is consider to be the height of a lowercase letter--- in the current font.--- --- Note better to use xlowerHeight--- -markHeight :: FromPtSize u => DrawingContext -> u-markHeight = fromPtSize . xcharHeight . font_size . font_props----- | Height of a lower case \'x\' in Courier.---  --- \'x\' has no ascenders or descenders. --- -lowerxHeight :: FromPtSize u => DrawingContext -> u-lowerxHeight = fromPtSize . xcharHeight . font_size . font_props----- | textDimensions : text -> DrawingContext -> (width,height)----textDimensions :: FromPtSize u => String -> DrawingContext -> (u,u)-textDimensions str attr = (w,h)-  where-    sz = font_size  $ font_props attr-    w  = fromPtSize $ textWidth  sz (charCount str)-    h  = fromPtSize $ numeralHeight sz--- updateStrokeProps :: (StrokeAttr -> StrokeAttr)                    -> DrawingContext -> DrawingContext updateStrokeProps fn = (\s i -> s { stroke_props = fn i }) <*> stroke_props@@ -141,7 +123,11 @@ setLineWidth       :: Double -> DrawingContext -> DrawingContext setLineWidth d      = updateStrokeProps (\s -> s { line_width = d }) -+-- | Set the line width to a /thick/.+--+-- Note this context update is /oblivious/ - operationally the +-- line width is set to exactly @2.0@.+-- thick               :: DrawingContext -> DrawingContext thick               = setLineWidth thick_line @@ -151,10 +137,37 @@ thin                :: DrawingContext -> DrawingContext thin                = setLineWidth thin_line +--------------------------------------------------------------------------------  dashPattern         :: DashPattern -> DrawingContext -> DrawingContext dashPattern d       = updateStrokeProps (\s -> s { dash_pattern = d })         +unit_dash_pattern   :: DashPattern+unit_dash_pattern   = Dash 0 [(1,1)]++-- oblivious+phase               :: Int -> DashPattern -> DashPattern+phase _ Solid       = Solid+phase i (Dash _ xs) = Dash i xs++-- non-oblivious+dphase               :: Int -> DashPattern -> DashPattern+dphase _ Solid       = Solid+dphase d (Dash i xs) = Dash (i+d) xs++doublegaps              :: DashPattern -> DashPattern+doublegaps Solid        = Solid+doublegaps (Dash i xs)  = Dash i (map fn xs)+  where+    fn (a,b) = (a,2*b)++doubledashes              :: DashPattern -> DashPattern+doubledashes Solid        = Solid+doubledashes (Dash i xs)  = Dash i (map fn xs)+  where+    fn (a,b) = (a*2,b)++ --------------------------------------------------------------------------------  @@ -166,10 +179,38 @@  -------------------------------------------------------------------------------- +-- | Set the font size to double the current size, note the font+-- size also controls the size of dots, arrowsheads etc.+-- +doublesize          :: DrawingContext -> DrawingContext+doublesize          = (\s sz -> fontsize (sz*2) s) <*> (font_size . font_props)+++-- | Set the font size to half the current size, note the font+-- size also controls the size of dots, arrowsheads etc.+-- +-- As fontsize is an integer this is not exact - half size of+-- 15pt type is 7pt.+-- +halfsize            :: DrawingContext -> DrawingContext+halfsize            = (\s sz -> fontsize (sz `div` 2) s) +                        <*> (font_size . font_props)+++--------------------------------------------------------------------------------+ swapColours :: DrawingContext -> DrawingContext swapColours =      (\s a b -> s { primary_colour = b, secondary_colour = a })         <*> primary_colour <*> secondary_colour++bothPrimary :: DrawingContext -> DrawingContext+bothPrimary = (\s a -> s { secondary_colour = a }) <*> primary_colour++bothSecondary :: DrawingContext -> DrawingContext+bothSecondary = (\s a -> s { primary_colour = a }) <*> secondary_colour++  primaryColour :: RGBi -> DrawingContext -> DrawingContext primaryColour rgb = \s -> s { primary_colour = rgb } 

@@ -28,7 +28,10 @@   , closedStroke   , filledPath   , borderedPath+     , textline+  , centermonoTextline+  , textlineMulti   , hkernline   , vkernline @@ -39,9 +42,13 @@    , supplyPt   , localPoint+  , vecdisplace   , displace+  , hdisplace+  , vdisplace    , straightLine+  , straightLineBetween    , strokedRectangle   , filledRectangle@@ -59,15 +66,21 @@    ) where -import Wumpus.Basic.Graphic.DrawingContext import Wumpus.Basic.Graphic.BaseTypes+import Wumpus.Basic.Graphic.DrawingContext+import Wumpus.Basic.Graphic.Query  import Wumpus.Core                              -- package: wumpus-core  import Data.AffineSpace                         -- package: vector-space+import Data.VectorSpace  import Control.Applicative+import Control.Monad+import Data.Foldable ( foldrM )+import Data.Monoid + drawGraphic :: (Real u, Floating u, FromPtSize u)              => DrawingContext -> Graphic u -> Maybe (Picture u) drawGraphic ctx gf = post $ runGraphic ctx gf@@ -89,44 +102,65 @@ -- having the same names is actually not so useful...  openStroke :: Num u => PrimPath u -> Graphic u-openStroke pp = (\rgb attr -> singleH $ ostroke rgb attr pp) -                    <$> asksDF primary_colour <*> asksDF stroke_props-+openStroke pp = +    withStrokeAttr $ \rgb attr -> singleH $ ostroke rgb attr pp  closedStroke :: Num u => PrimPath u -> Graphic u-closedStroke pp = (\rgb attr -> singleH $ cstroke rgb attr pp) -                      <$> asksDF primary_colour <*> asksDF stroke_props-+closedStroke pp = +    withStrokeAttr $ \rgb attr -> singleH $ cstroke rgb attr pp  filledPath :: Num u => PrimPath u -> Graphic u-filledPath pp = (\rgb -> singleH $ fill rgb pp) -                    <$> asksDF secondary_colour+filledPath pp = withFillAttr $ \rgb -> singleH $ fill rgb pp+                    borderedPath :: Num u => PrimPath u -> Graphic u borderedPath pp = -    (\frgb attr srgb -> singleH $ fillStroke frgb attr srgb pp) -        <$> asksDF secondary_colour <*> asksDF stroke_props -                                    <*> asksDF primary_colour-+    withBorderedAttr $ \frgb attr srgb -> singleH $ fillStroke frgb attr srgb pp  -------------------------------------------------------------------------------- --  ++ textline :: Num u => String -> LocGraphic u textline ss baseline_left =-    (\(rgb,attr) -> singleH $ textlabel rgb attr ss baseline_left) -       <$> asksDF textAttr+    withTextAttr $ \rgb attr -> singleH $ textlabel rgb attr ss baseline_left +-- | As 'textline' but the supplied point is the /center/.+--+-- Centered is inexact - it is calculated with monospaced font+-- metrics.+-- +centermonoTextline :: (Fractional u, Ord u, FromPtSize u) +                   => String -> LocGraphic u+centermonoTextline ss pt = monoVecToCenter ss  >>= \v ->+                           textline ss (vecdisplace (negateV v) pt)++++++-- | Point is the baseline left of the bottom line.+--+textlineMulti :: Fractional u => [String] -> LocGraphic u+textlineMulti xs baseline_left = liftM snd $ +    lineSpacing >>= \dy -> foldrM (foldStep dy) (baseline_left,mempty) xs+  where+    foldStep dy str (pt,gfic) = (\a -> (pt .+^ vvec dy, a `mappend` gfic))+                                    <$> textline str pt+                                ++ hkernline :: Num u => [KerningChar u] -> LocGraphic u hkernline ks baseline_left = -    (\(rgb,attr) -> singleH $ hkernlabel rgb attr ks baseline_left) -       <$> asksDF textAttr+    withTextAttr $ \rgb attr -> singleH $ hkernlabel rgb attr ks baseline_left+        vkernline :: Num u => [KerningChar u] -> LocGraphic u vkernline ks baseline_left = -    (\(rgb,attr) -> singleH $ vkernlabel rgb attr ks baseline_left) -       <$> asksDF textAttr+    withTextAttr $ \rgb attr -> singleH $ vkernlabel rgb attr ks baseline_left+     --------------------------------------------------------------------------------@@ -134,20 +168,18 @@  strokedEllipse :: Num u => u -> u -> LocGraphic u strokedEllipse hw hh pt =  -    (\rgb attr -> singleH $ strokeEllipse rgb attr hw hh pt) -       <$> asksDF primary_colour <*> asksDF stroke_props+    withStrokeAttr $ \rgb attr -> singleH $ strokeEllipse rgb attr hw hh pt+     filledEllipse :: Num u => u -> u -> LocGraphic u filledEllipse hw hh pt =  -    (\rgb -> singleH $ fillEllipse rgb hw hh pt) -       <$> asksDF secondary_colour+    withFillAttr $ \rgb -> singleH $ fillEllipse rgb hw hh pt+    borderedEllipse :: Num u => u -> u -> LocGraphic u borderedEllipse hw hh pt = -    (\frgb attr srgb -> singleH $ fillStrokeEllipse frgb attr srgb hw hh pt) -        <$> asksDF secondary_colour <*> asksDF stroke_props -        <*> asksDF primary_colour-+    withBorderedAttr $ \frgb attr srgb -> +      singleH $ fillStrokeEllipse frgb attr srgb hw hh pt  -------------------------------------------------------------------------------- @@ -158,12 +190,20 @@ supplyPt :: Point2 u -> LocGraphic u -> Graphic u supplyPt pt gf = gf pt  +vecdisplace :: Num u => Vec2 u -> Point2 u -> Point2 u+vecdisplace (V2 dx dy) (P2 x y) = P2 (x+dx) (y+dy) + displace :: Num u => u -> u -> Point2 u -> Point2 u displace dx dy (P2 x y) = P2 (x+dx) (y+dy) +hdisplace :: Num u => u -> Point2 u -> Point2 u+hdisplace dx (P2 x y) = P2 (x+dx) y +vdisplace :: Num u => u -> Point2 u -> Point2 u+vdisplace dy (P2 x y) = P2 x (y+dy) + localPoint :: (Point2 u -> Point2 u) -> LocGraphic u -> LocGraphic u localPoint upd gf = \pt -> gf (upd pt) @@ -173,7 +213,12 @@  straightLine :: Fractional u => Vec2 u -> LocGraphic u straightLine v = \pt -> openStroke $ path pt [lineTo $ pt .+^ v]-           +          ++straightLineBetween :: Fractional u => Point2 u -> Point2 u -> Graphic u+straightLineBetween p1 p2 = openStroke $ path p1 [lineTo p2]++  -- | Supplied point is /bottom-left/. --

@@ -0,0 +1,192 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Graphic.Query+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC with TypeFamilies and more+--+-- Querying the Drawing Context.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Graphic.Query+  ( ++    +    textAttr+  , withTextAttr++  , strokeAttr+  , withStrokeAttr++  , fillAttr+  , withFillAttr++  , borderedAttr+  , withBorderedAttr++  , lineWidth+  , fontSize+  , markHeight+  , lineSpacing++  -- +  , monoCharWidth+  , monoSpacerWidth+  , monoTextWidth+  , monoTextLength+  , monoTextHeight+  , monoNumeralHeight+  , monoLowerxHeight+  , monoDescenderDepth+  , monoTextDimensions+  , monoVecToCenter  +  ) where++import Wumpus.Basic.Graphic.BaseTypes+import Wumpus.Basic.Graphic.DrawingContext+++import Wumpus.Core                      -- package: wumpus-core++import Control.Applicative+++textAttr :: DrawingF (RGBi,FontAttr)+textAttr = (,) <$> asksDF primary_colour <*> asksDF font_props++-- | Because @textAttr@ is so commonly used here is a functional+-- version that avoids tupling.+--+withTextAttr :: (RGBi -> FontAttr -> a) -> DrawingF a+withTextAttr fn = fn <$> asksDF primary_colour <*> asksDF font_props+++strokeAttr :: DrawingF (RGBi, StrokeAttr)+strokeAttr = (,) <$> asksDF primary_colour <*> asksDF stroke_props++withStrokeAttr :: (RGBi -> StrokeAttr -> a) -> DrawingF a+withStrokeAttr fn = fn <$> asksDF primary_colour <*> asksDF stroke_props+++fillAttr :: DrawingF RGBi+fillAttr = asksDF secondary_colour++withFillAttr :: (RGBi -> a) -> DrawingF a+withFillAttr fn = fn <$> asksDF secondary_colour++borderedAttr :: DrawingF (RGBi, StrokeAttr, RGBi)+borderedAttr = (,,) <$> asksDF secondary_colour <*> asksDF stroke_props +                                                <*> asksDF primary_colour++withBorderedAttr :: (RGBi -> StrokeAttr -> RGBi -> a) -> DrawingF a+withBorderedAttr fn = +    fn <$> asksDF secondary_colour <*> asksDF stroke_props +                                   <*> asksDF primary_colour+++++lineWidth :: DrawingF Double+lineWidth = line_width <$> asksDF stroke_props++fontSize :: DrawingF Int+fontSize = font_size <$> asksDF font_props+++++-- Maybe these functions are better as queries - i.e. functions+-- of type DrawingF, e.g.+-- +-- > lineSpacing :: Fractional u => DrawingF u+-- +-- Then the /client/ can just bound the answer directly+-- rather than using +--+-- > askDF lineSpacing >>= \u -> ...+--++lineSpacing :: Fractional u => DrawingF u+lineSpacing = +    (\sz factor -> realToFrac $ factor * fromIntegral sz)+      <$> asksDF (font_size . font_props) <*> asksDF line_spacing_factor++-- | A Mark is consider to be the height of a lowercase letter+-- in the current font.+-- +-- Note better to use xlowerHeight+-- +markHeight :: FromPtSize u => DrawingF u+markHeight = (fromPtSize . xcharHeight . font_size) <$> asksDF font_props++-- Note - there are probably enough functions that use just +-- markHeight to merit a withMarkHeight function.+++++++--------------------------------------------------------------------------------++withFontSize :: (FontSize -> u) -> DrawingF u+withFontSize fn = fn . font_size <$> asksDF font_props++monoCharWidth :: FromPtSize u => DrawingF u+monoCharWidth = withFontSize (fromPtSize . charWidth)++monoSpacerWidth :: FromPtSize u => DrawingF u+monoSpacerWidth = withFontSize (fromPtSize . spacerWidth)+++monoTextWidth :: FromPtSize u => Int -> DrawingF u+monoTextWidth n = withFontSize $ \sz -> fromPtSize $ textWidth sz n+++monoTextLength :: FromPtSize u => String -> DrawingF u+monoTextLength ss = monoTextWidth $ charCount ss+++monoTextHeight :: FromPtSize u => DrawingF u+monoTextHeight = withFontSize (fromPtSize . textHeight)++monoNumeralHeight :: FromPtSize u => DrawingF u+monoNumeralHeight = withFontSize (fromPtSize . numeralHeight)+++-- | Height of a lower case \'x\' in Courier.+--  +-- \'x\' has no ascenders or descenders. +-- +monoLowerxHeight :: FromPtSize u => DrawingF u+monoLowerxHeight = withFontSize (fromPtSize . xcharHeight)++monoDescenderDepth :: FromPtSize u => DrawingF u+monoDescenderDepth = withFontSize (fromPtSize . descenderDepth)+++-- | Query the dimensions of the text using the current font size+-- but using metrics derived from Courier.+--+-- Note - the width will generally be a over-estimate for +-- non-monospaced fonts.+-- +monoTextDimensions :: (Num u, Ord u, FromPtSize u) => String -> DrawingF (u,u)+monoTextDimensions ss = +    (\sz -> post $ textBounds sz zeroPt ss) +      <$> asksDF (font_size . font_props)+  where+    post bb = (boundaryWidth bb, boundaryHeight bb)+++-- | Vector from baseline left to center+monoVecToCenter :: (Fractional u, Ord u, FromPtSize u) +                => String -> DrawingF (Vec2 u)+monoVecToCenter ss = (\(w,h) dy -> vec (0.5*w) (0.5*h - dy)) +                       <$> monoTextDimensions ss <*> monoDescenderDepth

@@ -0,0 +1,173 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Graphic.ScalingContext+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- Scaling in X and Y+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Graphic.ScalingContext+  (+    ScalingContext(..)++  , Scaling+  , runScaling+  , ScalingT+  , runScalingT++  , regularScalingContext+  , coordinateScalingContext++  , unitX+  , unitY+++  ) where++import Wumpus.Basic.Graphic.BaseClasses++import Wumpus.Core				-- package: wumpus-core++import Control.Applicative++data ScalingContext ux uy u = ScalingContext+      { scale_in_x  :: ux -> u+      , scale_in_y  :: uy -> u+      }++++-- Chains (for example) want a plain monad rather than a transformer.+--+newtype Scaling ux uy u a = Scaling {+          getScaling :: ScalingContext ux uy u -> a }+++type instance MonUnit (Scaling ux uy u) = u++++instance Functor (Scaling ux uy u) where+  fmap f ma = Scaling $ \ctx -> let a = getScaling ma ctx in f a++instance Applicative (Scaling ux uy u) where+  pure a    = Scaling $ \_   -> a+  mf <*> ma = Scaling $ \ctx -> let f = getScaling mf ctx+                                    a = getScaling ma ctx+             			in (f a)++instance Monad (Scaling ux uy u) where+  return a = Scaling $ \_   -> a+  m >>= k  = Scaling $ \ctx -> let a = getScaling m ctx+    	     	               in (getScaling . k) a ctx++++instance ScalingM (Scaling ux uy u) where+  type XDim (Scaling ux uy u) = ux +  type YDim (Scaling ux uy u) = uy+  scaleX ux       = Scaling $ \ctx -> (scale_in_x ctx) ux+  scaleY uy       = Scaling $ \ctx -> (scale_in_y ctx) uy+  scalePt ux uy   = Scaling $ \ctx -> P2 (scale_in_x ctx ux) (scale_in_y ctx uy)+  scaleVec ux uy  = Scaling $ \ctx -> V2 (scale_in_x ctx ux) (scale_in_y ctx uy)++runScaling :: ScalingContext ux uy u -> Scaling ux uy u a -> a+runScaling ctx sf = (getScaling sf) ctx    +++++--------------------------------------------------------------------------------+-- Transformer++-- Turtle (for example) wants a transformer so it can use TraceM+-- and DrawingCtxM+--+newtype ScalingT ux uy u m a = ScalingT { +          getScalingT :: ScalingContext ux uy u -> m a }++type instance MonUnit (ScalingT ux uy u m) = u+++instance Monad m => Functor (ScalingT ux uy u m) where+  fmap f ma = ScalingT $ \ctx -> getScalingT ma ctx >>= \a -> return (f a)++instance Monad m => Applicative (ScalingT ux uy u m) where+  pure a    = ScalingT $ \_   -> return a+  mf <*> ma = ScalingT $ \ctx -> getScalingT mf ctx >>= \f -> +                                 getScalingT ma ctx >>= \a ->+             			 return (f a)++instance Monad m => Monad (ScalingT ux uy u m) where+  return a = ScalingT $ \_   -> return a+  m >>= k  = ScalingT $ \ctx -> getScalingT m ctx >>= \a -> +    	     	      	     	(getScalingT . k) a ctx+++instance Monad m => ScalingM (ScalingT ux uy u m) where+  type XDim (ScalingT ux uy u m) = ux +  type YDim (ScalingT ux uy u m) = uy+  scaleX ux       = ScalingT $ \ctx -> return $ (scale_in_x ctx) ux+  scaleY uy       = ScalingT $ \ctx -> return $ (scale_in_y ctx) uy+  scalePt ux uy   = ScalingT $ \ctx -> +                      return $ P2 (scale_in_x ctx ux) (scale_in_y ctx uy)+  scaleVec ux uy  = ScalingT $ \ctx -> +                      return $ V2 (scale_in_x ctx ux) (scale_in_y ctx uy)++++-- Cross instances - needed to run SalingT /locally/ in Drawing.++instance DrawingCtxM m => DrawingCtxM (ScalingT ux uy u m) where+  askCtx   = ScalingT $ \_ -> askCtx >>= \dctx -> return dctx+  localCtx ctx mf = ScalingT $ \sctx -> localCtx ctx (getScalingT mf sctx)+++instance (Monad m, TraceM m, u ~ MonUnit m) => TraceM (ScalingT ux uy u m) where+  trace a  = ScalingT $ \_ -> trace a +++++runScalingT :: ScalingContext ux uy u -> ScalingT ux uy u m a -> m a+runScalingT ctx sf = (getScalingT sf) ctx    ++--------------------------------------------------------------------------------+-- constructors for scaling context++regularScalingContext :: Num u => u -> ScalingContext u u u+regularScalingContext u = ScalingContext+      { scale_in_x  = (\x -> u*x)+      , scale_in_y  = (\y -> u*y)+      }++coordinateScalingContext :: Num u => u -> u -> ScalingContext Int Int u+coordinateScalingContext sx sy = ScalingContext+      { scale_in_x  = (\x -> sx * fromIntegral x)+      , scale_in_y  = (\y -> sy * fromIntegral y)+      }++++--------------------------------------------------------------------------------+-- operations+++++unitX :: (ScalingM m, Num ux, ux ~ XDim m, u ~ MonUnit m) => m u+unitX = scaleX 1+ +unitY :: (ScalingM m, Num uy, uy ~ YDim m, u ~ MonUnit m) => m u+unitY = scaleY 1++ 

@@ -1,5 +1,3 @@-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE FunctionalDependencies     #-} {-# OPTIONS -Wall #-}  --------------------------------------------------------------------------------@@ -18,22 +16,22 @@ -- drawing - sending commands to update the a cursor. -- -- While Wumpus generally aims for a more compositional,--- \"coordinate-free\" style of drawing, some types of --- diagram are more easily expressed in the LOGO style.+-- \"coordinate-free\" style of drawing, some types of diagram +-- are more easily expressed in the LOGO style. --+-- Note - as turtle drawing with Wumpus is a /local effect/, +-- there is only one instance of TurtleM. Potentially TurtleM +-- will be removed and the functions implemented directly. +-- --------------------------------------------------------------------------------  module Wumpus.Basic.Monads.TurtleClass   (      Coord-  , TurtleConfig(..)-  , regularConfig     , TurtleM(..)-  , TurtleScaleM(..) -  , askSteps   , setsLoc   , setsLoc_ @@ -45,48 +43,22 @@   , moveDown   , nextLine  -  , getPos-  , scaleCoord    ) where  -import Wumpus.Core                      -- package: wumpus-core -import Control.Monad- type Coord = (Int,Int)  --- Might want to expand this with an initial y-value,--- otherwise using nextLine will get you negative y-values--- without care...--data TurtleConfig u = TurtleConfig -      { xstep :: !u-      , ystep :: !u -      }  -  deriving (Eq,Show)---regularConfig :: u -> TurtleConfig u-regularConfig u = TurtleConfig u u -- class Monad m => TurtleM m where   getLoc     :: m (Int,Int)   setLoc     :: (Int,Int) -> m ()   getOrigin  :: m (Int,Int)   setOrigin  :: (Int,Int) -> m () -class TurtleM m => TurtleScaleM m u | m -> u where -  xStep     :: m u-  yStep     :: m u  -askSteps :: TurtleScaleM m u => m (u,u)-askSteps = liftM2 (,) xStep yStep- setsLoc :: TurtleM m => (Coord -> (a,Coord)) -> m a setsLoc f = getLoc      >>= \coord ->              let (a,coord') = f coord in setLoc coord' >> return a@@ -95,7 +67,6 @@ setsLoc_ f = getLoc     >>= \coord ->  setLoc (f coord)  - resetLoc    :: TurtleM m => m () resetLoc    = getOrigin >>= setLoc @@ -117,14 +88,4 @@ nextLine    :: TurtleM m => m () nextLine    = getOrigin >>= \(ox,_) ->               setsLoc_ $ \(_,y) -> (ox,y-1)---getPos :: (TurtleScaleM m u, Num u) => m (Point2 u)-getPos = getLoc   >>= \(x,y)   ->-         askSteps >>= \(sx,sy) ->-         return $ P2 (sx * fromIntegral x) (sy * fromIntegral y)--scaleCoord  :: (TurtleScaleM m u, Num u) => (Int,Int) -> m (Point2 u)-scaleCoord (x,y) = askSteps >>= \(sx,sy) ->-                   return $ P2 (sx * fromIntegral x) (sy * fromIntegral y) 

@@ -38,10 +38,6 @@   , TurtleT   , runTurtleT -  -- * Turtle combined with Drawing-  , TurtleDrawing-  , runTurtleDrawing-  , execTurtleDrawing       ) where @@ -54,6 +50,11 @@ import Control.Monad  +-- Note - if Turtle is now just a /local effect/ monad is the +-- Turtle class still needed? Afterall, there is (probably)+-- only ever going to be one instance.+--+ -- Turtle is a Reader / State monad --  -- The env is the horizontal and vertical move distances.@@ -66,56 +67,57 @@       , _current_coord   :: (Int,Int)       } +type TurtleScalingT u m a = ScalingT Int Int u m a+ newtype TurtleT u m a = TurtleT { -          getTurtleT :: TurtleConfig u -> TurtleState -> m (a, TurtleState) }+          getTurtleT :: TurtleState -> TurtleScalingT u m (a, TurtleState) }  type instance MonUnit (TurtleT u m) = u+     + -- Functor  + instance Monad m => Functor (TurtleT u m) where-  fmap f m = TurtleT $ \r s -> getTurtleT m r s >>= \(a,s') ->-                               return (f a, s')+  fmap f m = TurtleT $ \s -> getTurtleT m s >>= \(a,s') ->+                             return (f a, s') + -- Applicative   instance Monad m => Applicative (TurtleT u m) where-  pure a    = TurtleT $ \_ s -> return (a,s)-  mf <*> ma = TurtleT $ \r s -> getTurtleT mf r s  >>= \(f,s')  ->-                                getTurtleT ma r s' >>= \(a,s'') ->-                                return (f a,s'') +  pure a    = TurtleT $ \s -> return (a,s)+  mf <*> ma = TurtleT $ \s -> getTurtleT mf s  >>= \(f,s')  ->+                              getTurtleT ma s' >>= \(a,s'') ->+                              return (f a,s'')    -- Monad   instance Monad m => Monad (TurtleT u m) where-  return a = TurtleT $ \_ s -> return (a,s)-  m >>= k  = TurtleT $ \r s -> getTurtleT m r s        >>= \(a,s')  ->-                               (getTurtleT . k) a r s' >>= \(b,s'') ->-                               return (b,s'')+  return a = TurtleT $ \s -> return (a,s)+  m >>= k  = TurtleT $ \s -> getTurtleT m s        >>= \(a,s')  ->+                             (getTurtleT . k) a s' >>= \(b,s'') ->+                             return (b,s'')     instance Monad m => TurtleM (TurtleT u m) where-  getLoc      = TurtleT $ \_ s@(TurtleState _ c) -> return (c,s)-  setLoc c    = TurtleT $ \_   (TurtleState o _) -> return ((),TurtleState o c)-  getOrigin   = TurtleT $ \_ s@(TurtleState o _) -> return (o,s)-  setOrigin o = TurtleT $ \_   (TurtleState _ c) -> return ((),TurtleState o c)--instance Monad m => TurtleScaleM (TurtleT u m) u where-  xStep    = TurtleT $ \r s -> return (xstep r,s)-  yStep    = TurtleT $ \r s -> return (ystep r,s)+  getLoc      = TurtleT $ \s@(TurtleState _ c) -> return (c,s)+  setLoc c    = TurtleT $ \(TurtleState o _)   -> return ((),TurtleState o c)+  getOrigin   = TurtleT $ \s@(TurtleState o _) -> return (o,s)+  setOrigin o = TurtleT $ \(TurtleState _ c)   -> return ((),TurtleState o c)  --- Run functions discard the state...- runTurtleT :: (Monad m, Num u) -           => TurtleConfig u -> (Int,Int) -> TurtleT u m a -> m a-runTurtleT cfg ogin mf = liftM fst $ getTurtleT mf cfg (TurtleState ogin ogin)--+           => (Int,Int) -> ScalingContext Int Int u -> TurtleT u m a -> m a+runTurtleT ogin cfg mf = +    runScalingT cfg (getTurtleT mf st0) >>= \(a,_) -> return a+  where +    st0 = TurtleState ogin ogin    @@ -123,89 +125,16 @@ -- Cross instances  instance DrawingCtxM m => DrawingCtxM (TurtleT u m) where-  askCtx   = TurtleT $ \_ s -> askCtx >>= \ ctx -> return (ctx,s)-  localCtx ctx mf = TurtleT $ \r s -> localCtx ctx (getTurtleT mf r s)+  askCtx   = TurtleT $ \s -> askCtx >>= \ ctx -> return (ctx,s)+  localCtx ctx mf = TurtleT $ \s -> localCtx ctx (getTurtleT mf s)   -- This needs undecidable instances...  instance (Monad m, TraceM m, u ~ MonUnit m) => TraceM (TurtleT u m) where-  trace a  = TurtleT $ \_ s -> trace a >> return ((),s)+  trace a  = TurtleT $ \s -> trace a >> return ((),s)   instance (Monad m, u ~ MonUnit m, Num u) => PointSupplyM (TurtleT u m) where-  position = getPos-------------------------------------------------------------------------------------newtype TurtleDrawing u a = TurtleDrawing { -          getTurtleDrawing :: TurtleT u (Drawing u) a }---type instance MonUnit (TurtleDrawing u) = u---instance Functor (TurtleDrawing u) where-  fmap f = TurtleDrawing . fmap f . getTurtleDrawing---- Applicative -instance Applicative (TurtleDrawing u) where-  pure a    = TurtleDrawing $ pure a-  mf <*> ma = TurtleDrawing $ getTurtleDrawing mf <*> getTurtleDrawing ma----- Monad --instance Monad (TurtleDrawing u) where-  return a = TurtleDrawing $ return a-  m >>= k  = TurtleDrawing $ getTurtleDrawing m >>= (getTurtleDrawing . k)---- TurtleM--instance TurtleM (TurtleDrawing u) where-  getLoc      = TurtleDrawing $ getLoc -  setLoc c    = TurtleDrawing $ setLoc c-  getOrigin   = TurtleDrawing $ getOrigin-  setOrigin o = TurtleDrawing $ setOrigin o--instance TurtleScaleM (TurtleDrawing u) u where-  xStep    = TurtleDrawing $ xStep-  yStep    = TurtleDrawing $ yStep------ TraceM --instance TraceM (TurtleDrawing u) where-  trace a = TurtleDrawing $ trace a---- DrawingCtxM--instance DrawingCtxM (TurtleDrawing u) where-  askCtx          = TurtleDrawing $ askCtx-  localCtx ctx ma = TurtleDrawing $ localCtx ctx (getTurtleDrawing ma)---- PointSupplyM--instance Num u => PointSupplyM (TurtleDrawing u) where-  position = getPos---runTurtleDrawing :: Num u -                 => TurtleConfig u -                 -> (Int,Int)-                 -> DrawingContext-                 -> TurtleDrawing u a -                 -> (a, HPrim u)-runTurtleDrawing cfg ogin ctx mf = -    runDrawing ctx ( runTurtleT cfg ogin $ getTurtleDrawing mf)-+  position = TurtleT $ \s@(TurtleState _ (x,y)) -> scalePt x y >>= \pt -> return (pt,s) -execTurtleDrawing :: Num u -                  => TurtleConfig u-                  -> (Int,Int) -                  -> DrawingContext-                  -> TurtleDrawing u a -                  -> HPrim u-execTurtleDrawing cfg ogin ctx mf = snd $ runTurtleDrawing cfg ogin ctx mf

@@ -10,155 +10,20 @@ -- Stability   :  highly unstable -- Portability :  GHC ----- Extended path type - more amenable for complex drawings than--- the type in Wumpus-Core.------ \*\* WARNING \*\* this module is an experiment, and may --- change significantly or even be dropped from future revisions.+-- Shim import module for Paths. --  --------------------------------------------------------------------------------  module Wumpus.Basic.Paths    (  -    connectS-  , pathGraphic--  , shorten-  , shortenL-  , shortenR-  , midpoint-  , directionL-  , directionR+    module Wumpus.Basic.Paths.Base+  , module Wumpus.Basic.Paths.Connectors+  , module Wumpus.Basic.Paths.Construction    ) where -import Wumpus.Basic.Graphic import Wumpus.Basic.Paths.Base+import Wumpus.Basic.Paths.Connectors import Wumpus.Basic.Paths.Construction -import Wumpus.Core                              -- package: wumpus-core--import Data.AffineSpace                         -- package: vector-space--import Data.Sequence----connectS :: Floating u => PathF u-connectS = \p0 p1 -> execPath p0 $ lineto p1------ This one might be more useful...--pathGraphic :: Num u => PathF u -> ConnGraphic u-pathGraphic bpath = \p1 p2 -> openStroke $ toPrimPathU $ bpath p1 p2-----shorten  :: (Real u, Floating u, Ord u) => u -> Path u -> Path u-shorten u p = shortenL u $ shortenR u p------------------------------------------------------------------------------------- shorten from the left...--shortenL :: (Real u, Floating u, Ord u) => u -> Path u -> Path u-shortenL n (Path u bp) | n >= u         = emptyPath-                       | otherwise      = step n (viewl bp)-  where-    step _ EmptyL     = emptyPath-    step d (e :< se)  = let z = segmentLength e in-                        case compare d z of-                          GT -> step (d-z) (viewl se)-                          EQ -> Path (u-n) se-                          _  -> Path (u-n) (shortenSegL d e <| se)---shortenSegL :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u-shortenSegL n (LineSeg  u l) = LineSeg  (u-n) (shortenLineL n l) -shortenSegL n (CurveSeg u c) = CurveSeg (u-n) (snd $ subdividet (n/u) c)--shortenLineL :: (Real u, Floating u) => u -> Line u -> Line u-shortenLineL n (Line p1 p2) = Line (p1 .+^ v) p2-  where-    v0 = p2 .-. p1-    v  = avec (direction v0) n-    ------------------------------------------------------------------------------------ shorten from the right ...- -shortenR :: (Real u, Floating u, Ord u) => u -> Path u -> Path u-shortenR n (Path u bp) | n >= u         = emptyPath-                       | otherwise      = step n (viewr bp)-  where-    step _ EmptyR     = emptyPath-    step d (se :> e)  = let z = segmentLength e in-                        case compare d z of-                          GT -> step (d-z) (viewr se)-                          EQ -> Path (u-n) se-                          _  -> Path (u-n) (se |> shortenSegR d e)----shortenSegR :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u-shortenSegR n (LineSeg  u l) = LineSeg  (u-n) (shortenLineR n l) -shortenSegR n (CurveSeg u c) = CurveSeg (u-n) (fst $ subdividet ((u-n)/u) c)---shortenLineR :: (Real u, Floating u) => u -> Line u -> Line u-shortenLineR n (Line p1 p2) = Line p1 (p2 .+^ v)-  where-    v0 = p1 .-. p2-    v  = avec (direction v0) n--------------------------------------------------------------------------------------midpoint :: (Real u, Floating u) => Path u -> Point2 u-midpoint (Path u bp) = step (u/2) (viewl bp)-  where-    step _ EmptyL    = zeroPt-    step d (e :< se) = let z = segmentLength e in-                       case compare d z of-                         GT -> step (d-z) (viewl se)-                         EQ -> segmentEnd e-                         _  -> segmentEnd $ shortenSegL d e ----------------------------------------------------------------------------------------- tangents---directionL :: (Real u, Floating u) => Path u -> Radian-directionL (Path _ se) = step $ viewl se-  where-    step (LineSeg  _ l :< _) = lineDirectionL l -    step (CurveSeg _ c :< _) = curveDirectionL c-    step _                   = 0--directionR :: (Real u, Floating u) => Path u -> Radian-directionR (Path _ se) = step $ viewr se-  where-    step (_ :> LineSeg  _ l) = lineDirectionR l -    step (_ :> CurveSeg _ c) = curveDirectionR c-    step _                   = 0---lineDirectionL :: (Real u, Floating u) => Line u -> Radian-lineDirectionL (Line p0 p1) = direction (pvec p1 p0)--lineDirectionR :: (Real u, Floating u) => Line u -> Radian-lineDirectionR (Line p0 p1) = direction (pvec p0 p1)--curveDirectionL :: (Real u, Floating u) => Curve u -> Radian-curveDirectionL (Curve p0 p1 _ _) = direction $ pvec p1 p0--curveDirectionR :: (Real u, Floating u) => Curve u -> Radian-curveDirectionR (Curve _ _ p2 p3) = direction $ pvec p2 p3- 

@@ -22,9 +22,7 @@ module Wumpus.Basic.Paths.Base   (  -    PathF--  , Path(..)+    Path(..)   , PathSeg(..)   , Curve(..)   , Line(..)@@ -56,7 +54,7 @@ -- Note - path doesn\'t need a drawing context for  -- construction... ---type PathF u = Point2 u -> Point2 u -> Path u+-- type PathF u = Point2 u -> Point2 u -> Path u   data Path u = Path 

@@ -0,0 +1,211 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Paths.Connectors+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Extended path type - more amenable for complex drawings than+-- the type in Wumpus-Core.+--+-- \*\* WARNING \*\* this module is an experiment, and may +-- change significantly or even be dropped from future revisions.+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.Paths.Connectors +  ( ++    ConnPath+  , connectS+  , vhconn+  , hvconn+  , arbv+  , arbh+  , curveconn+  , joint+  , pathGraphic+  , fillPath++  , shorten+  , shortenL+  , shortenR+  , midpoint+  , directionL+  , directionR++  ) where++import Wumpus.Basic.Graphic+import Wumpus.Basic.Paths.Base+import Wumpus.Basic.Paths.Construction++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space++import Data.Sequence++type ConnPath u = Point2 u -> Point2 u -> Path u++connectS :: Floating u => ConnPath u+connectS = \p1 p2 -> execPath p1 $ lineto p2++vhconn :: Floating u => ConnPath u+vhconn p1 p2 = execPath p1 $ verticalHorizontal p2++hvconn :: Floating u => ConnPath u+hvconn p1 p2 = execPath p1 $ horizontalVertical p2++arbv :: Floating u => u -> ConnPath u+arbv v p1@(P2 x1 y1) (P2 x2 y2) = execPath p1 $ vline v >> hline dx >> vline dy+  where+    dx = x2 - x1+    dy = y2 - (y1+v)+++arbh :: Floating u => u -> ConnPath u+arbh h p1@(P2 x1 y1) (P2 x2 y2) = execPath p1 $ hline h >> vline dy >> hline dx+  where+    dx = x2 - (x1+h)+    dy = y2 - y1++curveconn :: (Floating u, Ord u) => Radian -> Radian -> ConnPath u+curveconn r1 r2 p1 p2 = execPath p1 $ curveto r1 r2 p2+++joint :: (Real u, Floating u) => u -> ConnPath u +joint u p1@(P2 x1 y1) p2@(P2 x2 y2) = +    execPath p1 $ lineto (mid_pt .+^ avec perp_ang u) >> lineto p2+  where+    mid_pt    = P2 (x1 + 0.5*(x2-x1)) (y1 + 0.5*(y2-y1))+    perp_ang  = (pi*0.5) + direction (pvec p2 p1) ++-- This one might be more useful...+-- +-- ... No - can\'t a add tips to this one.+--+pathGraphic :: Num u => ConnPath u -> ConnGraphic u+pathGraphic bpath = \p1 p2 -> openStroke $ toPrimPathU $ bpath p1 p2+++-- Mind out for name clash...++-- | Closes and fills a path+--+fillPath :: Num u => Path u -> Graphic u+fillPath = filledPath . toPrimPathU++++shorten  :: (Real u, Floating u, Ord u) => u -> Path u -> Path u+shorten u p = shortenL u $ shortenR u p++--------------------------------------------------------------------------------+-- shorten from the left...++shortenL :: (Real u, Floating u, Ord u) => u -> Path u -> Path u+shortenL n (Path u bp) | n >= u         = emptyPath+                       | otherwise      = step n (viewl bp)+  where+    step _ EmptyL     = emptyPath+    step d (e :< se)  = let z = segmentLength e in+                        case compare d z of+                          GT -> step (d-z) (viewl se)+                          EQ -> Path (u-n) se+                          _  -> Path (u-n) (shortenSegL d e <| se)+++shortenSegL :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u+shortenSegL n (LineSeg  u l) = LineSeg  (u-n) (shortenLineL n l) +shortenSegL n (CurveSeg u c) = CurveSeg (u-n) (snd $ subdividet (n/u) c)++shortenLineL :: (Real u, Floating u) => u -> Line u -> Line u+shortenLineL n (Line p1 p2) = Line (p1 .+^ v) p2+  where+    v0 = p2 .-. p1+    v  = avec (direction v0) n+    +--------------------------------------------------------------------------------+-- shorten from the right ...+ +shortenR :: (Real u, Floating u, Ord u) => u -> Path u -> Path u+shortenR n (Path u bp) | n >= u         = emptyPath+                       | otherwise      = step n (viewr bp)+  where+    step _ EmptyR     = emptyPath+    step d (se :> e)  = let z = segmentLength e in+                        case compare d z of+                          GT -> step (d-z) (viewr se)+                          EQ -> Path (u-n) se+                          _  -> Path (u-n) (se |> shortenSegR d e)++++shortenSegR :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u+shortenSegR n (LineSeg  u l) = LineSeg  (u-n) (shortenLineR n l) +shortenSegR n (CurveSeg u c) = CurveSeg (u-n) (fst $ subdividet ((u-n)/u) c)+++shortenLineR :: (Real u, Floating u) => u -> Line u -> Line u+shortenLineR n (Line p1 p2) = Line p1 (p2 .+^ v)+  where+    v0 = p1 .-. p2+    v  = avec (direction v0) n++++--------------------------------------------------------------------------------++-- This should return direction as well...+--+midpoint :: (Real u, Floating u) => Path u -> Point2 u+midpoint (Path u bp) = step (u/2) (viewl bp)+  where+    step _ EmptyL    = zeroPt+    step d (e :< se) = let z = segmentLength e in+                       case compare d z of+                         GT -> step (d-z) (viewl se)+                         EQ -> segmentEnd e+                         _  -> segmentEnd $ shortenSegR d e ++++++--------------------------------------------------------------------------------+-- tangents+++directionL :: (Real u, Floating u) => Path u -> Radian+directionL (Path _ se) = step $ viewl se+  where+    step (LineSeg  _ l :< _) = lineDirectionL l +    step (CurveSeg _ c :< _) = curveDirectionL c+    step _                   = 0++directionR :: (Real u, Floating u) => Path u -> Radian+directionR (Path _ se) = step $ viewr se+  where+    step (_ :> LineSeg  _ l) = lineDirectionR l +    step (_ :> CurveSeg _ c) = curveDirectionR c+    step _                   = 0+++lineDirectionL :: (Real u, Floating u) => Line u -> Radian+lineDirectionL (Line p0 p1) = direction (pvec p1 p0)++lineDirectionR :: (Real u, Floating u) => Line u -> Radian+lineDirectionR (Line p0 p1) = direction (pvec p0 p1)++curveDirectionL :: (Real u, Floating u) => Curve u -> Radian+curveDirectionL (Curve p0 p1 _ _) = direction $ pvec p1 p0++curveDirectionR :: (Real u, Floating u) => Curve u -> Radian+curveDirectionR (Curve _ _ p2 p3) = direction $ pvec p2 p3+ 

@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE FlexibleContexts           #-} {-# OPTIONS -Wall #-} @@ -21,11 +22,13 @@ module Wumpus.Basic.Paths.Construction   (  -    MPath-  , CPath+    PathM   , runPath   , execPath   , lineto+  , rlineto+  , vline+  , hline   , bezierto   , curveto   , verticalHorizontal@@ -46,61 +49,84 @@       , path_accum    :: Path u       } -newtype MPath u a = MPath { getMPath :: PathState u -> (a,PathState u) }+newtype PathM u a = PathM { getPathM :: PathState u -> (a,PathState u) } -type CPath u = MPath u () -instance Functor (MPath u) where-  fmap f mf = MPath $ \s -> let (a,s') = getMPath mf s in (f a,s')+instance Functor (PathM u) where+  fmap f mf = PathM $ \s -> let (a,s1) = getPathM mf s in (f a,s1)  -instance Applicative (MPath u) where-  pure a    = MPath $ \s -> (a,s)-  mf <*> ma = MPath $ \s -> let (f,s')  = getMPath mf s-                                (a,s'') = getMPath ma s'-                            in (f a,s'')+instance Applicative (PathM u) where+  pure a    = PathM $ \s -> (a,s)+  mf <*> ma = PathM $ \s -> let (f,s1) = getPathM mf s+                                (a,s2) = getPathM ma s1+                            in (f a,s2) -instance Monad (MPath u) where-  return a  = MPath $ \s -> (a,s)-  m >>= k   = MPath $ \s -> let (a,s') = getMPath m s in-                            (getMPath . k) a s'+instance Monad (PathM u) where+  return a  = PathM $ \s -> (a,s)+  m >>= k   = PathM $ \s -> let (a,s1) = getPathM m s in+                            (getPathM . k) a s1  -runPath :: Num u => Point2 u -> MPath u a -> (a, Path u)-runPath start mf = let (a,s') = getMPath mf s in (a, path_accum s')+-- Design note - it is probably best to follow LRText and have+-- the path monad isolated from the trace monad. While it would +-- be nice to trace arbitrary labels as we go, state changes to the +-- DrawingCtx would make things complicated.+--++{-+openStrokePathM :: (Num u, TraceM m, DrawingCtxM m, u ~ MonUnit m) +                => Point2 u -> PathM u a -> m a+openStrokePathM pt ma = let (a,p) = runPath pt ma  in +    draw (openStroke $ toPrimPathU p) >> return a+-}++-- Running the path is agnostic to the DrawingCtx.++runPath :: Num u => Point2 u -> PathM u a -> (a, Path u)+runPath start mf = let (a,s') = getPathM mf s in (a, path_accum s')   where     s = PathState { current_point = start                   , path_accum    = emptyPath                   } -execPath :: Num u => Point2 u -> MPath u a -> Path u+execPath :: Num u => Point2 u -> PathM u a -> Path u execPath start mf = snd $ runPath start mf  -exchTip :: Point2 u -> (Point2 u -> Path u -> Path u) -> MPath u ()+exchTip :: Point2 u -> (Point2 u -> Path u -> Path u) -> PathM u () exchTip new updP = -    MPath $ \(PathState old bp) -> ((), PathState new (updP old bp)) +    PathM $ \(PathState old bp) -> ((), PathState new (updP old bp))  -tip :: MPath u (Point2 u)-tip = MPath $ \s -> (current_point s,s)+tip :: PathM u (Point2 u)+tip = PathM $ \s -> (current_point s,s)  -lineto :: Floating u => Point2 u -> CPath u+lineto :: Floating u => Point2 u -> PathM u () lineto end = exchTip end upd   where     upd start bp = bp `addSegment` pline start end  +rlineto :: Floating u => Vec2 u -> PathM u ()+rlineto (V2 dx dy) = tip >>= \(P2 x y) -> lineto (P2 (x+dx) (y+dy)) +hline :: Floating u => u -> PathM u ()+hline dx = tip >>= \(P2 x y) -> lineto (P2 (x+dx) y)++vline :: Floating u => u -> PathM u ()+vline dy = tip >>= \(P2 x y) -> lineto (P2 x (y+dy))+ + bezierto :: (Floating u, Ord u) -         => Point2 u -> Point2 u -> Point2 u -> CPath u+         => Point2 u -> Point2 u -> Point2 u -> PathM u () bezierto cp1 cp2 end = exchTip end upd    where     upd start bp = bp `addSegment` pcurve start cp1 cp2 end   curveto :: (Floating u, Ord u) -        => Radian -> Radian -> Point2 u -> CPath u+        => Radian -> Radian -> Point2 u -> PathM u () curveto cin cout end = exchTip end upd   where      upd start bp = bp `addSegment` pcurveAng start cin cout end@@ -115,10 +141,10 @@     v2     = avec cout sz  -verticalHorizontal :: Floating u => Point2 u -> CPath u+verticalHorizontal :: Floating u => Point2 u -> PathM u () verticalHorizontal (P2 x y) =      tip >>= \(P2 x0 _) -> lineto (P2 x0 y) >> lineto (P2 x y) -horizontalVertical :: Floating u => Point2 u -> CPath u+horizontalVertical :: Floating u => Point2 u -> PathM u () horizontalVertical (P2 x y) =      tip >>= \(P2 _ y0) -> lineto (P2 x y0) >> lineto (P2 x y)

@@ -0,0 +1,162 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Shapes.Base+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Common core for shapes+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.Shapes.Base+  ( +++    Shape(..)++  , drawShape++  -- * ShapeCTM +  , ShapeCTM(..)+  , identityCTM++  , ctmDisplace+  , ctmCenter++  , ShapeLabel+  , runShapeLabel+  , nolabel+  , shapelabel++  ) where++import Wumpus.Basic.Graphic+++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space+++import Control.Applicative+import Data.Monoid+++data Shape u sh =  Shape +      { src_ctm :: ShapeCTM u +      , out_fun :: ShapeCTM u -> Image u sh+      }++type instance DUnit (Shape u sh) = u++++++drawShape :: Shape u sh -> Image u sh+drawShape (Shape { src_ctm = ctm, out_fun = fn }) = fn ctm +++instance (Real u, Floating u) => Rotate (Shape u sh) where+  rotate r = updateCTM (rotateCTM r)++instance Num u => Scale (Shape u sh) where+  scale x y = updateCTM (scaleCTM x y)++instance Num u => Translate (Shape u sh) where+  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++--------------------------------------------------------------------------------+-- CTM++-- Note - all shapes need a location (usually/always the center)+-- so this needs to be stored in the CTM.+--++data ShapeCTM u = ShapeCTM +      { ctm_trans_x             :: !u+      , ctm_trans_y             :: !u+      , ctm_scale_x             :: !u+      , ctm_scale_y             :: !u+      , ctm_rotation            :: Radian+      }+  deriving (Eq,Show)++type instance DUnit (ShapeCTM u) = u++identityCTM :: Num u => ShapeCTM u+identityCTM = ShapeCTM { ctm_trans_x  = 0 +                       , ctm_trans_y  = 0 +                       , ctm_scale_x  = 1+                       , ctm_scale_y  = 1+                       , ctm_rotation = 0 }++++++scaleCTM :: Num u => u -> u -> ShapeCTM u -> ShapeCTM u+scaleCTM sx sy = +    (\s x y -> s { ctm_scale_x = x*sx, ctm_scale_y = y*sy })+      <*> ctm_scale_x <*> ctm_scale_y+++rotateCTM :: Radian -> ShapeCTM u -> ShapeCTM u+rotateCTM ang1 = +    (\s ang -> s { ctm_rotation = circularModulo $ ang1+ang })+      <*> ctm_rotation+++translateCTM :: Num u => u -> u -> ShapeCTM u -> ShapeCTM u+translateCTM dx dy = +    (\s x y -> s { ctm_trans_x = x+dx, ctm_trans_y = y+dy })+      <*> ctm_trans_x <*> ctm_trans_y+++ctmDisplace :: (Real u, Floating u) => Point2 u -> ShapeCTM u -> Point2 u+ctmDisplace (P2 x y) (ShapeCTM { ctm_trans_x  = dx, ctm_trans_y  = dy +                               , ctm_scale_x  = sx, ctm_scale_y  = sy+                               , ctm_rotation = theta }) = +    translate dx dy $ rotate theta $ P2 (sx*x) (sy*y)+++ctmCenter :: (Real u, Floating u) => ShapeCTM u -> Point2 u+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,411 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE TypeSynonymInstances       #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Shapes.Derived+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- +-- +--------------------------------------------------------------------------------++module Wumpus.Basic.Shapes.Derived+  ( +    Rectangle+  , DRectangle+  , rectangle+  , lrectangle++  , Circle+  , DCircle+  , circle+  , lcircle++  , Coordinate+  , DCoordinate+  , coordinate++  , Diamond+  , DDiamond+  , diamond+  , ldiamond++  , Ellipse+  , DEllipse+  , ellipse+  , lellipse++  , FreeLabel+  , DFreeLabel+  , freelabel++  ) where++import Wumpus.Basic.Anchors+import Wumpus.Basic.Graphic+import Wumpus.Basic.Shapes.Base+import Wumpus.Basic.Utils.Intersection++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space ++import Data.Monoid+++--------------------------------------------------------------------------------+-- Rectangle++data Rectangle u = Rectangle +      { rect_ctm    :: ShapeCTM u+      , rect_hw     :: !u+      , rect_hh     :: !u +      }+  deriving (Eq,Show)++type DRectangle = Rectangle Double++type instance DUnit (Rectangle u) = u+++instance (Real u, Floating u) => CenterAnchor (Rectangle u) where+  center = ctmCenter . rect_ctm+++calcRectPoint :: (Real u, Floating u) +              => (u -> u -> Point2 u) -> Rectangle u -> Point2 u+calcRectPoint f (Rectangle { rect_ctm = ctm, rect_hw = hw, rect_hh = hh }) =+    let pt = f hw hh in ctmDisplace pt ctm++instance (Real u, Floating u) => CardinalAnchor (Rectangle u) where+  north = calcRectPoint $ \ _  hh -> P2 0 hh+  south = calcRectPoint $ \ _  hh -> P2 0 (-hh)+  east  = calcRectPoint $ \ hw _  -> P2 hw 0+  west  = calcRectPoint $ \ hw _  -> P2 (-hw) 0++instance (Real u, Floating u) => CardinalAnchor2 (Rectangle u) where+  northeast = calcRectPoint $ \ hw hh -> P2 hw hh+  southeast = calcRectPoint $ \ hw hh -> P2 hw (-hh)+  southwest = calcRectPoint $ \ hw hh -> P2 (-hw) (-hh)+  northwest = calcRectPoint $ \ hw hh -> P2 (-hw) hh+++instance (Real u, Floating u) => RadialAnchor (Rectangle u) where+  radialAnchor theta rect@(Rectangle { rect_hw=hw, rect_hh=hh }) = +      maybe ctr id $ findIntersect ctr theta $ rectangleLines ctr hw hh +    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+                      }+++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)+                          }+++outputRect :: (Real u, Floating u) +           => u -> u -> ShapeLabel u -> ShapeCTM u -> Image u (Rectangle u)+outputRect hw hh shl ctm = intoImage (pureDF a) (drawRect a `mappend` label) +  where+    a     = Rectangle { rect_ctm = ctm, rect_hw = hw, rect_hh = hh }+    label = runShapeLabel ctm shl+++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+                           ]++++++--------------------------------------------------------------------------------+-- Circle++data Circle u = Circle +      { circ_ctm    :: ShapeCTM u+      , circ_radius :: !u +      }+  deriving (Eq,Show)+  +type DCircle = Circle Double++type instance DUnit (Circle u) = u++instance (Real u, Floating u) => CenterAnchor (Circle u) where+  center = ctmCenter . circ_ctm+++calcCircPoint :: (Real u, Floating u) +              => (u -> Point2 u) -> Circle u -> Point2 u+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) => 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 (pureDF a) (drawCirc a `mappend` label) +  where+    a     = Circle { circ_ctm = ctm, circ_radius = rad }+    label = runShapeLabel ctm shl+++drawCirc :: (Real u, Floating u) => Circle u -> Graphic u+drawCirc = borderedPath . circlePath+++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+  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 (pureDF a) (drawCoord a) +  where+    a = Coordinate { coord_ctm = ctm }+++drawCoord :: (Real u, Floating u) => Coordinate u -> Graphic u+drawCoord coord = localDF swapColours $ filledEllipse 2 2 (center coord)++--------------------------------------------------------------------------------+-- Diamond+++data Diamond u = Diamond +      { dia_ctm   :: ShapeCTM u+      , dia_hw    :: !u+      , dia_hh    :: !u+      }++type DDiamond = Diamond Double++type instance DUnit (Diamond u) = u+++instance (Real u, Floating u) => CenterAnchor (Diamond u) where+  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 }) =+    let pt = f hw hh in ctmDisplace pt ctm++instance (Real u, Floating u) => CardinalAnchor (Diamond u) where+  north = calcDiaPoint $ \ _  hh -> P2 0 hh+  south = calcDiaPoint $ \ _  hh -> P2 0 (-hh)+  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)+                          }++++outputDia :: (Real u, Floating u) +          => u -> u -> ShapeLabel u -> ShapeCTM u -> Image u (Diamond u)+outputDia hw hh shl ctm = intoImage (pureDF 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 ]+++--------------------------------------------------------------------------------+-- Ellipse+++data Ellipse u = Ellipse+      { ell_ctm     :: ShapeCTM u +      , ell_rx      :: !u+      , ell_ry      :: !u+      }++type DEllipse = Ellipse Double++type instance DUnit (Ellipse u) = u++++instance (Real u, Floating u) => CenterAnchor (Ellipse u) where+  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)+                          }+++outputEll :: (Real u, Floating u) +          => u -> u -> ShapeLabel u -> ShapeCTM u -> Image u (Ellipse u)+outputEll rx ry shl ctm = intoImage (pureDF a) (drawEll a `mappend` label)+  where+    a     = Ellipse { ell_ctm = ctm, ell_rx = rx, ell_ry = ry }+    label = runShapeLabel ctm shl+++drawEll :: (Real u, Floating u) => Ellipse u -> Graphic u+drawEll = borderedPath . ellipsePath+++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 +++-- | x_radius is the unit length.+--+rescale :: (Scale t, Fractional u, u ~ DUnit t) => u -> u -> t -> t+rescale rx ry = scale 1 (ry/rx) +++--------------------------------------------------------------------------------+-- 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++type instance DUnit (FreeLabel u) = u+++instance (Real u, Floating u) => CenterAnchor (FreeLabel u) where+  center = center . getFreeLabel+++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)

@@ -12,19 +12,53 @@ -- -- Named literals from Symbol font, drawn with the LRText monad. -- --- Note - currently the techinique used here generates adequate--- PostScript, but very ineficient SVG.--- --- Also uUpsilon is not mapped to the correct character...+-- Note - Symbol font handling and precise letter placing in SVG +-- viewers is mixed. Chrome works well good, Firefox (3.6.3) and +-- Safari (5.0.1) are unsatisfactory.+--  +--    -- --------------------------------------------------------------------------------  module Wumpus.Basic.Text.LRSymbol   (  ++  -- * Upper case letters and upper case Greek letters+    uAlpha+  , uBeta+  , uChi+  , uDelta+  , uEpsilon+  , uEta+  , uEuro+  , uGamma+  , uIfraktur+  , uIota+  , uKappa+  , uLambda+  , uMu+  , uNu+  , uOmega+  , uOmicron+  , uPhi+  , uPi+  , uPsi+  , uRfraktur+  , uRho+  , uSigma+  , uTau+  , uTheta+  , uUpsilon+  , uUpsilon1+  , uXi+  , uZeta+  ++   -- * Lower case Greek letters -    alpha+  , alpha   , beta   , gamma   , delta@@ -48,21 +82,121 @@   , psi   , omega -  -- * Upper case Greek letters-  , uGamma-  , uDelta-  , uTheta-  , uLambda-  , uXi-  , uPi-  , uSigma-  , uUpsilon-  , uPhi-  , uPsi-  , uOmega--  , otimes-  , oplus+  -- * Miscellaneous chars+  , aleph+  , ampersand+  , angle+  , angleleft+  , angleright+  , approxequal+  , arrowboth+  , arrowdblboth+  , arrowdbldown+  , arrowdblleft+  , arrowdblright+  , arrowdblup+  , arrowdown+  , arrowleft+  , arrowright+  , arrowup+  , asteriskmath+  , bar+  , braceleft+  , braceright+  , bracketleft+  , bracketright+  , bullet+  , carriagereturn+  , circlemultiply+  , circleplus+  , club +  , colon+  , comma+  , congruent+  , copyrightsans+  , copyrightserif+  , degree+  , diamond+  , divide+  , dotmath+  , eight+  , element+  , ellipsis+  , emptyset+  , equal+  , equivalence+  , exclam+  , existential+  , five+  , florin+  , four+  , fraction+  , gradient+  , greater+  , greaterequal+  , heart+  , infinity+  , integral+  , intersection+  , less+  , lessequal+  , logicaland+  , logicalnot+  , logicalor+  , lozenge+  , minus+  , minute+  , multiply+  , nine+  , notelement+  , notequal+  , notsubset+  , numbersign+  , omega1+  , omicron+  , one+  , parenleft+  , parenright+  , partialdiff+  , percent+  , period+  , perpendicular+  , phi1+  , plus+  , plusminus+  , product+  , propersubset+  , propersuperset+  , proportional+  , question+  , radical+  , radicalex+  , reflexsubset+  , reflexsuperset+  , registersans+  , registerserif+  , second+  , semicolon+  , seven+  , sigma1+  , similar+  , six+  , slash+  , space+  , spade+  , suchthat+  , summation+  , therefore+  , theta1+  , three+  , trademarksans+  , trademarkserif+  , two+  , underscore+  , union+  , universal+  , weierstrass+  , zero    ) where @@ -70,144 +204,543 @@ import Wumpus.Basic.Text.LRText  -import Prelude hiding ( pi )+import Prelude hiding ( pi, product ) --- Note - due to a optimization in Wumpus-Core, the PostScript--- generated by the techinique here - writing a --- (single-character) label one at a time - isn\'t too bad as --- Wumpus-Core only issues a findfont command when the font --- changes. --- --- However for SVG the result is very poor - one text element --- including an orientation changing matrix transforming for --- each character.--- --- Wumpus-Core\'s SVG rendering will work at some point.---    ----------------------------------------------------------------------------------- lower case+-- upper case +-- | Note - prints as \'A\'.+--+uAlpha          :: Num u => LRText u ()+uAlpha          = symb 'A' -alpha       :: Num u => TextM u ()-alpha       = symb 'a'+-- | Note - prints as \'B\'.+--+uBeta           :: Num u => LRText u ()+uBeta           = symb 'B' -beta        :: Num u => TextM u ()-beta        = symb 'b'+-- | Note - prints as \'X\'.+--+uChi            :: Num u => LRText u ()+uChi            = symb 'C' -gamma       :: Num u => TextM u ()-gamma       = symb 'g'+uDelta          :: Num u => LRText u ()+uDelta          = symb 'D' -delta       :: Num u => TextM u ()-delta       = symb 'd'+-- | Note - prints as \'E\'.+--+uEpsilon        :: Num u => LRText u ()+uEpsilon        = symb 'E' -epsilon     :: Num u => TextM u ()-epsilon     = symb 'e'+-- | Note - prints as \'H\'.+--+uEta            :: Num u => LRText u ()+uEta            = symb 'H' -zeta        :: Num u => TextM u ()-zeta        = symb 'z' -eta         :: Num u => TextM u ()-eta         = symb 'h'+-- | Note - does not appear to print in Chrome.+--+uEuro           :: Num u => LRText u ()+uEuro           = symbEscInt 0o240 -theta       :: Num u => TextM u ()-theta       = symb 'q'+uGamma          :: Num u => LRText u ()+uGamma          = symb 'G' -iota        :: Num u => TextM u ()-iota        = symb 'i'+uIfraktur       :: Num u => LRText u ()+uIfraktur       = symbEscInt 0o301 -kappa       :: Num u => TextM u ()-kappa       = symb 'k'+-- | Note - prints as \'I\'.+--+uIota           :: Num u => LRText u ()+uIota           = symb 'I' -lambda      :: Num u => TextM u ()-lambda      = symb 'l'+-- | Note - prints as \'K\'.+--+uKappa          :: Num u => LRText u ()+uKappa          = symb 'K' -mu          :: Num u => TextM u ()-mu          = symb 'm'+uLambda         :: Num u => LRText u ()+uLambda         = symb 'L' -nu          :: Num u => TextM u ()-nu          = symb 'n'+-- | Note - prints as \'M\'.+--+uMu             :: Num u => LRText u ()+uMu             = symb 'M' -xi          :: Num u => TextM u ()-xi          = symb 'x'+-- | Note - prints as \'N\'.+--+uNu             :: Num u => LRText u ()+uNu             = symb 'N' -pi          :: Num u => TextM u ()-pi          = symb 'p'+uOmega          :: Num u => LRText u ()+uOmega          = symbEscInt 0o127 -rho         :: Num u => TextM u ()-rho         = symb 'r'+uOmicron        :: Num u => LRText u ()+uOmicron        = symbEscInt 0o117 -sigma       :: Num u => TextM u ()-sigma       = symb 's'+uPhi            :: Num u => LRText u ()+uPhi            = symbEscInt 0o106 -tau         :: Num u => TextM u ()-tau         = symb 't'+uPi             :: Num u => LRText u ()+uPi             = symb 'P' -upsilon     :: Num u => TextM u ()-upsilon     = symb 'u'+uPsi            :: Num u => LRText u ()+uPsi            = symbEscInt 0o131 -phi         :: Num u => TextM u ()-phi         = symb 'j'+uRfraktur       :: Num u => LRText u ()+uRfraktur       = symbEscInt 0o302 -chi         :: Num u => TextM u ()-chi         = symb 'c'+uRho            :: Num u => LRText u ()+uRho            = symbEscInt 0o122 -psi         :: Num u => TextM u ()-psi         = symb 'y'+uSigma          :: Num u => LRText u ()+uSigma          = symb 'S' -omega       :: Num u => TextM u ()-omega       = symb 'w'+uTau            :: Num u => LRText u ()+uTau            = symb 'T'  +uTheta          :: Num u => LRText u ()+uTheta          = symb 'Q'++-- | Note - prints as \'Y\'.+--+uUpsilon        :: Num u => LRText u ()+uUpsilon        = symbEscInt 0o125++-- | Note - this is the /pretty/ Upsilon.+--+uUpsilon1       :: Num u => LRText u ()+uUpsilon1       = symbEscInt 0o241++uXi             :: Num u => LRText u ()+uXi             = symb 'X'++uZeta           :: Num u => LRText u ()+uZeta           = symb 'Z'++ ----------------------------------------------------------------------------------- upper case+-- lower case Greek letters -uGamma      :: Num u => TextM u ()-uGamma      = symb 'G' -uDelta      :: Num u => TextM u ()-uDelta      = symb 'D'+alpha           :: Num u => LRText u ()+alpha           = symb 'a' -uTheta      :: Num u => TextM u ()-uTheta      = symb 'Q'+beta            :: Num u => LRText u ()+beta            = symb 'b' -uLambda     :: Num u => TextM u ()-uLambda     = symb 'L'+gamma           :: Num u => LRText u ()+gamma           = symb 'g' -uXi         :: Num u => TextM u ()-uXi         = symb 'X'+delta           :: Num u => LRText u ()+delta           = symb 'd' -uPi         :: Num u => TextM u ()-uPi         = symb 'P'+epsilon         :: Num u => LRText u ()+epsilon         = symb 'e' -uSigma      :: Num u => TextM u ()-uSigma      = symb 'S'+zeta            :: Num u => LRText u ()+zeta            = symb 'z' --- | Not working in PostScript, @\&\#161;@ works for SVG but --- PostScript needs an encoding table for Symbol-Font not Latin1!------ For PostScript, Latin1 @161@ maps to @exclamdown@ not --- @Upsilon1@, extending Wumpus-Core to support this will require --- quite some work...----uUpsilon    :: Num u => TextM u ()-uUpsilon    = symbEscInt 161+eta             :: Num u => LRText u ()+eta             = symb 'h' -uPhi        :: Num u => TextM u ()-uPhi        = symb 'F'+theta           :: Num u => LRText u ()+theta           = symb 'q' -uPsi        :: Num u => TextM u ()-uPsi        = symb 'Y'+iota            :: Num u => LRText u ()+iota            = symb 'i' -uOmega      :: Num u => TextM u ()-uOmega      = symb 'W'+kappa           :: Num u => LRText u ()+kappa           = symb 'k' +lambda          :: Num u => LRText u ()+lambda          = symb 'l' +mu              :: Num u => LRText u ()+mu              = symb 'm'++nu              :: Num u => LRText u ()+nu              = symb 'n'++xi              :: Num u => LRText u ()+xi              = symb 'x'++pi              :: Num u => LRText u ()+pi              = symb 'p'++rho             :: Num u => LRText u ()+rho             = symb 'r'++sigma           :: Num u => LRText u ()+sigma           = symb 's'++tau             :: Num u => LRText u ()+tau             = symb 't'++upsilon         :: Num u => LRText u ()+upsilon         = symb 'u'++phi             :: Num u => LRText u ()+phi             = symb 'j'++chi             :: Num u => LRText u ()+chi             = symb 'c'++psi             :: Num u => LRText u ()+psi             = symb 'y'++omega           :: Num u => LRText u ()+omega           = symb 'w'+++ --------------------------------------------------------------------------------+-- Miscellaneous chars -otimes      :: Num u => TextM u ()-otimes      = symbi 0xc4+aleph           :: Num u => LRText u ()+aleph           = symbEscInt 0o300 -oplus       :: Num u => TextM u ()-oplus       = symbi 0xc5+ampersand       :: Num u => LRText u ()+ampersand       = symbEscInt 0o046++angle           :: Num u => LRText u ()+angle           = symbEscInt 0o320++angleleft       :: Num u => LRText u ()+angleleft       = symbEscInt 0o341++angleright      :: Num u => LRText u ()+angleright      = symbEscInt 0o361++approxequal     :: Num u => LRText u ()+approxequal     = symbEscInt 0o273++arrowboth       :: Num u => LRText u ()+arrowboth       = symbEscInt 0o253++arrowdblboth    :: Num u => LRText u ()+arrowdblboth    = symbEscInt 0o333++arrowdbldown    :: Num u => LRText u ()+arrowdbldown    = symbEscInt 0o337++arrowdblleft    :: Num u => LRText u ()+arrowdblleft    = symbEscInt 0o334++arrowdblright   :: Num u => LRText u ()+arrowdblright   = symbEscInt 0o336++arrowdblup      :: Num u => LRText u ()+arrowdblup      = symbEscInt 0o335++arrowdown       :: Num u => LRText u ()+arrowdown       = symbEscInt 0o257++arrowleft       :: Num u => LRText u ()+arrowleft       = symbEscInt 0o254++arrowright      :: Num u => LRText u ()+arrowright      = symbEscInt 0o256++arrowup         :: Num u => LRText u ()+arrowup         = symbEscInt 0o255++asteriskmath    :: Num u => LRText u ()+asteriskmath    = symbEscInt 0o052++bar             :: Num u => LRText u ()+bar             = symbEscInt 0o174++braceleft       :: Num u => LRText u ()+braceleft       = symbEscInt 0o173++braceright      :: Num u => LRText u ()+braceright      = symbEscInt 0o175++bracketleft     :: Num u => LRText u ()+bracketleft     = symbEscInt 0o133++bracketright    :: Num u => LRText u ()+bracketright    = symbEscInt 0o135++bullet          :: Num u => LRText u ()+bullet          = symbEscInt 0o267++carriagereturn  :: Num u => LRText u ()+carriagereturn  = symbEscInt 0o277+++circlemultiply  :: Num u => LRText u ()+circlemultiply  = symbEscInt 0o304++circleplus      :: Num u => LRText u ()+circleplus      = symbEscInt 0o305++club            :: Num u => LRText u ()+club            = symbEscInt 0o247++colon           :: Num u => LRText u ()+colon           = symbEscInt 0o072++comma           :: Num u => LRText u ()+comma           = symbEscInt 0o054++congruent       :: Num u => LRText u ()+congruent             = symbEscInt 0o100++copyrightsans   :: Num u => LRText u ()+copyrightsans   = symbEscInt 0o343++copyrightserif  :: Num u => LRText u ()+copyrightserif  = symbEscInt 0o323++degree          :: Num u => LRText u ()+degree          = symbEscInt 0o260++diamond         :: Num u => LRText u ()+diamond         = symbEscInt 0o250++divide          :: Num u => LRText u ()+divide          = symbEscInt 0o270++dotmath         :: Num u => LRText u ()+dotmath         = symbEscInt 0o327++eight           :: Num u => LRText u ()+eight           = symbEscInt 0o070++element         :: Num u => LRText u ()+element         = symbEscInt 0o316++ellipsis        :: Num u => LRText u ()+ellipsis        = symbEscInt 0o274++emptyset        :: Num u => LRText u ()+emptyset        = symbEscInt 0o306++equal           :: Num u => LRText u ()+equal           = symbEscInt 0o075++equivalence     :: Num u => LRText u ()+equivalence     = symbEscInt 0o272++exclam          :: Num u => LRText u ()+exclam          = symbEscInt 0o041++existential     :: Num u => LRText u ()+existential     = symbEscInt 0o044++five            :: Num u => LRText u ()+five            = symbEscInt 0o065++florin          :: Num u => LRText u ()+florin          = symbEscInt 0o246++four            :: Num u => LRText u ()+four            = symbEscInt 0o064++fraction        :: Num u => LRText u ()+fraction        = symbEscInt 0o244++gradient        :: Num u => LRText u ()+gradient        = symbEscInt 0o321++greater         :: Num u => LRText u ()+greater         = symbEscInt 0o076++greaterequal    :: Num u => LRText u ()+greaterequal    = symbEscInt 0o263++heart           :: Num u => LRText u ()+heart           = symbEscInt 0o251++infinity        :: Num u => LRText u ()+infinity        = symbEscInt 0o245++integral        :: Num u => LRText u ()+integral        = symbEscInt 0o362++intersection    :: Num u => LRText u ()+intersection    = symbEscInt 0o307++less            :: Num u => LRText u ()+less            = symbEscInt 0o074++lessequal       :: Num u => LRText u ()+lessequal       = symbEscInt 0o243++logicaland      :: Num u => LRText u ()+logicaland      = symbEscInt 0o331++logicalnot      :: Num u => LRText u ()+logicalnot      = symbEscInt 0o330++logicalor       :: Num u => LRText u ()+logicalor       = symbEscInt 0o332++lozenge         :: Num u => LRText u ()+lozenge         = symbEscInt 0o340++minus           :: Num u => LRText u ()+minus           = symbEscInt 0o055++minute          :: Num u => LRText u ()+minute          = symbEscInt 0o242++multiply        :: Num u => LRText u ()+multiply        = symbEscInt 0o264++nine            :: Num u => LRText u ()+nine            = symbEscInt 0o071++notelement      :: Num u => LRText u ()+notelement      = symbEscInt 0o317++notequal        :: Num u => LRText u ()+notequal        = symbEscInt 0o271++notsubset       :: Num u => LRText u ()+notsubset       = symbEscInt 0o313++numbersign      :: Num u => LRText u ()+numbersign      = symbEscInt 0o043++omega1          :: Num u => LRText u ()+omega1          = symbEscInt 0o166++omicron         :: Num u => LRText u ()+omicron         = symbEscInt 0o157++one             :: Num u => LRText u ()+one             = symbEscInt 0o061++parenleft       :: Num u => LRText u ()+parenleft       = symbEscInt 0o050++parenright      :: Num u => LRText u ()+parenright      = symbEscInt 0o051++partialdiff     :: Num u => LRText u ()+partialdiff     = symbEscInt 0o266++percent         :: Num u => LRText u ()+percent         = symbEscInt 0o045++period          :: Num u => LRText u ()+period          = symbEscInt 0o056++perpendicular   :: Num u => LRText u ()+perpendicular   = symbEscInt 0o136++phi1            :: Num u => LRText u ()+phi1            = symbEscInt 0o152++plus            :: Num u => LRText u ()+plus            = symbEscInt 0o053++plusminus       :: Num u => LRText u ()+plusminus       = symbEscInt 0o261++product         :: Num u => LRText u ()+product         = symbEscInt 0o325++propersubset    :: Num u => LRText u ()+propersubset    = symbEscInt 0o314++propersuperset  :: Num u => LRText u ()+propersuperset  = symbEscInt 0o311++proportional    :: Num u => LRText u ()+proportional    = symbEscInt 0o265++question        :: Num u => LRText u ()+question        = symbEscInt 0o077++radical         :: Num u => LRText u ()+radical         = symbEscInt 0o326++radicalex       :: Num u => LRText u ()+radicalex       = symbEscInt 0o140++reflexsubset    :: Num u => LRText u ()+reflexsubset    = symbEscInt 0o315++reflexsuperset  :: Num u => LRText u ()+reflexsuperset  = symbEscInt 0o312++registersans    :: Num u => LRText u ()+registersans    = symbEscInt 0o342++registerserif   :: Num u => LRText u ()+registerserif   = symbEscInt 0o322++second          :: Num u => LRText u ()+second          = symbEscInt 0o262++semicolon       :: Num u => LRText u ()+semicolon       = symbEscInt 0o073++seven           :: Num u => LRText u ()+seven           = symbEscInt 0o067++sigma1          :: Num u => LRText u ()+sigma1          = symbEscInt 0o126++similar         :: Num u => LRText u ()+similar         = symbEscInt 0o176++six             :: Num u => LRText u ()+six             = symbEscInt 0o066++slash           :: Num u => LRText u ()+slash           = symbEscInt 0o057++space           :: Num u => LRText u ()+space           = symbEscInt 0o040++spade           :: Num u => LRText u ()+spade           = symbEscInt 0o252++suchthat        :: Num u => LRText u ()+suchthat        = symbEscInt 0o047++summation       :: Num u => LRText u ()+summation       = symbEscInt 0o345++therefore       :: Num u => LRText u ()+therefore       = symbEscInt 0o134++theta1          :: Num u => LRText u ()+theta1          = symbEscInt 0o112++three           :: Num u => LRText u ()+three           = symbEscInt 0o063++trademarksans   :: Num u => LRText u ()+trademarksans   = symbEscInt 0o344++trademarkserif  :: Num u => LRText u ()+trademarkserif  = symbEscInt 0o324++two             :: Num u => LRText u ()+two             = symbEscInt 0o062++underscore      :: Num u => LRText u ()+underscore      = symbEscInt 0o137++union           :: Num u => LRText u ()+union           = symbEscInt 0o310++universal       :: Num u => LRText u ()+universal       = symbEscInt 0o042++weierstrass     :: Num u => LRText u ()+weierstrass     = symbEscInt 0o303++zero            :: Num u => LRText u ()+zero            = symbEscInt 0o060++

@@ -18,8 +18,8 @@ -- expected that kerning will need to be added per-letter for -- variable width fonts. ----- This module makes precise text spacing \*possible\* - it does --- not make it \*easy\*.+-- This module makes precise horizontal text spacing \*possible\*, +-- it does not make it \*easy\*. --  -------------------------------------------------------------------------------- @@ -27,15 +27,18 @@   (   -    TextM-  , runTextM-  , execTextM+    LRText +  , runLRText+  , execLRText+   , kern   , char+  , escInt+  , escName   , symb-  , symbi   , symbEscInt+  , symbEscName    ) where @@ -47,7 +50,6 @@  import Control.Applicative import Control.Monad-import Data.Char ( chr ) import Data.Monoid  @@ -59,9 +61,8 @@ -- Note - if we have font change (e.g. to symbol font) then we  -- have to generate more than one hkernline. -- --- If one wants to be really prissy about optimization, one could--- generate two simultaneous and overlayed lines - one in regular --- font, one in Symbol. +-- Apropos /optimization/ we have two two simultaneous and +-- overlayed lines - one in the regular font, and one in Symbol.  -- -- Result should be a LocGraphic (so cannot do a trace as we go).  --@@ -92,106 +93,109 @@ -- can take the initial font size, stroke colour etc. -- -newtype TextM u a = TextM { getTextM :: Env u -> St u -> (a, St u) }+newtype LRText u a = LRText { getLRText :: Env u -> St u -> (a, St u) } -type instance MonUnit (TextM u) = u+type instance MonUnit (LRText u) = u -instance Functor (TextM u) where-  fmap f mf = TextM $ \r s -> let (a,s') = getTextM mf r s in (f a,s')+instance Functor (LRText u) where+  fmap f mf = LRText $ \r s -> let (a,s') = getLRText mf r s in (f a,s')  -instance Applicative (TextM u) where-  pure a    = TextM $ \_ s -> (a,s)-  mf <*> ma = TextM $ \r s -> let (f,s')  = getTextM mf r s-                                  (a,s'') = getTextM ma r s'-                              in (f a,s'')+instance Applicative (LRText u) where+  pure a    = LRText $ \_ s -> (a,s)+  mf <*> ma = LRText $ \r s -> let (f,s')  = getLRText mf r s+                                   (a,s'') = getLRText ma r s'+                               in (f a,s'') -instance Monad (TextM u) where-  return a  = TextM $ \_ s -> (a,s)-  m >>= k   = TextM $ \r s -> let (a,s')  = getTextM m r s -                              in (getTextM . k) a r s'+instance Monad (LRText u) where+  return a  = LRText $ \_ s -> (a,s)+  m >>= k   = LRText $ \r s -> let (a,s')  = getLRText m r s +                               in (getLRText . k) a r s' -                              --- Note - post has to displace in the vertical to get the bottom --- line at the base line... -runTextM :: (Num u, FromPtSize u, DrawingCtxM m, u ~ MonUnit m) -         => TextM u a -> m (a, LocGraphic u)-runTextM ma = askCtx >>= \ctx -> -    let e = runDF ctx envZero in post $ getTextM ma e stZero-  where-    post (a,st)  = let sG = updCtxSym $ mkHKern $ toListH $ acc_sym st-                       cG = mkHKern $ toListH $ acc_chr st-                   in return (a, sG `lgappend` cG) -    mkHKern []   = const mempty-    mkHKern xs   = hkernline xs -    updCtxSym lg = localLG (fontface symbol) lg+runLRText :: (Num u, FromPtSize u) => LRText u a -> LocImage u a+runLRText ma = \pt -> envZero >>= \e1 -> +                   let (a,st) = getLRText ma e1 st_zero +                   in mkline pt (acc_chr st) >>= \g1 ->+                      localDF (fontface symbol) (mkline pt (acc_sym st)) >>= \g2 ->+                      return (a,g1 `mappend` g2)+  where+    mkline pt h = case toListH h of+                   [] -> return mempty+                   xs -> hkernline xs pt  -execTextM :: (Num u, FromPtSize u, DrawingCtxM m, u ~ MonUnit m) -          => TextM u a -> m (LocGraphic u)-execTextM ma = liftM snd $ runTextM ma  -+execLRText :: (Num u, FromPtSize u) => LRText u a -> LocGraphic u+execLRText ma = \pt -> liftM snd (runLRText ma pt)  -stZero :: Num u => St u-stZero = St { delta_chr       = 0-            , delta_sym       = 0-            , acc_chr         = emptyH-            , acc_sym         = emptyH }+st_zero :: Num u => St u+st_zero = St { delta_chr       = 0+             , delta_sym       = 0+             , acc_chr         = emptyH+             , acc_sym         = emptyH }+   envZero :: FromPtSize u => DrawingF (Env u) envZero = (\sz -> Env { char_width   = fromPtSize $ charWidth sz                       , spacer_width = fromPtSize $ spacerWidth sz })-            <$> asksDF (font_size . font_props)+            <$> fontSize  -gets :: (St u -> a) -> TextM u a-gets fn = TextM $ \_ s -> (fn s, s)+gets :: (St u -> a) -> LRText u a+gets fn = LRText $ \_ s -> (fn s, s) -charMove :: Num u => TextM u ()-charMove = TextM $ \(Env {char_width=cw, spacer_width=sw}) s -> +charMove :: Num u => LRText u ()+charMove = LRText $ \(Env {char_width=cw, spacer_width=sw}) s ->               let step_width = cw + sw                      d_sym      = (delta_sym s) + step_width              in ((), s { delta_chr = step_width, delta_sym = d_sym })  -symbMove :: Num u => TextM u ()-symbMove = TextM $ \(Env {char_width=cw, spacer_width=sw}) s -> +symbMove :: Num u => LRText u ()+symbMove = LRText $ \(Env {char_width=cw, spacer_width=sw}) s ->               let step_width = cw + sw                  d_chr      = (delta_chr s) + step_width              in ((), s { delta_chr = d_chr, delta_sym = step_width })  -snocSymb :: KerningChar u -> TextM u ()-snocSymb kc = TextM $ \_ s -> ((), upd s)+snocSymb :: KerningChar u -> LRText u ()+snocSymb kc = LRText $ \_ s -> ((), upd s)   where     upd = (\s a -> s { acc_sym = a `snocH` kc}) <*> acc_sym -snocChar :: KerningChar u -> TextM u ()-snocChar kc = TextM $ \_ s -> ((), upd s)+snocChar :: KerningChar u -> LRText u ()+snocChar kc = LRText $ \_ s -> ((), upd s)   where     upd = (\s a -> s { acc_chr = a `snocH` kc}) <*> acc_chr -kern :: Num u => u -> TextM u ()-kern dx = TextM $ \_ s -> ((), upd s)+kern :: Num u => u -> LRText u ()+kern dx = LRText $ \_ s -> ((), upd s)   where     upd = (\s a b -> s { delta_chr = a+dx, delta_sym = b+dx})              <*> delta_chr <*> delta_sym -char :: Num u => Char -> TextM u ()+char :: Num u => Char -> LRText u () char ch = gets delta_chr           >>= \u ->            snocChar (kernchar u ch) >> charMove -symb :: Num u => Char -> TextM u ()-symb sy = gets delta_sym           >>= \u -> -          snocSymb (kernchar u sy) >> symbMove+escInt ::  Num u => Int -> LRText u ()+escInt i = gets delta_chr            >>= \u -> +           snocChar (kernEscInt u i) >> charMove +escName ::  Num u => String -> LRText u ()+escName s = gets delta_chr             >>= \u -> +            snocChar (kernEscName u s) >> charMove -symbi :: Num u => Int -> TextM u ()-symbi i = symb (chr i)  +symb :: Num u => Char -> LRText u ()+symb sy = gets delta_sym           >>= \u -> +          snocSymb (kernchar u sy) >> symbMove -symbEscInt :: Num u => Int -> TextM u ()++symbEscInt :: Num u => Int -> LRText u () symbEscInt i = gets delta_sym            >>= \u ->                 snocSymb (kernEscInt u i) >> symbMove +symbEscName :: Num u => String -> LRText u ()+symbEscName s = gets delta_sym             >>= \u -> +                snocSymb (kernEscName u s) >> symbMove

@@ -81,8 +81,9 @@ -- findIntersect :: (Floating u, Real u, Ord u)                => Point2 u -> Radian -> [LineSegment u] -> Maybe (Point2 u)-findIntersect ctr theta = step +findIntersect ctr ang0 = step    where+    theta       = circularModulo ang0     eqn         = toLineEqn $ pointSlope ctr theta     step []     = Nothing     step (x:xs) = case intersection x eqn of 

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

@@ -1,5 +1,5 @@ name:             wumpus-basic-version:          0.8.0+version:          0.9.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -21,6 +21,37 @@   .   Changelog:   .+  0.8.0 to 0.9.0:+  .+  * Re-worked @Basic.Text.LRSymbol@ changed the type name and the+    types of the run functions. Added more symbols and a new demo +    @Symbols.hs@.+  .+  * @ScalingContext@ added to @Basic.Graphic@. Changed +    @monoTextWidth@ to take a character count, the old behaviour +    is recreated by the new function @monoTextLength@. +  .+  * @Basic.Graphic.Chain@ removed. It is now superseded by+    @Basic.Chains@.+  .+  * Added new property to @DrawingContext@ for line spacing +    scaling factor, and added a new drawing primitive +    @textlineMulti@ for multi-line, left justified labels.+  .+  * Synthezied attribute /getters/ such as @textDimensions@ moved+    from @Basic.Graphic.DrawingContext@ to the new module+    @Basic.Graphic.Query@. The type of all the functions has +    changed to DrawingF. @lowerxHeight@ is renamed +    @monoLowerxHeight@ emphasizing that the metrics pertain to+    monospaced Courier font.+  .+  * Added Shapes modules.+  . +  * TurtleMonad module - the TurtleDrawing type and run functions+    have been removed and the internals have been reworked. +    Turtle is now run solely as a /local effect/ within the +    Drawing monad. +  .   0.7.0 to 0.8.0:   .   * Re-introduced LRText and LRSymbol - they now work with @@ -53,23 +84,29 @@   CHANGES,   LICENSE,   demo/DotPic.hs,+  demo/ClipPic.hs,   demo/ColourCharts.hs,   demo/ColourDefns.hs,   demo/FontPic.hs,-  demo/Picture.hs+  demo/Picture.hs,+  demo/Shapes.hs,+  demo/Symbols.hs  library   hs-source-dirs:     src   build-depends:      base            <  5,                        containers      >= 0.3     && <= 0.4,                        vector-space    >= 0.6,-                      wumpus-core     == 0.33.0+                      wumpus-core     == 0.34.0       exposed-modules:     Wumpus.Basic.Anchors,     Wumpus.Basic.Arrows,     Wumpus.Basic.Arrows.Tips,+    Wumpus.Basic.Chains,+    Wumpus.Basic.Chains.Base,+    Wumpus.Basic.Chains.Derived,     Wumpus.Basic.Colour.SVGColours,     Wumpus.Basic.Colour.X11Colours,     Wumpus.Basic.Dots,@@ -77,16 +114,20 @@     Wumpus.Basic.Graphic,     Wumpus.Basic.Graphic.BaseClasses,     Wumpus.Basic.Graphic.BaseTypes,-    Wumpus.Basic.Graphic.Chain,     Wumpus.Basic.Graphic.Drawing,     Wumpus.Basic.Graphic.DrawingContext,     Wumpus.Basic.Graphic.PrimGraphic,+    Wumpus.Basic.Graphic.Query,+    Wumpus.Basic.Graphic.ScalingContext,     Wumpus.Basic.Monads.TurtleClass,     Wumpus.Basic.Monads.TurtleMonad,     Wumpus.Basic.Paths,     Wumpus.Basic.Paths.Base,+    Wumpus.Basic.Paths.Connectors,     Wumpus.Basic.Paths.Construction,     Wumpus.Basic.SafeFonts,+    Wumpus.Basic.Shapes.Base,+    Wumpus.Basic.Shapes.Derived,     Wumpus.Basic.Text.LRSymbol,     Wumpus.Basic.Text.LRText,     Wumpus.Basic.Utils.HList,