wumpus-basic 0.2.0 → 0.3.0

raw patch · 24 files changed

+2845/−133 lines, 24 filesdep ~wumpus-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: wumpus-core

API changes (from Hackage documentation)

Files

• demo/ColourCharts.hs +1/−1
• demo/DotPic.hs +82/−0
• demo/FontPic.hs +4/−3
• demo/Picture.hs +207/−0
• src/Wumpus/Basic/AnchorDots.hs +178/−0
• src/Wumpus/Basic/Anchors.hs +68/−0
• src/Wumpus/Basic/Dots.hs +201/−0
• src/Wumpus/Basic/Graphic.hs +193/−25
• src/Wumpus/Basic/Graphic/DrawingAttr.hs +79/−0
• src/Wumpus/Basic/Graphic/PointSupply.hs +109/−0
• src/Wumpus/Basic/Monads/ConsDrawing.hs +178/−0
• src/Wumpus/Basic/Monads/Drawing.hs +52/−0
• src/Wumpus/Basic/Monads/DrawingCtxClass.hs +74/−0
• src/Wumpus/Basic/Monads/DrawingCtxMonad.hs +121/−0
• src/Wumpus/Basic/Monads/STraceMonad.hs +128/−0
• src/Wumpus/Basic/Monads/SnocDrawing.hs +175/−0
• src/Wumpus/Basic/Monads/TraceClass.hs +34/−0
• src/Wumpus/Basic/Monads/TraceMonad.hs +23/−8
• src/Wumpus/Basic/Monads/TurtleClass.hs +130/−0
• src/Wumpus/Basic/Monads/TurtleMonad.hs +84/−88
• src/Wumpus/Basic/Utils/Intersection.hs +133/−0
• src/Wumpus/Basic/VersionNumber.hs +6/−2
• src/Wumpus/Deprecated/PictureLanguage.hs +543/−0
• wumpus-basic.cabal +42/−6

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

@@ -0,0 +1,82 @@+{-# OPTIONS -Wall #-}++module DotPic where+++import Wumpus.Basic.Dots+import Wumpus.Basic.Graphic+import Wumpus.Basic.Graphic.DrawingAttr+import Wumpus.Basic.SVGColours+import Wumpus.Basic.Utils.HList+import Wumpus.Deprecated.PictureLanguage++import Wumpus.Core                      -- package: wumpus-core++import System.Directory++main :: IO ()+main = do +    createDirectoryIfMissing True "./out/"+    demo01++pt2 :: Point2 Double+pt2 = P2 100 10+++demo01 :: IO ()+demo01 = do +    writeEPS_latin1 "./out/dots01.eps" pic+    writeSVG_latin1 "./out/dots01.svg" pic+  where +    pic :: Picture Double+    pic = extendBoundary 10 10 $ +          uniformScale 2       $ +            vsepA VLeft 10 p1 [p2,p3,p4,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14+                              ,p15,p16,p17]+    +    p1  = makeDotPic dotHLine       points+    p2  = makeDotPic dotVLine       points+    p3  = makeDotPic dotX           points+    p4  = makeDotPic dotPlus        points   +    p5  = makeDotPic dotCross       points+    p6  = makeDotPic dotDiamond     points+    p7  = makeDotPic dotDisk        points+    p8  = makeDotPic dotSquare      points+    p9  = makeDotPic dotCircle      points+    p10 = makeDotPic dotPentagon    points+    p11 = makeDotPic dotStar        points+    p12 = makeDotPic dotAsterisk    points+    p13 = makeDotPic dotOPlus       points+    p14 = makeDotPic dotOCross      points+    p15 = makeDotPic dotFOCross     points+    p16 = makeDotPic dotFDiamond    points+    p17 = makeDotPic (dotText "AA") points+ +std_attr :: DrawingAttr+std_attr = standardAttr 12++points :: [Point2 Double]+points = [P2 0 0, P2 32 10, P2 64 0, P2 96 10]++makeDotPic :: (Real u, Floating u) +           => (DrawingAttr -> GraphicF u) -> [Point2 u] -> Picture u+makeDotPic fn xs = drawGraphicU $ veloH (fn std_attr) xs . dashline+  where+    dashline = wrapG $ ostroke attr $ vertexPath xs+    attr     = (cadetBlue, DashPattern $ evenDashes 1)+++errK :: a+errK = error "no picture"++++-- Should these produce a DashPattern or a StrokeAttr?++evenDashes :: Int -> DashPattern +evenDashes n = Dash 0 [(n,n)]++dashOffset :: Int -> DashPattern -> DashPattern+dashOffset _ Solid       = Solid+dashOffset n (Dash _ xs) = Dash n xs+

@@ -2,13 +2,14 @@  module FontPic where -import Wumpus.Core-import Wumpus.Extra.PictureLanguage import Wumpus.Basic.SafeFonts import Wumpus.Basic.SVGColours ( steelBlue ) import Wumpus.Basic.X11Colours ( indianRed1 )+import Wumpus.Deprecated.PictureLanguage -import Data.AffineSpace+import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space import Data.VectorSpace  import Data.List ( unfoldr )

@@ -0,0 +1,207 @@+{-# OPTIONS -Wall #-}++module Picture where++import Wumpus.Core+import Wumpus.Deprecated.PictureLanguage++import System.Directory+++main :: IO ()+main = do +    createDirectoryIfMissing True "./out/"+    sequence_  [ demo01, demo02, demo03, demo04, demo05+               , demo06, demo07, demo08, demo09, demo10+               , demo11, demo12, demo13, demo14 ]++peru :: PSRgb+peru = RGB3 0.804  0.522  0.247++plum :: PSRgb+plum = RGB3 0.867  0.627  0.867++black :: PSRgb+black = RGB3 0 0 0 +++square :: DPicture +square = frame $ cstroke () $ vertexPath+  [ P2 0 0, P2 40 0, P2 40 40, P2 0 40 ]++funnyshape :: DPicture+funnyshape = frame $ cstroke () $ vertexPath+  [ P2 0 0, P2 20 0, P2 20 10, P2 30 10, P2 30 20, P2 0 20 ]+++demo01 :: IO ()+demo01 = do +  writePS_latin1  "./out/picture01.ps"    [funnyshape ->- square]+  writeSVG_latin1 "./out/picture01.svg" $ funnyshape ->- square+++pic1 :: Picture Double+pic1 = square ->- (funnyshape ->- funnyshape) ->- square++squares :: Picture Double+squares = square ->- square ->- square++demo02 :: IO ()+demo02 = do +   writePS_latin1  "./out/picture02.ps"  [squares]+   writeSVG_latin1 "./out/picture02.svg" squares +    ++demo03 :: IO ()+demo03 = do +    writeEPS_latin1 "./out/picture03.eps" p1 +    writeSVG_latin1 "./out/picture03.svg" p1+  where     +    p1 = square ->- (rotate45About (center squares) squares) ->- square+++demo04 :: IO ()+demo04 = do +    writeEPS_latin1 "./out/picture04.eps" p1+    writeSVG_latin1 "./out/picture04.svg" p1+  where+    p1 = square -//- squares+   ++demo05 :: IO ()+demo05 = do +    writeEPS_latin1 "./out/picture05.eps" p1+    writeSVG_latin1 "./out/picture05.svg" p1+  where+    p1 = square `over` (rotate (pi/4) squares)+   ++demo06 :: IO ()+demo06 = do +    writeEPS_latin1 "./out/picture06.eps" p1+    writeSVG_latin1 "./out/picture06.svg" p1+  where+    p1 = square `over` (rotate45 square)+++-- Note the move via @at@ is not apparent when SVG file is +-- viewed with Mozilla or Chrome - check picture7a.svg+-- We only see that the move has /worked/ when we compose+-- with with `over` a square at the origin. ++demo07 :: IO ()+demo07 = do +    writeEPS_latin1 "./out/picture07.eps" p1+    writeSVG_latin1 "./out/picture07.svg" p1+    writeSVG_latin1 "./out/picture07a.svg" p2+  where+    p1 = square `over` p2+    p2 = (square `at` (P2 100 30))  -@- (rotate45 square)+++demo08 :: IO ()+demo08 = do +    writeEPS_latin1 "./out/picture08.eps" p1+    writeSVG_latin1 "./out/picture08.svg" p1+  where+    p1 = hspace 20 square square++mkFilledSquare :: (PSColour c, Fill c) => c -> Double -> DPicture +mkFilledSquare col n = frame $ fill col $ vertexPath+  [ P2 0 0, P2 n 0, P2 n n, P2 0 n ]+++demo09 :: IO ()+demo09 = do +    writeEPS_latin1 "./out/picture09.eps" p1+    writeSVG_latin1 "./out/picture09.svg" p1+  where+    p1 = (alignH HTop s1 s2) `op` s3+    s1 = uniformScale 1.5  $ mkFilledSquare plum 40+    s2 = uniformScale 1.75 $ mkFilledSquare peru 40+    s3 = scale 3 1.5       $ mkFilledSquare black 40+    op = alignH HBottom+ ++demo10 :: IO ()+demo10 = do +    writeEPS_latin1 "./out/picture10.eps" p1+    writeSVG_latin1 "./out/picture10.svg" p1+  where+    p1 = vsepA VRight 5 s1 [s2,s3]+    s1 = uniformScale 1.5  $ mkFilledSquare plum 40+    s2 = uniformScale 1.75 $ mkFilledSquare peru 40+    s3 = scale 3 1.5       $ mkFilledSquare black 40+ +++-- Stroked ellipe problem under scaling...+demo11 :: IO ()+demo11 = do +    writeEPS_latin1 "./out/picture11.eps" pic+    writeSVG_latin1 "./out/picture11.svg" pic+  where+    pic :: Picture Double+    pic = p1 -//- p2+    p1 = scale 6 12 $ frame $ ellipse (plum, LineWidth 2) 4 6 zeroPt+    p2 = scale 6 12 $ frame $ ellipse (peru, LineWidth 2) 6 6 zeroPt+++-- Note the movement of the plum square won't be regarded by +-- Firefox as it crops whitespace automatically.+demo12 :: IO ()+demo12 = do +    writeEPS_latin1 "./out/picture12.eps" pic+    writeSVG_latin1 "./out/picture12.svg" pic+  where+    pic :: Picture Double+    pic = p1 -//- p2 -//- p3 -//- p4+    p1 = small_black -@- large_plum     -- moves black+    p2 = large_plum  -@- small_black    -- moves plum+    p3 = small_black ->- large_plum     -- moves plum+    p4 = small_black -<- large_plum     -- moves black++    small_black = mkFilledSquare black 10 `at` P2 30 0+    large_plum  = mkFilledSquare plum  40 `at` P2 100 0+++demo13 :: IO ()+demo13 = do +    writeEPS_latin1 "./out/picture13.eps" pic+    writeSVG_latin1 "./out/picture13.svg" pic+  where+    pic :: Picture Double+    pic = (p1 `at` P2 20 20) ->- (p2 `at` P2 60 20) ++    p1 = small_black `below` small_peru   -- moves small black+    p2 = small_black `above` small_plum   -- moves small black++    small_black = mkFilledSquare black 10 `at` P2 50 0+    small_plum  = mkFilledSquare plum  10 `at` P2 50 0+    small_peru  = mkFilledSquare peru  10 `at` P2 50 0++demo14 :: IO ()+demo14 = do +    writeEPS_latin1 "./out/picture14.eps" pic+    writeSVG_latin1 "./out/picture14.svg" pic+  where+    pic :: Picture Double+    pic = hsep 40 p1 [p2,p3,p4,p5,p6]++    p1 = alignH HTop    small_black mid_peru+    p2 = alignH HBottom small_black mid_plum+    p3 = alignH HCenter small_black mid_peru++    p4 = alignV VLeft   mid_black small_peru+    p5 = alignV VRight  mid_black small_plum+    p6 = alignV VCenter mid_black small_peru++    small_black = mkFilledSquare black 10 `at` P2 10 0+    mid_plum    = mkFilledSquare plum  25 `at` P2 50 0+    mid_peru    = mkFilledSquare peru  25 `at` P2 50 0++    mid_black   = mkFilledSquare black 25 `at` P2 10 10+    small_plum  = mkFilledSquare plum  10 `at` P2 10 50+    small_peru  = mkFilledSquare peru  10 `at` P2 10 50++

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

@@ -0,0 +1,68 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Anchors+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC with TypeFamilies and more+--+-- Anchor points on \"shapes\".+--+-- ** WARNING ** this module is highly experimental, and may +-- change significantly or even be dropped from future revisions.+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.Anchors+  ( ++  -- * Anchors+    CenterAnchor(..)+  , CardinalAnchor(..)+  , CardinalAnchor2(..)+  , TextAnchor(..)+  , RadialAnchor(..)++  ) where++import Wumpus.Core                      -- package: wumpus-core+++class CenterAnchor t where+  center :: DUnit t ~ u => t -> Point2 u++-- Note - in TikZ cardinal anchors are not necessarily at the+-- equivalent radial position, for instance reactangle north-east+-- is the top-right corner whether or not this is incident at +-- 45deg.+--++class CardinalAnchor t where+  north :: DUnit t ~ u => t -> Point2 u+  south :: DUnit t ~ u => t -> Point2 u+  east  :: DUnit t ~ u => t -> Point2 u+  west  :: DUnit t ~ u => t -> Point2 u++class CardinalAnchor2 t where+  northeast :: DUnit t ~ u => t -> Point2 u+  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+  textAnchor :: DUnit t ~ u => t -> Point2 u+++-- | Anchor on a border that can be identified with and angle.+--+class RadialAnchor t where+  radialAnchor :: DUnit t ~ u => Radian -> t -> Point2 u+

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

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

@@ -0,0 +1,79 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.DrawingAttr+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC with TypeFamilies and more+--+-- Drawing attributes+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.Graphic.DrawingAttr+  ( ++  -- * Drawing attributes+    DrawingAttr(..)++  , standardAttr+  , strokeAttr   +  , fillAttr+  , textAttr+  , markHeight++  , textDimensions++  ) where+++import Wumpus.Basic.SafeFonts+import Wumpus.Basic.SVGColours++import Wumpus.Core                      -- package: wumpus-core++import Control.Applicative++data DrawingAttr = DrawingAttr +      { line_width         :: Double+      , font_props         :: FontAttr+      , stroke_colour      :: DRGB+      , fill_colour        :: DRGB+      }+  deriving (Eq,Show)++standardAttr :: FontSize -> DrawingAttr+standardAttr sz = DrawingAttr { line_width         = 1.0+                              , font_props         = courier sz+                              , stroke_colour      = black+                              , fill_colour        = gold  }++ +strokeAttr :: DrawingAttr -> (DRGB, StrokeAttr)+strokeAttr = liftA2 (,) stroke_colour (LineWidth . line_width)++fillAttr :: DrawingAttr -> DRGB+fillAttr = fill_colour++textAttr :: DrawingAttr -> (DRGB,FontAttr)+textAttr = liftA2 (,) stroke_colour font_props++-- | A Mark is consider to be the height of a lowercase letter+-- in the current font.+--+markHeight :: Fractional u => DrawingAttr -> u+markHeight = xcharHeight . font_size . font_props+++-- | textDimensions : text -> DrawingAttr -> (width,height)+--+textDimensions :: Fractional u => String -> DrawingAttr -> (u,u)+textDimensions str attr = (w,h)+  where+    sz = font_size  $ font_props attr+    w  = textWidth  sz (1 + length str) +    h  = textHeight sz

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

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

@@ -0,0 +1,52 @@+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Monads.Drawing+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC +--+-- Drawing operations+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Monads.Drawing+  (+    +    MGraphicF +  , traceG+  , node+  , at+  ) where++import Wumpus.Basic.Graphic+import Wumpus.Basic.Monads.TraceClass+import Wumpus.Basic.Monads.TurtleClass++import Wumpus.Core                              -- package: wumpus-core+++type MGraphicF m u a = Point2 u -> m a++traceG :: (Monad m, TraceM m (Primitive u)) => GraphicF u -> MGraphicF m u ()+traceG fn = \pt -> trace (fn pt)++-- MGraphic functions will have to trace themselves...++node :: (TraceM m (Primitive u), TurtleScaleM m u, Num u) +     => MGraphicF m u a -> m a +node mgF = getPos >>= \pt -> mgF pt+++infixr 6 `at` ++at :: (Num u, TraceM m (Primitive u), TurtleScaleM m u) +   => MGraphicF m u a -> (Int,Int) -> m a+at mgF coord = scaleCoord coord >>= \pt -> mgF pt+

@@ -0,0 +1,74 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Monads.DrawingCtxClass+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC +--+-- Class.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Monads.DrawingCtxClass+  (++  -- * Re-exports from Wumpus.Basic.Graphic.DrawingAttr+    DrawingAttr(..)+  , standardAttr++  -- * DrawingCtx class++  , DrawingCtxM(..)+  , withinModifiedCtx++  , strokeAttr+  , fillAttr+  , textAttr+  , markHeight++  , textDimensions+  +  ) where++import Wumpus.Basic.Graphic.DrawingAttr ( DrawingAttr(..), standardAttr )+import qualified Wumpus.Basic.Graphic.DrawingAttr as DA++import Wumpus.Core                      -- package: wumpus-core++import Control.Monad+++-- local to add? or new class...++class Monad m => DrawingCtxM m where+  askDrawingCtx :: m DrawingAttr+  localCtx      :: DrawingAttr -> m a -> m a++++withinModifiedCtx :: DrawingCtxM m +                  => (DrawingAttr -> DrawingAttr) -> m a -> m a+withinModifiedCtx upd ma = askDrawingCtx >>= \ctx -> localCtx (upd ctx) ma+++strokeAttr  :: DrawingCtxM m => m (DRGB, StrokeAttr)+strokeAttr  = liftM DA.strokeAttr askDrawingCtx+++fillAttr    :: DrawingCtxM m => m DRGB+fillAttr    = liftM DA.fillAttr askDrawingCtx++textAttr    :: DrawingCtxM m => m  (DRGB, FontAttr)+textAttr    = liftM DA.textAttr askDrawingCtx++markHeight  :: (Fractional u, DrawingCtxM m) => m u+markHeight  = liftM DA.markHeight askDrawingCtx++textDimensions :: (Fractional u, DrawingCtxM m) => String -> m (u,u)+textDimensions str = liftM (DA.textDimensions str) askDrawingCtx+

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

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

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

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

@@ -1,5 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE FunctionalDependencies     #-}+{-# LANGUAGE UndecidableInstances       #-} {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE TypeSynonymInstances       #-} {-# OPTIONS -Wall #-}@@ -32,17 +32,20 @@      Trace   , TraceT-  , TraceM(..)    , runTrace   , runTraceT     ) where -import MonadLib ( MonadT(..) )          -- package: monadLib-+import Wumpus.Basic.Monads.DrawingCtxClass+import Wumpus.Basic.Monads.TraceClass+import Wumpus.Basic.Monads.TurtleClass import Wumpus.Basic.Utils.HList ++import MonadLib ( MonadT(..) )          -- package: monadLib+ import Control.Applicative  @@ -96,11 +99,7 @@ instance MonadT (TraceT i) where    lift m = TraceT $ \w -> m >>= \ a -> return (a,w) -class TraceM  m i | m -> i where-  trace  :: H i -> m ()-  trace1 :: i -> m () - instance TraceM (Trace i) i where   trace  h = Trace $ \w -> ((), h . w)     trace1 i = Trace $ \w -> ((), i `consH` w)  @@ -118,6 +117,22 @@ runTraceT mf = getTraceT mf id >>= \(a,w) -> return (a,w)  +--------------------------------------------------------------------------------+-- Cross instances +instance DrawingCtxM m => DrawingCtxM (TraceT i m) where+  askDrawingCtx   = TraceT $ \w -> askDrawingCtx >>= \ ctx -> return (ctx,w)+  localCtx ctx mf = TraceT $ \w -> localCtx ctx (getTraceT mf w)+++instance TurtleM m => TurtleM (TraceT i m) where+  getLoc          = TraceT $ \w -> getLoc >>= \a -> return (a,w)+  setLoc c        = TraceT $ \w -> setLoc c >> return ((),w)+  getOrigin       = TraceT $ \w -> getOrigin >>= \a -> return (a,w)+  setOrigin o     = TraceT $ \w -> setOrigin o >> return ((),w)++instance TurtleScaleM m u => TurtleScaleM (TraceT i m) u where+  xStep           = TraceT $ \w -> xStep >>= \a -> return (a,w)+  yStep           = TraceT $ \w -> yStep >>= \a -> return (a,w)   

@@ -0,0 +1,130 @@+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE FunctionalDependencies     #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Monads.TurtleClass+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC +--+-- Turtle monad and monad transformer.+--+-- The Turtle monad embodies the LOGO style of imperative +-- drawing - sending commands to update the a cursor.+--+-- While Wumpus generally aims for a more compositional,+-- \"coordinate-free\" style of drawing, some types of +-- diagram are more easily expressed in the LOGO style.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Monads.TurtleClass+  (++    Coord+  , TurtleConfig(..)+  , regularConfig ++  , TurtleM(..)+  , TurtleScaleM(..)++  , askSteps+  , setsLoc+  , setsLoc_++  -- * movement+  , resetLoc+  , moveLeft+  , moveRight+  , moveUp+  , moveDown+  , nextLine+ +  , getPos+  , scaleCoord++  ) where+++import Wumpus.Core                      -- package: wumpus-core++import Control.Monad++type Coord = (Int,Int)+++-- Might want to expand this with an initial y-value,+-- otherwise using nextLine will get you negative y-values+-- without care...++data TurtleConfig u = TurtleConfig +      { xstep :: !u+      , ystep :: !u +      }  +  deriving (Eq,Show)+++regularConfig :: u -> TurtleConfig u+regularConfig u = TurtleConfig u u +++class Monad m => TurtleM m where+  getLoc     :: m (Int,Int)+  setLoc     :: (Int,Int) -> m ()+  getOrigin  :: m (Int,Int)+  setOrigin  :: (Int,Int) -> m ()++class TurtleM m => TurtleScaleM m u | m -> u where +  xStep     :: m u+  yStep     :: m u+++askSteps :: TurtleScaleM m u => m (u,u)+askSteps = liftM2 (,) xStep yStep++setsLoc :: TurtleM m => (Coord -> (a,Coord)) -> m a+setsLoc f = getLoc      >>= \coord -> +            let (a,coord') = f coord in setLoc coord' >> return a++setsLoc_ :: TurtleM m => (Coord -> Coord) -> m ()+setsLoc_ f = getLoc     >>= \coord ->  setLoc (f coord)++++resetLoc    :: TurtleM m => m ()+resetLoc    = getOrigin >>= setLoc+++moveRight   :: TurtleM m => m ()+moveRight   = setsLoc_ $ \(x,y)-> (x+1, y)+++moveLeft    :: TurtleM m => m ()+moveLeft    = setsLoc_ $ \(x,y) -> (x-1,y)++moveUp      :: TurtleM m => m ()+moveUp      = setsLoc_ $ \(x,y) -> (x,y+1)++moveDown    :: TurtleM m => m ()+moveDown    = setsLoc_ $ \(x,y) -> (x ,y-1)+++nextLine    :: TurtleM m => m ()+nextLine    = getOrigin >>= \(ox,_) ->+              setsLoc_ $ \(_,y) -> (ox,y-1)+++getPos :: (TurtleScaleM m u, Num u) => m (Point2 u)+getPos = getLoc   >>= \(x,y)   ->+         askSteps >>= \(sx,sy) ->+         return $ P2 (sx * fromIntegral x) (sy * fromIntegral y)++scaleCoord  :: (TurtleScaleM m u, Num u) => (Int,Int) -> m (Point2 u)+scaleCoord (x,y) = askSteps >>= \(sx,sy) ->+                   return $ P2 (sx * fromIntegral x) (sy * fromIntegral y)+

@@ -1,5 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE UndecidableInstances       #-} {-# LANGUAGE TypeSynonymInstances       #-}+{-# LANGUAGE FlexibleInstances          #-} {-# OPTIONS -Wall #-}  --------------------------------------------------------------------------------@@ -19,147 +21,141 @@ -- -- While Wumpus generally aims for a more compositional, -- \"coordinate-free\" style of drawing, some types of --- diagram are very easily expressed in the LOGO style.+-- diagram are more easily expressed in the LOGO style. -- --------------------------------------------------------------------------------  module Wumpus.Basic.Monads.TurtleMonad   (-    Coord(..) -  , Turtle-  , TurtleT -  , TurtleM(..)+    Turtle+  , TurtleT    , runTurtle   , runTurtleT -  , setsLoc-  , setsLoc_--  -- * movement-  , reset-  , moveLeft-  , moveRight-  , moveUp-  , moveDown-  , nextLine--  , wander     ) where +import Wumpus.Basic.Monads.DrawingCtxClass+import Wumpus.Basic.Monads.TraceClass+import Wumpus.Basic.Monads.TurtleClass + import MonadLib ( MonadT(..) )          -- package: monadLib  import Control.Applicative+import Control.Monad  -data Coord = Coord !Int !Int--instance Show Coord where-  showsPrec i (Coord x y) = showsPrec i (x,y)+-- Turtle is a Reader / State monad+-- +-- The env is the horizontal and vertical move distances.+-- +-- The state is the current coordinate and the origin.+-- +data TurtleState = TurtleState +      { _turtle_origin   :: (Int,Int)+      , _current_coord   :: (Int,Int)+      } -newtype Turtle    a = Turtle  { getTurtle  :: Coord -> (a, Coord) } +newtype Turtle u a = Turtle  { +          getTurtle  :: TurtleConfig u -> TurtleState -> (a, TurtleState) }  -newtype TurtleT m a = TurtleT { getTurtleT :: Coord -> m (a, Coord) }+newtype TurtleT u m a = TurtleT { +          getTurtleT :: TurtleConfig u -> TurtleState -> m (a, TurtleState) }   -- Functor -instance Functor Turtle where-  fmap f m = Turtle $ \st -> let (a,st') = getTurtle m st in (f a, st')                   +instance Functor (Turtle u) where+  fmap f m = Turtle $ \r s -> let (a,s') = getTurtle m r s in (f a, s') -instance Monad m => Functor (TurtleT m) where-  fmap f m = TurtleT $ \st -> getTurtleT m st >>= \(a,st') ->-                              return (f a, st')+instance Monad m => Functor (TurtleT u m) where+  fmap f m = TurtleT $ \r s -> getTurtleT m r s >>= \(a,s') ->+                               return (f a, s')  -- Applicative -instance Applicative Turtle where-  pure a    = Turtle $ \st -> (a,st)-  mf <*> ma = Turtle $ \st -> let (f,st')  = getTurtle mf st -                                  (a,st'') = getTurtle ma st'-                              in (f a,st'') +instance Applicative (Turtle u) where+  pure a    = Turtle $ \_ s -> (a,s)+  mf <*> ma = Turtle $ \r s -> let (f,s')  = getTurtle mf r s +                                   (a,s'') = getTurtle ma r s'+                                in (f a,s'')   -instance Monad m => Applicative (TurtleT m) where-  pure a    = TurtleT $ \st -> return (a,st)-  mf <*> ma = TurtleT $ \st -> getTurtleT mf st  >>= \(f,st')  ->-                               getTurtleT ma st' >>= \(a,st'') ->-                               return (f a,st'') +instance Monad m => Applicative (TurtleT u m) where+  pure a    = TurtleT $ \_ s -> return (a,s)+  mf <*> ma = TurtleT $ \r s -> getTurtleT mf r s  >>= \(f,s')  ->+                                getTurtleT ma r s' >>= \(a,s'') ->+                                return (f a,s'')    -- Monad  -instance Monad Turtle where-  return a = Turtle $ \st -> (a,st)-  m >>= k  = Turtle $ \st -> let (a,st') = getTurtle m st-                             in (getTurtle . k) a st'+instance Monad (Turtle u) where+  return a = Turtle $ \_ s -> (a,s)+  m >>= k  = Turtle $ \r s -> let (a,s') = getTurtle m r s+                              in (getTurtle . k) a r s' -instance Monad m => Monad (TurtleT m) where-  return a = TurtleT $ \st -> return (a,st)-  m >>= k  = TurtleT $ \st -> getTurtleT m st        >>= \(a,st')  ->-                              (getTurtleT . k) a st' >>= \(b,st'') ->-                              return (b,st'')+instance Monad m => Monad (TurtleT u m) where+  return a = TurtleT $ \_ s -> return (a,s)+  m >>= k  = TurtleT $ \r s -> getTurtleT m r s        >>= \(a,s')  ->+                               (getTurtleT . k) a r s' >>= \(b,s'') ->+                               return (b,s'') -instance MonadT TurtleT where-  lift m = TurtleT $ \st -> m >>= \a -> return (a,st)+instance MonadT (TurtleT u) where+  lift m = TurtleT $ \_ s -> m >>= \a -> return (a,s) -class Monad m => TurtleM m where-  getLoc :: m Coord-  setLoc :: Coord -> m () -instance TurtleM Turtle where-  getLoc   = Turtle $ \st -> (st,st)-  setLoc c = Turtle $ \_  -> ((),c)-   -instance Monad m => TurtleM (TurtleT m) where-  getLoc   = TurtleT $ \st -> return (st,st)-  setLoc c = TurtleT $ \_  -> return ((),c)+instance TurtleM (Turtle u) where+  getLoc      = Turtle $ \_ s@(TurtleState _ c) -> (c,s)+  setLoc c    = Turtle $ \_   (TurtleState o _) -> ((),TurtleState o c)+  getOrigin   = Turtle $ \_ s@(TurtleState o _) -> (o,s)+  setOrigin o = Turtle $ \_   (TurtleState _ c) -> ((),TurtleState o c) +instance TurtleScaleM (Turtle u) u where+  xStep    = Turtle $ \r s -> (xstep r,s)+  yStep    = Turtle $ \r s -> (ystep r,s) -runTurtle :: Turtle a -> (a,(Int,Int))-runTurtle mf = post $ getTurtle mf (Coord 0 0) -  where-    post (a, Coord x y) = (a,(x,y)) -runTurtleT :: Monad m => TurtleT m a -> m (a,(Int,Int))-runTurtleT mf = getTurtleT mf (Coord 0 0) >>= \(a, Coord x y) -> return (a,(x,y))+instance Monad m => TurtleM (TurtleT u m) where+  getLoc      = TurtleT $ \_ s@(TurtleState _ c) -> return (c,s)+  setLoc c    = TurtleT $ \_   (TurtleState o _) -> return ((),TurtleState o c)+  getOrigin   = TurtleT $ \_ s@(TurtleState o _) -> return (o,s)+  setOrigin o = TurtleT $ \_   (TurtleState _ c) -> return ((),TurtleState o c) +instance Monad m => TurtleScaleM (TurtleT u m) u where+  xStep    = TurtleT $ \r s -> return (xstep r,s)+  yStep    = TurtleT $ \r s -> return (ystep r,s) -setsLoc :: TurtleM m => (Coord -> (a,Coord)) -> m a-setsLoc f = getLoc >>= \st -> let (a,st') = f st in setLoc st' >> return a -setsLoc_ :: TurtleM m => (Coord -> Coord) -> m ()-setsLoc_ f = getLoc >>= \st -> let st' = f st in setLoc st'+-- Run functions discard the state... -reset       :: TurtleM m => m ()-reset       = setLoc (Coord 0 0)+runTurtle :: Num u => TurtleConfig u -> (Int,Int) -> Turtle u a -> a+runTurtle cfg ogin mf = fst $ getTurtle mf cfg (TurtleState ogin ogin)+ +runTurtleT :: (Monad m, Num u) +           => TurtleConfig u -> (Int,Int) -> TurtleT u m a -> m a+runTurtleT cfg ogin mf = liftM fst $ getTurtleT mf cfg (TurtleState ogin ogin) -moveRight   :: TurtleM m => m ()-moveRight   = setsLoc_ $ \(Coord x y) -> Coord (x+1) y -moveLeft    :: TurtleM m => m ()-moveLeft    = setsLoc_ $ \(Coord x y) -> Coord (x-1) y -moveUp      :: TurtleM m => m ()-moveUp      = setsLoc_ $ \(Coord x y) -> Coord x (y-1)+----------------------------------------------------------------------------------+-- Cross instances -moveDown    :: TurtleM m => m ()-moveDown    = setsLoc_ $ \(Coord x y) -> Coord x (y+1)+instance DrawingCtxM m => DrawingCtxM (TurtleT u m) where+  askDrawingCtx   = TurtleT $ \_ s -> askDrawingCtx >>= \ ctx -> return (ctx,s)+  localCtx ctx mf = TurtleT $ \r s -> localCtx ctx (getTurtleT mf r s) -nextLine    :: TurtleM m => m ()-nextLine    = setsLoc_ $ \(Coord _ y) -> Coord 0 (y-1) +-- This needs undecidable instances... --- | No longer sure about this combinator...----wander :: TurtleM m => m a -> m (a,Coord,Coord)-wander ma = getLoc >>= \start ->-            ma     >>= \ans   ->-            getLoc >>= \end   ->-            return (ans,start,end)+instance (Monad m, TraceM m i) => TraceM (TurtleT u m) i where+  trace a  = TurtleT $ \_ s -> trace a >> return ((),s)+  trace1 a = TurtleT $ \_ s -> trace1 a >> return ((),s)++ 

@@ -0,0 +1,133 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Utils.Intersection+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC with TypeFamilies and more+--+-- Intersection of line to line and line to plane+-- +-- +--------------------------------------------------------------------------------++module Wumpus.Basic.Utils.Intersection+  ( +    LineSegment(..)+  , PointSlope+  , pointSlope+  , LineEqn+  , lineEqn+  , toLineEqn+  , findIntersect+  , intersection++  , rectangleLines++  ) +  where++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space+import Data.VectorSpace++data LineSegment u = LS (Point2 u) (Point2 u)+  deriving (Eq,Ord,Show)+++data PointSlope u = PointSlope +      { _point_slope_point :: Point2 u+      , _point_slope_slope :: u+      }+  deriving (Eq,Show)++pointSlope :: Fractional u => Point2 u -> Radian -> PointSlope u +pointSlope pt theta = PointSlope pt (fromRadian $ tan theta)+++-- | Line in equational form, i.e. @Ax + By + C = 0@.+data LineEqn u = LineEqn +      { _line_eqn_A :: !u+      , _line_eqn_B :: !u+      , _line_eqn_C :: !u +      }+  deriving (Eq,Show)++lineEqn :: Num u => Point2 u -> Point2 u -> LineEqn u+lineEqn (P2 x1 y1) (P2 x2 y2) = LineEqn a b c +  where+    a = y1 - y2+    b = x2 - x1+    c = (x1*y2) - (x2*y1)+++toLineEqn :: Num u => PointSlope u -> LineEqn u+toLineEqn (PointSlope (P2 x0 y0) m) = LineEqn m (-1) ((-m) * x0 + y0)+++++data IntersectionResult u = Intersects u u | Contained | NoIntersect+  deriving (Eq,Show)+++-- Note the uses a /plane/ so is susceptible to picking the +-- wrong quadrant...+--+findIntersect :: (Floating u, Real u, Ord u)+               => Point2 u -> Radian -> [LineSegment u] -> Maybe (Point2 u)+findIntersect ctr theta = step +  where+    eqn         = toLineEqn $ pointSlope ctr theta+    step []     = Nothing+    step (x:xs) = case intersection x eqn of +                     Just pt | quadrantCheck theta ctr pt -> Just pt+                     _       -> step xs+++quadrantCheck :: (Real u, Floating u) +              => Radian -> Point2 u -> Point2 u -> Bool+quadrantCheck theta ctr pt = theta `req` langle ctr pt++intersection :: (Fractional u, Ord u) +             => LineSegment u -> LineEqn u -> Maybe (Point2 u)+intersection ls@(LS p q) eqn = case intersect1 ls eqn of+    Intersects fp fq -> let t = fp / (fp-fq) in Just $ affineComb p q t +    Contained        -> Just p+    NoIntersect      -> Nothing++++intersect1 :: (Num u, Ord u) +           => LineSegment u -> LineEqn u -> IntersectionResult u+intersect1 (LS p q) eqn = +     if inters fp fq then Intersects fp fq+        else if contained fp fq then Contained else NoIntersect+  where+    inters a b    = (a < 0 && b >= 0) || (a > 0 && b <= 0)+    contained a b = a == 0 && b == 0+    fp            = lineF p eqn+    fq            = lineF q eqn+ +lineF :: Num u => Point2 u -> LineEqn u -> u+lineF (P2 x y) (LineEqn a b c) = a*x + b*y + c++affineComb :: Num u => Point2 u -> Point2 u -> u -> Point2 u+affineComb p q t = p .+^ t *^ (q .-. p)++++++rectangleLines :: Num u => Point2 u -> u -> u -> [LineSegment u]+rectangleLines ctr hw hh = [LS br tr, LS tr tl, LS tl bl, LS bl br]+  where+    br = ctr .+^ (vec hw    (-hh))+    tr = ctr .+^ (vec hw    hh)+    tl = ctr .+^ (vec (-hw) hh)+    bl = ctr .+^ (vec (-hw) (-hh))

@@ -8,7 +8,7 @@ -- -- Maintainer  :  stephen.tetley@gmail.com -- Stability   :  unstable--- Portability :  GHC with TypeFamilies and more+-- Portability :  GHC -- -- Version number --@@ -21,5 +21,9 @@   ) where  +-- | Version number+--+-- > (0,3,0)+-- wumpus_basic_version :: (Int,Int,Int)-wumpus_basic_version = (0,2,0)+wumpus_basic_version = (0,3,0)

@@ -0,0 +1,543 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Deprecated.PictureLanguage+-- Copyright   :  (c) Stephen Tetley 2009-2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC with TypeFamilies and more+--+-- Type classes and derived functions to compose 2D /pictures/.+--+-- WARNING - this module is deprecated.+--+--------------------------------------------------------------------------------++module Wumpus.Deprecated.PictureLanguage +  (+  -- * Data types for alignment +    HAlign(..)+  , VAlign(..)++  -- * Type family and classes+  , PUnit +  , Horizontal(..)+  , Vertical(..)+  , Composite(..)+  , Move(..)+  , Blank(..)++  -- * Bounds+  -- $boundsdoc+  , center+  , topleft+  , topright+  , bottomleft+  , bottomright++  -- * Composition+  , ( -@- )+  , ( ->- )+  , ( -<- )+  , ( -//- )+  , above+  , below+  , at+  , centeredAt+  , stackOnto+  , hcat +  , vcat+  , stackOntoCenter++  , hspace+  , vspace+  , hsep+  , vsep+ +  -- * Compose with alignment+  , alignH+  , alignV+  , hcatA+  , vcatA+  , hsepA+  , vsepA++  -- * Special function for text+  , multilabel+++  ) where++import Wumpus.Core++import Data.AffineSpace++import Data.List ( foldl' )+++--------------------------------------------------------------------------------+-- Data types++-- Alignment++-- | Horizontal alignment - align to the top, center or bottom.+data HAlign = HTop | HCenter | HBottom+  deriving (Eq,Show)++-- | Vertical alignment - align to the left, center or bottom.+data VAlign = VLeft | VCenter | VRight+  deriving (Eq,Show)+++++--------------------------------------------------------------------------------+-- Type family and classes+++-- | The type of /points/ within a Picture.+type family PUnit a+++-- | > a `over` b+-- +-- Place \'picture\' a over b. The idea of @over@ here is the same+-- as z-ordering in 2D design programs. Implementations of this +-- class should \'draw\' picture a over b but move neither.+-- +-- Similarly @beneath@ should \'draw\' the first picture behind +-- the second but move neither.+--+-- Beneath has a default definition:+--+-- > beneath = flip over+--+class Composite a where+  over    :: a -> a -> a+  beneath :: a -> a -> a++  beneath = flip over+++-- | Create a /picture/ that has no content but occupies space +-- (i.e. it has a bounding box).+class Blank a where+  blank :: PUnit a -> PUnit a -> a+++-- | Move horizontally.+class Horizontal a where+  moveH      :: PUnit a -> a -> a+  leftBound  :: a -> PUnit a+  rightBound :: a -> PUnit a++-- | Move vertically.+class Vertical a where+  moveV       :: PUnit a -> a -> a+  topBound    :: a -> PUnit a+  bottomBound :: a -> PUnit a+++  +-- | Move in both the horizontal and vertical.+class Move a where+  move :: PUnit a -> PUnit a -> a -> a+++++--------------------------------------------------------------------------------++-- Operations on bounds++-- $boundsdoc+-- Corresponding operations are available on bounding boxes - the +-- definitions here have different type class obligations.++-- | The center of a picture.+center :: (Horizontal a, Vertical a, Fractional u, u ~ PUnit a) => a -> Point2 u+center a = P2 hcenter vcenter where  +    hcenter = leftBound a   + 0.5 * (rightBound a - leftBound a)+    vcenter = bottomBound a + 0.5 * (topBound a   - bottomBound a)++-- | Extract the top-left corner.+topleft       :: (Horizontal a, Vertical a, u ~ PUnit a) => a -> Point2 u+topleft a     = P2 (leftBound a)  (topBound a)++-- | Extract the top-right corner.+topright      :: (Horizontal a, Vertical a, u ~ PUnit a) => a -> Point2 u+topright a    = P2 (rightBound a) (topBound a)++-- | Extract the bottom-left corner.+bottomleft    :: (Horizontal a, Vertical a, u ~ PUnit a) => a -> Point2 u+bottomleft a  = P2 (leftBound a)  (bottomBound a)++-- | Extract the bottom-right corner.+bottomright   :: (Horizontal a, Vertical a, u ~ PUnit a) => a -> Point2 u+bottomright a = P2 (rightBound a) (bottomBound a)++--------------------------------------------------------------------------------+-- Internal helpers++leftmid       :: (Fractional u, Horizontal a, Vertical a, u ~ PUnit a) +              => a -> Point2 u+leftmid a     = P2 (leftBound a) (midpt (bottomBound a) (topBound a))++rightmid      :: (Fractional u, Horizontal a, Vertical a, u ~ PUnit a) +              => a -> Point2 u+rightmid a    = P2 (rightBound a) (midpt (bottomBound a) (topBound a))+++topmid        :: (Fractional u, Horizontal a, Vertical a, u ~ PUnit a) +              => a -> Point2 u+topmid a      = P2 (midpt (leftBound a) (rightBound a)) (topBound a)++bottommid     :: (Fractional u, Horizontal a, Vertical a, u ~ PUnit a) +              => a -> Point2 u+bottommid a   = P2 (midpt (leftBound a) (rightBound a)) (bottomBound a)+++midpt :: Fractional a => a -> a -> a+midpt a b = a + 0.5*(b-a)++--------------------------------------------------------------------------------+-- Composition++infixr 5 -//-, `above`, `below`+infixr 6 ->-, -@-+++-- | > a -@- b+-- +-- Center @a@ on top of @b@, @a@ is potentially moved and drawn +-- 'over' @b@.+--+(-@-) :: (Horizontal a, Vertical a, Composite a, Move a, Fractional u, +             u ~ PUnit a)+         => a -> a -> a+p1 -@- p2 = (move x y p1) `over` p2 where V2 x y = center p2 .-. center p1+++-- | > a ->- b+-- +-- Horizontal composition - move @b@, placing it to the right +-- of @a@.+-- +(->-) :: (Horizontal a, Composite a, Num u, u ~ PUnit a) => a -> a -> a+a ->- b = a `over` (moveH disp b) where disp = rightBound a - leftBound b ++-- | > a -<- b+-- +-- Horizontal composition - move @a@, placing it to the left +-- of @b@.+--+(-<-) :: (Horizontal a, Composite a, Num u, u ~ PUnit a) => a -> a -> a+a -<- b = (moveH disp a) `over` b where disp = leftBound b - rightBound a+++-- | > a -//- b+--+-- Vertical composition - move @b@, placing it below @a@.+--+(-//-) :: (Vertical a, Composite a, Num u, u ~ PUnit a) => a -> a -> a+a -//- b = a `over` (moveV disp b) where disp = bottomBound a - topBound b +++-- | > a `below` b+-- +-- Vertical composition - move @a@, placing it below @b@+--+below :: (Vertical a, Composite a, Num u, u ~ PUnit a) => a -> a -> a+a `below` b = (moveV disp a) `over` b where disp = bottomBound a - topBound b++++-- | > a `above` b+-- +-- Vertical composition - move @a@, placing it above @b@.+--+above :: (Vertical a, Composite a, Num u, u ~ PUnit a) => a -> a -> a+a `above` b = (moveV disp a) `over` b where disp = topBound b - bottomBound a +++-- | Place the picture at the supplied point.+-- +at :: (Move a, u ~ PUnit a) => a -> Point2 u  -> a+p `at` (P2 x y) = move x y p++-- | Center the picture at the supplied point.+--+centeredAt :: (Horizontal a, Vertical a, Move a, Composite a, Blank a, +               Fractional u, u ~ PUnit a) +           => a -> Point2 u -> a+centeredAt p pt = p -@- (blank 0 0 `at` pt) ++++-- | > xs `stackOnto` a+-- +-- Stack the list of pictures @xs@ 'over' @a@.+--+-- Note, the first picture in the list is drawn at the top, the+-- last picture is draw 'over' @a@.+--+stackOnto :: (Composite a) => [a] -> a -> a+stackOnto = flip (foldr over)++-- | > x ->- xs+-- +-- Concatenate the list pictures @xs@ horizontally with @(->-)@ +-- starting at @x@.+-- +hcat :: (Horizontal a, Composite a, Num u, u ~ PUnit a)+     => a -> [a] -> a+hcat = foldl' (->-)++-- | > x -//- xs+-- +-- Concatenate the list of pictures @xs@ vertically with @(-\/\/-)@ +-- starting at @x@.+--+vcat :: (Vertical a, Composite a, Num u, u ~ PUnit a)+     => a -> [a] -> a+vcat = foldl' (-//-)++++-- | Stack pictures centered ontop of each other - the first +-- picture in the list is drawn at the top, last picture is on +-- drawn at the bottom.+stackOntoCenter :: (Horizontal a, Vertical a, Composite a, +                Move a, Fractional u,+                u ~ PUnit a)+            => [a] -> a -> a+stackOntoCenter = flip $ foldr (-@-)++++--------------------------------------------------------------------------------++-- Helpers+blankH  :: (Num u, Blank a, u ~ PUnit a) => u -> a+blankH = blank `flip` 0++blankV  :: (Num u, Blank a, u ~ PUnit a) => u -> a+blankV = blank 0+++-- NOTE+-- The following simple definition of hspace is invalid:+--+-- > hspace n a b = a ->- (moveH n b)+-- +-- The movement due to @moveH n@ is annulled by the @->-@ +-- operator which moves relative to the bounding box.+-- +-- The almost as simple definition below, seems to justify +-- including Blank as a Picture constructor.+--+++-- | > hspace n a b+--+-- Concatenate the pictures @a@ and @b@ with @(->-)@ - injecting +-- a space of @n@ units to separate the pictures.+--+hspace :: (Num u, Composite a, Horizontal a, Blank a, u ~ PUnit a) +       => u -> a -> a -> a+hspace n a b = a ->- blankH n ->- b++-- | > vspace n a b+--+-- Concatenate the pictures @a@ and @b@ with @(-\/\/-)@ - injecting +-- a space of @n@ units to separate the pictures.+--+vspace :: (Num u, Composite a, Vertical a, Blank a, u ~ PUnit a) +       => u -> a -> a -> a+vspace n a b = a -//- blankV n -//-  b++++-- | > hsep n x xs+--+-- Concatenate the list of pictures @xs@ horizontally with +-- @hspace@ starting at @x@. The pictures are interspersed with +-- spaces of @n@ units.+--+hsep :: (Num u, Composite a, Horizontal a, Blank a, u ~ PUnit a) +       => u -> a -> [a] -> a+hsep n = foldl' (hspace n)++++-- | > vsep n x xs+--+-- Concatenate the list of pictures @xs@ vertically with +-- @vspace@ starting at @x@. The pictures are interspersed with +-- spaces of @n@ units.+--+vsep :: (Num u, Composite a, Vertical a, Blank a, u ~ PUnit a) +       => u -> a -> [a] -> a+vsep n = foldl' (vspace n)+++--------------------------------------------------------------------------------+-- Aligning pictures+++-- | > alignH z a b+--+-- Move picture @b@ up or down to be horizontally aligned along a +-- line from the top, center or bottom of picture @a@+-- +alignH :: ( Fractional u, Composite a, Horizontal a, Vertical a, Move a+          , u ~ PUnit a ) +       => HAlign -> a -> a -> a+alignH HTop    p1 p2 = vecMove p1 p2 (vvec $ topBound p1 - topBound p2)+alignH HBottom p1 p2 = vecMove p1 p2 (vvec $ bottomBound p1 - bottomBound p2)+alignH HCenter p1 p2 = vecMove p1 p2 (vvec v)+  where V2 _ v = rightmid p1    .-. leftmid p2+++-- | > alignV z a b+--+-- Move picture @b@ left or right to be vertically aligned along a +-- line from the left side, center or right side of picture @a@+-- +alignV :: ( Fractional u, Composite a, Horizontal a, Vertical a, Move a+          , u ~ PUnit a ) +       => VAlign -> a -> a -> a+alignV VLeft   p1 p2 = vecMove p1 p2 (hvec $ leftBound p1 - leftBound p2) +alignV VRight  p1 p2 = vecMove p1 p2 (hvec $ rightBound p1 - rightBound p2)+alignV VCenter p1 p2 = vecMove p1 p2 (hvec h) +  where V2 h _ = bottommid p1   .-. topmid p2+++-- Helpers++vecMove :: (Composite a, Move a, u ~ PUnit a) => a -> a -> (Vec2 u) -> a +vecMove a b (V2 x y) = a `over` (move x y) b ++-- Unlike alignH this function \"moves and concatenates\".+moveAlignH :: ( Fractional u, Composite a, Horizontal a, Vertical a, Move a+          , u ~ PUnit a ) +       => HAlign -> a -> a -> a+moveAlignH HTop    p1 p2 = vecMove p1 p2 (topright p1    .-. topleft p2)+moveAlignH HCenter p1 p2 = vecMove p1 p2 (rightmid p1    .-. leftmid p2)+moveAlignH HBottom p1 p2 = vecMove p1 p2 (bottomright p1 .-. bottomleft p2)+++-- Unlike alignV this function \"moves and concatenates\".+moveAlignV :: ( Fractional u, Composite a, Horizontal a, Vertical a, Move a+          , u ~ PUnit a ) +       => VAlign -> a -> a -> a+moveAlignV VLeft   p1 p2 = vecMove p1 p2 (bottomleft p1  .-. topleft p2)+moveAlignV VCenter p1 p2 = vecMove p1 p2 (bottommid p1   .-. topmid p2)+moveAlignV VRight  p1 p2 = vecMove p1 p2 (bottomright p1 .-. topright p2)+++-- | Variant of 'hcat' that aligns the pictures as well as+-- concatenating them.+hcatA :: ( Fractional u, Horizontal a, Vertical a+         , Composite a, Move a, u ~ PUnit a)+     => HAlign -> a -> [a] -> a+hcatA ha = foldl' (moveAlignH ha)++-- | Variant of 'vcat' that aligns the pictures as well as+-- concatenating them.+vcatA :: ( Fractional u, Horizontal a, Vertical a+         , Composite a, Move a, u ~ PUnit a)+     => VAlign -> a -> [a] -> a+vcatA va = foldl' (moveAlignV va)+++-- | Variant of @hsep@ that aligns the pictures as well as+-- concatenating and spacing them.+hsepA :: ( Fractional u, Horizontal a, Vertical a+         , Composite a, Move a, Blank a, u ~ PUnit a)+     => HAlign -> u -> a -> [a] -> a+hsepA ha n = foldl' op where +   a `op` b = moveAlignH ha (moveAlignH ha a (blankH n)) b ++-- | Variant of @vsep@ that aligns the pictures as well as+-- concatenating and spacing them.+vsepA :: ( Fractional u, Horizontal a, Vertical a+         , Composite a, Move a, Blank a, u ~ PUnit a)+     => VAlign -> u -> a -> [a] -> a+vsepA va n = foldl' op where +   a `op` b = moveAlignV va (moveAlignV va a (blankV n)) b ++--------------------------------------------------------------------------------++-- TO DETERMINE+-- What should leftBound and rightBound be for an empty picture?++type instance PUnit (Picture u) = u++instance (Num u, Ord u) => Horizontal (Picture u) where+  moveH a p  = p `picMoveBy` (hvec a) +  leftBound  = leftPlane . boundary+  rightBound = rightPlane . boundary++instance (Num u, Ord u) => Vertical (Picture u) where+  moveV a p   = p `picMoveBy` (vvec a) +  topBound    = upperPlane . boundary+  bottomBound = lowerPlane . boundary++-- Note - picture is a binary tree and drawing is depth-first,+-- left-to-right so pictures in the right of the tree potentially+-- are drawn on top of pictures on the left.+--+-- So to print picture a _over_ picture b we form this node:+--+-- >  locale +-- >    /\+-- >   /  \+-- >  b    a+--+-- Hence `over` flips b and a+++instance (Num u, Ord u) => Composite (Picture u) where+  over = picOver       ++instance (Num u, Ord u) => Move (Picture u) where+  move x y p = p `picMoveBy` (V2 x y)+++instance (Num u, Ord u) => Blank (Picture u) where+  blank w h = blankPicture (bbox zeroPt (P2 w h))++++--------------------------------------------------------------------------------+-- +++-- | Create multiple lines of text.+--+-- The dimension argument is the linespacing, measured as the+-- distance between the upper lines descender and the lower +-- lines ascender.+--+-- An error is throw if the list of strings is empty+-- +multilabel :: (Real u, Floating u, TextLabel t) +           => t -> u -> VAlign -> [String] -> Point2 u -> Picture u+multilabel _    _ _  []     _  = error $ +    "Wumpus.Core.PictureLanguage.multilabel - empty list."++multilabel attr n va (x:xs) pt = +    moveAll $ vsepA va n line1 (map mkPic xs)+  where+    line1     = mkPic x+    mkPic s   = frame $ textlabel attr s zeroPt+    vdelta p  = boundaryHeight (boundary p) - boundaryHeight (boundary line1)+    moveAll p = moveV (vdelta p) $ p `at` pt++

@@ -1,5 +1,5 @@ name:             wumpus-basic-version:          0.2.0+version:          0.3.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -9,10 +9,30 @@ synopsis:         Common drawing utilities built on wumpus-core. description:   .-  Very preliminary release...+  \*\* WARNING \*\* - this package is sub-alpha. It is only on +  Hackage to support other packages (Wumpus-Tree, +  Wumpus-Microprint) that are slighly more stable.   .+  A few of the modules (SafeFonts, SVGColours, X11Colours) are+  fairly stable others simply aren\'t and may even disappear in+  subsequent updates.+  .+  .   Changelog:   .+  0.2.0 to 0.3.0 :+  . +  * Added the anchors, monads, drawingAttrs...+  .+  * Added the module @PictureLanguage@ from Wumpus-Core.+    It is located with the path prefix @Wumpus.Deprecated@.+    At some point it will be replaced...+  .+  * Basic.Graphic - rectangles and lines now take the supplied+    point to be the center rather than the bottom-left corner.+    Name changes - @circle@ changed to @disk@, @text@ changed to +    @textline@.+  .   0.1.1 to 0.2.0:   .   * Added the module @Wumpus.Basic.Graphic@.@@ -30,28 +50,44 @@ extra-source-files:   CHANGES,   LICENSE,+  demo/DotPic.hs,   demo/FontPic.hs,   demo/ColourCharts.hs,-  demo/ColourDefns.hs-+  demo/ColourDefns.hs,+  demo/Picture.hs  library   hs-source-dirs:     src   build-depends:      base            <  5,                        vector-space    >= 0.6,                       monadLib        >= 3.6,-                      wumpus-core     >= 0.20.0+                      wumpus-core     >= 0.21.0       exposed-modules:+    Wumpus.Basic.Anchors,+    Wumpus.Basic.AnchorDots,+    Wumpus.Basic.Dots,     Wumpus.Basic.Graphic,+    Wumpus.Basic.Graphic.DrawingAttr,+    Wumpus.Basic.Graphic.PointSupply,+    Wumpus.Basic.Monads.ConsDrawing,+    Wumpus.Basic.Monads.Drawing,+    Wumpus.Basic.Monads.DrawingCtxClass,+    Wumpus.Basic.Monads.DrawingCtxMonad,+    Wumpus.Basic.Monads.STraceMonad,+    Wumpus.Basic.Monads.SnocDrawing,+    Wumpus.Basic.Monads.TraceClass,     Wumpus.Basic.Monads.TraceMonad,+    Wumpus.Basic.Monads.TurtleClass,     Wumpus.Basic.Monads.TurtleMonad,     Wumpus.Basic.SafeFonts,     Wumpus.Basic.SVGColours,     Wumpus.Basic.X11Colours,     Wumpus.Basic.Utils.HList,-    Wumpus.Basic.VersionNumber+    Wumpus.Basic.Utils.Intersection,+    Wumpus.Basic.VersionNumber,+    Wumpus.Deprecated.PictureLanguage    other-modules: