wumpus-core 0.16.0 → 0.17.0

raw patch · 18 files changed

+821/−705 lines, 18 filesdep +timedep −old-timePVP ok

version bump matches the API change (PVP)

Dependencies added: time

Dependencies removed: old-time

API changes (from Hackage documentation)

Files

• CHANGES +3/−0
• demo/FontPic.hs +2/−1
• demo/LabelPic.hs +10/−8
• demo/Picture.hs +1/−1
• doc-src/Guide.lhs +18/−13
• doc/Guide.pdf binary
• src/Wumpus/Core.hs +7/−27
• src/Wumpus/Core/BoundingBox.hs +20/−28
• src/Wumpus/Core/OutputPostScript.hs +9/−8
• src/Wumpus/Core/OutputSVG.hs +7/−8
• src/Wumpus/Core/Picture.hs +21/−33
• src/Wumpus/Core/PictureInternal.hs +55/−77
• src/Wumpus/Core/PictureLanguage.hs +0/−475
• src/Wumpus/Core/Utils.hs +12/−8
• src/Wumpus/Core/VersionNumber.hs +1/−1
• src/Wumpus/Core/WumpusTypes.hs +51/−0
• src/Wumpus/Extra/PictureLanguage.hs +554/−0
• wumpus-core.cabal +50/−17

@@ -1,3 +1,6 @@+0.16.0 to 0.17.0:+  +  . ???  0.15.0 to 0.16.0: 

@@ -3,6 +3,7 @@ module FontPic where  import Wumpus.Core+import Wumpus.Extra.PictureLanguage import Wumpus.Extra.SafeFonts import Wumpus.Extra.SVGColours ( steelBlue ) import Wumpus.Extra.X11Colours ( indianRed1 )@@ -25,7 +26,7 @@   makeFontLabel :: DRGB -> FontAttr -> (DPoint2 -> DPrimitive)-makeFontLabel c fa = \pt -> textlabel (c,fa) pt msg+makeFontLabel c fa = textlabel (c,fa) msg   where     msg = unwords [ font_name fa, (show $ font_size fa) ++ "pt"] 

@@ -3,15 +3,17 @@ module LabelPic where  import Wumpus.Core-+import Wumpus.Extra.PictureLanguage  --------------------------------------------------------------------------------    drawBounds :: (Fractional u, Ord u) => Picture u -> Picture u-drawBounds p        = p `over` (frame $ cstroke () ph) where-    ph   = vertexPath $ corners $ boundary p+drawBounds p        = p `over` (frame $ cstroke () ph) +  where+    ph            = vertexPath $ [bl,br,tr,tl]+    (bl,br,tr,tl) = corners $ boundary p  -------------------------------------------------------------------------------- @@ -29,8 +31,8 @@  lbl1 :: Picture Double lbl1 = line1 -//- line2 where-  line1 = frame (textlabel attrs zeroPt "Hello")-  line2 = frame (textlabel attrs zeroPt "World")+  line1 = frame (textlabel attrs "Hello" zeroPt)+  line2 = frame (textlabel attrs "World" zeroPt)   attrs = (peru, FontAttr "Helvetica" "Helvetica" SVG_REGULAR 12)   @@ -76,7 +78,7 @@ bigT = bigLetter plum  'T'  bigLetter :: PSRgb -> Char -> Picture Double-bigLetter col ch = uniformScale 5 $ frame $ textlabel attrs zeroPt [ch]+bigLetter col ch = uniformScale 5 $ frame $ textlabel attrs [ch] zeroPt   where     attrs = (col, FontAttr "Helvetica" "Helvetica" SVG_REGULAR 12)  @@ -135,7 +137,7 @@     writeSVG_latin1 "./out/label10.svg" p1   where     p1 :: Picture Double-    p1 = frame $ textlabel () zeroPt "myst&#egrave;re"+    p1 = frame $ textlabel () "myst&#egrave;re" zeroPt  demo11 :: IO () demo11 = do@@ -144,7 +146,7 @@   where     pic :: Picture Double     pic = p1 `over` p2-    p1  = multilabel plum 3 VLeft (P2 50 50) ["Hello", "from", "Wumpus"]+    p1  = multilabel plum 3 VLeft ["Hello", "from", "Wumpus"] (P2 50 50)     p2  = bigA `at` P2 50 50  

@@ -3,7 +3,7 @@ module Picture where  import Wumpus.Core-+import Wumpus.Extra.PictureLanguage   peru :: PSRgb

@@ -104,12 +104,6 @@ width, etc. - may be specified or not. The technique is due to 
 Iavor S. Diatchki's XML-Light.
 
-\item[\texttt{Wumpus.Core.PictureLanguage.}]
-Composition operators for pictures. The operators are somewhat 
-analogue to the usual operators or pretty-printing libraries, 
-but work in 2D rather than largely horizontally with some 
-vertical concatenation.
-
 \item[\texttt{Wumpus.Core.TextEncoder.}]
 Types for handling non-ASCII character codes. This module is
 perhaps under-cooked thou it appears adequate for Latin-1...
@@ -120,16 +114,27 @@ 
 \item[\texttt{Wumpus.Core.VersionNumber.}]
 Current version number of \wumpuscore.
+
+\item[\texttt{Wumpus.Core.WumpusTypes.}]
+This module collects internal types for Pictures, Paths etc. and
+presents them as opaque types - i.e. their constructors are 
+hidden. 
 \end{description}
 
 The package also contains some extra modules defining
-safe fonts and colour schemes. These modules would ideally be
-packaged in a separate package \texttt{wumpus-extra}, 
-unfortunately the other code in this package is not yet suitable 
-for wide spread distribution, so they are currently distributed 
-with \wumpuscore.
+picture composition operators, safe fonts and colour schemes. 
+These modules would ideally be packaged in a separate package 
+\texttt{wumpus-extra}, unfortunately the other code in this 
+package is not yet suitable for wide spread distribution, so 
+they are currently distributed with \wumpuscore.
 
 \begin{description}
+\item[\texttt{Wumpus.Extra.PictureLanguage.}]
+Composition operators for pictures. The operators are somewhat 
+analogue to the usual operators or pretty-printing libraries, 
+but work in 2D rather than largely horizontally with some 
+vertical concatenation.
+
 \item[\texttt{Wumpus.Extra.SafeFonts.}]
 Safe to use font and size combinations. The fonts named here are 
 included with GhostScript and are aliased as \emph{safe} fonts
@@ -285,8 +290,8 @@ 
 The following table lists PostScript fonts and their SVG 
 equivalents. As of revision 0.15.0 \wumpuscore includes a module 
-\texttt{Wumpus.Extra.SafeFonts} encoding this list to avoid 
-typographical slips...
+\texttt{Wumpus.Extra.SafeFonts} encoding the fonts in this list 
+to avoid typographical slips...
 
 
 

binary file changed (56701 → 56843 bytes)

@@ -36,13 +36,14 @@ -- -- * "Wumpus.Core.TextEncoder" --+-- * "Wumpus.Core.VersionNumber" --+-- * "Wumpus.Core.WumpusTypes"+-- -- Named colours ( black, white etc.) are hidden from  -- "Wumpus.Core.Colour" to avoid collisions with modules that -- define colour sets (e.g. all the SVG colours).  ----- Some data types are exported from --- "Wumpus.Core.PictureInternal" but are made opaque.  --  -------------------------------------------------------------------------------- @@ -58,29 +59,11 @@   , module Wumpus.Core.OutputPostScript   , module Wumpus.Core.OutputSVG   , module Wumpus.Core.Picture-  , module Wumpus.Core.PictureLanguage   , module Wumpus.Core.TextEncoder+  , module Wumpus.Core.VersionNumber+  , module Wumpus.Core.WumpusTypes -  , wumpus_core_version -  -- 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@@ -92,9 +75,6 @@ import Wumpus.Core.OutputPostScript import Wumpus.Core.OutputSVG import Wumpus.Core.Picture-import Wumpus.Core.PictureInternal-import Wumpus.Core.PictureLanguage import Wumpus.Core.TextEncoder-import Wumpus.Core.VersionNumber ( wumpus_core_version )--+import Wumpus.Core.VersionNumber+import Wumpus.Core.WumpusTypes

@@ -17,6 +17,10 @@ -- simplifies the implementation of pictures themselves and -- bounding boxes. -- +-- WARNING - this module is no so tightly designed, with some +-- of the functions seeming superfluous in hindsight. It is+-- likely to change in the future.+--  --------------------------------------------------------------------------------  module Wumpus.Core.BoundingBox @@ -24,7 +28,6 @@   -- * Types     BoundingBox(..)   , DBoundingBox-  , CardinalPoint(..)    -- * Type class   , Boundary(..)@@ -42,7 +45,7 @@   , boundaryTopRight   , boundaryTopLeft   , boundaryBottomRight-  , boundaryPoint+   , leftPlane   , rightPlane   , lowerPlane@@ -67,18 +70,14 @@ -- spared the obligation to be /empty/. BoundingBox is an instance -- of the Semigroup class where @append@ is the union operation. -- -data BoundingBox a = BBox { -                         ll_corner :: Point2 a, -                         ur_corner :: Point2 a -                       }+data BoundingBox a = BBox +      { ll_corner :: Point2 a+      , ur_corner :: Point2 a +      }   deriving (Eq,Show)  type DBoundingBox = BoundingBox Double --- | A location on a bounding box - the center @C@ and the usual--- compass points @N@, @S@, etc.-data CardinalPoint = C | N | NE | E | SE | S | SW | W | NW-  deriving (Eq,Show)   --------------------------------------------------------------------------------@@ -110,6 +109,7 @@  -- | Type class extracting the bounding box of an object -  -- Picture, Path etc.+-- class Boundary a where   boundary :: a -> BoundingBox (DUnit a) @@ -138,17 +138,23 @@  -- | 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)   -- | The union of two bounding boxes. This is also the @append@  -- of BoundingBox\'s @Semigroup@ instance.+-- union :: Ord a => BoundingBox a -> BoundingBox a -> BoundingBox a BBox ll ur `union` BBox ll' ur' = BBox (cmin ll ll') (cmax ur ur')  -- | Trace a list of points, retuning the BoundingBox that  -- includes them.+--+-- 'trace' throws a run-time error when supplied with the empty +-- list.+-- 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"@@ -160,15 +166,18 @@     br = P2 x1 y0     tl = P2 x0 y1 --- | Witinh test - is the supplied point within the bounding box?+-- | Within test - is the supplied point within the bounding box?+-- withinBB :: Ord a => Point2 a -> BoundingBox a -> Bool withinBB p (BBox ll ur) = within p ll ur  -- | Extract the width of a bounding box.+-- boundaryWidth :: Num a => BoundingBox a -> a boundaryWidth (BBox (P2 xmin _) (P2 xmax _)) = xmax - xmin  -- | Extract the height of a bounding box.+-- boundaryHeight :: Num a => BoundingBox a -> a boundaryHeight (BBox (P2 _ ymin) (P2 _ ymax)) = ymax - ymin @@ -194,23 +203,6 @@ boundaryBottomRight (BBox (P2 _ y) (P2 x _)) = P2 x y  --- | Extract a point from the bounding box at the supplied --- cardinal position.-boundaryPoint :: Fractional a -              => CardinalPoint -> BoundingBox a -> Point2 a-boundaryPoint loc (BBox (P2 x0 y0) (P2 x1 y1)) = fn loc where-  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)   --------------------------------------------------------------------------------

@@ -162,7 +162,7 @@ -- 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)      = @@ -201,9 +201,9 @@                            }  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+outputPrimitive (PPath (c,dp) p)    = outputPath dp c p +outputPrimitive (PLabel props l)    = updateFont props $ outputLabel l+outputPrimitive (PEllipse (c,dp) e) = outputEllipse dp c e  updateFont :: LabelProps -> WumpusM () -> WumpusM () updateFont (c,fnt) ma = updateColour c $ do @@ -287,8 +287,8 @@   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 +outputPathSeg (PLineTo (P2 x y))  = ps_lineto x y+outputPathSeg (PCurveTo p1 p2 p3) = ps_curveto x1 y1 x2 y2 x3 y3    where     P2 x1 y1 = p1     P2 x2 y2 = p2@@ -297,9 +297,10 @@ -- | 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 +              => DrawEllipse -> c -> PrimEllipse u -> WumpusM ()+outputEllipse dp c (PrimEllipse (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...

@@ -115,10 +115,9 @@   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+primitive c (PPath props p)     = clipAttrib c $ path props p+primitive c (PLabel props l)    = clipAttrib c $ label props l+primitive c (PEllipse props e)  = clipAttrib c $ ellipse props e   @@ -210,8 +209,8 @@  -- 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 +ellipse :: PSUnit u => EllipseProps -> PrimEllipse u -> SvgM Element+ellipse (c,dp) (PrimEllipse (P2 x y) w h)      | w == h    = return $ element_circle                            `rap` add_attrs (circle_attrs  ++ style_attrs)     | otherwise = return $ element_ellipse @@ -267,8 +266,8 @@ 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)) = +pathSegment (PLineTo (P2 x1 y1))                        = path_l x1 y1+pathSegment (PCurveTo (P2 x1 y1) (P2 x2 y2) (P2 x3 y3)) =      path_c x1 y1 x2 y2 x3 y3  

@@ -44,17 +44,18 @@    , TextLabel(..)   , ztextlabel-  , multilabel    , Ellipse(..)   , zellipse ---   -- * Operations   , extendBoundary ++  -- * Warning - don\'t use these are a temporary exports+  , movePic  -- re-export from PictureInternal+  , picOver+   ) where  import Wumpus.Core.BoundingBox@@ -62,7 +63,6 @@ import Wumpus.Core.Geometry import Wumpus.Core.GraphicsState import Wumpus.Core.PictureInternal-import Wumpus.Core.PictureLanguage import Wumpus.Core.TextEncodingInternal import Wumpus.Core.Utils @@ -155,12 +155,12 @@ -- | Create a straight-line PathSegment. -- lineTo :: Point2 u -> PathSegment u-lineTo = PLine+lineTo = PLineTo  -- | Create a curved PathSegment. -- curveTo :: Point2 u -> Point2 u -> Point2 u -> PathSegment u-curveTo = PCurve+curveTo = PCurveTo   -- | Convert the list of vertices to a path of straight line @@ -168,7 +168,7 @@ -- vertexPath :: [Point2 u] -> Path u vertexPath []     = error "Picture.vertexPath - empty point list"-vertexPath (x:xs) = Path x (map PLine xs)+vertexPath (x:xs) = Path x (map PLineTo xs)   @@ -180,7 +180,7 @@ 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 (a:b:c:ys) = PCurveTo a b c : fn ys    fn _          = []  @@ -312,8 +312,8 @@ -------------------------------------------------------------------------------- -- Labels to primitive -mkTextLabel :: PSRgb -> FontAttr -> Point2 u -> String -> Primitive u-mkTextLabel c attr pt txt = PLabel (c,attr) (Label pt $ lexLabel txt)+mkTextLabel :: PSRgb -> FontAttr -> String -> Point2 u -> Primitive u+mkTextLabel c attr txt pt = PLabel (c,attr) (Label pt $ lexLabel txt)  -- SVG seems to have an issue with /Courier/ and needs /Courier New/. @@ -330,8 +330,10 @@ -- Unless a 'FontAttr' is specified, the label will use 12pt  -- Courier. --+-- The supplied point is is the bottom left corner.+-- class TextLabel t where -  textlabel :: t -> Point2 u -> String -> Primitive u+  textlabel :: t -> String -> Point2 u -> Primitive u   instance TextLabel () where textlabel () = mkTextLabel psBlack default_font@@ -359,35 +361,16 @@  -- | Create a label where the font is @Courier@, text size is 10  -- and colour is black.-ztextlabel :: Point2 u -> String -> Primitive u+ztextlabel :: String -> Point2 u -> Primitive u ztextlabel = mkTextLabel psBlack default_font  --- | Create multiple lines of text.------ The dimension argument is the linespacing, measured as the--- distance between the upper lines descender and the lower --- lines ascender.------ An error is throw if the list of strings is empty--- -multilabel :: (Fractional u, Ord u, TextLabel t) -           => t -> u -> VAlign -> Point2 u -> [String]-> Picture u-multilabel _    _ _  _  []     = error $ -    "Wumpus.Core.Picture.multilabel - empty list."-multilabel attr n va pt (x:xs) = -    moveAll $ vsepA va n line1 (map mkPic xs)-  where-    line1     = mkPic x-    mkPic     = frame . textlabel attr zeroPt-    vdelta p  = boundaryHeight (boundary p) - boundaryHeight (boundary line1)-    moveAll p = moveV (vdelta p) $ p `at` pt  --------------------------------------------------------------------------------  mkEllipse :: Num u            => PSRgb -> DrawEllipse -> u -> u -> Point2 u -> Primitive u-mkEllipse c dp hw hh pt = PEllipse (c,dp) pt hw hh+mkEllipse c dp hw hh pt = PEllipse (c,dp) (PrimEllipse pt hw hh)   ellipseDefault :: EllipseProps@@ -489,3 +472,8 @@          posve n | n < 0     = 0             | otherwise = n ++picOver :: (Num u, Ord u) => Picture u -> Picture u -> Picture u+a `picOver` b = Picture (ortho zeroPt, bb) (mkList2 b a) +  where+    bb = union (boundary a) (boundary b)

@@ -30,6 +30,8 @@   , DPathSegment   , Label(..)   , DLabel+  , PrimEllipse(..)+  , DPrimEllipse    , PathProps                   -- hide in Wumpus.Core export?   , LabelProps                  -- hide in Wumpus.Core export?@@ -44,6 +46,8 @@      -- * Extras   , mapLocale+  , movePic+  , moveLocale   , extractFrame   , repositionProperties @@ -54,7 +58,6 @@ import Wumpus.Core.FontSize import Wumpus.Core.Geometry import Wumpus.Core.GraphicsState-import Wumpus.Core.PictureLanguage hiding ( hcat, vcat, hsep, vsep ) import Wumpus.Core.TextEncodingInternal import Wumpus.Core.Utils @@ -100,7 +103,7 @@ --  -- The additional constructors are convenience: ----- @PickBlank@ has a bounding box but no content and is useful for+-- @PicBlank@ 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.@@ -140,41 +143,50 @@ -- 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 -                    } +data Primitive u = PPath    PathProps    (Path u)+                 | PLabel   LabelProps   (Label u) +                 | PEllipse EllipseProps (PrimEllipse u)   deriving (Eq,Show)  type DPrimitive = Primitive Double  -+-- | Path - start point and a list of path segments.+-- 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)+-- | PathSegment - either a cubic Bezier curve or a line.+--  +data PathSegment u = PCurveTo  (Point2 u) (Point2 u) (Point2 u)+                   | PLineTo   (Point2 u)   deriving (Eq,Show)  type DPathSegment = PathSegment Double -data Label u = Label { -                   label_bottom_left :: Point2 u,-                   label_text        :: EncodedText-                 }+-- | Label - represented by bottom left corner and text.+--+data Label u = Label +      { label_bottom_left :: Point2 u+      , label_text        :: EncodedText+      }   deriving (Eq,Show)  type DLabel = Label Double +-- Ellipse represented by center and half_width * half_height+--+data PrimEllipse u = PrimEllipse +      { ellipse_center      :: Point2 u+      , ellipse_half_width  :: u+      , ellipse_half_height :: u +      } +  deriving (Eq,Show) +type DPrimEllipse = PrimEllipse Double+ -- | Note when drawn /filled/ and drawn /stroked/ the same  -- polygon will have (slightly) different size:  -- @@ -236,30 +248,33 @@ 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+  pretty (PEllipse _ e)     = pretty e    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 +  pretty (PCurveTo p1 p2 p3)    = text ".*" <> pretty p1 <> text ",," <> pretty p2                                            <> text "*." <> pretty p3-  pretty (PLine pt)           = text "--" <> pretty pt+  pretty (PLineTo pt)           = text "--" <> pretty pt  instance Pretty u => Pretty (Label u) where   pretty (Label pt s) = dquotes (pretty s) <> char '@' <> pretty pt +instance Pretty u => Pretty (PrimEllipse u) where+  pretty (PrimEllipse c w h) = pretty "ellipse" <+> pretty c+                                                <+> text "w:" <> pretty w+                                                <+> text "h:" <> pretty h + --------------------------------------------------------------------------------  -- | 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'))+  Path st xs `append` Path st' xs' = Path st (xs ++ (PLineTo st' : xs'))   instance Pointwise (Path u) where@@ -268,18 +283,20 @@  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)+  pointwise f (PLineTo p)         = PLineTo (f p)+  pointwise f (PCurveTo p1 p2 p3) = PCurveTo (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+type instance DUnit (Picture u)     = u+type instance DUnit (Primitive u)   = u+type instance DUnit (Path u)        = u+type instance DUnit (PrimEllipse u) = u + instance (Floating u, Real u) => Rotate (Picture u) where   rotate = rotatePicture  @@ -340,59 +357,14 @@     (bl,br,tr,tl) = corners bb  --------------------------------------------------------------------------------- --- 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, Ord 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 +      f (PLineTo p1)        acc  = p1 : acc+      f (PCurveTo p1 p2 p3) acc  = p1 : p2 : p3 : acc    -- Note - this will calculate a very bad bounding box for text.@@ -403,8 +375,14 @@   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) +  boundary (PEllipse _ e)               = boundary e+++instance (Fractional u, Ord u) => Boundary (PrimEllipse u) where+  boundary (PrimEllipse c hw hh)        = BBox (c .-^ v) (c .+^ v)      where v = V2 hw hh+ +   instance Boundary (Picture u) where

@@ -1,475 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Core.PictureLanguage--- Copyright   :  (c) Stephen Tetley 2009-2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC with TypeFamilies and more------ Type classes and derived functions to compose 2D /pictures/.------ The operations are fairly standard - see Regions in Paul --- Hudak\'s \'The Haskell School of Expression' and the pretty--- printing libraries wl-pprint and Text.PrettyPrint.HughesPJ --- (pretty printing combinators are some ways in \'One and a --- half D\' as they have horizontal operations but only carriage --- return in the vertical.--------------------------------------------------------------------------------------module Wumpus.Core.PictureLanguage -  (-  -- * Data types for alignment -    HAlign(..)-  , VAlign(..)--  -- * Type family and classes-  , PUnit -  , Horizontal(..)-  , Vertical(..)-  , Composite(..)-  , Move(..)-  , Blank(..)--  -- * Bounds-  -- $boundsdoc-  , center-  , topleft-  , topright-  , bottomleft-  , bottomright--  -- * Composition-  , ( -@- )-  , ( ->- )-  , ( -<- )-  , ( -//- )-  , above-  , below-  , at-  , centeredAt-  , stackOnto-  , hcat -  , vcat-  , stackOntoCenter--  , hspace-  , vspace-  , hsep-  , vsep- -  -- * Compose with alignment-  , alignH-  , alignV-  , hcatA-  , vcatA-  , hsepA-  , vsepA--  ) where--import Wumpus.Core.Geometry--import Data.AffineSpace--import Data.List ( foldl' )-------------------------------------------------------------------------------------- Data types---- Alignment---- | Horizontal alignment - align to the top, center or bottom.-data HAlign = HTop | HCenter | HBottom-  deriving (Eq,Show)---- | Vertical alignment - align to the left, center or bottom.-data VAlign = VLeft | VCenter | VRight-  deriving (Eq,Show)---------------------------------------------------------------------------------------- Type family and classes----- | The type of /points/ within a Picture.-type family PUnit a----- | > a `over` b--- --- Place \'picture\' a over b. The idea of @over@ here is the same--- as z-ordering in 2D design programs. Implementations of this --- class should \'draw\' picture a over b but move neither.--- --- Similarly @beneath@ should \'draw\' the first picture behind --- the second but move neither.------ Beneath has a default definition:------ > beneath = flip over----class Composite a where-  over    :: a -> a -> a-  beneath :: a -> a -> a--  beneath = flip over----- | Create a /picture/ that has no content but occupies space --- (i.e. it has a bounding box).-class Blank a where-  blank :: PUnit a -> PUnit a -> a----- | Move horizontally.-class Horizontal a where-  moveH      :: PUnit a -> a -> a-  leftBound  :: a -> PUnit a-  rightBound :: a -> PUnit a---- | Move vertically.-class Vertical a where-  moveV       :: PUnit a -> a -> a-  topBound    :: a -> PUnit a-  bottomBound :: a -> PUnit a---  --- | Move in both the horizontal and vertical.-class Move a where-  move :: PUnit a -> PUnit a -> a -> a----------------------------------------------------------------------------------------- Operations on bounds---- $boundsdoc--- Corresponding operations are available on bounding boxes - the --- definitions here have different type class obligations.---- | The center of a picture.-center :: (Horizontal a, Vertical a, Fractional u, u ~ PUnit a) => a -> Point2 u-center a = P2 hcenter vcenter where  -    hcenter = leftBound a   + 0.5 * (rightBound a - leftBound a)-    vcenter = bottomBound a + 0.5 * (topBound a   - bottomBound a)---- | Extract the top-left corner.-topleft       :: (Horizontal a, Vertical a, u ~ PUnit a) => a -> Point2 u-topleft a     = P2 (leftBound a)  (topBound a)---- | Extract the top-right corner.-topright      :: (Horizontal a, Vertical a, u ~ PUnit a) => a -> Point2 u-topright a    = P2 (rightBound a) (topBound a)---- | Extract the bottom-left corner.-bottomleft    :: (Horizontal a, Vertical a, u ~ PUnit a) => a -> Point2 u-bottomleft a  = P2 (leftBound a)  (bottomBound a)---- | Extract the bottom-right corner.-bottomright   :: (Horizontal a, Vertical a, u ~ PUnit a) => a -> Point2 u-bottomright a = P2 (rightBound a) (bottomBound a)------------------------------------------------------------------------------------- Internal helpers--leftmid       :: (Fractional u, Horizontal a, Vertical a, u ~ PUnit a) -              => a -> Point2 u-leftmid a     = P2 (leftBound a) (midpt (bottomBound a) (topBound a))--rightmid      :: (Fractional u, Horizontal a, Vertical a, u ~ PUnit a) -              => a -> Point2 u-rightmid a    = P2 (rightBound a) (midpt (bottomBound a) (topBound a))---topmid        :: (Fractional u, Horizontal a, Vertical a, u ~ PUnit a) -              => a -> Point2 u-topmid a      = P2 (midpt (leftBound a) (rightBound a)) (topBound a)--bottommid     :: (Fractional u, Horizontal a, Vertical a, u ~ PUnit a) -              => a -> Point2 u-bottommid a   = P2 (midpt (leftBound a) (rightBound a)) (bottomBound a)---midpt :: Fractional a => a -> a -> a-midpt a b = a + 0.5*(b-a)------------------------------------------------------------------------------------- Composition--infixr 5 -//-, `above`, `below`-infixr 6 ->-, -@------ | > a -@- b--- --- Center @a@ on top of @b@, @a@ is potentially moved and drawn --- 'over' @b@.----(-@-) :: (Horizontal a, Vertical a, Composite a, Move a, Fractional u, -             u ~ PUnit a)-         => a -> a -> a-p1 -@- p2 = (move x y p1) `over` p2 where V2 x y = center p2 .-. center p1----- | > a ->- b--- --- Horizontal composition - move @b@, placing it to the right --- of @a@.--- -(->-) :: (Horizontal a, Composite a, Num u, u ~ PUnit a) => a -> a -> a-a ->- b = a `over` (moveH disp b) where disp = rightBound a - leftBound b ---- | > a -<- b--- --- Horizontal composition - move @a@, placing it to the left --- of @b@.----(-<-) :: (Horizontal a, Composite a, Num u, u ~ PUnit a) => a -> a -> a-a -<- b = (moveH disp a) `over` b where disp = leftBound b - rightBound a----- | > a -//- b------ Vertical composition - move @b@, placing it below @a@.----(-//-) :: (Vertical a, Composite a, Num u, u ~ PUnit a) => a -> a -> a-a -//- b = a `over` (moveV disp b) where disp = bottomBound a - topBound b ----- | > a `below` b--- --- Vertical composition - move @a@, placing it below @b@----below :: (Vertical a, Composite a, Num u, u ~ PUnit a) => a -> a -> a-a `below` b = (moveV disp a) `over` b where disp = bottomBound a - topBound b------ | > a `above` b--- --- Vertical composition - move @a@, placing it above @b@.----above :: (Vertical a, Composite a, Num u, u ~ PUnit a) => a -> a -> a-a `above` b = (moveV disp a) `over` b where disp = topBound b - bottomBound a ----- | Place the picture at the supplied point.--- -at :: (Move a, u ~ PUnit a) => a -> Point2 u  -> a-p `at` (P2 x y) = move x y p---- | Center the picture at the supplied point.----centeredAt :: (Horizontal a, Vertical a, Move a, Composite a, Blank a, -               Fractional u, u ~ PUnit a) -           => a -> Point2 u -> a-centeredAt p pt = p -@- (blank 0 0 `at` pt) ------ | > xs `stackOnto` a--- --- Stack the list of pictures @xs@ 'over' @a@.------ Note, the first picture in the list is drawn at the top, the--- last picture is draw 'over' @a@.----stackOnto :: (Composite a) => [a] -> a -> a-stackOnto = flip (foldr over)---- | > x ->- xs--- --- Concatenate the list pictures @xs@ horizontally with @(->-)@ --- starting at @x@.--- -hcat :: (Horizontal a, Composite a, Num u, u ~ PUnit a)-     => a -> [a] -> a-hcat = foldl' (->-)---- | > x -//- xs--- --- Concatenate the list of pictures @xs@ vertically with @(-\/\/-)@ --- starting at @x@.----vcat :: (Vertical a, Composite a, Num u, u ~ PUnit a)-     => a -> [a] -> a-vcat = foldl' (-//-)------ | Stack pictures centered ontop of each other - the first --- picture in the list is drawn at the top, last picture is on --- drawn at the bottom.-stackOntoCenter :: (Horizontal a, Vertical a, Composite a, -                Move a, Fractional u,-                u ~ PUnit a)-            => [a] -> a -> a-stackOntoCenter = flip $ foldr (-@-)---------------------------------------------------------------------------------------- Helpers-blankH  :: (Num u, Blank a, u ~ PUnit a) => u -> a-blankH = blank `flip` 0--blankV  :: (Num u, Blank a, u ~ PUnit a) => u -> a-blankV = blank 0----- NOTE--- The following simple definition of hspace is invalid:------ > hspace n a b = a ->- (moveH n b)--- --- The movement due to @moveH n@ is annulled by the @->-@ --- operator which moves relative to the bounding box.--- --- The almost as simple definition below, seems to justify --- including Blank as a Picture constructor.-------- | > hspace n a b------ Concatenate the pictures @a@ and @b@ with @(->-)@ - injecting --- a space of @n@ units to separate the pictures.----hspace :: (Num u, Composite a, Horizontal a, Blank a, u ~ PUnit a) -       => u -> a -> a -> a-hspace n a b = a ->- blankH n ->- b---- | > vspace n a b------ Concatenate the pictures @a@ and @b@ with @(-\/\/-)@ - injecting --- a space of @n@ units to separate the pictures.----vspace :: (Num u, Composite a, Vertical a, Blank a, u ~ PUnit a) -       => u -> a -> a -> a-vspace n a b = a -//- blankV n -//-  b------ | > hsep n x xs------ Concatenate the list of pictures @xs@ horizontally with --- @hspace@ starting at @x@. The pictures are interspersed with --- spaces of @n@ units.----hsep :: (Num u, Composite a, Horizontal a, Blank a, u ~ PUnit a) -       => u -> a -> [a] -> a-hsep n = foldl' (hspace n)------ | > vsep n x xs------ Concatenate the list of pictures @xs@ vertically with --- @vspace@ starting at @x@. The pictures are interspersed with --- spaces of @n@ units.----vsep :: (Num u, Composite a, Vertical a, Blank a, u ~ PUnit a) -       => u -> a -> [a] -> a-vsep n = foldl' (vspace n)-------------------------------------------------------------------------------------- Aligning pictures----- | > alignH z a b------ Move picture @b@ up or down to be horizontally aligned along a --- line from the top, center or bottom of picture @a@--- -alignH :: ( Fractional u, Composite a, Horizontal a, Vertical a, Move a-          , u ~ PUnit a ) -       => HAlign -> a -> a -> a-alignH HTop    p1 p2 = vecMove p1 p2 (vvec $ topBound p1 - topBound p2)-alignH HBottom p1 p2 = vecMove p1 p2 (vvec $ bottomBound p1 - bottomBound p2)-alignH HCenter p1 p2 = vecMove p1 p2 (vvec v)-  where V2 _ v = rightmid p1    .-. leftmid p2----- | > alignV z a b------ Move picture @b@ left or right to be vertically aligned along a --- line from the left side, center or right side of picture @a@--- -alignV :: ( Fractional u, Composite a, Horizontal a, Vertical a, Move a-          , u ~ PUnit a ) -       => VAlign -> a -> a -> a-alignV VLeft   p1 p2 = vecMove p1 p2 (hvec $ leftBound p1 - leftBound p2) -alignV VRight  p1 p2 = vecMove p1 p2 (hvec $ rightBound p1 - rightBound p2)-alignV VCenter p1 p2 = vecMove p1 p2 (hvec h) -  where V2 h _ = bottommid p1   .-. topmid p2----- Helpers--vecMove :: (Composite a, Move a, u ~ PUnit a) => a -> a -> (Vec2 u) -> a -vecMove a b (V2 x y) = a `over` (move x y) b ---- Unlike alignH this function \"moves and concatenates\".-moveAlignH :: ( Fractional u, Composite a, Horizontal a, Vertical a, Move a-          , u ~ PUnit a ) -       => HAlign -> a -> a -> a-moveAlignH HTop    p1 p2 = vecMove p1 p2 (topright p1    .-. topleft p2)-moveAlignH HCenter p1 p2 = vecMove p1 p2 (rightmid p1    .-. leftmid p2)-moveAlignH HBottom p1 p2 = vecMove p1 p2 (bottomright p1 .-. bottomleft p2)----- Unlike alignV this function \"moves and concatenates\".-moveAlignV :: ( Fractional u, Composite a, Horizontal a, Vertical a, Move a-          , u ~ PUnit a ) -       => VAlign -> a -> a -> a-moveAlignV VLeft   p1 p2 = vecMove p1 p2 (bottomleft p1  .-. topleft p2)-moveAlignV VCenter p1 p2 = vecMove p1 p2 (bottommid p1   .-. topmid p2)-moveAlignV VRight  p1 p2 = vecMove p1 p2 (bottomright p1 .-. topright p2)----- | Variant of 'hcat' that aligns the pictures as well as--- concatenating them.-hcatA :: ( Fractional u, Horizontal a, Vertical a-         , Composite a, Move a, u ~ PUnit a)-     => HAlign -> a -> [a] -> a-hcatA ha = foldl' (moveAlignH ha)---- | Variant of 'vcat' that aligns the pictures as well as--- concatenating them.-vcatA :: ( Fractional u, Horizontal a, Vertical a-         , Composite a, Move a, u ~ PUnit a)-     => VAlign -> a -> [a] -> a-vcatA va = foldl' (moveAlignV va)----- | Variant of @hsep@ that aligns the pictures as well as--- concatenating and spacing them.-hsepA :: ( Fractional u, Horizontal a, Vertical a-         , Composite a, Move a, Blank a, u ~ PUnit a)-     => HAlign -> u -> a -> [a] -> a-hsepA ha n = foldl' op where -   a `op` b = moveAlignH ha (moveAlignH ha a (blankH n)) b ---- | Variant of @vsep@ that aligns the pictures as well as--- concatenating and spacing them.-vsepA :: ( Fractional u, Horizontal a, Vertical a-         , Composite a, Move a, Blank a, u ~ PUnit a)-     => VAlign -> u -> a -> [a] -> a-vsepA va n = foldl' op where -   a `op` b = moveAlignV va (moveAlignV va a (blankV n)) b -

@@ -81,8 +81,7 @@ import Control.Monad ( ap ) import Data.List ( intersperse ) import Data.Ratio-import System.Time -+import Data.Time   @@ -197,22 +196,27 @@ 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+mkTimeStamp = getZonedTime >>= return . format . zonedTimeToLocalTime   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 ]+    format t  = mkTime t ++ " " ++ mkDate t+    mkTime = concat . intersperse ":" . sequenceA tfuns . localTimeOfDay+    mkDate = showGregorian . localDay+    tfuns  = [ pad2 . todHour, pad2 . todMin, pad2 . floori . todSec ]     pad2 i | i < 10    = '0' : show i            | otherwise = show i   +floori :: RealFrac a => a -> Int+floori = floor ++--------------------------------------------------------------------------------  -- | Enclose string in parens. parens :: String -> String 

@@ -22,4 +22,4 @@   wumpus_core_version :: (Int,Int,Int)-wumpus_core_version = (0,16,0)+wumpus_core_version = (0,17,0)

@@ -0,0 +1,51 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.WumpusTypes+-- Copyright   :  (c) Stephen Tetley 2009-2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  unstable +-- Portability :  GHC with TypeFamilies and more+--+-- This module re-exports types and functions from +-- "Wumpus.Core.PictureInternal" but makes them opaque. ++-- +--------------------------------------------------------------------------------+++-- Having this module just re-exporting types should make +-- the Haddock documentation more cohesive. Modules+-- in wumpus-core should not use this module.+++module Wumpus.Core.WumpusTypes+  (++  -- * Picture types+    Picture+  , DPicture+  , Primitive+  , DPrimitive+  , Path+  , DPath+  , PathSegment+  , DPathSegment+  , Label+  , DLabel++  -- * Drawing styles+  , PathProps                   -- Better hidden?+  , LabelProps                  --      "+  , EllipseProps                --      "+  , DrawPath                    --      "+  , DrawEllipse                 --      "++  ) where+++import Wumpus.Core.PictureInternal+

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

@@ -1,5 +1,5 @@ name:             wumpus-core-version:          0.16.0+version:          0.17.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -20,7 +20,7 @@   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 +  applied to 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@@ -30,23 +30,33 @@   that are not really part of the \"core\", but they provide    lists of named colours and fonts.   .-  THE DRAWBACKS...+  WARNING...   .+  wumpus-core is likely to change quite a bit with the next +  revision as I want to see if I can make Primitives +  support affine translations. Hopefully this will not change +  the API significantly though it will mean the generated +  SVG and PostScript files will be different (possibly +  clearer). Also the Core.BoundingBox module is not too well+  designed, too many functions that do not offer distinct+  functionality. Some functionality was removed in this revision+  (0.17.0) and more is likely to follow. +  .+  GENERAL DRAWBACKS...+  .   For actually drawing pictures, diagrams, etc. Wumpus is very    low level. I\'ve worked on a complementary package    @wumpus-extra@ with higher-level stuff (polygons, arrows etc.)   but it is too unstable for Hackage. Preview releases can be   found at <http://code.google.com/p/copperbox/> though.   .-  Wumpus-core should be fairly stable from now on. 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 +  Some of the design decisions made for wumpus-core are not +  sophisticated (e.g. how attributes like colour are    handled, and how the bounding boxes of text labels are    calculated), so Wumpus might be limited compared to other    systems. However its design permits a simple implementation - -  which is a priority. Text encoding an exception, I\'m not sure -  how reasonable the design is. The current implementation +  which is a priority. Text encoding an exception - I\'m not +  sure how reasonable the design is. The current implementation    appears okay for Latin 1 but I\'m not sure about other    character sets, and I may have to revise it significantly.   .@@ -63,6 +73,33 @@   convert Wumpus'\s EPS files to many other formats (bitmaps).    .   Changelog:+  .+  0.16.0 to 0.17.0:+  .+  * Added Core.WumpusTypes to export opaque versions of+    datatypes from Core.PictureInternal. This should make+    the Haddock documentation more cohesive.+  . +  * Moved the Core.PictureLanguage module into the Extra+    namespace (Extra.PictureLanguage). This module change+    in detail, if not in spirit in the future as I'm not +    to happy with it. Also this model is somewhat +    \"higher-level\" than the modules in wumpus-core, so +    a different home seems fitting. +  . +  * Removed CardinalPoint and boundaryPoint from BoundingBox.+  .+  * Argument order of 'textlabel' and 'ztextlabel' changed so+    that Point2 is the last argument.+  .+  * PathSegment constructor names changed - this is an internal+    change as the constructors are not exported.+  .+  * Primitive type changed - moved Ellipse properties into +    PrimEllipse type - internal change.+  .+  * Removed dependency on \'old-time\'.+  .   0.15.0 to 0.16.0:   .   * Additions to Core.Geometry (direction, pvec, vangle, @@ -84,13 +121,7 @@   .     * Added centeredAt to PictureLanguage   .-  0.14.0 to 0.15.0:   .-  * Added Named colours and \"safe fonts\" from wumpus-extra.-  .-  * Added wumpus_core_version to track version number.-  .-  . build-type:         Simple stability:          unstable cabal-version:      >= 1.2@@ -110,7 +141,8 @@  library   hs-source-dirs:     src-  build-depends:      base < 5, containers, old-time,+  build-depends:      base < 5, containers,+                      time >= 1.1.3 && < 1.2,                       wl-pprint, vector-space,                        monadLib, xml, algebra                         @@ -125,10 +157,11 @@     Wumpus.Core.OutputPostScript,     Wumpus.Core.OutputSVG,     Wumpus.Core.Picture,-    Wumpus.Core.PictureLanguage,     Wumpus.Core.TextEncoder,     Wumpus.Core.TextLatin1,     Wumpus.Core.VersionNumber,+    Wumpus.Core.WumpusTypes,+    Wumpus.Extra.PictureLanguage,     Wumpus.Extra.SafeFonts,     Wumpus.Extra.SVGColours,     Wumpus.Extra.X11Colours