wumpus-basic 0.9.0 → 0.10.0

raw patch · 38 files changed

+1644/−1023 lines, 38 filesdep ~wumpus-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: wumpus-core

API changes (from Hackage documentation)

Files

• CHANGES +74/−0
• demo/ClipPic.hs +5/−3
• demo/ColourCharts.hs +1/−1
• demo/ColourDefns.hs +1/−1
• demo/DotPic.hs +3/−3
• demo/FontPic.hs +3/−3
• demo/PetriNet.hs +125/−0
• demo/Picture.hs +3/−3
• demo/Shapes.hs +1/−105
• demo/Symbols.hs +1/−1
• src/Wumpus/Basic/Anchors.hs +1/−8
• src/Wumpus/Basic/Arrows.hs +39/−23
• src/Wumpus/Basic/Arrows/Tips.hs +94/−14
• src/Wumpus/Basic/Colour/SVGColours.hs +2/−2
• src/Wumpus/Basic/Colour/X11Colours.hs +2/−2
• src/Wumpus/Basic/Dots.hs +4/−4
• src/Wumpus/Basic/Dots/Primitive.hs +15/−13
• src/Wumpus/Basic/Graphic.hs +4/−4
• src/Wumpus/Basic/Graphic/Base.hs +334/−0
• src/Wumpus/Basic/Graphic/BaseClasses.hs +0/−87
• src/Wumpus/Basic/Graphic/BaseTypes.hs +0/−301
• src/Wumpus/Basic/Graphic/DirectionContext.hs +140/−0
• src/Wumpus/Basic/Graphic/Drawing.hs +9/−10
• src/Wumpus/Basic/Graphic/DrawingContext.hs +83/−40
• src/Wumpus/Basic/Graphic/PrimGraphic.hs +6/−1
• src/Wumpus/Basic/Graphic/Query.hs +61/−48
• src/Wumpus/Basic/Graphic/ScalingContext.hs +22/−4
• src/Wumpus/Basic/Monads/TurtleMonad.hs +2/−2
• src/Wumpus/Basic/Paths/Base.hs +339/−74
• src/Wumpus/Basic/Paths/Connectors.hs +28/−153
• src/Wumpus/Basic/Paths/Construction.hs +55/−48
• src/Wumpus/Basic/Paths/RoundCorners.hs +114/−0
• src/Wumpus/Basic/Shapes/Base.hs +15/−0
• src/Wumpus/Basic/Shapes/Derived.hs +6/−6
• src/Wumpus/Basic/Text/LRText.hs +5/−5
• src/Wumpus/Basic/Utils/Intersection.hs +1/−1
• src/Wumpus/Basic/VersionNumber.hs +2/−2
• wumpus-basic.cabal +44/−51

@@ -1,4 +1,78 @@ ++0.9.0 to 0.10.0:++  * @Basic.Graphic.BaseClasses@ and @Basic.Graphic.BaseTypes@ +    merged into same module so they can depend on each other +    without orphans instances.++  * @DrawingF@ renamed to @DrawingR@, the related type synonyms+    have also been changed, e.g. @LocDrawingF@ is now +    @LocDrawingR@.++  * Method names in the @DrawingCtxM@ class changed - @askCtx@ is+    now @askDC@, @localCtx@ is now @localize@. Removed the +    functions @askDF@, @asksDF@, @pureDF@ that worked for +    @DrawingF@ (now @DrawingR@), @DrawingR@ now uses the +    Applicative\'s @pure@ and the @DrawingCtxM@ class for these +    functionalities.++  * @Basic.Graphic.DrawingContext@ - renamed @primary_colour@ to+    @stroke_colour@ and @secondary_colour@ to @fill_colour@. The +    setter functions has been similarly renamed.++  * Added the type synonym @DrawingContextF@ to +    @Basic.Graphic.DrawingContext@. Changed relevant function+    signatures to use it.++  * Re-worked the Path modules - base types entirely different,+    connectors entirely different, monadic path construction +    largely the same.++  * Initial work on round cornered paths.+ +  * Removed the type class @TextAnchor@ from @Basic.Anchors@. +    This was a left-over from a previous implementation of +    Shapes and is not relevant to the current implementation.+ +  * Added @DirectionContext@ to @Basic.Graphic@.++  * @localLG@ removed it can be acheived with composition -+    @localize upd . loc_graphic_function@. @lgappend@ is also +    removed - it can be recreated applicatively.++0.8.0 to 0.9.0:++  * Re-worked @Basic.Text.LRSymbol@ changed the type name and the+    types of the run functions. Added more symbols and a new demo +    @Symbols.hs@.++  * @ScalingContext@ added to @Basic.Graphic@. Changed +    @monoTextWidth@ to take a character count, the old behaviour +    is recreated by the new function @monoTextLength@. ++  * @Basic.Graphic.Chain@ removed. It is now superseded by+    @Basic.Chains@.++  * Added new property to @DrawingContext@ for line spacing +    scaling factor, and added a new drawing primitive +    @textlineMulti@ for multi-line, left justified labels.++  * Synthezied attribute /getters/ such as @textDimensions@ moved+    from @Basic.Graphic.DrawingContext@ to the new module+    @Basic.Graphic.Query@. The type of all the functions has +    changed to DrawingF. @lowerxHeight@ is renamed +    @monoLowerxHeight@ emphasizing that the metrics pertain to+    monospaced Courier font.++  * Added Shapes modules.+ +  * TurtleMonad module - the TurtleDrawing type and run functions+    have been removed and the internals have been reworked. +    Turtle is now run solely as a /local effect/ within the +    Drawing monad. ++ 0.7.0 to 0.8.0:    * Re-introduced LRText and LRSymbol - they now work with 

@@ -39,12 +39,14 @@ pic :: DPicture pic = pic1 `nextToV` (stackOver [cpic1, cpic2, cpic3] cpic4) +fillPath :: Num u => Path u -> Graphic u+fillPath = filledPath . toPrimPathU  pic1 :: DPicture pic1 = liftToPictureU $ execDrawing pic_drawing_ctx $ -         localCtx (secondaryColour medium_slate_blue) $ do+         localize (fillColour medium_slate_blue) $ do             draw $ fillPath path01-            localCtx (secondaryColour powder_blue) $ +            localize (fillColour powder_blue) $                       draw $ fillPath path02             draw $ fillPath path03             draw $ fillPath path04@@ -52,7 +54,7 @@  background :: RGBi -> DPicture  background rgb = liftToPictureU $ execDrawing pic_drawing_ctx $ -                   localCtx (primaryColour rgb) $ do                  +                   localize (strokeColour rgb) $ do                                        mapM_ iheartHaskell ps     where

@@ -43,7 +43,7 @@   colourSample :: String -> RGBi -> DPoint2 -> Drawing Double ()-colourSample name rgb pt = localCtx (secondaryColour rgb) $ do +colourSample name rgb pt = localize (fillColour rgb) $ do      draw $ borderedRectangle 15 10 `at` pt     draw $ textline name `at` displace 20 2 pt          

@@ -8,7 +8,7 @@ -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com> -- Stability   :  highly unstable--- Portability :  GHC with TypeFamilies and more+-- Portability :  GHC -- -- All the SVG / X11 \"named colours\" listed in tables.  --

@@ -51,7 +51,7 @@     p17 = makeDotPic (dotText "AA") points   std_ctx :: DrawingContext-std_ctx = secondaryColour peru $ standardContext 12+std_ctx = fillColour peru $ standardContext 12  points :: [Point2 Double] points = [P2 0 0, P2 32 10, P2 64 0, P2 96 10]@@ -66,10 +66,10 @@     dashline     mapM_ (\pt -> drawi $ dotImg `ati` pt) xs   where-    dashline = localCtx attrUpd (draw $ openStroke $ vertexPath xs)+    dashline = localize attrUpd (draw $ openStroke $ vertexPath xs)      attrUpd  :: DrawingContext -> DrawingContext-    attrUpd  =  dashPattern (evenDashes 1) . primaryColour cadet_blue+    attrUpd  =  dashPattern (evenDashes 1) . strokeColour cadet_blue   

@@ -34,9 +34,9 @@   makeLabel :: RGBi -> FontFace -> Int -> DLocGraphic-makeLabel rgb ff sz = -    localLG (primaryColour rgb . fontsize sz . fontface ff) -            (textline $ fontMsg ff sz)+makeLabel rgb ff sz = localize upd . (textline $ fontMsg ff sz)+  where+    upd = fillColour rgb . fontsize sz . fontface ff  -- indian_red1 -- steel_blue

@@ -0,0 +1,125 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++-- Acknowledgment - the petri net is taken from Claus Reinke\'s+-- paper /Haskell-Coloured Petri Nets/.+++module PetriNet where++import Wumpus.Basic.Anchors+import Wumpus.Basic.Arrows+import Wumpus.Basic.Colour.SVGColours+import Wumpus.Basic.Graphic                     -- package: wumpus-basic+import Wumpus.Basic.Paths+import Wumpus.Basic.Shapes.Base+import Wumpus.Basic.Shapes.Derived+import Wumpus.Basic.SafeFonts++import Wumpus.Core                              -- package: wumpus-core+++import System.Directory++++main :: IO ()+main = do +    createDirectoryIfMissing True "./out/"+    writeEPS_latin1 "./out/petri_net.eps" petri_net+    writeSVG_latin1 "./out/petri_net.svg" petri_net+    +++petri_net :: DPicture+petri_net = liftToPictureU $ execDrawing (standardContext 14) $ do+              pw     <- place 0 140+              tu1    <- transition 70 140+              rtw    <- place 140 140+              tu2    <- transition 210 140+              w      <- place 280 140+              tu3    <- transition 350 140+              res    <- place 280 70+              pr     <- place 0 0+              tl1    <- transition 70 0+              rtr    <- place 140 0+              tl2    <- transition 210 0+              r      <- place 280 0+              tl3    <- transition 350 0+              connector (east pw)  (west tu1)              +              connector (east tu1) (west rtw)+              connector (east rtw) (west tu2)+              connector (east tu2) (west w)+              connector (east w)   (west tu3)+              connectorC 32 (north tu3) (north pw)+              connector (east pr)  (west tl1)              +              connector (east tl1) (west rtr)+              connector (east rtr) (west tl2)+              connector (east tl2) (west r)+              connector (east r)   (west tl3)+              connectorC (-32) (south tl3) (south pr)+              connector (southwest res) (northeast tl2)+              connector (northwest tl3) (southeast res)+              connectorD 6    (southwest tu3) (northeast res)+              connectorD (-6) (southwest tu3) (northeast res) +              connectorD 6    (northwest res) (southeast tu2)+              connectorD (-6) (northwest res) (southeast tu2) +              draw $ lblParensParens `at` (P2 (-36) 150)+              draw $ lblParensParens `at` (P2 300 60)+              draw $ lblParensParensParens `at` (P2 (-52) (-14))+              draw $ lblBold "processing_w"   `at` (southwards 12 pw)+              draw $ lblBold "ready_to_write" `at` (southwards 12 rtw)+              draw $ lblBold "writing"        `at` (southwards 12 w)+              draw $ lblBold' "resource"      `at` (P2 300 72)+              draw $ lblBold "processing_r"   `at` (northwards 12 pr)+              draw $ lblBold "ready_to_read"  `at` (northwards 12 rtr)+              draw $ lblBold "reading"        `at` (northwards 12 r)+              return ()++greenFill :: DrawingCtxM m => m a -> m a+greenFill = localize (fillColour lime_green)++place :: (Real u, Floating u, DrawingCtxM m, TraceM m, u ~ MonUnit m) +      => u -> u -> m (Circle u)+place x y = greenFill $ drawi $ drawShape $ translate x y $ circle 14++transition :: (Real u, Floating u, DrawingCtxM m, TraceM m, u ~ MonUnit m) +           => u -> u -> m (Rectangle u)+transition x y = greenFill $ drawi $ drawShape $ translate x y $ rectangle 32 22++connector :: ( Real u, Floating u, FromPtSize u+             , DrawingCtxM m, TraceM m, u ~ MonUnit m )+          => Point2 u -> Point2 u -> m ()+connector p1 p2 = do+   _ <- drawi $ arrowTri60 connect `conn` p1 $ p2+   return ()+++connectorC :: ( Real u, Floating u, FromPtSize u+             , DrawingCtxM m, TraceM m, u ~ MonUnit m )+           => u -> Point2 u -> Point2 u -> m ()+connectorC v p1 p2 = do+    _ <- drawi $ arrowTri60 (vhvconn v) `conn` p1 $ p2+    return ()++connectorD :: ( Real u, Floating u, FromPtSize u+             , DrawingCtxM m, TraceM m, u ~ MonUnit m )+           => u -> Point2 u -> Point2 u -> m ()+connectorD u p1 p2 = do+    _ <- drawi $ arrowTri60 (joint u) `conn` p1 $ p2+    return ()+++lblParensParens :: Num u => LocGraphic u+lblParensParens = localize (fontface helvetica) . textline "(),()"++lblParensParensParens :: Num u => LocGraphic u+lblParensParensParens = localize (fontface helvetica) . textline "(),(),()"+++lblBold' :: Num u => String -> LocGraphic u+lblBold' ss = localize (fontface helveticaBold) . textline ss+++lblBold :: (Fractional u, Ord u, FromPtSize u) => String -> LocGraphic u+lblBold ss = localize (fontface helveticaBold) . centermonoTextline ss

@@ -135,17 +135,17 @@  rect_red :: DPicture rect_red = liftToPictureU $ execDrawing pic_drawing_ctx $ -              localCtx (secondaryColour indian_red)+              localize (fillColour indian_red)                        (draw $ borderedRectangle 30 10 `at` (P2 0 10))                   rect_green :: DPicture rect_green = liftToPictureU $ execDrawing pic_drawing_ctx $ -              localCtx (secondaryColour olive_drab)+              localize (fillColour olive_drab)                        (draw $ borderedRectangle 15 15 `at` (P2 10 10))   rect_blue :: DPicture rect_blue = liftToPictureU $ execDrawing pic_drawing_ctx $ -              localCtx (secondaryColour powder_blue)+              localize (fillColour powder_blue)                        (draw $ borderedRectangle 20 30 `at` (P2 10 0)) 

@@ -1,20 +1,12 @@-{-# LANGUAGE TypeFamilies               #-} {-# OPTIONS -Wall #-} --- Acknowledgment - the petri net is taken from Claus Reinke\'s--- paper /Haskell-Coloured Petri Nets/. - module Shapes where -import Wumpus.Basic.Anchors-import Wumpus.Basic.Arrows import Wumpus.Basic.Colour.SVGColours import Wumpus.Basic.Graphic                     -- package: wumpus-basic-import Wumpus.Basic.Paths import Wumpus.Basic.Shapes.Base import Wumpus.Basic.Shapes.Derived-import Wumpus.Basic.SafeFonts  import Wumpus.Core                              -- package: wumpus-core @@ -28,8 +20,6 @@     createDirectoryIfMissing True "./out/"     writeEPS_latin1 "./out/shapes01.eps" pic1     writeSVG_latin1 "./out/shapes01.svg" pic1-    writeEPS_latin1 "./out/petri_net.eps" petri_net-    writeSVG_latin1 "./out/petri.svg" petri_net       pic1 :: DPicture@@ -38,104 +28,10 @@                                                    $ lrectangle 90 30 "Rectangle"          _ <- drawi $ drawShape $ translate 100  0 $ lcircle 10 "C0"    -         _ <- localCtx (primaryColour red) $ +         _ <- localize (strokeColour red) $                         drawi $ drawShape $ translate 220 10 $ rotate30 $ coordinate          _ <- drawi $ drawShape $ translate 0   40 $ ldiamond 10 10 "d1"          _ <- drawi $ drawShape $ translate 400 50 $ lrectangle 20 100 "R2"          return ()  ---petri_net :: DPicture-petri_net = liftToPictureU $ execDrawing (standardContext 14) $ do-              pw     <- place 0 140-              tu1    <- transition 70 140-              rtw    <- place 140 140-              tu2    <- transition 210 140-              w      <- place 280 140-              tu3    <- transition 350 140-              res    <- place 280 70-              pr     <- place 0 0-              tl1    <- transition 70 0-              rtr    <- place 140 0-              tl2    <- transition 210 0-              r      <- place 280 0-              tl3    <- transition 350 0-              connector (east pw)  (west tu1)              -              connector (east tu1) (west rtw)-              connector (east rtw) (west tu2)-              connector (east tu2) (west w)-              connector (east w)   (west tu3)-              connectorC 32 (north tu3) (north pw)-              connector (east pr)  (west tl1)              -              connector (east tl1) (west rtr)-              connector (east rtr) (west tl2)-              connector (east tl2) (west r)-              connector (east r)   (west tl3)-              connectorC (-32) (south tl3) (south pr)-              connector (southwest res) (northeast tl2)-              connector (northwest tl3) (southeast res)-              connectorD 6    (southwest tu3) (northeast res)-              connectorD (-6) (southwest tu3) (northeast res) -              connectorD 6    (northwest res) (southeast tu2)-              connectorD (-6) (northwest res) (southeast tu2) -              draw $ lblParensParens `at` (P2 (-36) 150)-              draw $ lblParensParens `at` (P2 300 60)-              draw $ lblParensParensParens `at` (P2 (-52) (-14))-              draw $ lblBold "processing_w"   `at` (southwards 12 pw)-              draw $ lblBold "ready_to_write" `at` (southwards 12 rtw)-              draw $ lblBold "writing"        `at` (southwards 12 w)-              draw $ lblBold' "resource"      `at` (P2 300 72)-              draw $ lblBold "processing_r"   `at` (northwards 12 pr)-              draw $ lblBold "ready_to_read"  `at` (northwards 12 rtr)-              draw $ lblBold "reading"        `at` (northwards 12 r)-              return ()--greenFill :: DrawingCtxM m => m a -> m a-greenFill = localCtx (secondaryColour lime_green)--place :: (Real u, Floating u, DrawingCtxM m, TraceM m, u ~ MonUnit m) -      => u -> u -> m (Circle u)-place x y = greenFill $ drawi $ drawShape $ translate x y $ circle 14--transition :: (Real u, Floating u, DrawingCtxM m, TraceM m, u ~ MonUnit m) -           => u -> u -> m (Rectangle u)-transition x y = greenFill $ drawi $ drawShape $ translate x y $ rectangle 32 22--connector :: ( Real u, Floating u, FromPtSize u-             , DrawingCtxM m, TraceM m, u ~ MonUnit m )-          => Point2 u -> Point2 u -> m ()-connector p1 p2 = do-   _ <- drawi $ arrowTri60 connectS `conn` p1 $ p2-   return ()---connectorC :: ( Real u, Floating u, FromPtSize u-             , DrawingCtxM m, TraceM m, u ~ MonUnit m )-           => u -> Point2 u -> Point2 u -> m ()-connectorC v p1 p2 = do-    _ <- drawi $ arrowTri60 (arbv v) `conn` p1 $ p2-    return ()--connectorD :: ( Real u, Floating u, FromPtSize u-             , DrawingCtxM m, TraceM m, u ~ MonUnit m )-           => u -> Point2 u -> Point2 u -> m ()-connectorD u p1 p2 = do-    _ <- drawi $ arrowTri60 (joint u) `conn` p1 $ p2-    return ()---lblParensParens :: Num u => LocGraphic u-lblParensParens = localLG (fontface helvetica) $ textline "(),()"--lblParensParensParens :: Num u => LocGraphic u-lblParensParensParens = localLG (fontface helvetica) $ textline "(),(),()"---lblBold' :: Num u => String -> LocGraphic u-lblBold' ss = localLG (fontface helveticaBold) $ textline ss---lblBold :: (Fractional u, Ord u, FromPtSize u) => String -> LocGraphic u-lblBold ss = localLG (fontface helveticaBold) $ centermonoTextline ss

@@ -2,7 +2,7 @@  module Symbols where -import Wumpus.Basic.Graphic+import Wumpus.Basic.Graphic hiding ( perpendicular ) import Wumpus.Basic.SafeFonts import Wumpus.Basic.Text.LRSymbol import Wumpus.Basic.Text.LRText

@@ -9,7 +9,7 @@ -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com> -- Stability   :  highly unstable--- Portability :  GHC with TypeFamilies and more+-- Portability :  GHC -- -- Anchor points on shapes. --@@ -25,7 +25,6 @@     CenterAnchor(..)   , CardinalAnchor(..)   , CardinalAnchor2(..)-  , TextAnchor(..)   , RadialAnchor(..)    -- * extended anchor points@@ -66,12 +65,6 @@   southeast :: DUnit t ~ u => t -> Point2 u   southwest :: DUnit t ~ u => t -> Point2 u   northwest :: DUnit t ~ u => t -> Point2 u---- | 'textAnchor' is the Bottom left corner --- on the baseline.----class TextAnchor t where-  baselineSW :: DUnit t ~ u => t -> Point2 u   -- | Anchor on a border that can be identified with and angle.

@@ -8,18 +8,18 @@ -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com> -- Stability   :  highly unstable--- Portability :  GHC with TypeFamilies and more+-- Portability :  GHC ----- Anchor points on shapes.+-- Draw arrows. ----- \*\* WARNING \*\* this module is an experiment, and may --- change significantly or even be dropped from future revisions.+-- \*\* WARNING \*\* - the types are /wrong/ here and need more +-- thought. --  --------------------------------------------------------------------------------  module Wumpus.Basic.Arrows   ( -    line+    cline     , arrowTri90@@ -34,6 +34,7 @@   , arrowBarb45        , arrowPerp+  , arrowRBracket    ) where @@ -47,17 +48,22 @@ import Control.Applicative import Data.Monoid -liftConnPath :: ConnPath u -> ConnDrawingF u (Path u)-liftConnPath pF p1 p2 = pureDF $ pF p1 p2+liftConnector :: Connector u -> ConnDrawingR u (Path u)+liftConnector pF p1 p2 = pure $ pF p1 p2 -line :: Num u => ConnPath u -> ConnImage u (Path u)-line pathF = intoConnImage (liftConnPath pathF) (pathGraphic pathF)+cline :: Num u => Connector u -> ConnImage u (Path u)+cline pathF = intoConnImage (liftConnector pathF) (pathGraphic pathF) +-- ... No - can\'t a add tips to this one.+--+pathGraphic :: Num u => Connector u -> ConnGraphic u+pathGraphic bpath = \p1 p2 -> openStroke $ toPrimPathU $ bpath p1 p2 + -- Here the path is already shortened - we have accounted for the -- points already, so it is just a graphic.  lineTipR :: Num u => Path u -> Graphic u -> Graphic u-lineTipR bpath tip = openStroke (toPrimPathU bpath) `mappend` tip+lineTipR bpath arrtip = openStroke (toPrimPathU bpath) `mappend` arrtip      @@ -73,7 +79,7 @@ -- path segments. -- rightPathProps :: (Real u, Floating u, FromPtSize u) -               => ConnPath u -> ConnDrawingF u (Path u,Radian)+               => Connector u -> ConnDrawingR u (Path u,Radian) rightPathProps pathF p1 p2 =      (\h sw -> (shortenPath h sw, calcTheta h))       <$> markHeight <*> lineWidth@@ -86,7 +92,7 @@   triTipRight :: (Real u, Floating u, FromPtSize u) -            => ConnPath u -> (Radian -> LocGraphic u) -> ConnImage u (Path u) +            => Connector u -> (Radian -> LocGraphic u) -> ConnImage u (Path u)  triTipRight pathF tipF p1 p2 =     rightPathProps pathF p1 p2          >>= \(shortF,theta) ->      lineTipR shortF (tipF theta p2)     >>= \arrow_pic      ->@@ -98,7 +104,7 @@ -- This version does not /retract/ the path... -- barbTipRight :: (Real u, Floating u, FromPtSize u) -             => ConnPath u -> (Radian -> LocGraphic u) -> ConnImage u (Path u)  +             => Connector u -> (Radian -> LocGraphic u) -> ConnImage u (Path u)   barbTipRight pathF tipF p1 p2 =      rightPathProps pathF p1 p2          >>= \(_,theta) ->      lineTipR path_zero (tipF theta p2)  >>= \arrow_pic  ->@@ -109,58 +115,68 @@   arrowTri90 :: (Real u, Floating u, FromPtSize u) -           => ConnPath u -> ConnImage u (Path u)+           => Connector u -> ConnImage u (Path u) arrowTri90 pathF = triTipRight pathF tri90                arrowTri60 :: (Real u, Floating u, FromPtSize u) -           => ConnPath u -> ConnImage u (Path u)+           => Connector u -> ConnImage u (Path u) arrowTri60 pathF = triTipRight pathF tri60    arrowTri45 :: (Real u, Floating u, FromPtSize u) -           => ConnPath u -> ConnImage u (Path u)+           => Connector u -> ConnImage u (Path u) arrowTri45 pathF = triTipRight pathF tri45   arrowOTri90 :: (Real u, Floating u, FromPtSize u) -            => ConnPath u -> ConnImage u (Path u)+            => Connector u -> ConnImage u (Path u) arrowOTri90 pathF = triTipRight pathF otri90        arrowOTri60 :: (Real u, Floating u, FromPtSize u) -            => ConnPath u -> ConnImage u (Path u)+            => Connector u -> ConnImage u (Path u) arrowOTri60 pathF = triTipRight pathF otri60     arrowOTri45 :: (Real u, Floating u, FromPtSize u) -            => ConnPath u -> ConnImage u (Path u)+            => Connector u -> ConnImage u (Path u) arrowOTri45 pathF = triTipRight pathF otri45    arrowBarb90 :: (Real u, Floating u, FromPtSize u) -            => ConnPath u -> ConnImage u (Path u)+            => Connector u -> ConnImage u (Path u) arrowBarb90 pathF = barbTipRight pathF barb90  arrowBarb60 :: (Real u, Floating u, FromPtSize u) -            => ConnPath u -> ConnImage u (Path u)+            => Connector u -> ConnImage u (Path u) arrowBarb60 pathF = barbTipRight pathF barb60  arrowBarb45 :: (Real u, Floating u, FromPtSize u) -            => ConnPath u -> ConnImage u (Path u)+            => Connector u -> ConnImage u (Path u) arrowBarb45 pathF = barbTipRight pathF barb45                         arrowPerp :: (Real u, Floating u, FromPtSize u) -          => ConnPath u -> ConnImage u (Path u)+          => Connector u -> ConnImage u (Path u) arrowPerp pathF p1 p2 =      lineTipR path_zero perp_tip >>= \arrow_pic -> return (path_zero, arrow_pic)   where     path_zero = pathF  p1 p2     theta     = langle p1 p2     perp_tip  = perp theta p2+++arrowRBracket :: (Real u, Floating u, FromPtSize u) +              => Connector u -> ConnImage u (Path u)+arrowRBracket pathF p1 p2 = +    lineTipR path_zero perp_tip >>= \arrow_pic -> return (path_zero, arrow_pic)+  where+    path_zero = pathF  p1 p2+    theta     = langle p1 p2+    perp_tip  = rbracket theta p2

@@ -8,7 +8,7 @@ -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com> -- Stability   :  highly unstable--- Portability :  GHC with TypeFamilies and more+-- Portability :  GHC -- -- Anchor points on shapes. --@@ -34,6 +34,8 @@    , perp +  , rbracket+   ) where  import Wumpus.Basic.Graphic@@ -44,21 +46,87 @@  import Control.Applicative --- | tripoints takes dimensions from the xlowerHeight.+++-- | Tiplen is length of the tip \*along the line it follows\*.  ---tripoints :: (Floating u, FromPtSize u)-          => Radian -> Radian -> LocDrawingF u (Point2 u, Point2 u)-tripoints triang theta tip = -    (\h -> let d = h / (fromRadian $ cos halfang) -           in (tip .-^ v1 d, tip .-^ v2 d))-      <$> markHeight+-- > |\+-- > | \+-- > | /+-- > |/+-- > +-- > |  |  -- tip len+--++-- | Tip width is the distance between upper and lower +-- arrow points.+--+-- >       __+-- > |\    +-- > | \   tip+-- > | /   width+-- > |/    __+-- >       ++++-- | This one is for triangular tips defined by their tip angle+-- e.g. 90deg, 60deg, 45deg.+--+-- The tip width will be variable (tip length should be the +-- markHeight).+-- +triVecsByAngle :: Floating u => u -> Radian -> Radian -> (Vec2 u, Vec2 u)+triVecsByAngle tiplen halfang theta = (vec_to_upper, vec_to_lower)   where-    halfang = 0.5 * triang-    v1 d    = avec (theta + halfang) d-    v2 d    = avec (theta - halfang) d+    hypo_len     = tiplen / (fromRadian $ cos halfang)+    rtheta       = pi + theta        -- theta in the opposite direction+    vec_to_upper = avec (circularModulo $ rtheta - halfang) hypo_len+    vec_to_lower = avec (circularModulo $ rtheta + halfang) hypo_len   +-- | This one is for triangles when the tip height and tip width+-- are known.+--+triVecsByDist  :: (Real u, Floating u) +               => u -> u -> Radian -> (Vec2 u, Vec2 u)+triVecsByDist tiplen half_tipwidth theta = (vec_to_upper, vec_to_lower)+  where+    hypo_len     = sqrt $ (tiplen*tiplen) + (half_tipwidth*half_tipwidth)+    halfang      = toRadian $ atan (half_tipwidth / tiplen) +    rtheta       = pi + theta        -- theta in the opposite direction+    vec_to_upper = avec (circularModulo $ rtheta - halfang) hypo_len+    vec_to_lower = avec (circularModulo $ rtheta + halfang) hypo_len  ++--------------------------------------------------------------------------------++-- | Tripoints takes the \*tip length\* is the mark height.+--+-- This means that the 90deg tip has a tip width greater-than the+-- mark height (but that is okay - seemingly this is how TikZ +-- does it!).+--+tripointsByAngle :: (Floating u, FromPtSize u)+                 => Radian -> Radian -> LocDrawingR u (Point2 u, Point2 u)+tripointsByAngle triang theta tip = +    (\h -> let (vupper,vlower) = triVecsByAngle h (0.5*triang) theta+           in  (tip .+^ vupper, tip .+^ vlower))+      <$> markHeight++++tripointsByDist :: (Real u, Floating u, FromPtSize u)+                => (u -> u) -> (u -> u) -> Radian +                -> LocDrawingR u (Point2 u, Point2 u)+tripointsByDist lenF halfwidthF theta tip = +    (\h -> let (vup,vlo) = triVecsByDist (lenF h) (halfwidthF $ 0.5*h) theta+           in  (tip .+^ vup, tip .+^ vlo))+      <$> markHeight++++ -- width = xchar_height -- filled with stroke colour! @@ -68,8 +136,8 @@       -> (PrimPath u -> Graphic u)        -> LocGraphic u triAng triang theta gf pt = -    tripoints triang theta pt >>= \(u,v) -> -    localDF bothPrimary (gf $  vertexPath [pt,u,v])+    tripointsByAngle triang theta pt >>= \(u,v) -> +    localize bothStrokeColour (gf $  vertexPath [pt,u,v])   @@ -106,7 +174,8 @@ barbAng :: (Floating u, Real u, FromPtSize u)       => Radian -> Radian -> LocGraphic u barbAng ang theta pt = -    tripoints ang theta pt >>= \(u,v) -> openStroke (vertexPath [u,pt,v])+    tripointsByAngle ang theta pt >>= \(u,v) -> +    openStroke (vertexPath [u,pt,v])   barb90 :: (Floating u, Real u, FromPtSize u) @@ -129,3 +198,14 @@     let v = makeV h in openStroke $ vertexPath [ pt .+^ v, pt .-^ v]   where     makeV h  = avec (theta + pi/2) (0.5 * h)+++rbracket :: (Floating u, FromPtSize u) => Radian -> LocGraphic u+rbracket theta pt = markHalfHeight >>= \hh -> +   runDirection theta $ +     displacePerp   hh  pt >>= \p1 ->+     displacePara (-hh) p1 >>= \p0 ->+     displacePerp (-hh) pt >>= \p2 ->+     displacePara (-hh) p2 >>= \p3 ->+     return (openStroke $ vertexPath [p0,p1,p2,p3]) +   

@@ -7,8 +7,8 @@ -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC with TypeFamilies and more+-- Stability   :  unstable+-- Portability :  GHC -- -- The SVG \'named colours\', as rgb [0,1] values  --

@@ -7,8 +7,8 @@ -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC with TypeFamilies and more+-- Stability   :  unstable+-- Portability :  GHC -- -- The X11 \'named colours\', as rgb [0,1] values  --

@@ -11,7 +11,7 @@ -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com> -- Stability   :  highly unstable--- Portability :  GHC with TypeFamilies, GADTs and more+-- Portability :  GHC -- -- Dots with anchors. --@@ -139,8 +139,8 @@                              $ rectangleLines ctr hw hh  rectangleLDO :: (Real u, Floating u) -             => u -> u -> LocDrawingF u (DotAnchor u)-rectangleLDO w h pt = pureDF $ rectangleAnchor (w*0.5) (h*0.5) pt+             => u -> u -> LocDrawingR u (DotAnchor u)+rectangleLDO w h pt = pure $ rectangleAnchor (w*0.5) (h*0.5) pt   circleAnchor :: Floating u => u -> Point2 u -> DotAnchor u@@ -148,7 +148,7 @@                                  (\theta -> ctr .+^ (avec theta rad))                                  (radialCardinal rad ctr) -circleLDO :: (Floating u, FromPtSize u) => LocDrawingF u (DotAnchor u)+circleLDO :: (Floating u, FromPtSize u) => LocDrawingR u (DotAnchor u) circleLDO pt = (\diam -> circleAnchor (diam * 0.5) pt) <$> markHeight   

@@ -8,7 +8,7 @@ -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com> -- Stability   :  highly unstable--- Portability :  GHC with TypeFamilies and more+-- Portability :  GHC -- -- Marks - dots without anchor handles. --@@ -116,26 +116,27 @@   markHLine :: (Fractional u, FromPtSize u) => LocGraphic u -markHLine = standardSize (\h -> axialLine (hvec h))+markHLine = standardSize $ \h -> axialLine (hvec h)       markVLine :: (Fractional u, FromPtSize u) => LocGraphic u -markVLine = standardSize (\h -> axialLine (vvec h)) +markVLine = standardSize $ \h -> axialLine (vvec h)    markX :: (Fractional u, FromPtSize u) => LocGraphic u-markX = standardSize (\h -> let w = 0.75 * h in-                            axialLine (vec w h) `lgappend` axialLine (vec (-w) h))+markX = standardSize $ \h -> +    let w = 0.75 * h +    in mappend <$> axialLine (vec w h) <*> axialLine (vec (-w) h)    markPlus :: (Fractional u, FromPtSize u) =>  LocGraphic u-markPlus = markVLine `lgappend` markHLine+markPlus = mappend <$> markVLine <*> markHLine   markCross :: (Floating u, FromPtSize u) =>  LocGraphic u-markCross = standardSize -             (\h -> axialLine (avec ang h) `lgappend` axialLine (avec (-ang) h))+markCross = standardSize $ \h -> +    mappend <$> axialLine (avec ang h) <*> axialLine (avec (-ang) h)   where     ang = pi*0.25   @@ -144,7 +145,7 @@ -- needs horizontal pinch...  pathDiamond :: (Fractional u, FromPtSize u) -            => Point2 u -> DrawingF (PrimPath u)+            => Point2 u -> DrawingR (PrimPath u) pathDiamond pt = (\h -> let hh    = 0.66 * h; hw = 0.5 * h                          in vertexPath [dvs hh, dve hw,dvn hh, dvw hw])                    <$> markHeight@@ -205,7 +206,8 @@   markAsterisk :: (Floating u, FromPtSize u) => LocGraphic u-markAsterisk = standardSize (\h -> lineF1 h `lgappend` lineF2 h `lgappend` lineF3 h)+markAsterisk = standardSize $ \h -> +    (\a b c -> a `mappend` b `mappend` c) <$> lineF1 h <*> lineF2 h <*> lineF3 h   where     ang       = (pi*2) / 6     lineF1 z  = axialLine (vvec z)@@ -215,15 +217,15 @@   markOPlus :: (Fractional u, FromPtSize u) => LocGraphic u-markOPlus = markCircle `lgappend` markPlus+markOPlus = mappend <$> markCircle <*> markPlus   markOCross :: (Floating u, FromPtSize u) => LocGraphic u-markOCross = markCircle `lgappend` markCross+markOCross = mappend <$> markCircle <*> markCross   markFOCross :: (Floating u, FromPtSize u) => LocGraphic u-markFOCross = markCross `lgappend` markBCircle +markFOCross = liftA2 mappend markCross markBCircle    -- bkCircle :: (Fractional u, FromPtSize u) => LocGraphic u

@@ -17,8 +17,8 @@  module Wumpus.Basic.Graphic   (-    module Wumpus.Basic.Graphic.BaseClasses-  , module Wumpus.Basic.Graphic.BaseTypes+    module Wumpus.Basic.Graphic.Base+  , module Wumpus.Basic.Graphic.DirectionContext   , module Wumpus.Basic.Graphic.Drawing   , module Wumpus.Basic.Graphic.DrawingContext   , module Wumpus.Basic.Graphic.PrimGraphic@@ -26,8 +26,8 @@   , module Wumpus.Basic.Graphic.ScalingContext   ) where -import Wumpus.Basic.Graphic.BaseClasses-import Wumpus.Basic.Graphic.BaseTypes+import Wumpus.Basic.Graphic.Base+import Wumpus.Basic.Graphic.DirectionContext import Wumpus.Basic.Graphic.Drawing import Wumpus.Basic.Graphic.DrawingContext import Wumpus.Basic.Graphic.PrimGraphic

@@ -0,0 +1,334 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Graphic.Base+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Base types for Drawing Objects, Graphics / Images (a Graphic +-- that also returns an answer), etc.+-- +-- Base classes for monadic drawing.+--+-- Note on suffix names. Function types suffixed @F@ are functions +-- from same-to-same, e.g.:+--+-- > type Point2F u = Point2 u -> Point2 u+--+-- Functional types subfixed @R@ are functions from some static +-- context to the answer type (c.f the ReaderMonad), e.g.:+--+-- > newtype DrawingR a = DrawingR { getDrawingR :: DrawingContext -> a }+--+-- The suffix @M@ is used for classes defining monadic actions.+--+-- \*\* WARNING \*\* - some names are expected to change.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Graphic.Base+  (+    +  -- * Drawing monads.+    MonUnit+  , TraceM(..)+  , DrawingCtxM(..)+  , asksDC+ +  , PointSupplyM(..)++  -- * Base types+  , HPrim+  , hprimToList+  , singleH++  , Point2F+  , DPoint2F++  , DrawingR+  , LocDrawingR+  , DLocDrawingR++  , runDrawingR++  , Graphic+  , DGraphic+  ++  , runGraphic+  , xlinkGraphic++  , LocGraphic+  , DLocGraphic++  , Image+  , DImage+  , LocImage+  , DLocImage++  , runImage+  , intoImage+  , intoLocImage+  , xlinkImage++  , ConnDrawingR+  , DConnDrawingR+  , ConnGraphic+  , DConnGraphic+  , ConnImage+  , DConnImage++  , intoConnImage++  ) where++import Wumpus.Basic.Graphic.DrawingContext+import Wumpus.Basic.Utils.HList++import Wumpus.Core                      -- package: wumpus-core+++import Control.Applicative+import Data.Monoid+++--------------------------------------------------------------------------------+-- Monadic drawing++-- | DUnit is always for fully saturated type constructors, so +-- (seemingly) an equivalent type family is needed for monads.++type family MonUnit m :: * +++-- | Collect elementary graphics as part of a larger drawing.+--+-- TraceM works much like a writer monad.+--+class Monad m => TraceM (m :: * -> *) where+  trace  :: HPrim (MonUnit m) -> m ()++class Monad m => DrawingCtxM (m :: * -> *) where+  askDC    :: m DrawingContext+  localize :: (DrawingContext -> DrawingContext) -> m a -> m a+++-- | Project a value out of a context.+--+asksDC :: DrawingCtxM m => (DrawingContext -> a) -> m a+asksDC f = askDC >>= (return . f)+++++++-- | A monad that supplies points, e.g. a turtle monad. +--+class Monad m => PointSupplyM (m :: * -> *) where+  position :: u ~ MonUnit m => m (Point2 u)+ ++--------------------------------------------------------------------------------+-- Base types++-- | Graphics objects, even simple ones (line, arrow, dot) might +-- need more than one primitive (path or text label) for their+-- construction. Hence, the primary representation that all the +-- others are built upon must support /concatenation/ of +-- primitives. +--+-- Wumpus-Core has a type Picture - made from one or more +-- Primitives - but Pictures include support for affine frames. +-- For drawing many simple graphics (dots, connector lines...) +-- that do not need individual affine transformations this is a +-- penalty. A list of Primitives is therefore more suitable +-- representation, and a Hughes list which supports+-- efficient concatenation is wise.+--+newtype HPrim u = HPrim { getHPrim :: H (PrimElement u) }++-- Note - only a Monoid instance for HPrim - they cannot be +-- shown, fmapped etc.++instance Monoid (HPrim u) where+  mempty          = HPrim emptyH+  ha `mappend` hb = HPrim $ getHPrim ha `appendH` getHPrim hb+++hprimToList :: HPrim u -> [PrimElement u]+hprimToList = toListH . getHPrim+++singleH :: PrimElement u -> HPrim u+singleH = HPrim . wrapH ++-- | Point transformation function.+--+type Point2F u = Point2 u -> Point2 u++type DPoint2F = Point2F Double++--------------------------------------------------------------------------------+--++-- | Drawings in Wumpus-Basic have an implicit /graphics state/ +-- the @DrawingContext@, the most primitive building block is +-- a function from the DrawingContext to some polymorphic answer.+-- +-- This functional type is represented concretely as @DrawingR@.+-- +-- > DrawingR :: DrawingContext -> a +--+newtype DrawingR a = DrawingR { getDrawingR :: DrawingContext -> a }+++instance Functor DrawingR where+  fmap f ma = DrawingR $ \ctx -> f $ getDrawingR ma ctx ++-- The monoid instance seems sensible...+--+instance Monoid a => Monoid (DrawingR a) where +  mempty          = DrawingR $ \_   -> mempty+  fa `mappend` fb = DrawingR $ \ctx -> +                      getDrawingR fa ctx `mappend` getDrawingR fb ctx++-- Applicative++instance Applicative DrawingR where+  pure a    = DrawingR $ \_   -> a+  mf <*> ma = DrawingR $ \ctx -> let f = getDrawingR mf ctx+                                     a = getDrawingR ma ctx+                                 in f a++-- Monad ++instance Monad DrawingR where+  return a  = DrawingR $ \_   -> a+  ma >>= k  = DrawingR $ \ctx -> let a = getDrawingR ma ctx+                                 in (getDrawingR . k) a ctx +++instance DrawingCtxM DrawingR where+  askDC           = DrawingR $ \ctx -> ctx+  localize upd df = DrawingR $ \ctx -> getDrawingR df (upd ctx)+  ++-- | Run a /Drawing Function/ with the supplied /Drawing Context/.+--+runDrawingR :: DrawingContext -> DrawingR a -> a+runDrawingR ctx df = getDrawingR df ctx+++++type LocDrawingR u a = Point2 u -> DrawingR a ++type DLocDrawingR a = LocDrawingR Double a+++--------------------------------------------------------------------------------+++-- Simple drawing - representing one or more prims++type Graphic u = DrawingR (HPrim u)++type DGraphic = Graphic Double+++runGraphic :: DrawingContext -> Graphic u -> HPrim u+runGraphic ctx gf = (getDrawingR gf) ctx+++xlinkGraphic :: XLink -> Graphic u -> Graphic u+xlinkGraphic xlink gf = DrawingR $ \ctx -> +    let xs = hprimToList $ runGraphic ctx gf +    in (singleH $ xlinkGroup xlink xs)+++--------------------------------------------------------------------------------+++-- | Commonly graphics take a start point as well as a drawing +-- context.+-- +-- Here they are called a LocGraphic - graphic with a (starting) +-- location.+--+type LocGraphic u = Point2 u -> Graphic u++type DLocGraphic = LocGraphic Double+++++--------------------------------------------------------------------------------+++-- | Images return a value as well as drawing. A /node/ is a +-- typical example - nodes are drawing but the also support +-- taking anchor points.+--+type Image u a = DrawingR (a, HPrim u)++type DImage a = Image Double a++type LocImage u a = Point2 u -> Image u a++type DLocImage a = LocImage Double a++runImage :: DrawingContext -> Image u a -> (a,HPrim u)+runImage ctx img = (getDrawingR img) ctx+++intoImage :: DrawingR a -> Graphic u -> Image u a+intoImage f g = DrawingR $ \ctx -> +    let a = getDrawingR f ctx; o = getDrawingR g ctx in (a,o)+++intoLocImage :: LocDrawingR u a -> LocGraphic u -> LocImage u a+intoLocImage f g pt = DrawingR $ \ctx -> +    let a = getDrawingR (f pt) ctx; o = getDrawingR (g pt) ctx in (a,o)+++xlinkImage :: XLink -> Image u a -> Image u a+xlinkImage xlink img = DrawingR $ \ctx -> +    let (a,hp) = runImage ctx img +    in (a, singleH $ xlinkGroup xlink $ hprimToList hp)++--------------------------------------------------------------------------------+--++type ConnDrawingR u a = Point2 u -> Point2 u -> DrawingR a++type DConnDrawingR a = ConnDrawingR Double a++-- | ConnGraphic is a connector drawn between two points +-- contructing a Graphic.+--+type ConnGraphic u = Point2 u -> Point2 u -> Graphic u++type DConnGraphic = ConnGraphic Double++-- | ConImage is a connector drawn between two points +-- constructing an Image.+--+type ConnImage u a = Point2 u -> Point2 u -> Image u a++type DConnImage a = ConnImage Double a+++intoConnImage :: ConnDrawingR u a -> ConnGraphic u -> ConnImage u a+intoConnImage f g p1 p2 = DrawingR $ \ctx -> +    let a = getDrawingR (f p1 p2) ctx; o = getDrawingR (g p1 p2) ctx in (a,o)++++

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

@@ -1,301 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Graphic.Image--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  highly unstable--- Portability :  GHC ------ Base types for Drawing Objects, Graphics / Images (a Graphic --- that also returns an answer), etc.------ \*\* WARNING \*\* - some names are expected to change --- particularly the naming of the /append/ and /concat/ functions.--------------------------------------------------------------------------------------module Wumpus.Basic.Graphic.BaseTypes-  (-    --    HPrim-  , hprimToList-  , singleH--  , Point2F-  , DPoint2F--  , DrawingF-  , LocDrawingF-  , DLocDrawingF--  , runDF-  , pureDF -  , askDF-  , asksDF-  , localDF--  , Graphic-  , DGraphic-  --  , runGraphic-  , xlinkGraphic--  , LocGraphic-  , DLocGraphic-  , localLG-  , lgappend--  , Image-  , DImage-  , LocImage-  , DLocImage--  , runImage-  , intoImage-  , intoLocImage-  , xlinkImage--  , ConnDrawingF-  , DConnDrawingF-  , ConnGraphic-  , DConnGraphic-  , ConnImage-  , DConnImage--  , intoConnImage--  ) where--import Wumpus.Basic.Graphic.DrawingContext-import Wumpus.Basic.Utils.HList--import Wumpus.Core                      -- package: wumpus-core---import Control.Applicative-import Data.Monoid------ | Graphics objects, even simple ones (line, arrow, dot) might --- need more than one primitive (path or text label) for their--- construction. Hence, the primary representation that all the --- others are built upon must support /concatenation/ of --- primitives. ------ Wumpus-Core has a type Picture - made from one or more --- Primitives - but Pictures include support for affine frames. --- For drawing many simple graphics (dots, connector lines...) --- that do not need individual affine transformations this is a --- penalty. A list of Primitives is therefore more suitable --- representation, and a Hughes list which supports--- efficient concatenation is wise.----newtype HPrim u = HPrim { getHPrim :: H (PrimElement u) }---- Note - only a Monoid instance for HPrim - they cannot be --- shown, fmapped etc.--instance Monoid (HPrim u) where-  mempty          = HPrim emptyH-  ha `mappend` hb = HPrim $ getHPrim ha `appendH` getHPrim hb---hprimToList :: HPrim u -> [PrimElement u]-hprimToList = toListH . getHPrim---singleH :: PrimElement u -> HPrim u-singleH = HPrim . wrapH ---- | Point transformation function.----type Point2F u = Point2 u -> Point2 u--type DPoint2F = Point2F Double----------------------------------------------------------------------------------------- | Drawings in Wumpus-Basic have an implicit /graphics state/ --- the @DrawingContext@, the most primitive building block is --- a function from the DrawingContext to some polymorphic answer.--- --- This functional type is represented concretely as @DrawingF@.--- --- > DrawingF :: DrawingContext -> a ----newtype DrawingF a = DrawingF { getDrawingF :: DrawingContext -> a }---instance Functor DrawingF where-  fmap f ma = DrawingF $ \ctx -> f $ getDrawingF ma ctx ---- The monoid instance seems sensible...----instance Monoid a => Monoid (DrawingF a) where -  mempty          = DrawingF $ \_   -> mempty-  fa `mappend` fb = DrawingF $ \ctx -> -                      getDrawingF fa ctx `mappend` getDrawingF fb ctx---- Applicative--instance Applicative DrawingF where-  pure a    = DrawingF $ \_   -> a-  mf <*> ma = DrawingF $ \ctx -> let f = getDrawingF mf ctx-                                     a = getDrawingF ma ctx-                                 in f a---- Monad --instance Monad DrawingF where-  return a  = DrawingF $ \_   -> a-  ma >>= k  = DrawingF $ \ctx -> let a = getDrawingF ma ctx-                                 in (getDrawingF . k) a ctx ---- | Run a /Drawing Function/ with the supplied /Drawing Context/.----runDF :: DrawingContext -> DrawingF a -> a-runDF ctx df = getDrawingF df ctx----- | Wrap a value into a DrawingF.------ Note the value is /pure/ it does depend on the DrawingContext--- (it is /context free/).----pureDF :: a -> DrawingF a-pureDF a = DrawingF $ \ _ctx -> a --askDF :: DrawingF DrawingContext-askDF = DrawingF id--asksDF :: (DrawingContext -> a) -> DrawingF a-asksDF fn = DrawingF $ \ctx -> fn ctx--localDF :: (DrawingContext -> DrawingContext) -        -> DrawingF a -> DrawingF a-localDF upd gf = DrawingF $ \ctx -> getDrawingF gf (upd ctx)----type LocDrawingF u a = Point2 u -> DrawingF a --type DLocDrawingF a = LocDrawingF Double a---------------------------------------------------------------------------------------- Simple drawing - representing one or more prims--type Graphic u = DrawingF (HPrim u)--type DGraphic = Graphic Double---runGraphic :: DrawingContext -> Graphic u -> HPrim u-runGraphic ctx gf = (getDrawingF gf) ctx---xlinkGraphic :: XLink -> Graphic u -> Graphic u-xlinkGraphic xlink gf = askDF >>= \ctx -> -    let xs = hprimToList $ runGraphic ctx gf in pureDF (singleH $ xlinkGroup xlink xs)---------------------------------------------------------------------------------------- | Commonly graphics take a start point as well as a drawing --- context.--- --- Here they are called a LocGraphic - graphic with a (starting) --- location.----type LocGraphic u = Point2 u -> Graphic u--type DLocGraphic = LocGraphic Double---localLG :: -    (DrawingContext -> DrawingContext) -> LocGraphic u -> LocGraphic u-localLG upd img = \pt -> localDF upd (img pt) ----- | Composition operator for LocGraphic - both LocGraphics--- are drawn at the same origin and the results concatenated.-------lgappend :: LocGraphic u -> LocGraphic u -> LocGraphic u-lgappend f g = \pt -> f pt `mappend` g pt---------------------------------------------------------------------------------------- | Images return a value as well as drawing. A /node/ is a --- typical example - nodes are drawing but the also support --- taking anchor points.----type Image u a = DrawingF (a, HPrim u)--type DImage a = Image Double a--type LocImage u a = Point2 u -> Image u a--type DLocImage a = LocImage Double a--runImage :: DrawingContext -> Image u a -> (a,HPrim u)-runImage ctx img = (getDrawingF img) ctx---intoImage :: DrawingF a -> Graphic u -> Image u a-intoImage f g = DrawingF $ \ctx -> -    let a = getDrawingF f ctx; o = getDrawingF g ctx in (a,o)---intoLocImage :: LocDrawingF u a -> LocGraphic u -> LocImage u a-intoLocImage f g pt = DrawingF $ \ctx -> -    let a = getDrawingF (f pt) ctx; o = getDrawingF (g pt) ctx in (a,o)---xlinkImage :: XLink -> Image u a -> Image u a-xlinkImage xlink img = askDF >>= \ctx -> -    let (a,hp) = runImage ctx img -    in pureDF (a, singleH $ xlinkGroup xlink $ hprimToList hp)---------------------------------------------------------------------------------------type ConnDrawingF u a = Point2 u -> Point2 u -> DrawingF a--type DConnDrawingF a = ConnDrawingF Double a---- | ConnGraphic is a connector drawn between two points --- contructing a Graphic.----type ConnGraphic u = Point2 u -> Point2 u -> Graphic u--type DConnGraphic = ConnGraphic Double---- | ConImage is a connector drawn between two points --- constructing an Image.----type ConnImage u a = Point2 u -> Point2 u -> Image u a--type DConnImage a = ConnImage Double a---intoConnImage :: ConnDrawingF u a -> ConnGraphic u -> ConnImage u a-intoConnImage f g p1 p2 = DrawingF $ \ctx -> -    let a = getDrawingF (f p1 p2) ctx; o = getDrawingF (g p1 p2) ctx in (a,o)----

@@ -0,0 +1,140 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Graphic.DirectionContext+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- Reader monad over (angular) direction.+--+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Graphic.DirectionContext+  (++    DirectionM(..)+  , Direction+  , runDirection+  , DirectionT+  , runDirectionT++  , displacePerp+  , displacePara++  ) where++import Wumpus.Basic.Graphic.Base++import Wumpus.Core				-- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space++import Control.Applicative+++-- Should this use MonUnit for consistency ??++class Monad m => DirectionM m where+  localTheta    :: Radian -> m a -> m a+  asksTheta     :: (Radian -> a) -> m a +  parallel      :: Floating u => u -> m (Vec2 u)+  perpendicular :: Floating u => u -> m (Vec2 u)+++--+newtype Direction a = Direction { getDirection :: Radian -> a }++++instance Functor Direction where+  fmap f ma = Direction $ \r -> let a = getDirection ma r in f a++instance Applicative Direction where+  pure a    = Direction $ \_ -> a+  mf <*> ma = Direction $ \r -> let f = getDirection mf r+                                    a = getDirection ma r+             			in (f a)++instance Monad Direction where+  return a = Direction $ \_ -> a+  m >>= k  = Direction $ \r -> let a = getDirection m r+    	     	               in (getDirection . k) a r++++runDirection :: Radian -> Direction a -> a+runDirection theta sf = (getDirection sf) theta+++instance DirectionM Direction where+  localTheta theta ma = Direction $ \_ -> getDirection ma theta+  asksTheta fn        = Direction $ \r -> fn r+  parallel d          = Direction $ \r -> avec (circularModulo r) d+  perpendicular d     = Direction $ \r -> +                          avec (circularModulo $ (0.5*pi) + r) d  +++--------------------------------------------------------------------------------+-- Transformer++newtype DirectionT m a = DirectionT { getDirectionT :: Radian -> m a }++type instance MonUnit (DirectionT m) = MonUnit m++instance Monad m => Functor (DirectionT m) where+  fmap f ma = DirectionT $ \r -> getDirectionT ma r >>= \a -> return (f a)++instance Monad m => Applicative (DirectionT m) where+  pure a    = DirectionT $ \_ -> return a+  mf <*> ma = DirectionT $ \r -> getDirectionT mf r >>= \f -> +                                 getDirectionT ma r >>= \a ->+             			 return (f a)++instance Monad m => Monad (DirectionT m) where+  return a = DirectionT $ \_ -> return a+  m >>= k  = DirectionT $ \r -> getDirectionT m r >>= \a -> +    	     	      	     	(getDirectionT . k) a r++++instance Monad m => DirectionM (DirectionT m) where+  localTheta theta ma = DirectionT $ \_ -> getDirectionT ma theta+  asksTheta fn        = DirectionT $ \r -> return (fn r)+  parallel d          = DirectionT $ \r -> return (avec (circularModulo r) d)+  perpendicular d     = DirectionT $ \r -> +                          return (avec (circularModulo $ (0.5*pi) + r) d)+++-- Cross instances - needed to run SalingT /locally/ in Drawing.++instance DrawingCtxM m => DrawingCtxM (DirectionT m) where+  askDC           = DirectionT $ \_ -> askDC >>= \dctx -> return dctx+  localize ctx mf = DirectionT $ \r -> localize ctx (getDirectionT mf r)+++instance (Monad m, TraceM m) => TraceM (DirectionT m) where+  trace a  = DirectionT $ \_ -> trace a ++++++runDirectionT :: Radian -> DirectionT m a -> m a+runDirectionT theta sf = (getDirectionT sf) theta+++--------------------------------------------------------------------------------++displacePerp :: (DirectionM m, Floating u) => u -> Point2 u -> m (Point2 u)+displacePerp u pt = perpendicular u >>= \v -> return (pt .+^ v)+++displacePara :: (DirectionM m, Floating u) => u -> Point2 u -> m (Point2 u)+displacePara u pt = parallel u >>= \v -> return (pt .+^ v)

@@ -54,8 +54,7 @@   ) where  -import Wumpus.Basic.Graphic.BaseClasses-import Wumpus.Basic.Graphic.BaseTypes+import Wumpus.Basic.Graphic.Base import Wumpus.Basic.Graphic.DrawingContext   @@ -157,14 +156,14 @@ -- DrawingCtxM  instance DrawingCtxM (Drawing u) where-  askCtx         = Drawing $ \ctx s -> (ctx, s)-  localCtx cF ma = Drawing $ \ctx  s -> getDrawing ma (cF ctx) s+  askDC           = Drawing $ \ctx s -> (ctx, s)+  localize upd ma = Drawing $ \ctx s -> getDrawing ma (upd ctx) s    instance Monad m => DrawingCtxM (DrawingT u m) where-  askCtx         = DrawingT $ \ctx s -> return (ctx,s)-  localCtx cF ma = DrawingT $ \ctx s -> getDrawingT ma (cF ctx) s+  askDC           = DrawingT $ \ctx s -> return (ctx,s)+  localize upd ma = DrawingT $ \ctx s -> getDrawingT ma (upd ctx) s   @@ -281,7 +280,7 @@ -- This operation is analogeous to @tell@ in a Writer monad. --  draw :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Graphic u -> m ()-draw gf = askCtx >>= \ctx -> trace (runGraphic ctx gf)+draw gf = askDC >>= \ctx -> trace (runGraphic ctx gf)  -- | Hyperlink version of 'draw'. --@@ -298,7 +297,7 @@ -- monad, and the result is returned. --  drawi ::  (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Image u a -> m a-drawi img = askCtx >>= \ctx -> +drawi img = askDC >>= \ctx ->              let (a,o) = runImage ctx img in trace o >> return a  -- | Hyperlink version of 'drawi'.@@ -326,13 +325,13 @@  node :: (TraceM m, DrawingCtxM m, PointSupplyM m, u ~ MonUnit m)       => LocGraphic u -> m ()-node gfL = askCtx   >>= \ctx -> +node gfL = askDC   >>= \ctx ->             position >>= \pt  -> trace (runGraphic ctx $ gfL pt)   nodei :: (TraceM m, DrawingCtxM m, PointSupplyM m, u ~ MonUnit m)       => LocImage u a -> m a-nodei imgL = askCtx   >>= \ctx -> +nodei imgL = askDC   >>= \ctx ->               position >>= \pt  ->               let (a,o) = runImage ctx (imgL pt) in trace o >> return a 

@@ -8,7 +8,7 @@ -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com> -- Stability   :  highly unstable--- Portability :  GHC with TypeFamilies and more+-- Portability :  GHC -- -- Drawing attributes --@@ -25,8 +25,10 @@    -- * Drawing context     DrawingContext(..)+  , DrawingContextF    , standardContext+  , default_drawing_context    -- * Modifiers    -- ** Line widths@@ -34,6 +36,16 @@   , ultrathick   , thin +  -- ** Line caps+  , capButt+  , capRound+  , capSquare++  -- ** Line joins+  , joinMiter+  , joinRound+  , joinBevel+   -- ** Dash Pattern   , dashPattern   , unit_dash_pattern@@ -42,20 +54,20 @@   , doublegaps   , doubledashes -  -- ** Font properties+  -- * Font properties   , fontsize   , fontface -  -- ** Mark drawing size+  -- * Font / mark drawing size   , doublesize   , halfsize -  -- ** Colour+  -- * Colour   , swapColours-  , bothPrimary-  , bothSecondary-  , primaryColour-  , secondaryColour +  , bothStrokeColour+  , bothFillColour+  , strokeColour+  , fillColour    @@ -73,32 +85,34 @@ data DrawingContext = DrawingContext       { stroke_props          :: StrokeAttr       , font_props            :: FontAttr-      , primary_colour        :: RGBi      -- usually the stroke colour-      , secondary_colour      :: RGBi      -- usually the fill colour+      , stroke_colour         :: RGBi      -- also text colour...+      , fill_colour           :: RGBi             , line_spacing_factor   :: Double       }   deriving (Eq,Show) +type DrawingContextF = DrawingContext -> DrawingContext + standardContext :: FontSize -> DrawingContext standardContext sz = -    DrawingContext { stroke_props           = default_stroke_attr-                   , font_props             = FontAttr sz courier-                   , primary_colour         = black-                   , secondary_colour       = light_gray-                   , line_spacing_factor    = 1.2  +    DrawingContext { stroke_props         = default_stroke_attr+                   , font_props           = FontAttr sz courier+                   , stroke_colour        = black+                   , fill_colour          = light_gray+                   , line_spacing_factor  = 1.2                      }  -+default_drawing_context :: DrawingContext+default_drawing_context = +    standardContext (font_size wumpus_default_font)  -updateStrokeProps :: (StrokeAttr -> StrokeAttr) -                  -> DrawingContext -> DrawingContext+updateStrokeProps :: (StrokeAttr -> StrokeAttr) -> DrawingContextF updateStrokeProps fn = (\s i -> s { stroke_props = fn i }) <*> stroke_props -updateFontProps :: (FontAttr -> FontAttr) -                -> DrawingContext -> DrawingContext+updateFontProps :: (FontAttr -> FontAttr) -> DrawingContextF updateFontProps fn = (\s i -> s { font_props = fn i }) <*> font_props  @@ -120,7 +134,7 @@ thin_line           :: Double thin_line           = 0.5 -setLineWidth       :: Double -> DrawingContext -> DrawingContext+setLineWidth       :: Double -> DrawingContextF setLineWidth d      = updateStrokeProps (\s -> s { line_width = d })  -- | Set the line width to a /thick/.@@ -128,18 +142,47 @@ -- Note this context update is /oblivious/ - operationally the  -- line width is set to exactly @2.0@. ---thick               :: DrawingContext -> DrawingContext+thick               :: DrawingContextF thick               = setLineWidth thick_line -ultrathick          :: DrawingContext -> DrawingContext+ultrathick          :: DrawingContextF ultrathick          = setLineWidth ultra_thick_line -thin                :: DrawingContext -> DrawingContext+thin                :: DrawingContextF thin                = setLineWidth thin_line ++setLineCap          :: LineCap -> DrawingContextF+setLineCap d        = updateStrokeProps (\s -> s { line_cap = d })+++capButt             :: DrawingContextF+capButt             = setLineCap CapButt++capRound            :: DrawingContextF+capRound            = setLineCap CapRound++capSquare           :: DrawingContextF+capSquare           = setLineCap CapSquare+++setLineJoin         :: LineJoin -> DrawingContextF+setLineJoin d       = updateStrokeProps (\s -> s { line_join = d })+++joinMiter           :: DrawingContextF+joinMiter           = setLineJoin JoinMiter++joinRound           :: DrawingContextF+joinRound           = setLineJoin JoinRound++joinBevel           :: DrawingContextF+joinBevel           = setLineJoin JoinBevel++ -------------------------------------------------------------------------------- -dashPattern         :: DashPattern -> DrawingContext -> DrawingContext+dashPattern         :: DashPattern -> DrawingContextF dashPattern d       = updateStrokeProps (\s -> s { dash_pattern = d })          unit_dash_pattern   :: DashPattern@@ -171,10 +214,10 @@ --------------------------------------------------------------------------------  -fontface            :: FontFace -> DrawingContext -> DrawingContext+fontface            :: FontFace -> DrawingContextF fontface ff         = updateFontProps (\(FontAttr sz _) -> FontAttr sz ff) -fontsize            :: Int -> DrawingContext -> DrawingContext+fontsize            :: Int -> DrawingContextF fontsize sz         = updateFontProps (\(FontAttr _ ff) -> FontAttr sz ff)  --------------------------------------------------------------------------------@@ -182,7 +225,7 @@ -- | Set the font size to double the current size, note the font -- size also controls the size of dots, arrowsheads etc. -- -doublesize          :: DrawingContext -> DrawingContext+doublesize          :: DrawingContextF doublesize          = (\s sz -> fontsize (sz*2) s) <*> (font_size . font_props)  @@ -192,30 +235,30 @@ -- As fontsize is an integer this is not exact - half size of -- 15pt type is 7pt. -- -halfsize            :: DrawingContext -> DrawingContext+halfsize            :: DrawingContextF halfsize            = (\s sz -> fontsize (sz `div` 2) s)                          <*> (font_size . font_props)   -------------------------------------------------------------------------------- -swapColours :: DrawingContext -> DrawingContext+swapColours :: DrawingContextF swapColours = -    (\s a b -> s { primary_colour = b, secondary_colour = a })-        <*> primary_colour <*> secondary_colour+    (\s a b -> s { stroke_colour = b, fill_colour = a })+        <*> stroke_colour <*> fill_colour -bothPrimary :: DrawingContext -> DrawingContext-bothPrimary = (\s a -> s { secondary_colour = a }) <*> primary_colour+bothStrokeColour :: DrawingContextF+bothStrokeColour = (\s a -> s { fill_colour = a }) <*> stroke_colour -bothSecondary :: DrawingContext -> DrawingContext-bothSecondary = (\s a -> s { primary_colour = a }) <*> secondary_colour+bothFillColour :: DrawingContextF+bothFillColour = (\s a -> s { stroke_colour = a }) <*> fill_colour   -primaryColour :: RGBi -> DrawingContext -> DrawingContext-primaryColour rgb = \s -> s { primary_colour = rgb } +strokeColour :: RGBi -> DrawingContextF+strokeColour rgb = \s -> s { stroke_colour = rgb }   -secondaryColour :: RGBi -> DrawingContext -> DrawingContext-secondaryColour rgb = \s -> s { secondary_colour = rgb } +fillColour :: RGBi -> DrawingContextF+fillColour rgb = \s -> s { fill_colour = rgb }  

@@ -49,6 +49,7 @@    , straightLine   , straightLineBetween+  , curveBetween    , strokedRectangle   , filledRectangle@@ -66,7 +67,7 @@    ) where -import Wumpus.Basic.Graphic.BaseTypes+import Wumpus.Basic.Graphic.Base import Wumpus.Basic.Graphic.DrawingContext import Wumpus.Basic.Graphic.Query @@ -217,6 +218,10 @@  straightLineBetween :: Fractional u => Point2 u -> Point2 u -> Graphic u straightLineBetween p1 p2 = openStroke $ path p1 [lineTo p2]++curveBetween :: Fractional u +             => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Graphic u+curveBetween sp cp1 cp2 ep = openStroke $ path sp [curveTo cp1 cp2 ep]   

@@ -8,7 +8,7 @@ -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com> -- Stability   :  highly unstable--- Portability :  GHC with TypeFamilies and more+-- Portability :  GHC -- -- Querying the Drawing Context. --@@ -33,6 +33,7 @@   , lineWidth   , fontSize   , markHeight+  , markHalfHeight   , lineSpacing    -- @@ -48,7 +49,7 @@   , monoVecToCenter     ) where -import Wumpus.Basic.Graphic.BaseTypes+import Wumpus.Basic.Graphic.Base import Wumpus.Basic.Graphic.DrawingContext  @@ -57,54 +58,57 @@ import Control.Applicative  -textAttr :: DrawingF (RGBi,FontAttr)-textAttr = (,) <$> asksDF primary_colour <*> asksDF font_props+textAttr :: (Applicative m, DrawingCtxM m) => m (RGBi,FontAttr)+textAttr = (,) <$> asksDC stroke_colour <*> asksDC font_props  -- | Because @textAttr@ is so commonly used here is a functional -- version that avoids tupling. ---withTextAttr :: (RGBi -> FontAttr -> a) -> DrawingF a-withTextAttr fn = fn <$> asksDF primary_colour <*> asksDF font_props+withTextAttr :: (Applicative m, DrawingCtxM m) +             => (RGBi -> FontAttr -> a) -> m a+withTextAttr fn = fn <$> asksDC stroke_colour <*> asksDC font_props  -strokeAttr :: DrawingF (RGBi, StrokeAttr)-strokeAttr = (,) <$> asksDF primary_colour <*> asksDF stroke_props+strokeAttr :: (Applicative m, DrawingCtxM m) => m (RGBi, StrokeAttr)+strokeAttr = (,) <$> asksDC stroke_colour <*> asksDC stroke_props -withStrokeAttr :: (RGBi -> StrokeAttr -> a) -> DrawingF a-withStrokeAttr fn = fn <$> asksDF primary_colour <*> asksDF stroke_props+withStrokeAttr :: (Applicative m, DrawingCtxM m) +               => (RGBi -> StrokeAttr -> a) -> m a+withStrokeAttr fn = fn <$> asksDC stroke_colour <*> asksDC stroke_props  -fillAttr :: DrawingF RGBi-fillAttr = asksDF secondary_colour+fillAttr :: (Applicative m, DrawingCtxM m) => m RGBi+fillAttr = asksDC fill_colour -withFillAttr :: (RGBi -> a) -> DrawingF a-withFillAttr fn = fn <$> asksDF secondary_colour+withFillAttr :: (Applicative m, DrawingCtxM m) => (RGBi -> a) -> m a+withFillAttr fn = fn <$> asksDC fill_colour -borderedAttr :: DrawingF (RGBi, StrokeAttr, RGBi)-borderedAttr = (,,) <$> asksDF secondary_colour <*> asksDF stroke_props -                                                <*> asksDF primary_colour+borderedAttr :: (Applicative m, DrawingCtxM m) => m (RGBi, StrokeAttr, RGBi)+borderedAttr = (,,) <$> asksDC fill_colour <*> asksDC stroke_props +                                           <*> asksDC stroke_colour -withBorderedAttr :: (RGBi -> StrokeAttr -> RGBi -> a) -> DrawingF a+withBorderedAttr :: (Applicative m, DrawingCtxM m) +                 => (RGBi -> StrokeAttr -> RGBi -> a) -> m a withBorderedAttr fn = -    fn <$> asksDF secondary_colour <*> asksDF stroke_props -                                   <*> asksDF primary_colour+    fn <$> asksDC fill_colour <*> asksDC stroke_props +                              <*> asksDC stroke_colour    -lineWidth :: DrawingF Double-lineWidth = line_width <$> asksDF stroke_props+lineWidth :: (Applicative m, DrawingCtxM m) => m Double+lineWidth = line_width <$> asksDC stroke_props -fontSize :: DrawingF Int-fontSize = font_size <$> asksDF font_props+fontSize :: (Applicative m, DrawingCtxM m) => m Int+fontSize = font_size <$> asksDC font_props     -- Maybe these functions are better as queries - i.e. functions--- of type DrawingF, e.g.+-- of type DrawingR, e.g. -- --- > lineSpacing :: Fractional u => DrawingF u+-- > lineSpacing :: Fractional u => DrawingR u --  -- Then the /client/ can just bound the answer directly -- rather than using @@ -112,19 +116,26 @@ -- > askDF lineSpacing >>= \u -> ... -- -lineSpacing :: Fractional u => DrawingF u+lineSpacing :: (Applicative m, DrawingCtxM m, Fractional u) => m u lineSpacing =      (\sz factor -> realToFrac $ factor * fromIntegral sz)-      <$> asksDF (font_size . font_props) <*> asksDF line_spacing_factor+      <$> asksDC (font_size . font_props) <*> asksDC line_spacing_factor --- | A Mark is consider to be the height of a lowercase letter--- in the current font.--- --- Note better to use xlowerHeight+-- | The /mark/ height is the height of a lowercase letter in the +-- current font.+--+-- Arrowheads, dots etc. should generally be drawn at the mark +-- height. -- -markHeight :: FromPtSize u => DrawingF u-markHeight = (fromPtSize . xcharHeight . font_size) <$> asksDF font_props+markHeight :: (Applicative m, DrawingCtxM m, FromPtSize u) => m u+markHeight = (fromPtSize . xcharHeight . font_size) <$> asksDC font_props ++markHalfHeight :: (Applicative m, DrawingCtxM m, Fractional u, FromPtSize u) +               => m u+markHalfHeight = (0.5*) <$> markHeight++ -- Note - there are probably enough functions that use just  -- markHeight to merit a withMarkHeight function. @@ -135,28 +146,28 @@  -------------------------------------------------------------------------------- -withFontSize :: (FontSize -> u) -> DrawingF u-withFontSize fn = fn . font_size <$> asksDF font_props+withFontSize :: (Applicative m, DrawingCtxM m) => (FontSize -> u) -> m u+withFontSize fn = (fn . font_size) <$> asksDC font_props -monoCharWidth :: FromPtSize u => DrawingF u+monoCharWidth :: (Applicative m, DrawingCtxM m, FromPtSize u) => m u monoCharWidth = withFontSize (fromPtSize . charWidth) -monoSpacerWidth :: FromPtSize u => DrawingF u+monoSpacerWidth :: (Applicative m, DrawingCtxM m, FromPtSize u) => m u monoSpacerWidth = withFontSize (fromPtSize . spacerWidth)  -monoTextWidth :: FromPtSize u => Int -> DrawingF u+monoTextWidth :: (Applicative m, DrawingCtxM m, FromPtSize u) => Int -> m u monoTextWidth n = withFontSize $ \sz -> fromPtSize $ textWidth sz n  -monoTextLength :: FromPtSize u => String -> DrawingF u+monoTextLength :: (Applicative m, DrawingCtxM m, FromPtSize u) => String -> m u monoTextLength ss = monoTextWidth $ charCount ss  -monoTextHeight :: FromPtSize u => DrawingF u+monoTextHeight :: (Applicative m, DrawingCtxM m, FromPtSize u) => m u monoTextHeight = withFontSize (fromPtSize . textHeight) -monoNumeralHeight :: FromPtSize u => DrawingF u+monoNumeralHeight :: (Applicative m, DrawingCtxM m, FromPtSize u) => m u monoNumeralHeight = withFontSize (fromPtSize . numeralHeight)  @@ -164,10 +175,10 @@ --   -- \'x\' has no ascenders or descenders.  -- -monoLowerxHeight :: FromPtSize u => DrawingF u+monoLowerxHeight :: (Applicative m, DrawingCtxM m, FromPtSize u) => m u monoLowerxHeight = withFontSize (fromPtSize . xcharHeight) -monoDescenderDepth :: FromPtSize u => DrawingF u+monoDescenderDepth :: (Applicative m, DrawingCtxM m, FromPtSize u) => m u monoDescenderDepth = withFontSize (fromPtSize . descenderDepth)  @@ -177,16 +188,18 @@ -- Note - the width will generally be a over-estimate for  -- non-monospaced fonts. -- -monoTextDimensions :: (Num u, Ord u, FromPtSize u) => String -> DrawingF (u,u)+monoTextDimensions :: (Applicative m, DrawingCtxM m, Num u, Ord u, FromPtSize u)+                   => String -> m (u,u) monoTextDimensions ss =      (\sz -> post $ textBounds sz zeroPt ss) -      <$> asksDF (font_size . font_props)+      <$> asksDC (font_size . font_props)   where     post bb = (boundaryWidth bb, boundaryHeight bb)   -- | Vector from baseline left to center-monoVecToCenter :: (Fractional u, Ord u, FromPtSize u) -                => String -> DrawingF (Vec2 u)+monoVecToCenter :: ( Applicative m, DrawingCtxM m+                   , Fractional u, Ord u, FromPtSize u ) +                => String -> m (Vec2 u) monoVecToCenter ss = (\(w,h) dy -> vec (0.5*w) (0.5*h - dy))                         <$> monoTextDimensions ss <*> monoDescenderDepth

@@ -17,8 +17,10 @@  module Wumpus.Basic.Graphic.ScalingContext   (-    ScalingContext(..) +    ScalingM(..)+  , ScalingContext(..)+   , Scaling   , runScaling   , ScalingT@@ -33,12 +35,28 @@    ) where -import Wumpus.Basic.Graphic.BaseClasses+import Wumpus.Basic.Graphic.Base  import Wumpus.Core				-- package: wumpus-core  import Control.Applicative +++-- | Scaling...+--+class Monad m => ScalingM m where+  type XDim m :: *+  type YDim m :: *+  scaleX :: (u ~ MonUnit m, ux ~ XDim m) => ux -> m u+  scaleY :: (u ~ MonUnit m, uy ~ YDim m) => uy -> m u+  scalePt  :: (u ~ MonUnit m, ux ~ XDim m, uy ~ YDim m) +           => ux -> uy -> m (Point2 u)+  scaleVec :: (u ~ MonUnit m, ux ~ XDim m, uy ~ YDim m) +           => ux -> uy -> m (Vec2 u)+++ data ScalingContext ux uy u = ScalingContext       { scale_in_x  :: ux -> u       , scale_in_y  :: uy -> u@@ -128,8 +146,8 @@ -- Cross instances - needed to run SalingT /locally/ in Drawing.  instance DrawingCtxM m => DrawingCtxM (ScalingT ux uy u m) where-  askCtx   = ScalingT $ \_ -> askCtx >>= \dctx -> return dctx-  localCtx ctx mf = ScalingT $ \sctx -> localCtx ctx (getScalingT mf sctx)+  askDC           = ScalingT $ \_    -> askDC >>= \dctx -> return dctx+  localize upd mf = ScalingT $ \sctx -> localize upd (getScalingT mf sctx)   instance (Monad m, TraceM m, u ~ MonUnit m) => TraceM (ScalingT ux uy u m) where

@@ -125,8 +125,8 @@ -- Cross instances  instance DrawingCtxM m => DrawingCtxM (TurtleT u m) where-  askCtx   = TurtleT $ \s -> askCtx >>= \ ctx -> return (ctx,s)-  localCtx ctx mf = TurtleT $ \s -> localCtx ctx (getTurtleT mf s)+  askDC           = TurtleT $ \s -> askDC >>= \ ctx -> return (ctx,s)+  localize upd mf = TurtleT $ \s -> localize upd (getTurtleT mf s)   -- This needs undecidable instances...

@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE FlexibleContexts           #-} {-# OPTIONS -Wall #-} @@ -22,23 +23,38 @@ module Wumpus.Basic.Paths.Base   (  -    Path(..)-  , PathSeg(..)-  , Curve(..)-  , Line(..)-  , emptyPath-  , pline-  , pcurve-  , addSegment-  , segmentLength-  , segmentStart-  , segmentEnd+    Path+  , DPath+  , length+  , line+  , curve+  , tracePoints+  , curveByAngles    , toPrimPath    , toPrimPathU-  , subdivide-  , subdividet-    +++  , tipL+  , tipR++  , shortenBoth+  , shortenL+  , shortenR+  , directionL+  , directionR++  , midpoint++  , PathViewL(..)+  , DPathViewL+  , PathViewR(..)+  , DPathViewR+  , PathSegment(..)+  , DPathSegment+  , pathViewL+  , pathViewR+   ) where  @@ -48,77 +64,127 @@ import Data.VectorSpace  import Data.Maybe-import Data.Sequence ( Seq, ViewL(..), viewl, (|>)  )+import Data.Monoid+import Data.Sequence ( Seq, (><), ViewL(..), viewl+                     , ViewR(..), viewr, (<|) , (|>) ) import qualified Data.Sequence as S --- Note - path doesn\'t need a drawing context for --- construction...------ type PathF u = Point2 u -> Point2 u -> Path u-+import Prelude hiding ( length ) -data Path u = Path -       { path_length    :: u -       , path_elements  :: Seq (PathSeg u)-       }+data Path u = PathEmpty +            | Path { _path_length   :: u +                   , _path_start    :: Point2 u+                   , _path_elements :: Seq (PathSeg u)+                   , _path_end      :: Point2 u+                   }   deriving (Eq,Ord,Show) +type DPath = Path Double +-- Annotating each segment with length is \*\* good \*\*.+-- Makes it much more efficient to find the midpoint.+--+-- But what do we do about the start point:+--+-- a) put it in the segment - too much info in the type, allows +-- consistency problems vis-a-vis gaps in the path.+--+-- b) leave it out - too little info in the type, allows +-- consistency problems with length.+--+-- Option (a) is probably most convenient espcially as the +-- constructors won\'t be exported.+ -- Annotation is length... -- -data PathSeg u = LineSeg  u (Line u)-               | CurveSeg u (Curve u)+data PathSeg u = LineSeg  { _line_length  :: u +                          , _line_start   :: Point2 u+                          , _line_end     :: Point2 u+                          }+               | CurveSeg { _curve_length :: u +                          , _curve_start  :: Point2 u+                          , _ctrl_pt_one  :: Point2 u+                          , _ctrl_pt_two  :: Point2 u+                          , _curve_end    :: Point2 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)+type instance DUnit (Path u)    = u+type instance DUnit (PathSeg u) = u -data Line u = Line -      { line_start  :: Point2 u-      , line_end    :: Point2 u -      }-  deriving (Eq,Ord,Show)  -emptyPath :: Num u => Path u -emptyPath = Path 0 S.empty+length :: Num u => Path u -> u+length PathEmpty      = 0+length (Path u _ _ _) = u +append :: Floating u => Path u -> Path u -> Path u+append PathEmpty b         = b+append a         PathEmpty = a+append (Path len1 start1 se1 end1) (Path len2 start2 se2 end2) +    | end1 == start2 = Path (len1+len2) start1 (se1 >< se2) end2 +    | otherwise      = let join      = lineSegment end1 start2+                           total_len = len1 + len2 + segmentLength join+                       in Path total_len start1 (se1 >< (join <| se2)) end2  -addSegment :: Num u => Path u -> PathSeg u -> Path u-addSegment (Path n se) e@(LineSeg u _)  = Path (n+u) (se |> e)-addSegment (Path n se) e@(CurveSeg u _) = Path (n+u) (se |> e) +instance Floating u => Monoid (Path u) where+  mempty  = PathEmpty+  mappend = append+++ segmentLength :: PathSeg u -> u-segmentLength (LineSeg  u _) = u-segmentLength (CurveSeg u _) = u+segmentLength (LineSeg u _ _)       = u+segmentLength (CurveSeg u _ _ _ _)  = u + segmentStart :: PathSeg u -> Point2 u-segmentStart (LineSeg  _ (Line p0 _))      = p0-segmentStart (CurveSeg _ (Curve p0 _ _ _)) = p0+segmentStart (LineSeg  _ p0 _)      = p0+segmentStart (CurveSeg _ p0 _ _ _)  = p0  segmentEnd :: PathSeg u -> Point2 u-segmentEnd (LineSeg  _ (Line _ p1))      = p1-segmentEnd (CurveSeg _ (Curve _ _ _ p3)) = p3+segmentEnd (LineSeg  _ _ p1)        = p1+segmentEnd (CurveSeg _ _ _ _ p3)    = p3    -pline :: Floating u => Point2 u -> Point2 u -> PathSeg u -pline p0 p1 = LineSeg (vlength $ pvec p0 p1) (Line p0 p1)+lineSegment :: Floating u => Point2 u -> Point2 u -> PathSeg u +lineSegment p0 p1 = let v = vlength $ pvec p0 p1 in LineSeg v p0 p1 -pcurve :: (Floating u, Ord u)-       => Point2 u -> Point2 u -> Point2 u -> Point2 u -> PathSeg u -pcurve p0 p1 p2 p3 = -    let c = Curve p0 p1 p2 p3 in CurveSeg (curveLength c) c+line :: Floating u => Point2 u -> Point2 u -> Path u +line p0 p1 = let v = vlength $ pvec p0 p1 +             in Path v p0 (S.singleton $ LineSeg v p0 p1) p1+    +curve :: (Floating u, Ord u)+      => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Path u +curve p0 p1 p2 p3 = let v = curveLength p0 p1 p2 p3+                    in Path v p0 (S.singleton $ CurveSeg v p0 p1 p2 p3) p3 --- | Turn a BasicPath into an ordinary Path.++tracePoints :: Floating u => [Point2 u] -> Path u+tracePoints []       = PathEmpty+tracePoints [a]      = line a a+tracePoints (a:b:xs) = step (line a b) b xs+  where+    step acc _ []     = acc+    step acc e (y:ys) = step (acc `mappend` line e y) y ys+++curveByAngles :: (Floating u, Ord u) +              => Point2 u -> Radian -> Radian -> Point2 u -> Path u+curveByAngles start cin cout end = curve start (start .+^ v1) (end .+^ v2) end+  where+    sz     = 0.375 * (vlength $ pvec start end)+    v1     = avec cin  sz+    v2     = avec cout sz++++-- | Turn a Path into an ordinary PrimPath. -- -- An empty path returns Nothing - the path representation in  -- Wumpus-Core does not allow empty paths - a path must always@@ -129,21 +195,22 @@ -- segment. -- toPrimPath :: Path u -> Maybe (PrimPath u)-toPrimPath = step1 . viewl . path_elements+toPrimPath PathEmpty         = Nothing+toPrimPath (Path _ _ segs _) = step1 $ viewl segs   where-    step1 EmptyL               = Nothing-    step1 (e :< se)            = let (p1,s) = elemP e in -                                 Just $ path p1 $ s : step2 (viewl se)+    step1 EmptyL                  = Nothing+    step1 (e :< se)               = let (start,a) = seg1 e in +                                    Just $ path start $ a : step2 (viewl se) -    step2 EmptyL               = []-    step2 (e :< se)            = snd (elemP e) : step2 (viewl se)+    step2 EmptyL                  = []+    step2 (e :< se)               = seg2 e : step2 (viewl se)     -    elemP (LineSeg  _ l)       = elemL l-    elemP (CurveSeg _ c)       = elemC c+    seg1 (LineSeg  _ p0 p1)       = (p0, lineTo p1)+    seg1 (CurveSeg _ p0 p1 p2 p3) = (p0, curveTo p1 p2 p3)  -    elemL (Line p1 p2)         = (p1, lineTo p2)-    elemC (Curve p1 p2 p3 p4)  = (p1, curveTo p2 p3 p4)-+    seg2 (LineSeg  _ _  p1)       = lineTo p1+    seg2 (CurveSeg _ _  p1 p2 p3) = curveTo p1 p2 p3+  toPrimPathU :: Path u -> PrimPath u toPrimPathU = fromMaybe errK . toPrimPath   where@@ -154,14 +221,18 @@ -------------------------------------------------------------------------------- -- Curve length -curveLength :: (Floating u, Ord u) => Curve u -> u-curveLength = gravesenLength 0.1+data StrictCurve u = Curve !(Point2 u) !(Point2 u) !(Point2 u) !(Point2 u) +curveLength :: (Floating u, Ord u)      +            => Point2 u -> Point2 u -> Point2 u -> Point2 u -> u+curveLength p0 p1 p2 p3 = gravesenLength 0.1 $ Curve p0 p1 p2 p3++ -- | 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 :: (Floating u, Ord u) => u -> StrictCurve u -> u gravesenLength err_tol crv = step crv where   step c = let l1 = ctrlPolyLength c                l0 = cordLength c@@ -170,12 +241,12 @@               else 0.5*l0 + 0.5*l1  -ctrlPolyLength :: Floating u => Curve u -> u+ctrlPolyLength :: Floating u => StrictCurve 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 :: Floating u => StrictCurve u -> u cordLength (Curve p0 _ _ p3) = vlength $ pvec p0 p3  @@ -187,7 +258,8 @@  -- | Curve subdivision via de Casteljau\'s algorithm. ---subdivide :: Fractional u => Curve u -> (Curve u, Curve u)+subdivide :: Fractional u +          => StrictCurve u -> (StrictCurve u, StrictCurve u) subdivide (Curve p0 p1 p2 p3) =     (Curve p0 p01 p012 p0123, Curve p0123 p123 p23 p3)   where@@ -201,7 +273,7 @@ -- | subdivide with an affine weight along the line... -- subdividet :: Real u-           => u -> Curve u -> (Curve u, Curve u)+           => u -> StrictCurve u -> (StrictCurve u, StrictCurve u) subdividet t (Curve p0 p1 p2 p3) =      (Curve p0 p01 p012 p0123, Curve p0123 p123 p23 p3)   where@@ -215,3 +287,196 @@ affineCombination :: Real u => u -> Point2 u -> Point2 u -> Point2 u affineCombination a p1 p2 = p1 .+^ a *^ (p2 .-. p1) +--------------------------------------------------------------------------------+-- tips ++tipL :: Path u -> Maybe (Point2 u)+tipL PathEmpty       = Nothing+tipL (Path _ sp _ _) = Just sp+++tipR :: Path u -> Maybe (Point2 u)+tipR PathEmpty       = Nothing+tipR (Path _ _ _ ep) = Just ep+++-- | Shorten both ends...+--+shortenBoth :: (Real u, Floating u) => u -> Path u -> Path u+shortenBoth u p = shortenL u $ shortenR u p++--------------------------------------------------------------------------------+-- shorten from the left...++shortenL :: (Real u, Floating u) => u -> Path u -> Path u+shortenL _ PathEmpty          = PathEmpty+shortenL n (Path u _ segs ep) +    | n >= u                  = PathEmpty+    | otherwise               = step n (viewl segs)+  where+    step _ EmptyL     = PathEmpty+    step d (e :< se)  = let z  = segmentLength e in+                        case compare d z of+                          GT -> step (d-z) (viewl se)+                          EQ -> makeLeftPath (u-n) se ep+                          LT -> let e1 = shortenSegL d e+                                in Path (u-n) (segmentStart e1) (e1 <| se) ep+++makeLeftPath :: u -> Seq (PathSeg u) -> Point2 u -> Path u+makeLeftPath u se ep = +    case viewl se of+      EmptyL   -> PathEmpty +      (e :< _) -> Path u (segmentStart e) se ep+++shortenSegL :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u+shortenSegL n (LineSeg  u p0 p1)        = +    LineSeg  (u-n) (shortenLineL n p0 p1) p1++shortenSegL n (CurveSeg u p0 p1 p2 p3)  = +    let (Curve p0' p1' p2' p3') = snd $ subdividet (n/u) (Curve p0 p1 p2 p3)+    in CurveSeg (u-n) p0' p1' p2' p3'+++shortenLineL :: (Real u, Floating u) +             => u -> Point2 u -> Point2 u -> Point2 u+shortenLineL n p0 p1 = p0 .+^ v+  where+    v0 = p1 .-. p0+    v  = avec (direction v0) n++++--------------------------------------------------------------------------------+-- shorten from the right ...+ +shortenR :: (Real u, Floating u) => u -> Path u -> Path u+shortenR _ PathEmpty          = PathEmpty+shortenR n (Path u sp segs _) +    | n >= u                  = PathEmpty+    | otherwise               = step n (viewr segs)+  where+    step _ EmptyR     = PathEmpty+    step d (se :> e)  = let z = segmentLength e in+                        case compare d z of+                          GT -> step (d-z) (viewr se)+                          EQ -> makeRightPath n sp se+                          LT -> let e1 = shortenSegR d e+                                in Path (u-n) sp (se |> e1) (segmentEnd e1)+                         ++makeRightPath :: u -> Point2 u -> Seq (PathSeg u) -> Path u+makeRightPath u sp se = +    case viewr se of+      EmptyR   -> PathEmpty +      (_ :> e) -> Path u sp se (segmentEnd e)++++shortenSegR :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u+shortenSegR n (LineSeg  u p0 p1)        = +    LineSeg  (u-n) p0 (shortenLineR n p0 p1) ++shortenSegR n (CurveSeg u p0 p1 p2 p3)  = +    let (Curve p0' p1' p2' p3') = fst $ subdividet ((u-n)/u) (Curve p0 p1 p2 p3)+    in CurveSeg (u-n) p0' p1' p2' p3'+++shortenLineR :: (Real u, Floating u) +             => u -> Point2 u -> Point2 u -> Point2 u+shortenLineR n p0 p1 = p1 .+^ v+  where+    v0 = p0 .-. p1+    v  = avec (direction v0) n+++++--------------------------------------------------------------------------------+-- line direction++-- | Direction of empty path is considered to be 0.+--+directionL :: (Real u, Floating u) => Path u -> Radian+directionL PathEmpty        = 0+directionL (Path _ _ se _)  = step $ viewl se+  where+    step (LineSeg  _ p0 p1 :< _)      = lineDirection p1 p0  -- 1-to-0+    step (CurveSeg _ p0 p1 _ _ :< _)  = lineDirection p1 p0+    step _                            = 0+++-- | Direction of empty path is considered to be 0.+--+directionR :: (Real u, Floating u) => Path u -> Radian+directionR PathEmpty       = 0+directionR (Path _ _ se _) = step $ viewr se+  where+    step (_ :> LineSeg  _ p0 p1)      = lineDirection p0 p1+    step (_ :> CurveSeg _ _  _ p2 p3) = lineDirection p2 p3+    step _                            = 0++{-+-- Note - previously Paths were using this version of +-- lineDirection+-- +-- Needs testing as to whether the new one does what is expected. +--+lineDirection :: (Real u, Floating u) => Point2 u -> Point2 u -> Radian+lineDirection p0 p1 = direction (pvec p0 p1)+-}++++--------------------------------------------------------------------------------+++-- Return direction as well because the calculation is expensive...+--+midpoint :: (Real u, Floating u) => Path u -> Maybe (Point2 u, Radian)+midpoint pa = let u = length pa in+  if u == 0 then Nothing +            else let pa1 = shortenR (u/2) pa +                 in fmap (\a -> (a,directionR pa1)) $ tipR pa1+++--------------------------------------------------------------------------------++data PathViewL u = EmptyPathL+                 | PathSegment u :<< Path u+  deriving (Eq,Ord,Show) ++type DPathViewL = PathViewL Double++data PathViewR u = EmptyPathR+                 | Path u :>> PathSegment u+  deriving (Eq,Ord,Show) ++type DPathViewR = PathViewR Double+++data PathSegment u = Line1  (Point2 u) (Point2 u)+                   | Curve1 (Point2 u) (Point2 u) (Point2 u) (Point2 u)+  deriving (Eq,Ord,Show) ++type DPathSegment = PathSegment Double++type instance DUnit (PathViewL u)   = u+type instance DUnit (PathViewR u)   = u+type instance DUnit (PathSegment u) = u++pathViewL :: Num u => Path u -> PathViewL u+pathViewL PathEmpty          = EmptyPathL+pathViewL (Path u _ segs ep) = case viewl segs of+    EmptyL                         -> EmptyPathL +    (LineSeg v p0 p1 :< se)        -> Line1 p0 p1 :<< Path (u-v) p1 se ep+    (CurveSeg v p0 p1 p2 p3 :< se) -> Curve1 p0 p1 p2 p3 :<< Path (u-v) p3 se ep+++pathViewR :: Num u => Path u -> PathViewR u+pathViewR PathEmpty          = EmptyPathR+pathViewR (Path u _ segs ep) = case viewr segs of+    EmptyR                         -> EmptyPathR+    (se :> LineSeg v p0 p1)        -> Path (u-v) p1 se ep :>> Line1 p0 p1+    (se :> CurveSeg v p0 p1 p2 p3) -> Path (u-v) p3 se ep :>> Curve1 p0 p1 p2 p3

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

@@ -12,7 +12,7 @@ -- Stability   :  highly unstable -- Portability :  GHC ----- Build paths.+-- Build paths monadically. -- -- \*\* WARNING \*\* this module is an experiment, and may  -- change significantly or even be dropped from future revisions.@@ -25,12 +25,17 @@     PathM   , runPath   , execPath++  , tip+   , lineto   , rlineto-  , vline   , hline+  , vline+   , bezierto   , curveto+   , verticalHorizontal   , horizontalVertical @@ -43,15 +48,29 @@ import Data.AffineSpace                         -- package: vector-space  import Control.Applicative+import Data.Maybe+import Data.Monoid -data PathState u = PathState ++-- Are connectors and paths quite different things?+--+-- It looks like they are - connectors always know start and end +-- points.+--+++-- State monad version is quite good - it ameliorates the problem+-- of joing to the end point of an empty path...++data St u = St       { current_point :: Point2 u -      , path_accum    :: Path u+      , path_acc      :: Path u       } -newtype PathM u a = PathM { getPathM :: PathState u -> (a,PathState u) } +newtype PathM u a = PathM { getPathM :: St u -> (a,St u) } + instance Functor (PathM u) where   fmap f mf = PathM $ \s -> let (a,s1) = getPathM mf s in (f a,s1) @@ -68,77 +87,64 @@                             (getPathM . k) a s1  --- Design note - it is probably best to follow LRText and have--- the path monad isolated from the trace monad. While it would --- be nice to trace arbitrary labels as we go, state changes to the --- DrawingCtx would make things complicated.--- -{--openStrokePathM :: (Num u, TraceM m, DrawingCtxM m, u ~ MonUnit m) -                => Point2 u -> PathM u a -> m a-openStrokePathM pt ma = let (a,p) = runPath pt ma  in -    draw (openStroke $ toPrimPathU p) >> return a--}---- Running the path is agnostic to the DrawingCtx.--runPath :: Num u => Point2 u -> PathM u a -> (a, Path u)-runPath start mf = let (a,s') = getPathM mf s in (a, path_accum s')+-- Running the path is (probably) agnostic to the DrawingCtx.+--+runPath :: Floating u => Point2 u -> PathM u a -> (a, Path u)+runPath start mf = let (a,s') = getPathM mf s in (a, path_acc s')   where-    s = PathState { current_point = start-                  , path_accum    = emptyPath-                  }+    s = St { current_point = start+           , path_acc      = mempty+           } -execPath :: Num u => Point2 u -> PathM u a -> Path u+execPath :: Floating u => Point2 u -> PathM u a -> Path u execPath start mf = snd $ runPath start mf +snocline :: Floating u => Vec2 u -> PathM u ()+snocline v = PathM $ \(St pt ac) -> let ep = pt .+^ v +                                    in ((), St ep (ac `mappend` line pt ep)) -exchTip :: Point2 u -> (Point2 u -> Path u -> Path u) -> PathM u ()-exchTip new updP = -    PathM $ \(PathState old bp) -> ((), PathState new (updP old bp))   tip :: PathM u (Point2 u) tip = PathM $ \s -> (current_point s,s)   lineto :: Floating u => Point2 u -> PathM u ()-lineto end = exchTip end upd-  where-    upd start bp = bp `addSegment` pline start end-+lineto pt = PathM $ \(St p0 ac) -> ((), St pt (ac `mappend` line p0 pt))  rlineto :: Floating u => Vec2 u -> PathM u () rlineto (V2 dx dy) = tip >>= \(P2 x y) -> lineto (P2 (x+dx) (y+dy)) + hline :: Floating u => u -> PathM u ()-hline dx = tip >>= \(P2 x y) -> lineto (P2 (x+dx) y)+hline len = snocline (hvec len)   vline :: Floating u => u -> PathM u ()-vline dy = tip >>= \(P2 x y) -> lineto (P2 x (y+dy))- +vline len = snocline (vvec len)  ++ bezierto :: (Floating u, Ord u)           => Point2 u -> Point2 u -> Point2 u -> PathM u ()-bezierto cp1 cp2 end = exchTip end upd -  where-    upd start bp = bp `addSegment` pcurve start cp1 cp2 end+bezierto c1 c2 ep = PathM $ \(St p0 ac) -> +    ((), St ep (ac `mappend` curve p0 c1 c2 ep))  ++++--++ curveto :: (Floating u, Ord u)          => Radian -> Radian -> Point2 u -> PathM u ()-curveto cin cout end = exchTip end upd-  where -    upd start bp = bp `addSegment` pcurveAng start cin cout end+curveto cin cout end = PathM $ \(St p0 ac) -> +    let seg  = curveByAngles p0 cin cout end +        ac1  = ac `mappend` seg+        end1 = fromMaybe end $ tipR ac1+    in ((), St end1 ac1)   -pcurveAng :: (Floating u, Ord u) -        => Point2 u -> Radian -> Radian -> Point2 u -> PathSeg 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 -> PathM u ()@@ -148,3 +154,4 @@ horizontalVertical :: Floating u => Point2 u -> PathM u () horizontalVertical (P2 x y) =      tip >>= \(P2 _ y0) -> lineto (P2 x y0) >> lineto (P2 x y)+

@@ -0,0 +1,114 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Paths.RoundCorners+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Drawing round cornered polygons.+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.Paths.RoundCorners+  ( +    cornerCurve+  , illustratePath+  , roundEvery++  ) where++import Wumpus.Basic.Colour.SVGColours+import Wumpus.Basic.Graphic+import Wumpus.Basic.Paths.Base hiding ( length )+import Wumpus.Basic.Utils.Intersection+++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space++import Data.Monoid+++-- | The length of the control-point vector wants to be slighly +-- longer than half of /d/ (d - being the distance between the +-- /truncated/ points and the corner).+--+cornerCurve :: (Real u, Floating u) +            => Point2 u -> Point2 u -> Point2 u -> Path u+cornerCurve p1 p2 p3 = curve p1 cp1 cp2 p3+  where+    len1 = 0.6 *  (vlength $ pvec p1 p2)+    len2 = 0.6 *  (vlength $ pvec p3 p2)+    cp1  = p1 .+^ (avec (langle p1 p2) len1)+    cp2  = p3 .+^ (avec (langle p3 p2) len2)+++roundEvery :: (Real u, Floating u) +           => u -> [Point2 u] -> Path u +roundEvery u (start:b:c:xs) = step (twoParts u start b c) (b:c:xs)+  where+    step acc (m:n:o:ps)     = step (acc `mappend` twoParts u m n o) (n:o:ps)+    step acc [n,o]          = acc `mappend` twoParts u n o start+                                  `mappend` twoParts u o start b +    step acc _              = acc+roundEvery _ _              = mempty+++-- | Two parts - line and corner curve...+--+twoParts :: (Real u, Floating u) +         => u ->  Point2 u -> Point2 u -> Point2 u -> Path u+twoParts u a b c = line p1 p2 `mappend` cornerCurve p2 b p3+  where+    p1 = a .+^ (avec (direction $ pvec a b) u)+    p2 = b .+^ (avec (direction $ pvec b a) u)+    p3 = b .+^ (avec (direction $ pvec b c) u)+ +++--------------------------------------------------------------------------------+-- ++-- This needs moving outside of the Path modules as it has +-- dependencies on SVGColour and Graphic (the Path modules should+-- be /neutral/ to wards depenedencies on other parts of +-- Wumpus-Basic).+--++illustratePath :: Fractional u => Path u -> Graphic u+illustratePath = localize (strokeColour black) . step1 . pathViewL+  where+    step1 EmptyPathL = mempty+    step1 (e :<< se) = drawPathBoth e `mappend` rest (pathViewL se)++    rest EmptyPathL = mempty+    rest (e :<< se) = drawPath1 e `mappend` rest (pathViewL se)++drawPathBoth :: Fractional u => PathSegment u -> Graphic u+drawPathBoth pa@(Line1 p1 _)      = drawPath1 pa `mappend` pathPoint p1+drawPathBoth pa@(Curve1 p1 _ _ _) = drawPath1 pa `mappend` pathPoint p1++drawPath1 :: Fractional u => PathSegment u -> Graphic u+drawPath1 (Line1 p1 p2)        = +    straightLineBetween p1 p2 `mappend` pathPoint p2++drawPath1 (Curve1 p1 p2 p3 p4) =  +    mconcat [ bezierCtrl p1 p2, bezierCtrl p4 p3, curveBetween p1 p2 p3 p4+            , pathPoint p4]+++bezierCtrl :: Fractional u => Point2 u -> Point2 u -> Graphic u+bezierCtrl p1 p2 = +    localize (strokeColour light_steel_blue . fillColour red) $+      straightLineBetween p1 p2 `mappend` filledDisk 1 p2+++pathPoint :: Num u => Point2 u -> Graphic u+pathPoint = localize bothStrokeColour . filledDisk 1+

@@ -50,6 +50,21 @@ import Data.Monoid  +-- | Note - this formulation prevents rounded corner shapes...+--+-- Currently shapes that aren\'t paths:+--+-- > Coordinate+-- > FreeLabel+--+-- Alternative +--+-- > out_fun :: ShapeCTM u -> (Path u,sh)+--+-- All shapes expect FreeLabel are oblivious to the +-- DrawingContext for the /shape/+--+ data Shape u sh =  Shape        { src_ctm :: ShapeCTM u        , out_fun :: ShapeCTM u -> Image u sh

@@ -119,7 +119,7 @@  outputRect :: (Real u, Floating u)             => u -> u -> ShapeLabel u -> ShapeCTM u -> Image u (Rectangle u)-outputRect hw hh shl ctm = intoImage (pureDF a) (drawRect a `mappend` label) +outputRect hw hh shl ctm = intoImage (return a) (drawRect a `mappend` label)    where     a     = Rectangle { rect_ctm = ctm, rect_hw = hw, rect_hh = hh }     label = runShapeLabel ctm shl@@ -193,7 +193,7 @@  outputCirc :: (Real u, Floating u)             => u -> ShapeLabel u -> ShapeCTM u -> Image u (Circle u)-outputCirc rad shl ctm = intoImage (pureDF a) (drawCirc a `mappend` label) +outputCirc rad shl ctm = intoImage (return a) (drawCirc a `mappend` label)    where     a     = Circle { circ_ctm = ctm, circ_radius = rad }     label = runShapeLabel ctm shl@@ -234,13 +234,13 @@                    }  outputCoord :: (Real u, Floating u) => ShapeCTM u -> Image u (Coordinate u)-outputCoord ctm = intoImage (pureDF a) (drawCoord a) +outputCoord ctm = intoImage (return a) (drawCoord a)    where     a = Coordinate { coord_ctm = ctm }   drawCoord :: (Real u, Floating u) => Coordinate u -> Graphic u-drawCoord coord = localDF swapColours $ filledEllipse 2 2 (center coord)+drawCoord coord = localize swapColours $ filledEllipse 2 2 (center coord)  -------------------------------------------------------------------------------- -- Diamond@@ -288,7 +288,7 @@  outputDia :: (Real u, Floating u)            => u -> u -> ShapeLabel u -> ShapeCTM u -> Image u (Diamond u)-outputDia hw hh shl ctm = intoImage (pureDF a) (drawDia a `mappend` label) +outputDia hw hh shl ctm = intoImage (return a) (drawDia a `mappend` label)    where     a     = Diamond { dia_ctm = ctm, dia_hw = hw, dia_hh = hh }     label = runShapeLabel ctm shl@@ -335,7 +335,7 @@  outputEll :: (Real u, Floating u)            => u -> u -> ShapeLabel u -> ShapeCTM u -> Image u (Ellipse u)-outputEll rx ry shl ctm = intoImage (pureDF a) (drawEll a `mappend` label)+outputEll rx ry shl ctm = intoImage (return a) (drawEll a `mappend` label)   where     a     = Ellipse { ell_ctm = ctm, ell_rx = rx, ell_ry = ry }     label = runShapeLabel ctm shl

@@ -117,10 +117,10 @@  runLRText :: (Num u, FromPtSize u) => LRText u a -> LocImage u a runLRText ma = \pt -> envZero >>= \e1 -> -                   let (a,st) = getLRText ma e1 st_zero -                   in mkline pt (acc_chr st) >>= \g1 ->-                      localDF (fontface symbol) (mkline pt (acc_sym st)) >>= \g2 ->-                      return (a,g1 `mappend` g2)+    let (a,st) = getLRText ma e1 st_zero +    in mkline pt (acc_chr st) >>= \g1 ->+       localize (fontface symbol) (mkline pt (acc_sym st)) >>= \g2 ->+       return (a,g1 `mappend` g2)   where     mkline pt h = case toListH h of                    [] -> return mempty@@ -137,7 +137,7 @@              , acc_sym         = emptyH }   -envZero :: FromPtSize u => DrawingF (Env u)+envZero :: FromPtSize u => DrawingR (Env u) envZero = (\sz -> Env { char_width   = fromPtSize $ charWidth sz                       , spacer_width = fromPtSize $ spacerWidth sz })             <$> fontSize

@@ -8,7 +8,7 @@ -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com> -- Stability   :  highly unstable--- Portability :  GHC with TypeFamilies and more+-- Portability :  GHC -- -- Intersection of line to line and line to plane -- 

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

@@ -1,5 +1,5 @@ name:             wumpus-basic-version:          0.9.0+version:          0.10.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -14,66 +14,57 @@   library turns out to be much more demanding than designing a    low-level one (Wumpus-Core).    .-  A few of the modules (SafeFonts, SVGColours, X11Colours) are-  fairly stable others simply aren\'t and may even disappear in-  subsequent updates.+  Some of the modules (SafeFonts, SVGColours, X11Colours) are+  relatively stable. The core modules of @Basic.Graphic@ (@Base@,+  @PrimGraphic@, @DrawingContext@) are quite weather-beaten if +  not exactly stable, although the newer modules +  (@ScalingContext@, @DirectionContext@) are still quite green.+  Other modules (Paths, Chains, Shapes) are essentially sketches +  and may be radically different in subsequent updates.   .   .   Changelog:   .-  0.8.0 to 0.9.0:-  .-  * Re-worked @Basic.Text.LRSymbol@ changed the type name and the-    types of the run functions. Added more symbols and a new demo -    @Symbols.hs@.+  0.9.0 to 0.10.0:   .-  * @ScalingContext@ added to @Basic.Graphic@. Changed -    @monoTextWidth@ to take a character count, the old behaviour -    is recreated by the new function @monoTextLength@. +  * @Basic.Graphic.BaseClasses@ and @Basic.Graphic.BaseTypes@ +    merged into same module so they can depend on each other +    without orphans instances.   .-  * @Basic.Graphic.Chain@ removed. It is now superseded by-    @Basic.Chains@.+  * @DrawingF@ renamed to @DrawingR@, the related type synonyms+    have also been changed, e.g. @LocDrawingF@ is now +    @LocDrawingR@.   .-  * Added new property to @DrawingContext@ for line spacing -    scaling factor, and added a new drawing primitive -    @textlineMulti@ for multi-line, left justified labels.+  * Method names in the @DrawingCtxM@ class changed - @askCtx@ is+    now @askDC@, @localCtx@ is now @localize@. Removed the +    functions @askDF@, @asksDF@, @pureDF@ that worked for +    @DrawingF@ (now @DrawingR@), @DrawingR@ now uses the +    Applicative\'s @pure@ and the @DrawingCtxM@ class for these +    functionalities.   .-  * Synthezied attribute /getters/ such as @textDimensions@ moved-    from @Basic.Graphic.DrawingContext@ to the new module-    @Basic.Graphic.Query@. The type of all the functions has -    changed to DrawingF. @lowerxHeight@ is renamed -    @monoLowerxHeight@ emphasizing that the metrics pertain to-    monospaced Courier font.+  * @Basic.Graphic.DrawingContext@ - renamed @primary_colour@ to+    @stroke_colour@ and @secondary_colour@ to @fill_colour@. The +    setter functions has been similarly renamed.   .-  * Added Shapes modules.-  . -  * TurtleMonad module - the TurtleDrawing type and run functions-    have been removed and the internals have been reworked. -    Turtle is now run solely as a /local effect/ within the -    Drawing monad. +  * Added the type synonym @DrawingContextF@ to +    @Basic.Graphic.DrawingContext@. Changed relevant function+    signatures to use it.   .-  0.7.0 to 0.8.0:+  * Re-worked the Path modules - base types entirely different,+    connectors entirely different, monadic path construction +    largely the same.   .-  * Re-introduced LRText and LRSymbol - they now work with -    Wumpus-Core\'s kerning support.+  * Initial work on round cornered paths.   . -  * Changes to @Graphic.Basic.BaseTypes@ - @DrawingObject@ -    renamed to @DrawingF@. @HPrim@ wrapped as a newtype to -    support a Monoid instance. Removed @appendGraphic@ and @gcat@ -    as they can be achieved with @mappend@ and @mconcat@. -    @appendAt@ renamed to @lgappend@. @PointT@ remaned to -    @PointF@.-  .-  * Changes to @Graphic.Basic.Drawing@ - @drawAt@, @drawAtImg@, -    @drawConn@, @drawConnImg@ all removed. They are replaced -    by @draw@ and @drawi@ together with then new @at@ and @conn@-    combinators.-  .-  * Changes to @Basic.Graphic.PrimGraphic@ - @localDrawingContext@-    renamed to @localLG@ and moved to @Basic.Graphic.BaseTypes@.+  * Removed the type class @TextAnchor@ from @Basic.Anchors@. +    This was a left-over from a previous implementation of +    Shapes and is not relevant to the current implementation.+  . +  * Added @DirectionContext@ to @Basic.Graphic@.   .-  * Updates to @Basic.SafeFonts@ to work with changes to -    @Wumpus.Core@.+  * @localLG@ removed it can be acheived with composition -+    @localize upd . loc_graphic_function@. @lgappend@ is also +    removed - it can be recreated applicatively.   .   . build-type:         Simple@@ -88,6 +79,7 @@   demo/ColourCharts.hs,   demo/ColourDefns.hs,   demo/FontPic.hs,+  demo/PetriNet.hs,   demo/Picture.hs,   demo/Shapes.hs,   demo/Symbols.hs@@ -97,7 +89,7 @@   build-depends:      base            <  5,                        containers      >= 0.3     && <= 0.4,                        vector-space    >= 0.6,-                      wumpus-core     == 0.34.0+                      wumpus-core     == 0.35.0       exposed-modules:@@ -112,8 +104,8 @@     Wumpus.Basic.Dots,     Wumpus.Basic.Dots.Primitive,     Wumpus.Basic.Graphic,-    Wumpus.Basic.Graphic.BaseClasses,-    Wumpus.Basic.Graphic.BaseTypes,+    Wumpus.Basic.Graphic.Base,+    Wumpus.Basic.Graphic.DirectionContext,     Wumpus.Basic.Graphic.Drawing,     Wumpus.Basic.Graphic.DrawingContext,     Wumpus.Basic.Graphic.PrimGraphic,@@ -125,6 +117,7 @@     Wumpus.Basic.Paths.Base,     Wumpus.Basic.Paths.Connectors,     Wumpus.Basic.Paths.Construction,+    Wumpus.Basic.Paths.RoundCorners,     Wumpus.Basic.SafeFonts,     Wumpus.Basic.Shapes.Base,     Wumpus.Basic.Shapes.Derived,