wumpus-core 0.12.0 → 0.13.0

raw patch · 23 files changed

+1042/−450 lines, 23 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGES +26/−0
• demo/LabelPic.hs +12/−1
• demo/Picture.hs +80/−9
• src/Wumpus/Core.hs +37/−6
• src/Wumpus/Core/AffineTrans.hs +42/−13
• src/Wumpus/Core/BoundingBox.hs +46/−20
• src/Wumpus/Core/Colour.hs +60/−27
• src/Wumpus/Core/FontSize.hs +22/−11
• src/Wumpus/Core/Geometry.hs +77/−51
• src/Wumpus/Core/GraphicsState.hs +64/−10
• src/Wumpus/Core/OutputPostScript.hs +16/−38
• src/Wumpus/Core/OutputSVG.hs +10/−7
• src/Wumpus/Core/Picture.hs +75/−35
• src/Wumpus/Core/PictureInternal.hs +6/−5
• src/Wumpus/Core/PictureLanguage.hs +203/−54
• src/Wumpus/Core/PostScript.hs +9/−7
• src/Wumpus/Core/SVG.hs +9/−6
• src/Wumpus/Core/TextEncoder.hs +83/−0
• src/Wumpus/Core/TextEncoding.hs +0/−119
• src/Wumpus/Core/TextEncodingInternal.hs +101/−0
• src/Wumpus/Core/TextLatin1.hs +8/−5
• src/Wumpus/Core/Utils.hs +1/−1
• wumpus-core.cabal +55/−25

@@ -0,0 +1,26 @@+++0.12.0 to 0.13.0:++  * More Haddock documenting. ++  * @lowerLeftUpperRight@ removed from "Wumpus.Core.BoundingBox".++  * Added range checking and Ord obligation t to the @bbox@ +    \'smart\' constructor.++  * Numeric instances for "Wumpus.Core.Colour" improved.++  * MatrixMult type class simplified++  * Dash Pattern made a list of on-off pairs rather than just a +    list ++  * The modules - Wumpus.Core.PictureInternal, Wumpus.Core.PostScript,+    Wumpus.Core.SVG & Wumpus.Core.Utils - are no longer exposed.++  * Various operators in "Wumpus.Core.PictureLanguage" changed.++  * Wumpus.Core.TextEncoding split into an internal and a public +    module (internal - Wumpus.Core.TextEncodingInternal, public - +    Wumpus.Core.TextEncoder).

@@ -127,7 +127,7 @@     writeEPS_latin1 "./out/label09.eps" p1     writeSVG_latin1 "./out/label09.svg" p1   where-    p1 = (bigA -//- bigB) ->- (bigA -\\- bigB) +    p1 = (bigA `above` bigB) ->- (bigA `below` bigB)       demo10 :: IO () demo10 = do @@ -137,9 +137,20 @@     p1 :: Picture Double     p1 = frame $ textlabel () zeroPt "myst&#egrave;re" +demo11 :: IO ()+demo11 = do+    writeEPS_latin1 "./out/label11.eps" pic+    writeSVG_latin1 "./out/label11.svg" pic+  where+    pic :: Picture Double+    pic = p1 `over` p2+    p1  = multilabel plum 3 VLeft (P2 50 50) ["Hello", "from", "Wumpus"]+    p2  = bigA `at` P2 50 50 + main :: IO () main = sequence_   [ demo01, demo02, demo03, demo04, demo05   , demo06, demo07, demo08, demo09, demo10+  , demo11   ]  

@@ -97,9 +97,9 @@   where     p1 = hspace 20 square square -mkFilledSquare :: (PSColour c, Fill c) => c -> DPicture -mkFilledSquare col = frame $ fill col $ vertexPath-  [ P2 0 0, P2 40 0, P2 40 40, P2 0 40 ]+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 ()@@ -108,9 +108,9 @@     writeSVG_latin1 "./out/picture09.svg" p1   where     p1 = (alignH HTop s1 s2) `op` s3-    s1 = uniformScale 1.5  $ mkFilledSquare plum -    s2 = uniformScale 1.75 $ mkFilledSquare peru-    s3 = scale 3 1.5       $ mkFilledSquare black+    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   @@ -120,14 +120,85 @@     writeSVG_latin1 "./out/picture10.svg" p1   where     p1 = vsepA VRight 5 s1 [s2,s3]-    s1 = uniformScale 1.5  $ mkFilledSquare plum -    s2 = uniformScale 1.75 $ mkFilledSquare peru-    s3 = scale 3 1.5       $ mkFilledSquare black+    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) zeroPt 4 6+    p2 = scale 6 12 $ frame $ ellipse (peru, LineWidth 2) zeroPt 6 6+++-- 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++ main :: IO () main = sequence_   [ demo01, demo02, demo03, demo04, demo05   , demo06, demo07, demo08, demo09, demo10+  , demo11, demo12, demo13, demo14   ]

@@ -7,11 +7,42 @@ -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC+-- Stability   :  unstable +-- Portability :  GHC with TypeFamilies and more ----- Common interface to Wumpus.Core...--- +-- Common interface to Wumpus.Core.+--+-- This module re-exports types and functions from:+--+-- * "Wumpus.Core.AffineTrans"+--+-- * "Wumpus.Core.BoundingBox"+--+-- * "Wumpus.Core.Colour"+--+-- * "Wumpus.Core.FontSize"+--+-- * "Wumpus.Core.Geometry"+--+-- * "Wumpus.Core.GraphicsState"+--+-- * "Wumpus.Core.OutputPostScript"+--+-- * "Wumpus.Core.OutputSVG"+--+-- * "Wumpus.Core.Picture"+--+-- * "Wumpus.Core.PictureLanguage"+--+-- * "Wumpus.Core.TextEncoding"+--+--+-- Named colours ( black, white etc.) are hidden from +-- "Wumpus.Core.Colour" to avoid collisions with modules that+-- define colour sets (e.g. all the SVG colours). +--+-- Some data types are exported from +-- "Wumpus.Core.PictureInternal" but are made opaque.  --  -------------------------------------------------------------------------------- @@ -28,7 +59,7 @@   , module Wumpus.Core.OutputSVG   , module Wumpus.Core.Picture   , module Wumpus.Core.PictureLanguage-  , module Wumpus.Core.TextEncoding+  , module Wumpus.Core.TextEncoder    -- Export from Picture Internal   , Picture@@ -61,7 +92,7 @@ import Wumpus.Core.Picture import Wumpus.Core.PictureInternal import Wumpus.Core.PictureLanguage-import Wumpus.Core.TextEncoding+import Wumpus.Core.TextEncoder   

@@ -7,12 +7,32 @@ -- | -- Module      :  Wumpus.Core.AffineTrans -- Copyright   :  (c) Stephen Tetley 2009--- License     :  BSD-style (see LICENSE)+-- License     :  BSD3+-- -- Maintainer  :  stephen.tetley@gmail.com--- Stability   :  experimental--- Portability :  GHC only+-- Stability   :  unstable+-- Portability :  GHC with TypeFamilies and more ----- Affine transformations+-- Affine transformations.+-- +-- The common affine transformations represented as type classes -+-- scaling, rotation, translation.+--+-- Unlike other functional graphics systems (e.g. Clastic), Wumpus+-- performs the affine transformations as matrix operations. This +-- simplifies the implementation of pictures +-- ("Wumpus.Core.PictureInternal"). When a picture is composed and +-- transformed, transformations will be performed directly on the +-- bounding box in Wumpus but the transformation of the +-- picture content (paths or text labels) will be communicated to +-- PostScript or SVG to render. This is because Wumpus has no +-- access to the paths that make fonts so cannot transform them +-- directly.+-- +-- To generate efficient PostScript, Wumpus relies on the matrix+-- representations of the affine transformations being invertible.+-- Please do not scale elements by zero.+-- --------------------------------------------------------------------------------  module Wumpus.Core.AffineTrans@@ -57,8 +77,7 @@ -- Affine transformations   --- Rotate-+-- | Type class for rotation. class Rotate t where   rotate :: Radian -> t -> t @@ -69,8 +88,8 @@ instance (Floating a, Real a) => Rotate (Vec2 a) where   rotate a = ((rotationMatrix a) *#) --- Rotate about +-- | Type class for rotation about a point. class RotateAbout t where   rotateAbout :: Radian -> Point2 (DUnit t) -> t -> t  @@ -85,6 +104,7 @@ -------------------------------------------------------------------------------- -- Scale +-- | Type class for scaling. class Scale t where   scale :: DUnit t -> DUnit t -> t -> t @@ -97,10 +117,10 @@ -------------------------------------------------------------------------------- -- Translate +-- | Type class for translations. class Translate t where   translate :: DUnit t -> DUnit t -> t -> t --- | translate @x@ @y@. instance Num u => Translate (Point2 u) where   translate x y = ((translationMatrix x y) *#) @@ -113,37 +133,43 @@   -+-- | Rotate by 30 degrees about the origin.  rotate30 :: Rotate t => t -> t  rotate30 = rotate (pi/6)  +-- | Rotate by 30 degrees about the supplied point. rotate30About :: (RotateAbout t, DUnit t ~ u) => Point2 u -> t -> t  rotate30About = rotateAbout (pi/6) -+-- | Rotate by 45 degrees about the origin.  rotate45 :: Rotate t => t -> t  rotate45 = rotate (pi/4)  +-- | Rotate by 45 degrees about the supplied point. rotate45About :: (RotateAbout t, DUnit t ~ u) => Point2 u -> t -> t  rotate45About = rotateAbout (pi/4) -+-- | Rotate by 60 degrees about the origin.  rotate60 :: Rotate t => t -> t  rotate60 = rotate (2*pi/3)  +-- | Rotate by 60 degrees about the supplied point. rotate60About :: (RotateAbout t, DUnit t ~ u) => Point2 u -> t -> t  rotate60About = rotateAbout (2*pi/3) +-- | Rotate by 90 degrees about the origin.  rotate90 :: Rotate t => t -> t  rotate90 = rotate (pi/2)  +-- | Rotate by 90 degrees about the supplied point. rotate90About :: (RotateAbout t, DUnit t ~ u) => Point2 u -> t -> t  rotate90About = rotateAbout (pi/2) -+-- | Rotate by 120 degrees about the origin.  rotate120 :: Rotate t => t -> t  rotate120 = rotate (4*pi/3)  +-- | Rotate by 120 degrees about the supplied point. rotate120About :: (RotateAbout t, DUnit t ~ u) => Point2 u -> t -> t  rotate120About = rotateAbout (4*pi/3) @@ -152,19 +178,22 @@ -------------------------------------------------------------------------------- -- Common scalings +-- | Scale both x and y dimensions by the same amount. uniformScale :: (Scale t, DUnit t ~ u) => u -> t -> t  uniformScale a = scale a a  -+-- | Reflect in the X-plane about the origin. reflectX :: (Num u, Scale t, DUnit t ~ u) => t -> t reflectX = scale (-1) 1 +-- | Reflect in the Y-plane about the origin. reflectY :: (Num u, Scale t, DUnit t ~ u) => t -> t reflectY = scale 1 (-1)  -------------------------------------------------------------------------------- -- translations +-- | Translate by the x and y components of a vector. translateBy :: (Translate t, DUnit t ~ u) => Vec2 u -> t -> t  translateBy (V2 x y) = translate x y 

@@ -5,13 +5,18 @@ -- | -- Module      :  Wumpus.Core.BoundingBox -- Copyright   :  (c) Stephen Tetley 2009--- License     :  BSD-style (see LICENSE)+-- License     :  BSD3+-- -- Maintainer  :  stephen.tetley@gmail.com--- Stability   :  experimental--- Portability :  GHC only+-- Stability   :  unstable+-- Portability :  GHC with TypeFamilies and more -- -- Bounding box with no notion of \'empty\'. --+-- Empty pictures cannot be created with Wumpus. This greatly +-- simplifies the implementation of pictures themselves and+-- bounding boxes.+--  --------------------------------------------------------------------------------  module Wumpus.Core.BoundingBox @@ -30,7 +35,6 @@   , union    , trace   , corners-  , lowerLeftUpperRight   , withinBB   , boundaryWidth   , boundaryHeight@@ -56,10 +60,12 @@   --- | Bounding box of a picture.+-- | Bounding box of a picture, represented by the lower left and+-- upper right corners. -- --- We cannot construct empty pictures - so bounding boxes too a --- saved the obligation to be empty.+-- We cannot construct empty pictures - so bounding boxes are +-- spared the obligation to be /empty/. BoundingBox is an instance+-- of the Semigroup class where @append@ is the union operation. --  data BoundingBox a = BBox {                           ll_corner :: Point2 a, @@ -69,6 +75,8 @@  type DBoundingBox = BoundingBox Double +-- | A location on a bounding box - the center @C@ and the usual+-- compass points @N@, @S@, etc. data CardinalPoint = C | N | NE | E | SE | S | SW | W | NW   deriving (Eq,Show) @@ -99,6 +107,8 @@ -------------------------------------------------------------------------------- -- Boundary class +-- | Type class extracting the bounding box of an object - +-- Picture, Path etc. class Boundary a where   boundary :: a -> BoundingBox (DUnit a) @@ -113,8 +123,16 @@  -------------------------------------------------------------------------------- -bbox :: Point2 a -> Point2 a -> BoundingBox a-bbox = BBox +-- | Contruct a bounding box, vis the BBox constructor with range +-- checking on the corner points.+--+-- @bbox@ throws an error if the width or height of the +-- constructed bounding box is negative.+--+bbox :: Ord a => Point2 a -> Point2 a -> BoundingBox a+bbox ll@(P2 x0 y0) ur@(P2 x1 y1) +   | x0 <= x1 && y0 <= y1 = BBox ll ur +   | otherwise            = error "Wumpus.Core.BoundingBox.bbox - malformed."   -- | Create a BoundingBox with bottom left corner at the origin,@@ -123,34 +141,33 @@ obbox w h = BBox zeroPt (P2 w h)  +-- | The union of two bounding boxes. This is also the @append@ +-- of BoundingBox\'s @Semigroup@ instance. union :: Ord a => BoundingBox a -> BoundingBox a -> BoundingBox a BBox ll ur `union` BBox ll' ur' = BBox (cmin ll ll') (cmax ur ur') --- Trace the point list finding the /extremity/...-+-- | Trace a list of points, retuning the BoundingBox that +-- includes them. trace :: (Num a, Ord a) => [Point2 a] -> BoundingBox a trace (p:ps) = uncurry BBox $ foldr (\z (a,b) -> (cmin z a, cmax z b) ) (p,p) ps trace []     = error $ "BoundingBox.trace called in empty list" -+-- | Generate all the corners of a bounding box, counter-clock +-- wise from the bottom left, i.e. @[bl, br, tr, tl]@. corners :: BoundingBox a -> [Point2 a] corners (BBox bl@(P2 x0 y0) tr@(P2 x1 y1)) = [bl, br, tr, tl] where     br = P2 x1 y0     tl = P2 x0 y1 --lowerLeftUpperRight :: (a,a,a,a) -> BoundingBox a -> (a,a,a,a)-lowerLeftUpperRight _   (BBox (P2 x0 y0) (P2 x1 y1)) = (x0,y0,x1,y1)---+-- | Witinh test - is the supplied point within the bounding box? withinBB :: Ord a => Point2 a -> BoundingBox a -> Bool withinBB p (BBox ll ur) = within p ll ur -+-- | Extract the width of a bounding box. boundaryWidth :: Num a => BoundingBox a -> a boundaryWidth (BBox (P2 xmin _) (P2 xmax _)) = xmax - xmin +-- | Extract the height of a bounding box. boundaryHeight :: Num a => BoundingBox a -> a boundaryHeight (BBox (P2 _ ymin) (P2 _ ymax)) = ymax - ymin @@ -159,20 +176,25 @@  -- Points on the boundary -+-- | Extract the bottom-left corner of the bounding box. boundaryBottomLeft  :: BoundingBox a -> Point2 a boundaryBottomLeft (BBox p0 _ ) = p0 +-- | Extract the top-right corner of the bounding box. boundaryTopRight :: BoundingBox a -> Point2 a boundaryTopRight (BBox _ p1) = p1 +-- | Extract the top-left corner of the bounding box. boundaryTopLeft :: BoundingBox a -> Point2 a boundaryTopLeft (BBox (P2 x _) (P2 _ y)) = P2 x y +-- | Extract the bottom-right corner of the bounding box. boundaryBottomRight :: BoundingBox a -> Point2 a boundaryBottomRight (BBox (P2 _ y) (P2 x _)) = P2 x y  +-- | Extract a point from the bounding box at the supplied +-- cardinal position. boundaryPoint :: Fractional a                => CardinalPoint -> BoundingBox a -> Point2 a boundaryPoint loc (BBox (P2 x0 y0) (P2 x1 y1)) = fn loc where@@ -196,15 +218,19 @@  -- Are these really worthwhile ? ... +-- | Extract the unit of the left vertical plane. leftPlane :: BoundingBox a -> a leftPlane (BBox (P2 l _) _) = l +-- | Extract the unit of the right vertical plane. rightPlane :: BoundingBox a -> a rightPlane (BBox _ (P2 r _)) = r +-- | Extract the unit of the lower horizontal plane. lowerPlane :: BoundingBox a -> a lowerPlane (BBox (P2 _ l) _) = l +-- | Extract the unit of the upper horizontal plane. upperPlane :: BoundingBox a -> a upperPlane (BBox _ (P2 _ u)) = u 

@@ -8,12 +8,21 @@ -- Copyright   :  (c) Stephen Tetley 2009 -- License     :  BSD3 ----- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC with TypeFamilies and more ----- RGB, HSB, Gray colour types. --+-- RGB, HSB, Gray colour types, and conversions between them.+--+-- Internally Wumpus uses @RGB3 Double@ with range [0.0, 1..0] +-- as the colour type. All colour values in the generated SVG or +-- PostScript files will be RGB.+--+-- Colour have Num instances for convenience, though the +-- operations of @Data.VectorSpace@ (instances also defined) +-- seem more approriate.+-- --------------------------------------------------------------------------------  @@ -73,13 +82,16 @@   newtype Gray a = Gray a-  deriving (Eq,Num,Ord,Show)+  deriving (Eq,Num,Fractional,Ord,Show)  -- | Gray represented by a Double - values should be in the range -- 0.0 (black) to 1.0 (white). type DGray = Gray Double  +--------------------------------------------------------------------------------+-- Num instances+ instance Num a => Num (RGB3 a) where   (+) (RGB3 a b c) (RGB3 x y z) = RGB3 (a+x) (b+y) (c+z)   (-) (RGB3 a b c) (RGB3 x y z) = RGB3 (a-x) (b-y) (c-z)@@ -89,24 +101,7 @@   signum (RGB3 a b c)         = RGB3 (signum a) (signum b) (signum c)   fromInteger i = RGB3 (fromInteger i) (fromInteger i) (fromInteger i) -instance Fractional a => Fractional (RGB3 a) where-  (/) (RGB3 a b c) (RGB3 x y z) = RGB3 (a/x) (b/y) (c/z)-  recip (RGB3 a b c)            = RGB3 (recip a) (recip b) (recip c)-  fromRational a = RGB3 (fromRational a) (fromRational a) (fromRational a) - -instance Num a => AdditiveGroup (RGB3 a) where-  zeroV = RGB3 0 0 0-  (^+^) = (+)-  negateV = negate---instance (Num a, VectorSpace a) => VectorSpace (RGB3 a) where-  type Scalar (RGB3 a) = Scalar a-  s *^ (RGB3 a b c) = RGB3 (s*^a) (s*^b) (s*^c)--- instance Num a => Num (HSB3 a) where   (+) (HSB3 a b c) (HSB3 x y z) = HSB3 (a+x) (b+y) (c+z)   (-) (HSB3 a b c) (HSB3 x y z) = HSB3 (a-x) (b-y) (c-z)@@ -116,24 +111,55 @@   signum (HSB3 a b c)         = HSB3 (signum a) (signum b) (signum c)   fromInteger i = HSB3 (fromInteger i) (fromInteger i) (fromInteger i) +-- Num (Gray a) derived+++instance Fractional a => Fractional (RGB3 a) where+  (/) (RGB3 a b c) (RGB3 x y z) = RGB3 (a/x) (b/y) (c/z)+  recip (RGB3 a b c)            = RGB3 (recip a) (recip b) (recip c)+  fromRational a = RGB3 (fromRational a) (fromRational a) (fromRational a)+ instance Fractional a => Fractional (HSB3 a) where   (/) (HSB3 a b c) (HSB3 x y z) = HSB3 (a/x) (b/y) (c/z)   recip (HSB3 a b c)            = HSB3 (recip a) (recip b) (recip c)   fromRational a = HSB3 (fromRational a) (fromRational a) (fromRational a)  +-- Fractional (Gray a) derived++--------------------------------------------------------------------------------+-- Instances for VectorSpace+  +instance Num a => AdditiveGroup (RGB3 a) where+  zeroV = RGB3 0 0 0+  (^+^) = (+)+  negateV = negate+  instance Num a => AdditiveGroup (HSB3 a) where   zeroV = HSB3 0 0 0   (^+^) = (+)   negateV = negate +instance Num a => AdditiveGroup (Gray a) where+  zeroV = Gray 0                -- black+  (^+^) = (+)+  negateV = negate  -instance (Num a, VectorSpace a) => VectorSpace (HSB3 a) where-  type Scalar (HSB3 a) = Scalar a-  s *^ (HSB3 a b c) = HSB3 (s*^a) (s*^b) (s*^c)+instance Num a => VectorSpace (RGB3 a) where+  type Scalar (RGB3 a) = a+  s *^ (RGB3 a b c) = RGB3 (s*a) (s*b) (s*c) +instance Num a => VectorSpace (HSB3 a) where+  type Scalar (HSB3 a) = a+  s *^ (HSB3 a b c) = HSB3 (s*a) (s*b) (s*c)++instance Num a => VectorSpace (Gray a) where+  type Scalar (Gray a) = a+  s *^ (Gray a) = Gray (s*a)++ -------------------------------------------------------------------------------- -- Operations @@ -145,7 +171,7 @@ -- the documentation to Dr. Uwe Kern's xcolor LaTeX package  -+-- | Covert RGB \[0,1\] to HSB \[0,1\]. rgb2hsb :: DRGB -> DHSB rgb2hsb (RGB3 r g b) = HSB3 hue sat bri   where@@ -165,7 +191,7 @@         | otherwise           = (1/6) * (5+n)  -+-- | Covert HSB \[0,1\] to RGB \[0,1\]. hsb2rgb :: DHSB -> DRGB hsb2rgb (HSB3 hue sat bri) = bri *^ (vE - (sat *^ fV))   where@@ -180,15 +206,22 @@           | i == 5    = RGB3  0     1     f           | otherwise = RGB3  0     1     1           +-- | Covert RGB \[0,1\] to Gray \[0,1\]. rgb2gray :: DRGB -> DGray rgb2gray (RGB3 r g b) = Gray $ 0.3 * r + 0.59 * g + 0.11 * b  ++-- | Covert Gray \[0,1\] to RGB \[0,1\]. gray2rgb :: DGray -> DRGB gray2rgb (Gray a) = a *^ vE ++-- | Covert HSB \[0,1\] to Gray \[0,1\]. hsb2gray :: DHSB -> DGray hsb2gray (HSB3 _ _ b) = Gray b  ++-- | Covert Gray \[0,1\] to HSB \[0,1\]. gray2hsb :: DGray -> DHSB gray2hsb (Gray a) = HSB3 0 0 a 

@@ -4,20 +4,30 @@ -- | -- Module      :  Wumpus.Core.FontSize -- Copyright   :  (c) Stephen Tetley 2009--- License     :  BSD-style (see LICENSE)+-- License     :  BSD3+-- -- Maintainer  :  stephen.tetley@gmail.com--- Stability   :  experimental--- Portability :  GHC only+-- Stability   :  unstable+-- Portability :  GHC with TypeFamilies and more ----- Text handling+-- Font size calculation for Label\'s bounding boxes. -- +-- Calculations are based on metrics derived from Courier at 48 +-- pt. As Courier is a monospaced font, bounding boxes calculated +-- for other font families will usually have longer width than is+-- necessary for the printed text. +-- +-- This is a deficiency of Wumpus, but alternatives would have+-- significant implementation complexity.+--  --------------------------------------------------------------------------------  module Wumpus.Core.FontSize   (    -  -- * Type synonym+  -- * Type synonyms     FontSize+  , CharCount    -- * Courier metrics at 48 point   , courier48_width@@ -26,11 +36,12 @@   , courier48_descender_depth   , courier48_spacer_width ++  -- * Metrics calculation   , widthAt48pt   , textWidth   , textHeight   , descenderDepth-   , textBounds    ) where@@ -101,15 +112,15 @@ textWidth sz n = (fromIntegral sz)/48 * widthAt48pt n  -- | Text height is just identity/double-coercion, i.e. --- @18 == 18.0@. The /size/ of a font is (apparently) the maximum--- height (body + descender max + ascender max).+-- @18 == 18.0@. The /size/ of a font is the maximum height:+--+-- > body + descender max + ascender max+-- textHeight :: Num u =>  FontSize -> u textHeight = fromIntegral  -- | Descender depth for font size @sz@. -- --- (The metrics are taken from Courier, of course).--- descenderDepth :: Fractional u => FontSize -> u descenderDepth sz =  (fromIntegral sz) / 48 * courier48_descender_depth @@ -126,7 +137,7 @@ -- For variable width fonts the calculated bounding box will  -- usually be too long. ---textBounds :: Fractional u +textBounds :: (Fractional u, Ord u)             => FontSize -> Point2 u -> CharCount -> BoundingBox u textBounds sz body_bl n = bbox bl tr where     h           = textHeight sz

@@ -11,12 +11,18 @@ -- | -- Module      :  Wumpus.Core.Geometry -- Copyright   :  (c) Stephen Tetley 2009--- License     :  BSD-style (see LICENSE)+-- License     :  BSD3+-- -- Maintainer  :  stephen.tetley@gmail.com--- Stability   :  experimental--- Portability :  GHC only+-- Stability   :  unstable+-- Portability :  GHC with TypeFamilies and more ----- 2D geometry+-- Objects and operations for 2D geometry.+-- +-- Vector, point, affine frame, 3x3 matrix, and radian +-- representations, plus a type family @DUnit@ for parameterizing+-- type classes with some /dimension/.+-- --------------------------------------------------------------------------------  module Wumpus.Core.Geometry @@ -104,15 +110,13 @@  -- Datatypes  --- Vectors-+-- | 2D Vector - both components are strict. data Vec2 a = V2 !a !a   deriving (Eq,Show)  type DVec2 = Vec2 Double --- Points-+-- | 2D Point - both components are strict. data Point2 a = P2 !a !a   deriving (Eq,Show) @@ -149,11 +153,9 @@ -- >    sin(a)  cos(a) 0   -- >      0         0  1 ) ----- This is congruent with the form presented in Santos -  --- Example 45, page 17 extended to 3x3. ------ ref. David A. Santos /Multivariable and Vector Calculus/,--- July 17, 2008 Version.+-- This seems commplace in geometry texts, but PostScript +-- represents the @current-transformation-matrix@  in +-- column-major form. -- -- The right-most column is considered to represent a -- coordinate:@@ -181,7 +183,8 @@   -- | Radian is represented with a distinct type. --- Equality and ordering are approximate where the epsilon is 0.0001.+-- Equality and ordering are approximate where the epsilon +-- is 0.0001. newtype Radian = Radian { getRadian :: Double }   deriving (Num,Real,Fractional,Floating,RealFrac,RealFloat) @@ -212,6 +215,7 @@ -------------------------------------------------------------------------------- -- instances +-- Functor  instance Functor Vec2 where   fmap f (V2 a b) = V2 (f a) (f b)@@ -225,9 +229,9 @@     M3'3 (f m) (f n) (f o) (f p) (f q) (f r) (f s) (f t) (f u)  --- Vectors have a sensible Monoid instance as addition, points don't-+-- Monoid +-- Vectors have a sensible Monoid instance as addition, points don't  instance Num a => Monoid (Vec2 a) where   mempty  = V2 0 0@@ -241,13 +245,14 @@   mappend = frameProduct  --+-- Show  instance Show a => Show (Matrix3'3 a) where   show (M3'3 a b c d e f g h i) = "(M3'3 " ++ body ++ ")" where     body = show [[a,b,c],[d,e,f],[g,h,i]] +-- Num+ instance Num a => Num (Matrix3'3 a) where   (+) = lift2Matrix3'3 (+)    (-) = lift2Matrix3'3 (-)@@ -262,7 +267,7 @@   signum = fmap signum   fromInteger a = M3'3 a' a' a'  a' a' a'  a' a' a' where a' = fromInteger a  --- Radians+-- Instances for Radian which are 'special'.  instance Show Radian where   showsPrec i (Radian a) = showsPrec i a@@ -301,7 +306,7 @@   pretty (Radian d) = double d <> text ":rad"  ----------------------------------------------------------------------------------- Vector space and related instances+-- Vector space instances  instance Num a => AdditiveGroup (Vec2 a) where   zeroV = V2 0 0 @@ -340,11 +345,10 @@ --------------------------------------------------------------------------------  -- | Pointwise is a Functor like type class, except that the --- container/element relationship is defined by a type family --- rather than a type parameter. This means that applied function --- must be type preserving.--+-- container/element relationship is defined via an associated +-- type rather than a type parameter. This means that applied +-- function must be type preserving.+-- class Pointwise sh where   type Pt sh :: *   pointwise :: (Pt sh -> Pt sh) -> sh -> sh@@ -377,22 +381,18 @@  infixr 7 *#  -class MatrixMult mat t where -  type MatrixParam t :: *-  (*#) :: MatrixParam t ~ a => mat a -> t -> t+-- | Matrix multiplication - typically of points and vectors +-- represented as homogeneous coordinates. +--+class MatrixMult t where +  (*#) :: DUnit t ~ a => Matrix3'3 a -> t -> t  --- Matrix multiplication of points and vectors as per homogeneous --- coordinates (we don't perform the /last three/ multiplications--- as we throw the result away).- -instance Num a => MatrixMult Matrix3'3 (Vec2 a) where-  type MatrixParam (Vec2 a) = a       +instance Num a => MatrixMult (Vec2 a) where          (M3'3 a b c d e f _ _ _) *# (V2 m n) = V2 (a*m+b*n+c*0) (d*m+e*n+f*0)  -instance Num a => MatrixMult Matrix3'3 (Point2 a) where-  type MatrixParam (Point2 a) = a+instance Num a => MatrixMult(Point2 a) where   (M3'3 a b c d e f _ _ _) *# (P2 m n) = P2 (a*m+b*n+c*1) (d*m+e*n+f*1)  --------------------------------------------------------------------------------@@ -417,9 +417,12 @@ -------------------------------------------------------------------------------- -- Points +-- | Construct a point at 0 0. zeroPt :: Num a => Point2 a zeroPt = P2 0 0 +-- | Calculate the counter-clockwise angle between two points +-- and the x-axis. langle :: (Floating u, Real u) => Point2 u -> Point2 u -> Radian langle (P2 x y) (P2 x' y') = toRadian $ atan $ (y'-y) / (x'-x)  @@ -427,13 +430,17 @@ -------------------------------------------------------------------------------- -- Frame operations +-- | Create a frame with standard (orthonormal bases) at the +-- supplied point. ortho :: Num a => Point2 a -> Frame2 a ortho o = Frame2 (V2 1 0) (V2 0 1) o +-- | Displace the origin of the frame by the supplied vector. displaceOrigin :: Num a => Vec2 a -> Frame2 a -> Frame2 a displaceOrigin v (Frame2 e0 e1 o) = Frame2 e0 e1 (o.+^v) -+-- | \'World coordinate\' calculation of a point in the supplied+-- frame. pointInFrame :: Num a => Point2 a -> Frame2 a -> Point2 a pointInFrame (P2 x y) (Frame2 vx vy o) = (o .+^ (vx ^* x)) .+^ (vy ^* y)   @@ -468,7 +475,6 @@ -- -- > Frame (V2 e0x e0y) (V2 e1x e1y) (P2 ox oy) -- - matrix2Frame :: Matrix3'3 a -> Frame2 a matrix2Frame (M3'3 e0x e1x ox                     e0y e1y oy@@ -497,7 +503,6 @@ -- >       0 1 0 -- >       0 0 1 ) --- identityMatrix :: Num a => Matrix3'3 a identityMatrix = M3'3 1 0 0                         0 1 0  @@ -511,17 +516,28 @@ -- >       0  sy 0 -- >       0  0  1 ) --- scalingMatrix :: Num a => a -> a -> Matrix3'3 a scalingMatrix sx sy = M3'3  sx 0  0                                0  sy 0                                0  0  1 +-- | Construct a translation matrix:+--+-- > (M3'3 1  0  x+-- >       0  1  y+-- >       0  0  1 )+-- translationMatrix :: Num a => a -> a -> Matrix3'3 a translationMatrix x y = M3'3 1 0 x                                0 1 y                                0 0 1 +-- | Construct a rotation matrix:+--+-- > (M3'3 cos(a)  -sin(a)  x+-- >       sin(a)   cos(a)  y+-- >       0        0       1 )+-- rotationMatrix :: (Floating a, Real a) => Radian -> Matrix3'3 a rotationMatrix a = M3'3 (cos ang) (negate $ sin ang) 0                          (sin ang) (cos ang)          0  @@ -533,7 +549,13 @@ -- A reflection about the y-axis is a scale of (-1) 1  --- Rotation about some /point/.+-- | Construct a matrix for rotation about some /point/.+--+-- This is the product of three matrices: T R T^-1+-- +-- (T being the translation matrix, R the rotation matrix and+-- T^-1 the inverse of the translation matrix).+-- originatedRotationMatrix :: (Floating a, Real a)                           => Radian -> (Point2 a) -> Matrix3'3 a originatedRotationMatrix ang (P2 x y) = mT * (rotationMatrix ang) * mTinv@@ -548,18 +570,15 @@   --- inversion-+-- | Invert a matrix. invert :: Fractional a => Matrix3'3 a -> Matrix3'3 a  invert m = (1 / determinant m) *^ adjoint m +-- | Determinant of a matrix. determinant :: Num a => Matrix3'3 a -> a determinant (M3'3 a b c d e f g h i) = a*e*i - a*f*h - b*d*i + b*f*g + c*d*h - c*e*g --adjoint :: Num a => Matrix3'3 a -> Matrix3'3 a -adjoint = transpose . cofactor . mofm-+-- | Transpose a matrix. transpose :: Matrix3'3 a -> Matrix3'3 a transpose (M3'3 a b c                  d e f @@ -567,6 +586,12 @@                               b e h                                 c f i +-- Helpers++adjoint :: Num a => Matrix3'3 a -> Matrix3'3 a +adjoint = transpose . cofactor . mofm++ cofactor :: Num a => Matrix3'3 a -> Matrix3'3 a cofactor (M3'3 a b c                  d e f  @@ -596,23 +621,24 @@ -------------------------------------------------------------------------------- -- Radians --- Radian numeric type +-- | The epislion used for floating point equality on radians. radian_epsilon :: Double radian_epsilon = 0.0001 -+-- | Equality on radians, this is the operation used for (==) in+-- Radian\'s Eq instance. req :: Radian -> Radian -> Bool req a b = (fromRadian $ abs (a-b)) < radian_epsilon   --- Radian construction+-- | Convert to radians. toRadian :: Real a => a -> Radian  toRadian = Radian . realToFrac  --- Radian extraction +-- | Convert from radians. fromRadian :: Fractional a => Radian -> a fromRadian = realToFrac . getRadian 

@@ -8,12 +8,38 @@ -- Copyright   :  (c) Stephen Tetley 2009 -- License     :  BSD3 ----- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC with TypeFamilies and more ----- Data types modelling the Graphics state+-- Data types for stroke and label attributes and type classes +-- for conversion to PostScript\'s colour and matrix +-- representations. +-- +-- Wumpus represents pictures as trees - a leaf represents a +-- path or text label. All attributes of a path or text label +-- (colour, stroke width, font, ...) are stored in the leaf. So+-- a picture is a leaf labelled tree.+-- +-- By contrast, PostScript maintains a /graphics state/. A +-- PostScript program is free to modify the graphics state +-- anywhere in the program. Stroke width is a general property  +-- shared by all elements (initially it has the default value 1).+-- Only stroked paths actually regard stroke width, fonts and +-- filled and clipping paths ignore it. PostScript allows more +-- control over the graphics state by allowing the current state+-- to be saved and restored with the @gsave@ and @grestore@. +-- This is useful for modularity but is a comparatively expensive+-- procedure. --+-- When Wumpus renders Pictures as PostScript it maintains a +-- limited graphics state with just current colour and current +-- font. This is so Wumpus can avoid repeating @setrgbcolor@ and+-- @findfont@ operations in the generated PostScript if +-- subsequent elements share the same values.+-- +-- +--    --------------------------------------------------------------------------------  @@ -51,7 +77,12 @@  -- Graphics state datatypes -+-- | Stroke attributes are an algebriac type rather than a +-- record type. This is for convenience when attributing paths -+-- paths can be attibuted with just the differences from the +-- default settings, rather than all the settings whether or not+-- they are important.+-- data StrokeAttr = LineWidth   Double                 | MiterLimit  Double                 | LineCap     LineCap@@ -59,19 +90,36 @@                 | DashPattern DashPattern    deriving (Eq,Show) ++-- | Line cap - default in output is butt. data LineCap = CapButt | CapRound | CapSquare   deriving (Enum,Eq,Show) +-- | Line join - default in output is miter. data LineJoin = JoinMiter | JoinRound | JoinBevel   deriving (Enum,Eq,Show) -data DashPattern = Solid | Dash Int [Int]+-- | Dash pattern - either a solid line or a list of on-off pairs+-- together with an /offset/ into the dashes.+data DashPattern = Solid | Dash Int [(Int,Int)]   deriving (Eq,Show)  --- PostScript (or at least GhostScript) seems to require both--- attributes (name & size) are set at the same time.-+-- | Font name and size. Equivalent fonts have different names+-- in PostScript and SVG. A PostScript font name includes the +-- font style (e.g. @Times-BoldItalic@) whereas an SVG font has +-- a name (the @font-family@ attribute) and a style.+--+-- For PostScript, the following fonts are expected to exist on +-- most platforms:+--+-- > Times-Roman  Times-Italic  Times-Bold  Times-BoldOtalic+-- > Helvetica  Helvetica-Oblique  Helvetica-Bold  Helvetica-Bold-Oblique+-- > Courier  Courier-Oblique  Courier-Bold  Courier-Bold-Oblique+-- > Symbol+--+-- See the PostScript Language Reference Manual.+-- data FontAttr = FontAttr {                      font_name       :: String,        -- for PostScript                     svg_font_family :: String,        -- for SVG@@ -80,6 +128,8 @@                   }   deriving (Eq,Show) +-- | SVG font styles - potentially a style may generate both+-- @font-weight@ and @font-style@ attributes in the SVG output. data SVGFontStyle = SVG_REGULAR | SVG_BOLD | SVG_ITALIC | SVG_BOLD_ITALIC                   | SVG_OBLIQUE | SVG_BOLD_OBLIQUE   deriving (Eq,Show)@@ -140,7 +190,10 @@ -------------------------------------------------------------------------------- -- Conversion to CTM -+-- | Convert to the CTM. Wumpus offshores affine transformations +-- to PostScript as @concat@ commands. So frames and matrices +-- must support being represented as the CTM.+-- class ToCTM a where    toCTM :: u ~ DUnit a => a -> CTM u @@ -159,6 +212,7 @@ -------------------------------------------------------------------------------- -- Conversion to PSColour +-- | Convert to RGB [0,1] for PostScript rendering. class PSColour a where psColour :: a -> RGB3 Double  instance PSColour (RGB3 Double) where

@@ -4,18 +4,21 @@ -- | -- Module      :  Wumpus.Core.OutputPostScript -- Copyright   :  (c) Stephen Tetley 2009--- License     :  BSD-style (see LICENSE)+-- License     :  BSD3+-- -- Maintainer  :  stephen.tetley@gmail.com--- Stability   :  experimental--- Portability :  GHC only+-- Stability   :  unstable+-- Portability :  GHC with TypeFamilies and more --+-- Output PostScript - either PostScript (PS) files or +-- EPS (Encapusulated PostScript) files can be generated.  --+-- --------------------------------------------------------------------------------  module Wumpus.Core.OutputPostScript    (    -- * Output PostScript-  -- $fontdoc     writePS   , writeEPS   @@ -30,7 +33,8 @@ import Wumpus.Core.GraphicsState import Wumpus.Core.PictureInternal import Wumpus.Core.PostScript-import Wumpus.Core.TextEncoding+import Wumpus.Core.TextEncoder+import Wumpus.Core.TextEncodingInternal import Wumpus.Core.TextLatin1 import Wumpus.Core.Utils @@ -43,45 +47,22 @@   ----- $fontdoc------ The following fonts are expected to exist on most platforms:------ > Times-Roman  Times-Italic  Times-Bold  Times-Bolditalic--- > Helvetica  Helvetica-Oblique  Helvetica-Bold  Helvetica-Bold-Oblique--- > Courier  Courier-Oblique  Courier-Bold  Courier-Bold-Oblique--- > Symbol------ See the PostScript Language Reference Manual.---- type FontSpec = (String,Int)--- -------------------------------------------------------------------------------- -- Render to PostScript --- | Write a series of pictures to a Postscript file. Each +-- | Output a series of pictures to a Postscript file. Each  -- picture will be printed on a separate page.  ----- If the picture contains text labels, you should provide a --- FontSpec to transmit @findfont@, @scalefont@ etc. commands --- to PostScript.     writePS :: (Fractional u, Ord u, PSUnit u)          => FilePath -> TextEncoder -> [Picture u] -> IO () writePS filepath enc pic = do      timestamp <- mkTimeStamp     writeFile filepath $ psDraw timestamp enc pic --- | Write a picture to an EPS (Encapsulated PostScript) file. +-- | Output a picture to an EPS (Encapsulated PostScript) file.  -- The .eps file can then be imported or embedded in another  -- document. ----- If the picture contains text labels, you should provide a --- FontSpec to transmit @findfont@, @scalefont@ etc. commands --- to PostScript.     writeEPS :: (Fractional u, Ord u, PSUnit u)            => FilePath -> TextEncoder -> Picture u -> IO () writeEPS filepath enc pic = do@@ -101,10 +82,8 @@   ----+--------------------------------------------------------------------------------+-- Internals   -- | Draw a picture, generating PostScript output.@@ -133,9 +112,9 @@     --- Note the bounding box may have negative components - if it --- does it will need translating.-+-- | Note the bounding box may /below the origin/ - if it is, it +-- will need translating.+-- epsDraw :: (Fractional u, Ord u, PSUnit u)          => String -> TextEncoder -> Picture u -> PostScript epsDraw timestamp enc pic = runWumpus enc $ do @@ -349,7 +328,6 @@ outputLabel (Label (P2 x y) entxt) = do     ps_moveto x y     outputEncodedText entxt---    ps_show str  outputEncodedText :: EncodedText -> WumpusM ()  outputEncodedText = mapM_ outputTextChunk . getEncodedText

@@ -5,10 +5,11 @@ -- | -- Module      :  Wumpus.Core.OutputSVG -- Copyright   :  (c) Stephen Tetley 2009--- License     :  BSD-style (see LICENSE)+-- License     :  BSD3+-- -- Maintainer  :  stephen.tetley@gmail.com--- Stability   :  experimental--- Portability :  GHC only+-- Stability   :  unstable+-- Portability :  GHC with TypeFamilies and more -- -- Output SVG.  --@@ -44,7 +45,8 @@ import Wumpus.Core.GraphicsState import Wumpus.Core.PictureInternal import Wumpus.Core.SVG-import Wumpus.Core.TextEncoding+import Wumpus.Core.TextEncoder+import Wumpus.Core.TextEncodingInternal import Wumpus.Core.TextLatin1 import Wumpus.Core.Utils @@ -55,7 +57,6 @@ import Text.XML.Light  - type Clipped    = Bool  @@ -65,10 +66,12 @@  -------------------------------------------------------------------------------- +-- | Output a picture to a SVG file.  writeSVG :: (Ord u, PSUnit u) => FilePath -> TextEncoder -> Picture u -> IO () writeSVG filepath enc pic =      writeFile filepath $ unlines $ map ppContent $ svgDraw enc pic  +-- | Version of 'writeSVG' - using Latin1 encoding.  writeSVG_latin1 :: (Ord u, PSUnit u) => FilePath -> Picture u -> IO () writeSVG_latin1 filepath = writeSVG filepath latin1Encoder  @@ -252,8 +255,8 @@     dash Solid       = (:) (attr_stroke_dasharray_none)     dash (Dash _ []) = (:) (attr_stroke_dasharray_none)     dash (Dash i xs) = (:) (attr_stroke_dashoffset i) . -                       (:) (attr_stroke_dasharray xs)-   +                       (:) (attr_stroke_dasharray $ conv xs)+    conv = foldr (\(x,y) a -> x:y:a) []     svgPath :: PSUnit u => DrawPath -> Path u -> SvgPath

@@ -5,12 +5,14 @@ -- | -- Module      :  Wumpus.Core.Picture -- Copyright   :  (c) Stephen Tetley 2009--- License     :  BSD-style (see LICENSE)--- Maintainer  :  stephen.tetley@gmail.com--- Stability   :  experimental--- Portability :  GHC only+-- License     :  BSD3 --+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC with TypeFamilies and more --+-- Construction of pictures, paths and text labels.+--  --------------------------------------------------------------------------------  module Wumpus.Core.Picture @@ -60,7 +62,8 @@ import Wumpus.Core.Geometry import Wumpus.Core.GraphicsState import Wumpus.Core.PictureInternal-import Wumpus.Core.TextEncoding+import Wumpus.Core.PictureLanguage+import Wumpus.Core.TextEncodingInternal import Wumpus.Core.Utils  import Data.Semigroup@@ -79,25 +82,20 @@ stdFrame :: Num u => Frame2 u  stdFrame = ortho zeroPt ------------------------------------------------------------------------------------ OneList helper ---- | This module (Wumpus.Core.Picture) should be the only --- interface to the /outside world/ for creating - -------------------------------------------------------------------------------- -- Construction   --- | Create a blank picture sized to the supplied bounding box.+-- | Create a blank 'Picture' sized to the supplied bounding box. -- This is useful for spacing rows or columns of pictures.+-- blankPicture :: Num u => BoundingBox u -> Picture u blankPicture bb = PicBlank (stdFrame, bb)  --- | Lift a Primitive to a Picture, located in the standard frame.+-- | Lift a 'Primitive' to a 'Picture', located in the standard frame. frame :: (Fractional u, Ord u) => Primitive u -> Picture u frame p = Single (stdFrame, boundary p) p  @@ -122,17 +120,20 @@   --- | Lift a list of Primitives to a composite Picture, all --- Primitives will be located within the standard frame.--- The list of Primitives must be non-empty.+-- | Lift a list of primitives to a composite picture, all +-- primitives will be located within the standard frame. --+-- This function throws an error when supplied the empty list.+-- frameMulti :: (Fractional u, Ord u) => [Primitive u] -> Picture u frameMulti [] = error "Wumpus.Core.Picture.frameMulti - empty list" frameMulti xs = multi $ map frame xs  --- | Place multiple pictures within the same affine frame+-- | Place multiple pictures within the same affine frame.+-- -- This function throws an error when supplied the empty list.+-- multi :: (Fractional u, Ord u) => [Picture u] -> Picture u multi ps = Picture (stdFrame, sconcat $ map boundary ps) ones   where @@ -145,7 +146,8 @@   --- | Create a Path from the start point and alist of PathSegments.+-- | Create a Path from a start point and a list of +-- PathSegments. path :: Point2 u -> [PathSegment u] -> Path u path = Path  @@ -165,8 +167,6 @@ vertexPath (x:xs) = Path x (map PLine xs)  --- Not a paramorphism as you want to consume3 rather than --- look-ahead3...  -- | Convert a list of vertices to a path of curve segments. -- The first point in the list makes the start point, each curve @@ -195,6 +195,12 @@             => PSRgb -> [StrokeAttr] -> Path u -> Primitive u cstrokePath c attrs p = PPath (c, CStroke attrs) p +-- | Create a open, stroked path (@ostroke@) or a closed, stroked+-- path (@cstroke@).+--+-- @ostroke@ and @cstroke@ are overloaded to make attributing +-- the path more convenient.+--  class Stroke t where   ostroke :: (Num u, Ord u) => t -> Path u -> Primitive u   cstroke :: (Num u, Ord u) => t -> Path u -> Primitive u@@ -262,14 +268,18 @@   --- fills only have one property - colour--- Having a fill class seems uniform as we have a stroke class     fillPath :: (Num u, Ord u) => PSRgb -> Path u -> Primitive u fillPath c p = PPath (c,CFill) p +-- | Create a filled path (@fill@). Fills only have one +-- property - colour. But there are various representations of +-- colour.+--+-- @ fill () @ will fill with the default colour - black.+--  class Fill t where   fill :: (Num u, Ord u) => t -> Path u -> Primitive u  @@ -286,6 +296,7 @@ -------------------------------------------------------------------------------- -- Clipping  +-- | Clip a picture with respect to the supplied path. clip :: (Num u, Ord u) => Path u -> Picture u -> Picture u clip cp p = Clip (ortho zeroPt, boundary cp) cp p @@ -301,6 +312,16 @@ default_font :: FontAttr default_font = FontAttr "Courier" "Courier New" SVG_REGULAR 12 +-- | Create a text label. The string should not contain newline+-- or tab characters. Use 'multilabel' to create text with +-- multiple lines.+-- +-- @textlabel@ is overloaded to make attributing the label more +-- convenient.+--+-- Unless a 'FontAttr' is specified, the label will use 12pt +-- Courier.+-- class TextLabel t where    textlabel :: t -> Point2 u -> String -> Primitive u @@ -334,17 +355,25 @@ ztextlabel = mkTextLabel psBlack default_font  ---- (The implementation of this function needs attention).+-- | Create multiple lines of text. ---multilabel :: (Fractional u, Ord u) -           => [Label u] -> LabelProps -> BoundingBox u -> Picture u-multilabel ps props bb = -    Picture (stdFrame, bb) $ fromListErr err_msg -                           $ map frame-                           $ zipWith PLabel (repeat props) ps -  where -    err_msg = "Wumpus.Core.Picture.multilabel - empty list."+-- 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 :: (Fractional u, Ord u, TextLabel t) +           => t -> u -> VAlign -> Point2 u -> [String]-> Picture u+multilabel _    _ _  _  []     = error $ +    "Wumpus.Core.Picture.multilabel - empty list."+multilabel attr n va pt (x:xs) = +    moveAll $ vsepA va n line1 (map mkPic xs)+  where+    line1     = mkPic x+    mkPic     = frame . textlabel attr zeroPt+    vdelta p  = boundaryHeight (boundary p) - boundaryHeight (boundary line1)+    moveAll p = moveV (vdelta p) $ p `at` pt  -------------------------------------------------------------------------------- @@ -357,11 +386,22 @@ ellipseDefault = (psBlack, EFill)  --- | Instances will create a filled ellipse unless the supplied --- element /implies/ a stoked ellipse, e.g.:+-- | Create an ellipse, the ellipse will be filled unless the +-- supplied attributes /imply/ a stoked ellipse, e.g.: -- -- > ellipse (LineWidth 4) zeroPt 40 40 --- > ellipse EFill zeroPt 40 40  +--+-- Note - within Wumpus, ellipses are considered an unfortunate+-- but useful /optimization/. Drawing good cicles with Beziers +-- needs at least eight curves, but drawing them with +-- PostScript\'s @arc@ command is a single operation.  For +-- drawings with many dots (e.g. scatter plots) it seems sensible+-- to employ this optimaztion.+--+-- A deficiency of Wumpus\'s ellipse is that (non-uniformly)+-- scaling a stroked ellipse also (non-uniformly) scales the pen +-- it is drawn with. Where the ellipse is wider, the pen stroke +-- will be wider too.  -- class Ellipse t where   ellipse :: Fractional u => t -> Point2 u -> u -> u -> Primitive u

@@ -7,10 +7,11 @@ -- | -- Module      :  Wumpus.Core.PictureInternal -- Copyright   :  (c) Stephen Tetley 2009--- License     :  BSD-style (see LICENSE)+-- License     :  BSD3+-- -- Maintainer  :  stephen.tetley@gmail.com--- Stability   :  experimental--- Portability :  GHC only+-- Stability   :  unstable+-- Portability :  GHC with TypeFamilies and more -- -- Internal representation of Pictures  -- @@ -54,7 +55,7 @@ import Wumpus.Core.Geometry import Wumpus.Core.GraphicsState import Wumpus.Core.PictureLanguage hiding ( hcat, vcat, hsep, vsep )-import Wumpus.Core.TextEncoding+import Wumpus.Core.TextEncodingInternal import Wumpus.Core.Utils  import Data.Aviary@@ -374,7 +375,7 @@   move x y = movePic (V2 x y)  -instance Num u => Blank (Picture u) where+instance (Num u, Ord u) => Blank (Picture u) where   blank w h = PicBlank (ortho zeroPt, bbox zeroPt (P2 w h))  --------------------------------------------------------------------------------

@@ -6,19 +6,26 @@ -- | -- Module      :  Wumpus.Core.PictureLanguage -- Copyright   :  (c) Stephen Tetley 2009--- License     :  BSD-style (see LICENSE)+-- License     :  BSD3+-- -- Maintainer  :  stephen.tetley@gmail.com--- Stability   :  experimental--- Portability :  GHC only+-- Stability   :  unstable+-- Portability :  GHC with TypeFamilies and more ----- Picture language operations c.f. PPrint and --- Text.PrettyPrint.HughesPJ, but fully in two dimensions --- rather than horizontal + carriage return.+-- Type classes and derived functions to compose 2D /pictures/. --+-- The operations are fairly standard - see Regions in Paul +-- Hudak\'s \'The Haskell School of Expression' and the pretty+-- printing libraries wl-pprint and Text.PrettyPrint.HughesPJ +-- (pretty printing combinators are some ways in \'One and a +-- half D\' as they have horizontal operations but only carriage +-- return in the vertical.+-- --------------------------------------------------------------------------------  module Wumpus.Core.PictureLanguage    (+  -- * Data types for alignment      HAlign(..)   , VAlign(..) @@ -31,6 +38,7 @@   , Blank(..)    -- * Bounds+  -- $boundsdoc   , center   , topleft   , topright@@ -38,15 +46,16 @@   , bottomright    -- * Composition+  , ( -@- )   , ( ->- )   , ( -<- )   , ( -//- )-  , ( -\\- )+  , above+  , below   , at   , stackOnto   , hcat    , vcat-  , ( -@- )   , stackOntoCenter    , hspace@@ -64,7 +73,7 @@    ) where -import Wumpus.Core.Geometry ( Point2(..), Vec2(..) )+import Wumpus.Core.Geometry  import Data.AffineSpace @@ -76,10 +85,11 @@  -- 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) @@ -90,58 +100,89 @@ -- Type family and classes  --- The unit type of /points/ within a Picture.+-- | 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 -class Composite a where-  over    :: a -> a -> a-  beneath :: a -> a -> a -  beneath = flip over   --- Move in 2D+-- | Move in both the horizontal and vertical. class Move a where   move :: PUnit a -> PUnit a -> a -> a  -class Blank a where-  blank :: PUnit a -> PUnit 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@@ -167,53 +208,93 @@ -------------------------------------------------------------------------------- -- Composition -infixr 5 -//-+infixr 5 -//-, `above`, `below` infixr 6 ->-, -@-  --- | Center the pic1 on top of pic2.+-- | > 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 = p1 `over` (move x y p2) where V2 x y = center p1 .-. center p2+p1 -@- p2 = (move x y p1) `over` p2 where V2 x y = center p2 .-. center p1  --- | Horizontal composition - place @b@ at the right of @a@.+-- | > 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 = over a (moveH disp b) where disp = rightBound a - leftBound b +a ->- b = a `over` (moveH disp b) where disp = rightBound a - leftBound b  --- | Horizontal composition - place @a@ at the left of @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-(-<-) = flip (->-)   -- TO TEST...+a -<- b = (moveH disp a) `over` b where disp = leftBound b - rightBound a --- | Vertical composition - place @b@ below @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 = over a (moveV disp b) where disp = bottomBound a - topBound b +a -//- b = a `over` (moveV disp b) where disp = bottomBound a - topBound b  --- | Vertical composition - place @a@ above @b@.-(-\\-) :: (Vertical a, Composite a, Num u, u ~ PUnit a) => a -> a -> a-(-\\-) = flip (-//-) +-- | > 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  --- stackOnto :: [a] -> a -> a--- This would obviate the need for pempty without needing a --- non-empty list --- | Stack the pictures using 'over' - the first picture in the --- list is drawn at the top, last picture is on drawn at the --- bottom.+-- | > 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' (-//-)@@ -233,7 +314,7 @@  -------------------------------------------------------------------------------- -+-- Helpers blankH  :: (Num u, Blank a, u ~ PUnit a) => u -> a blankH = blank `flip` 0 @@ -241,8 +322,8 @@ blankV = blank 0  ---- | The following simple definition of hspace is invalid:+-- NOTE+-- The following simple definition of hspace is invalid: -- -- > hspace n a b = a ->- (moveH n b) -- @@ -252,18 +333,46 @@ -- 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+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)@@ -273,45 +382,85 @@ -- 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  -alignH :: ( Fractional u, Composite a, Horizontal a, Vertical a, Move a+-- 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-alignH HTop    p1 p2 = vecMove p1 p2 (topright p1    .-. topleft p2)-alignH HCenter p1 p2 = vecMove p1 p2 (rightmid p1    .-. leftmid p2)-alignH HBottom p1 p2 = vecMove p1 p2 (bottomright p1 .-. bottomleft p2)+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) -alignV :: ( Fractional u, Composite a, Horizontal a, Vertical a, Move a++-- 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-alignV VLeft   p1 p2 = vecMove p1 p2 (bottomleft p1  .-. topleft p2)-alignV VCenter p1 p2 = vecMove p1 p2 (bottommid p1   .-. topmid p2)-alignV VRight  p1 p2 = vecMove p1 p2 (bottomright p1 .-. topright p2)+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' (alignH ha)+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' (alignV va)-+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 = alignH ha (alignH ha a (blankH n)) b +   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 = alignV va (alignV va a (blankV n)) b +   a `op` b = moveAlignV va (moveAlignV va a (blankV n)) b  

@@ -10,11 +10,11 @@ -- Copyright   :  (c) Stephen Tetley 2009 -- License     :  BSD3 ----- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC with TypeFamilies and more ----- Wumpus - Writer Monad PostScript +-- PostScript generation via a Writer monad. -- -- PostScript is emitted line by line - there is no abstract -- syntax tree representing PostScript. So we use a writer @@ -89,7 +89,7 @@  import Wumpus.Core.Colour import Wumpus.Core.GraphicsState-import Wumpus.Core.TextEncoding+import Wumpus.Core.TextEncoder import Wumpus.Core.Utils ( PSUnit(..), roundup, parens, hsep )  import Data.Aviary@@ -332,8 +332,10 @@  -- | @ [... ...] ... setdash @ ps_setdash :: DashPattern -> WumpusM ()-ps_setdash Solid        = command "setdash" ["[]", "0"]-ps_setdash (Dash n arr) = command "setdash" [showArray shows arr, show n]+ps_setdash Solid          = command "setdash" ["[]", "0"]+ps_setdash (Dash n pairs) = command "setdash" [showArray shows arr, show n]+  where+    arr = foldr (\(x,y) a -> x:y:a) [] pairs  -- | @ ... setgray @ ps_setgray :: PSUnit u => u -> WumpusM ()

@@ -5,11 +5,14 @@ -- | -- Module      :  Wumpus.Core.SVG -- Copyright   :  (c) Stephen Tetley 2009--- License     :  BSD-style (see LICENSE)+-- License     :  BSD3+-- -- Maintainer  :  stephen.tetley@gmail.com--- Stability   :  experimental--- Portability :  GHC only+-- Stability   :  unstable+-- Portability :  GHC with TypeFamilies and more --+-- SVG generation.+-- -- SVG is represented using XML.Light. XML.Light is a simple, -- generic XML representation (almost) everything is an element  -- with attributes.@@ -100,7 +103,7 @@  import Wumpus.Core.Colour import Wumpus.Core.GraphicsState-import Wumpus.Core.TextEncoding+import Wumpus.Core.TextEncoder import Wumpus.Core.Utils  import Data.Aviary@@ -340,12 +343,12 @@  -- | @ stroke-width=\"...\" @ attr_stroke_width :: PSUnit u => u -> Attr-attr_stroke_width = unqualAttr "stoke-width" . dtrunc+attr_stroke_width = unqualAttr "stroke-width" . dtrunc   -- | @ stroke-miterlimit=\"...\" @ attr_stroke_miterlimit :: PSUnit u => u -> Attr-attr_stroke_miterlimit = unqualAttr "stoke-miterlimit" . dtrunc+attr_stroke_miterlimit = unqualAttr "stroke-miterlimit" . dtrunc  -- | @ stroke-linejoin=\"...\" @ attr_stroke_linejoin :: LineJoin -> Attr

@@ -0,0 +1,83 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.TextEncoder+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC with TypeFamilies and more+--+-- Extended character code handling.+-- +-- Wumpus uses SVG style escaping to embed character codes or +-- names in regular strings:+--+-- > "regular ascii text &#egrave; more ascii text"+--  +-- i.e. character names and codes are delimited by @&#@ on the +-- left and @;@ on the right.+--+-- In Wumpus strings both character names and character codes can+-- be embedded - it seems conventional for PostScript to use +-- names e.g.:  +--+-- > (myst) show /egrave glyphshow (re) show+-- +-- ... and SVG to use codes, e.g.: +--+-- > mystère+--+-- To accommodate both Wumpus defines a TextEncoder record which +-- provides a two-way mapping between character codes and glyph +-- names for a character set.+--+--------------------------------------------------------------------------------++module Wumpus.Core.TextEncoder+  ( +    GlyphName+  , CharCode+  , PostScriptLookup+  , SVGLookup+  , TextEncoder(..)++  ) where+++import Data.Char++type GlyphName = String+type CharCode  = Int ++type PostScriptLookup = CharCode -> Maybe GlyphName+type SVGLookup        = GlyphName -> Maybe CharCode+++-- | A TextEncoder+--+-- An /instance/ needs: +--+-- * The functions for looking up codes by glyph-name and +-- glyph-name by code. +-- +-- * The name of the encoding - this is printed in the xml +-- prologue of the SVG file as the @encoding@ attribute. Latin +-- 1\'s official name is \"ISO-8859-1\". +-- +-- * Fallback glyph-names and char codes in case lookup fails.+-- +-- "Wumpus.Core.TextLatin1" defines an implementation for Latin 1.+--+data TextEncoder = TextEncoder  {+                       ps_lookup         :: PostScriptLookup,+                       svg_lookup        :: SVGLookup,+                       svg_encoding_name :: String,+                       ps_fallback       :: GlyphName,+                       svg_fallback      :: CharCode+                     }+                     ++-- no show instance as a TextEncoder contains functions.

@@ -1,119 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Core.TextEncoding--- Copyright   :  (c) Stephen Tetley 2009--- License     :  BSD-style (see LICENSE)--- Maintainer  :  stephen.tetley@gmail.com--- Stability   :  experimental--- Portability :  GHC only------ Extended character handling...--- -----------------------------------------------------------------------------------module Wumpus.Core.TextEncoding-  ( -    GlyphName-  , CharCode-  , PostScriptLookup-  , SVGLookup-  , TextEncoder(..)--  , EncodedText(..)    -  , TextChunk(..)--  , textLength-  , lookupByCharCode  -  , lookupByGlyphName--  , lexLabel--  ) where--import Text.PrettyPrint.Leijen hiding ( SText )--import Data.Char--type GlyphName = String-type CharCode  = Int --type PostScriptLookup = CharCode -> Maybe GlyphName-type SVGLookup        = GlyphName -> Maybe CharCode--data TextEncoder = TextEncoder  {-                       ps_lookup         :: PostScriptLookup,-                       svg_lookup        :: SVGLookup,-                       svg_encoding_name :: String,-                       ps_fallback       :: GlyphName,-                       svg_fallback      :: CharCode-                     }-                     ---newtype EncodedText = EncodedText { getEncodedText :: [TextChunk] }-  deriving (Eq,Show)---data TextChunk = SText  String-               | EscInt Int-               | EscStr GlyphName-  deriving (Eq,Show)-------------------------------------------------------------------------------------instance Pretty EncodedText where-  pretty = hcat . map pretty . getEncodedText--instance Pretty TextChunk where-  pretty (SText s)   = string s-  pretty (EscInt i)  = text "&#" <> int i  <> semi-  pretty (EscStr s)  = text "&#" <> text s <> semi------------------------------------------------------------------------------------textLength :: EncodedText -> Int-textLength = foldr add 0 . getEncodedText where -    add (SText s) n = n + length s-    add _         n = n + 1---lookupByCharCode :: CharCode -> TextEncoder -> Maybe GlyphName-lookupByCharCode i enc = (ps_lookup enc) i--lookupByGlyphName :: GlyphName -> TextEncoder -> Maybe CharCode-lookupByGlyphName i enc = (svg_lookup enc) i----- | Output to PostScript as @ /egrave glyphshow @---- Output to SVG as an escaped decimal, e.g. @ &#232; @------ Note, HTML entity names do not seem to be supported in SVG,--- @ &egrave; @ does not work in FireFox or Chrome.---lexLabel :: String -> EncodedText-lexLabel = EncodedText . lexer--lexer :: String -> [TextChunk]-lexer []            = []--lexer ('&':'#':xs)  = esc xs-  where-    esc (c:cs) | isDigit c = let (s,cs') = span isDigit cs -                             in  intval (c:s) cs'-               | otherwise = let (s,cs') = span isAlpha cs -                             in EscStr (c:s) : optsemi cs'-    esc []                 = []--    optsemi (';':cs)   = lexer cs      -- let ill-formed go through-    optsemi cs         = lexer cs--    intval [] rest  = optsemi rest-    intval cs rest  = EscInt (read cs) : optsemi rest--lexer (x:xs)        = let (s,xs') = span (/= '&') xs -                      in SText (x:s) : lexer xs'

@@ -0,0 +1,101 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.TextEncodingInternal+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC with TypeFamilies and more+--+-- Extended character handling...+-- +--------------------------------------------------------------------------------++module Wumpus.Core.TextEncodingInternal+  ( ++    EncodedText(..)    +  , TextChunk(..)++  , textLength+  , lookupByCharCode  +  , lookupByGlyphName++  , lexLabel++  ) where++import Wumpus.Core.TextEncoder++import Text.PrettyPrint.Leijen hiding ( SText )++import Data.Char++newtype EncodedText = EncodedText { getEncodedText :: [TextChunk] }+  deriving (Eq,Show)+++data TextChunk = SText  String+               | EscInt Int+               | EscStr GlyphName+  deriving (Eq,Show)+++--------------------------------------------------------------------------------++instance Pretty EncodedText where+  pretty = hcat . map pretty . getEncodedText++instance Pretty TextChunk where+  pretty (SText s)   = string s+  pretty (EscInt i)  = text "&#" <> int i  <> semi+  pretty (EscStr s)  = text "&#" <> text s <> semi++--------------------------------------------------------------------------------++textLength :: EncodedText -> Int+textLength = foldr add 0 . getEncodedText where +    add (SText s) n = n + length s+    add _         n = n + 1+++lookupByCharCode :: CharCode -> TextEncoder -> Maybe GlyphName+lookupByCharCode i enc = (ps_lookup enc) i++lookupByGlyphName :: GlyphName -> TextEncoder -> Maybe CharCode+lookupByGlyphName i enc = (svg_lookup enc) i+++-- | Output to PostScript as @ /egrave glyphshow @++-- Output to SVG as an escaped decimal, e.g. @ &#232; @+--+-- Note, HTML entity names do not seem to be supported in SVG,+-- @ &egrave; @ does not work in FireFox or Chrome.+++lexLabel :: String -> EncodedText+lexLabel = EncodedText . lexer++lexer :: String -> [TextChunk]+lexer []            = []++lexer ('&':'#':xs)  = esc xs+  where+    esc (c:cs) | isDigit c = let (s,cs') = span isDigit cs +                             in  intval (c:s) cs'+               | otherwise = let (s,cs') = span isAlpha cs +                             in EscStr (c:s) : optsemi cs'+    esc []                 = []++    optsemi (';':cs)   = lexer cs      -- let ill-formed go through+    optsemi cs         = lexer cs++    intval [] rest  = optsemi rest+    intval cs rest  = EscInt (read cs) : optsemi rest++lexer (x:xs)        = let (s,xs') = span (/= '&') xs +                      in SText (x:s) : lexer xs'

@@ -4,12 +4,13 @@ -- | -- Module      :  Wumpus.Core.TextLatin1 -- Copyright   :  (c) Stephen Tetley 2009--- License     :  BSD-style (see LICENSE)+-- License     :  BSD3+-- -- Maintainer  :  stephen.tetley@gmail.com--- Stability   :  experimental--- Portability :  GHC only+-- Stability   :  unstable+-- Portability :  GHC with TypeFamilies and more ----- Extended character handling...+-- A TextEncoder record instance for Latin1 characters. --  -------------------------------------------------------------------------------- @@ -24,13 +25,14 @@    ) where -import Wumpus.Core.TextEncoding+import Wumpus.Core.TextEncoder  import qualified Data.Map as Map  type Latin1Name = String type Latin1ISOCode = Int +-- | Latin1 TextEncoder instance. latin1Encoder :: TextEncoder latin1Encoder = TextEncoder {     ps_lookup         = Map.lookup `flip` codeToName,@@ -46,6 +48,7 @@ codeToName = foldr fn Map.empty latin1All where   fn (s,i) a = Map.insert i s a  +-- | A lookup list of Latin 1 names to their octal code. latin1All :: [(Latin1Name, Latin1ISOCode)] latin1All = [ ("A",                     0o101)             , ("AE",                    0o306)

@@ -11,7 +11,7 @@ -- Stability   :  highly unstable -- Portability :  GHC ----- Utility functions+-- Utility functions and a OneList (non-empty list) data type. -- -------------------------------------------------------------------------------- 

@@ -1,5 +1,5 @@ name:             wumpus-core-version:          0.12.0+version:          0.13.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -13,8 +13,8 @@   Wumpus is a library for generating 2D vector pictures, its    salient feature is portability due to no FFI dependencies.    It can generate PostScript (EPS) files and SVG files. The -  generated PostScript code is quite efficient (no unnecessary -  stack operations) and plain [1].+  generated PostScript code is plain [1] and quite efficient +  (no unnecessary stack operations).   .   Pictures in Wumpus are made from /paths/ and text /labels/.    Paths themselves are made from points. The usual affine @@ -30,40 +30,68 @@   For actually drawing pictures, diagrams, etc. Wumpus is very    low level. I am working on a complementary package    @wumpus-extra@ with higher-level stuff (polygons, arrows etc.)-  but it is far too unstable for Hackage. Preview releases can be-  found at http://code.google.com/p/copperbox/ though.+  but it is too unstable for Hackage. Preview releases can be+  found at <http://code.google.com/p/copperbox/> though.   .-  Wumpus-core should be fairly stable from now on, except for-  the fact that more modules are exposed than strictly necessary-  this is so their Haddock docs are available. Client\'s should -  only import the @Wumpus.Core@ module. There may be some name -  changes etc. that will change interfaces, but Wumpus has -  been carefully implemented. Some of the design decisions are-  not sophisticated (e.g. how attributes like colour are handled, -  and the bounding boxes of text labels are calculated), so-  Wumpus might be limited compared to other systems but its -  design permits a simple implementation - which is a priority. -  Text encoding is the exception, the current implementation -  appears reasonable for Latin 1 but I\'m not sure about other -  character sets, and I might have to revise it significantly.+  Wumpus-core should be fairly stable from now on. There may be +  some name changes etc. that will change interfaces, but Wumpus +  has been carefully implemented. Some of the design decisions +  are not sophisticated (e.g. how attributes like colour are +  handled, and the bounding boxes of text labels are calculated), +  so Wumpus might be limited compared to other systems. However +  its design permits a simple implementation - which is a +  priority. Text encoding an exception, I\'m not sure how +  reasonable the design is. The current implementation appears +  okay for Latin 1 but I\'m not sure about other character sets, +  and I may have to revise it significantly.   .   /There is no documentation/ - the graphics model used by    Wumpus is different to PostScript or SVG, and Wumpus really    needs a manual. Unfortunately there isn\'t one yet, and I will -  be focusing on @wumpus-extra@ for the foreseeable future so a+  be focusing on @wumpus-extra@ for the foreseeable future; so a   manual won\'t be written soon. If you want FFI-free vector   graphics and Wumpus seems to otherwise fit the task, please    email me and I will try to help.   .   \[1\] Because the output is simple, straight-line PostScript -  code it is possible to use GraphicsMagick or similar tools to +  code, it is possible to use GraphicsMagick or a similar tool to    convert Wumpus'\s EPS files to many other formats (bitmaps). - +  .+  Changelog:+  .+  0.12.0 to 0.13.0:+  .+  * More Haddock documenting. +  .+  * @lowerLeftUpperRight@ removed from "Wumpus.Core.BoundingBox".+  .+  * Added range checking and Ord obligation to the @bbox@ +    \'smart\' constructor.+  .+  * Numeric instances for "Wumpus.Core.Colour" improved.+  .+  * MatrixMult type class simplified+  .+  * Dash Pattern made a list of on-off pairs rather than just a +    list +  .+  * The modules - Wumpus.Core.PictureInternal, Wumpus.Core.PostScript,+    Wumpus.Core.SVG & Wumpus.Core.Utils - are no longer exposed.+  .+  * Various operators in "Wumpus.Core.PictureLanguage" changed.+  .+  * Wumpus.Core.TextEncoding split into an internal and a public +    module (internal - Wumpus.Core.TextEncodingInternal, public - +    Wumpus.Core.TextEncoder).++  . build-type:         Simple stability:          highly unstable cabal-version:      >= 1.2  extra-source-files:+  CHANGES,+  LICENSE,   demo/LabelPic.hs,   demo/Picture.hs @@ -86,14 +114,16 @@     Wumpus.Core.OutputPostScript,     Wumpus.Core.OutputSVG,     Wumpus.Core.Picture,-    Wumpus.Core.PictureInternal,     Wumpus.Core.PictureLanguage,+    Wumpus.Core.TextEncoder,+    Wumpus.Core.TextLatin1++  other-modules:+    Wumpus.Core.PictureInternal,     Wumpus.Core.PostScript,     Wumpus.Core.SVG,-    Wumpus.Core.TextEncoding,-    Wumpus.Core.TextLatin1,+    Wumpus.Core.TextEncodingInternal,     Wumpus.Core.Utils-  other-modules:        extensions: