wumpus-basic 0.6.0 → 0.7.0

raw patch · 32 files changed

+1661/−1889 lines, 32 filesdep ~wumpus-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: wumpus-core

API changes (from Hackage documentation)

Files

• demo/ColourCharts.hs +31/−59
• demo/DotPic.hs +14/−11
• demo/FontPic.hs +3/−3
• demo/Picture.hs +15/−12
• src/Wumpus/Basic/Arrows.hs +87/−81
• src/Wumpus/Basic/Arrows/Tips.hs +43/−44
• src/Wumpus/Basic/Dots.hs +107/−35
• src/Wumpus/Basic/Dots/Base.hs +0/−201
• src/Wumpus/Basic/Dots/Primitive.hs +231/−0
• src/Wumpus/Basic/Graphic.hs +13/−8
• src/Wumpus/Basic/Graphic/BaseClasses.hs +72/−0
• src/Wumpus/Basic/Graphic/BaseTypes.hs +246/−0
• src/Wumpus/Basic/Graphic/Chain.hs +87/−0
• src/Wumpus/Basic/Graphic/Drawing.hs +233/−0
• src/Wumpus/Basic/Graphic/DrawingAttr.hs +0/−135
• src/Wumpus/Basic/Graphic/DrawingContext.hs +180/−0
• src/Wumpus/Basic/Graphic/PointSupply.hs +0/−109
• src/Wumpus/Basic/Graphic/PrimGraphic.hs +233/−0
• src/Wumpus/Basic/Graphic/Primitive.hs +0/−297
• src/Wumpus/Basic/Monads/Drawing.hs +0/−158
• src/Wumpus/Basic/Monads/DrawingCtxClass.hs +0/−41
• src/Wumpus/Basic/Monads/DrawingMonad.hs +0/−133
• src/Wumpus/Basic/Monads/TraceClass.hs +0/−33
• src/Wumpus/Basic/Monads/TurtleMonad.hs +27/−51
• src/Wumpus/Basic/Paths.hs +2/−4
• src/Wumpus/Basic/Paths/Base.hs +4/−1
• src/Wumpus/Basic/Text/LRSymbol.hs +0/−203
• src/Wumpus/Basic/Text/LRText.hs +0/−192
• src/Wumpus/Basic/Utils/Combinators.hs +0/−60
• src/Wumpus/Basic/Utils/HList.hs +1/−0
• src/Wumpus/Basic/VersionNumber.hs +2/−2
• wumpus-basic.cabal +30/−16

@@ -1,87 +1,59 @@ {-# OPTIONS -Wall #-} -module ColourCharts where+module ColourChart where  import ColourDefns -import Wumpus.Core-import Wumpus.Basic.Colour.SVGColours ( black ) import Wumpus.Basic.Graphic-import Wumpus.Basic.SafeFonts-import Wumpus.Basic.Utils.HList -import Data.AffineSpace--import Data.List-import Data.Maybe+import Wumpus.Core                              -- package: wumpus-core  import System.Directory + main :: IO ()-main = do-   createDirectoryIfMissing True "./out/"-   test01- -test01 :: IO ()-test01 = do +main = do +    createDirectoryIfMissing True "./out/"     writeEPS_latin1 "./out/SVGcolours.eps" svg     writeSVG_latin1 "./out/SVGcolours.svg" svg     writeEPS_latin1 "./out/X11colours.eps" $ uniformScale 0.75 x11_portrait     writeSVG_latin1 "./out/X11colours.svg" x11_landscape  svg :: Picture Double-svg = mkPic all_svg_colours (ixDownLeftRight 4 60 (scalePt 160))+svg = makePicture 60 160 all_svg_colours  x11_landscape :: Picture Double-x11_landscape = mkPic all_x11_colours (ixDownLeftRight 6 60 (scalePt 140))+x11_landscape = makePicture 60 140 all_x11_colours  x11_portrait :: Picture Double-x11_portrait = mkPic all_x11_colours (ixDownLeftRight 5 72 (scalePt 140))-    ---- Note - this is code from an old project that needs tidying up...--mkPic :: [(String,RGBi)] -> [DPoint2] -> DPicture -mkPic cs pts = fromMaybe errK $ -                 drawGraphic $ concatH $ zipWith colourSample cs pts-  where-    errK = error "Empty Picture"--scalePt :: Num u => u -> Point2 u -> Point2 u-scalePt w (P2 x y) = P2 (x*w) (y*12) --colourSample :: (Fractional u, Floating u, Ord u) -             => (String,RGBi) -> GraphicF u-colourSample (name,rgb) = block `cc` lbl -  where-    block = filledRectangle rgb  15 10-    lbl   = textline black (FontAttr 10 courier) name . (.+^ hvec 18)+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  -------------------------------- | Generate points in a grid - move down a whole column, move --- right one, move down the next column.--- --- Points are generated from count-1 to 0, but can be scaled --- or have the offest shifted with the point transformer function.+-- Note - cannot use node twice as it increments the point supply. ---ixDownLeftRight :: (Num u)-                => Int -> Int -> (Point2 u -> Point2 u) -> [Point2 u]-ixDownLeftRight row_count col_count fn = -    [fn $ P2 x y | x <- countup   (row_count - 1)-                 , y <- countdown (col_count - 1) ]+colourSample :: String -> RGBi -> ChainT Double (Drawing Double) ()+colourSample name rgb = localCtx (secondaryColour rgb) $ do +    { pt <- position +    ; drawAt pt (borderedRectangle 15 10)+    ; drawAt (displace 20 2 pt) (textline name)+    }      --- | Countdown from n to 0.-countdown :: Num u => Int -> [u]-countdown = unfoldr phi where-   phi i | i < 0 = Nothing-   phi i         = Just (fromIntegral i,i-1) --- | Count up to n from 0. -countup :: Num u => Int -> [u]-countup n = unfoldr phi 0 where-   phi i | i > n = Nothing-   phi i         = Just (fromIntegral i,i+1)+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)   +

@@ -4,11 +4,9 @@   import Wumpus.Basic.Colour.SVGColours-import Wumpus.Basic.Dots.Base+import Wumpus.Basic.Dots import Wumpus.Basic.Graphic-import Wumpus.Basic.Graphic.DrawingAttr import Wumpus.Basic.PictureLanguage-import Wumpus.Basic.Utils.HList  import Wumpus.Core                      -- package: wumpus-core @@ -52,22 +50,27 @@     p16 = makeDotPic dotFDiamond    points     p17 = makeDotPic (dotText "AA") points  -std_attr :: DrawingAttr-std_attr = standardAttr 12+std_ctx :: DrawingContext+std_ctx = secondaryColour peru $ standardContext 12  points :: [Point2 Double] points = [P2 0 0, P2 32 10, P2 64 0, P2 96 10] ++-- Note - order of drawing is may need to change with future+-- revisions.+-- makeDotPic :: (Real u, Floating u, FromPtSize u) -           => (DrawingAttr -> GraphicF u) -> [Point2 u] -> Picture u-makeDotPic fn xs = drawGraphicU $ veloH (fn std_attr) xs . dashline+           => DotLocImage u -> [Point2 u] -> Picture u+makeDotPic dotImg xs = liftToPictureU $ execDrawing std_ctx $ do +    dashline+    mapM_ (\pt -> drawAtImg pt dotImg) xs   where-    dashline = wrapG $ ostroke cadet_blue attr $ vertexPath xs-    attr     = default_stroke_attr { dash_pattern = evenDashes 1 }+    dashline = localCtx attrUpd (draw $ openStroke $ vertexPath xs) +    attrUpd  :: DrawingContext -> DrawingContext+    attrUpd  =  dashPattern (evenDashes 1) . primaryColour cadet_blue -errK :: a-errK = error "no picture"   

@@ -29,15 +29,15 @@     writeSVG_latin1 "./out/font_symbol.svg"    symbol_pic  -makeFontLabel :: RGBi -> FontAttr -> DPoint2 -> DPrimitive+makeFontLabel :: RGBi -> FontAttr -> DPoint2 -> DPrimElement makeFontLabel rgb fa = textlabel rgb fa msg   where     msg = unwords [ font_name $ font_face fa, (show $ font_size fa) ++ "pt"] -blueLabel :: FontFace -> Int -> DPoint2 -> DPrimitive+blueLabel :: FontFace -> Int -> DPoint2 -> DPrimElement blueLabel ff i = makeFontLabel steel_blue (FontAttr i ff) -redLabel :: FontFace -> Int -> DPoint2 -> DPrimitive+redLabel :: FontFace -> Int -> DPoint2 -> DPrimElement redLabel ff i = makeFontLabel indian_red1 (FontAttr i ff)  

@@ -5,7 +5,6 @@ import Wumpus.Basic.Colour.SVGColours import Wumpus.Basic.Graphic import Wumpus.Basic.PictureLanguage-import Wumpus.Basic.SafeFonts  import Wumpus.Core                              -- package: wumpus-core @@ -124,25 +123,29 @@  -------------------------------------------------------------------------------- +pic_drawing_ctx :: DrawingContext+pic_drawing_ctx = standardContext 14+ picAnno :: DPicture -> String -> DPicture picAnno pic msg = alignHSep HCenter 30 pic lbl   where-    lbl = drawGraphicU $ supply (P2 0 0) $ -            textline black (FontAttr 14 courier) msg+    lbl = liftToPictureU $ execDrawing pic_drawing_ctx $ +            drawAt zeroPt (textline msg)   rect_red :: DPicture-rect_red = drawGraphicU $ supply (P2 0 10) $ -          strokedRectangle black zeroSA 30 10 `cc` filledRectangle indian_red 30 10-+rect_red = liftToPictureU $ execDrawing pic_drawing_ctx $ +              localCtx (secondaryColour indian_red)+                       (drawAt (P2 0 10) $ borderedRectangle 30 10)+                  rect_green :: DPicture-rect_green = drawGraphicU $ supply (P2 10 10) $ -    strokedRectangle black zeroSA 15 15 `cc` filledRectangle olive_drab 15 15+rect_green = liftToPictureU $ execDrawing pic_drawing_ctx $ +              localCtx (secondaryColour olive_drab)+                       (drawAt (P2 10 10) $ borderedRectangle 15 15)   rect_blue :: DPicture-rect_blue = drawGraphicU $ supply (P2 10 0) $ -    strokedRectangle black zeroSA 20 30 `cc` filledRectangle powder_blue 20 30+rect_blue = liftToPictureU $ execDrawing pic_drawing_ctx $ +              localCtx (secondaryColour powder_blue)+                       (drawAt (P2 10 0) $ borderedRectangle 20 30) -zeroSA :: StrokeAttr-zeroSA = default_stroke_attr

@@ -21,6 +21,7 @@   (      line +   , arrowTri90   , arrowTri60   , arrowTri45@@ -38,124 +39,129 @@  import Wumpus.Basic.Arrows.Tips import Wumpus.Basic.Graphic-import Wumpus.Basic.Graphic.DrawingAttr-import Wumpus.Basic.Monads.Drawing import Wumpus.Basic.Paths import Wumpus.Basic.Paths.Base import Wumpus.Basic.Utils.Intersection ( langle )  import Wumpus.Core                      -- package: wumpus-core +import Control.Applicative  +liftPathF :: PathF u -> ConnDrawingObject u (Path u)+liftPathF pF p1 p2 = DrawingObject $ \ _ -> pF p1 p2 -arrowWidth :: FromPtSize u => DrawingAttr -> u -arrowWidth = fromPtSize . xcharHeight . font_size . font_props+line :: Num u => PathF u -> ConnImage u (Path u)+line pathF = intoConnImage (liftPathF pathF) (pathGraphic pathF)  -line :: Num u => PathF u -> AConnector u (Path u)-line pathF p0 p1 = AGraphic df mf+-- Here the path is already shortened - we have accounted for the+-- points already, so it is just a graphic. +lineTipR :: Num u => Path u -> Graphic u -> Graphic u+lineTipR bpath tip = openStroke (toPrimPathU bpath) `appendGraphic` tip+   ++++-- | Returns two items:+-- +-- 1. Shorten the line by the line width - this stops the path+-- tip puncturing the arrow head (particulary visible on open +-- triangle tips).+-- +-- 2. Calculate the direction back along the line at half the +-- lower_x_height - this gets a good angle for the tip on curved+-- path segments.+--+rightPathProps :: (Real u, Floating u, FromPtSize u) +               => PathF u -> ConnDrawingObject u (Path u,Radian)+rightPathProps pathF p1 p2 = +    (\h sw -> (shortenPath h sw, calcTheta h))+      <$> asksObj lowerxHeight <*> asksObj (line_width . stroke_props)     where-    df attr () = pathGraphic (pathF p0 p1) attr-    mf _    () = pathF p0 p1+    long_path          = pathF p1 p2  +    shortenPath lxh sw = shortenR (lxh + (realToFrac sw)) long_path +    calcTheta lxh      = directionR $ shortenR (0.5*lxh) long_path    +triTipRight :: (Real u, Floating u, FromPtSize u) +            => PathF u -> (Radian -> LocGraphic u) -> ConnImage u (Path u) +triTipRight pathF tipF p1 p2 =+    rightPathProps pathF p1 p2          >>= \(shortF,theta) -> +    lineTipR shortF (tipF theta p2)     >>= \arrow_pic      ->+    return (pathF p1 p2, arrow_pic)+++++-- This version does not /retract/ the path...+--+barbTipRight :: (Real u, Floating u, FromPtSize u) +             => PathF u -> (Radian -> LocGraphic u) -> ConnImage u (Path u)  +barbTipRight pathF tipF p1 p2 = +    rightPathProps pathF p1 p2          >>= \(_,theta) -> +    lineTipR path_zero (tipF theta p2)  >>= \arrow_pic  ->+    return (path_zero, arrow_pic)+  where+    path_zero = pathF p1 p2+++ arrowTri90 :: (Real u, Floating u, FromPtSize u) -           => PathF u -> AConnector u (Path u)-arrowTri90 pathF = \p0 p1 -> -    AGraphic (\attr () -> triTipRight pathF tri90 p0 p1 attr) -             (\_    () -> pathF p0 p1)+           => PathF u -> ConnImage u (Path u)+arrowTri90 pathF = triTipRight pathF tri90+ +           + arrowTri60 :: (Real u, Floating u, FromPtSize u) -           => PathF u -> AConnector u (Path u)-arrowTri60 pathF = \p0 p1 ->-    AGraphic (\attr () -> triTipRight pathF tri60 p0 p1 attr) -             (\_    () -> pathF p0 p1)+           => PathF u -> ConnImage u (Path u)+arrowTri60 pathF = triTipRight pathF tri60+   arrowTri45 :: (Real u, Floating u, FromPtSize u) -           => PathF u -> AConnector u (Path u)-arrowTri45 pathF = \p0 p1 ->-    AGraphic (\attr () -> triTipRight pathF tri45 p0 p1 attr) -             (\_    () -> pathF p0 p1)+           => PathF u -> ConnImage u (Path u)+arrowTri45 pathF = triTipRight pathF tri45 + arrowOTri90 :: (Real u, Floating u, FromPtSize u) -            => PathF u -> AConnector u (Path u)-arrowOTri90 pathF = \p0 p1 ->-    AGraphic (\attr () -> triTipRight pathF otri90 p0 p1 attr) -             (\_    () -> pathF p0 p1)+            => PathF u -> ConnImage u (Path u)+arrowOTri90 pathF = triTipRight pathF otri90+       arrowOTri60 :: (Real u, Floating u, FromPtSize u) -            => PathF u -> AConnector u (Path u)-arrowOTri60 pathF = \p0 p1 -> -    AGraphic (\attr () -> triTipRight pathF otri60 p0 p1 attr) -             (\_    () -> pathF p0 p1)+            => PathF u -> ConnImage u (Path u)+arrowOTri60 pathF = triTipRight pathF otri60   + arrowOTri45 :: (Real u, Floating u, FromPtSize u) -            => PathF u -> AConnector u (Path u)-arrowOTri45 pathF = \p0 p1 ->-    AGraphic (\attr () -> triTipRight pathF otri45 p0 p1 attr)-             (\_    () -> pathF p0 p1)+            => PathF u -> ConnImage u (Path u)+arrowOTri45 pathF = triTipRight pathF otri45  + arrowBarb90 :: (Real u, Floating u, FromPtSize u) -            => PathF u -> AConnector u (Path u)-arrowBarb90 pathF = \p0 p1 ->-    AGraphic (\attr () -> barbTipRight pathF barb90 p0 p1 attr)-             (\_    () -> pathF p0 p1)+            => PathF u -> ConnImage u (Path u)+arrowBarb90 pathF = barbTipRight pathF barb90  arrowBarb60 :: (Real u, Floating u, FromPtSize u) -            => PathF u -> AConnector u (Path u)-arrowBarb60 pathF = \p0 p1 ->-    AGraphic (\attr () -> barbTipRight pathF barb60 p0 p1 attr)-             (\_    () -> pathF p0 p1)+            => PathF u -> ConnImage u (Path u)+arrowBarb60 pathF = barbTipRight pathF barb60  arrowBarb45 :: (Real u, Floating u, FromPtSize u) -            => PathF u -> AConnector u (Path u)-arrowBarb45 pathF = \p0 p1 ->-    AGraphic (\attr () -> barbTipRight pathF barb45 p0 p1 attr)-             (\_    () -> pathF p0 p1)-+            => PathF u -> ConnImage u (Path u)+arrowBarb45 pathF = barbTipRight pathF barb45  -triTipRight :: (Real u, Floating u, FromPtSize u) -            => PathF u -            -> (Radian -> DrawingAttr -> GraphicF u)-            -> Point2 u -> Point2 u -> DrawingAttr -            -> Graphic u -triTipRight pathF tipF p0 p1 attr = -    pathGraphic short_path attr . tipF theta attr p1-  where-    sz              = arrowWidth attr-    line_unit       = realToFrac $ (line_width $ stroke_props attr)-    long_path       = pathF p0 p1-    short_path      = shortenR (sz+line_unit) long_path-    mid_short_path  = shortenR (0.5*sz) long_path-    theta           = directionR mid_short_path                      ---barbTipRight :: (Real u, Floating u, FromPtSize u) -             => PathF u -             -> (Radian -> DrawingAttr -> GraphicF u)-             -> Point2 u -> Point2 u -> DrawingAttr -             -> Graphic u -barbTipRight pathF tipF p0 p1 attr = -    pathGraphic long_path attr . tipF theta attr p1-  where-    sz              = arrowWidth attr-    long_path       = pathF p0 p1-    mid_short_path  = shortenR (0.5*sz) long_path-    theta           = directionR mid_short_path-                     - arrowPerp :: (Real u, Floating u, FromPtSize u) -          => PathF u -> AConnector u (Path u)-arrowPerp pathF p0 p1 = AGraphic df mf+          => PathF u -> ConnImage u (Path u)+arrowPerp pathF p1 p2 = +    lineTipR path_zero perp_tip >>= \arrow_pic -> return (path_zero, arrow_pic)   where-    df attr () = let theta = langle p0 p1  in-                 pathGraphic (pathF p0 p1) attr . perp theta attr p1-    mf _    () = pathF p0 p1-+    path_zero = pathF  p1 p2+    theta     = langle p1 p2+    perp_tip  = perp theta p2

@@ -20,6 +20,7 @@ module Wumpus.Basic.Arrows.Tips   (  +     tri90   , tri60   , tri45@@ -36,21 +37,25 @@   ) where  import Wumpus.Basic.Graphic-import Wumpus.Basic.Graphic.DrawingAttr  import Wumpus.Core                      -- package: wumpus-core  import Data.AffineSpace                 -- package: vector-space +import Control.Applicative -tripoints :: Floating u-          => Radian -> u -> Radian -> Point2 u -> (Point2 u, Point2 u)-tripoints triang xchar_height theta tip = (tip .-^ v1, tip .-^ v2)+-- | tripoints takes dimensions from the xlowerHeight.+--+tripoints :: (Floating u, FromPtSize u)+          => Radian -> Radian -> LocDrawingObject u (Point2 u, Point2 u)+tripoints triang theta tip = +    (\h -> let d = h / (fromRadian $ cos halfang) +           in (tip .-^ v1 d, tip .-^ v2 d))+      <$> asksObj lowerxHeight   where     halfang = 0.5 * triang-    d       = xchar_height / (fromRadian $ cos halfang)-    v1      = avec (theta + halfang) d-    v2      = avec (theta - halfang) d+    v1 d    = avec (theta + halfang) d+    v2 d    = avec (theta - halfang) d   @@ -59,73 +64,67 @@  triAng :: (Floating u, Real u, FromPtSize u)       => Radian -      -> (PrimPath u -> DrawingAttr -> Primitive u) -      -> Radian -> DrawingAttr -> GraphicF u-triAng ang fn theta attr pt = wrapG $ fn (vertexPath [pt,u,v]) attr-  where-    sz    = fromPtSize $ xcharHeight $ font_size $ font_props attr-    (u,v) = tripoints ang sz theta  pt+      -> Radian+      -> (PrimPath u -> Graphic u) +      -> LocGraphic u+triAng triang theta gf pt = +    tripoints triang theta pt >>= \(u,v) -> gf (vertexPath [pt,u,v])  --- The arg order should be:--- Radian -> DrawingAttr -> GraphicF u --- as DrawingAttr is a 'static' arg.+-- TODO - maybe filling needs to use swapColours  tri90 :: (Floating u, Real u, FromPtSize u)-      => Radian -> DrawingAttr -> GraphicF u-tri90 = triAng (pi/2) (\p a -> fill (stroke_colour a) p)+      => Radian -> LocGraphic u+tri90 theta = triAng (pi/2) theta filledPath   tri60 :: (Floating u, Real u, FromPtSize u)-      => Radian -> DrawingAttr -> GraphicF u-tri60 = triAng (pi/3) (\p a -> fill (stroke_colour a) p)+      => Radian -> LocGraphic u+tri60 theta = triAng (pi/3) theta filledPath + tri45 :: (Floating u, Real u, FromPtSize u)-      => Radian -> DrawingAttr -> GraphicF u-tri45 = triAng (pi/4) (\p a -> fill (stroke_colour a) p)+      => Radian -> LocGraphic u+tri45 theta = triAng (pi/4) theta filledPath   otri90 :: (Floating u, Real u, FromPtSize u)-      => Radian -> DrawingAttr -> GraphicF u-otri90 = triAng (pi/2) (\p a -> cstroke (stroke_colour a) (stroke_props a) p)+      => Radian -> LocGraphic u+otri90 theta = triAng (pi/2) theta closedStroke + otri60 :: (Floating u, Real u, FromPtSize u)-      => Radian -> DrawingAttr -> GraphicF u-otri60 = triAng (pi/3) (\p a -> cstroke (stroke_colour a) (stroke_props a) p)+      => Radian -> LocGraphic u+otri60 theta = triAng (pi/3) theta closedStroke  otri45 :: (Floating u, Real u, FromPtSize u)-      => Radian -> DrawingAttr -> GraphicF u-otri45 = triAng (pi/4) (\p a -> cstroke (stroke_colour a) (stroke_props a) p)-+      => Radian -> LocGraphic u+otri45 theta = triAng (pi/4) theta closedStroke  barbAng :: (Floating u, Real u, FromPtSize u)-      => Radian -> Radian -> DrawingAttr -> GraphicF u-barbAng ang theta attr pt = -    wrapG $ ostroke (stroke_colour attr) (stroke_props attr) $ vertexPath [u,pt,v]-  where-    sz    = fromPtSize $ xcharHeight $ font_size $ font_props attr-    (u,v) = tripoints ang sz theta  pt+      => Radian -> Radian -> LocGraphic u+barbAng ang theta pt = +    tripoints ang theta pt >>= \(u,v) -> openStroke (vertexPath [u,pt,v])   barb90 :: (Floating u, Real u, FromPtSize u) -       => Radian -> DrawingAttr -> GraphicF u+       => Radian -> LocGraphic u barb90 = barbAng (pi/2)  barb60 :: (Floating u, Real u, FromPtSize u) -       => Radian -> DrawingAttr -> GraphicF u+       => Radian -> LocGraphic u barb60 = barbAng (pi/3)  barb45 :: (Floating u, Real u, FromPtSize u) -       => Radian -> DrawingAttr -> GraphicF u+       => Radian -> LocGraphic u barb45 = barbAng (pi/4)   -perp :: (Floating u, FromPtSize u) => Radian -> DrawingAttr -> GraphicF u-perp theta attr = \pt -> -    wrapG $ ostroke (stroke_colour attr) (stroke_props attr) -          $ vertexPath [ pt .+^ v, pt .-^ v]+perp :: (Floating u, FromPtSize u) => Radian -> LocGraphic u+perp theta pt =  +    asksObj lowerxHeight >>= \ h -> +    let v = makeV h in openStroke $ vertexPath [ pt .+^ v, pt .-^ v]   where-    half_sz = 0.5 * (fromPtSize $ xcharHeight $ font_size $ font_props attr)-    v       = avec (theta + pi/2) half_sz+    makeV h  = avec (theta + pi/2) (0.5 * h)

@@ -15,6 +15,10 @@ -- -- Dots with anchors. --+-- In many cases a surrounding circle is used to locate anchor+-- points - this could be improved to use the actual dot border +-- at some point.+-- --------------------------------------------------------------------------------  module Wumpus.Basic.Dots@@ -22,26 +26,44 @@    -- * Existential anchor type     DotAnchor+ +  , DotLocImage+  , DDotLocImage    -- * Dots with anchor points-  , dotCircle-  , dotDisk-  , dotSquare   , dotChar   , dotText+  , dotHLine+  , dotVLine+  , dotX+  , dotPlus+  , dotCross+  , dotDiamond+  , dotFDiamond +  , dotDisk+  , dotSquare+  , dotCircle+  , dotPentagon+  , dotStar++  , dotAsterisk+  , dotOPlus+  , dotOCross+  , dotFOCross+   ) where  import Wumpus.Basic.Anchors-import qualified Wumpus.Basic.Dots.Base         as BD-import Wumpus.Basic.Graphic.DrawingAttr-import Wumpus.Basic.Monads.Drawing+import Wumpus.Basic.Dots.Primitive+import Wumpus.Basic.Graphic import Wumpus.Basic.Utils.Intersection  import Wumpus.Core                              -- package: wumpus-core  import Data.AffineSpace                         -- package: vector-space +import Control.Applicative   -- An existential thing that supports anchors.@@ -82,14 +104,6 @@    northwest (DotAnchor _ _ c1) = c1 NW  -circleAnchor :: Floating u => u -> Point2 u -> DotAnchor u-circleAnchor rad ctr = DotAnchor ctr -                                 (\theta -> ctr .+^ (avec theta rad))-                                 (radialCardinal rad ctr)---- radialCardinal :: Floating u => u -> Point2 u ->  Cardinal -> Point2 u radialCardinal rad ctr NN = ctr .+^ (avec (pi/2)     rad)  radialCardinal rad ctr NE = ctr .+^ (avec (pi/4)     rad) @@ -115,7 +129,7 @@ rectCardinal hw hh ctr NW = ctr .+^ (vec  (-hw)  hh)   -rectangleAnchor :: (Real u, Floating u) =>  u -> u -> Point2 u -> DotAnchor u+rectangleAnchor :: (Real u, Floating u) => u -> u -> Point2 u -> DotAnchor u rectangleAnchor hw hh ctr =      DotAnchor { center_anchor   = ctr               , radial_anchor   = fn  @@ -124,36 +138,94 @@     fn theta =  maybe ctr id $ findIntersect ctr theta                               $ rectangleLines ctr hw hh +rectangleLDO :: (Real u, Floating u) +             => u -> u -> LocDrawingObject u (DotAnchor u)+rectangleLDO w h pt = liftDrawingObject $ rectangleAnchor (w*0.5) (h*0.5) pt  -dotCircle :: (Floating u, FromPtSize u) => ANode u (DotAnchor u)-dotCircle = AGraphic (BD.dotCircle) mkF-  where-    mkF attr pt = circleAnchor (0.5 * markHeight attr) pt+circleAnchor :: Floating u => u -> Point2 u -> DotAnchor u+circleAnchor rad ctr = DotAnchor ctr +                                 (\theta -> ctr .+^ (avec theta rad))+                                 (radialCardinal rad ctr) +circleLDO :: (Floating u, FromPtSize u) => LocDrawingObject u (DotAnchor u)+circleLDO pt = (\diam -> circleAnchor (diam * 0.5) pt) <$> asksObj markHeight  -dotDisk :: (Floating u, FromPtSize u) => ANode u (DotAnchor u)-dotDisk = AGraphic (BD.dotDisk) mkF-  where-    mkF attr pt = circleAnchor (0.5 * markHeight attr) pt  -dotSquare :: (Floating u, Real u, FromPtSize u) => ANode u (DotAnchor u)-dotSquare = AGraphic (BD.dotSquare) mkF-  where-    mkF attr pt = let h = markHeight attr in-                  rectangleAnchor (0.5*h) (0.5*h) pt+-------------------------------------------------------------------------------- +type DotLocImage u = LocImage u (DotAnchor u)  +type DDotLocImage = DotLocImage Double + dotChar :: (Floating u, Real u, FromPtSize u) -        => Char -> ANode u (DotAnchor u)-dotChar ch = dotText [ch]+        => Char -> DotLocImage u+dotChar ch pt = asksObj (textDimensions [ch]) >>= \(w,h) -> +                intoLocImage (rectangleLDO w h) (markChar ch) pt + dotText :: (Floating u, Real u, FromPtSize u) -        => String -> ANode u (DotAnchor u) -dotText str = AGraphic (BD.dotText str) mkF-  where-    mkF attr pt = let (w,h) = textDimensions str attr in-                  rectangleAnchor (0.5*w) (0.5*h) pt+        => String -> DotLocImage u +dotText ss pt = asksObj (textDimensions ss) >>= \(w,h) -> +                intoLocImage (rectangleLDO w h) (markText ss) pt  +dotHLine :: (Floating u, FromPtSize u) => DotLocImage u+dotHLine = intoLocImage circleLDO markHLine+++dotVLine :: (Floating u, FromPtSize u) => DotLocImage u+dotVLine = intoLocImage circleLDO markVLine+++dotX :: (Floating u, FromPtSize u) => DotLocImage u+dotX = intoLocImage circleLDO markX++dotPlus :: (Floating u, FromPtSize u) => DotLocImage u+dotPlus = intoLocImage circleLDO markPlus++dotCross :: (Floating u, FromPtSize u) => DotLocImage u+dotCross = intoLocImage circleLDO markCross++dotDiamond :: (Floating u, FromPtSize u) => DotLocImage u+dotDiamond = intoLocImage circleLDO markDiamond++dotFDiamond :: (Floating u, FromPtSize u) => DotLocImage u+dotFDiamond = intoLocImage circleLDO markFDiamond++++dotDisk :: (Floating u, FromPtSize u) => DotLocImage u+dotDisk = intoLocImage circleLDO markDisk+++dotSquare :: (Floating u, Real u, FromPtSize u) => DotLocImage u+dotSquare pt = asksObj markHeight >>= \ h ->+               intoLocImage (rectangleLDO h h) markSquare pt+++++dotCircle :: (Floating u, FromPtSize u) => DotLocImage u+dotCircle = intoLocImage circleLDO markCircle+++dotPentagon :: (Floating u, FromPtSize u) => DotLocImage u+dotPentagon = intoLocImage circleLDO markPentagon++dotStar :: (Floating u, FromPtSize u) => DotLocImage u+dotStar = intoLocImage circleLDO markStar+++dotAsterisk :: (Floating u, FromPtSize u) => DotLocImage u+dotAsterisk = intoLocImage circleLDO markAsterisk++dotOPlus :: (Floating u, FromPtSize u) => DotLocImage u+dotOPlus = intoLocImage circleLDO markOPlus++dotOCross :: (Floating u, FromPtSize u) => DotLocImage u+dotOCross = intoLocImage circleLDO markOCross++dotFOCross :: (Floating u, FromPtSize u) => DotLocImage u+dotFOCross = intoLocImage circleLDO markFOCross

@@ -1,201 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Dots.Base--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC with TypeFamilies and more------ Dots--- -----------------------------------------------------------------------------------module Wumpus.Basic.Dots.Base-  ( ---  -- * Dots-    dotChar-  , dotText-  , dotHLine-  , dotVLine-  , dotX-  , dotPlus-  , dotCross-  , dotDiamond-  , dotFDiamond-  , dotDisk-  , dotSquare-  , dotCircle-  , dotPentagon-  , dotStar-  , dotAsterisk-  , dotOPlus-  , dotOCross-  , dotFOCross--  ) where---import Wumpus.Basic.Graphic-import Wumpus.Basic.Graphic.DrawingAttr-import Wumpus.Basic.Graphic.PointSupply-import Wumpus.Basic.Utils.HList--import Wumpus.Core                      -- package: wumpus-core--import Data.AffineSpace                 -- package: vector-space-import Data.VectorSpace---- Marks should be the height of a lower-case letter...---- NOTES------ TikZ has both stroked and bordered (filled and outline-stroked)--- marks e.g. square and square*------dotChar :: (Fractional u, FromPtSize u) => Char -> DrawingAttr -> GraphicF u-dotChar ch = dotText [ch]--dotText :: (Fractional u, FromPtSize u) => String -> DrawingAttr -> GraphicF u-dotText str attr = \ctr -> let pt = disp (-hw) (-hh) ctr in-    wrapG $ textlabel (stroke_colour attr) (font_props attr) str pt-  where-    sz = font_size  $ font_props attr-    hh = fromPtSize $ 0.5 * numeralHeight sz-    hw = fromPtSize $ 0.5 * textWidth sz (length str) ---- | Supplied point is the center.----axialLine :: Fractional u => RGBi -> StrokeAttr -> Vec2 u -> GraphicF u-axialLine rgb attr v = \ctr -> let pt = ctr .-^ (0.5 *^ v) in-    wrapG $ ostroke rgb attr $ path pt [lineTo $ pt .+^ v]- ------- Better would be a version of straightLine where the point is --- the center not the start...--- -dotHLine :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u -dotHLine attr = let w = markHeight attr in -    axialLine (stroke_colour attr) (stroke_props attr) (hvec w)-    --dotVLine :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u -dotVLine attr = let h = markHeight attr in -    axialLine (stroke_colour attr) (stroke_props attr) (vvec h)---dotX :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u-dotX attr = ls1 `cc` ls2-  where-    h        = markHeight attr-    w        = 0.75 * h-    ls1      = axialLine (stroke_colour attr) (stroke_props attr) (vec w h)-    ls2      = axialLine (stroke_colour attr) (stroke_props attr) (vec (-w) h)---dotPlus :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u-dotPlus attr = dotVLine attr `cc` dotHLine attr---dotCross :: (Floating u, FromPtSize u) => DrawingAttr -> GraphicF u-dotCross attr = ls1 `cc` ls2-  where-    z        = markHeight attr-    ls1      = axialLine (stroke_colour attr) (stroke_props attr) (avec (pi*0.25) z)-    ls2      = axialLine (stroke_colour attr) (stroke_props attr) (avec (negate $ pi*0.25) z)----- needs horizontal pinch...--pathDiamond :: (Fractional u, FromPtSize u) => DrawingAttr -> PathF u-pathDiamond attr = vertexPath . sequence [dvs,dve,dvn,dvw]-  where-    hh    = 0.66  * markHeight attr-    hw    = 0.5   * markHeight attr-    dvs   = (.+^ vvec (-hh))-    dve   = (.+^ hvec hw)-    dvn   = (.+^ vvec hh)-    dvw   = (.+^ hvec (-hw))--type PathF u = Point2 u -> PrimPath u--dotDiamond :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u-dotDiamond attr = -    wrapG . cstroke (stroke_colour attr) (stroke_props attr) . pathDiamond attr--dotFDiamond :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u-dotFDiamond attr = dotDiamond attr `cc` filled -  where-    filled = wrapG . fill (fill_colour attr) . pathDiamond attr------ | Note disk is filled.----dotDisk :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u-dotDisk attr = disk (fill_colour attr) (0.5*markHeight attr) ---dotSquare :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u-dotSquare attr = let u = markHeight attr in-     strokedRectangle (stroke_colour attr) (stroke_props attr) u u -    ---dotCircle :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u-dotCircle attr = disk (stroke_colour attr) (0.5*markHeight attr) ---dotPentagon :: (Floating u, FromPtSize u) => DrawingAttr -> GraphicF u-dotPentagon attr = -    wrapG . cstroke (stroke_colour attr) (stroke_props attr) -          . vertexPath . polygonPointsV 5 hh-  where-    hh      = 0.5 * markHeight attr-- --dotStar :: (Floating u, FromPtSize u) => DrawingAttr -> GraphicF u -dotStar attr = \pt -> veloH (fn pt) $ polygonPointsV 5 hh pt-  where-    hh        = 0.5 * markHeight attr-    fn pt pt' = wrapG $ cstroke (stroke_colour attr) (stroke_props attr) -                      $ path pt [lineTo pt'] -----dotAsterisk :: (Floating u, FromPtSize u) => DrawingAttr -> GraphicF u-dotAsterisk attr = ls1 `cc` ls2 `cc` ls3-  where-    z         = markHeight attr-    (rgb,sa)  = strokeAttr attr-    ang       = two_pi / 6-    ls1       = axialLine rgb sa (vvec z)-    ls2       = axialLine rgb sa (avec (half_pi + ang)    z)-    ls3       = axialLine rgb sa (avec (half_pi + ang + ang) z)---dotOPlus :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u-dotOPlus attr = dotCircle attr `cc` dotPlus attr---dotOCross :: (Floating u, FromPtSize u) => DrawingAttr -> GraphicF u-dotOCross attr = dotCircle attr `cc` dotCross attr---dotFOCross :: (Floating u, FromPtSize u) => DrawingAttr -> GraphicF u-dotFOCross attr = dotCircle attr `cc` dotCross attr `cc` bkCircle attr --bkCircle :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u-bkCircle attr = disk (fillAttr attr) (0.5*markHeight attr) 

@@ -0,0 +1,231 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Dots.Primitive+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC with TypeFamilies and more+--+-- Marks - dots without anchor handles.+--+-- \*\* WARNING \*\* - names are expected to change - filled and+-- background-filled marks need a naming convention.+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.Dots.Primitive+  ( +++  -- * Marks+    markChar+  , markText++  , markHLine+  , markVLine+  , markX+  , markPlus+  , markCross+  , markDiamond+  , markFDiamond+  , markBDiamond +  , markDisk+  , markSquare+  , markCircle  +  , markPentagon+  , markStar+  , markAsterisk+  , markOPlus+  , markOCross+  , markFOCross+++  ) where+++import Wumpus.Basic.Graphic++import Wumpus.Core                      -- package: wumpus-core++import Data.AffineSpace                 -- package: vector-space+import Data.VectorSpace++import Control.Applicative+import Data.List++-- Marks should be the height of a lower-case letter...++-- NOTES+--+-- TikZ has both stroked and bordered (filled and outline-stroked)+-- marks e.g. square and square*+--+++-- | 'polygonPoints' : @ num_points * radius * center -> [point] @ +--+polygonPoints :: Floating u => Int -> u -> Point2 u -> [Point2 u]+polygonPoints n radius ctr = unfoldr phi (0,(pi*0.5))+  where+    theta = (pi*2) / fromIntegral n+    +    phi (i,ang) | i < n     = Just (ctr .+^ avec ang radius, (i+1,ang+theta))+                | otherwise = Nothing++++-- | A mark is the height of a lowercase \'x\'.+-- +standardSize :: FromPtSize u => (u -> LocGraphic u) -> LocGraphic u+standardSize f = \pt -> asksObj markHeight >>= \h -> f h pt++halfHeightSize :: (Fractional u, FromPtSize u) +               => (u -> LocGraphic u) -> LocGraphic u+halfHeightSize f = \pt -> asksObj 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 ch = markText [ch]+++++-- Note - eta-expanded (?)+--+markText :: (Fractional u, FromPtSize u) => String -> LocGraphic u+markText ss pt = asksObj (textDimensions ss) >>= \(w,h) -> +                 shiftOrigin (0.5 * (-w)) (0.5 * (-h)) (textline ss) pt++++++-- | Supplied point is the center.+--+axialLine :: Fractional u => Vec2 u -> LocGraphic u+axialLine v = localPoint (\ctr -> ctr .-^ (0.5 *^ v)) (straightLine v)++++markHLine :: (Fractional u, FromPtSize u) => LocGraphic u +markHLine = standardSize (\h -> axialLine (hvec h))+    ++markVLine :: (Fractional u, FromPtSize u) => LocGraphic u +markVLine = standardSize (\h -> axialLine (vvec h)) +++markX :: (Fractional u, FromPtSize u) => LocGraphic u+markX = standardSize (\h -> let w = 0.75 * h in+                            axialLine (vec w h) `appendAt` axialLine (vec (-w) h))++++markPlus :: (Fractional u, FromPtSize u) =>  LocGraphic u+markPlus = markVLine `appendAt` markHLine+++markCross :: (Floating u, FromPtSize u) =>  LocGraphic u+markCross = standardSize +             (\h -> axialLine (avec ang h) `appendAt` axialLine (avec (-ang) h))+  where+    ang = pi*0.25  ++++-- needs horizontal pinch...++pathDiamond :: (Fractional u, FromPtSize u) +            => Point2 u -> DrawingObject (PrimPath u)+pathDiamond pt = (\h -> let hh    = 0.66 * h; hw = 0.5 * h +                        in vertexPath [dvs hh, dve hw,dvn hh, dvw hw])+                   <$> asksObj markHeight+  where+    dvs hh = pt .+^ vvec (-hh)+    dve hw = pt .+^ hvec hw+    dvn hh = pt .+^ vvec hh+    dvw hw = pt .+^ hvec (-hw)++++markDiamond :: (Fractional u, FromPtSize u) => LocGraphic u+markDiamond = \pt -> pathDiamond pt >>= closedStroke  ++markFDiamond :: (Fractional u, FromPtSize u) => LocGraphic u+markFDiamond = \pt -> pathDiamond pt >>= filledPath  ++markBDiamond :: (Fractional u, FromPtSize u) => LocGraphic u+markBDiamond = \pt -> pathDiamond pt >>= borderedPath+++-- | Note disk is filled.+--+markDisk :: (Fractional u, FromPtSize u) => LocGraphic u+markDisk = halfHeightSize filledDisk ++++markSquare :: (Fractional u, FromPtSize u) => LocGraphic u+markSquare = standardSize (\h -> let d = 0.5*(-h) in +                                 shiftOrigin d d $ strokedRectangle h h) +    +++markCircle :: (Fractional u, FromPtSize u) => LocGraphic u+markCircle = halfHeightSize strokedDisk +++markBCircle :: (Fractional u, FromPtSize u) => LocGraphic u+markBCircle = halfHeightSize borderedDisk ++++markPentagon :: (Floating u, FromPtSize u) => LocGraphic u+markPentagon pt = asksObj markHeight >>= \h ->+                  closedStroke $ vertexPath $ polygonPoints 5 (0.5*h) pt++ +++markStar :: (Floating u, FromPtSize u) => LocGraphic u +markStar pt = asksObj markHeight >>= \h -> +              let (p:ps) = polygonPoints 5 (0.5*h) pt in gcat (fn p) $ map fn ps+  where+    fn p1  = openStroke $ path pt [lineTo p1] +++++markAsterisk :: (Floating u, FromPtSize u) => LocGraphic u+markAsterisk = standardSize (\h -> lineF1 h `appendAt` lineF2 h `appendAt` lineF3 h)+  where+    ang       = (pi*2) / 6+    lineF1 z  = axialLine (vvec z)+    lineF2 z  = axialLine (avec ((pi*0.5) + ang)    z)+    lineF3 z  = axialLine (avec ((pi*0.5) + ang + ang) z)++++markOPlus :: (Fractional u, FromPtSize u) => LocGraphic u+markOPlus = markCircle `appendAt` markPlus+++markOCross :: (Floating u, FromPtSize u) => LocGraphic u+markOCross = markCircle `appendAt` markCross+++markFOCross :: (Floating u, FromPtSize u) => LocGraphic u+markFOCross = markCross `appendAt` markBCircle +++-- bkCircle :: (Fractional u, FromPtSize u) => LocGraphic u+-- bkCircle = disk (fillAttr attr) (0.5*markHeight attr) +

@@ -10,19 +10,24 @@ -- Stability   :  highly unstable -- Portability :  GHC  ----- Import shim for @Wumpus.Basic.Graphic.Primitive@.------ \*\* WARNING \*\* - this module is highly experimental, and --- may change significantly or even be dropped from future --- revisions.+-- Import shim for @Wumpus.Basic.Graphic@ modules. -- -- --------------------------------------------------------------------------------  module Wumpus.Basic.Graphic   (-    module Wumpus.Basic.Graphic.Primitive-  +    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   ) where -import Wumpus.Basic.Graphic.Primitive+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

@@ -0,0 +1,72 @@+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Graphic.BaseClasses+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC +--+-- Base classes and type families.+--+-- Drawing is always built on TraceM and DrawingCtxM, it may use+-- PointSupplyM for chains or turtle drawing.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Graphic.BaseClasses+  (+    MonUnit+  , TraceM(..)+  , DrawingCtxM(..)+  , asksCtx  ++  , PointSupplyM(..)++  ) where++import Wumpus.Basic.Graphic.BaseTypes ( HPrim )+import Wumpus.Basic.Graphic.DrawingContext+ ++import Wumpus.Core                              -- package: wumpus-core+++++-- DUnit is always for fully saturated types, so (seemingly) an equivalent+-- type family is needed.++type family MonUnit m :: * +++-- | Collect elementary graphics as part of a larger drawing.+--+-- TraceM works much like a writer monad.+--+class Monad m => TraceM (m :: * -> *) where+  trace  :: HPrim (MonUnit m) -> m ()++class Monad m => DrawingCtxM (m :: * -> *) where+  askCtx    :: m DrawingContext+  localCtx  :: (DrawingContext -> DrawingContext) -> m a -> m a+++-- | Project a value out of a context.+--+asksCtx :: DrawingCtxM m => (DrawingContext -> a) -> m a+asksCtx f = askCtx >>= (return . f)+++-- | A monad that supplies points, e.g. a turtle monad. +--+class Monad m => PointSupplyM (m :: * -> *) where+  position :: u ~ MonUnit m => m (Point2 u)+ 

@@ -0,0 +1,246 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Graphic.Image+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Base types for Drawing Objects, Graphics / Images (a Graphic +-- that also returns an answer), etc.+--+-- \*\* WARNING \*\* - some names are expected to change +-- particularly the naming of the /append/ and /concat/ functions.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Graphic.BaseTypes+  (+    ++    HPrim+  , Point2T+  , DPoint2T++  , DrawingObject(..)+  , LocDrawingObject+  , DLocDrawingObject++  , liftDrawingObject ++  , Graphic+  , DGraphic+  , appendGraphic+  , gcat+  +  , asksObj+  , localCtxObj++  , runGraphic++  , LocGraphic+  , DLocGraphic+  , appendAt++  , Image+  , DImage+  , LocImage+  , DLocImage++  , runImage+  , intoImage+  , intoLocImage++  , ConnDrawingObject+  , DConnDrawingObject+  , ConnGraphic+  , DConnGraphic+  , ConnImage+  , DConnImage++  , intoConnImage++  ) where++import Wumpus.Basic.Graphic.DrawingContext+import Wumpus.Basic.Utils.HList++import Wumpus.Core                      -- package: wumpus-core+++import Control.Applicative+++++++-- | Graphics objects, even simple ones (line, arrow, dot) might +-- need more than one primitive (path or text label) for their+-- construction. Hence, the primary representation that all the +-- others are built upon must support /concatenation/ of +-- primitives. +--+-- Wumpus-Core has a type Picture - made from one or more +-- Primitives - but Pictures include support for affine frames. +-- For drawing many simple graphics (dots, connector lines...) +-- that do not need individual affine transformations this is a +-- penalty. A list of Primitives is therefore more suitable +-- representation, and a Hughes list which supports+-- efficient concatenation is wise.+--+type HPrim u = H (PrimElement u)+++-- | Point transformation function.+--+type Point2T u = Point2 u -> Point2 u++type DPoint2T = Point2T Double+++newtype DrawingObject a = DrawingObject { +          getDrawingObject :: DrawingContext -> a }++++type LocDrawingObject u a = Point2 u -> DrawingObject a ++type DLocDrawingObject a = LocDrawingObject Double a++++instance Functor DrawingObject where+  fmap f ma = DrawingObject $ \ctx -> f $ getDrawingObject ma ctx +++-- Applicative++instance Applicative DrawingObject where+  pure a    = DrawingObject $ \_   -> a+  mf <*> ma = DrawingObject $ \ctx -> let f = getDrawingObject mf ctx+                                          a = getDrawingObject ma ctx+                                      in f a++-- Monad ++instance Monad DrawingObject where+  return a  = DrawingObject $ \_   -> a+  ma >>= k  = DrawingObject $ \ctx -> let a = getDrawingObject ma ctx+                                      in (getDrawingObject . k) a ctx +++liftDrawingObject :: a -> DrawingObject a+liftDrawingObject a = DrawingObject $ \ _ctx -> a ++-- Simple drawing - representing one or more prims++type Graphic u = DrawingObject (HPrim u)++type DGraphic = Graphic Double+++appendGraphic :: Graphic u -> Graphic u -> Graphic u+appendGraphic gf1 gf2 = DrawingObject $ \ctx ->          +      (getDrawingObject gf1 ctx) `appendH` (getDrawingObject gf2 ctx)++gcat :: Graphic u -> [Graphic u] -> Graphic u+gcat a = step a +  where+    step ac []     = ac+    step ac (x:xs) = step (ac `appendGraphic` x) xs+ ++asksObj :: (DrawingContext -> a) -> DrawingObject a+asksObj fn = DrawingObject $ \ctx -> fn ctx++localCtxObj :: (DrawingContext -> DrawingContext) +            -> DrawingObject a -> DrawingObject a+localCtxObj upd gf = DrawingObject $ \ctx -> getDrawingObject gf (upd ctx)++runGraphic :: DrawingContext -> Graphic u -> HPrim u+runGraphic ctx gf = (getDrawingObject gf) ctx+++--------------------------------------------------------------------------------+++-- | Commonly graphics take a start point as well as a drawing +-- context.+-- +-- Here they are called a LocGraphic - graphic with a (starting) +-- location.+--+type LocGraphic u = Point2 u -> Graphic u++type DLocGraphic = LocGraphic Double+++++-- | Composition operator for LocGraphic - both LocGraphics+-- are drawn at the same origin and the results concatenated.+--+--+appendAt :: LocGraphic u -> LocGraphic u -> LocGraphic u+appendAt f g = \pt -> f pt `appendGraphic` g pt+++--------------------------------------------------------------------------------+++-- | Images return a value as well as drawing. A /node/ is a +-- typical example - nodes are drawing but the also support +-- taking anchor points.+--+type Image u a = DrawingObject (a, HPrim u)++type DImage a = Image Double a++type LocImage u a = Point2 u -> Image u a++type DLocImage a = LocImage Double a++runImage :: DrawingContext -> Image u a -> (a,HPrim u)+runImage ctx img = (getDrawingObject img) ctx+++intoImage :: DrawingObject a -> Graphic u -> Image u a+intoImage f g = DrawingObject $ \ctx -> +    let a = getDrawingObject f ctx; o = getDrawingObject g ctx in (a,o)+++intoLocImage :: LocDrawingObject u a -> LocGraphic u -> LocImage u a+intoLocImage f g pt = DrawingObject $ \ctx -> +    let a = getDrawingObject (f pt) ctx+        o = getDrawingObject (g pt) ctx +    in (a,o)++type ConnDrawingObject u a = Point2 u -> Point2 u -> DrawingObject a++type DConnDrawingObject a = ConnDrawingObject Double a++-- | ConnGraphic is a connector drawn between two points +-- contructing a Graphic.+--+type ConnGraphic u = Point2 u -> Point2 u -> Graphic u++type DConnGraphic = ConnGraphic Double++-- | ConImage is a connector drawn between two points +-- constructing an Image.+--+type ConnImage u a = Point2 u -> Point2 u -> Image u a++type DConnImage a = ConnImage Double a+++intoConnImage :: ConnDrawingObject u a -> ConnGraphic u -> ConnImage u a+intoConnImage f g p1 p2 = DrawingObject $ \ctx -> +    let a = getDrawingObject (f p1 p2) ctx+        o = getDrawingObject (g p1 p2) ctx +    in (a,o)

@@ -0,0 +1,87 @@+{-# 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 :: Point2T 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 +          => Point2T 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)

@@ -0,0 +1,233 @@+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Graphic.Drawing+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC +--+-- Drawing with trace and drawing context (i.e. reader monad+-- of attributes - fill_colour etc.).+--+-- \*\* WARNING \*\* - some names are expected to change +-- particularly the naming of the @draw@, @drawAt@, @node@, @...@ +-- functions.+--+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Graphic.Drawing+  (++    Drawing+  , DrawingT+  , runDrawing+  , execDrawing+  , runDrawingT+  , execDrawingT+  , liftToPictureU+ +  , draw+  , drawAt+  , drawAtImg+  , drawConn+  , drawConnImg+  , node++  ) where+++import Wumpus.Basic.Graphic.BaseClasses+import Wumpus.Basic.Graphic.BaseTypes+import Wumpus.Basic.Graphic.DrawingContext+import Wumpus.Basic.Utils.HList+ ++import Wumpus.Core                              -- package: wumpus-core++import Control.Applicative+import Control.Monad+++++-- Note - Drawing run \once\ - it is supplied with the starting+-- environment (DrawingContext) and returns a Picture.+--+-- Other Wumpus monads (e.g. Turtle) will typically be run inside+-- the Drawing monad as a local effect, rather than built into a +-- transformer stack.+--+++newtype Drawing u a   = Drawing { +          getDrawing :: DrawingContext -> HPrim u -> (a, HPrim u) }++newtype DrawingT u m a = DrawingT { +          getDrawingT :: DrawingContext -> HPrim u -> m (a, HPrim u) }++++type instance MonUnit (Drawing u) = u+type instance MonUnit (DrawingT u m) = u++++-- Functor++instance Functor (Drawing u) where+  fmap f ma = Drawing $ \ctx s -> +                let (a,s1) = getDrawing ma ctx s in (f a,s1)+++instance Monad m => Functor (DrawingT u m) where+  fmap f ma = DrawingT $ \ctx s -> +                getDrawingT ma ctx s >>= \(a,s1) -> return (f a,s1)++++-- Applicative++instance Applicative (Drawing u) where+  pure a    = Drawing $ \_   s -> (a, s)+  mf <*> ma = Drawing $ \ctx s -> let (f,s1) = getDrawing mf ctx s+                                      (a,s2) = getDrawing ma ctx s1+                                 in (f a, s2)+++instance Monad m => Applicative (DrawingT u m) where+  pure a    = DrawingT $ \_   s -> return (a, s)+  mf <*> ma = DrawingT $ \ctx s -> getDrawingT mf ctx s  >>= \(f,s1) ->+                                   getDrawingT ma ctx s1 >>= \(a,s2) ->+                                   return (f a, s2)++-- Monad++instance Monad (Drawing u) where+  return a  = Drawing $ \_   s -> (a, s)+  ma >>= k  = Drawing $ \ctx s -> let (a,s1) = getDrawing ma ctx s+                                  in (getDrawing . k) a ctx s1+                               ++++instance Monad m => Monad (DrawingT u m) where+  return a  = DrawingT $ \_   s -> return (a, s)+  ma >>= k  = DrawingT $ \ctx s -> getDrawingT ma ctx s       >>= \(a,s1) ->+                                   (getDrawingT . k) a ctx s1+                                 ++++-- TraceM +--+-- Note -  @ state `appendH` a @ means the first expression in a +-- monadic drawing is top of the Z-Order.+-- +-- This is the matches a list of Prims in Wumpus-Core where the +-- first element is drawn on top, however is not necessarily+-- intuitive if you regard the do-block as a sequence of +-- /actions/.+--+-- Ideally some control over the Z-Order, possibly adding +-- /layers/ to the drawing model would be valuable. +-- ++instance TraceM (Drawing u) where+  trace a = Drawing $ \_ s -> ((),s `appendH` a)+++instance Monad m => TraceM (DrawingT u m) where+  trace a = DrawingT $ \_ s -> return ((),s `appendH` a)++++-- DrawingCtxM++instance DrawingCtxM (Drawing u) where+  askCtx         = Drawing $ \ctx s -> (ctx, s)+  localCtx cF ma = Drawing $ \ctx  s -> getDrawing ma (cF ctx) s++++instance Monad m => DrawingCtxM (DrawingT u m) where+  askCtx         = DrawingT $ \ctx s -> return (ctx,s)+  localCtx cF ma = DrawingT $ \ctx s -> getDrawingT ma (cF ctx) s++++-- Note - the result type of runDrawing and friends needs more +-- thought and may change. +--+-- Possibly a wrapped HPrim that only supports concat and safe+-- extraction is best.+--+-- Or it could generate a picture, but then separate drawings+-- need the picture combinators to put them together. +-- +++runDrawing :: DrawingContext -> Drawing u a -> (a, HPrim u)+runDrawing ctx ma = getDrawing ma ctx emptyH++execDrawing :: DrawingContext -> Drawing u a -> HPrim u+execDrawing ctx ma = snd $ runDrawing ctx ma++++runDrawingT :: Monad m => DrawingContext -> DrawingT u m a -> m (a, HPrim u) +runDrawingT ctx ma = getDrawingT ma ctx emptyH++execDrawingT :: Monad m => DrawingContext -> DrawingT u m a -> m (HPrim u)+execDrawingT ctx ma = liftM snd $ runDrawingT ctx ma+++liftToPictureU :: (Real u, Floating u, FromPtSize u) => HPrim u -> Picture u+liftToPictureU hf = let prims = toListH hf in +                    if null prims then errK else frame prims+  where+    errK = error "liftToPictureU - empty prims list."++--------------------------------------------------------------------------------++draw :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Graphic u -> m ()+draw gf = askCtx >>= \ctx -> trace (runGraphic ctx gf)++drawAt :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) +       => Point2 u ->LocGraphic u -> m ()+drawAt pt gfL = askCtx >>= \ctx -> trace (runGraphic ctx (gfL pt))++drawAtImg :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) +          => Point2 u -> LocImage u a -> m a+drawAtImg pt imgL = askCtx >>= \ctx -> +                    let (a,o) = runImage ctx (imgL pt)+                    in trace o >> return a+++     +drawConn :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) +         => Point2 u -> Point2 u -> ConnGraphic u -> m ()+drawConn p1 p2 connL = askCtx >>= \ctx -> trace (runGraphic ctx (connL p1 p2))+     +drawConnImg :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) +            => Point2 u -> Point2 u -> ConnImage u a -> m a+drawConnImg p1 p2 connL = askCtx >>= \ctx -> +                          let (a,o) = runImage ctx (connL p1 p2)+                          in trace o >> return a+            +++node :: (TraceM m, DrawingCtxM m, PointSupplyM m, u ~ MonUnit m) +     => LocGraphic u -> m ()+node gfL = askCtx   >>= \ctx -> +           position >>= \pt  -> trace (runGraphic ctx $ gfL pt)++

@@ -1,135 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.DrawingAttr--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC with TypeFamilies and more------ Drawing attributes--- -----------------------------------------------------------------------------------module Wumpus.Basic.Graphic.DrawingAttr-  ( --  -- * Drawing attributes-    DrawingAttr(..)--  , standardAttr-  , strokeAttr   -  , fillAttr-  , textAttr-  , markHeight--  , textDimensions--  -- * Line widths-  , thick-  , ultrathick-  , thin--  -- * Font properties-  , fontsize-  , fontface--  ) where---import Wumpus.Basic.SafeFonts-import Wumpus.Basic.Colour.SVGColours-import Wumpus.Basic.Utils.Combinators--import Wumpus.Core                      -- package: wumpus-core--import Control.Applicative--data DrawingAttr = DrawingAttr -      { stroke_props       :: StrokeAttr-      , font_props         :: FontAttr-      , stroke_colour      :: RGBi-      , fill_colour        :: RGBi-      }-  deriving (Eq,Show)--standardAttr :: FontSize -> DrawingAttr-standardAttr sz = DrawingAttr { stroke_props       = default_stroke_attr-                              , font_props         = FontAttr sz courier-                              , stroke_colour      = black-                              , fill_colour        = gold  }-- -strokeAttr :: DrawingAttr -> (RGBi, StrokeAttr)-strokeAttr = liftA2 (,) stroke_colour stroke_props--fillAttr :: DrawingAttr -> RGBi-fillAttr = fill_colour--textAttr :: DrawingAttr -> (RGBi,FontAttr)-textAttr = liftA2 (,) stroke_colour font_props---- | A Mark is consider to be the height of a lowercase letter--- in the current font.----markHeight :: FromPtSize u => DrawingAttr -> u-markHeight = fromPtSize . xcharHeight . font_size . font_props----- | textDimensions : text -> DrawingAttr -> (width,height)----textDimensions :: FromPtSize u => String -> DrawingAttr -> (u,u)-textDimensions str attr = (w,h)-  where-    sz = font_size  $ font_props attr-    w  = fromPtSize $ textWidth  sz (1 + length str) -    h  = fromPtSize $ textHeight sz--------------------------------------------------------------------------------------- line widths---- Note - some care might be needed if we ever define other unit --- types...---- std_line_width      :: Double--- std_line_width      = 1.0--thick_line          :: Double-thick_line          = 2.0--ultra_thick_line    :: Double-ultra_thick_line    = 4.0--thin_line           :: Double-thin_line           = 0.5--setLineWidth       :: Double -> DrawingAttr -> DrawingAttr-setLineWidth d      = star (\s i -> s { stroke_props = upd i} ) stroke_props-  where-   upd attrs        = attrs { line_width = d }---thick               :: DrawingAttr -> DrawingAttr-thick               = setLineWidth thick_line--ultrathick          :: DrawingAttr -> DrawingAttr-ultrathick          = setLineWidth ultra_thick_line--thin                :: DrawingAttr -> DrawingAttr-thin                = setLineWidth thin_line---fontface            :: FontFace -> DrawingAttr -> DrawingAttr-fontface ff         = star (\s i -> s { font_props = upd i }) font_props-  where-    upd (FontAttr sz _) = FontAttr sz ff--fontsize            :: Int -> DrawingAttr -> DrawingAttr-fontsize sz         = star (\s i -> s { font_props = upd i }) font_props-  where-    upd (FontAttr _ ff) = FontAttr sz ff

@@ -0,0 +1,180 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Graphic.DrawingAttr+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC with TypeFamilies and more+--+-- Drawing attributes+--+-- \*\* WARNING \*\* - this module needs systematic naming +-- schemes both for update functions (primaryColour, ...) and +-- for synthesized selectors (e.g. lowerxHeight). The current +-- names will change.+--+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.Graphic.DrawingContext+  ( ++  -- * Drawing context+    DrawingContext(..)++  , standardContext+  , textAttr+  , markHeight+  , lowerxHeight+  , textDimensions++  -- * Modifiers +  -- ** Line widths+  , thick+  , ultrathick+  , thin++  -- ** Dash Pattern+  , dashPattern++  -- ** Font properties+  , fontsize+  , fontface++  -- ** Colour+  , swapColours+  , primaryColour+  , secondaryColour ++++  +  ) where+++import Wumpus.Basic.SafeFonts+import Wumpus.Basic.Colour.SVGColours++import Wumpus.Core                      -- package: wumpus-core++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+      }+  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  }++++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++updateFontProps :: (FontAttr -> FontAttr) +                -> DrawingContext -> DrawingContext+updateFontProps fn = (\s i -> s { font_props = fn i }) <*> font_props+++--------------------------------------------------------------------------------+-- line widths++-- Note - some care might be needed if we ever define other unit +-- types...++-- std_line_width      :: Double+-- std_line_width      = 1.0++thick_line          :: Double+thick_line          = 2.0++ultra_thick_line    :: Double+ultra_thick_line    = 4.0++thin_line           :: Double+thin_line           = 0.5++setLineWidth       :: Double -> DrawingContext -> DrawingContext+setLineWidth d      = updateStrokeProps (\s -> s { line_width = d })+++thick               :: DrawingContext -> DrawingContext+thick               = setLineWidth thick_line++ultrathick          :: DrawingContext -> DrawingContext+ultrathick          = setLineWidth ultra_thick_line++thin                :: DrawingContext -> DrawingContext+thin                = setLineWidth thin_line+++dashPattern         :: DashPattern -> DrawingContext -> DrawingContext+dashPattern d       = updateStrokeProps (\s -> s { dash_pattern = d })        ++--------------------------------------------------------------------------------+++fontface            :: FontFace -> DrawingContext -> DrawingContext+fontface ff         = updateFontProps (\(FontAttr sz _) -> FontAttr sz ff)++fontsize            :: Int -> DrawingContext -> DrawingContext+fontsize sz         = updateFontProps (\(FontAttr _ ff) -> FontAttr sz ff)++--------------------------------------------------------------------------------++swapColours :: DrawingContext -> DrawingContext+swapColours = +    (\s a b -> s { primary_colour = b, secondary_colour = a })+        <*> primary_colour <*> secondary_colour++primaryColour :: RGBi -> DrawingContext -> DrawingContext+primaryColour rgb = \s -> s { primary_colour = rgb } +++secondaryColour :: RGBi -> DrawingContext -> DrawingContext+secondaryColour rgb = \s -> s { secondary_colour = rgb } +

@@ -1,109 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Graphic.PointSupply--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  highly unstable--- Portability :  GHC ------ --- \*\* WARNING \*\* - function names likely to change.--------------------------------------------------------------------------------------module Wumpus.Basic.Graphic.PointSupply-  (-    -- * Constants (might move from this module)-    two_pi-  , half_pi-  -  -- * Generate points.-  , polygonPointsV-  , hpoints-  , vpoints-  -  ) where-  --import Wumpus.Core                      -- package: wumpus-core--import Data.AffineSpace                 -- package: vector-space--import Data.List--two_pi :: Radian-two_pi = 2.0 * pi--half_pi :: Radian-half_pi = 0.5 * pi----- | 'polygonPointsV' : @ num_points * radius * center -> [point] @ ----polygonPointsV :: Floating u => Int -> u -> Point2 u -> [Point2 u]-polygonPointsV n radius = sequence vecs-  where-    theta = two_pi / fromIntegral n-    vecs  = unfoldr phi (0,half_pi)-    -    phi (i,ang) | i < n     = Just ((.+^ avec ang radius), (i+1,ang+theta))-                | otherwise = Nothing---   --- | 'hpoints' : @ ypos * step * (x0,x1) -> [point] @--- --- Generate points in a horizontal line between x0 and x1.------ Note - the step increment is w.r.t. 0 rather than x0. x0 and --- x1 are just the range. An example:--- --- > hpoints 0 10 (5,35)------ > [P2 10 0, P2 20 0, P2 30 0]----hpoints :: RealFrac u => u -> u -> (u,u) -> [Point2 u]-hpoints y step (x0,x1) = unfoldr phi start-  where-    start              = initial step x0-    phi st | st < x1   = Just (P2 st y, st+step)  -           | otherwise = Nothing----- | 'vpoints' : @ xpos * step * (y0,y1) -> [point] @--- --- Generate points in a vertical line between y0 and y1.------ Note - the step increment is w.r.t. 0 rather than y0. y0 and --- y1 are just the range. An example:--- --- > vpoints 5 100 (50,500)------ > [P2 5 100, P2 5 200, P2 5 300, P2 5 400]----vpoints :: RealFrac u => u -> u -> (u,u) -> [Point2 u]-vpoints x step (y0,y1) = unfoldr phi start-  where-    start              = initial step y0-    phi st | st < y1   = Just (P2 x st, st+step)  -           | otherwise = Nothing----initial :: RealFrac a => a -> a -> a -initial step minval = step * (fn $ minval / step)-  where-    fn x | x < 0     = fromIntegral $ ceilingi x-         | otherwise = fromIntegral $ 1 + floori x----ceilingi  :: RealFrac a => a -> Integer-ceilingi  = ceiling--floori    :: RealFrac a => a -> Integer-floori    = floor

@@ -0,0 +1,233 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Graphic.PrimGraphic+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Elementary functions for the Graphic and LocGraphic types.+--+-- The functions here are generally analogeous to the Picture +-- API in @Wumpus.Core@, but here they exploit the implicit +-- @DrawingContext@.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Graphic.PrimGraphic+  (+    drawGraphic+  , drawGraphicU+++  , openStroke+  , closedStroke+  , filledPath+  , borderedPath+  , textline+  , strokedEllipse+  , filledEllipse  +  , borderedEllipse++  , supplyPt+  , localDrawingContext+  , localPoint+  , displace++  , straightLine++  , strokedRectangle+  , filledRectangle+  , borderedRectangle+++  , strokedCircle+  , filledCircle+  , borderedCircle+  +  , strokedDisk+  , filledDisk+  , borderedDisk+  ++  ) where++import Wumpus.Basic.Graphic.DrawingContext+import Wumpus.Basic.Graphic.BaseTypes+import Wumpus.Basic.Utils.HList++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space++import Control.Applicative++drawGraphic :: (Real u, Floating u, FromPtSize u) +            => DrawingContext -> Graphic u -> Maybe (Picture u)+drawGraphic ctx gf = post $ runGraphic ctx gf+  where+    post hf = let xs = toListH hf in +              if null xs then Nothing else Just (frame xs)++drawGraphicU :: (Real u, Floating u, FromPtSize u) +             => DrawingContext -> Graphic u -> Picture u+drawGraphicU ctx gf = post $ runGraphic ctx gf+  where+    post hf = let xs = toListH hf in +              if null xs then errK else frame xs+    errK    = error "drawGraphicU - empty Graphic."+++-- having the same names is actually not so useful...++openStroke :: Num u => PrimPath u -> Graphic u+openStroke pp = (\rgb attr -> wrapH $ ostroke rgb attr pp) +                    <$> asksObj primary_colour <*> asksObj stroke_props+++closedStroke :: Num u => PrimPath u -> Graphic u+closedStroke pp = (\rgb attr -> wrapH $ cstroke rgb attr pp) +                      <$> asksObj primary_colour <*> asksObj stroke_props+++filledPath :: Num u => PrimPath u -> Graphic u+filledPath pp = (\rgb -> wrapH $ fill rgb pp) +                    <$> asksObj secondary_colour+++borderedPath :: Num u => PrimPath u -> Graphic u+borderedPath pp = +    (\frgb attr srgb -> wrapH $ fillStroke frgb attr srgb pp) +        <$> asksObj secondary_colour <*> asksObj stroke_props <*> asksObj primary_colour+++textline :: Num u => String -> LocGraphic u+textline ss baseline_left =+    (\(rgb,attr) -> wrapH $ textlabel rgb attr ss baseline_left) +       <$> asksObj textAttr+++strokedEllipse :: Num u => u -> u -> LocGraphic u+strokedEllipse hw hh pt =  +    (\rgb attr -> wrapH $ strokeEllipse rgb attr hw hh pt) +       <$> asksObj primary_colour <*> asksObj stroke_props++filledEllipse :: Num u => u -> u -> LocGraphic u+filledEllipse hw hh pt =  +    (\rgb -> wrapH $ fillEllipse rgb hw hh pt) +       <$> asksObj secondary_colour++borderedEllipse :: Num u => u -> u -> LocGraphic u+borderedEllipse hw hh pt = +    (\frgb attr srgb -> wrapH $ fillStrokeEllipse frgb attr srgb hw hh pt) +        <$> asksObj secondary_colour <*> asksObj stroke_props +        <*> asksObj primary_colour+++--------------------------------------------------------------------------------+++-- | Supplying a point to a 'CFGraphic' takes it to a regular +-- 'Graphic'.+--+supplyPt :: Point2 u -> LocGraphic u -> Graphic u+supplyPt pt gf = gf pt +++displace :: Num u => u -> u -> Point2 u -> Point2 u+displace dx dy (P2 x y) = P2 (x+dx) (y+dy)+++localDrawingContext :: +    (DrawingContext -> DrawingContext) -> LocGraphic u -> LocGraphic u+localDrawingContext upd img = \pt -> localCtxObj upd (img pt) ++localPoint :: (Point2 u -> Point2 u) -> LocGraphic u -> LocGraphic u+localPoint upd gf = \pt -> gf (upd pt)+++--------------------------------------------------------------------------------+++straightLine :: Fractional u => Vec2 u -> LocGraphic u+straightLine v = \pt -> openStroke $ path pt [lineTo $ pt .+^ v]+           ++-- | Supplied point is /bottom-left/.+--+rectangle :: Num u => u -> u -> Point2 u -> PrimPath u+rectangle w h bl = path bl [ lineTo br, lineTo tr, lineTo tl ]+  where+    br = bl .+^ hvec w+    tr = br .+^ vvec h+    tl = bl .+^ vvec h ++++-- | Supplied point is /bottom left/.+--+strokedRectangle :: Fractional u => u -> u -> LocGraphic u+strokedRectangle w h = closedStroke . rectangle w h++++-- | Supplied point is /bottom left/.+--+filledRectangle :: Fractional u => u -> u -> LocGraphic u+filledRectangle w h = filledPath . rectangle w h+  ++-- | Supplied point is /bottom left/.+--+borderedRectangle :: Fractional u => u -> u -> LocGraphic u+borderedRectangle w h = borderedPath . rectangle w h++--------------------------------------------------------------------------------+++-- | Supplied point is center. Circle is drawn with Bezier +-- curves. +--+strokedCircle :: Floating u => Int -> u -> LocGraphic u+strokedCircle n r = closedStroke . curvedPath . bezierCircle n r++++-- | Supplied point is center. Circle is drawn with Bezier +-- curves. +--+filledCircle :: Floating u => Int -> u -> LocGraphic u+filledCircle n r = filledPath . curvedPath . bezierCircle n r+++-- | Supplied point is center. Circle is drawn with Bezier +-- curves. +--+borderedCircle :: Floating u => Int -> u -> LocGraphic u+borderedCircle n r = borderedPath . curvedPath . bezierCircle n r+++-- | 'disk' is drawn with Wumpus-Core\'s @ellipse@ primitive.+--+-- This is a efficient representation of circles using +-- PostScript\'s @arc@ or SVG\'s @circle@ in the generated +-- output. However, stroked-circles do not draw well after +-- non-uniform scaling - the line width is scaled as well as +-- the shape.+--+-- For stroked circles that can be scaled, consider making the +-- circle from Bezier curves.+--+strokedDisk :: Num u => u -> LocGraphic u+strokedDisk radius = strokedEllipse radius radius+++filledDisk :: Num u => u -> LocGraphic u+filledDisk radius = filledEllipse radius radius++borderedDisk :: Num u => u -> LocGraphic u+borderedDisk radius = borderedEllipse radius radius

@@ -1,297 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Graphic.Primitive--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  highly unstable--- Portability :  GHC ------ Graphic types and operations.------ \*\* WARNING \*\* - this due a major revision and will change--- significantly (or disappear...).-----------------------------------------------------------------------------------------module Wumpus.Basic.Graphic.Primitive-  (-  -- * Type aliases-    Graphic  -  , DGraphic--  , GraphicF-  , DGraphicF---  -- * General combinators-  , cc-  , supply--  -- * Operations-  , drawGraphic-  , drawGraphicU--  , wrapG-  , emptyG --  -- * Graphic primitives-  , textline-  , xtextline-  , straightLine-  , strokedRectangle-  , filledRectangle-  , rectanglePath-  , strokedCircle-  , filledCircle-  , disk--  -- * Displacement-  , Point2T-  , DPoint2T -  , positionWith-  , disp-  , vdisp-  , hdisp--  -- * Grid-  , Rectangle(..)-  , DRectangle-  , grid-  , border--  , RectangleLoc-  , DRectangleLoc-  , withinRectangleLoc--  ) where--import Wumpus.Basic.Graphic.PointSupply-import Wumpus.Basic.Utils.HList--import Wumpus.Core                      -- package: wumpus-core--import Data.AffineSpace                 -- package: vector-space--import Data.Maybe------ | Note - this representation allows for zero, one or more--- Primitives to be collected together.----type Graphic u          = H (Primitive u)--type DGraphic           = Graphic Double--type GraphicF u         = Point2 u -> Graphic u--type DGraphicF          = GraphicF Double-------------------------------------------------------------------------------------- Combinators...--infixr 9 `cc`---- | Composition operator...------ > cc f g = \x y -> f x (g x y)----cc :: (r1 -> a -> ans) -> (r1 -> r2 -> a) -> r1 -> r2 -> ans-cc f g = \x y -> f x (g x y)----- | Reverse application.----supply :: u -> (u -> a) -> a -supply u f = f u--------------------------------------------------------------------------------------- | Note - a Picture cannot be empty whereas a Graphic can.--- Hence this function returns via Maybe.----drawGraphic :: (Real u, Floating u, FromPtSize u) -            => Graphic u -> Maybe (Picture u)-drawGraphic f = post $ f []-  where-    post [] = Nothing-    post xs = Just $ frame xs ----- | /Unsafe/ version of 'drawGraphic' - this function throws --- an error when the graphic is empty.----drawGraphicU :: (Real u, Floating u, FromPtSize u) => Graphic u -> Picture u-drawGraphicU = fromMaybe errK . drawGraphic-  where-    errK = error "drawGraphic - empty Graphic."----- | Lift a Primitive to a Graphic----wrapG :: Primitive u -> Graphic u-wrapG = wrapH ---- | The empty graphic.----emptyG :: Graphic u-emptyG = emptyH-------------------------------------------------------------------------------------- | Text should not contain newlines.------ Note the supplied point is the \'left-baseline\'.----textline :: Num u => RGBi -> FontAttr -> String -> GraphicF u-textline rgb attr ss = wrapG . textlabel rgb attr ss --xtextline :: Num u => RGBi -> FontAttr -> XLink -> String -> GraphicF u-xtextline rgb attr xl ss = wrapG . xtextlabel rgb attr xl ss ------ | Vector is applied to the point.----straightLine :: Fractional u => RGBi -> StrokeAttr -> Vec2 u -> GraphicF u-straightLine rgb attr v = -    \pt -> wrapG $ ostroke rgb attr $ path pt [lineTo $ pt .+^ v]- ---- | Supplied point is center.----strokedRectangle :: Fractional u => RGBi -> StrokeAttr -> u -> u -> GraphicF u-strokedRectangle rgb attr w h = wrapG . cstroke rgb attr . rectangle w h---- | Supplied point is center.----filledRectangle :: Fractional u => RGBi -> u -> u -> GraphicF u-filledRectangle rgb w h = wrapG . fill rgb . rectangle w h--rectangle :: Fractional u => u -> u -> Point2 u -> PrimPath u-rectangle w h ctr = rectanglePath w h (ctr .-^ vec (0.5*w) (0.5*h))---- | Supplied point is /bottom-left/.----rectanglePath :: Num u => u -> u -> Point2 u -> PrimPath u-rectanglePath w h bl = path bl [ lineTo br, lineTo tr, lineTo tl ]-  where-    br = bl .+^ hvec w-    tr = br .+^ vvec h-    tl = bl .+^ vvec h ----- | 'strokedCircle' : @ stroked_props * num_subs * radius -> GraphicF @------ Draw a stroked circle made from Bezier curves. @num_subs@ is --- the number of subdivisions per quadrant.------ The result is a HOF (GraphicF :: Point -> Graphic) where the --- point is the center. --- -strokedCircle :: Floating u => RGBi -> StrokeAttr -> Int -> u -> GraphicF u-strokedCircle rgb attr n r = -    wrapG . cstroke rgb attr . curvedPath . bezierCircle n r----- | 'filledCircle' : @ fill_props * num_subs * radius -> GraphicF @------ Draw a filled circle made from Bezier curves. @num_subs@ is --- the number of subdivisions per quadrant.------ The result is a HOF (GraphicF :: Point -> Graphic) where the --- point is the center. ----filledCircle :: Floating u => RGBi -> Int -> u -> GraphicF u-filledCircle rgb n r = wrapG . fill rgb . curvedPath . bezierCircle n r------ | 'disk' is drawn with Wumpus-Core\'s @ellipse@ primitive.------ This is a efficient representation of circles using --- PostScript\'s @arc@ or SVG\'s @circle@ in the generated --- output. However, stroked-circles do not draw well after --- non-uniform scaling - the line width is scaled as well as --- the shape.------ For stroked circles that can be scaled, consider making the --- circle from Bezier curves.----disk :: Fractional u => RGBi -> u -> GraphicF u-disk rgb radius = wrapG . fillEllipse rgb radius radius -------------------------------------------------------------------------------------- Transforming points...---type Point2T    u = Point2 u -> Point2 u--type DPoint2T     = Point2T Double--positionWith :: Point2T u -> (Point2 u -> a) -> (Point2 u -> a)-positionWith displacer gf  = gf . displacer ---disp :: Num u => u -> u -> Point2T u-disp x y = (.+^ V2 x y)--hdisp :: Num u => u -> Point2T u-hdisp x = disp x 0--vdisp :: Num u => u -> Point2T u-vdisp y = disp 0 y------------------------------------------------------------------------------------- need a border / frame abstraction...--data Rectangle u = Rectangle -      { rect_width     :: !u-      , rect_height    :: !u -      }  -  deriving (Eq,Ord,Show)--type DRectangle = Rectangle Double---- | 'grid' : @ stroke_props * xstep * ystep * boundary_rect -> GraphicF @------ The result is a HOF (GraphicF :: Point -> Graphic) where the --- point is bottom-left. ----grid :: RealFrac u => RGBi -> StrokeAttr -> u -> u -> Rectangle u -> GraphicF u -grid rgb attr xstep ystep (Rectangle w h) = \pt ->-    vlines pt . hlines pt-  where-    vlines (P2 x y) = veloH (straightLine rgb attr (vvec h)) $ hpoints y xstep (x,x+w)-    hlines (P2 x y) = veloH (straightLine rgb attr (hvec w)) $ vpoints x ystep (y,y+h)-    ---- | 'border' : @ stroke_props * boundary_rect -> GraphicF @------ The result is a HOF (GraphicF :: Point -> Graphic) where the --- point is bottom-left. ----border :: Num u => RGBi -> StrokeAttr -> Rectangle u -> GraphicF u-border rgb attr (Rectangle w h) = wrapG . cstroke rgb attr . rectanglePath w h----type RectangleLoc u = (Rectangle u, Point2 u)--type DRectangleLoc = RectangleLoc Double---withinRectangleLoc :: (Num u, Ord u) => Point2 u -> RectangleLoc u -> Bool-withinRectangleLoc (P2 x y) (Rectangle w h, P2 ox oy) = -   ox <= x && x <= (ox+w) && oy <= y && y <= (oy+h)---

@@ -1,158 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Monads.Drawing--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC ------ Graphic types and lifters...--------------------------------------------------------------------------------------------module Wumpus.Basic.Monads.Drawing-  (-    -    AGraphic(..)-  , ANode-  , AFreeGraphic-  , AConnector--  , node-  , nodeAt-  , at-  , liftAFG-  , connect-  , connect_-  , props--  -- doodle-  , thick--  ) where--import Wumpus.Basic.Graphic-import Wumpus.Basic.Graphic.DrawingAttr-import Wumpus.Basic.Monads.DrawingCtxClass-import Wumpus.Basic.Monads.TraceClass-import Wumpus.Basic.Monads.TurtleClass--import Wumpus.Core                              -- package: wumpus-core--import Control.Applicative---- | AGraphic --- --- param typically @Point2 u@ or @()@------ If the param is a point it will be supplied by the drawing --- mode / drawing monad (e.g. the Turtle monad which supplies--- the current point).----data AGraphic param u a = AGraphic -       { agDrawF    :: DrawingAttr -> param -> Graphic u-       , agMakeF    :: DrawingAttr -> param -> a-       }----- | ANode is drawn a a point supplied by the drawing --- (e.g. current node of Turtle).----type ANode u a = AGraphic (Point2 u) u a---- /Free/ graphic----type AFreeGraphic u a = AGraphic () u a--type AConnector u a = Point2 u -> Point2 u -> AFreeGraphic u a--instance Functor (AGraphic pm u) where-  fmap f (AGraphic df mf) = AGraphic df (\pt attr -> f $ mf pt attr)--instance Applicative (AGraphic pm u) where-  pure a = AGraphic (\_ _ -> id) (\_ _ -> a)-  (AGraphic df1 mf1) <*> (AGraphic df2 mf2) = AGraphic df mf-      where-        df attr pt   = df2 attr pt . df1 attr pt-        mf attr pt   = mf1 attr pt $ mf2 attr pt----- This doesn't work like at on MGraphicF, as the point is not --- scaled w.r.t. TurtleScaleM ...----at :: ANode u a -> Point2 u -> ANode u a-at (AGraphic df mf) pt = AGraphic (\attr _ -> df attr pt)-                                  (\attr _ -> mf attr pt)------ getPos should be a class method outside of Turtle--- those Bivariate context from PSC could implement it...--node :: (Num u, TraceM m u, DrawingCtxM m, TurtleScaleM m u) -     => ANode u a -> m a-node (AGraphic df mf) = -    askDrawingCtx >>= \attr ->-    getPos        >>= \pt   ->-    trace (df attr pt) >> return (mf attr pt)--nodeAt :: (Num u, TraceM m u, DrawingCtxM m) -       => ANode u a -> Point2 u -> m a-nodeAt (AGraphic df mf) pt = -    askDrawingCtx >>= \attr ->-    trace (df attr pt) >> return (mf attr pt)---liftAFG :: (Num u, TraceM m u, DrawingCtxM m) -        => AFreeGraphic u a -> m a-liftAFG (AGraphic df mf) = -    askDrawingCtx >>= \attr -> trace (df attr ()) >> return (mf attr ())----connect :: (Num u, TraceM m u, DrawingCtxM m) -        => AConnector u a -> Point2 u -> Point2 u -> m a-connect conn p1 p2 = let (AGraphic df mf) = conn p1 p2 in  -    askDrawingCtx >>= \attr -> trace (df attr ()) >> return (mf attr ())----- This is a bit unfortunate - with a connector we can\'t touch--- the drawingAttr inside the AGraphic becase a connecter  is------ > pt -> pt -> AGraphic------ and not------ > AGraphic--------- Maybe AGraphic shouldn\'t have the agAttrF field?----------connect_ :: (Num u, TraceM m u, DrawingCtxM m) -         => (DrawingAttr -> DrawingAttr) -         -> AConnector u a -> Point2 u -> Point2 u -> m a-connect_ fn conn p1 p2 = let (AGraphic df mf) = conn p1 p2 in  -    askDrawingCtx >>= \a0 ->-    let attr = fn $ a0 in trace (df attr ()) >> return (mf attr ())-----infixr 7 `props`--props :: AGraphic pm u a -> (DrawingAttr -> DrawingAttr) -> AGraphic pm u a-props (AGraphic df mf) upd = AGraphic (\attr p -> df (upd attr) p) -                                      (\attr p -> mf (upd attr) p)---

@@ -1,41 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Monads.DrawingCtxClass--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC ------ Class.--------------------------------------------------------------------------------------module Wumpus.Basic.Monads.DrawingCtxClass-  (---  -- * DrawingCtx class--    DrawingCtxM(..)-  , withinModifiedCtx-  -  ) where--import Wumpus.Basic.Graphic.DrawingAttr---class Monad m => DrawingCtxM m where-  askDrawingCtx :: m DrawingAttr-  localCtx      :: DrawingAttr -> m a -> m a----withinModifiedCtx :: DrawingCtxM m -                  => (DrawingAttr -> DrawingAttr) -> m a -> m a-withinModifiedCtx upd ma = askDrawingCtx >>= \ctx -> localCtx (upd ctx) ma--

@@ -1,133 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FunctionalDependencies     #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Monads.DrawingMonad--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC ------ Drawing with trace and drawing context (i.e. reader monad--- of attributes - fill_colour etc.).--------------------------------------------------------------------------------------module Wumpus.Basic.Monads.DrawingMonad-  (-    -    Drawing-  , DrawingT-  , runDrawing-  , execDrawing-  , runDrawingT-  , execDrawingT--  , module Wumpus.Basic.Graphic.DrawingAttr-  , module Wumpus.Basic.Monads.DrawingCtxClass-  , module Wumpus.Basic.Monads.TraceClass--  ) where--import Wumpus.Basic.Graphic-import Wumpus.Basic.Graphic.DrawingAttr-import Wumpus.Basic.Monads.DrawingCtxClass-import Wumpus.Basic.Monads.TraceClass----- import Wumpus.Core                              -- package: wumpus-core--import Control.Applicative-import Control.Monad----newtype Drawing  u a   = Drawing { -          getDrawing :: DrawingAttr -> (a, Graphic u) }--newtype DrawingT u m a = DrawingT { -          getDrawingT :: DrawingAttr -> m (a, Graphic u) }---- Functor--instance Functor (Drawing u) where-  fmap f ma = Drawing $ \attr -> -                let (a,w) = getDrawing ma attr in (f a,w)---instance Monad m => Functor (DrawingT u m) where-  fmap f ma = DrawingT $ \attr -> -                getDrawingT ma attr >>= \(a,w) -> return (f a,w)---- Applicative--instance Applicative (Drawing u) where-  pure a    = Drawing $ \_    -> (a, emptyG)-  mf <*> ma = Drawing $ \attr -> let (f,w1) = getDrawing mf attr -                                     (a,w2) = getDrawing ma attr-                                 in (f a, w2 . w1)--instance Monad m => Applicative (DrawingT u m) where-  pure a    = DrawingT $ \_    -> return (a, emptyG)-  mf <*> ma = DrawingT $ \attr -> getDrawingT mf attr >>= \(f,w1) ->-                                  getDrawingT ma attr >>= \(a,w2) ->-                                  return (f a, w2 . w1)---- Monad--instance Monad (Drawing u) where-  return a  = Drawing $ \_    -> (a, emptyG)-  ma >>= k  = Drawing $ \attr -> let (a,w1) = getDrawing ma attr -                                     (b,w2) = (getDrawing . k) a attr-                                 in (b, w2 . w1)----instance Monad m => Monad (DrawingT u m) where-  return a  = DrawingT $ \_    -> return (a, emptyG)-  ma >>= k  = DrawingT $ \attr -> getDrawingT ma attr      >>= \(a,w1) ->-                                  (getDrawingT . k) a attr >>= \(b,w2) -> -                                  return (b, w2 . w1)---- TraceM --instance TraceM (Drawing u) u where-  trace a = Drawing $ \_ -> ((),a)--instance Monad m => TraceM (DrawingT u m) u where-  trace a = DrawingT $ \_ -> return ((),a)----- DrawingCtxM--instance DrawingCtxM (Drawing u) where-  askDrawingCtx   = Drawing $ \attr -> (attr,emptyG)-  localCtx ctx ma = Drawing $ \_    -> getDrawing ma ctx----instance Monad m => DrawingCtxM (DrawingT u m) where-  askDrawingCtx   = DrawingT $ \attr -> return (attr,emptyG)-  localCtx ctx ma = DrawingT $ \_    -> getDrawingT ma ctx------runDrawing :: DrawingAttr -> Drawing u a -> (a, Graphic u) -runDrawing attr ma = getDrawing ma attr--execDrawing :: DrawingAttr -> Drawing u a -> Graphic u-execDrawing attr ma = snd $ runDrawing attr ma--runDrawingT :: Monad m => DrawingAttr -> DrawingT u m a -> m (a, Graphic u) -runDrawingT attr ma = getDrawingT ma attr--execDrawingT :: Monad m => DrawingAttr -> DrawingT u m a -> m (Graphic u)-execDrawingT attr ma = liftM snd $ runDrawingT attr ma

@@ -1,33 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE FunctionalDependencies     #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Monads.TraceClass--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC ------ Tracing class covers both cons and snoc tracing--------------------------------------------------------------------------------------module Wumpus.Basic.Monads.TraceClass-  (--    TraceM(..)-- -  ) where---import Wumpus.Basic.Graphic---class TraceM  m u | m -> u where-  trace  :: Graphic u -> m ()-

@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE UndecidableInstances       #-} {-# LANGUAGE TypeSynonymInstances       #-}@@ -14,7 +15,7 @@ -- Stability   :  unstable -- Portability :  GHC  ----- Turtle monad and monad transformer.+-- Turtle monad transformer. -- -- The Turtle monad embodies the LOGO style of imperative  -- drawing - sending commands to update the a cursor.@@ -23,29 +24,28 @@ -- \"coordinate-free\" style of drawing, some types of  -- diagram are more easily expressed in the LOGO style. --+-- Turtle is only a transformer - it is intended to be run within+-- a 'Drawing'.+-- --------------------------------------------------------------------------------  module Wumpus.Basic.Monads.TurtleMonad   (-+    -- * Re-exports+    module Wumpus.Basic.Monads.TurtleClass -    Turtle+  -- * Turtle transformer   , TurtleT--  , runTurtle   , runTurtleT +  -- * Turtle combined with Drawing   , TurtleDrawing   , runTurtleDrawing   , execTurtleDrawing--  , module Wumpus.Basic.Monads.DrawingMonad-  , module Wumpus.Basic.Monads.TurtleClass       ) where  import Wumpus.Basic.Graphic-import Wumpus.Basic.Monads.DrawingMonad import Wumpus.Basic.Monads.TurtleClass  @@ -66,30 +66,20 @@       , _current_coord   :: (Int,Int)       } -newtype Turtle u a = Turtle  { -          getTurtle  :: TurtleConfig u -> TurtleState -> (a, TurtleState) } - newtype TurtleT u m a = TurtleT {            getTurtleT :: TurtleConfig u -> TurtleState -> m (a, TurtleState) } +type instance MonUnit (TurtleT u m) = u  -- Functor -instance Functor (Turtle u) where-  fmap f m = Turtle $ \r s -> let (a,s') = getTurtle m r s in (f a, s')  instance Monad m => Functor (TurtleT u m) where   fmap f m = TurtleT $ \r s -> getTurtleT m r s >>= \(a,s') ->                                return (f a, s')  -- Applicative -instance Applicative (Turtle u) where-  pure a    = Turtle $ \_ s -> (a,s)-  mf <*> ma = Turtle $ \r s -> let (f,s')  = getTurtle mf r s -                                   (a,s'') = getTurtle ma r s'-                                in (f a,s'')  - 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')  ->@@ -99,11 +89,6 @@  -- Monad  -instance Monad (Turtle u) where-  return a = Turtle $ \_ s -> (a,s)-  m >>= k  = Turtle $ \r s -> let (a,s') = getTurtle m r s-                              in (getTurtle . k) a r s'- 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')  ->@@ -112,17 +97,7 @@   -instance TurtleM (Turtle u) where-  getLoc      = Turtle $ \_ s@(TurtleState _ c) -> (c,s)-  setLoc c    = Turtle $ \_   (TurtleState o _) -> ((),TurtleState o c)-  getOrigin   = Turtle $ \_ s@(TurtleState o _) -> (o,s)-  setOrigin o = Turtle $ \_   (TurtleState _ c) -> ((),TurtleState o c) -instance TurtleScaleM (Turtle u) u where-  xStep    = Turtle $ \r s -> (xstep r,s)-  yStep    = Turtle $ \r s -> (ystep r,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)@@ -136,9 +111,6 @@  -- Run functions discard the state... -runTurtle :: Num u => TurtleConfig u -> (Int,Int) -> Turtle u a -> a-runTurtle cfg ogin mf = fst $ getTurtle mf cfg (TurtleState ogin ogin)-  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)@@ -146,25 +118,31 @@   + ---------------------------------------------------------------------------------- -- Cross instances  instance DrawingCtxM m => DrawingCtxM (TurtleT u m) where-  askDrawingCtx   = TurtleT $ \_ s -> askDrawingCtx >>= \ ctx -> return (ctx,s)+  askCtx   = TurtleT $ \_ s -> askCtx >>= \ ctx -> return (ctx,s)   localCtx ctx mf = TurtleT $ \r s -> localCtx ctx (getTurtleT mf r s)   -- This needs undecidable instances... -instance (Monad m, TraceM m i) => TraceM (TurtleT u m) i where+instance (Monad m, TraceM m, u ~ MonUnit m) => TraceM (TurtleT u m) where   trace a  = TurtleT $ \_ s -> trace a >> return ((),s)   -------------------------------------------------------------------------------- + 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 @@ -196,7 +174,7 @@ -- Lifters no longer supplied... -- TraceM  -instance TraceM (TurtleDrawing u) u where+instance TraceM (TurtleDrawing u) where   trace a = TurtleDrawing $ trace a  @@ -204,26 +182,24 @@ -- DrawingCtxM  instance DrawingCtxM (TurtleDrawing u) where-  askDrawingCtx   = TurtleDrawing $ askDrawingCtx+  askCtx          = TurtleDrawing $ askCtx   localCtx ctx ma = TurtleDrawing $ localCtx ctx (getTurtleDrawing ma)   runTurtleDrawing :: Num u                   => TurtleConfig u                   -> (Int,Int)-                 -> DrawingAttr +                 -> DrawingContext                  -> TurtleDrawing u a -                 -> (a, Graphic u)-runTurtleDrawing cfg ogin attr mf = -    runDrawing attr ( runTurtleT cfg ogin $ getTurtleDrawing mf)+                 -> (a, HPrim u)+runTurtleDrawing cfg ogin ctx mf = +    runDrawing ctx ( runTurtleT cfg ogin $ getTurtleDrawing mf)   execTurtleDrawing :: Num u                    => TurtleConfig u                   -> (Int,Int) -                  -> DrawingAttr +                  -> DrawingContext                   -> TurtleDrawing u a -                  -> Graphic u-execTurtleDrawing cfg ogin attr mf = -    snd $ runTurtleDrawing cfg ogin attr mf-+                  -> HPrim u+execTurtleDrawing cfg ogin ctx mf = snd $ runTurtleDrawing cfg ogin ctx mf

@@ -34,7 +34,6 @@   ) where  import Wumpus.Basic.Graphic-import Wumpus.Basic.Graphic.DrawingAttr import Wumpus.Basic.Paths.Base import Wumpus.Basic.Paths.Construction @@ -53,9 +52,8 @@  -- This one might be more useful... -pathGraphic :: Num u => Path u -> DrawingAttr -> Graphic u-pathGraphic bpath attr = -    wrapG $ ostroke (stroke_colour attr) (stroke_props attr) $ toPrimPathU bpath+pathGraphic :: Num u => PathF u -> ConnGraphic u+pathGraphic bpath = \p1 p2 -> openStroke $ toPrimPathU $ bpath p1 p2   

@@ -43,6 +43,7 @@        ) where + import Wumpus.Core                              -- package: wumpus-core  import Data.AffineSpace@@ -52,7 +53,9 @@ import Data.Sequence ( Seq, ViewL(..), viewl, (|>)  ) import qualified Data.Sequence as S -+-- Note - path doesn\'t need a drawing context for +-- construction...+-- type PathF u = Point2 u -> Point2 u -> Path u  

@@ -1,203 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Text.LRSymbol--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ 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...--------------------------------------------------------------------------------------module Wumpus.Basic.Text.LRSymbol-  ( --  -- * Lower case--    alpha-  , beta-  , gamma-  , delta-  , epsilon-  , zeta-  , eta-  , theta-  , iota-  , kappa-  , lambda-  , mu-  , nu-  , xi-  , pi-  , rho-  , sigma-  , tau-  , upsilon-  , phi-  , chi-  , psi-  , omega--  -- * Upper case-  , uGamma-  , uDelta-  , uTheta-  , uLambda-  , uXi-  , uPi-  , uSigma-  , uUpsilon-  , uPhi-  , uPsi-  , uOmega--  ) where---import Wumpus.Basic.SafeFonts-import Wumpus.Basic.Text.LRText--import Wumpus.Core                              -- package: wumpus-core--import Data.Char ( chr )-import Prelude hiding ( pi )---- 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.--- --useSymbol :: TextM u a -> TextM u a-useSymbol = bracketFontFace symbol-------------------------------------------------------------------------------------- lower case---alpha       :: (Num u, FromPtSize u) => TextM u ()-alpha       = useSymbol $ char 'a'--beta        :: (Num u, FromPtSize u) => TextM u ()-beta        = useSymbol $ char 'b'--gamma       :: (Num u, FromPtSize u) => TextM u ()-gamma       = useSymbol $ char 'g'--delta       :: (Num u, FromPtSize u) => TextM u ()-delta       = useSymbol $ char 'd'--epsilon     :: (Num u, FromPtSize u) => TextM u ()-epsilon     = useSymbol $ char 'e'--zeta        :: (Num u, FromPtSize u) => TextM u ()-zeta        = useSymbol $ char 'z'--eta         :: (Num u, FromPtSize u) => TextM u ()-eta         = useSymbol $ char 'h'--theta       :: (Num u, FromPtSize u) => TextM u ()-theta       = useSymbol $ char 'q'--iota        :: (Num u, FromPtSize u) => TextM u ()-iota        = useSymbol $ char 'i'--kappa       :: (Num u, FromPtSize u) => TextM u ()-kappa       = useSymbol $ char 'k'--lambda      :: (Num u, FromPtSize u) => TextM u ()-lambda      = useSymbol $ char 'l'--mu          :: (Num u, FromPtSize u) => TextM u ()-mu          = useSymbol $ char 'm'--nu          :: (Num u, FromPtSize u) => TextM u ()-nu          = useSymbol $ char 'n'--xi          :: (Num u, FromPtSize u) => TextM u ()-xi          = useSymbol $ char 'x'--pi          :: (Num u, FromPtSize u) => TextM u ()-pi          = useSymbol $ char 'p'--rho         :: (Num u, FromPtSize u) => TextM u ()-rho         = useSymbol $ char 'r'--sigma       :: (Num u, FromPtSize u) => TextM u ()-sigma       = useSymbol $ char 's'--tau         :: (Num u, FromPtSize u) => TextM u ()-tau         = useSymbol $ char 't'--upsilon     :: (Num u, FromPtSize u) => TextM u ()-upsilon     = useSymbol $ char 'u'--phi         :: (Num u, FromPtSize u) => TextM u ()-phi         = useSymbol $ char 'j'--chi         :: (Num u, FromPtSize u) => TextM u ()-chi         = useSymbol $ char 'c'--psi         :: (Num u, FromPtSize u) => TextM u ()-psi         = useSymbol $ char 'y'--omega       :: (Num u, FromPtSize u) => TextM u ()-omega       = useSymbol $ char 'w'-------------------------------------------------------------------------------------- upper case--uGamma      :: (Num u, FromPtSize u) => TextM u ()-uGamma      = useSymbol $ char 'G'--uDelta      :: (Num u, FromPtSize u) => TextM u ()-uDelta      = useSymbol $ char 'D'--uTheta      :: (Num u, FromPtSize u) => TextM u ()-uTheta      = useSymbol $ char 'Q'--uLambda     :: (Num u, FromPtSize u) => TextM u ()-uLambda     = useSymbol $ char 'L'--uXi         :: (Num u, FromPtSize u) => TextM u ()-uXi         = useSymbol $ char 'X'--uPi         :: (Num u, FromPtSize u) => TextM u ()-uPi         = useSymbol $ char 'P'--uSigma      :: (Num u, FromPtSize u) => TextM u ()-uSigma      = useSymbol $ char 'S'---- | Not working, though 161 should be uUpsilon.----uUpsilon    :: (Num u, FromPtSize u) => TextM u ()-uUpsilon    = useSymbol $ char $ chr 161--uPhi        :: (Num u, FromPtSize u) => TextM u ()-uPhi        = useSymbol $ char 'F'--uPsi        :: (Num u, FromPtSize u) => TextM u ()-uPsi        = useSymbol $ char 'Y'--uOmega      :: (Num u, FromPtSize u) => TextM u ()-uOmega      = useSymbol $ char 'W'-

@@ -1,192 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Text.LRText--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ LRText monad - left-to-right text.--- --- \*\* WARNING \*\* - This is out dated now that Wumpus-Core has--- support for /kerned/ labels.--------------------------------------------------------------------------------------module Wumpus.Basic.Text.LRText-  ( -    TextM-  , runTextM--  , text-  , char-  , kern-  , newline-  , bracketFontFace--  ) where---import Wumpus.Basic.Graphic-import Wumpus.Basic.Utils.Combinators--import Wumpus.Core                              -- package: wumpus-core--import Control.Applicative---- Need a note in wumpus-core and here about space:preserve----- Graphic or GraphicF ? ans. GraphicF---- Note - should be compatible with free-label and shape labels.--- This seems to favour GraphicF.---- Not quite the same as a trace monad because it needs the --- result to a function \"from Point -> ... \"---data Idx = Idx { idx_x :: !Int, idx_y :: !Int }-  deriving (Eq,Ord,Show)---rightn      :: Int -> Idx -> Idx -rightn n    = star (\s i -> s { idx_x = i+n }) idx_x--down1       :: Idx -> Idx -down1       = star (\s i -> s { idx_y = i-1, idx_x =0 }) idx_y---- can track the /user vectors so far/ in the state...---data St u = St -      { xy_pos          :: Idx-      , font_desc       :: FontAttr-      , horizontal_disp :: PtSize-      , acc_graphic     :: TGraphicF u-      }---- Vertical distance between baselines.-type VDist = PtSize       --type Env = (VDist, RGBi)--newtype TextM u a = TextM { getTextM :: Env -> St u -> (a, St u) }---- wrap GraphicF as it has /special/ construction.----newtype TGraphicF u = TGraphicF { getTGraphicF :: GraphicF u }--consT :: Num u => (Vec2 u, GraphicF u) -> TGraphicF u -> TGraphicF u-consT (V2 x y, f) tg = TGraphicF $ (f . disp x y) `cc` (getTGraphicF tg) ---instance Functor (TextM u) where-  fmap f mf = TextM $ \r s -> let (a,s') = getTextM 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 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'-                              --- Note - post has to displace in the vertical to get the bottom --- line at the base line...--runTextM :: (Num u, FromPtSize u) -         => PtSize -> (RGBi,FontAttr) -> (TextM u a) -> (a,GraphicF u)-runTextM vdistance (rgb,font) ma = post $ getTextM ma env st-  where-    post (a,s)  = let gf = getTGraphicF $ acc_graphic s-                      h  = fromIntegral $ idx_y $ xy_pos s-                  in (a, gf . vdisp (negate $ h * fromPtSize vdistance))--    env         = (vdistance,rgb) --    st          = St { xy_pos          = Idx 0 0 -                     , font_desc       = font-                     , horizontal_disp = 0-                     , acc_graphic     = TGraphicF (const emptyG) }-------------------------------------------------------------------------------------- State monad ops.--- Note - not all the state should be accessible. --setFontAttr :: FontAttr -> TextM u ()-setFontAttr fa = TextM $ \_ s -> ((), s { font_desc = fa })--setsFontAttr :: (FontAttr -> FontAttr) -> TextM u ()-setsFontAttr fn = TextM $ \_ st -> ((), upd st) -  where-    upd = star (\s i -> s { font_desc = fn i} ) font_desc--getFontAttr :: TextM u FontAttr-getFontAttr = TextM $ \_ s -> (font_desc s,s)   -------------------------------------------------------------------------------------makeDisplacement :: (Num u, FromPtSize u) -                 => FontSize -> PtSize -> PtSize -> Idx -> (Vec2 u)-makeDisplacement font_sz lefth vdist (Idx x y) = -    vec (txt_width + fromPtSize lefth)   -        (fromPtSize vdist * fromIntegral y)-  where-    txt_width = fromPtSize $ textWidth font_sz x---text :: (Num u, FromPtSize u) => String -> TextM u ()-text str = TextM $ \r s -> ((), upd r s)-  where-    upd (vdist,rgb) s@(St idx font h acc) = -        let g1  = textline rgb font str -            v   = makeDisplacement (font_size font) h vdist idx-        in s { xy_pos      = rightn (length str) idx-             , acc_graphic = (v,g1) `consT` acc      }---char :: (Num u, FromPtSize u) => Char -> TextM u ()-char ch = TextM $ \r s -> ((), upd r s)-  where-    upd (vdist,rgb) s@(St idx font h acc) = -        let g1  = textline rgb font [ch] -            v   = makeDisplacement (font_size font) h vdist idx-        in s { xy_pos      = rightn 1 idx-             , acc_graphic = (v,g1) `consT` acc }---kern :: (Num u, FromPtSize u) => PtSize ->  TextM u ()-kern h = TextM $ \_ s -> ((), upd s)-  where-    upd = star (\s i -> s { horizontal_disp = i + h }) horizontal_disp-----newline :: TextM u ()-newline = TextM $ \_ s -> ((), upd s)-  where-    upd = star (\s idx -> s { xy_pos = down1 idx, horizontal_disp = 0})-               xy_pos----bracketFontFace :: FontFace -> TextM u a -> TextM u a-bracketFontFace face mf = do-    old <- getFontAttr-    setsFontAttr fn-    ans <- mf -    setFontAttr old -    return ans-  where-    fn attr = attr { font_face = face }

@@ -1,60 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Utils.Combinators--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Combinators...--- -----------------------------------------------------------------------------------module Wumpus.Basic.Utils.Combinators-  ( --  -- * Starlings...-    star-  , star2-  , star3-  , star4 --  ) where---- starlings...---- Note - this is the correct argument order for a starling.--- I\'ve used these combinators elsewhere with arguments of the--- \"combiner\" in the wrong order.--star     :: (r -> a -> ans) -         -> (r -> a) -         -> r -> ans-star f fa x = f x (fa x)--star2    :: (r -> a -> b -> ans) -         -> (r -> a) -         -> (r -> b) -         -> r -> ans-star2 f fa fb x = f x (fa x) (fb x)--star3    :: (r -> a -> b -> c -> ans) -         -> (r -> a) -         -> (r -> b) -         -> (r -> c) -         -> r -> ans-star3 f fa fb fc x = f x (fa x) (fb x) (fc x)--star4    :: (r -> a -> b -> c -> d -> ans) -         -> (r -> a) -         -> (r -> b) -         -> (r -> c)-         -> (r -> d) -         -> r -> ans-star4 f fa fb fc fd x = f x (fa x) (fb x) (fc x) (fd x)--

@@ -35,6 +35,7 @@   ) where  + -------------------------------------------------------------------------------- -- Hughes list 

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

@@ -1,5 +1,5 @@ name:             wumpus-basic-version:          0.6.0+version:          0.7.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -9,9 +9,10 @@ synopsis:         Common drawing utilities built on wumpus-core. description:   .-  \*\* WARNING \*\* - this package is sub-alpha. It is only on -  Hackage to support other packages (Wumpus-Tree, -  Wumpus-Microprint) that are slighly more stable.+  \*\* WARNING \*\* - this package is sub-alpha. It was released +  to Hackage prematurely - designing a higher-level drawing +  library turns out to be much more demanding than designing a +  low-level one (Wumpus-Core).    .   A few of the modules (SafeFonts, SVGColours, X11Colours) are   fairly stable others simply aren\'t and may even disappear in@@ -20,6 +21,23 @@   .   Changelog:   .+  0.6.0 to 0.7.0:+  .+  * Major rework of Graphic types, the old types (AGraphic, +    GraphicF etc.) and the old drawing monads have been removed. +    The new types are based on the AGraphic and related types but +    their implementation is different. The new types track the +    /graphics state/ within the type (the DrawingContext) plus +    how to draw themselves. For real drawings, graphics are +    collected with a Writer-like monad the @Basic.Graphic.Drawing@ +    monad which replaces the DrawingCtx and Trace monads. The +    Turtle monad remains and has been updated to work with the new+    drawing monads.+  .+  * LRText and LRSymbol modules temporarily removed as they +    contradict the new, optimized kerning functionality in +    @Wumpus.Core@.+  .   0.5.0 to 0.6.0:   .   * Updates to work with wumpus-core-0.30.0.@@ -58,7 +76,7 @@   build-depends:      base            <  5,                        containers      >= 0.3     && <= 0.4,                        vector-space    >= 0.6,-                      wumpus-core     == 0.31.0+                      wumpus-core     == 0.32.0       exposed-modules:@@ -68,24 +86,20 @@     Wumpus.Basic.Colour.SVGColours,     Wumpus.Basic.Colour.X11Colours,     Wumpus.Basic.Dots,-    Wumpus.Basic.Dots.Base,+    Wumpus.Basic.Dots.Primitive,     Wumpus.Basic.Graphic,-    Wumpus.Basic.Graphic.DrawingAttr,-    Wumpus.Basic.Graphic.Primitive,-    Wumpus.Basic.Graphic.PointSupply,-    Wumpus.Basic.Monads.Drawing,-    Wumpus.Basic.Monads.DrawingMonad,-    Wumpus.Basic.Monads.DrawingCtxClass,-    Wumpus.Basic.Monads.TraceClass,+    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.Monads.TurtleClass,     Wumpus.Basic.Monads.TurtleMonad,     Wumpus.Basic.Paths,     Wumpus.Basic.Paths.Base,     Wumpus.Basic.Paths.Construction,     Wumpus.Basic.SafeFonts,-    Wumpus.Basic.Text.LRSymbol,-    Wumpus.Basic.Text.LRText,-    Wumpus.Basic.Utils.Combinators,     Wumpus.Basic.Utils.HList,     Wumpus.Basic.Utils.Intersection,     Wumpus.Basic.VersionNumber,