wumpus-basic 0.3.0 → 0.4.0

raw patch · 31 files changed

+1999/−1170 lines, 31 filesdep +containersdep ~wumpus-corePVP ok

version bump matches the API change (PVP)

Dependencies added: containers

Dependency ranges changed: wumpus-core

API changes (from Hackage documentation)

Files

• demo/ColourCharts.hs +1/−1
• demo/DotPic.hs +2/−2
• demo/FontPic.hs +5/−5
• src/Wumpus/Basic/AnchorDots.hs +0/−178
• src/Wumpus/Basic/Anchors.hs +3/−3
• src/Wumpus/Basic/Arrows.hs +160/−0
• src/Wumpus/Basic/Arrows/Tips.hs +130/−0
• src/Wumpus/Basic/Dots.hs +95/−137
• src/Wumpus/Basic/Dots/Base.hs +200/−0
• src/Wumpus/Basic/Graphic.hs +4/−2
• src/Wumpus/Basic/Graphic/DrawingAttr.hs +57/−7
• src/Wumpus/Basic/Monads/ConsDrawing.hs +0/−178
• src/Wumpus/Basic/Monads/Drawing.hs +120/−14
• src/Wumpus/Basic/Monads/DrawingCtxClass.hs +2/−35
• src/Wumpus/Basic/Monads/DrawingCtxMonad.hs +0/−121
• src/Wumpus/Basic/Monads/DrawingMonad.hs +133/−0
• src/Wumpus/Basic/Monads/STraceMonad.hs +0/−128
• src/Wumpus/Basic/Monads/SnocDrawing.hs +0/−175
• src/Wumpus/Basic/Monads/TraceClass.hs +3/−4
• src/Wumpus/Basic/Monads/TraceMonad.hs +0/−138
• src/Wumpus/Basic/Monads/TurtleMonad.hs +73/−4
• src/Wumpus/Basic/Paths.hs +165/−0
• src/Wumpus/Basic/Paths/Base.hs +216/−0
• src/Wumpus/Basic/Paths/Construction.hs +124/−0
• src/Wumpus/Basic/SafeFonts.hs +26/−26
• src/Wumpus/Basic/Text/LRSymbol.hs +203/−0
• src/Wumpus/Basic/Text/LRText.hs +189/−0
• src/Wumpus/Basic/Utils/Combinators.hs +60/−0
• src/Wumpus/Basic/VersionNumber.hs +2/−2
• src/Wumpus/Deprecated/PictureLanguage.hs +1/−1
• wumpus-basic.cabal +25/−9

@@ -54,7 +54,7 @@ colourSample (name,rgb) = block `cc` lbl    where     block = filledRectangle rgb  15 10-    lbl   = textline (courier 10) name . (.+^ hvec 18)+    lbl   = textline (FontAttr 10 courier) name . (.+^ hvec 18)   

@@ -3,7 +3,7 @@ module DotPic where  -import Wumpus.Basic.Dots+import Wumpus.Basic.Dots.Base import Wumpus.Basic.Graphic import Wumpus.Basic.Graphic.DrawingAttr import Wumpus.Basic.SVGColours@@ -58,7 +58,7 @@ points :: [Point2 Double] points = [P2 0 0, P2 32 10, P2 64 0, P2 96 10] -makeDotPic :: (Real u, Floating u) +makeDotPic :: (Real u, Floating u, FromPtSize u)             => (DrawingAttr -> GraphicF u) -> [Point2 u] -> Picture u makeDotPic fn xs = drawGraphicU $ veloH (fn std_attr) xs . dashline   where

@@ -32,13 +32,13 @@ makeFontLabel :: DRGB -> FontAttr -> DPoint2 -> DPrimitive makeFontLabel c fa = textlabel (c,fa) msg   where-    msg = unwords [ font_name fa, (show $ font_size fa) ++ "pt"]+    msg = unwords [ font_name $ font_face fa, (show $ font_size fa) ++ "pt"] -blueLabel :: (Int -> FontAttr) -> Int -> DPoint2 -> DPrimitive-blueLabel f i = makeFontLabel steelBlue (f i)+blueLabel :: FontFace -> Int -> DPoint2 -> DPrimitive+blueLabel ff i = makeFontLabel steelBlue (FontAttr i ff) -redLabel :: (Int -> FontAttr) -> Int -> DPoint2 -> DPrimitive-redLabel f i = makeFontLabel indianRed1 (f i)+redLabel :: FontFace -> Int -> DPoint2 -> DPrimitive+redLabel ff i = makeFontLabel indianRed1 (FontAttr i ff)   point_sizes :: [Int]

@@ -1,178 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE ExistentialQuantification  #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.AnchorDots--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC with TypeFamilies, GADTs and more------ Dots with anchors.--------------------------------------------------------------------------------------module Wumpus.Basic.AnchorDots-  ( --  -- * Existential anchor type-    DotAnchor--  -- * Dots with anchor points-  , dotCircle-  , dotDisk-  , dotSquare-  , dotChar-  , dotText--  ) where--import Wumpus.Basic.Anchors-import qualified Wumpus.Basic.Dots              as BD-import Wumpus.Basic.Monads.Drawing-import Wumpus.Basic.Monads.DrawingCtxClass-import Wumpus.Basic.Monads.TraceClass-import Wumpus.Basic.Utils.Intersection--import Wumpus.Core                              -- package: wumpus-core--import Data.AffineSpace                         -- package: vector-space------ An existential thing that supports anchors.--- This means any dot can retun the same (opaque) structure------ But it does mean that which anchor class are supported is --- fixed - the datatype needs a field for each one.--- Supporting north, southeast etc. will also be tedious...----data DotAnchor u = forall s.  -                    DotAnchor { center_anchor   :: Point2 u-                              , radial_anchor   :: Radian   -> Point2 u-                              , cardinal_anchor :: Cardinal -> Point2 u }--data Cardinal = NN | NE | EE | SE | SS | SW | WW | NW-  deriving (Eq,Show) --type instance DUnit (DotAnchor u) = u--instance CenterAnchor (DotAnchor u) where-  center (DotAnchor ca _ _) = ca--instance RadialAnchor (DotAnchor u) where-   radialAnchor theta (DotAnchor _ ra _) = ra theta--instance CardinalAnchor (DotAnchor u) where-   north (DotAnchor _ _ c1) = c1 NN-   south (DotAnchor _ _ c1) = c1 SS-   east  (DotAnchor _ _ c1) = c1 EE-   west  (DotAnchor _ _ c1) = c1 WW----instance CardinalAnchor2 (DotAnchor u) where-   northeast (DotAnchor _ _ c1) = c1 NE-   southeast (DotAnchor _ _ c1) = c1 SE-   southwest (DotAnchor _ _ c1) = c1 SW-   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) -radialCardinal rad ctr EE = ctr .+^ (avec  0         rad) -radialCardinal rad ctr SE = ctr .+^ (avec (7/4 * pi) rad) -radialCardinal rad ctr SS = ctr .+^ (avec (6/4 * pi) rad) -radialCardinal rad ctr SW = ctr .+^ (avec (5/4 * pi) rad) -radialCardinal rad ctr WW = ctr .+^ (avec  pi        rad) -radialCardinal rad ctr NW = ctr .+^ (avec (3/4 * pi) rad) ----- Rectangle cardinal points are at \"middles and corners\".-----rectCardinal :: Floating u => u ->  u -> Point2 u -> Cardinal -> Point2 u-rectCardinal _  hh ctr NN = ctr .+^ (vvec hh) -rectCardinal hw hh ctr NE = ctr .+^ (vec  hw     hh) -rectCardinal hw _  ctr EE = ctr .+^ (hvec hw) -rectCardinal hw hh ctr SE = ctr .+^ (vec  hw    (-hh)) -rectCardinal _  hh ctr SS = ctr .+^ (vvec (-hh)) -rectCardinal hw hh ctr SW = ctr .+^ (vec  (-hw) (-hh) )-rectCardinal hw _  ctr WW = ctr .+^ (hvec (-hw)) -rectCardinal hw hh ctr NW = ctr .+^ (vec  (-hw)  hh) ---rectangleAnchor :: (Real u, Floating u) =>  u -> u -> Point2 u -> DotAnchor u-rectangleAnchor hw hh ctr = -    DotAnchor { center_anchor   = ctr-              , radial_anchor   = fn  -              , cardinal_anchor = rectCardinal hw hh ctr }-  where-    fn theta =  maybe ctr id $ findIntersect ctr theta -                             $ rectangleLines ctr hw hh------- This draws to the trace then returns an opaque thing--- (a Circle) that supports anchors--dotCircle :: ( Monad m, TraceM m (Primitive u), DrawingCtxM m-             , Floating u) -          => MGraphicF m u (DotAnchor u)-dotCircle = \pt -> askDrawingCtx                    >>= \attr -> -                   markHeight                       >>= \h    ->-                   trace (BD.dotCircle attr pt)     >> -                   return (circleAnchor (0.5*h) pt)---dotDisk :: ( Monad m, TraceM m (Primitive u), DrawingCtxM m-           , Floating u) -        => MGraphicF m u (DotAnchor u)-dotDisk = \pt -> askDrawingCtx                    >>= \attr -> -                 markHeight                       >>= \h    ->-                 trace (BD.dotDisk attr pt)       >> -                 return (circleAnchor (0.5*h) pt)----dotSquare :: ( Monad m, TraceM m (Primitive u), DrawingCtxM m-             , Real u, Floating u) -          => MGraphicF m u (DotAnchor u)-dotSquare = \pt -> askDrawingCtx                >>= \attr -> -                   markHeight                   >>= \h    ->-                   trace (BD.dotSquare attr pt) >> -                   return (rectangleAnchor (0.5*h) (0.5*h) pt)------dotChar :: ( Monad m, TraceM m (Primitive u), DrawingCtxM m-           , Real u, Floating u) -          => Char -> MGraphicF m u (DotAnchor u)-dotChar ch = dotText [ch]--dotText :: ( Monad m, TraceM m (Primitive u), DrawingCtxM m-           , Real u, Floating u) -          => String -> MGraphicF m u (DotAnchor u)-dotText str = \pt -> askDrawingCtx                  >>= \attr  -> -                     textDimensions str             >>= \(w,h) ->-                     trace (BD.dotText str attr pt) >>-                     return (rectangleAnchor (0.5*w) (0.5*h) pt)--

@@ -11,9 +11,9 @@ -- Stability   :  highly unstable -- Portability :  GHC with TypeFamilies and more ----- Anchor points on \"shapes\".+-- Anchor points on shapes. ----- ** WARNING ** this module is highly experimental, and may +-- \*\* WARNING \*\* this module is an experiment, and may  -- change significantly or even be dropped from future revisions. --  --------------------------------------------------------------------------------@@ -58,7 +58,7 @@ -- on the baseline. -- class TextAnchor t where-  textAnchor :: DUnit t ~ u => t -> Point2 u+  baselineSW :: DUnit t ~ u => t -> Point2 u   -- | Anchor on a border that can be identified with and angle.

@@ -0,0 +1,160 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Arrows+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC with TypeFamilies and more+--+-- Anchor points on shapes.+--+-- \*\* WARNING \*\* this module is an experiment, and may +-- change significantly or even be dropped from future revisions.+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.Arrows+  ( +    line++  , arrowTri90+  , arrowTri60+  , arrowTri45+  , arrowOTri90+  , arrowOTri60+  , arrowOTri45++  , arrowBarb90+  , arrowBarb60+  , arrowBarb45+    +  , arrowPerp++  ) where++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.Core                      -- package: wumpus-core+++++arrowWidth :: FromPtSize u => DrawingAttr -> u +arrowWidth = fromPtSize . xcharHeight . font_size . font_props+++line :: Num u => BPathF u -> AConnector u (BPath u)+line pathF p0 p1 = AGraphic df mf+  where+    df attr () = pathGraphic (pathF p0 p1) attr+    mf _    () = pathF p0 p1+++++arrowTri90 :: (Real u, Floating u, FromPtSize u) +           => BPathF u -> AConnector u (BPath u)+arrowTri90 pathF = \p0 p1 -> +    AGraphic (\attr () -> triTipRight pathF tri90 p0 p1 attr) +             (\_    () -> pathF p0 p1)++arrowTri60 :: (Real u, Floating u, FromPtSize u) +           => BPathF u -> AConnector u (BPath u)+arrowTri60 pathF = \p0 p1 ->+    AGraphic (\attr () -> triTipRight pathF tri60 p0 p1 attr) +             (\_    () -> pathF p0 p1)+ +arrowTri45 :: (Real u, Floating u, FromPtSize u) +           => BPathF u -> AConnector u (BPath u)+arrowTri45 pathF = \p0 p1 ->+    AGraphic (\attr () -> triTipRight pathF tri45 p0 p1 attr) +             (\_    () -> pathF p0 p1)++arrowOTri90 :: (Real u, Floating u, FromPtSize u) +            => BPathF u -> AConnector u (BPath u)+arrowOTri90 pathF = \p0 p1 ->+    AGraphic (\attr () -> triTipRight pathF otri90 p0 p1 attr) +             (\_    () -> pathF p0 p1)++arrowOTri60 :: (Real u, Floating u, FromPtSize u) +            => BPathF u -> AConnector u (BPath u)+arrowOTri60 pathF = \p0 p1 -> +    AGraphic (\attr () -> triTipRight pathF otri60 p0 p1 attr) +             (\_    () -> pathF p0 p1)+++arrowOTri45 :: (Real u, Floating u, FromPtSize u) +            => BPathF u -> AConnector u (BPath u)+arrowOTri45 pathF = \p0 p1 ->+    AGraphic (\attr () -> triTipRight pathF otri45 p0 p1 attr)+             (\_    () -> pathF p0 p1)+++arrowBarb90 :: (Real u, Floating u, FromPtSize u) +            => BPathF u -> AConnector u (BPath u)+arrowBarb90 pathF = \p0 p1 ->+    AGraphic (\attr () -> barbTipRight pathF barb90 p0 p1 attr)+             (\_    () -> pathF p0 p1)++arrowBarb60 :: (Real u, Floating u, FromPtSize u) +            => BPathF u -> AConnector u (BPath u)+arrowBarb60 pathF = \p0 p1 ->+    AGraphic (\attr () -> barbTipRight pathF barb60 p0 p1 attr)+             (\_    () -> pathF p0 p1)++arrowBarb45 :: (Real u, Floating u, FromPtSize u) +            => BPathF u -> AConnector u (BPath u)+arrowBarb45 pathF = \p0 p1 ->+    AGraphic (\attr () -> barbTipRight pathF barb45 p0 p1 attr)+             (\_    () -> pathF p0 p1)++++triTipRight :: (Real u, Floating u, FromPtSize u) +            => BPathF 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 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) +             => BPathF 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) +          => BPathF u -> AConnector u (BPath u)+arrowPerp pathF p0 p1 = AGraphic df mf+  where+    df attr () = let theta = langle p0 p1  in+                 pathGraphic (pathF p0 p1) attr . perp theta attr p1+    mf _    () = pathF p0 p1+

@@ -0,0 +1,130 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Arrows.Tips+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC with TypeFamilies and more+--+-- Anchor points on shapes.+--+-- \*\* WARNING \*\* this module is an experiment, and may +-- change significantly or even be dropped from future revisions.+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.Arrows.Tips+  ( ++    tri90+  , tri60+  , tri45+  , otri90+  , otri60+  , otri45++  , barb90+  , barb60+  , barb45++  , perp++  ) where++import Wumpus.Basic.Graphic+import Wumpus.Basic.Graphic.DrawingAttr++import Wumpus.Core                      -- package: wumpus-core++import Data.AffineSpace                 -- package: vector-space+++tripoints :: Floating u+          => Radian -> u -> Radian -> Point2 u -> (Point2 u, Point2 u)+tripoints triang xchar_height theta tip = (tip .-^ v1, tip .-^ v2)+  where+    halfang = 0.5 * triang+    d       = xchar_height / (fromRadian $ cos halfang)+    v1      = avec (theta + halfang) d+    v2      = avec (theta - halfang) d++++-- width = xchar_height+-- filled with stroke colour!++triAng :: (Floating u, Real u, FromPtSize u)+      => Radian +      -> (Path 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+++-- The arg order should be:+-- Radian -> DrawingAttr -> GraphicF u++-- as DrawingAttr is a 'static' arg.++tri90 :: (Floating u, Real u, FromPtSize u)+      => Radian -> DrawingAttr -> GraphicF u+tri90 = triAng (pi/2) (\p a -> fill (stroke_colour a) p)+++tri60 :: (Floating u, Real u, FromPtSize u)+      => Radian -> DrawingAttr -> GraphicF u+tri60 = triAng (pi/3) (\p a -> fill (stroke_colour a) p)++tri45 :: (Floating u, Real u, FromPtSize u)+      => Radian -> DrawingAttr -> GraphicF u+tri45 = triAng (pi/4) (\p a -> fill (stroke_colour a) p)+++otri90 :: (Floating u, Real u, FromPtSize u)+      => Radian -> DrawingAttr -> GraphicF u+otri90 = triAng (pi/2) (\p a -> cstroke (strokeAttr a) p)++otri60 :: (Floating u, Real u, FromPtSize u)+      => Radian -> DrawingAttr -> GraphicF u+otri60 = triAng (pi/3) (\p a -> cstroke (strokeAttr a) p)++otri45 :: (Floating u, Real u, FromPtSize u)+      => Radian -> DrawingAttr -> GraphicF u+otri45 = triAng (pi/4) (\p a -> cstroke (strokeAttr a) p)+++barbAng :: (Floating u, Real u, FromPtSize u)+      => Radian -> Radian -> DrawingAttr -> GraphicF u+barbAng ang theta attr pt = +    wrapG $ ostroke (strokeAttr attr) $ vertexPath [u,pt,v]+  where+    sz    = fromPtSize $ xcharHeight $ font_size $ font_props attr+    (u,v) = tripoints ang sz theta  pt+++barb90 :: (Floating u, Real u, FromPtSize u) +       => Radian -> DrawingAttr -> GraphicF u+barb90 = barbAng (pi/2)++barb60 :: (Floating u, Real u, FromPtSize u) +       => Radian -> DrawingAttr -> GraphicF u+barb60 = barbAng (pi/3)++barb45 :: (Floating u, Real u, FromPtSize u) +       => Radian -> DrawingAttr -> GraphicF u+barb45 = barbAng (pi/4)++++perp :: (Floating u, FromPtSize u) => Radian -> DrawingAttr -> GraphicF u+perp theta attr = \pt -> +    wrapG $ ostroke (strokeAttr attr) $ vertexPath [ pt .+^ v, pt .-^ v]+  where+    half_sz = 0.5 * (fromPtSize $ xcharHeight $ font_size $ font_props attr)+    v       = avec (theta + pi/2) half_sz

@@ -1,3 +1,6 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE FlexibleContexts           #-} {-# OPTIONS -Wall #-}  --------------------------------------------------------------------------------@@ -8,194 +11,149 @@ -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com> -- Stability   :  highly unstable--- Portability :  GHC with TypeFamilies and more+-- Portability :  GHC with TypeFamilies, GADTs and more ----- Dots--- +-- Dots with anchors.+-- --------------------------------------------------------------------------------  module Wumpus.Basic.Dots   (  +  -- * Existential anchor type+    DotAnchor -  -- * Dots-    dotChar-  , dotText-  , dotHLine-  , dotVLine-  , dotX-  , dotPlus-  , dotCross-  , dotDiamond-  , dotFDiamond+  -- * Dots with anchor points+  , dotCircle   , dotDisk   , dotSquare-  , dotCircle-  , dotPentagon-  , dotStar-  , dotAsterisk-  , dotOPlus-  , dotOCross-  , dotFOCross+  , dotChar+  , dotText    ) where --import Wumpus.Basic.Graphic+import Wumpus.Basic.Anchors+import qualified Wumpus.Basic.Dots.Base         as BD import Wumpus.Basic.Graphic.DrawingAttr-import Wumpus.Basic.Graphic.PointSupply-import Wumpus.Basic.Utils.HList+import Wumpus.Basic.Monads.Drawing+import Wumpus.Basic.Utils.Intersection -import Wumpus.Core                      -- package: wumpus-core+import Wumpus.Core                              -- package: wumpus-core -import Data.AffineSpace                 -- package: vector-space-import Data.VectorSpace+import Data.AffineSpace                         -- package: vector-space --- Marks should be the height of a lower-case letter... --- NOTES++-- An existential thing that supports anchors.+-- This means any dot can retun the same (opaque) structure ----- Affine transforming Points, LineSegments etc. before--- they become pictures is _GOOD_! The calculations are done in --- Wumpus and so don't cause extra (gsave... grestore) in --- PostScript.+-- But it does mean that which anchor class are supported is +-- fixed - the datatype needs a field for each one.+-- Supporting north, southeast etc. will also be tedious... --+data DotAnchor u = forall s.  +                    DotAnchor { center_anchor   :: Point2 u+                              , radial_anchor   :: Radian   -> Point2 u+                              , cardinal_anchor :: Cardinal -> Point2 u } -dotChar :: Fractional u => Char -> DrawingAttr -> GraphicF u-dotChar ch = dotText [ch]+data Cardinal = NN | NE | EE | SE | SS | SW | WW | NW+  deriving (Eq,Show)  -dotText :: Fractional u => String -> DrawingAttr -> GraphicF u-dotText str attr = \ctr -> let pt = disp (-hw) (-hh) ctr in-    wrapG $ textlabel (textAttr attr) str pt-  where-    sz = font_size $ font_props attr-    hh = 0.5 * numeralHeight sz-    hw = 0.5 * textWidth sz (length str) +type instance DUnit (DotAnchor u) = u --- | Supplied point is the center.----axialLine :: (Stroke t, Fractional u) => t -> Vec2 u -> GraphicF u-axialLine t v = \ctr -> let pt = ctr .-^ (0.5 *^ v) in-    wrapG $ ostroke t $ path pt [lineTo $ pt .+^ v]- +instance CenterAnchor (DotAnchor u) where+  center (DotAnchor ca _ _) = ca +instance RadialAnchor (DotAnchor u) where+   radialAnchor theta (DotAnchor _ ra _) = ra theta +instance CardinalAnchor (DotAnchor u) where+   north (DotAnchor _ _ c1) = c1 NN+   south (DotAnchor _ _ c1) = c1 SS+   east  (DotAnchor _ _ c1) = c1 EE+   west  (DotAnchor _ _ c1) = c1 WW  --- Better would be a version of straightLine where the point is --- the center not the start...--- -dotHLine :: Fractional u => DrawingAttr -> GraphicF u -dotHLine attr = let w = markHeight attr in -    axialLine (strokeAttr attr) (hvec w)-     -dotVLine :: Fractional u => DrawingAttr -> GraphicF u -dotVLine attr = let h = markHeight attr in -    axialLine (strokeAttr attr) (vvec h)+instance CardinalAnchor2 (DotAnchor u) where+   northeast (DotAnchor _ _ c1) = c1 NE+   southeast (DotAnchor _ _ c1) = c1 SE+   southwest (DotAnchor _ _ c1) = c1 SW+   northwest (DotAnchor _ _ c1) = c1 NW  -dotX :: Fractional u => DrawingAttr -> GraphicF u-dotX attr = ls1 `cc` ls2-  where-    h        = markHeight attr-    w        = 0.75 * h-    ls1      = axialLine (strokeAttr attr) (vec w    h)-    ls2      = axialLine (strokeAttr attr) (vec (-w) h)+circleAnchor :: Floating u => u -> Point2 u -> DotAnchor u+circleAnchor rad ctr = DotAnchor ctr +                                 (\theta -> ctr .+^ (avec theta rad))+                                 (radialCardinal rad ctr)  -dotPlus :: Fractional u => DrawingAttr -> GraphicF u-dotPlus attr = dotVLine attr `cc` dotHLine attr  -dotCross :: Floating u => DrawingAttr -> GraphicF u-dotCross attr = ls1 `cc` ls2-  where-    z        = markHeight attr-    ls1      = axialLine (strokeAttr attr) (avec (pi*0.25)    z)-    ls2      = axialLine (strokeAttr attr) (avec (negate $ pi*0.25) z)+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) +radialCardinal rad ctr EE = ctr .+^ (avec  0         rad) +radialCardinal rad ctr SE = ctr .+^ (avec (7/4 * pi) rad) +radialCardinal rad ctr SS = ctr .+^ (avec (6/4 * pi) rad) +radialCardinal rad ctr SW = ctr .+^ (avec (5/4 * pi) rad) +radialCardinal rad ctr WW = ctr .+^ (avec  pi        rad) +radialCardinal rad ctr NW = ctr .+^ (avec (3/4 * pi) rad)   --- needs horizontal pinch...+-- Rectangle cardinal points are at \"middles and corners\".+-- -pathDiamond :: Fractional 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))+rectCardinal :: Floating u => u ->  u -> Point2 u -> Cardinal -> Point2 u+rectCardinal _  hh ctr NN = ctr .+^ (vvec hh) +rectCardinal hw hh ctr NE = ctr .+^ (vec  hw     hh) +rectCardinal hw _  ctr EE = ctr .+^ (hvec hw) +rectCardinal hw hh ctr SE = ctr .+^ (vec  hw    (-hh)) +rectCardinal _  hh ctr SS = ctr .+^ (vvec (-hh)) +rectCardinal hw hh ctr SW = ctr .+^ (vec  (-hw) (-hh) )+rectCardinal hw _  ctr WW = ctr .+^ (hvec (-hw)) +rectCardinal hw hh ctr NW = ctr .+^ (vec  (-hw)  hh)  -type PathF u = Point2 u -> Path u -dotDiamond :: Fractional u => DrawingAttr -> GraphicF u-dotDiamond attr = -    wrapG . cstroke (strokeAttr attr) . pathDiamond attr--dotFDiamond :: Fractional u => DrawingAttr -> GraphicF u-dotFDiamond attr = dotDiamond attr `cc` filled +rectangleAnchor :: (Real u, Floating u) =>  u -> u -> Point2 u -> DotAnchor u+rectangleAnchor hw hh ctr = +    DotAnchor { center_anchor   = ctr+              , radial_anchor   = fn  +              , cardinal_anchor = rectCardinal hw hh ctr }   where-    filled = wrapG . fill (fillAttr attr) . pathDiamond attr+    fn theta =  maybe ctr id $ findIntersect ctr theta +                             $ rectangleLines ctr hw hh   --- | Note disk is filled.----dotDisk :: Fractional u => DrawingAttr -> GraphicF u-dotDisk attr = disk (fill_colour attr) (0.5*markHeight attr) ---dotSquare :: Fractional u => DrawingAttr -> GraphicF u-dotSquare attr = let u = markHeight attr in-     strokedRectangle (strokeAttr attr) u u -    ---dotCircle :: Fractional u => DrawingAttr -> GraphicF u-dotCircle attr = disk (strokeAttr attr) (0.5*markHeight attr) ---dotPentagon :: Floating u => DrawingAttr -> GraphicF u-dotPentagon attr = -    wrapG . cstroke (strokeAttr attr) . vertexPath . polygonPointsV 5 hh+dotCircle :: (Floating u, FromPtSize u) => ANode u (DotAnchor u)+dotCircle = AGraphic (BD.dotCircle) mkF   where-    hh      = 0.5 * markHeight attr+    mkF attr pt = circleAnchor (0.5 * markHeight attr) pt -  -dotStar :: Floating u => DrawingAttr -> GraphicF u -dotStar attr = \pt -> veloH (fn pt) $ polygonPointsV 5 hh pt+dotDisk :: (Floating u, FromPtSize u) => ANode u (DotAnchor u)+dotDisk = AGraphic (BD.dotDisk) mkF   where-    hh        = 0.5 * markHeight attr-    fn pt pt' = wrapG $ cstroke (strokeAttr attr) $ path pt [lineTo pt'] --+    mkF attr pt = circleAnchor (0.5 * markHeight attr) pt  -dotAsterisk :: Floating u => DrawingAttr -> GraphicF u-dotAsterisk attr = ls1 `cc` ls2 `cc` ls3+dotSquare :: (Floating u, Real u, FromPtSize u) => ANode u (DotAnchor u)+dotSquare = AGraphic (BD.dotSquare) mkF   where-    z        = markHeight attr-    props    = strokeAttr attr-    ang      = two_pi / 6-    ls1      = axialLine props (vvec z)-    ls2      = axialLine props (avec (half_pi + ang)    z)-    ls3      = axialLine props (avec (half_pi + ang + ang) z)+    mkF attr pt = let h = markHeight attr in+                  rectangleAnchor (0.5*h) (0.5*h) pt  -dotOPlus :: Fractional u-         => DrawingAttr -> GraphicF u-dotOPlus attr = dotCircle attr `cc` dotPlus attr-+dotChar :: (Floating u, Real u, FromPtSize u) +        => Char -> ANode u (DotAnchor u)+dotChar ch = dotText [ch] -dotOCross :: Floating u => DrawingAttr -> GraphicF u-dotOCross attr = dotCircle attr `cc` dotCross attr+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  -dotFOCross :: Floating u => DrawingAttr -> GraphicF u-dotFOCross attr = dotCircle attr `cc` dotCross attr `cc` bkCircle attr --bkCircle :: Fractional u => DrawingAttr -> GraphicF u-bkCircle attr = disk (fillAttr attr) (0.5*markHeight attr) 

@@ -0,0 +1,200 @@+{-# 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+--+-- Affine transforming Points, LineSegments etc. before+-- they become pictures is _GOOD_! The calculations are done in +-- Wumpus and so don't cause extra (gsave... grestore) in +-- PostScript.+--++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 (textAttr 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 :: (Stroke t, Fractional u) => t -> Vec2 u -> GraphicF u+axialLine t v = \ctr -> let pt = ctr .-^ (0.5 *^ v) in+    wrapG $ ostroke t $ 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 (strokeAttr attr) (hvec w)+    ++dotVLine :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u +dotVLine attr = let h = markHeight attr in +    axialLine (strokeAttr 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 (strokeAttr attr) (vec w    h)+    ls2      = axialLine (strokeAttr 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 (strokeAttr attr) (avec (pi*0.25)    z)+    ls2      = axialLine (strokeAttr 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 -> Path u++dotDiamond :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u+dotDiamond attr = +    wrapG . cstroke (strokeAttr attr) . pathDiamond attr++dotFDiamond :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u+dotFDiamond attr = dotDiamond attr `cc` filled +  where+    filled = wrapG . fill (fillAttr 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 (strokeAttr attr) u u +    +++dotCircle :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u+dotCircle attr = disk (strokeAttr attr) (0.5*markHeight attr) +++dotPentagon :: (Floating u, FromPtSize u) => DrawingAttr -> GraphicF u+dotPentagon attr = +    wrapG . cstroke (strokeAttr 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 (strokeAttr attr) $ path pt [lineTo pt'] +++++dotAsterisk :: (Floating u, FromPtSize u) => DrawingAttr -> GraphicF u+dotAsterisk attr = ls1 `cc` ls2 `cc` ls3+  where+    z        = markHeight attr+    props    = strokeAttr attr+    ang      = two_pi / 6+    ls1      = axialLine props (vvec z)+    ls2      = axialLine props (avec (half_pi + ang)    z)+    ls3      = axialLine props (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) 

@@ -28,6 +28,7 @@   , GraphicF   , DGraphicF +   -- * General combinators   , cc   , supply@@ -116,7 +117,8 @@ -- | Note - a Picture cannot be empty whereas a Graphic can. -- Hence this function returns via Maybe. ---drawGraphic :: (Real u, Floating u) => Graphic u -> Maybe (Picture u)+drawGraphic :: (Real u, Floating u, FromPtSize u) +            => Graphic u -> Maybe (Picture u) drawGraphic f = post $ f []   where     post [] = Nothing@@ -126,7 +128,7 @@ -- | /Unsafe/ version of 'drawGraphic' - this function throws  -- an error when the graphic is empty. ---drawGraphicU :: (Real u, Floating u) => Graphic u -> Picture u+drawGraphicU :: (Real u, Floating u, FromPtSize u) => Graphic u -> Picture u drawGraphicU = fromMaybe errK . drawGraphic   where     errK = error "drawGraphic - empty Graphic."

@@ -28,11 +28,21 @@    , textDimensions +  -- * Line widths+  , thick+  , ultrathick+  , thin++  -- * Font properties+  , fontsize+  , fontface+   ) where   import Wumpus.Basic.SafeFonts import Wumpus.Basic.SVGColours+import Wumpus.Basic.Utils.Combinators  import Wumpus.Core                      -- package: wumpus-core @@ -47,8 +57,8 @@   deriving (Eq,Show)  standardAttr :: FontSize -> DrawingAttr-standardAttr sz = DrawingAttr { line_width         = 1.0-                              , font_props         = courier sz+standardAttr sz = DrawingAttr { line_width         = std_line_width+                              , font_props         = FontAttr sz courier                               , stroke_colour      = black                               , fill_colour        = gold  } @@ -65,15 +75,55 @@ -- | A Mark is consider to be the height of a lowercase letter -- in the current font. ---markHeight :: Fractional u => DrawingAttr -> u-markHeight = xcharHeight . font_size . font_props+markHeight :: FromPtSize u => DrawingAttr -> u+markHeight = fromPtSize . xcharHeight . font_size . font_props   -- | textDimensions : text -> DrawingAttr -> (width,height) ---textDimensions :: Fractional u => String -> DrawingAttr -> (u,u)+textDimensions :: FromPtSize u => String -> DrawingAttr -> (u,u) textDimensions str attr = (w,h)   where     sz = font_size  $ font_props attr-    w  = textWidth  sz (1 + length str) -    h  = textHeight sz+    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++thick               :: DrawingAttr -> DrawingAttr+thick attr          = attr { line_width = thick_line }++ultrathick          :: DrawingAttr -> DrawingAttr+ultrathick attr     = attr { line_width = ultra_thick_line }++thin                :: DrawingAttr -> DrawingAttr+thin attr           = attr { line_width = 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

@@ -1,178 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Monads.ConsDrawing--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC ------ Trace plus DrawingCtx plus Turtle...--------------------------------------------------------------------------------------module Wumpus.Basic.Monads.ConsDrawing-  (-    ConsDrawing-  , ConsDrawingT--  , runConsDrawing-  , runConsDrawingT-  , execConsDrawing-  , execConsDrawingT--  -- * Re-exports-  , module Wumpus.Basic.Monads.Drawing-  , module Wumpus.Basic.Monads.DrawingCtxClass-  , module Wumpus.Basic.Monads.TraceClass-  , module Wumpus.Basic.Monads.TurtleClass --  ) where--import Wumpus.Basic.Graphic-import Wumpus.Basic.Monads.Drawing-import Wumpus.Basic.Monads.DrawingCtxClass-import Wumpus.Basic.Monads.DrawingCtxMonad-import Wumpus.Basic.Monads.TraceClass-import Wumpus.Basic.Monads.TraceMonad-import Wumpus.Basic.Monads.TurtleClass-import Wumpus.Basic.Monads.TurtleMonad--import Wumpus.Core                      -- package: wumpus-core--import MonadLib ( MonadT(..) )          -- package: monadLib--import Control.Applicative-import Control.Monad---newtype ConsDrawing u a = ConsDrawing { -          getConsDrawing  :: TurtleT          u-                           ( DrawingCtxT-                           ( Trace (Primitive u))) a }--newtype ConsDrawingT u m a = ConsDrawingT { -          getConsDrawingT :: TurtleT           u-                           ( DrawingCtxT-                           ( TraceT (Primitive u) m)) a }----- Functor--instance Functor (ConsDrawing u) where-  fmap f = ConsDrawing . fmap f . getConsDrawing--instance Monad m => Functor (ConsDrawingT u m) where-  fmap f = ConsDrawingT . fmap f . getConsDrawingT----- Applicative -instance Applicative (ConsDrawing u) where-  pure a    = ConsDrawing $ pure a-  mf <*> ma = ConsDrawing $ getConsDrawing mf <*> getConsDrawing ma-                   ---instance Monad m => Applicative (ConsDrawingT u m) where-  pure a    = ConsDrawingT $ pure a-  mf <*> ma = ConsDrawingT $ getConsDrawingT mf <*> getConsDrawingT ma----- Monad --instance Monad (ConsDrawing u) where-  return a = ConsDrawing $ return a-  m >>= k  = ConsDrawing $ getConsDrawing m >>= (getConsDrawing . k)---instance Monad m => Monad (ConsDrawingT u m) where-  return a = ConsDrawingT $ return a-  m >>= k  = ConsDrawingT $ getConsDrawingT m >>= (getConsDrawingT . k)---instance MonadT (ConsDrawingT u) where-  lift m = ConsDrawingT $ lift $ lift $ lift m---instance TurtleM (ConsDrawing u) where-  getLoc      = ConsDrawing $ getLoc-  setLoc c    = ConsDrawing $ setLoc c-  getOrigin   = ConsDrawing $ getOrigin-  setOrigin o = ConsDrawing $ setOrigin o--instance TurtleScaleM (ConsDrawing u) u where-  xStep    = ConsDrawing $ xStep-  yStep    = ConsDrawing $ yStep---instance Monad m => TurtleM (ConsDrawingT u m) where-  getLoc      = ConsDrawingT $ getLoc-  setLoc c    = ConsDrawingT $ setLoc c-  getOrigin   = ConsDrawingT $ getOrigin-  setOrigin o = ConsDrawingT $ setOrigin o---instance Monad m => TurtleScaleM (ConsDrawingT u m) u where-  xStep    = ConsDrawingT $ xStep-  yStep    = ConsDrawingT $ yStep---instance DrawingCtxM (ConsDrawing u) where-  askDrawingCtx   = ConsDrawing $ lift askDrawingCtx-  localCtx ctx ma = ConsDrawing $ localCtx ctx (getConsDrawing ma)-  --instance Monad m => DrawingCtxM (ConsDrawingT u m) where-  askDrawingCtx   = ConsDrawingT $ lift askDrawingCtx-  localCtx ctx ma = ConsDrawingT $ localCtx ctx (getConsDrawingT ma)--instance TraceM (ConsDrawing u) (Primitive u) where-  trace  a = ConsDrawing $ lift $ lift $ trace a-  trace1 a = ConsDrawing $ lift $ lift $ trace1 a--instance Monad m => TraceM (ConsDrawingT u m) (Primitive u) where-  trace  a = ConsDrawingT $ lift $ lift $ trace a-  trace1 a = ConsDrawingT $ lift $ lift $ trace1 a--runConsDrawing :: Num u -               => TurtleConfig u -               -> (Int,Int)-               -> DrawingAttr -               -> ConsDrawing u a -               -> (a, Graphic u)-runConsDrawing cfg ogin attr mf = runTrace -                                ( runDrawingCtxT attr-                                ( runTurtleT cfg ogin $ getConsDrawing mf ))---runConsDrawingT :: (Monad m, Num u) -                => TurtleConfig u -                -> (Int,Int)-                -> DrawingAttr -                -> ConsDrawingT u m a -                -> m (a, Graphic u)-runConsDrawingT cfg ogin attr mf = runTraceT -                                 ( runDrawingCtxT attr-                                 ( runTurtleT cfg ogin $ getConsDrawingT mf ))--execConsDrawing :: Num u -                => TurtleConfig u-                -> (Int,Int) -                -> DrawingAttr -                -> ConsDrawing u a -                -> Graphic u-execConsDrawing cfg ogin attr mf = snd $ runConsDrawing cfg ogin attr mf---execConsDrawingT :: (Monad m, Num u)-                 => TurtleConfig u -                 -> (Int,Int)-                 -> DrawingAttr -                 -> ConsDrawingT u m a -                 -> m (Graphic u)-execConsDrawingT cfg ogin attr mf = liftM snd $ runConsDrawingT cfg ogin attr mf

@@ -12,41 +12,147 @@ -- Stability   :  unstable -- Portability :  GHC  ----- Drawing operations+-- Graphic types and lifters... --+--+-- --------------------------------------------------------------------------------  module Wumpus.Basic.Monads.Drawing   (     -    MGraphicF -  , traceG+    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 -type MGraphicF m u a = Point2 u -> m a+-- | 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+       } -traceG :: (Monad m, TraceM m (Primitive u)) => GraphicF u -> MGraphicF m u ()-traceG fn = \pt -> trace (fn pt) --- MGraphic functions will have to trace themselves...+-- | 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 -node :: (TraceM m (Primitive u), TurtleScaleM m u, Num u) -     => MGraphicF m u a -> m a -node mgF = getPos >>= \pt -> mgF pt+-- /Free/ graphic+--+type AFreeGraphic u a = AGraphic () u a +type AConnector u a = Point2 u -> Point2 u -> AFreeGraphic u a -infixr 6 `at` +instance Functor (AGraphic pm u) where+  fmap f (AGraphic df mf) = AGraphic df (\pt attr -> f $ mf pt attr) -at :: (Num u, TraceM m (Primitive u), TurtleScaleM m u) -   => MGraphicF m u a -> (Int,Int) -> m a-at mgF coord = scaleCoord coord >>= \pt -> mgF pt+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)++ 

@@ -17,34 +17,17 @@ module Wumpus.Basic.Monads.DrawingCtxClass   ( -  -- * Re-exports from Wumpus.Basic.Graphic.DrawingAttr-    DrawingAttr(..)-  , standardAttr    -- * DrawingCtx class -  , DrawingCtxM(..)+    DrawingCtxM(..)   , withinModifiedCtx--  , strokeAttr-  , fillAttr-  , textAttr-  , markHeight--  , textDimensions      ) where -import Wumpus.Basic.Graphic.DrawingAttr ( DrawingAttr(..), standardAttr )-import qualified Wumpus.Basic.Graphic.DrawingAttr as DA--import Wumpus.Core                      -- package: wumpus-core--import Control.Monad+import Wumpus.Basic.Graphic.DrawingAttr  --- local to add? or new class...- class Monad m => DrawingCtxM m where   askDrawingCtx :: m DrawingAttr   localCtx      :: DrawingAttr -> m a -> m a@@ -55,20 +38,4 @@                   => (DrawingAttr -> DrawingAttr) -> m a -> m a withinModifiedCtx upd ma = askDrawingCtx >>= \ctx -> localCtx (upd ctx) ma --strokeAttr  :: DrawingCtxM m => m (DRGB, StrokeAttr)-strokeAttr  = liftM DA.strokeAttr askDrawingCtx---fillAttr    :: DrawingCtxM m => m DRGB-fillAttr    = liftM DA.fillAttr askDrawingCtx--textAttr    :: DrawingCtxM m => m  (DRGB, FontAttr)-textAttr    = liftM DA.textAttr askDrawingCtx--markHeight  :: (Fractional u, DrawingCtxM m) => m u-markHeight  = liftM DA.markHeight askDrawingCtx--textDimensions :: (Fractional u, DrawingCtxM m) => String -> m (u,u)-textDimensions str = liftM (DA.textDimensions str) askDrawingCtx 

@@ -1,121 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE UndecidableInstances       #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Monads.DrawingCtxMonad--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC ------ Reader (enviroment) monad for common drawing attributes.--------------------------------------------------------------------------------------module Wumpus.Basic.Monads.DrawingCtxMonad-  (---  -- * DrawingCtx monads-    DrawingCtx-  , DrawingCtxT     --  , runDrawingCtx-  , runDrawingCtxT--  -  ) where--import Wumpus.Basic.Monads.DrawingCtxClass-import Wumpus.Basic.Monads.TraceClass-import Wumpus.Basic.Monads.TurtleClass--import MonadLib ( MonadT(..) )          -- package: monadLib--import Control.Applicative-import Control.Monad---newtype DrawingCtx a = DrawingCtx  { getDrawingCtx  :: DrawingAttr -> a } --newtype DrawingCtxT m a = DrawingCtxT { getDrawingCtxT :: DrawingAttr -> m a }----- Functor--instance Functor DrawingCtx where-  fmap f m = DrawingCtx $ \r -> let a = getDrawingCtx m r in f a--instance Monad m => Functor (DrawingCtxT m) where-  fmap f m = DrawingCtxT $ \r -> getDrawingCtxT m r >>= \a ->-                                 return (f a)---- Applicative -instance Applicative DrawingCtx where-  pure a    = DrawingCtx $ \_ -> a-  mf <*> ma = DrawingCtx $ \r -> let f = getDrawingCtx mf r-                                     a = getDrawingCtx ma r-                                 in f a ---instance Monad m => Applicative (DrawingCtxT m) where-  pure a    = DrawingCtxT $ \_ -> return a-  mf <*> ma = DrawingCtxT $ \r -> getDrawingCtxT mf r  >>= \f ->-                                  getDrawingCtxT ma r  >>= \a ->-                                  return (f a) ----- Monad --instance Monad DrawingCtx where-  return a = DrawingCtx $ \_ -> a-  m >>= k  = DrawingCtx $ \r -> let a = getDrawingCtx m r-                                in (getDrawingCtx . k) a r--instance Monad m => Monad (DrawingCtxT m) where-  return a = DrawingCtxT $ \_ -> return a-  m >>= k  = DrawingCtxT $ \r -> getDrawingCtxT m r       >>= \a  ->-                                 (getDrawingCtxT . k) a r ---instance MonadT DrawingCtxT where-  lift m = DrawingCtxT $ \_ -> m >>= \a -> return a----instance DrawingCtxM DrawingCtx where-  askDrawingCtx    = DrawingCtx id-  localCtx ctx ma  = DrawingCtx $ \_ -> getDrawingCtx ma ctx  --instance Monad m => DrawingCtxM (DrawingCtxT m) where-  askDrawingCtx    = DrawingCtxT return-  localCtx ctx ma  = DrawingCtxT $ \_ -> getDrawingCtxT ma ctx  ---runDrawingCtx :: DrawingAttr -> DrawingCtx a -> a-runDrawingCtx cfg mf = getDrawingCtx mf cfg--runDrawingCtxT :: Monad m => DrawingAttr -> DrawingCtxT m a -> m a-runDrawingCtxT cfg mf = getDrawingCtxT mf cfg-------------------------------------------------------------------------------------- Cross instances--instance (Monad m, TraceM m i) => TraceM (DrawingCtxT m) i where-  trace a  = DrawingCtxT $ \_ -> trace a-  trace1 a = DrawingCtxT $ \_ -> trace1 a--instance TurtleM m => TurtleM (DrawingCtxT m) where-  getLoc          = DrawingCtxT $ \_ -> getLoc-  setLoc c        = DrawingCtxT $ \_ -> setLoc c-  getOrigin       = DrawingCtxT $ \_ -> getOrigin-  setOrigin o     = DrawingCtxT $ \_ -> setOrigin o--instance TurtleScaleM m u => TurtleScaleM (DrawingCtxT m) u where-  xStep           = DrawingCtxT $ \_ -> xStep-  yStep           = DrawingCtxT $ \_ -> yStep

@@ -0,0 +1,133 @@+{-# 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,128 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE UndecidableInstances       #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE TypeSynonymInstances       #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Monads.STraceMonad--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC ------ Snoc tracing monad--------------------------------------------------------------------------------------module Wumpus.Basic.Monads.STraceMonad-  (--    STrace-  , STraceT--  , runSTrace-  , runSTraceT- -  ) where--import Wumpus.Basic.Monads.DrawingCtxClass-import Wumpus.Basic.Monads.TraceClass-import Wumpus.Basic.Monads.TurtleClass--import Wumpus.Basic.Utils.HList--import MonadLib ( MonadT(..) )          -- package: monadLib--import Control.Applicative----newtype STrace  i   a = STrace  { getSTrace  :: H i -> (a, H i) }--newtype STraceT i m a = STraceT { getSTraceT :: H i -> m (a, H i) }---- Functor--instance Functor (STrace i) where-  fmap f m = STrace $ \w -> let (a,w') = getSTrace m w in (f a, w')--instance Monad m => Functor (STraceT i m) where-  fmap f m = STraceT $ \w -> getSTraceT m w >>= \(a,w') ->-                             return (f a, w')---- Applicative--instance Applicative (STrace i) where-  pure a    = STrace $ \w -> (a,w)-  mf <*> ma = STrace $ \w -> let (f,w')  = getSTrace mf w -                                 (a,w'') = getSTrace ma w'-                             in (f a,w'')---instance Monad m => Applicative (STraceT i m) where-  pure a    = STraceT $ \w -> return (a,w)-  mf <*> ma = STraceT $ \w -> getSTraceT mf w  >>= \(f,w')  ->-                              getSTraceT ma w' >>= \(a,w'') ->-                              return (f a,w'') ---- Monad--instance Monad (STrace i) where-  return a = STrace $ \w -> (a,w)-  m >>= k  = STrace $ \w -> let (a,w') = getSTrace m w-                            in (getSTrace . k) a w'-     ---instance Monad m => Monad (STraceT i m) where-  return a = STraceT $ \w -> return (a,w)-  m >>= k  = STraceT $ \w -> getSTraceT m w        >>= \(a,w')  ->-                             (getSTraceT . k) a w' >>= \(b,w'') ->-                             return (b,w'')-----instance MonadT (STraceT i) where -  lift m = STraceT $ \w -> m >>= \ a -> return (a,w)---instance TraceM (STrace i) i where-  trace  h = STrace $ \w -> ((), w . h)  -  trace1 i = STrace $ \w -> ((), w `snocH` i)  --instance Monad m => TraceM (STraceT i m) i where-  trace  h = STraceT $ \w -> return ((), w . h)  -  trace1 i = STraceT $ \w -> return ((), w `snocH` i)  ----runSTrace :: STrace i a -> (a,H i)-runSTrace mf = getSTrace mf id --runSTraceT :: Monad m => STraceT i m a -> m (a,H i)-runSTraceT mf = getSTraceT mf id >>= \(a,w) -> return (a,w)--------------------------------------------------------------------------------------- Cross instances--instance DrawingCtxM m => DrawingCtxM (STraceT i m) where-  askDrawingCtx   = STraceT $ \w -> askDrawingCtx >>= \ctx -> return (ctx,w)-  localCtx ctx mf = STraceT $ \w -> localCtx ctx (getSTraceT mf w)---instance TurtleM m => TurtleM (STraceT i m) where-  getLoc          = STraceT $ \w -> getLoc >>= \a -> return (a,w)-  setLoc c        = STraceT $ \w -> setLoc c >> return ((),w)-  getOrigin       = STraceT $ \w -> getOrigin >>= \a -> return (a,w)-  setOrigin o     = STraceT $ \w -> setOrigin o >> return ((),w)--instance TurtleScaleM m u => TurtleScaleM (STraceT i m) u where-  xStep           = STraceT $ \w -> xStep >>= \a -> return (a,w)-  yStep           = STraceT $ \w -> yStep >>= \a -> return (a,w)

@@ -1,175 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Monads.SnocDrawing--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC ------ STrace plus DrawingCtx plus Turtle...--------------------------------------------------------------------------------------module Wumpus.Basic.Monads.SnocDrawing-  (-    SnocDrawing-  , SnocDrawingT--  , runSnocDrawing-  , runSnocDrawingT-  , execSnocDrawing-  , execSnocDrawingT--  -- * Re-exports-  , module Wumpus.Basic.Monads.Drawing-  , module Wumpus.Basic.Monads.DrawingCtxClass-  , module Wumpus.Basic.Monads.TraceClass-  , module Wumpus.Basic.Monads.TurtleClass --  ) where--import Wumpus.Basic.Graphic-import Wumpus.Basic.Monads.Drawing-import Wumpus.Basic.Monads.DrawingCtxClass-import Wumpus.Basic.Monads.DrawingCtxMonad-import Wumpus.Basic.Monads.STraceMonad-import Wumpus.Basic.Monads.TraceClass-import Wumpus.Basic.Monads.TurtleClass-import Wumpus.Basic.Monads.TurtleMonad--import Wumpus.Core                      -- package: wumpus-core--import MonadLib ( MonadT(..) )          -- package: monadLib--import Control.Applicative-import Control.Monad---newtype SnocDrawing u a = SnocDrawing { -          getSnocDrawing  :: TurtleT           u-                           ( DrawingCtxT -                           ( STrace (Primitive u))) a }--newtype SnocDrawingT u m a = SnocDrawingT { -          getSnocDrawingT :: TurtleT            u-                           ( DrawingCtxT -                           ( STraceT (Primitive u) m)) a }----- Functor--instance Functor (SnocDrawing u) where-  fmap f = SnocDrawing . fmap f . getSnocDrawing--instance Monad m => Functor (SnocDrawingT u m) where-  fmap f = SnocDrawingT . fmap f . getSnocDrawingT----- Applicative -instance Applicative (SnocDrawing u) where-  pure a    = SnocDrawing $ pure a-  mf <*> ma = SnocDrawing $ getSnocDrawing mf <*> getSnocDrawing ma-                   ---instance Monad m => Applicative (SnocDrawingT u m) where-  pure a    = SnocDrawingT $ pure a-  mf <*> ma = SnocDrawingT $ getSnocDrawingT mf <*> getSnocDrawingT ma----- Monad --instance Monad (SnocDrawing u) where-  return a = SnocDrawing $ return a-  m >>= k  = SnocDrawing $ getSnocDrawing m >>= (getSnocDrawing . k)---instance Monad m => Monad (SnocDrawingT u m) where-  return a = SnocDrawingT $ return a-  m >>= k  = SnocDrawingT $ getSnocDrawingT m >>= (getSnocDrawingT . k)---instance MonadT (SnocDrawingT u) where-  lift m = SnocDrawingT $ lift $ lift $ lift m---instance TurtleM (SnocDrawing u) where-  getLoc      = SnocDrawing $ getLoc-  setLoc c    = SnocDrawing $ setLoc c-  getOrigin   = SnocDrawing $ getOrigin-  setOrigin o = SnocDrawing $ setOrigin o--instance TurtleScaleM (SnocDrawing u) u where-  xStep    = SnocDrawing $ xStep-  yStep    = SnocDrawing $ yStep--instance Monad m => TurtleM (SnocDrawingT u m) where-  getLoc      = SnocDrawingT $ getLoc-  setLoc c    = SnocDrawingT $ setLoc c-  getOrigin   = SnocDrawingT $ getOrigin-  setOrigin o = SnocDrawingT $ setOrigin o---instance Monad m => TurtleScaleM (SnocDrawingT u m) u where-  xStep    = SnocDrawingT $ xStep-  yStep    = SnocDrawingT $ yStep--instance DrawingCtxM (SnocDrawing u) where-  askDrawingCtx   = SnocDrawing $ askDrawingCtx-  localCtx ctx ma = SnocDrawing $ localCtx ctx (getSnocDrawing ma)--instance Monad m => DrawingCtxM (SnocDrawingT u m) where-  askDrawingCtx   = SnocDrawingT $ askDrawingCtx-  localCtx ctx ma = SnocDrawingT $ localCtx ctx (getSnocDrawingT ma)--instance TraceM (SnocDrawing u) (Primitive u) where-  trace  a = SnocDrawing $ lift $ lift $ trace a-  trace1 a = SnocDrawing $ lift $ lift $ trace1 a--instance Monad m => TraceM (SnocDrawingT u m) (Primitive u) where-  trace  a = SnocDrawingT $ lift $ lift $ trace a-  trace1 a = SnocDrawingT $ lift $ lift $ trace1 a--runSnocDrawing :: Num u -               => TurtleConfig u -               -> (Int,Int)-               -> DrawingAttr -               -> SnocDrawing u a -               -> (a, Graphic u)-runSnocDrawing cfg ogin attr mf = runSTrace -                                ( runDrawingCtxT attr-                                ( runTurtleT cfg ogin $ getSnocDrawing mf ))---runSnocDrawingT :: (Monad m, Num u) -                => TurtleConfig u-                -> (Int,Int) -                -> DrawingAttr -                -> SnocDrawingT u m a -                -> m (a, Graphic u)-runSnocDrawingT cfg ogin attr mf = runSTraceT -                                 ( runDrawingCtxT attr-                                 ( runTurtleT cfg ogin $ getSnocDrawingT mf ))--execSnocDrawing :: Num u -                => TurtleConfig u -                -> (Int,Int)-                -> DrawingAttr -                -> SnocDrawing u a -                -> Graphic u-execSnocDrawing cfg ogin attr mf = snd $ runSnocDrawing cfg ogin attr mf---execSnocDrawingT :: (Monad m, Num u)-                 => TurtleConfig u -                 -> (Int,Int)-                 -> DrawingAttr -                 -> SnocDrawingT u m a -                 -> m (Graphic u)-execSnocDrawingT cfg ogin attr mf = liftM snd $ runSnocDrawingT cfg ogin attr mf

@@ -25,10 +25,9 @@   ) where  -import Wumpus.Basic.Utils.HList+import Wumpus.Basic.Graphic  -class TraceM  m i | m -> i where-  trace  :: H i -> m ()-  trace1 :: i -> m ()+class TraceM  m u | m -> u where+  trace  :: Graphic u -> m () 

@@ -1,138 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE UndecidableInstances       #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE TypeSynonymInstances       #-}-{-# OPTIONS -Wall #-}-------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Monads.TraceMonad--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC ------ \"Trace\" monad and monad transformer.------ Trace is operationally similar to the Writer monad but it--- supports elementary consing as well as the Writer\'s monoidal --- concatenation. ------ Note, some care is needed to order the output to a trace with--- respect to the Z-order of a drawing. The API here may well--- be too limited... --- -----------------------------------------------------------------------------------module Wumpus.Basic.Monads.TraceMonad-  (--    Trace-  , TraceT--  , runTrace-  , runTraceT- -  ) where--import Wumpus.Basic.Monads.DrawingCtxClass-import Wumpus.Basic.Monads.TraceClass-import Wumpus.Basic.Monads.TurtleClass-import Wumpus.Basic.Utils.HList---import MonadLib ( MonadT(..) )          -- package: monadLib--import Control.Applicative----newtype Trace  i   a = Trace  { getTrace  :: H i -> (a, H i) }--newtype TraceT i m a = TraceT { getTraceT :: H i -> m (a, H i) }---- Functor--instance Functor (Trace i) where-  fmap f m = Trace $ \w -> let (a,w') = getTrace m w in (f a, w')--instance Monad m => Functor (TraceT i m) where-  fmap f m = TraceT $ \w -> getTraceT m w >>= \(a,w') ->-                            return (f a, w')---- Applicative--instance Applicative (Trace i) where-  pure a    = Trace $ \w -> (a,w)-  mf <*> ma = Trace $ \w -> let (f,w')  = getTrace mf w -                                (a,w'') = getTrace ma w'-                            in (f a,w'')---instance Monad m => Applicative (TraceT i m) where-  pure a    = TraceT $ \w -> return (a,w)-  mf <*> ma = TraceT $ \w -> getTraceT mf w  >>= \(f,w')  ->-                             getTraceT ma w' >>= \(a,w'') ->-                             return (f a,w'') ---- Monad--instance Monad (Trace i) where-  return a = Trace $ \w -> (a,w)-  m >>= k  = Trace $ \w -> let (a,w') = getTrace m w-                           in (getTrace . k) a w'-     ---instance Monad m => Monad (TraceT i m) where-  return a = TraceT $ \w -> return (a,w)-  m >>= k  = TraceT $ \w -> getTraceT m w        >>= \(a,w')  ->-                            (getTraceT . k) a w' >>= \(b,w'') ->-                            return (b,w'')-----instance MonadT (TraceT i) where -  lift m = TraceT $ \w -> m >>= \ a -> return (a,w)---instance TraceM (Trace i) i where-  trace  h = Trace $ \w -> ((), h . w)  -  trace1 i = Trace $ \w -> ((), i `consH` w)  --instance Monad m => TraceM (TraceT i m) i where-  trace  h = TraceT $ \w -> return ((), h . w)  -  trace1 i = TraceT $ \w -> return ((), i `consH` w)  ----runTrace :: Trace i a -> (a,H i)-runTrace mf = getTrace mf id --runTraceT :: Monad m => TraceT i m a -> m (a,H i)-runTraceT mf = getTraceT mf id >>= \(a,w) -> return (a,w)-------------------------------------------------------------------------------------- Cross instances--instance DrawingCtxM m => DrawingCtxM (TraceT i m) where-  askDrawingCtx   = TraceT $ \w -> askDrawingCtx >>= \ ctx -> return (ctx,w)-  localCtx ctx mf = TraceT $ \w -> localCtx ctx (getTraceT mf w)---instance TurtleM m => TurtleM (TraceT i m) where-  getLoc          = TraceT $ \w -> getLoc >>= \a -> return (a,w)-  setLoc c        = TraceT $ \w -> setLoc c >> return ((),w)-  getOrigin       = TraceT $ \w -> getOrigin >>= \a -> return (a,w)-  setOrigin o     = TraceT $ \w -> setOrigin o >> return ((),w)--instance TurtleScaleM m u => TurtleScaleM (TraceT i m) u where-  xStep           = TraceT $ \w -> xStep >>= \a -> return (a,w)-  yStep           = TraceT $ \w -> yStep >>= \a -> return (a,w)- -

@@ -35,11 +35,18 @@   , runTurtle   , runTurtleT - ++  , TurtleDrawing+  , runTurtleDrawing+  , execTurtleDrawing++  , module Wumpus.Basic.Monads.DrawingMonad+  , module Wumpus.Basic.Monads.TurtleClass+      ) where -import Wumpus.Basic.Monads.DrawingCtxClass-import Wumpus.Basic.Monads.TraceClass+import Wumpus.Basic.Graphic+import Wumpus.Basic.Monads.DrawingMonad import Wumpus.Basic.Monads.TurtleClass  @@ -155,7 +162,69 @@  instance (Monad m, TraceM m i) => TraceM (TurtleT u m) i where   trace a  = TurtleT $ \_ s -> trace a >> return ((),s)-  trace1 a = TurtleT $ \_ s -> trace1 a >> return ((),s)  +--------------------------------------------------------------------------------++newtype TurtleDrawing u a = TurtleDrawing { +          getTurtleDrawing :: TurtleT u (Drawing u) a }++instance Functor (TurtleDrawing u) where+  fmap f = TurtleDrawing . fmap f . getTurtleDrawing++-- Applicative +instance Applicative (TurtleDrawing u) where+  pure a    = TurtleDrawing $ pure a+  mf <*> ma = TurtleDrawing $ getTurtleDrawing mf <*> getTurtleDrawing ma+++-- Monad ++instance Monad (TurtleDrawing u) where+  return a = TurtleDrawing $ return a+  m >>= k  = TurtleDrawing $ getTurtleDrawing m >>= (getTurtleDrawing . k)++-- TurtleM++instance TurtleM (TurtleDrawing u) where+  getLoc      = TurtleDrawing $ getLoc +  setLoc c    = TurtleDrawing $ setLoc c+  getOrigin   = TurtleDrawing $ getOrigin+  setOrigin o = TurtleDrawing $ setOrigin o++instance TurtleScaleM (TurtleDrawing u) u where+  xStep    = TurtleDrawing $ xStep+  yStep    = TurtleDrawing $ yStep++-- TraceM ++instance TraceM (TurtleDrawing u) u where+  trace a = TurtleDrawing $ lift (trace a)+++-- DrawingCtxM++instance DrawingCtxM (TurtleDrawing u) where+  askDrawingCtx   = TurtleDrawing $ lift askDrawingCtx+  localCtx ctx ma = TurtleDrawing $ localCtx ctx (getTurtleDrawing ma)+++runTurtleDrawing :: Num u +                 => TurtleConfig u +                 -> (Int,Int)+                 -> DrawingAttr +                 -> TurtleDrawing u a +                 -> (a, Graphic u)+runTurtleDrawing cfg ogin attr mf = +    runDrawing attr ( runTurtleT cfg ogin $ getTurtleDrawing mf)+++execTurtleDrawing :: Num u +                  => TurtleConfig u+                  -> (Int,Int) +                  -> DrawingAttr +                  -> TurtleDrawing u a +                  -> Graphic u+execTurtleDrawing cfg ogin attr mf = +    snd $ runTurtleDrawing cfg ogin attr mf 

@@ -0,0 +1,165 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Paths+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Extended path type - more amenable for complex drawings than+-- the type in Wumpus-Core.+--+-- \*\* WARNING \*\* this module is an experiment, and may +-- change significantly or even be dropped from future revisions.+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.Paths +  ( ++    connectS+  , pathGraphic++  , shorten+  , shortenL+  , shortenR+  , midpoint+  , directionL+  , directionR++  ) where++import Wumpus.Basic.Graphic+import Wumpus.Basic.Graphic.DrawingAttr+import Wumpus.Basic.Paths.Base+import Wumpus.Basic.Paths.Construction++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space++import Data.Sequence++++connectS :: Floating u => BPathF u+connectS = \p0 p1 -> execPath p0 $ lineto p1++++-- This one might be more useful...++pathGraphic :: Num u => BPath u -> DrawingAttr -> Graphic u+pathGraphic bpath attr = wrapG $ ostroke (strokeAttr attr) $ toPathU bpath+++++shorten  :: (Real u, Floating u, Ord u) => u -> BPath u -> BPath u+shorten u p = shortenL u $ shortenR u p++--------------------------------------------------------------------------------+-- shorten from the left...++shortenL :: (Real u, Floating u, Ord u) => u -> BPath u -> BPath u+shortenL n (BPath u bp) | n >= u         = emptyPath+                        | otherwise      = step n (viewl bp)+  where+    step _ EmptyL     = emptyPath+    step d (e :< se)  = let z = segmentLength e in+                        case compare d z of+                          GT -> step (d-z) (viewl se)+                          EQ -> BPath (u-n) se+                          _  -> BPath (u-n) (shortenSegL d e <| se)+++shortenSegL :: (Real u, Floating u) => u -> BPathSeg u -> BPathSeg u+shortenSegL n (BLineSeg  u l) = BLineSeg  (u-n) (shortenLineL n l) +shortenSegL n (BCurveSeg u c) = BCurveSeg (u-n) (snd $ subdividet (n/u) c)++shortenLineL :: (Real u, Floating u) => u -> Line u -> Line u+shortenLineL n (Line p1 p2) = Line (p1 .+^ v) p2+  where+    v0 = p2 .-. p1+    v  = avec (direction v0) n+    +--------------------------------------------------------------------------------+-- shorten from the right ...+ +shortenR :: (Real u, Floating u, Ord u) => u -> BPath u -> BPath u+shortenR n (BPath u bp) | n >= u         = emptyPath+                        | otherwise      = step n (viewr bp)+  where+    step _ EmptyR     = emptyPath+    step d (se :> e)  = let z = segmentLength e in+                        case compare d z of+                          GT -> step (d-z) (viewr se)+                          EQ -> BPath (u-n) se+                          _  -> BPath (u-n) (se |> shortenSegR d e)++++shortenSegR :: (Real u, Floating u) => u -> BPathSeg u -> BPathSeg u+shortenSegR n (BLineSeg  u l) = BLineSeg  (u-n) (shortenLineR n l) +shortenSegR n (BCurveSeg u c) = BCurveSeg (u-n) (fst $ subdividet ((u-n)/u) c)+++shortenLineR :: (Real u, Floating u) => u -> Line u -> Line u+shortenLineR n (Line p1 p2) = Line p1 (p2 .+^ v)+  where+    v0 = p1 .-. p2+    v  = avec (direction v0) n++++--------------------------------------------------------------------------------++midpoint :: (Real u, Floating u) => BPath u -> Point2 u+midpoint (BPath u bp) = step (u/2) (viewl bp)+  where+    step _ EmptyL    = zeroPt+    step d (e :< se) = let z = segmentLength e in+                       case compare d z of+                         GT -> step (d-z) (viewl se)+                         EQ -> segmentEnd e+                         _  -> segmentEnd $ shortenSegL d e ++++++--------------------------------------------------------------------------------+-- tangents+++directionL :: (Real u, Floating u) => BPath u -> Radian+directionL (BPath _ se) = step $ viewl se+  where+    step (BLineSeg  _ l :< _) = lineDirectionL l +    step (BCurveSeg _ c :< _) = curveDirectionL c+    step _                    = 0++directionR :: (Real u, Floating u) => BPath u -> Radian+directionR (BPath _ se) = step $ viewr se+  where+    step (_ :> BLineSeg  _ l) = lineDirectionR l +    step (_ :> BCurveSeg _ c) = curveDirectionR c+    step _                    = 0+++lineDirectionL :: (Real u, Floating u) => Line u -> Radian+lineDirectionL (Line p0 p1) = direction (pvec p1 p0)++lineDirectionR :: (Real u, Floating u) => Line u -> Radian+lineDirectionR (Line p0 p1) = direction (pvec p0 p1)++curveDirectionL :: (Real u, Floating u) => Curve u -> Radian+curveDirectionL (Curve p0 p1 _ _) = direction $ pvec p1 p0++curveDirectionR :: (Real u, Floating u) => Curve u -> Radian+curveDirectionR (Curve _ _ p2 p3) = direction $ pvec p2 p3+ 

@@ -0,0 +1,216 @@+{-# LANGUAGE FlexibleContexts           #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Paths.Base+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Extended path type - more amenable for complex drawings than+-- the type in Wumpus-Core.+--+-- \*\* WARNING \*\* this module is an experiment, and may +-- change significantly or even be dropped from future revisions.+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.Paths.Base+  ( ++    BPathF++  , BPath(..)+  , BPathSeg(..)+  , Curve(..)+  , Line(..)+  , emptyPath+  , pline+  , pcurve+  , addSegment+  , segmentLength+  , segmentStart+  , segmentEnd++  , toPath +  , toPathU+  , subdivide+  , subdividet+    +  ) where++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace+import Data.VectorSpace++import Data.Maybe+import Data.Sequence ( Seq, ViewL(..), viewl, (|>)  )+import qualified Data.Sequence as S+++type BPathF u = Point2 u -> Point2 u -> BPath u+++data BPath u = BPath +       { path_length    :: u +       , path_elements  :: Seq (BPathSeg u)+       }+  deriving (Eq,Ord,Show)+++-- Annotation is length...+-- +data BPathSeg u = BLineSeg  u (Line u)+                | BCurveSeg u (Curve u)+  deriving (Eq,Ord,Show)+++data Curve u = Curve +      { curve_start :: Point2 u+      , ctrl_point1 :: Point2 u+      , ctrl_point2 :: Point2 u+      , curve_end   :: Point2 u+      }+  deriving (Eq,Ord,Show)++data Line u = Line +      { line_start  :: Point2 u+      , line_end    :: Point2 u +      }+  deriving (Eq,Ord,Show)+++emptyPath :: Num u => BPath u +emptyPath = BPath 0 S.empty+++addSegment :: Num u => BPath u -> BPathSeg u -> BPath u+addSegment (BPath n se) e@(BLineSeg u _)  = BPath (n+u) (se |> e)+addSegment (BPath n se) e@(BCurveSeg u _) = BPath (n+u) (se |> e)++segmentLength :: BPathSeg u -> u+segmentLength (BLineSeg  u _) = u+segmentLength (BCurveSeg u _) = u++segmentStart :: BPathSeg u -> Point2 u+segmentStart (BLineSeg  _ (Line p0 _))      = p0+segmentStart (BCurveSeg _ (Curve p0 _ _ _)) = p0++segmentEnd :: BPathSeg u -> Point2 u+segmentEnd (BLineSeg  _ (Line _ p1))      = p1+segmentEnd (BCurveSeg _ (Curve _ _ _ p3)) = p3+++++pline :: Floating u => Point2 u -> Point2 u -> BPathSeg u +pline p0 p1 = BLineSeg (vlength $ pvec p0 p1) (Line p0 p1)++pcurve :: (Floating u, Ord u)+       => Point2 u -> Point2 u -> Point2 u -> Point2 u -> BPathSeg u +pcurve p0 p1 p2 p3 = +    let c = Curve p0 p1 p2 p3 in BCurveSeg (curveLength c) c+++-- | Turn a BasicPath into an ordinary Path.+--+-- An empty path returns Nothing - the path representation in +-- Wumpus-Core does not allow empty paths - a path must always+-- have at least start point.+--+-- Assumes path is properly formed - i.e. end point of one +-- segment is the same point as the start point of the next+-- segment.+--+toPath :: BPath u -> Maybe (Path u)+toPath = step1 . viewl . path_elements+  where+    step1 EmptyL               = Nothing+    step1 (e :< se)            = let (p1,s) = elemP e in +                                 Just $ path p1 $ s : step2 (viewl se)++    step2 EmptyL               = []+    step2 (e :< se)            = snd (elemP e) : step2 (viewl se)+    +    elemP (BLineSeg  _ l)      = elemL l+    elemP (BCurveSeg _ c)      = elemC c+ +    elemL (Line p1 p2)         = (p1, lineTo p2)+    elemC (Curve p1 p2 p3 p4)  = (p1, curveTo p2 p3 p4)++toPathU :: BPath u -> Path u+toPathU = fromMaybe errK . toPath+  where+    errK = error "toPathU - empty Path"++++--------------------------------------------------------------------------------+-- Curve length++curveLength :: (Floating u, Ord u) => Curve u -> u+curveLength = gravesenLength 0.1++-- | Jens Gravesen\'s bezier arc-length approximation. +--+-- Note this implementation is parametrized on error tolerance.+--+gravesenLength :: (Floating u, Ord u) => u -> Curve u -> u+gravesenLength err_tol crv = step crv where+  step c = let l1 = ctrlPolyLength c+               l0 = cordLength c+           in if   l1-l0 > err_tol+              then let (a,b) = subdivide c in step a + step b+              else 0.5*l0 + 0.5*l1+++ctrlPolyLength :: Floating u => Curve u -> u+ctrlPolyLength (Curve p0 p1 p2 p3) = len p0 p1 + len p1 p2 + len p2 p3+  where+    len pa pb = vlength $ pvec pa pb++cordLength :: Floating u => Curve u -> u+cordLength (Curve p0 _ _ p3) = vlength $ pvec p0 p3+++-- | midpoint between two points+--+pointMidpoint :: Fractional u => Point2 u -> Point2 u -> Point2 u+pointMidpoint p0 p1 = p0 .+^ v1 ^/ 2 where v1 = p1 .-. p0+++-- | Curve subdivision via de Casteljau\'s algorithm.+--+subdivide :: Fractional u => Curve u -> (Curve u, Curve u)+subdivide (Curve p0 p1 p2 p3) =+    (Curve p0 p01 p012 p0123, Curve p0123 p123 p23 p3)+  where+    p01   = pointMidpoint p0    p1+    p12   = pointMidpoint p1    p2+    p23   = pointMidpoint p2    p3+    p012  = pointMidpoint p01   p12+    p123  = pointMidpoint p12   p23+    p0123 = pointMidpoint p012  p123++-- | subdivide with an affine weight along the line...+--+subdividet :: Real u+           => u -> Curve u -> (Curve u, Curve u)+subdividet t (Curve p0 p1 p2 p3) = +    (Curve p0 p01 p012 p0123, Curve p0123 p123 p23 p3)+  where+    p01   = affineCombination t p0    p1+    p12   = affineCombination t p1    p2+    p23   = affineCombination t p2    p3+    p012  = affineCombination t p01   p12+    p123  = affineCombination t p12   p23+    p0123 = affineCombination t p012  p123++affineCombination :: Real u => u -> Point2 u -> Point2 u -> Point2 u+affineCombination a p1 p2 = p1 .+^ a *^ (p2 .-. p1)+

@@ -0,0 +1,124 @@+{-# LANGUAGE FlexibleContexts           #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Paths.Construction+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Build paths.+--+-- \*\* WARNING \*\* this module is an experiment, and may +-- change significantly or even be dropped from future revisions.+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.Paths.Construction+  ( ++    MPath+  , CPath+  , runPath+  , execPath+  , lineto+  , bezierto+  , curveto+  , verticalHorizontal+  , horizontalVertical++  ) where++import Wumpus.Basic.Paths.Base++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space++import Control.Applicative++data PathState u = PathState +      { current_point :: Point2 u +      , path_accum    :: BPath u+      }++newtype MPath u a = MPath { getMPath :: PathState u -> (a,PathState u) }++type CPath u = MPath u ()++instance Functor (MPath u) where+  fmap f mf = MPath $ \s -> let (a,s') = getMPath mf s in (f a,s')+++instance Applicative (MPath u) where+  pure a    = MPath $ \s -> (a,s)+  mf <*> ma = MPath $ \s -> let (f,s')  = getMPath mf s+                                (a,s'') = getMPath ma s'+                            in (f a,s'')++instance Monad (MPath u) where+  return a  = MPath $ \s -> (a,s)+  m >>= k   = MPath $ \s -> let (a,s') = getMPath m s in+                            (getMPath . k) a s'+++runPath :: Num u => Point2 u -> MPath u a -> (a, BPath u)+runPath start mf = let (a,s') = getMPath mf s in (a, path_accum s')+  where+    s = PathState { current_point = start+                  , path_accum    = emptyPath+                  }++execPath :: Num u => Point2 u -> MPath u a -> BPath u+execPath start mf = snd $ runPath start mf+++exchTip :: Point2 u -> (Point2 u -> BPath u -> BPath u) -> MPath u ()+exchTip new updP = +    MPath $ \(PathState old bp) -> ((), PathState new (updP old bp)) ++tip :: MPath u (Point2 u)+tip = MPath $ \s -> (current_point s,s)+++lineto :: Floating u => Point2 u -> CPath u+lineto end = exchTip end upd+  where+    upd start bp = bp `addSegment` pline start end++++bezierto :: (Floating u, Ord u) +         => Point2 u -> Point2 u -> Point2 u -> CPath u+bezierto cp1 cp2 end = exchTip end upd +  where+    upd start bp = bp `addSegment` pcurve start cp1 cp2 end+++curveto :: (Floating u, Ord u) +        => Radian -> Radian -> Point2 u -> CPath u+curveto cin cout end = exchTip end upd+  where +    upd start bp = bp `addSegment` pcurveAng start cin cout end+++pcurveAng :: (Floating u, Ord u) +        => Point2 u -> Radian -> Radian -> Point2 u -> BPathSeg u+pcurveAng start cin cout end = pcurve start (start .+^ v1) (end .+^ v2) end+  where+    sz     = 0.375 * (vlength $ pvec start end)+    v1     = avec cin  sz+    v2     = avec cout sz+++verticalHorizontal :: Floating u => Point2 u -> CPath u+verticalHorizontal (P2 x y) = +    tip >>= \(P2 x0 _) -> lineto (P2 x0 y) >> lineto (P2 x y)++horizontalVertical :: Floating u => Point2 u -> CPath u+horizontalVertical (P2 x y) = +    tip >>= \(P2 _ y0) -> lineto (P2 x y0) >> lineto (P2 x y)

@@ -56,74 +56,74 @@ -------------------------------------------------------------------------------- -- Times-Roman -timesRoman :: Int -> FontAttr-timesRoman = FontAttr "Times-Roman" "Times New Roman" SVG_REGULAR+timesRoman :: FontFace+timesRoman = FontFace "Times-Roman" "Times New Roman" SVG_REGULAR  -- Times Italic -timesItalic :: Int -> FontAttr-timesItalic = FontAttr "Times-Italic" "Times New Roman" SVG_ITALIC+timesItalic :: FontFace+timesItalic = FontFace "Times-Italic" "Times New Roman" SVG_ITALIC  -- Times Bold -timesBold :: Int -> FontAttr-timesBold = FontAttr "Times-Bold" "Times New Roman" SVG_BOLD+timesBold :: FontFace+timesBold = FontFace "Times-Bold" "Times New Roman" SVG_BOLD  -- Times Bold Italic -timesBoldItalic :: Int -> FontAttr+timesBoldItalic :: FontFace timesBoldItalic = -    FontAttr "Times-BoldItalic" "Times New Roman" SVG_BOLD_ITALIC+    FontFace "Times-BoldItalic" "Times New Roman" SVG_BOLD_ITALIC   -------------------------------------------------------------------------------- -- Helvetica -helvetica :: Int -> FontAttr-helvetica = FontAttr "Helvetica" "Helvetica" SVG_REGULAR+helvetica :: FontFace+helvetica = FontFace "Helvetica" "Helvetica" SVG_REGULAR   -- Helvetica Oblique -helveticaOblique :: Int -> FontAttr-helveticaOblique = FontAttr "Helvetica-Oblique" "Helvetica" SVG_OBLIQUE+helveticaOblique :: FontFace+helveticaOblique = FontFace "Helvetica-Oblique" "Helvetica" SVG_OBLIQUE  -- Helvetica Bold -helveticaBold :: Int -> FontAttr-helveticaBold = FontAttr "Helvetica-Bold" "Helvetica" SVG_BOLD+helveticaBold :: FontFace+helveticaBold = FontFace "Helvetica-Bold" "Helvetica" SVG_BOLD   -- Helvetica Bold Oblique -helveticaBoldOblique :: Int -> FontAttr+helveticaBoldOblique :: FontFace helveticaBoldOblique = -    FontAttr "Helvetica-Bold-Oblique" "Helvetica" SVG_BOLD_OBLIQUE+    FontFace "Helvetica-Bold-Oblique" "Helvetica" SVG_BOLD_OBLIQUE    -------------------------------------------------------------------------------- -- Courier -courier :: Int -> FontAttr-courier = FontAttr "Courier" "Courier New" SVG_REGULAR+courier :: FontFace+courier = FontFace "Courier" "Courier New" SVG_REGULAR  -- Courier Oblique -courierOblique :: Int -> FontAttr-courierOblique = FontAttr "Courier-Oblique" "Courier New" SVG_OBLIQUE+courierOblique :: FontFace+courierOblique = FontFace "Courier-Oblique" "Courier New" SVG_OBLIQUE  -- Courier Bold -courierBold :: Int -> FontAttr-courierBold = FontAttr "Courier-Bold" "Courier New" SVG_BOLD+courierBold :: FontFace+courierBold = FontFace "Courier-Bold" "Courier New" SVG_BOLD   -- Courier Bold Oblique -courierBoldOblique :: Int -> FontAttr+courierBoldOblique :: FontFace courierBoldOblique = -    FontAttr "Courier-Bold-Oblique" "Courier New" SVG_BOLD_OBLIQUE+    FontFace "Courier-Bold-Oblique" "Courier New" SVG_BOLD_OBLIQUE  -------------------------------------------------------------------------------- -- Symbol@@ -132,8 +132,8 @@ -- Symbol does not appear to be well supported by SVG. -- It renders in Chrome but not in Firefox. -symbol :: Int -> FontAttr-symbol = FontAttr "Symbol" "Symbol" SVG_REGULAR+symbol :: FontFace+symbol = FontFace "Symbol" "Symbol" SVG_REGULAR   

@@ -0,0 +1,203 @@+{-# 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'+

@@ -0,0 +1,189 @@+{-# 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.+-- +--------------------------------------------------------------------------------++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, DRGB)++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 -> (DRGB,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 }

@@ -0,0 +1,60 @@+{-# 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)++

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

@@ -527,7 +527,7 @@ -- -- An error is throw if the list of strings is empty -- -multilabel :: (Real u, Floating u, TextLabel t) +multilabel :: (Real u, Floating u, FromPtSize u, TextLabel t)             => t -> u -> VAlign -> [String] -> Point2 u -> Picture u multilabel _    _ _  []     _  = error $      "Wumpus.Core.PictureLanguage.multilabel - empty list."

@@ -1,5 +1,5 @@ name:             wumpus-basic-version:          0.3.0+version:          0.4.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -20,6 +20,17 @@   .   Changelog:   .+  0.3.0 to 0.4.0:+  .+  * Reworked the monads. Monads.DrawingMonad replaces +    Monads.Trace, Monads.DrawingCtx, Monads.ConsDrawing. The +    SnocDrawing monads have been removed as they were a design+    mistake.+  .+  * Removed MGraphicF type, added AGraphic.+  .+  * Initial work on arrow drawing and extended text drawing.+  .   0.2.0 to 0.3.0 :   .    * Added the anchors, monads, drawingAttrs...@@ -59,34 +70,39 @@ library   hs-source-dirs:     src   build-depends:      base            <  5, +                      containers      >= 0.3     && <= 0.4,                        vector-space    >= 0.6,                       monadLib        >= 3.6,-                      wumpus-core     >= 0.21.0+                      wumpus-core     >= 0.23.0       exposed-modules:     Wumpus.Basic.Anchors,-    Wumpus.Basic.AnchorDots,+    Wumpus.Basic.Arrows,+    Wumpus.Basic.Arrows.Tips,     Wumpus.Basic.Dots,+    Wumpus.Basic.Dots.Base,     Wumpus.Basic.Graphic,     Wumpus.Basic.Graphic.DrawingAttr,     Wumpus.Basic.Graphic.PointSupply,-    Wumpus.Basic.Monads.ConsDrawing,     Wumpus.Basic.Monads.Drawing,+    Wumpus.Basic.Monads.DrawingMonad,     Wumpus.Basic.Monads.DrawingCtxClass,-    Wumpus.Basic.Monads.DrawingCtxMonad,-    Wumpus.Basic.Monads.STraceMonad,-    Wumpus.Basic.Monads.SnocDrawing,     Wumpus.Basic.Monads.TraceClass,-    Wumpus.Basic.Monads.TraceMonad,     Wumpus.Basic.Monads.TurtleClass,     Wumpus.Basic.Monads.TurtleMonad,+    Wumpus.Basic.Paths,+    Wumpus.Basic.Paths.Base,+    Wumpus.Basic.Paths.Construction,     Wumpus.Basic.SafeFonts,     Wumpus.Basic.SVGColours,-    Wumpus.Basic.X11Colours,+    Wumpus.Basic.Text.LRSymbol,+    Wumpus.Basic.Text.LRText,+    Wumpus.Basic.Utils.Combinators,     Wumpus.Basic.Utils.HList,     Wumpus.Basic.Utils.Intersection,     Wumpus.Basic.VersionNumber,+    Wumpus.Basic.X11Colours,     Wumpus.Deprecated.PictureLanguage    other-modules: