packages feed

wumpus-core (empty) → 0.12.0

raw patch · 22 files changed

+5522/−0 lines, 22 filesdep +algebradep +basedep +containerssetup-changed

Dependencies added: algebra, base, containers, data-aviary, dlist, monadLib, old-time, vector-space, wl-pprint, xml

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2008 Stephen Peter Tetley++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runhaskell++import Distribution.Simple+main = defaultMain
+ demo/LabelPic.hs view
@@ -0,0 +1,145 @@+{-# OPTIONS -Wall #-}++module LabelPic where++import Wumpus.Core+++--------------------------------------------------------------------------------++++drawBounds :: (Fractional u, Ord u) => Picture u -> Picture u+drawBounds p        = p `over` (frame $ cstroke () ph) where+    ph   = vertexPath $ corners $ boundary p++--------------------------------------------------------------------------------+++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 ++++lbl1 :: Picture Double+lbl1 = line1 -//- line2 where+  line1 = frame (textlabel attrs zeroPt "Hello")+  line2 = frame (textlabel attrs zeroPt "World")+  attrs = (peru, FontAttr "Helvetica" "Helvetica" SVG_REGULAR 12) +++demo01 :: IO ()+demo01 = do +    writeEPS_latin1 "./out/label01.eps" lbl1+    writeSVG_latin1 "./out/label01.svg" lbl1++demo02 :: IO ()+demo02 = do +    writeEPS_latin1 "./out/label02.eps" p1+    writeSVG_latin1 "./out/label02.svg" p1+  where+    p1 = lbl1 ->- lbl1 ->- (rotateAbout (pi/4) (center lbl1) lbl1) ->- lbl1++demo03 :: IO ()+demo03 = do +    writeEPS_latin1 "./out/label03.eps" p1+    writeSVG_latin1 "./out/label03.svg" p1+  where+    p1 = (drawBounds lbl1) ->- +         (drawBounds lbl1) ->- +         (drawBounds $ rotateAbout (pi/4) (center lbl1) lbl1) ->- +         (drawBounds lbl1)++++demo04 :: IO ()+demo04 = do+    writeEPS_latin1 "./out/label04.eps" p1+    writeSVG_latin1 "./out/label04.svg" p1+  where+    p1 =        (drawBounds lbl1) +         `over` (drawBounds $ scale 2 2 lbl1)+         `over` (drawBounds $ scale 3 3 lbl1)+++++bigA, bigB, bigT :: Picture Double+bigA = bigLetter black 'A'+bigB = bigLetter peru  'B'+bigT = bigLetter plum  'T'++bigLetter :: PSRgb -> Char -> Picture Double+bigLetter col ch = uniformScale 5 $ frame $ textlabel attrs zeroPt [ch]+  where+    attrs = (col, FontAttr "Helvetica" "Helvetica" SVG_REGULAR 12) +++-- | A should be above B, above T+demo05 :: IO ()+demo05 = do +    writeEPS_latin1 "./out/label05.eps" p1+    writeSVG_latin1 "./out/label05.svg" p1+  where+    p1 = uniformScale 10 $ stackOntoCenter [bigA, bigB] bigT+++demo06 :: IO ()+demo06 = do +    writeEPS_latin1 "./out/label06.eps" p1+    writeSVG_latin1 "./out/label06.svg" p1+  where+    p1 = hsep 20 (fn 'a') (map fn "abcdefg")+    fn = drawBounds . bigLetter peru+++demo07 :: IO ()+demo07 = do +    writeEPS_latin1 "./out/label07.eps" p1+    writeSVG_latin1 "./out/label07.svg" p1+  where+    p1 = pA ->- pB ->- pC ->- pA+    +    pA = drawBounds bigA+    pB = drawBounds $ uniformScale 2 bigB+    pC = drawBounds $ move 0 10 $ bigLetter peru 'C'+++demo08 :: IO ()+demo08 = do +    writeEPS_latin1 "./out/label08.eps" p1+    writeSVG_latin1 "./out/label08.svg" p1+  where+    p1 = hcat pA [pA, pB, pC]+    +    pA = drawBounds bigA+    pB = drawBounds $ uniformScale 2 bigB+    pC = drawBounds $ move 0 10 $ bigLetter peru 'C'++demo09 :: IO ()+demo09 = do +    writeEPS_latin1 "./out/label09.eps" p1+    writeSVG_latin1 "./out/label09.svg" p1+  where+    p1 = (bigA -//- bigB) ->- (bigA -\\- bigB) +    +demo10 :: IO ()+demo10 = do +    writeEPS_latin1 "./out/label10.eps" p1+    writeSVG_latin1 "./out/label10.svg" p1+  where+    p1 :: Picture Double+    p1 = frame $ textlabel () zeroPt "myst&#egrave;re"+++main :: IO ()+main = sequence_+  [ demo01, demo02, demo03, demo04, demo05+  , demo06, demo07, demo08, demo09, demo10+  ]
+ demo/Picture.hs view
@@ -0,0 +1,133 @@+{-# OPTIONS -Wall #-}++module Picture where++import Wumpus.Core++++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 -> DPicture +mkFilledSquare col = frame $ fill col $ vertexPath+  [ P2 0 0, P2 40 0, P2 40 40, P2 0 40 ]+++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 +    s2 = uniformScale 1.75 $ mkFilledSquare peru+    s3 = scale 3 1.5       $ mkFilledSquare black+    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 +    s2 = uniformScale 1.75 $ mkFilledSquare peru+    s3 = scale 3 1.5       $ mkFilledSquare black+ +++main :: IO ()+main = sequence_+  [ demo01, demo02, demo03, demo04, demo05+  , demo06, demo07, demo08, demo09, demo10+  ]
+ src/Wumpus/Core.hs view
@@ -0,0 +1,67 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Common interface to Wumpus.Core...+-- +-- +--------------------------------------------------------------------------------+++module Wumpus.Core+  (+    module Wumpus.Core.AffineTrans +  , module Wumpus.Core.BoundingBox+  , module Wumpus.Core.Colour+  , module Wumpus.Core.FontSize+  , module Wumpus.Core.Geometry+  , module Wumpus.Core.GraphicsState+  , module Wumpus.Core.OutputPostScript+  , module Wumpus.Core.OutputSVG+  , module Wumpus.Core.Picture+  , module Wumpus.Core.PictureLanguage+  , module Wumpus.Core.TextEncoding++  -- Export from Picture Internal+  , Picture+  , DPicture+  , Primitive+  , DPrimitive+  , Path+  , DPath+  , PathSegment+  , DPathSegment+  , Label+  , DLabel++  , PathProps                   -- Better hidden?+  , LabelProps                  --      "+  , EllipseProps                --      "+  , DrawPath                    --      "+  , DrawEllipse                 --      "++  ) where++import Wumpus.Core.AffineTrans+import Wumpus.Core.BoundingBox+import Wumpus.Core.Colour hiding ( black, white, red, green, blue )+import Wumpus.Core.FontSize+import Wumpus.Core.Geometry+import Wumpus.Core.GraphicsState+import Wumpus.Core.OutputPostScript+import Wumpus.Core.OutputSVG+import Wumpus.Core.Picture+import Wumpus.Core.PictureInternal+import Wumpus.Core.PictureLanguage+import Wumpus.Core.TextEncoding+++
+ src/Wumpus/Core/AffineTrans.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# OPTIONS -Wall #-}++------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.AffineTrans+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  experimental+-- Portability :  GHC only+--+-- Affine transformations+--------------------------------------------------------------------------------++module Wumpus.Core.AffineTrans+  ( +  -- * Type classes+    Rotate(..)+  , RotateAbout(..)+  , Scale(..)+  , Translate(..)++  -- * Common rotations+  , rotate30+  , rotate30About+  , rotate45+  , rotate45About+  , rotate60+  , rotate60About+  , rotate90+  , rotate90About+  , rotate120+  , rotate120About+  +  -- * Common scalings+  , uniformScale+  , reflectX+  , reflectY++  -- * Translate by a vector+  , translateBy+  +  -- * Reflections in supplied plane rather than about the origin+  , reflectXPlane+  , reflectYPlane   ++  ) where++import Wumpus.Core.Geometry++++--------------------------------------------------------------------------------+-- Affine transformations +++-- Rotate++class Rotate t where+  rotate :: Radian -> t -> t+++instance (Floating a, Real a) => Rotate (Point2 a) where+  rotate a = ((rotationMatrix a) *#)++instance (Floating a, Real a) => Rotate (Vec2 a) where+  rotate a = ((rotationMatrix a) *#)++-- Rotate about++class RotateAbout t where+  rotateAbout :: Radian -> Point2 (DUnit t) -> t -> t +++instance (Floating a, Real a) => RotateAbout (Point2 a) where+  rotateAbout a pt = ((originatedRotationMatrix a pt) *#) +++instance (Floating a, Real a) => RotateAbout (Vec2 a) where+  rotateAbout a pt = ((originatedRotationMatrix a pt) *#) +  +--------------------------------------------------------------------------------+-- Scale++class Scale t where+  scale :: DUnit t -> DUnit t -> t -> t++instance Num u => Scale (Point2 u) where+  scale x y = ((scalingMatrix x y) *#) ++instance Num u => Scale (Vec2 u) where+  scale x y = ((scalingMatrix x y) *#) ++--------------------------------------------------------------------------------+-- Translate++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) *#)++instance Num u => Translate (Vec2 u) where+  translate x y = ((translationMatrix x y) *#)+++-------------------------------------------------------------------------------- +-- Common rotations+++++rotate30 :: Rotate t => t -> t +rotate30 = rotate (pi/6) ++rotate30About :: (RotateAbout t, DUnit t ~ u) => Point2 u -> t -> t +rotate30About = rotateAbout (pi/6)+++rotate45 :: Rotate t => t -> t +rotate45 = rotate (pi/4) ++rotate45About :: (RotateAbout t, DUnit t ~ u) => Point2 u -> t -> t +rotate45About = rotateAbout (pi/4)+++rotate60 :: Rotate t => t -> t +rotate60 = rotate (2*pi/3) ++rotate60About :: (RotateAbout t, DUnit t ~ u) => Point2 u -> t -> t +rotate60About = rotateAbout (2*pi/3)++rotate90 :: Rotate t => t -> t +rotate90 = rotate (pi/2) ++rotate90About :: (RotateAbout t, DUnit t ~ u) => Point2 u -> t -> t +rotate90About = rotateAbout (pi/2)+++rotate120 :: Rotate t => t -> t +rotate120 = rotate (4*pi/3) ++rotate120About :: (RotateAbout t, DUnit t ~ u) => Point2 u -> t -> t +rotate120About = rotateAbout (4*pi/3)++++--------------------------------------------------------------------------------+-- Common scalings++uniformScale :: (Scale t, DUnit t ~ u) => u -> t -> t +uniformScale a = scale a a +++reflectX :: (Num u, Scale t, DUnit t ~ u) => t -> t+reflectX = scale (-1) 1++reflectY :: (Num u, Scale t, DUnit t ~ u) => t -> t+reflectY = scale 1 (-1)++--------------------------------------------------------------------------------+-- translations++translateBy :: (Translate t, DUnit t ~ u) => Vec2 u -> t -> t +translateBy (V2 x y) = translate x y+++--------------------------------------------------------------------------------+-- Translation and scaling++-- | Reflect in the X plane that intersects the supplied point. +reflectXPlane :: (Num u, Scale t, Translate t, u ~ DUnit t) +              => Point2 u -> t -> t+reflectXPlane (P2 x y) = translate x y . scale (-1) 1 . translate (-x) (-y)++-- | Reflect in the Y plane that intersects the supplied point.+reflectYPlane :: (Num u, Scale t, Translate t, u ~ DUnit t) +              => Point2 u -> t -> t+reflectYPlane (P2 x y) = translate x y . scale 1 (-1) . translate (-x) (-y)
+ src/Wumpus/Core/BoundingBox.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.BoundingBox+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  experimental+-- Portability :  GHC only+--+-- Bounding box with no notion of \'empty\'.+--+--------------------------------------------------------------------------------++module Wumpus.Core.BoundingBox +  ( +  -- * Types+    BoundingBox(..)+  , DBoundingBox+  , CardinalPoint(..)++  -- * Type class+  , Boundary(..)+  +  -- * Operations+  , bbox+  , obbox+  , union +  , trace+  , corners+  , lowerLeftUpperRight+  , withinBB+  , boundaryWidth+  , boundaryHeight+  , boundaryBottomLeft+  , boundaryTopRight+  , boundaryTopLeft+  , boundaryBottomRight+  , boundaryPoint+  , leftPlane+  , rightPlane+  , lowerPlane+  , upperPlane++  ) where++import Wumpus.Core.AffineTrans+import Wumpus.Core.Geometry+import Wumpus.Core.Utils ( CMinMax(..), within )++import Data.Semigroup++import Text.PrettyPrint.Leijen hiding ( width )++++-- | Bounding box of a picture.+-- +-- We cannot construct empty pictures - so bounding boxes too a +-- saved the obligation to be empty.+-- +data BoundingBox a = BBox { +                         ll_corner :: Point2 a, +                         ur_corner :: Point2 a +                       }+  deriving (Eq,Show)++type DBoundingBox = BoundingBox Double++data CardinalPoint = C | N | NE | E | SE | S | SW | W | NW+  deriving (Eq,Show)+++--------------------------------------------------------------------------------+-- instances++-- BBox is NOT monoidal - it\'s much simpler that way.++instance Ord a => Semigroup (BoundingBox a) where+  append = union+++instance Pretty a => Pretty (BoundingBox a) where+  pretty (BBox p0 p1) = text "|_" <+> pretty p0 <+> pretty p1 <+> text "_|" +++--------------------------------------------------------------------------------+-- ++type instance DUnit (BoundingBox u) = u++instance (Num u, Ord u) => Scale (BoundingBox u) where+  scale x y bb     = trace $ map (scale x y) $ corners bb++++--------------------------------------------------------------------------------+-- Boundary class++class Boundary a where+  boundary :: a -> BoundingBox (DUnit a)+++--------------------------------------------------------------------------------+++instance Pointwise (BoundingBox a) where+  type Pt (BoundingBox a) = Point2 a+  pointwise f (BBox bl tr) = BBox (f bl) (f tr)+++--------------------------------------------------------------------------------++bbox :: Point2 a -> Point2 a -> BoundingBox a+bbox = BBox +++-- | Create a BoundingBox with bottom left corner at the origin,+-- and dimensions @w@ and @h@.+obbox :: Num a => a -> a -> BoundingBox a+obbox w h = BBox zeroPt (P2 w h)+++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 :: (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"+++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)++++withinBB :: Ord a => Point2 a -> BoundingBox a -> Bool+withinBB p (BBox ll ur) = within p ll ur+++boundaryWidth :: Num a => BoundingBox a -> a+boundaryWidth (BBox (P2 xmin _) (P2 xmax _)) = xmax - xmin++boundaryHeight :: Num a => BoundingBox a -> a+boundaryHeight (BBox (P2 _ ymin) (P2 _ ymax)) = ymax - ymin+++--------------------------------------------------------------------------------++-- Points on the boundary+++boundaryBottomLeft  :: BoundingBox a -> Point2 a+boundaryBottomLeft (BBox p0 _ ) = p0++boundaryTopRight :: BoundingBox a -> Point2 a+boundaryTopRight (BBox _ p1) = p1++boundaryTopLeft :: BoundingBox a -> Point2 a+boundaryTopLeft (BBox (P2 x _) (P2 _ y)) = P2 x y++boundaryBottomRight :: BoundingBox a -> Point2 a+boundaryBottomRight (BBox (P2 _ y) (P2 x _)) = P2 x y+++boundaryPoint :: Fractional a +              => CardinalPoint -> BoundingBox a -> Point2 a+boundaryPoint loc (BBox (P2 x0 y0) (P2 x1 y1)) = fn loc where+  fn C      = P2 xMid   yMid+  fn N      = P2 xMid   y1+  fn NE     = P2 x1     y1+  fn E      = P2 x1     yMid+  fn SE     = P2 x1     y0+  fn S      = P2 xMid   y0+  fn SW     = P2 x0     y0+  fn W      = P2 x0     yMid+  fn NW     = P2 x0     y1       ++  xMid      = x0 + 0.5 * (x1 - x0)+  yMid      = y0 + 0.5 * (y1 - y0)+++--------------------------------------------------------------------------------++-- /planes/ on the bounding box++-- Are these really worthwhile ? ...++leftPlane :: BoundingBox a -> a+leftPlane (BBox (P2 l _) _) = l++rightPlane :: BoundingBox a -> a+rightPlane (BBox _ (P2 r _)) = r++lowerPlane :: BoundingBox a -> a+lowerPlane (BBox (P2 _ l) _) = l++upperPlane :: BoundingBox a -> a+upperPlane (BBox _ (P2 _ u)) = u++++++
+ src/Wumpus/Core/Colour.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.Colour+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- RGB, HSB, Gray colour types.+--+--------------------------------------------------------------------------------+++module Wumpus.Core.Colour +  (+  -- * Colour types+    RGB3(..)+  , DRGB+  , HSB3(..)+  , DHSB+  , Gray(..)+  , DGray++  -- * Operations+  , rgb2hsb+  , hsb2rgb++  , rgb2gray+  , gray2rgb++  , hsb2gray+  , gray2hsb+  +  -- * Predefined colours+  , black+  , white+  , red+  , green+  , blue++  ) where++import Wumpus.Core.Utils+++import Data.VectorSpace++-- | Red-Green-Blue - no alpha.+data RGB3 a = RGB3 !a !a !a+  deriving (Eq,Show)++-- | RGB representated by Double - values should be in the range+-- 0.0 to 1.0. +-- +-- 1.0 represents full saturation, for instance red is +-- 1.0, 0.0, 0.0.+type DRGB = RGB3 Double+++-- | Hue-Saturation-Brightness.+data HSB3 a = HSB3 !a !a !a +  deriving (Eq,Show)++-- | HSB represented by Double - values should be in the range+-- 0.0 to 1.0.+type DHSB = HSB3 Double +++newtype Gray a = Gray a+  deriving (Eq,Num,Ord,Show)++-- | Gray represented by a Double - values should be in the range+-- 0.0 (black) to 1.0 (white).+type DGray = Gray Double+++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)+  (*) (RGB3 a b c) (RGB3 x y z) = RGB3 (a*x) (b*y) (c*z)+  abs (RGB3 a b c)            = RGB3 (abs a) (abs b) (abs c)+  negate (RGB3 a b c)         = RGB3 (negate a) (negate b) (negate c)+  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)+  (*) (HSB3 a b c) (HSB3 x y z) = HSB3 (a*x) (b*y) (c*z)+  abs (HSB3 a b c)            = HSB3 (abs a) (abs b) (abs c)+  negate (HSB3 a b c)         = HSB3 (negate a) (negate b) (negate c)+  signum (HSB3 a b c)         = HSB3 (signum a) (signum b) (signum c)+  fromInteger i = HSB3 (fromInteger i) (fromInteger i) (fromInteger i)++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)+++ +instance Num a => AdditiveGroup (HSB3 a) where+  zeroV = HSB3 0 0 0+  (^+^) = (+)+  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)++--------------------------------------------------------------------------------+-- Operations+++vE :: DRGB+vE = RGB3 1 1 1++-- Acknowledgment - the conversion functions are derived from+-- the documentation to Dr. Uwe Kern's xcolor LaTeX package++++rgb2hsb :: DRGB -> DHSB+rgb2hsb (RGB3 r g b) = HSB3 hue sat bri+  where+    x     = max3 r g b+    y     = med3 r g b+    z     = min3 r g b++    bri   = x++    (sat,hue) = if x==z then (0,0) else ((x-z)/x, f $ (x-y)/(x-z))+    +    f n | r >= g && g >= b    = (1/6) * (1-n) +        | g >= r && r >= b    = (1/6) * (1+n)+        | g >= b && b >= r    = (1/6) * (3-n)+        | b >= g && g >= r    = (1/6) * (3+n)+        | b >= r && r >= g    = (1/6) * (5-n)+        | otherwise           = (1/6) * (5+n)++++hsb2rgb :: DHSB -> DRGB+hsb2rgb (HSB3 hue sat bri) = bri *^ (vE - (sat *^ fV))+  where+    i     :: Int+    i     = floor $ (6 * hue)+    f     = (6 * hue) - fromIntegral i+    fV    | i == 0    = RGB3  0     (1-f) 1 +          | i == 1    = RGB3  f     0     1+          | i == 2    = RGB3  1     0     (1-f)+          | i == 3    = RGB3  1     f     0+          | i == 4    = RGB3  (1-f) 1     0+          | i == 5    = RGB3  0     1     f+          | otherwise = RGB3  0     1     1+          +rgb2gray :: DRGB -> DGray+rgb2gray (RGB3 r g b) = Gray $ 0.3 * r + 0.59 * g + 0.11 * b ++gray2rgb :: DGray -> DRGB+gray2rgb (Gray a) = a *^ vE++hsb2gray :: DHSB -> DGray+hsb2gray (HSB3 _ _ b) = Gray b ++gray2hsb :: DGray -> DHSB+gray2hsb (Gray a) = HSB3 0 0 a+++++--------------------------------------------------------------------------------++-- Some colours++-- There will be name clashes with the X11Colours / SVGColours.++-- | Black - 0.0, 0.0, 0.0.+black :: DRGB+black = RGB3 0 0 0++-- | White - 1.0, 1.0, 1.0.+white :: DRGB+white = RGB3 1 1 1++-- | Red - 1.0, 0.0, 0.0.+red :: DRGB+red = RGB3 1 0 0++-- | Green - 0.0, 1.0, 0.0.+green :: DRGB +green = RGB3 0 1 0++-- | Blue - 0.0, 0.0, 1.0.+blue :: DRGB+blue = RGB3 0 0 1+
+ src/Wumpus/Core/FontSize.hs view
@@ -0,0 +1,137 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.FontSize+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  experimental+-- Portability :  GHC only+--+-- Text handling+-- +--------------------------------------------------------------------------------++module Wumpus.Core.FontSize+  ( +  +  -- * Type synonym+    FontSize++  -- * Courier metrics at 48 point+  , courier48_width+  , courier48_body_height+  , courier48_height+  , courier48_descender_depth+  , courier48_spacer_width++  , widthAt48pt+  , textWidth+  , textHeight+  , descenderDepth++  , textBounds++  ) where++import Wumpus.Core.BoundingBox+import Wumpus.Core.Geometry++import Data.AffineSpace         -- vector-space++type CharCount = Int+type FontSize = Int++-- | The width of a letter in Courier at 48 pt.+--+-- The value is not entirely accurate but it is satisfactory.+courier48_width :: Num u => u+courier48_width = 26+++-- | The height of a letter without accents, ascenders or +-- descenders in Courier at 48 pt .+--+-- The value is not entirely accurate but it is satisfactory - +-- some letters are taller than others (e.g. numbers are taller +-- then capitals).+courier48_body_height :: Num u => u +courier48_body_height = 30+++-- | The /common maximum/ height of a letter in Courier at 48pt.+--+-- By common maximum the letter is allowed to have both an accent +-- or ascender and a descender.+--+-- Naturally the height is 48.0.+--+courier48_height :: Num u => u+courier48_height = 48+++-- | The depth of a descender in Courier at 48 pt.+-- +-- Also the height of an ascender.+courier48_descender_depth :: Num u => u +courier48_descender_depth = 9++++-- | The spacing between letters printed directly with +-- PostScript\'s show command for Courier at 48 pt.+--+-- The value is not entirely accurate but it is satisfactory.+courier48_spacer_width :: Num u => u+courier48_spacer_width = 3+++-- | Width of the supplied string when printed at 48pt.+widthAt48pt :: Fractional u => CharCount -> u+widthAt48pt n = courier48_width * len + courier48_spacer_width * len_sub+  where+    len      = fromIntegral n+    len_sub  = len - 1.0++--- | Text width at @sz@ point size of the string @s@. All+-- characters are counted literally - special chars may cause+-- problems (this a current deficiency of Wumpus).+textWidth :: Fractional u => FontSize -> CharCount -> u+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).+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++-- | Find the bounding box for the character count at the +-- supplied font-size.+-- +-- The supplied point represents the bottom left corner of the +-- a regular upper-case letter (that is without descenders).+-- The bounding box will always be /dropped/ to accommodate +-- ascenders - no interpretation of the string takes place to +-- see if it actually contains ascenders or descenders.+--  +-- The metrics used are derived from Courier - a monospaced font.+-- For variable width fonts the calculated bounding box will +-- usually be too long.+--+textBounds :: Fractional u +           => FontSize -> Point2 u -> CharCount -> BoundingBox u+textBounds sz body_bl n = bbox bl tr where+    h           = textHeight sz+    w           = textWidth  sz n+    dd          = descenderDepth sz+    bl          = body_bl .-^ V2 0 dd +    tr          = bl .+^ V2 w h+
+ src/Wumpus/Core/Geometry.hs view
@@ -0,0 +1,627 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# OPTIONS -Wall #-}++------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.Geometry+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  experimental+-- Portability :  GHC only+--+-- 2D geometry+--------------------------------------------------------------------------------++module Wumpus.Core.Geometry +  ( +  -- * Type family +    DUnit+  +  -- * Data types+  , Vec2(..)+  , DVec2+  , Point2(..)+  , DPoint2+  , Frame2(..)+  , DFrame2+  , Matrix3'3(..)+  , DMatrix3'3+  , Radian+++  -- * Pointwise type class+  , Pointwise(..)++  -- * Matrix multiply type class+  , MatrixMult(..)++  -- * Vector operations+  , hvec+  , vvec+  , avec++  -- * Point operations+  , zeroPt+  , langle++  -- * Frame operations+  , ortho+  , displaceOrigin+  , pointInFrame+  , frame2Matrix+  , matrix2Frame+  , frameProduct+  , standardFrame++  -- * Matrix contruction+  , identityMatrix+  , scalingMatrix+  , translationMatrix+  , rotationMatrix+  , originatedRotationMatrix++  -- * matrix operations+  , invert+  , determinant+  , transpose++  -- * Radian operations+  , req+  , toRadian+  , fromRadian+  , d2r+  , r2d++  ) where++import Wumpus.Core.Utils ( CMinMax(..), PSUnit(..) )++import Data.Aviary++import Data.AffineSpace+import Data.VectorSpace++import Text.PrettyPrint.Leijen hiding ( langle )++import Data.Function ( on )+import Data.Monoid+++--------------------------------------------------------------------------------++-- | Some unit of dimension usually double.++type family DUnit a :: *++++-- Datatypes ++-- Vectors++data Vec2 a = V2 !a !a+  deriving (Eq,Show)++type DVec2 = Vec2 Double++-- Points++data Point2 a = P2 !a !a+  deriving (Eq,Show)++type DPoint2 = Point2 Double++++-- | A two dimensional frame.+-- +-- The components are the two basis vectors @e0@ and @e1@ and +-- the origin @o@.+--+-- Typically these names for the elements will be used:+--+-- > Frame2 (V2 e0x e0y) (V2 e1x e1y) (P2 ox oy)+-- ++data Frame2 a = Frame2 (Vec2 a) (Vec2 a) (Point2 a)+  deriving (Eq,Show)++type DFrame2 = Frame2 Double++++-- | 3x3 matrix, considered to be in row-major form.+-- +-- > (M3'3 a b c+-- >       d e f+-- >       g h i)+--+-- For instance the rotation matrix is represented as+--+-- >  ( cos(a) -sin(a) 0+-- >    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.+--+-- The right-most column is considered to represent a+-- coordinate:+--+-- >  ( 1 0 x+-- >    0 1 y  +-- >    0 0 1 ) +-- >+-- +-- So a translation matrix representing the displacement in x +-- of 40 and in y of 10 would be:+--+-- >  ( 1 0 40+-- >    0 1 10  +-- >    0 0 1  ) +-- >+-- +++data Matrix3'3 a = M3'3 !a !a !a  !a !a !a  !a !a !a+  deriving (Eq)++type DMatrix3'3 = Matrix3'3 Double++++-- | Radian is represented with a distinct type. +-- Equality and ordering are approximate where the epsilon is 0.0001.+newtype Radian = Radian { getRadian :: Double }+  deriving (Num,Real,Fractional,Floating,RealFrac,RealFloat)+++--------------------------------------------------------------------------------+-- Family instances++type instance DUnit (Point2 a)    = a+type instance DUnit (Vec2 a)      = a+type instance DUnit (Frame2 a)    = a+type instance DUnit (Matrix3'3 a) = a++--------------------------------------------------------------------------------+-- lifters / convertors++lift2Vec2 :: (a -> a -> a) -> Vec2 a -> Vec2 a -> Vec2 a+lift2Vec2 op (V2 x y) (V2 x' y') = V2 (x `op` x') (y `op` y')+++lift2Matrix3'3 :: (a -> a -> a) -> Matrix3'3 a -> Matrix3'3 a -> Matrix3'3 a+lift2Matrix3'3 op (M3'3 a b c d e f g h i) (M3'3 m n o p q r s t u) = +      M3'3 (a `op` m) (b `op` n) (c `op` o)  +           (d `op` p) (e `op` q) (f `op` r)  +           (g `op` s) (h `op` t) (i `op` u)++++--------------------------------------------------------------------------------+-- instances+++instance Functor Vec2 where+  fmap f (V2 a b) = V2 (f a) (f b)+++instance Functor Point2 where+  fmap f (P2 a b) = P2 (f a) (f b)++instance Functor Matrix3'3 where+  fmap f (M3'3 m n o p q r s t u) = +    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++++instance Num a => Monoid (Vec2 a) where+  mempty  = V2 0 0+  mappend = lift2Vec2 (+) +++-- Affine frames also have a sensible Monoid instance++instance (Num a, InnerSpace (Vec2 a)) => Monoid (Frame2 a) where+  mempty = ortho zeroPt+  mappend = frameProduct++++++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]]++instance Num a => Num (Matrix3'3 a) where+  (+) = lift2Matrix3'3 (+) +  (-) = lift2Matrix3'3 (-)++  (*) (M3'3 a b c d e f g h i) (M3'3 m n o p q r s t u) = +      M3'3 (a*m+b*p+c*s) (a*n+b*q+c*t) (a*o+b*r+c*u) +           (d*m+e*p+f*s) (d*n+e*q+f*t) (d*o+e*r+f*u) +           (g*m+h*p+i*s) (g*n+h*q+i*t) (g*o+h*r+i*u) +  +  abs    = fmap abs +  negate = fmap negate+  signum = fmap signum+  fromInteger a = M3'3 a' a' a'  a' a' a'  a' a' a' where a' = fromInteger a ++-- Radians++instance Show Radian where+  showsPrec i (Radian a) = showsPrec i a++instance Eq Radian where (==) = req++instance Ord Radian where+  compare a b | a `req` b = EQ+              | otherwise = getRadian a `compare` getRadian b++--------------------------------------------------------------------------------+-- Pretty printing++instance Pretty a => Pretty (Vec2 a) where+  pretty (V2 a b) = angles (char '|' <+> pretty a <+> pretty b <+> char '|')++instance Pretty a => Pretty (Point2 a) where+  pretty (P2 a b) = brackets (char '|' <+> pretty a <+> pretty b <+> char '|')++instance Pretty a => Pretty (Frame2 a) where+  pretty (Frame2 e0 e1 o) = braces $+        text "e0:" <> pretty e0+    <+> text "e1:" <> pretty e1+    <+> text "o:" <> pretty o++instance PSUnit a => Pretty (Matrix3'3 a) where+  pretty (M3'3 a b c  d e f  g h i) = +      matline a b c <$> matline d e f <$> matline g h i+    where+      matline x y z = char '|' +         <+> (hcat $ map (fill 12 . text . dtrunc) [x,y,z]) +         <+> char '|'   +++instance Pretty Radian where+  pretty (Radian d) = double d <> text ":rad"++--------------------------------------------------------------------------------+-- Vector space and related instances++instance Num a => AdditiveGroup (Vec2 a) where+  zeroV = V2 0 0 +  (^+^) = lift2Vec2 (+)  +  negateV = fmap negate +++instance Num a => VectorSpace (Vec2 a) where+  type Scalar (Vec2 a) = a+  s *^ v = fmap (s*) v+++-- scalar (dot / inner) product via the class InnerSpace++instance (Num a, InnerSpace a, Scalar a ~ a) +    => InnerSpace (Vec2 a) where+  (V2 a b) <.> (V2 a' b') = (a <.> a') ^+^ (b <.> b')+++instance Num a => AffineSpace (Point2 a) where+  type Diff (Point2 a) = Vec2 a+  (P2 a b) .-. (P2 x y)   = V2 (a-x)  (b-y)+  (P2 a b) .+^ (V2 vx vy) = P2 (a+vx) (b+vy)+++instance Num a => AdditiveGroup (Matrix3'3 a) where+  zeroV = fromInteger 0+  (^+^) = (+)+  negateV = negate+++instance Num a => VectorSpace (Matrix3'3 a) where+  type Scalar (Matrix3'3 a) = a+  s *^ m = fmap (s*) m ++--------------------------------------------------------------------------------++-- | 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.+++class Pointwise sh where+  type Pt sh :: *+  pointwise :: (Pt sh -> Pt sh) -> sh -> sh+++instance Pointwise (a -> a) where+  type Pt (a->a) = a+  pointwise f pf = \a -> pf (f a)++instance Pointwise a => Pointwise [a] where +  type Pt [a] = Pt a+  pointwise f pts = map (pointwise f) pts ++instance Pointwise (Vec2 a) where+  type Pt (Vec2 a) = Vec2 a+  pointwise f v = f v++instance Pointwise (Point2 a) where+  type Pt (Point2 a) = Point2 a+  pointwise f pt = f pt++--------------------------------------------------------------------------------++instance Ord a => CMinMax (Point2 a) where+  cmin (P2 x y) (P2 x' y') = P2 (min x x') (min y y')+  cmax (P2 x y) (P2 x' y') = P2 (max x x') (max y y')++--------------------------------------------------------------------------------+-- Matrix multiply++infixr 7 *# ++class MatrixMult mat t where +  type MatrixParam t :: *+  (*#) :: MatrixParam t ~ a => mat 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       +  (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+  (M3'3 a b c d e f _ _ _) *# (P2 m n) = P2 (a*m+b*n+c*1) (d*m+e*n+f*1)++--------------------------------------------------------------------------------+-- Vectors++-- | Construct a vector with horizontal displacement.+hvec :: Num a => a -> Vec2 a+hvec d = V2 d 0++-- | Construct a vector with vertical displacement.+vvec :: Num a => a -> Vec2 a+vvec d = V2 0 d++-- | Construct a vector from an angle and magnitude.+avec :: Floating a => Radian -> a -> Vec2 a+avec theta d = V2 x y where+  ang = fromRadian theta+  x   = d * cos ang+  y   = d * sin ang+++--------------------------------------------------------------------------------+-- Points++zeroPt :: Num a => Point2 a+zeroPt = P2 0 0++langle :: (Floating u, Real u) => Point2 u -> Point2 u -> Radian+langle (P2 x y) (P2 x' y') = toRadian $ atan $ (y'-y) / (x'-x) +++--------------------------------------------------------------------------------+-- Frame operations++ortho :: Num a => Point2 a -> Frame2 a+ortho o = Frame2 (V2 1 0) (V2 0 1) o++displaceOrigin :: Num a => Vec2 a -> Frame2 a -> Frame2 a+displaceOrigin v (Frame2 e0 e1 o) = Frame2 e0 e1 (o.+^v)+++pointInFrame :: Num a => Point2 a -> Frame2 a -> Point2 a+pointInFrame (P2 x y) (Frame2 vx vy o) = (o .+^ (vx ^* x)) .+^ (vy ^* y)  ++-- | Concatenate the elements of the frame as columns forming a+-- 3x3 matrix. Points and vectors are considered homogeneous +-- coordinates - triples where the least element is either 0 +-- indicating a vector or 1 indicating a point:+--+-- > Frame (V2 e0x e0y) (V2 e1x e1y) (P2 ox oy)+-- +-- becomes+--+-- > (M3'3 e0x e1x ox+-- >       e0y e1y oy+-- >        0   0   1  )+--++frame2Matrix :: Num a =>  Frame2 a -> Matrix3'3 a+frame2Matrix (Frame2 (V2 e0x e0y) (V2 e1x e1y) (P2 ox oy)) = +    M3'3 e0x e1x ox  +         e0y e1y oy +         0   0   1+++-- | Interpret the matrix as columns forming a frame.+--+-- > (M3'3 e0x e1x ox+-- >       e0y e1y oy+-- >        0   0   1  )+--+-- becomes+--+-- > 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+                   _   _   _ ) = Frame2 (V2 e0x e0y) (V2 e1x e1y) (P2 ox oy)+++-- | /Multiplication/ of frames to form their product.+frameProduct :: (Num a, InnerSpace (Vec2 a)) => Frame2 a -> Frame2 a -> Frame2 a+frameProduct = matrix2Frame `oo` on (*) frame2Matrix++++-- | Is the origin at (0,0) and are the basis vectors orthogonal +-- with unit length?+standardFrame :: Num a => Frame2 a -> Bool+standardFrame (Frame2 (V2 1 0) (V2 0 1) (P2 0 0)) = True+standardFrame _                                   = False+++--------------------------------------------------------------------------------+-- Matrix construction++-- | Construct the identity matrix:+--+-- > (M3'3 1 0 0+-- >       0 1 0+-- >       0 0 1 )+--++identityMatrix :: Num a => Matrix3'3 a+identityMatrix = M3'3 1 0 0  +                      0 1 0  +                      0 0 1++-- Common transformation matrices (for 2d homogeneous coordinates)++-- | Construct a scaling matrix:+--+-- > (M3'3 sx 0  0+-- >       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++translationMatrix :: Num a => a -> a -> Matrix3'3 a+translationMatrix x y = M3'3 1 0 x  +                             0 1 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  +                        0         0                  1+  where ang = fromRadian a++-- No reflectionMatrix function+-- A reflection about the x-axis is a scale of 1 (-1)+-- A reflection about the y-axis is a scale of (-1) 1+++-- Rotation about some /point/.+originatedRotationMatrix :: (Floating a, Real a) +                         => Radian -> (Point2 a) -> Matrix3'3 a+originatedRotationMatrix ang (P2 x y) = mT * (rotationMatrix ang) * mTinv+  where+    mT    = M3'3 1 0 x     +                 0 1 y     +                 0 0 1++    mTinv = M3'3 1 0 (-x)  +                 0 1 (-y)  +                 0 0   1++++-- inversion++invert :: Fractional a => Matrix3'3 a -> Matrix3'3 a +invert m = (1 / determinant m) *^ adjoint m++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 :: Matrix3'3 a -> Matrix3'3 a+transpose (M3'3 a b c +                d e f +                g h i) = M3'3 a d g  +                              b e h  +                              c f i++cofactor :: Num a => Matrix3'3 a -> Matrix3'3 a+cofactor (M3'3 a b c  +               d e f  +               g h i) = M3'3   a  (-b)   c+                             (-d)   e  (-f)+                               g  (-h)   i++mofm :: Num a => Matrix3'3 a -> Matrix3'3 a+mofm (M3'3 a b c  +               d e f  +               g h i)  = M3'3 m11 m12 m13  +                              m21 m22 m23 +                          m31 m32 m33+  where  +    m11 = (e*i) - (f*h)+    m12 = (d*i) - (f*g)+    m13 = (d*h) - (e*g)+    m21 = (b*i) - (c*h)+    m22 = (a*i) - (c*g)+    m23 = (a*h) - (b*g)+    m31 = (b*f) - (c*e)+    m32 = (a*f) - (c*d)+    m33 = (a*e) - (b*d)++++--------------------------------------------------------------------------------+-- Radians++-- Radian numeric type++radian_epsilon :: Double+radian_epsilon = 0.0001+++req :: Radian -> Radian -> Bool+req a b = (fromRadian $ abs (a-b)) < radian_epsilon++++-- Radian construction+toRadian :: Real a => a -> Radian +toRadian = Radian . realToFrac+++-- Radian extraction +fromRadian :: Fractional a => Radian -> a+fromRadian = realToFrac . getRadian+++-- | Degrees to radians.+d2r :: (Floating a, Real a) => a -> Radian+d2r = Radian . realToFrac . (*) (pi/180)++-- | Radians to degrees.+r2d :: (Floating a, Real a) => Radian -> a+r2d = (*) (180/pi) . fromRadian+
+ src/Wumpus/Core/GraphicsState.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.GraphicsState+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Data types modelling the Graphics state+--+--------------------------------------------------------------------------------+++module Wumpus.Core.GraphicsState +  (+  -- * Data types  +  +  -- ** Stroke attributes+    StrokeAttr(..)+  , LineCap(..)+  , LineJoin(..)+  , DashPattern(..)++  -- ** Font+  , FontAttr(..)+  , SVGFontStyle(..)++  -- ** Colour+  , PSRgb++  -- ** Current Translation Matrix+  , CTM(..)++  -- * Convert to CTM+  , ToCTM(..)++  -- * Convert to PSColour+  , PSColour(..)++  ) where++import Wumpus.Core.Colour+import Wumpus.Core.Geometry+import Wumpus.Core.Utils++-- Graphics state datatypes+++data StrokeAttr = LineWidth   Double+                | MiterLimit  Double+                | LineCap     LineCap+                | LineJoin    LineJoin+                | DashPattern DashPattern +  deriving (Eq,Show)++data LineCap = CapButt | CapRound | CapSquare+  deriving (Enum,Eq,Show)++data LineJoin = JoinMiter | JoinRound | JoinBevel+  deriving (Enum,Eq,Show)++data DashPattern = Solid | Dash Int [Int]+  deriving (Eq,Show)+++-- PostScript (or at least GhostScript) seems to require both+-- attributes (name & size) are set at the same time.++data FontAttr = FontAttr { +                    font_name       :: String,        -- for PostScript+                    svg_font_family :: String,        -- for SVG+                    svg_font_style  :: SVGFontStyle,+                    font_size       :: Int +                  }+  deriving (Eq,Show)++data SVGFontStyle = SVG_REGULAR | SVG_BOLD | SVG_ITALIC | SVG_BOLD_ITALIC+                  | SVG_OBLIQUE | SVG_BOLD_OBLIQUE+  deriving (Eq,Show)++type PSRgb = RGB3 Double++++-- | PostScript's current transformation matrix.+-- +-- PostScript and its documentation considers the matrix to be +-- in this form:+--+-- > | a  b  0 |+-- > | c  d  0 | +-- > | tx ty 1 |+-- +-- i.e it considers the homogeneous coordinates of an affine +-- frame as /rows/ rather than /columns/ (Wumpus uses rows, as +-- they were the usual representation in the geometry +-- presentations that inspired it).+-- +-- Using the component names that we have used in the +-- description of 'Frame2', the CTM is:+--+-- > | e0x  e0y  0 |+-- > | e1x  e1y  0 | +-- > | ox   oy   1 |+-- +-- The CTM is represented in PostScript as an array, using our +-- names its layout is+--+-- > [ e0x e0y e1x e1y ox oy ] +--+-- Some examples, the scaling matrix:+--+-- > | sx 0  0 |+-- > | 0  sy 0 |  = [ sx 0 0 sy 0 0 ]+-- > | 0  0  1 |+-- +-- Translation (displacement) :+--+-- > | 1  0  0 |+-- > | 0  1  0 |  = [ 1 0 0 1 tx ty ]+-- > | tx ty 1 |+-- +-- Rotation:+-- +-- > |  cos(a)  sin(a)  0 |+-- > | -sin(a)  cos(a)  0 |  = [ cos(a) sin(a) -sin(a) cos(a) 0 0 ]+-- > |    0       0     1 |++data CTM u = CTM !u !u  !u !u  !u !u+  deriving (Eq,Show)++type instance DUnit (CTM u) = u++--------------------------------------------------------------------------------+-- Conversion to CTM+++class ToCTM a where +  toCTM :: u ~ DUnit a => a -> CTM u++instance ToCTM (Frame2 a) where+  toCTM (Frame2 (V2 e0x e0y) (V2 e1x e1y) (P2 ox oy)) +    = CTM e0x e0y  e1x e1y  ox oy+ ++instance ToCTM (Matrix3'3 a) where+  toCTM (M3'3 e0x e1x ox  +              e0y e1y oy  +              _   _   _  ) +    = CTM e0x e0y  e1x e1y  ox oy+++--------------------------------------------------------------------------------+-- Conversion to PSColour++class PSColour a where psColour :: a -> RGB3 Double++instance PSColour (RGB3 Double) where+  psColour (RGB3 r g b) = RGB3 (ramp r) (ramp g) (ramp b)++instance PSColour (HSB3 Double) where+  psColour = psColour . hsb2rgb++instance PSColour (Gray Double) where+  psColour = psColour . gray2rgb++++
+ src/Wumpus/Core/OutputPostScript.hs view
@@ -0,0 +1,373 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.OutputPostScript+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  experimental+-- Portability :  GHC only+--+--+--------------------------------------------------------------------------------++module Wumpus.Core.OutputPostScript +  ( +  -- * Output PostScript+  -- $fontdoc+    writePS+  , writeEPS+  +  , writePS_latin1+  , writeEPS_latin1++  ) where++import Wumpus.Core.BoundingBox+import Wumpus.Core.Colour+import Wumpus.Core.Geometry+import Wumpus.Core.GraphicsState+import Wumpus.Core.PictureInternal+import Wumpus.Core.PostScript+import Wumpus.Core.TextEncoding+import Wumpus.Core.TextLatin1+import Wumpus.Core.Utils++import Data.Aviary ( appro )++import MonadLib hiding ( Label )++import Control.Monad ( mapM_, zipWithM_ )+++++++-- $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 +-- 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. +-- 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+    timestamp <- mkTimeStamp+    writeFile filepath $ epsDraw timestamp enc pic+++-- | Version of 'writePS' - using Latin1 encoding. +writePS_latin1 :: (Fractional u, Ord u, PSUnit u) +        => FilePath -> [Picture u] -> IO ()+writePS_latin1 filepath = writePS filepath latin1Encoder ++-- | Version of 'writeEPS' - using Latin1 encoding. +writeEPS_latin1 :: (Fractional u, Ord u, PSUnit u)  +         => FilePath -> Picture u -> IO ()+writeEPS_latin1 filepath = writeEPS filepath latin1Encoder++++++++++-- | Draw a picture, generating PostScript output.+psDraw :: (Fractional u, Ord u, PSUnit u) +       => String -> TextEncoder -> [Picture u] -> PostScript+psDraw timestamp enc pics = runWumpus enc $ do+    psHeader 1 timestamp+    zipWithM_ psDrawPage pages pics+    psFooter+  where+    pages = map (\i -> (show i,i)) [1..]+++psDrawPage :: (Fractional u, Ord u, PSUnit u) +           => (String,Int) -> Picture u -> WumpusM ()+psDrawPage (lbl,ordinal) pic = do+    dsc_Page lbl ordinal+    ps_gsave+    cmdtrans+    outputPicture pic+    ps_grestore+    ps_showpage+  where+    (_,mbv)   = repositionProperties pic+    cmdtrans  = maybe (return ()) (\(V2 x y) -> ps_translate x y) mbv+  +++-- Note the bounding box may have negative components - if it +-- does it will need translating.++epsDraw :: (Fractional u, Ord u, PSUnit u) +        => String -> TextEncoder -> Picture u -> PostScript+epsDraw timestamp enc pic = runWumpus enc $ do +    epsHeader bb timestamp      +    ps_gsave+    cmdtrans+    outputPicture pic+    ps_grestore+    epsFooter  +  where+    (bb,mbv)  = repositionProperties pic+    cmdtrans  = maybe (return ()) (\(V2 x y) -> ps_translate x y) mbv+     ++psHeader :: Int -> String -> WumpusM ()+psHeader pagecount timestamp = do+    bang_PS+    dsc_Pages pagecount+    dsc_CreationDate $ parens timestamp+    dsc_EndComments+++epsHeader :: PSUnit u => BoundingBox u -> String -> WumpusM ()+epsHeader bb timestamp = do+    bang_EPS+    dsc_BoundingBox llx lly urx ury+    dsc_CreationDate $ parens timestamp+    dsc_EndComments+  where+    (llx,lly,urx,ury) = getBounds bb++getBounds :: Num u => BoundingBox u -> (u,u,u,u)+getBounds (BBox (P2 llx lly) (P2 urx ury)) = (llx,lly,urx,ury)++psFooter :: WumpusM ()+psFooter = dsc_EOF+++epsFooter :: WumpusM ()+epsFooter = do+    ps_showpage+    dsc_EOF++-- Create margins at the left and bottom of 4 points...+++-- | outputPicture +-- Frame changes, representing scalings translation, rotations...+-- are drawn when they are encountered as a @concat@ statement in a +-- block of @gsave ... grestore@.++outputPicture :: (Fractional u, PSUnit u) => Picture u -> WumpusM ()+outputPicture (PicBlank  _)             = return ()+outputPicture (Single (fr,_) prim)      = +    updateFrame fr $ outputPrimitive prim+outputPicture (Picture (fr,_) ones)      = do+    updateFrame fr $ onesmapM_ outputPicture  ones+outputPicture (Clip (fr,_) cp p)        = +    updateFrame fr $ do { clipPath cp ; outputPicture p }+++-- | @updateFrame@ relies on the current frame, when translated+-- to a matrix being invertible.+--+-- This is an allowable optimization because the current frame+-- is only manipulated with the affine transformations (scalings, +-- rotations...) which are invertible. +-- +-- It also performs another optimization:+--+-- If the frame is the standard frame @ [1 0 0 1 0 0] @ then +-- the monadic action is run as-is rather than being nested+-- in a block:+-- +-- > [1 0 0 1 0 0] concat+-- > ...+-- > [1 0 0 1 0 0] concat+--++updateFrame :: (Fractional u, PSUnit u) => Frame2 u -> WumpusM () -> WumpusM ()+updateFrame frm ma +  | standardFrame frm = ma+  | otherwise         = let m1 = frame2Matrix frm in +                        do { ps_concat $ toCTM m1+                           ; ma +                           ; ps_concat $ toCTM $ invert m1+                           }++outputPrimitive :: (Fractional u, PSUnit u) => Primitive u -> WumpusM ()+outputPrimitive (PPath (c,dp) p)           = outputPath dp c p +outputPrimitive (PLabel props l)           = updateFont props $ outputLabel l+outputPrimitive (PEllipse (c,dp) ct hw hh) = outputEllipse dp c ct hw hh++updateFont :: LabelProps -> WumpusM () -> WumpusM ()+updateFont (c,fnt) ma = updateColour c $ do +    mb_fnt <- deltaFontAttr fnt+    maybe (return ()) fontCommand mb_fnt+    ma+    +++updateColour :: PSColour c => c -> WumpusM () -> WumpusM ()+updateColour c ma = let rgbc = psColour c in do +    mb_col  <- deltaRgbColour rgbc+    maybe (return ()) colourCommand mb_col+    ma+  where+    colourCommand :: DRGB -> WumpusM ()+    colourCommand (RGB3 r g b) = ps_setrgbcolor r g b+ +    +++fontCommand :: FontAttr -> WumpusM ()+fontCommand (FontAttr name _ _ sz) = do+    ps_findfont name+    ps_scalefont sz+    ps_setfont++++    +outputPath :: (PSColour c, PSUnit u) +           => DrawPath -> c -> Path u -> WumpusM ()+outputPath CFill        c p = updateColour c $ do  +    startPath p+    ps_closepath+    ps_fill++outputPath (CStroke xs) c p = updatePen c xs $ do+    startPath p+    ps_closepath+    ps_stroke++outputPath (OStroke xs) c p = updatePen c xs $ do+    startPath p+    ps_stroke+  ++startPath :: PSUnit u => Path u -> WumpusM ()+startPath (Path (P2 x y) xs) = do+    ps_newpath+    ps_moveto x y+    mapM_ outputPathSeg xs++++clipPath :: PSUnit u => Path u -> WumpusM ()+clipPath p = do +    startPath p+    ps_closepath+    ps_clip++++updatePen :: PSColour c => c -> [StrokeAttr] -> WumpusM () -> WumpusM ()+updatePen c xs ma = let (mset, mreset) = strokeSetReset xs in +                    updateColour c $ do { mset ; ma ; mreset }++strokeSetReset :: [StrokeAttr] -> (WumpusM (), WumpusM ())+strokeSetReset = foldr (appro link cmd id) (return (), return ())+  where+    link Nothing      funs    = funs +    link (Just (f,g)) (fs,gs) = (fs >> f, gs >> g)+    +    mkSetReset mf        = maybe Nothing (\(a,b) -> Just (mf a, mf b))+    +    cmd (LineWidth d)    = mkSetReset ps_setlinewidth  $ deltaStrokeWidth d+    cmd (MiterLimit d)   = mkSetReset ps_setmiterlimit $ deltaMiterLimit d+    cmd (LineCap lc)     = mkSetReset ps_setlinecap    $ deltaLineCap lc+    cmd (LineJoin lj)    = mkSetReset ps_setlinejoin   $ deltaLineJoin lj+    cmd (DashPattern dp) = mkSetReset ps_setdash       $ deltaDashPattern dp+++outputPathSeg :: PSUnit u => PathSegment u -> WumpusM ()+outputPathSeg (PLine (P2 x y))  = ps_lineto x y+outputPathSeg (PCurve p1 p2 p3) = ps_curveto x1 y1 x2 y2 x3 y3 +  where+    P2 x1 y1 = p1+    P2 x2 y2 = p2+    P2 x3 y3 = p3++-- | This is not very good as it uses a PostScript's+-- @scale@ operator - this will vary the line width during the+-- drawing of a stroked ellipse.+outputEllipse :: (PSColour c, Fractional u, PSUnit u)+              => DrawEllipse -> c -> Point2 u -> u -> u -> WumpusM ()+outputEllipse dp c (P2 x y) hw hh +    | hw==hh    = outputArc dp c x y hw+    | otherwise = do { ps_gsave+                     -- Not so good -- the next line changes stroke width...+                     ; ps_scale 1 (hh/hw)+                     ; outputArc dp c x y hw+                     ; ps_grestore+                     }++outputArc :: (PSColour c, PSUnit u) +          => DrawEllipse -> c -> u -> u -> u -> WumpusM ()+outputArc EFill        c x y r = updateColour c $ do +    ps_arc x y r 0 360 +    ps_closepath+    ps_fill++outputArc (EStroke xs) c x y r = updatePen c xs $ do +    ps_arc x y r 0 360 +    ps_closepath+    ps_stroke+++outputLabel :: PSUnit u => Label u -> WumpusM ()+outputLabel (Label (P2 x y) entxt) = do+    ps_moveto x y+    outputEncodedText entxt+--    ps_show str++outputEncodedText :: EncodedText -> WumpusM () +outputEncodedText = mapM_ outputTextChunk . getEncodedText++outputTextChunk :: TextChunk -> WumpusM () +outputTextChunk (SText s)  = ps_show s++outputTextChunk (EscInt i) = +    ask >>= \env -> maybe (failk env) ps_glyphshow $ lookupByCharCode i env+  where+    failk = missingCode i . ps_fallback  ++outputTextChunk (EscStr s) = ps_glyphshow s ++missingCode :: CharCode -> GlyphName -> WumpusM ()+missingCode i fallback =  do+    ps_comment $ "missing lookup for &#" ++ show i ++ ";" +    ps_glyphshow fallback+            ++
+ src/Wumpus/Core/OutputSVG.hs view
@@ -0,0 +1,284 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.OutputSVG+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  experimental+-- Portability :  GHC only+--+-- Output SVG. +--+-- This is complicated by two differences with PostScript.+--+-- 1. The coordinate space of SVG is /origin top-left/, for +-- PostScript it is /origin bottom-left/.+-- +-- 2. Clipping in PostScript works by changing the graphics state+-- Clip a path, then all subsequent drawing be rendered only +-- when it is within the clip bounds. Clearly using clipping +-- paths within a @gsave ... grestore@ block is a good idea...+--+-- SVG uses /tagging/. A clipPath element is declared and named +-- then referenced in subsequent elements via the clip-path +-- attribute - @clip-path=\"url(#clip_path_tag)\"@.+--+--+--------------------------------------------------------------------------------++module Wumpus.Core.OutputSVG+  ( +  +  -- * Output SVG+    writeSVG++  , writeSVG_latin1+  +  ) where++import Wumpus.Core.AffineTrans+import Wumpus.Core.Geometry+import Wumpus.Core.GraphicsState+import Wumpus.Core.PictureInternal+import Wumpus.Core.SVG+import Wumpus.Core.TextEncoding+import Wumpus.Core.TextLatin1+import Wumpus.Core.Utils++import Data.Aviary ( (#) )++import MonadLib hiding ( Label )++import Text.XML.Light++++type Clipped    = Bool+++coordChange ::  (Num u, Ord u, Scale t, u ~ DUnit t) => t -> t+coordChange = scale 1 (-1)+++--------------------------------------------------------------------------------++writeSVG :: (Ord u, PSUnit u) => FilePath -> TextEncoder -> Picture u -> IO ()+writeSVG filepath enc pic = +    writeFile filepath $ unlines $ map ppContent $ svgDraw enc pic ++writeSVG_latin1 :: (Ord u, PSUnit u) => FilePath -> Picture u -> IO ()+writeSVG_latin1 filepath = writeSVG filepath latin1Encoder ++++svgDraw :: (Ord u, PSUnit u) => TextEncoder -> Picture u -> [Content]+svgDraw enc pic = runSVG enc $ +    picture False pic' >>= return . topLevelPic mbvec >>= prefixXmlDecls+  where+    pic'      = coordChange pic+    (_,mbvec) = repositionProperties pic'+++prefixXmlDecls :: Element -> SvgM [Content]+prefixXmlDecls e = do +    enc <- asks svg_encoding_name+    let xmlv = xmlVersion enc+    return $ [Text xmlv, Text svgDocType, Elem e]    ++topLevelPic :: PSUnit u => Maybe (Vec2 u) -> Element -> Element+topLevelPic Nothing         p = svgElement [p]+topLevelPic (Just (V2 x y)) p = svgElement [gElement [trans_attr] [p]] +  where +    trans_attr = attr_transform $ val_translate x y++++picture :: (Ord u, PSUnit u) => Clipped -> Picture u -> SvgM Element+picture _ (PicBlank _)            = return $ gElement [] []+picture c (Single (fr,_) prim)    = do +    elt <- primitive c prim+    return $ gElement (maybe [] return $ frameChange fr) [elt]++picture c (Picture (fr,_) ones)    = do+    es <- toListWithM (picture c) ones+    return $ gElement (maybe [] return $ frameChange fr) es++picture _ (Clip (fr,_) p a) = do +   cp <- clipPath p+   e1 <- picture True a+   return $ gElement (maybe [] return $ frameChange fr) [cp,e1]+++primitive :: (Ord u, PSUnit u) => Clipped -> Primitive u -> SvgM Element+primitive c (PPath props p)            = clipAttrib c $ path props p+primitive c (PLabel props l)           = clipAttrib c $ label props l+primitive c (PEllipse props mid hw hh) = clipAttrib c $ +                                                ellipse props mid hw hh++++-- All clipping paths are closed.+clipPath :: PSUnit u => Path u -> SvgM Element+clipPath p = do+    name <- newClipLabel+    return $ element_clippath ps # add_attr (attr_id name)+  where+    ps = closePath $ pathInstructions p++++clipAttrib :: Clipped -> SvgM Element -> SvgM Element+clipAttrib False melt = melt+clipAttrib True  melt = do +    s   <- currentClipLabel+    elt <- melt+    return $ add_attr (attr_clippath s) elt+++-- None of the remaining translation functions need to be in the+-- SvgM monad.++path :: PSUnit u => PathProps -> Path u -> SvgM Element+path (c,dp) p = +    return $ element_path ps # add_attrs (fill_a : stroke_a : opts)+  where+    (fill_a,stroke_a,opts) = drawProperties c dp+    ps                     = svgPath dp p +++-- Labels need the coordinate system remapping otherwise+-- the will be printed upside down. Both the start point and +-- the label itself need transforming.+-- +-- Also rendering coloured text is convoluted (needing the+-- tspan element).+-- +label :: (Ord u, PSUnit u) => LabelProps -> Label u -> SvgM Element+label (c,FontAttr _ fam style sz) (Label pt entxt) = do +     str <- encodedText entxt+     let tspan_elt = element_tspan str # add_attrs [ attr_fill c ]+     return $ element_text tspan_elt # add_attrs text_xs +                                     # add_attrs (fontStyle style)+  where+    P2 x y    = coordChange pt+    text_xs   = [ attr_x x+                , attr_y y +                , attr_transform $ val_matrix 1 0 0 (-1) 0 (0::Double)+                , attr_font_family fam+                , attr_font_size sz +                ]+    +    +++encodedText :: EncodedText -> SvgM String +encodedText entxt = +    let xs = getEncodedText entxt in mapM textChunk  xs >>= return . concat++-- | Unfortunately we can\'t readily put a comment in the +-- generated SVG when glyph-name lookup fails. Doing similar in +-- PostScript is easy because we are emiting /linear/ PostScript +-- as we go along. For SVG we are building an abstract syntax +-- tree.+-- +textChunk :: TextChunk -> SvgM String+textChunk (SText s)  = return s+textChunk (EscInt i) = return $ escapeCharCode i+textChunk (EscStr s) = +    asks (lookupByGlyphName s) >>= maybe failk (return . escapeCharCode) +  where+    failk = asks svg_fallback >>= return . escapeCharCode ++escapeCharCode :: CharCode -> String+escapeCharCode i = "&#" ++ show i ++ ";"++ +fontStyle :: SVGFontStyle -> [Attr]+fontStyle SVG_REGULAR      = []+fontStyle SVG_BOLD         = [attr_font_weight "bold"]+fontStyle SVG_ITALIC       = [attr_font_style "italic"]+fontStyle SVG_BOLD_ITALIC  = +    [attr_font_weight "bold", attr_font_style "italic"]+fontStyle SVG_OBLIQUE      = [attr_font_style "oblique"]+fontStyle SVG_BOLD_OBLIQUE = +    [attr_font_weight "bold", attr_font_style "oblique"]++-- If w==h the draw the ellipse as a circle++ellipse :: PSUnit u => EllipseProps -> Point2 u -> u -> u -> SvgM Element+ellipse (c,dp) (P2 x y) w h +    | w == h    = return $ element_circle  +                         # add_attrs (circle_attrs  ++ style_attrs)+    | otherwise = return $ element_ellipse +                         # add_attrs (ellipse_attrs ++ style_attrs)+  where+    circle_attrs  = [attr_cx x, attr_cy y, attr_r w]+    ellipse_attrs = [attr_cx x, attr_cy y, attr_rx w, attr_ry h]+    style_attrs   = fill_a : stroke_a : opts+                    where (fill_a,stroke_a,opts) = drawEllipse c dp+++-- A rule of thumb seems to be that SVG (at least SVG in Firefox)+-- will try to fill unless told not to. So always label paths+-- with @fill=...@ even if fill is @\"none\"@.+--+-- CFill   ==> stroke="none" fill="..."+-- CStroke ==> stroke="..."  fill="none"+-- OStroke ==> stroke="..."  fill="none"+--++drawProperties :: PSColour c => c -> DrawPath -> (Attr, Attr, [Attr])+drawProperties = fn where+  fn c CFill        = (attr_fill c, attr_stroke_none, [])+  fn c (OStroke xs) = (attr_fill_none, attr_stroke c, strokeAttributes xs)+  fn c (CStroke xs) = (attr_fill_none, attr_stroke c, strokeAttributes xs)++drawEllipse :: PSColour c => c -> DrawEllipse -> (Attr, Attr, [Attr])+drawEllipse = fn where+  fn c EFill        = (attr_fill c, attr_stroke_none, [])+  fn c (EStroke xs) = (attr_fill_none, attr_stroke c, strokeAttributes xs)+ ++strokeAttributes :: [StrokeAttr] -> [Attr]+strokeAttributes = foldr fn [] where+  fn (LineWidth a)    = (:) (attr_stroke_width a)+  fn (MiterLimit a)   = (:) (attr_stroke_miterlimit a)+  fn (LineCap lc)     = (:) (attr_stroke_linecap lc)+  fn (LineJoin lj)    = (:) (attr_stroke_linejoin lj)+  fn (DashPattern dp) = dash dp where+    dash Solid       = (:) (attr_stroke_dasharray_none)+    dash (Dash _ []) = (:) (attr_stroke_dasharray_none)+    dash (Dash i xs) = (:) (attr_stroke_dashoffset i) . +                       (:) (attr_stroke_dasharray xs)+   +++svgPath :: PSUnit u => DrawPath -> Path u -> SvgPath+svgPath (OStroke _) p = pathInstructions p+svgPath _           p = closePath $ pathInstructions p+++pathInstructions :: PSUnit u => Path u -> [String]+pathInstructions (Path (P2 x y) xs) = path_m x y : map pathSegment xs++pathSegment :: PSUnit u => PathSegment u -> String+pathSegment (PLine (P2 x1 y1))                        = path_l x1 y1+pathSegment (PCurve (P2 x1 y1) (P2 x2 y2) (P2 x3 y3)) = +    path_s x1 y1 x2 y2 x3 y3++++frameChange :: PSUnit u => Frame2 u -> Maybe Attr+frameChange fr +    | standardFrame fr = Nothing+    | otherwise        = Just $ attr_transform $ val_matrix a b c d e f +  where+    CTM a b c d e f = toCTM fr++++closePath :: SvgPath -> SvgPath +closePath xs = xs ++ ["Z"]
+ src/Wumpus/Core/Picture.hs view
@@ -0,0 +1,443 @@+{-# LANGUAGE FlexibleInstances          #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.Picture+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  experimental+-- Portability :  GHC only+--+--+--------------------------------------------------------------------------------++module Wumpus.Core.Picture +  (+  +   -- * Construction+    blankPicture+  , frame+  , frameWithin+  , frameMulti+  , multi+++  , path+  , lineTo+  , curveTo+  , vertexPath  +  , curvedPath++  -- * Constructing primitives+  , Stroke(..)+  , zostroke+  , zcstroke++  , Fill(..)+  , zfill+  +  , clip++  , TextLabel(..)+  , ztextlabel+  , multilabel++  , Ellipse(..)+  , zellipse+++++  -- * Operations+  , extendBoundary++  ) where++import Wumpus.Core.BoundingBox+import Wumpus.Core.Colour+import Wumpus.Core.Geometry+import Wumpus.Core.GraphicsState+import Wumpus.Core.PictureInternal+import Wumpus.Core.TextEncoding+import Wumpus.Core.Utils++import Data.Semigroup+++++--------------------------------------------------------------------------------++-- Default attributes++psBlack :: PSRgb+psBlack = RGB3 0 0 0+ +-- aka the standard frame+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.+-- 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.+frame :: (Fractional u, Ord u) => Primitive u -> Picture u+frame p = Single (stdFrame, boundary p) p ++-- | Frame a picture within the supplied bounding box+-- +-- A text label uses the supplied bounding box as is - no +-- clipping is performed if the bounding box is +-- smaller than the boundary size of the text. This may +-- cause strange overlap for subsequent composite pictures, and+-- incorrect bounding box annotations in the prologue of the +-- generated EPS file. +-- +-- Paths and ellipses are bound within the union of the supplied +-- bounding box and the inherent bounding box or the path or +-- ellipse. Thus the bounding box will never reframed to a +-- smaller size than the /natural/ bounding box.+--+frameWithin :: (Fractional u, Ord u) => Primitive u -> BoundingBox u -> Picture u+frameWithin p@(PLabel _ _) bb = Single (stdFrame,bb) p+frameWithin p              bb = Single (stdFrame,bb `append` boundary p) p+++++-- | 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.+--+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+-- 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 +    sconcat []      = error err_msg+    sconcat (x:xs)  = foldr append x xs++    ones            = fromListErr err_msg ps++    err_msg         = "Wumpus.Core.Picture.multi - empty list"++++-- | Create a Path from the start point and alist of PathSegments.+path :: Point2 u -> [PathSegment u] -> Path u+path = Path ++-- | Create a straight-line PathSegment.+lineTo :: Point2 u -> PathSegment u+lineTo = PLine++-- | Create a curved PathSegment.+curveTo :: Point2 u -> Point2 u -> Point2 u -> PathSegment u+curveTo = PCurve+++-- | Convert the list of vertices to a path of straight line +-- segments.+vertexPath :: [Point2 u] -> Path u+vertexPath []     = error "Picture.vertexPath - empty point list"+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 +-- segment thereafter takes 3 points. /Spare/ points at the end +-- are discarded. +curvedPath :: [Point2 u] -> Path u+curvedPath []     = error "Picture.curvedPath - empty point list"+curvedPath (x:xs) = Path x (fn xs) where+  fn (a:b:c:ys) = PCurve a b c : fn ys +  fn _          = []+++  ++++--------------------------------------------------------------------------------+-- Take Paths to Primitives+++ostrokePath :: (Num u, Ord u) +            => PSRgb -> [StrokeAttr] -> Path u -> Primitive u+ostrokePath c attrs p = PPath (c, OStroke attrs) p++cstrokePath :: (Num u, Ord u) +            => PSRgb -> [StrokeAttr] -> Path u -> Primitive u+cstrokePath c attrs p = PPath (c, CStroke attrs) p++class Stroke t where+  ostroke :: (Num u, Ord u) => t -> Path u -> Primitive u+  cstroke :: (Num u, Ord u) => t -> Path u -> Primitive u++instance Stroke () where+  ostroke () = ostrokePath psBlack []+  cstroke () = cstrokePath psBlack []++instance Stroke (RGB3 Double) where+  ostroke c = ostrokePath (psColour c) []+  cstroke c = cstrokePath (psColour c) []++instance Stroke (HSB3 Double) where+  ostroke c = ostrokePath (psColour c) []+  cstroke c = cstrokePath (psColour c) []++instance Stroke (Gray Double) where+  ostroke c = ostrokePath (psColour c) []+  cstroke c = cstrokePath (psColour c) []+++instance Stroke StrokeAttr where+  ostroke x = ostrokePath psBlack [x]+  cstroke x = cstrokePath psBlack [x]++instance Stroke [StrokeAttr] where+  ostroke xs = ostrokePath psBlack xs+  cstroke xs = cstrokePath psBlack xs++++instance Stroke (RGB3 Double,StrokeAttr) where+  ostroke (c,x) = ostrokePath (psColour c) [x]+  cstroke (c,x) = cstrokePath (psColour c) [x]++instance Stroke (HSB3 Double,StrokeAttr) where+  ostroke (c,x) = ostrokePath (psColour c) [x]+  cstroke (c,x) = cstrokePath (psColour c) [x]++instance Stroke (Gray Double,StrokeAttr) where+  ostroke (c,x) = ostrokePath (psColour c) [x]+  cstroke (c,x) = cstrokePath (psColour c) [x]++instance Stroke (RGB3 Double,[StrokeAttr]) where+  ostroke (c,xs) = ostrokePath (psColour c) xs+  cstroke (c,xs) = cstrokePath (psColour c) xs++instance Stroke (HSB3 Double,[StrokeAttr]) where+  ostroke (c,xs) = ostrokePath (psColour c) xs+  cstroke (c,xs) = cstrokePath (psColour c) xs++instance Stroke (Gray Double,[StrokeAttr]) where+  ostroke (c,xs) = ostrokePath (psColour c) xs+  cstroke (c,xs) = cstrokePath (psColour c) xs+++-- | Create an open stoke coloured black.+zostroke :: (Num u, Ord u) => Path u -> Primitive u+zostroke = ostrokePath psBlack []+ +-- | Create a closed stroke coloured black.+zcstroke :: (Num u, Ord u) => Path u -> Primitive u+zcstroke = cstrokePath psBlack []+++++-- 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++class Fill t where+  fill :: (Num u, Ord u) => t -> Path u -> Primitive u+ ++instance Fill ()                where fill () = fillPath psBlack +instance Fill (RGB3 Double)     where fill = fillPath . psColour+instance Fill (HSB3 Double)     where fill = fillPath . psColour+instance Fill (Gray Double)     where fill = fillPath . psColour++-- | Create a filled path coloured black. +zfill :: (Num u, Ord u) => Path u -> Primitive u+zfill = fillPath psBlack++--------------------------------------------------------------------------------+-- Clipping ++clip :: (Num u, Ord u) => Path u -> Picture u -> Picture u+clip cp p = Clip (ortho zeroPt, boundary cp) cp p+++--------------------------------------------------------------------------------+-- Labels to primitive++mkTextLabel :: PSRgb -> FontAttr -> Point2 u -> String -> Primitive u+mkTextLabel c attr pt txt = PLabel (c,attr) (Label pt $ lexLabel txt)++-- SVG seems to have an issue with /Courier/ and needs /Courier New/.++default_font :: FontAttr+default_font = FontAttr "Courier" "Courier New" SVG_REGULAR 12++class TextLabel t where +  textlabel :: t -> Point2 u -> String -> Primitive u+++instance TextLabel () where textlabel () = mkTextLabel psBlack default_font++instance TextLabel (RGB3 Double) where+  textlabel c = mkTextLabel (psColour c) default_font++instance TextLabel (HSB3 Double) where+  textlabel c = mkTextLabel (psColour c) default_font++instance TextLabel (Gray Double) where+  textlabel c = mkTextLabel (psColour c) default_font++instance TextLabel FontAttr where+  textlabel a = mkTextLabel psBlack a++instance TextLabel (RGB3 Double,FontAttr) where+  textlabel (c,a) = mkTextLabel (psColour c) a++instance TextLabel (HSB3 Double,FontAttr) where+  textlabel (c,a) = mkTextLabel (psColour c) a++instance TextLabel (Gray Double,FontAttr) where+  textlabel (c,a) = mkTextLabel (psColour c) a++-- | Create a label where the font is @Courier@, text size is 10 +-- and colour is black.+ztextlabel :: Point2 u -> String -> Primitive u+ztextlabel = mkTextLabel psBlack default_font++++-- (The implementation of this function needs attention).+--+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."++--------------------------------------------------------------------------------++mkEllipse :: Num u +          => PSRgb -> DrawEllipse -> Point2 u -> u -> u -> Primitive u+mkEllipse c dp pt hw hh = PEllipse (c,dp) pt hw hh+++ellipseDefault :: EllipseProps+ellipseDefault = (psBlack, EFill)+++-- | Instances will create a filled ellipse unless the supplied +-- element /implies/ a stoked ellipse, e.g.:+--+-- > ellipse (LineWidth 4) zeroPt 40 40 +-- > ellipse EFill zeroPt 40 40  +--+class Ellipse t where+  ellipse :: Fractional u => t -> Point2 u -> u -> u -> Primitive u++instance Ellipse ()             where ellipse () = zellipse+instance Ellipse DrawEllipse    where ellipse dp = mkEllipse psBlack dp++instance Ellipse StrokeAttr     where +    ellipse = mkEllipse psBlack . EStroke . return++instance Ellipse [StrokeAttr]   where +    ellipse = mkEllipse psBlack . EStroke++instance Ellipse (RGB3 Double) where +    ellipse c = mkEllipse (psColour c) EFill++instance Ellipse (HSB3 Double) where +    ellipse c = mkEllipse (psColour c) EFill++instance Ellipse (Gray Double) where +    ellipse c = mkEllipse (psColour c) EFill+++instance Ellipse (RGB3 Double,DrawEllipse) where +    ellipse (c,dp) = mkEllipse (psColour c) dp++instance Ellipse (HSB3 Double,DrawEllipse) where +    ellipse (c,dp) = mkEllipse (psColour c) dp++instance Ellipse (Gray Double,DrawEllipse) where +    ellipse (c,dp) = mkEllipse (psColour c) dp+++instance Ellipse (RGB3 Double,StrokeAttr) where +    ellipse (c,x) = mkEllipse (psColour c) (EStroke [x])++instance Ellipse (HSB3 Double,StrokeAttr) where +    ellipse (c,x) = mkEllipse (psColour c) (EStroke [x])++instance Ellipse (Gray Double,StrokeAttr) where +    ellipse (c,x) = mkEllipse (psColour c) (EStroke [x])++instance Ellipse (RGB3 Double,[StrokeAttr]) where +    ellipse (c,xs) = mkEllipse (psColour c) (EStroke xs)++instance Ellipse (HSB3 Double,[StrokeAttr]) where +    ellipse (c,xs) = mkEllipse (psColour c) (EStroke xs)++instance Ellipse (Gray Double,[StrokeAttr]) where +    ellipse (c,xs) = mkEllipse (psColour c) (EStroke xs)+++-- | Create a black, filled ellipse. +zellipse :: Num u => Point2 u -> u -> u -> Primitive u+zellipse = uncurry mkEllipse ellipseDefault+++--------------------------------------------------------------------------------++-- Operations on pictures and paths+++++-- | Extend the bounding box of a picture. +--+-- The bounding box is both horizontal directions by @x@ and +-- both vertical directions by @y@. @x@ and @y@ must be positive+-- This function cannot be used to shrink a boundary.+--+extendBoundary :: (Num u, Ord u) => u -> u -> Picture u -> Picture u+extendBoundary x y = mapLocale (\(fr,bb) -> (fr, extBB (posve x) (posve y) bb)) +  where+    extBB x' y' (BBox (P2 x0 y0) (P2 x1 y1)) = BBox pt1 pt2 where +        pt1 = P2 (x0-x') (y0-y')+        pt2 = P2 (x1+x') (y1+y')+    +    posve n | n < 0     = 0+            | otherwise = n
+ src/Wumpus/Core/PictureInternal.hs view
@@ -0,0 +1,461 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.PictureInternal+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  experimental+-- Portability :  GHC only+--+-- Internal representation of Pictures +-- +--------------------------------------------------------------------------------++module Wumpus.Core.PictureInternal +  (+  -- * Data types+    Picture(..)+  , DPicture+  , Primitive(..)+  , DPrimitive+  , Path(..)+  , DPath+  , PathSegment(..)+  , DPathSegment+  , Label(..)+  , DLabel++  , PathProps                   -- hide in Wumpus.Core export?+  , LabelProps                  -- hide in Wumpus.Core export?+  , EllipseProps                -- +  , DrawPath(..)                -- hide in Wumpus.Core export?+  , DrawEllipse(..)+  , Locale  + +  -- * Type class++  , PSUnit(..)+  +  -- * Extras+  , mapLocale+  , extractFrame+  , repositionProperties++  ) where++import Wumpus.Core.AffineTrans+import Wumpus.Core.BoundingBox+import Wumpus.Core.FontSize+import Wumpus.Core.Geometry+import Wumpus.Core.GraphicsState+import Wumpus.Core.PictureLanguage hiding ( hcat, vcat, hsep, vsep )+import Wumpus.Core.TextEncoding+import Wumpus.Core.Utils++import Data.Aviary++import Data.AffineSpace+import Data.Semigroup++import Text.PrettyPrint.Leijen++++-- | Picture is a leaf attributed tree - where atttibutes are +-- colour, line-width etc. It is parametric on the unit type +-- of points (typically Double).+-- +-- Wumpus\'s Picture, being a leaf attributed tree, is not +-- ideally matched to PostScript\'s picture representation, +-- which might be considered a node attributed tree if you +-- recast graphics state updates as syntactic commands +-- encountered during top-down evaluation.+-- +-- Currently this mismatch means that the PostScript code +-- generated by Wumpus has significant overuse of PostScript's+-- @gsave@ and @grestore@.+--+-- At some point a tree-rewriting step might be added to +-- coalesce some of the repeated graphics state updates.+--+-- Apropos the constructors, Picture is a simple non-empty +-- leaf-labelled rose tree via +-- +-- > Single (aka leaf) | Picture (OneList tree)+--+-- Where OneList is a variant of the standard list type that +-- disallows empty lists.+-- +-- The additional constructors are convenience:+--+-- @PickBlank@ has a bounding box but no content and is useful for+-- some picture language operations (e.g. @hsep@).+--+-- @Clip@ nests a picture (tree) inside a clipping path.+--+++data Picture u = PicBlank (Locale u)+               | Single   (Locale u) (Primitive u)+               | Picture  (Locale u) (OneList (Picture u))+               | Clip     (Locale u) (Path u)      (Picture u)+  deriving (Eq,Show) ++type DPicture = Picture Double+++-- | Wumpus\'s drawings are built from two fundamental +-- primitives: paths (line segments and Bezier curves) and +-- labels (single lines of text). +-- +-- Ellipses are a included as a primitive only for optimization +-- - drawing a reasonable circle with Bezier curves needs at +-- least eight curves. This is inconvenient for drawing dots +-- which can otherwise be drawn with a single @arc@ command.+-- +-- Wumpus does not follow PostScript and employ arcs as general +-- path primitives - they are used only to draw ellipses. This +-- is because arcs do not enjoy the nice properties of Bezier +-- curves, whereby the affine transformation of a Bezier curve +-- can simply be achieved by the affine transformation of it\'s +-- control points.+--+-- Ellipses are represented by their center, half-width and +-- half-height. Half-width and half-height are used so the +-- bounding box can be calculated using only multiplication, and +-- thus initially only obliging a Num constraint on the unit.+-- Though typically for affine transformations a Fractional +-- constraint is also obliged.+--++data Primitive u = PPath    PathProps (Path u)+                 | PLabel   LabelProps (Label u) +                 | PEllipse { +                      ellipse_props       :: EllipseProps,+                      ellipse_center      :: Point2 u,+                      ellipse_half_width  :: u,+                      ellipse_half_height :: u +                    } +  deriving (Eq,Show)++type DPrimitive = Primitive Double++++data Path u = Path (Point2 u) [PathSegment u]+  deriving (Eq,Show)++type DPath = Path Double+++data PathSegment u = PCurve  (Point2 u) (Point2 u) (Point2 u)+                   | PLine   (Point2 u)+  deriving (Eq,Show)++type DPathSegment = PathSegment Double++data Label u = Label { +                   label_bottom_left :: Point2 u,+                   label_text        :: EncodedText+                 }+  deriving (Eq,Show)++type DLabel = Label Double+++-- | Note when drawn /filled/ and drawn /stroked/ the same +-- polygon will have (slightly) different size: +-- +-- * A filled shape fills /within/ the boundary of the shape+-- +-- * A stroked shape draws a pen line around the boundary +--   of the shape. The actual size depends on the thickness+--   of the line (stroke width).+--+data DrawPath = CFill | CStroke [StrokeAttr] | OStroke [StrokeAttr]+  deriving (Eq,Show)++-- | Ellipses and circles are always closed.+data DrawEllipse = EFill | EStroke [StrokeAttr]+  deriving (Eq,Show)++type PathProps    = (PSRgb, DrawPath)+type LabelProps   = (PSRgb, FontAttr)+type EllipseProps = (PSRgb, DrawEllipse)++-- | Locale = (current frame x bounding box)+-- +-- Pictures (and sub-pictures) are located within an affine frame.+-- So pictures can be arranged (vertical and horizontal +-- composition) their bounding box is cached.+--+-- In Wumpus, affine transformations (scalings, rotations...)+-- transform the frame rather than the constituent points of +-- the primitives. Changes of frame are transmitted to PostScript+-- as @concat@ commands (and matrix transforms in SVG) - the +-- @point-in-world-coordinate@ of a point on a path is never +-- calculated.+--  +-- So that picture composition is remains stable under affine+-- transformation, the corners of bounding boxes are transformed+-- pointwise when the picture is scaled, rotated etc.+--+type Locale u = (Frame2 u, BoundingBox u) +++--------------------------------------------------------------------------------+-- Pretty printing++instance (Num u, Pretty u) => Pretty (Picture u) where+  pretty (PicBlank m)       = text "*BLANK*" <+> ppLocale m+  pretty (Single m prim)    = ppLocale m <$> indent 2 (pretty prim)+  pretty (Picture m ones)  = +      ppLocale m <$> indent 2 (list $ toListWith pretty ones)++  pretty (Clip m cpath p)   = +      text "Clip:" <+> ppLocale m <$> indent 2 (pretty cpath)+                                   <$> indent 2 (pretty p)++ppLocale :: (Num u, Pretty u) => Locale u -> Doc+ppLocale (fr,bb) = align (ppfr <$> pretty bb) where+   ppfr = if standardFrame fr then text "*std-frame*" else pretty fr+++instance Pretty u => Pretty (Primitive u) where+  pretty (PPath _ p)        = pretty "path:" <+> pretty p+  pretty (PLabel _ lbl)     = pretty lbl+  pretty (PEllipse _ c w h) = pretty "ellipse" <+> pretty c+                                               <+> text "w:" <> pretty w+                                               <+> text "h:" <> pretty h+++instance Pretty u => Pretty (Path u) where+   pretty (Path pt ps) = pretty pt <> hcat (map pretty ps)++instance Pretty u => Pretty (PathSegment u) where+  pretty (PCurve p1 p2 p3)    = text ".*" <> pretty p1 <> text ",," <> pretty p2 +                                          <> text "*." <> pretty p3+  pretty (PLine pt)           = text "--" <> pretty pt++instance Pretty u => Pretty (Label u) where+  pretty (Label pt s) = dquotes (pretty s) <> char '@' <> pretty pt+++--------------------------------------------------------------------------------++-- | Paths are sensibly a Semigroup - there is no notion of +-- /empty path/.++instance Semigroup (Path u) where+  Path st xs `append` Path st' xs' = Path st (xs ++ (PLine st' : xs'))+++instance Pointwise (Path u) where+  type Pt (Path u) = Point2 u+  pointwise f (Path st xs) = Path (f st) (map (pointwise f) xs)++instance Pointwise (PathSegment u) where+  type Pt (PathSegment u) = Point2 u+  pointwise f (PLine p)         = PLine (f p)+  pointwise f (PCurve p1 p2 p3) = PCurve (f p1) (f p2) (f p3)+  +++--------------------------------------------------------------------------------+-- Affine trans instances++type instance DUnit (Picture u) = u+type instance DUnit (Primitive u) = u+type instance DUnit (Path u) = u++instance (Floating u, Real u) => Rotate (Picture u) where+  rotate = rotatePicture ++instance (Floating u, Real u) => RotateAbout (Picture u) where+  rotateAbout = rotatePictureAbout++instance (Num u, Ord u) => Scale (Picture u) where+  scale = scalePicture++instance (Num u, Ord u) => Translate (Picture u) where+  translate = translatePicture++--------------------------------------------------------------------------------++-- Helpers for the affine transformations++rotatePicture :: (Real u, Floating u) => Radian -> Picture u -> Picture u+rotatePicture = bigphi transformPicture rotate rotate+++rotatePictureAbout :: (Real u, Floating u) +                   => Radian -> Point2 u -> Picture u -> Picture u+rotatePictureAbout ang pt = +    transformPicture (rotateAbout ang pt) (rotateAbout ang pt)+  +scalePicture :: (Num u, Ord u) => u -> u -> Picture u -> Picture u+scalePicture x y = transformPicture (scale x y) (scale x y)++translatePicture :: (Num u, Ord u) => u -> u -> Picture u -> Picture u+translatePicture x y = transformPicture (translate x y) (translate x y)+++transformPicture :: (Num u, Ord u) +                 => (Point2 u -> Point2 u) +                 -> (Vec2 u -> Vec2 u) +                 -> Picture u +                 -> Picture u+transformPicture fp fv = +    mapLocale $ \(frm,bb) -> (transformFrame fp fv frm, transformBBox fp bb)+++-- Shouldn't transforming the frame be the inverse transformation?++transformFrame :: Num u+               => (Point2 u -> Point2 u) +               -> (Vec2 u -> Vec2 u) +               -> Frame2 u +               -> Frame2 u+transformFrame fp fv (Frame2 e0 e1 o) = Frame2 (fv e0) (fv e1) (fp o)+++-- Bounding boxes need recalculating after a transformation.+-- For instance after a reflection in the y-axis br becomes bl.+transformBBox :: (Num u, Ord u)+              => (Point2 u -> Point2 u) -> BoundingBox u -> BoundingBox u+transformBBox fp = trace . map fp . corners+++--------------------------------------------------------------------------------++-- 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    = movePic (hvec a) +  leftBound  = leftPlane . boundary+  rightBound = rightPlane . boundary++instance (Num u, Ord u) => Vertical (Picture u) where+  moveV a     = movePic (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+  a `over` b = Picture (ortho zeroPt, bb) (mkList2 b a) where+               bb = union (boundary a) (boundary b)+                       ++++instance (Num u, Ord u, Horizontal (Picture u), Vertical (Picture u)) => +      Move (Picture u) where+  move x y = movePic (V2 x y)+++instance Num u => Blank (Picture u) where+  blank w h = PicBlank (ortho zeroPt, bbox zeroPt (P2 w h))++--------------------------------------------------------------------------------+-- Boundary++instance (Num u, Ord u) => Boundary (Path u) where+  boundary (Path st xs) = trace $ st : foldr f [] xs where+      f (PLine p1)        acc  = p1 : acc+      f (PCurve p1 p2 p3) acc  = p1 : p2 : p3 : acc +++-- Note - this will calculate a very bad bounding box for text.+-- Descenders will be transgress the boundary and width will be +-- very long.++instance (Fractional u, Ord u) => Boundary (Primitive u) where+  boundary (PPath _ p)                  = boundary p+  boundary (PLabel (_,a) (Label pt xs)) = textBounds (font_size a) pt char_count+    where char_count = textLength xs+  boundary (PEllipse _ c hw hh)         = BBox (c .-^ v) (c .+^ v) +    where v = V2 hw hh+++instance Boundary (Picture u) where+  boundary (PicBlank (_,bb))     = bb+  boundary (Single   (_,bb) _)   = bb+  boundary (Picture  (_,bb) _)   = bb+  boundary (Clip     (_,bb) _ _) = bb++++++--------------------------------------------------------------------------------+--+++mapLocale :: (Locale u -> Locale u) -> Picture u -> Picture u+mapLocale f (PicBlank m)      = PicBlank (f m)+mapLocale f (Single   m prim) = Single (f m) prim+mapLocale f (Picture  m ones) = Picture (f m) ones+mapLocale f (Clip     m x p)  = Clip (f m) x p+++movePic :: Num u => Vec2 u -> Picture u -> Picture u+movePic v = mapLocale (moveLocale v) ++  +moveLocale :: Num u => Vec2 u -> Locale u -> Locale u+moveLocale v (fr,bb) = (displaceOrigin v fr, pointwise (.+^ v) bb) ++--------------------------------------------------------------------------------+++-- | Should this really be public?+extractFrame :: Num u => Picture u -> Frame2 u+extractFrame (PicBlank (fr,_))     = fr+extractFrame (Single   (fr,_) _)   = fr+extractFrame (Picture  (fr,_) _)   = fr+extractFrame (Clip     (fr,_) _ _) = fr+++-- This needs is for PostScript and SVG output - it should be +-- hidden in the export list of Wumpus.Core+++-- If a picture has coordinates smaller than (P2 4 4) then it +-- needs repositioning before it is drawn to PostSCript or SVG.+-- +-- (P2 4 4) gives a 4 pt margin - maybe it sould be (0,0) or +-- user defined.+--+repositionProperties :: (Num u, Ord u) => Picture u -> (BoundingBox u, Maybe (Vec2 u))+repositionProperties = fn . boundary where+  fn bb@(BBox (P2 llx lly) (P2 urx ury))+      | llx < 4 || lly < 4  = (BBox ll ur, Just $ V2 x y)+      | otherwise           = (bb, Nothing)+    where +      x  = 4 - llx+      y  = 4 - lly+      ll = P2 (llx+x) (lly+y)+      ur = P2 (urx+x) (ury+y)  ++
+ src/Wumpus/Core/PictureLanguage.hs view
@@ -0,0 +1,317 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.PictureLanguage+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  experimental+-- Portability :  GHC only+--+-- Picture language operations c.f. PPrint and +-- Text.PrettyPrint.HughesPJ, but fully in two dimensions +-- rather than horizontal + carriage return.+--+--------------------------------------------------------------------------------++module Wumpus.Core.PictureLanguage +  (+    HAlign(..)+  , VAlign(..)++  -- * Type family and classes+  , PUnit +  , Horizontal(..)+  , Vertical(..)+  , Composite(..)+  , Move(..)+  , Blank(..)++  -- * Bounds+  , center+  , topleft+  , topright+  , bottomleft+  , bottomright++  -- * Composition+  , ( ->- )+  , ( -<- )+  , ( -//- )+  , ( -\\- )+  , at+  , stackOnto+  , hcat +  , vcat+  , ( -@- )+  , stackOntoCenter++  , hspace+  , vspace+  , hsep+  , vsep+ +  -- * Compose with alignment+  , alignH+  , alignV+  , hcatA+  , vcatA+  , hsepA+  , vsepA++  ) where++import Wumpus.Core.Geometry ( Point2(..), Vec2(..) )++import Data.AffineSpace++import Data.List ( foldl' )+++--------------------------------------------------------------------------------+-- Data types++-- Alignment+++data HAlign = HTop | HCenter | HBottom+  deriving (Eq,Show)++data VAlign = VLeft | VCenter | VRight+  deriving (Eq,Show)+++++--------------------------------------------------------------------------------+-- Type family and classes+++-- The unit type of /points/ within a Picture.+type family PUnit a+++class Horizontal a where+  moveH      :: PUnit a -> a -> a+  leftBound  :: a -> PUnit a+  rightBound :: a -> PUnit a++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+class Move a where+  move :: PUnit a -> PUnit a -> a -> a+++class Blank a where+  blank :: PUnit a -> PUnit a -> a++++--------------------------------------------------------------------------------++-- Operations on bounds++-- | 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)++topleft       :: (Horizontal a, Vertical a, u ~ PUnit a) => a -> Point2 u+topleft a     = P2 (leftBound a)  (topBound a)++topright      :: (Horizontal a, Vertical a, u ~ PUnit a) => a -> Point2 u+topright a    = P2 (rightBound a) (topBound a)++bottomleft    :: (Horizontal a, Vertical a, u ~ PUnit a) => a -> Point2 u+bottomleft a  = P2 (leftBound a)  (bottomBound a)++bottomright   :: (Horizontal a, Vertical a, u ~ PUnit a) => a -> Point2 u+bottomright a = P2 (rightBound a) (bottomBound a)+++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 -//-+infixr 6 ->-, -@-+++-- | Center the pic1 on top of pic2.+(-@-) :: (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+++-- | Horizontal composition - place @b@ at 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 ++-- | Horizontal composition - place @a@ at the left of @b@.+(-<-) :: (Horizontal a, Composite a, Num u, u ~ PUnit a) => a -> a -> a+(-<-) = flip (->-)   -- TO TEST...++-- | Vertical composition - place @b@ 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 ++-- | Vertical composition - place @a@ above @b@.+(-\\-) :: (Vertical a, Composite a, Num u, u ~ PUnit a) => a -> a -> a+(-\\-) = flip (-//-)+++-- | 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.+stackOnto :: (Composite a) => [a] -> a -> a+stackOnto = flip (foldr over)++hcat :: (Horizontal a, Composite a, Num u, u ~ PUnit a)+     => a -> [a] -> a+hcat = foldl' (->-)++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 (-@-)++++--------------------------------------------------------------------------------+++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++++-- | 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 :: (Num u, Composite a, Horizontal a, Blank a, u ~ PUnit a) +       => u -> a -> a -> a+hspace n a b = a ->- blankH n ->-  b++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 :: (Num u, Composite a, Horizontal a, Blank a, u ~ PUnit a) +       => u -> a -> [a] -> a+hsep n = foldl' (hspace n)++vsep :: (Num u, Composite a, Vertical a, Blank a, u ~ PUnit a) +       => u -> a -> [a] -> a+vsep n = foldl' (vspace n)+++--------------------------------------------------------------------------------+-- Aligning pictures+++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+          , 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)++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 (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)+++hcatA :: ( Fractional u, Horizontal a, Vertical a+         , Composite a, Move a, u ~ PUnit a)+     => HAlign -> a -> [a] -> a+hcatA ha = foldl' (alignH ha)++vcatA :: ( Fractional u, Horizontal a, Vertical a+         , Composite a, Move a, u ~ PUnit a)+     => VAlign -> a -> [a] -> a+vcatA va = foldl' (alignV va)++++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 ++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 +
+ src/Wumpus/Core/PostScript.hs view
@@ -0,0 +1,525 @@+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE TypeSynonymInstances       #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.PostScript+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Wumpus - Writer Monad PostScript +--+-- PostScript is emitted line by line - there is no abstract+-- syntax tree representing PostScript. So we use a writer +-- monad.+---+--------------------------------------------------------------------------------+++module Wumpus.Core.PostScript +  (+  -- * Types+    PostScript+  , WumpusM++  , runWumpus++  -- * Deltas +  , deltaFontAttr+  , deltaRgbColour++  , deltaStrokeWidth+  , deltaMiterLimit+  , deltaLineCap+  , deltaLineJoin+  , deltaDashPattern+ +  -- * Emit PostScript +  , ps_comment+  +  , ps_gsave+  , ps_grestore+  , ps_setlinewidth+  , ps_setlinecap+  , ps_setlinejoin+  , ps_setmiterlimit+  , ps_setdash+  , ps_setgray+  , ps_setrgbcolor+  , ps_sethsbcolor+  , ps_translate+  , ps_scale+  , ps_concat+  , ps_newpath+  , ps_moveto+  , ps_rmoveto+  , ps_lineto+  , ps_rlineto+  , ps_arc+  , ps_arcn+  , ps_curveto+  , ps_closepath+  , ps_clip+  , ps_fill+  , ps_stroke+  , ps_showpage+  , ps_findfont+  , ps_scalefont+  , ps_setfont+  , ps_show+  , ps_glyphshow+  , bang_PS+  , bang_EPS+  , dsc_comment+  , dsc_BoundingBox+  , dsc_CreationDate+  , dsc_Pages+  , dsc_Page+  , dsc_EndComments+  , dsc_EOF++  ) where++import Wumpus.Core.Colour+import Wumpus.Core.GraphicsState+import Wumpus.Core.TextEncoding+import Wumpus.Core.Utils ( PSUnit(..), roundup, parens, hsep )++import Data.Aviary++import qualified Data.DList as DL+import MonadLib++import Data.List ( foldl' )+++-- Graphics state for PostScript Rendering+--+-- Values with no default value (e.g. font) in the graphics +-- state of the PostScript interpreter (not Wumpus\'s renderer) +-- are Maybes.+-- +-- The graphics state is considered successive - all elements +-- have a colour and all text labels have a font. So during +-- processing there are two situations: ++-- (1) If font or colour is the same as the last no state+-- change needs to be printed.+--+-- (2) If the font or colour changes the update needs to be +-- printed, but as the next element always has a colour (and a+-- font if it is a label), no @undo@ needs to be printed.+--+-- This contrasts with the behaviour for stroke attributes+-- which needs @undo@.++data PostScriptGS = PostScriptGS { +        gs_font         :: Maybe FontAttr,+        gs_rgb_colour   :: DRGB+      }+  deriving (Eq,Show)++++-- | Stroke properties do not have to be fully specified in +-- Wumpus\'s picture types - i.e. a Path might have it\'s stroke +-- width set but nothing else.+--+-- If a path changes any of the stroke properties, it +-- immediately undoes the changes after drawing, returning the +-- the stroke values to their PostScript defaults.+--+-- This means Wumpus doesn't have to carry a nested environment +-- around as it renders to PostScript. As stroke properties can+-- only be assigned to leaves in the picture tree, a nested +-- environment wouldn\'t really be an ideal fit anyway.+++gs_stroke_width :: Double+gs_stroke_width = 1.0++gs_miter_limit  :: Double+gs_miter_limit  = 10.0++gs_line_cap     :: LineCap+gs_line_cap     = CapSquare++gs_line_join    :: LineJoin+gs_line_join    = JoinMiter++gs_dash_pattern :: DashPattern+gs_dash_pattern = Solid++++type PostScript = String++type PsOutput = DL.DList Char++type WumpusM a = PsT Id a+++newtype PsT m a = PsT { +    unPsT :: StateT PostScriptGS +                    (WriterT PsOutput (ReaderT TextEncoder m)) a }++gs_init :: PostScriptGS +gs_init = PostScriptGS { gs_font           = Nothing+                       , gs_rgb_colour     = black +                       }+           +            +runPsT :: Monad m +       => TextEncoder -> PsT m a -> m ((a,PostScriptGS),PsOutput)+runPsT i m = runReaderT i $ runWriterT $ runStateT gs_init $ unPsT m++instance Monad m => Functor (PsT m) where+  fmap f (PsT mf) = PsT $ fmap f mf ++instance Monad m => Monad (PsT m) where+  return a  = PsT $ return a+  ma >>= f  = PsT $ unPsT ma >>= unPsT . f++instance Monad m => WriterM (PsT m) PsOutput where+  put = PsT . put++instance Monad m => ReaderM (PsT m) TextEncoder where+  ask = PsT $ ask++instance Monad m => StateM (PsT m) PostScriptGS where+  set = PsT . set+  get = PsT $ get++instance MonadT PsT where+  lift = PsT . lift . lift . lift+++pstId :: TextEncoder -> PsT Id a -> ((a,PostScriptGS),PsOutput)+pstId = runId `oo` runPsT++-- | Drop state and result, take the Writer trace.+runWumpus :: TextEncoder -> WumpusM a -> String+runWumpus = (DL.toList . snd) `oo` pstId++--------------------------------------------------------------------------------+-- "Deltas" of the graphics state++deltaFontAttr :: FontAttr -> WumpusM (Maybe FontAttr)+deltaFontAttr new = get >>= maybe update diff . gs_font+  where+    update :: WumpusM (Maybe FontAttr)+    update = sets_ (\s -> s { gs_font = Just new }) >> return (Just new)+    +    diff :: FontAttr -> WumpusM (Maybe FontAttr)+    diff old | old == new = return Nothing+             | otherwise  = update+++deltaRgbColour :: DRGB -> WumpusM (Maybe DRGB)+deltaRgbColour new = get >>= diff . gs_rgb_colour+  where+    diff :: DRGB -> WumpusM (Maybe DRGB)+    diff old | old == new = return Nothing+             | otherwise  = do { sets_ (\s -> s { gs_rgb_colour = new })+                               ; return (Just new)+                               }+++deltaStrokeWidth :: Double -> Maybe (Double,Double)+deltaStrokeWidth n+    | n == gs_stroke_width = Nothing+    | otherwise            = Just (n,gs_stroke_width)++deltaMiterLimit :: Double -> Maybe (Double,Double)+deltaMiterLimit n +    | n == gs_miter_limit  = Nothing+    | otherwise            = Just (n,gs_miter_limit)+++deltaLineCap :: LineCap -> Maybe (LineCap,LineCap)+deltaLineCap lc+    | lc == gs_line_cap    = Nothing+    | otherwise            = Just (lc,gs_line_cap)++deltaLineJoin :: LineJoin -> Maybe (LineJoin,LineJoin)+deltaLineJoin lj +    | lj == gs_line_join   = Nothing+    | otherwise            = Just (lj,gs_line_join)++deltaDashPattern :: DashPattern -> Maybe (DashPattern,DashPattern)+deltaDashPattern p +    | p == gs_dash_pattern = Nothing+    | otherwise            = Just (p,gs_dash_pattern)++++--------------------------------------------------------------------------------+-- writer monad helpers++tell :: WriterM m i => i -> m ()+tell s = puts ((),s)++writeChar :: WriterM m PsOutput => Char -> m ()+writeChar = tell . DL.singleton +++write :: WriterM m PsOutput => String -> m ()+write = tell . DL.fromList +++writeln :: WriterM m PsOutput => String -> m ()+writeln s = write s >> writeChar '\n'+++writeArg :: WriterM m PsOutput => String -> m () +writeArg s = write s >> writeChar ' '+++++type Command = String++command :: Command -> [String] -> WumpusM ()+command cmd xs = mapM_ writeArg xs >> writeln cmd++++showArray :: (a -> ShowS) -> [a] -> String+showArray _ []     = "[ ]"+showArray f (x:xs) = sfun "]" +  where +    sfun = foldl' (\a e -> a . (' ':) . f e) (('[':) . f x) xs+                              +++-- | @ %% ... @+ps_comment :: String -> WumpusM ()+ps_comment s = write "%% " >> writeln s++--------------------------------------------------------------------------------+-- graphics state operators++-- | @ gsave @+ps_gsave :: WumpusM ()+ps_gsave = command "gsave" []++-- | @ grestore @+ps_grestore :: WumpusM () +ps_grestore = command "grestore" []++-- | @ ... setlinewidth @+ps_setlinewidth :: PSUnit u => u -> WumpusM ()+ps_setlinewidth = command "setlinewidth" . return . dtrunc++-- | @ ... setlinecap @+ps_setlinecap :: LineCap -> WumpusM ()+ps_setlinecap = command "setlinecap" . return . show . fromEnum++-- | @ ... setlinejoin @+ps_setlinejoin :: LineJoin -> WumpusM ()+ps_setlinejoin = command "setlinejoin" . return . show . fromEnum++-- | @ ... setmiterlimit @+ps_setmiterlimit :: PSUnit u => u -> WumpusM ()+ps_setmiterlimit = command "setmiterlimit" . return . dtrunc++-- | @ [... ...] ... setdash @+ps_setdash :: DashPattern -> WumpusM ()+ps_setdash Solid        = command "setdash" ["[]", "0"]+ps_setdash (Dash n arr) = command "setdash" [showArray shows arr, show n]++-- | @ ... setgray @+ps_setgray :: PSUnit u => u -> WumpusM ()+ps_setgray = command "setgray" . return . dtrunc ++-- | @ ... ... ... setrgbcolor @+ps_setrgbcolor :: PSUnit u => u -> u -> u -> WumpusM ()+ps_setrgbcolor r g b = command "setrgbcolor" $ map dtrunc [r,g,b]++-- | @ ... ... ... sethsbcolor @+ps_sethsbcolor :: PSUnit u => u -> u -> u -> WumpusM ()+ps_sethsbcolor h s b = command "sethsbcolor" $ map dtrunc [h,s,b]+++--------------------------------------------------------------------------------+-- coordinate system and matrix operators ++-- | @ ... ... translate @+ps_translate :: PSUnit u => u -> u -> WumpusM ()+ps_translate tx ty = do+    command "translate" $ map dtrunc [tx,ty]++-- | @ ... ... scale @+ps_scale :: PSUnit u => u -> u -> WumpusM ()+ps_scale tx ty = do+    command "scale" $ map dtrunc [tx,ty]+++-- Do not use setmatrix for changing the CTM use concat...++-- | @ [... ... ... ... ... ...] concat @+ps_concat :: PSUnit u => CTM u -> WumpusM ()+ps_concat (CTM a b  c d  e f) = command "concat" [mat] where +    mat = showArray ((++) . dtrunc) [a,b,c,d,e,f]+++--------------------------------------------------------------------------------+-- Path construction operators++-- | @ newpath @+ps_newpath :: WumpusM ()+ps_newpath = command "newpath" []+++-- Note - it is preferable to show doubles as 0.0 rather than 0.+-- In PostScript the coercion from int to float is apparently +-- quite expensive.++-- | @ ... ... moveto @+ps_moveto :: PSUnit u => u -> u -> WumpusM ()+ps_moveto x y = command "moveto" [dtrunc x, dtrunc y]++-- | @ ... ... rmoveto @+ps_rmoveto :: PSUnit u => u -> u -> WumpusM ()+ps_rmoveto x y = command "rmoveto" [dtrunc x, dtrunc y]++-- | @ ... ... lineto @+ps_lineto :: PSUnit u => u -> u -> WumpusM ()+ps_lineto x y = command "lineto" [dtrunc x, dtrunc y]++-- | @ ... ... rlineto @+ps_rlineto :: PSUnit u => u -> u -> WumpusM ()+ps_rlineto x y = command "rlineto" [dtrunc x, dtrunc y]++-- | @ ... ... ... ... ... arc @+ps_arc :: PSUnit u => u -> u -> u -> u -> u -> WumpusM ()+ps_arc x y r ang1 ang2 = +    command "arc" $ map dtrunc [x,y,r,ang1,ang2]++-- | @ ... ... ... ... ... arcn @+ps_arcn :: PSUnit u => u -> u -> u -> u -> u -> WumpusM ()+ps_arcn x y r ang1 ang2 = +    command "arcn" $ map dtrunc [x,y,r,ang1,ang2]++-- | @ ... ... ... ... ... ... curveto @+ps_curveto :: PSUnit u => u -> u -> u -> u -> u -> u -> WumpusM ()+ps_curveto x1 y1 x2 y2 x3 y3 = +    command "curveto" $ map dtrunc [x1,y1, x2,y2, x3,y3]++-- | @ closepath @+ps_closepath :: WumpusM ()+ps_closepath = command "closepath" []++-- | @ clip @+ps_clip :: WumpusM ()+ps_clip = command "clip" []++--------------------------------------------------------------------------------+--  painting operators++-- | @ fill @+ps_fill :: WumpusM ()+ps_fill = command "fill" []++-- | @ stroke @+ps_stroke :: WumpusM ()+ps_stroke = command "stroke" []+++--------------------------------------------------------------------------------+-- Output operators++-- | @ showpage @+ps_showpage :: WumpusM ()+ps_showpage = command "showpage" []++++--------------------------------------------------------------------------------+-- Character and font operators++-- | 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+--+-- List from Bill Casselman \'Mathematical Illustrations\' p279.++-- | @ /... findfont @+ps_findfont :: String -> WumpusM () +ps_findfont = command "findfont" . return . ('/' :)++-- | @ ... scalefont @+ps_scalefont :: Int -> WumpusM ()+ps_scalefont = command "scalefont" . return . show++-- | @ setfont @+ps_setfont :: WumpusM ()+ps_setfont = command "setfont" []++-- | @ (...) show  @+ps_show :: String -> WumpusM ()+ps_show = command "show" . return . parens++-- | @ (...) show  @+ps_glyphshow :: String -> WumpusM ()+ps_glyphshow = command "glyphshow" . return . ('/':)+++--------------------------------------------------------------------------------+-- document structuring conventions++-- | @ %!PS-Adobe-3.0 @+bang_PS :: WumpusM ()+bang_PS = writeln "%!PS-Adobe-3.0"++-- | @ %!PS-Adobe-3.0 EPSF-3.0 @+bang_EPS :: WumpusM ()+bang_EPS = writeln "%!PS-Adobe-3.0 EPSF-3.0"++-- | @ %%...: ... @+dsc_comment :: String -> [String] -> WumpusM ()+dsc_comment name [] = write "%%" >> writeln name+dsc_comment name xs = write "%%" >> write name >> write ": " >> writeln (hsep xs)+++-- | @ %%BoundingBox: ... ... ... ... @  /llx lly urx ury/+dsc_BoundingBox :: PSUnit u => u -> u -> u -> u -> WumpusM ()+dsc_BoundingBox llx lly urx ury = +  dsc_comment "BoundingBox"  (map (roundup . toDouble) [llx,lly,urx,ury])++-- | @ %%CreationDate: ... @+-- +-- The creation date is informational and never interpreted, +-- thus the format is entirely arbitrary.+dsc_CreationDate :: String -> WumpusM ()+dsc_CreationDate = dsc_comment "CreationDate" . return++-- | @ %%Pages: ... @+dsc_Pages :: Int -> WumpusM ()+dsc_Pages = dsc_comment "Pages" . return . show+++-- | @ %%Page: ... ... @+dsc_Page :: String -> Int -> WumpusM ()+dsc_Page label ordinal = +    dsc_comment "Page" [label, show ordinal]+++-- | @ %%EndComments @+dsc_EndComments :: WumpusM ()+dsc_EndComments = dsc_comment "EndComments" []++-- | @ %%EOF @+dsc_EOF :: WumpusM ()+dsc_EOF = dsc_comment "EOF" []+
+ src/Wumpus/Core/SVG.hs view
@@ -0,0 +1,434 @@+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.SVG+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  experimental+-- Portability :  GHC only+--+-- SVG is represented using XML.Light. XML.Light is a simple,+-- generic XML representation (almost) everything is an element +-- with attributes.+--+-- SVG output is monadic to handle clipping paths and +-- configurable text encoding via a Reader monad. +--+-- SVG does not achieve clipping by changing the graphics state +-- (being /declarative/ SVG doesn\'t have a graphics state as +-- such). Instead a clipping path has an id, subsequent elements +-- that are bound by the clipping path are tagged with a +-- @clip-path@ attribute that references the clipping path id: +--+-- > clip-path=\"url(#clip1)\"+-- +-- +-- The operations to build XML elements (e.g. element_path) don\'t +-- take more parameters than necessary, and are expected to be +-- augmented with attributes using 'add_attr' and 'add_attrs' from +-- the XML.Light library.+-- +--------------------------------------------------------------------------------++module Wumpus.Core.SVG +  (+  -- * SVG Monad +    SvgM+  , runSVG+  , newClipLabel+  , currentClipLabel   +++  -- * Build SVG+  , SvgPath++  , unqualAttr+  , xmlVersion+  , svgDocType+  , gElement+  , svgElement+  +  , element_circle+  , element_ellipse+  , attr_x+  , attr_y+  , attr_r+  , attr_rx+  , attr_ry+  , attr_cx+  , attr_cy+  , element_path+  , element_clippath+  , element_text+  , element_tspan+  , content_text+  , attr_font_family+  , attr_font_size+  , attr_font_weight+  , attr_font_style+  , attr_id+  , attr_fill+  , attr_fill_none+  , attr_stroke+  , attr_stroke_none+  , attr_stroke_width+  , attr_stroke_miterlimit+  , attr_stroke_linecap+  , attr_stroke_linejoin++  , attr_stroke_dasharray+  , attr_stroke_dasharray_none+  , attr_stroke_dashoffset++  , attr_color+  , attr_clippath+  , attr_transform+  , val_matrix+  , val_colour+  , val_rgb+  , val_url+  , val_translate+  , path_m+  , path_l+  , path_s+++  ) where++import Wumpus.Core.Colour+import Wumpus.Core.GraphicsState+import Wumpus.Core.TextEncoding+import Wumpus.Core.Utils++import Data.Aviary++import MonadLib hiding ( version )+import Text.XML.Light+++data SvgState = SvgSt { clipCount :: Int }++-- | The SVG monad - which wraps a state monad to generate +-- fresh names.+type SvgM a = SvgT Id a++newtype SvgT m a = SvgT { unSvgT :: StateT SvgState (ReaderT TextEncoder m) a }++runSvgT :: Monad m => TextEncoder -> SvgT m a -> m (a,SvgState)+runSvgT i m = runReaderT i $ runStateT st0 $ unSvgT m where+    st0 = SvgSt { clipCount = 0 } ++instance Monad m => Functor (SvgT m) where+  fmap f (SvgT mf) = SvgT $ fmap f mf ++instance Monad m => Monad (SvgT m) where+  return a  = SvgT $ return a+  ma >>= f  = SvgT $ unSvgT ma >>= unSvgT . f++instance Monad m => StateM (SvgT m) SvgState where+  get = SvgT $ get+  set = SvgT . set++instance Monad m => ReaderM (SvgT m) TextEncoder where+  ask = SvgT $ ask++instance MonadT SvgT where+  lift = SvgT . lift . lift+++svgId :: TextEncoder -> SvgT Id a -> (a,SvgState)+svgId = runId `oo` runSvgT  ++-- | Run the SVG monad.+runSVG :: TextEncoder -> SvgM a -> a+runSVG = fst `oo` svgId+++-- | Get the current clip label.+currentClipLabel :: SvgM String+currentClipLabel = get >>= return . clipname . clipCount++-- | Generate a new clip label.+newClipLabel :: SvgM String+newClipLabel = do +  i <- (get >>= return . clipCount)+  sets_ (\s -> s { clipCount=i+1 })+  return $ clipname i+++clipname :: Int -> String+clipname = ("clip" ++) . show+++--------------------------------------------------------------------------------+-- Helpers for XML.Light and /data in strings/.++-- | Helper for XML.Light+unqualAttr :: String -> String -> Attr+unqualAttr name val = Attr (unqual name) val+++--------------------------------------------------------------------------------+-- SVG helpers++type SvgPath = [String]+++-- | @ \<?xml version=\"1.0\" encoding=\"...\"?\> @+--+xmlVersion :: String -> CData+xmlVersion s = CData CDataRaw +                     ("<?xml version=\"1.0\" encoding=\"" ++ s ++ "\"?>")+                     (Just 1)++-- |+-- > <!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"           +-- >     "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd" > +--+svgDocType :: CData+svgDocType = CData CDataRaw (line1 ++ "\n" ++ line2) (Just 1)+  where+    line1 = "<!DOCTYPE svg PUBLIC \"-//W3C//DTD SVG 1.1//EN\""+    line2 = "  \"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd\">"++-- | +-- > <g> ... </g>+--+-- Wumpus uses the g element (group) to achieve nesting. +gElement :: [Attr] -> [Element] -> Element+gElement xs ys = unode "g" (xs,ys)++-- |+-- > <svg xmlns="http://www.w3.org/2000/svg" version="1.1">+-- > ...+-- > </svg>+--+svgElement :: [Element] -> Element+svgElement xs = unode "svg" ([xmlns,version],xs)+  where+    xmlns   = unqualAttr "xmlns" "http://www.w3.org/2000/svg"+    version = unqualAttr "version" "1.1"  +++--------------------------------------------------------------------------------++++-- |+-- > <circle/>+--+element_circle :: Element+element_circle = unode "circle" ()++-- |+-- > <ellipse/>+--+element_ellipse :: Element+element_ellipse = unode "ellipse" ()++++-- | @ x=\"...\" @+attr_x :: PSUnit u => u -> Attr+attr_x = unqualAttr "x" . dtrunc++-- | @ y=\"...\" @+attr_y :: PSUnit u => u -> Attr+attr_y = unqualAttr "y" . dtrunc++-- | @ r=\"...\" @+attr_r :: PSUnit u => u -> Attr+attr_r = unqualAttr "r" . dtrunc+++-- | @ rx=\"...\" @+attr_rx :: PSUnit u => u -> Attr+attr_rx = unqualAttr "rx" . dtrunc++-- | @ ry=\"...\" @+attr_ry :: PSUnit u => u -> Attr+attr_ry = unqualAttr "ry" . dtrunc++-- | @ cx=\"...\" @+attr_cx :: PSUnit u => u -> Attr+attr_cx = unqualAttr "cx" . dtrunc++-- | @ cy=\"...\" @+attr_cy :: PSUnit u => u -> Attr+attr_cy = unqualAttr "cy" . dtrunc+++++-- |+-- > <path d="..." />+--+-- Note the argument to this function is an attribute rather+-- than content. We have no use for empty paths.+element_path :: SvgPath -> Element+element_path = unode "path" . attr_d++-- |+-- > <clipPath>+-- > ...+-- > </clipPath>+--+element_clippath :: SvgPath -> Element+element_clippath = unode "clipPath" . element_path++-- |+-- > <text>...</text>+--+element_text :: Node t => t -> Element+element_text = unode "text" ++-- |+-- > <text>...</text>+--+element_tspan :: String -> Element+element_tspan = unode "tspan" . content_text+++-- | Render the string as 'CDataText' - see XML.Light.+content_text :: String -> Content+content_text str = Text $ CData CDataRaw str Nothing+++-- | @ font-family=\"...\" @+attr_font_family :: String -> Attr+attr_font_family = unqualAttr "font-family" ++-- | @ font-size=\"...\" @+attr_font_size :: Int -> Attr+attr_font_size = unqualAttr "font-size" . show++-- | @ font-weight=\"...\" @+attr_font_weight :: String -> Attr+attr_font_weight = unqualAttr "font-weight"++-- | @ font-style=\"...\" @+attr_font_style :: String -> Attr+attr_font_style = unqualAttr "font-style"+++-- | @ id=\"...\" @+attr_id :: String -> Attr+attr_id = unqualAttr "id" ++-- | @ d="..." @+attr_d :: SvgPath -> Attr+attr_d = unqualAttr "d" . hsep++-- | @ fill=\"rgb(..., ..., ...)\" @+attr_fill :: PSColour c => c -> Attr+attr_fill = unqualAttr "fill" . val_colour++-- | @ fill=\"none\" @+attr_fill_none :: Attr+attr_fill_none = unqualAttr "fill" "none"++-- | @ stroke=\"rgb(..., ..., ...)\" @+attr_stroke :: PSColour c => c -> Attr+attr_stroke = unqualAttr "stroke" . val_colour++-- | @ stroke=\"none\" @+attr_stroke_none :: Attr+attr_stroke_none = unqualAttr "stroke" "none"++-- | @ stroke-width=\"...\" @+attr_stroke_width :: PSUnit u => u -> Attr+attr_stroke_width = unqualAttr "stoke-width" . dtrunc+++-- | @ stroke-miterlimit=\"...\" @+attr_stroke_miterlimit :: PSUnit u => u -> Attr+attr_stroke_miterlimit = unqualAttr "stoke-miterlimit" . dtrunc++-- | @ stroke-linejoin=\"...\" @+attr_stroke_linejoin :: LineJoin -> Attr+attr_stroke_linejoin JoinMiter = unqualAttr "stroke-linejoin" "miter"+attr_stroke_linejoin JoinRound = unqualAttr "stroke-linejoin" "round"+attr_stroke_linejoin JoinBevel = unqualAttr "stroke-linejoin" "bevel"++++attr_stroke_linecap :: LineCap -> Attr+attr_stroke_linecap CapButt   = unqualAttr "stroke-linecap" "butt"+attr_stroke_linecap CapRound  = unqualAttr "stroke-linecap" "round"+attr_stroke_linecap CapSquare = unqualAttr "stroke-linecap" "square"+++-- | @ stroke-dasharray=\"...\" @+attr_stroke_dasharray :: [Int] -> Attr+attr_stroke_dasharray = unqualAttr "stroke-dasharray" . commasep . map show++-- | @ stroke-dasharray=\"none\" @+attr_stroke_dasharray_none :: Attr+attr_stroke_dasharray_none = unqualAttr "stroke-dasharray" "none"++-- | @ stroke-dashoffset=\"...\" @+attr_stroke_dashoffset :: Int -> Attr+attr_stroke_dashoffset = unqualAttr "stroke-dashoffset" . show++-- | @ color=\"rgb(..., ..., ...)\" @+--+-- Gray or HSB values will be converted to and rendered as RGB.+attr_color :: PSColour c => c -> Attr+attr_color = unqualAttr "color" . val_colour++-- | @ clip-path=\"url(#...)\" @+attr_clippath :: String -> Attr+attr_clippath = unqualAttr "clip-path" . val_url++-- | @ transform="..." @+attr_transform :: String -> Attr+attr_transform = unqualAttr "transform"++-- | @ matrix(..., ..., ..., ..., ..., ...) @+val_matrix :: PSUnit u => u -> u -> u -> u -> u -> u -> String+val_matrix a b c d e f = "matrix" ++ tupled (map dtrunc [a,b,c,d,e,f])++++-- | @ rgb(..., ..., ...) @+-- +-- HSB and gray scale are translated to RGB values.+val_colour :: PSColour c => c -> String+val_colour = val_rgb . psColour+++-- | @ rgb(..., ..., ...) @+val_rgb :: RGB3 Double -> String+val_rgb (RGB3 r g b) = "rgb" ++ show (ramp255 r,ramp255 g,ramp255 b)+++-- | @ url(#...) @+val_url :: String -> String+val_url s = "url" ++ parens ('#':s)++-- | @ translate(..., ...) @+val_translate :: PSUnit u => u -> u -> String+val_translate x y = "translate" ++ tupled (map dtrunc [x,y])+  +-- | @ M ... ... @+--+-- c.f. PostScript's @moveto@.+path_m :: PSUnit u => u -> u -> String+path_m x y  = hsep $ "M" : map dtrunc [x,y]++-- | @ L ... ... @+--+-- c.f. PostScript's @lineto@.+path_l :: PSUnit u => u -> u -> String+path_l x y  = hsep $ "L" : map dtrunc [x,y]++-- | @ S ... ... ... ... ... ... @+-- +-- c.f. PostScript's @curveto@.+path_s :: PSUnit u => u -> u -> u -> u -> u -> u -> String+path_s x1 y1 x2 y2 x3 y3 =  hsep $ "S" : map dtrunc [x1,y1,x2,y2,x3,y3]++
+ src/Wumpus/Core/TextEncoding.hs view
@@ -0,0 +1,119 @@+{-# 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'
+ src/Wumpus/Core/TextLatin1.hs view
@@ -0,0 +1,250 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.TextLatin1+-- 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.TextLatin1+  ( +    Latin1Name+  , Latin1ISOCode+  +  , latin1Encoder++  , latin1All++  ) where++import Wumpus.Core.TextEncoding++import qualified Data.Map as Map++type Latin1Name = String+type Latin1ISOCode = Int++latin1Encoder :: TextEncoder+latin1Encoder = TextEncoder {+    ps_lookup         = Map.lookup `flip` codeToName,+    svg_lookup        = Map.lookup `flip` nameToCode,+    svg_encoding_name = "ISO-8859-1",+    ps_fallback       = "space",+    svg_fallback      = 0o040+  }+nameToCode :: Map.Map String Int+nameToCode = Map.fromList latin1All++codeToName :: Map.Map Int String+codeToName = foldr fn Map.empty latin1All where+  fn (s,i) a = Map.insert i s a ++latin1All :: [(Latin1Name, Latin1ISOCode)]+latin1All = [ ("A",                     0o101)+            , ("AE",                    0o306)+            , ("Aacute",                0o301)+            , ("Acircumflex",           0o302)+            , ("Adieresis",             0o304)+            , ("Agrave",                0o300)+            , ("Aring",                 0o305)+            , ("Atilde",                0o303)+            , ("B",                     0o102)+            , ("C",                     0o103)+            , ("Ccedilla",              0o307)+            , ("D",                     0o104)+            , ("E",                     0o105)+            , ("Eacute",                0o311)+            , ("Ecircumflex",           0o312)+            , ("Edieresis",             0o313)+            , ("Egrave",                0o310)+            , ("Eth",                   0o320)+            , ("F",                     0o106)+            , ("G",                     0o107)+            , ("H",                     0o110)+            , ("I",                     0o111)+            , ("Iacute",                0o315)+            , ("Icircumflex",           0o316)+            , ("Idieresis",             0o317)+            , ("Igrave",                0o314)+            , ("J",                     0o112)+            , ("K",                     0o113)+            , ("L",                     0o114)+            , ("M",                     0o115)+            , ("N",                     0o116)+            , ("Ntilde",                0o321)+            , ("O",                     0o117)+            , ("Oacute",                0o323)+            , ("Ocircumflex",           0o324)+            , ("Odieresis",             0o326)+            , ("Ograve",                0o322)+            , ("Oslash",                0o351)+            , ("Otilde",                0o325)+            , ("P",                     0o120)+            , ("Q",                     0o121)+            , ("R",                     0o122)+            , ("S",                     0o123)+            , ("T",                     0o124)+            , ("Thorn",                 0o336)+            , ("U",                     0o125)+            , ("Uacute",                0o332)+            , ("Ucircumflex",           0o333)+            , ("Udieresis",             0o334)+            , ("Ugrave",                0o331)+            , ("V",                     0o126)+            , ("W",                     0o127)+            , ("X",                     0o130)+            , ("Y",                     0o131)+            , ("Yacute",                0o335)+            , ("Z",                     0o132)+            , ("a",                     0o141)+            , ("aacute",                0o341)+            , ("acircumflex",           0o342)+            , ("acute2",                0o264)+            , ("adieresis",             0o344)+            , ("ae",                    0o346)+            , ("agrave",                0o340)+            , ("ampersand",             0o046)+            , ("aring",                 0o345)+            , ("asciicircum",           0o136)+            , ("asciitilde",            0o176)+            , ("asterisk",              0o052)+            , ("at",                    0o100)+            , ("atilde",                0o343)+            , ("b",                     0o142)+            , ("backslash",             0o134)+            , ("bar",                   0o174)+            , ("braceleft",             0o173)+            , ("braceright",            0o175)+            , ("bracketleft",           0o133)+            , ("bracketright",          0o135)+            , ("breve",                 0o226)+            , ("brokenbar",             0o246)+            , ("c",                     0o143)+            , ("caron",                 0o237)+            , ("ccedilla",              0o347)+            , ("cedilla",               0o270)+            , ("cent",                  0o242)+            , ("circumflex",            0o223)+            , ("colon",                 0o072)+            , ("comma",                 0o054)+            , ("copyright",             0o251)+            , ("currency",              0o244)+            , ("d",                     0o144)+            , ("degree",                0o260)+            , ("dieresis",              0o250)+            , ("divide",                0o367)+            , ("dollar",                0o044)+            , ("dotaccent",             0o227)+            , ("dotlessi",              0o220)+            , ("e",                     0o145)+            , ("eacute",                0o351)+            , ("ecircumflex",           0o352)+            , ("edieresis",             0o353)+            , ("egrave",                0o350)+            , ("eight",                 0o070)+            , ("equal",                 0o075)+            , ("eth",                   0o360)+            , ("exclam",                0o041)+            , ("exclamdown",            0o241)+            , ("f",                     0o146)+            , ("five",                  0o065)+            , ("four",                  0o064)+            , ("g",                     0o147)+            , ("germandbls",            0o337)+            , ("grave",                 0o221)+            , ("greater",               0o076)+            , ("guillemotleft",         0o253)+            , ("guillemotright",        0o273)+            , ("h",                     0o150)+            , ("hungarumlaut",          0o235)+            , ("hyphen",                0o255)+            , ("i",                     0o151)+            , ("iacute",                0o355)+            , ("icircumflex",           0o356)+            , ("idieresis",             0o357)+            , ("igrave",                0o354)+            , ("j",                     0o152)+            , ("k",                     0o153)+            , ("l",                     0o154)+            , ("less",                  0o074)+            , ("logicalnot",            0o254)+            , ("m",                     0o155)+            , ("macron",                0o257)+            , ("minus",                 0o055)+            , ("mu",                    0o265)+            , ("multiply",              0o327)+            , ("n",                     0o156)+            , ("nine",                  0o071)+            , ("ntilde",                0o361)+            , ("numbersign",            0o043)+            , ("o",                     0o157)+            , ("oacute",                0o363)+            , ("ocircumflex",           0o364)+            , ("odieresis",             0o366)+            , ("ogonek",                0o236)+            , ("ograve",                0o362)+            , ("one",                   0o061)+            , ("onehalf",               0o275)+            , ("onequarter",            0o274)+            , ("onesuperior",           0o271)+            , ("ordfeminine",           0o252)+            , ("ordmasculine",          0o272)+            , ("oslash",                0o370)+            , ("otilde",                0o365)+            , ("p",                     0o160)+            , ("paragraph",             0o266)+            , ("parenleft",             0o050)+            , ("parenright",            0o051)+            , ("percent",               0o045)+            , ("period",                0o056)+            , ("periodcentered",        0o267)+            , ("plus",                  0o053)+            , ("plusminus",             0o261)+            , ("q",                     0o161)+            , ("question",              0o077)+            , ("questiondown",          0o277)+            , ("quotedbl",              0o042)+            , ("quoteleft",             0o140)+            , ("quoteright",            0o047)+            , ("r",                     0o162)+            , ("registered",            0o256)+            , ("ring",                  0o232)+            , ("s",                     0o163)+            , ("section",               0o247)+            , ("semicolon",             0o073)+            , ("seven",                 0o067)+            , ("six",                   0o066)+            , ("slash",                 0o057)+            , ("space",                 0o040)+            , ("sterling",              0o243)+            , ("t",                     0o164)+            , ("thorn",                 0o376)+            , ("three",                 0o063)+            , ("threequarters",         0o276)+            , ("threesuperior",         0o263)+            , ("tilde",                 0o224)+            , ("two",                   0o062)+            , ("twosuperior",           0o262)+            , ("u",                     0o165)+            , ("uacute",                0o372)+            , ("ucircumflex",           0o373)+            , ("udieresis",             0o374)+            , ("ugrave",                0o371)+            , ("underscore",            0o137)+            , ("v",                     0o166)+            , ("w",                     0o167)+            , ("x",                     0o170)+            , ("y",                     0o171)+            , ("yacute",                0o375)+            , ("ydieresis",             0o377)+            , ("yen",                   0o245)+            , ("z",                     0o172)+            , ("zero",                  0o060)+            ]
+ src/Wumpus/Core/Utils.hs view
@@ -0,0 +1,270 @@+{-# LANGUAGE FlexibleInstances          #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.Utils+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Utility functions+--+--------------------------------------------------------------------------------+++module Wumpus.Core.Utils+  ( ++  -- * Component-wise min and max+    CMinMax(..)+  , within++  -- * Three values  +  , max3+  , min3+  , med3+++  -- * Truncate / print a double+  , PSUnit(..)+  , truncateDouble+  , roundup++  , clamp+  , ramp+  , ramp255++  -- * PostScript timetmap+  , mkTimeStamp++  -- * Pretty printers for strings  +  , parens+  , hsep+  , commasep+  , tupled++  -- * Extras  +  , sequenceA+  , (<:>) +++  ++  -- * One type - non-empty list type+  , OneList(..)+  , mkList2+  , onesmapM_+  , toListWith+  , toListWithM+  , fromListErr++  ) where++++import Control.Applicative+import Control.Monad ( ap )+import Data.List ( intersperse )+import Data.Ratio+import System.Time +++++--------------------------------------------------------------------------------++-- | /Component-wise/ min and max. +-- Standard 'min' and 'max' via Ord are defined lexographically+-- on pairs, e.g.:+-- +-- > min (1,2) (2,1) = (1,2)+-- +-- For certain geometrical objects (Points!) we want the +-- (constructed-) componentwise min and max, e.g:+--+-- > cmin (1,2) (2,1) = (1,1) +-- > cmax (1,2) (2,1) = (2,2)+-- ++class CMinMax a where+  cmin :: a -> a -> a+  cmax :: a -> a -> a++++instance (Ord a, Ord b) => CMinMax (a,b) where+  cmin (x,y) (x',y') = (min x x', min y y')+  cmax (x,y) (x',y') = (max x x', max y y')+++-- | Test whether a is within opper and lower.+within :: Eq a => CMinMax a => a -> a -> a -> Bool+within a lower upper = (cmin a lower) == lower && (cmax a upper) == upper+++-- | max of 3+max3 :: Ord a => a -> a -> a -> a+max3 a b c = max (max a b) c++-- | min of 3+min3 :: Ord a => a -> a -> a -> a+min3 a b c = min (min a b) c+++-- | median of 3+med3 :: Ord a => a -> a -> a -> a+med3 a b c = if c <= x then x else if c > y then y else c+  where +    (x,y)                 = order a b+    order p q | p <= q    = (p,q)+              | otherwise = (q,p)+++--------------------------------------------------------------------------------+-- PS Unit++class Num a => PSUnit a where+  toDouble :: a -> Double+  dtrunc   :: a -> String+  +  dtrunc = truncateDouble . toDouble++instance PSUnit Double where+  toDouble = id+  dtrunc   = truncateDouble++instance PSUnit Float where+  toDouble = realToFrac++instance PSUnit (Ratio Integer) where+  toDouble = realToFrac++instance PSUnit (Ratio Int) where+  toDouble = realToFrac+++-- | Truncate the printed decimal representation of a Double.+-- The is prefered to 'showFFloat' from Numeric as it produces+-- shorter representations where appropriate.+-- +-- 0.000000000 becomes 0.0 rather than however many digs are +-- specified.+--  +truncateDouble :: Double -> String+truncateDouble d | abs d < 0.0001  = "0.0"+                 | d < 0.0         = '-' :  show (abs tx)+                 | otherwise       = show tx+  where+    tx :: Double+    tx = (realToFrac (roundi (d*1000000.0))) / 1000000.0++roundi :: RealFrac a => a -> Integer+roundi = round++-- | Take 'ceilingi' and show.+roundup :: Double -> String+roundup = show . ceilingi++-- Avoid those annoying 'Defaulting ...' warnings...+ceilingi :: RealFrac a => a -> Integer+ceilingi = ceiling+++clamp :: Ord a => a -> a -> a -> a +clamp a b x = max a (min b x)++ramp :: Double -> Double+ramp = clamp 0 1++-- | Scale a Double between 0.0 and 1.0 to be an Int between 0 +-- and 255.+ramp255 :: Double -> Int+ramp255 = clamp 0 255  . ceiling . (*255)++++-- | Generate a time stamp for the output files. Note PostScript+-- does no interpretation of the time stamp, it is solely for +-- information and so the representation is arbitrary.+mkTimeStamp :: IO String+mkTimeStamp = getClockTime >>= toCalendarTime >>= return . format+  where+    format t = mkTime t ++ " " ++ mkDate t+    mkTime = concat . intersperse ":" . sequenceA tfuns+    mkDate = concat . intersperse " " . sequenceA dfuns+    tfuns  = [ pad2 . ctHour, pad2 . ctMin, pad2 . ctSec ]+    dfuns  = [ show . ctDay, show . ctMonth, show . ctYear ]+    pad2 i | i < 10    = '0' : show i+           | otherwise = show i  ++++-- | Enclose string in parens.+parens :: String -> String +parens s = "(" ++ s  ++ ")"++-- | Separate with a space.+hsep :: [String] -> String+hsep = concat . intersperse " "++commasep :: [String] -> String+commasep = concat . intersperse ","++-- | @ (..., ...)@+tupled :: [String] -> String+tupled = parens . concat . intersperse ", " ++++-- | Applicative version of (monadic) 'sequence'.+-- Because we use MonadLib we don't want to bring in +-- Control.Monad.Instances ()+sequenceA :: Applicative f => [f a] -> f [a]+sequenceA = foldr (<:>) (pure []) +++-- | Applicative 'cons'.+infixr 6 <:>+(<:>) :: Applicative f => f a -> f [a] -> f [a]+(<:>) a b = (:) <$> a <*> b++++--------------------------------------------------------------------------------++infixr 5 :+++data OneList a = One a | a :+ OneList a+  deriving (Eq)++instance Show a => Show (OneList a) where+  show = ('{':) . ($ []) . step where+     step (One a)   = shows a . showChar '}'+     step (a :+ xs) = shows a . showChar ',' . step xs+++mkList2 :: a -> a -> OneList a+mkList2 a b = a :+ One b+++onesmapM_ :: Monad m => (a -> m b) -> OneList a -> m ()+onesmapM_ f (One a)   = f a >> return ()+onesmapM_ f (a :+ xs) = f a >> onesmapM_ f xs++toListWith :: (a -> b) -> OneList a -> [b]+toListWith f (One a)   = [f a]+toListWith f (a :+ xs) = f a : toListWith f xs++toListWithM :: Monad m => (a -> m b) -> OneList a -> m [b]+toListWithM f (One a)   = return return `ap` f a+toListWithM f (a :+ xs) = return (:) `ap` f a `ap` toListWithM f xs+++fromListErr :: String -> [a] -> OneList a+fromListErr msg []     = error msg+fromListErr _   [a]    = One a+fromListErr msg (a:xs) = a :+ fromListErr msg xs
+ wumpus-core.cabal view
@@ -0,0 +1,107 @@+name:             wumpus-core+version:          0.12.0+license:          BSD3+license-file:     LICENSE+copyright:        Stephen Tetley <stephen.tetley@gmail.com>+maintainer:       Stephen Tetley <stephen.tetley@gmail.com>+homepage:         http://code.google.com/p/copperbox/+category:         Graphics+synopsis:         Pure Haskell PostScript and SVG generation. +description:+  Wumpus - (W)riter (M)onad (P)ost (S)cript. +  .+  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].+  .+  Pictures in Wumpus are made from /paths/ and text /labels/. +  Paths themselves are made from points. The usual affine +  transformations (rotations, scaling, translations) can be+  applied to all geometric objects. Unlike PostScript there +  is no notion of a current point, Wumpus builds pictures in a+  coordinate-free style. There is a set of combinators for +  composing pictures (more-or-less similar to the usual pretty+  printing combinators).+  .+  THE DRAWBACKS...+  .+  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.+  .+  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.+  .+  /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+  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 +  convert Wumpus'\s EPS files to many other formats (bitmaps). + +build-type:         Simple+stability:          highly unstable+cabal-version:      >= 1.2++extra-source-files:+  demo/LabelPic.hs,+  demo/Picture.hs+++library+  hs-source-dirs:     src+  build-depends:      base < 5, containers, old-time,+                      wl-pprint, vector-space, +                      monadLib, xml, dlist, algebra, +                      data-aviary > 0.1.0+                        +  exposed-modules:+    Wumpus.Core,+    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.PictureInternal,+    Wumpus.Core.PictureLanguage,+    Wumpus.Core.PostScript,+    Wumpus.Core.SVG,+    Wumpus.Core.TextEncoding,+    Wumpus.Core.TextLatin1,+    Wumpus.Core.Utils+  other-modules:+    +  extensions:+    ++  ghc-options:+  +  includes: +  ++  +