wumpus-core 0.17.0 → 0.18.0

raw patch · 22 files changed

+1255/−176 lines, 22 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGES +50/−1
• demo/AffineTest01.hs +100/−0
• demo/AffineTest02.hs +99/−0
• demo/AffineTest03.hs +99/−0
• demo/AffineTest04.hs +99/−0
• demo/AffineTestBase.hs +186/−0
• demo/FontPic.hs +3/−0
• demo/LabelPic.hs +8/−6
• demo/Picture.hs +6/−5
• doc-src/WorldFrame.eps +0/−40
• doc-src/WorldFrame.hs +37/−0
• src/Wumpus/Core/BoundingBox.hs +16/−0
• src/Wumpus/Core/Colour.hs +29/−0
• src/Wumpus/Core/Geometry.hs +24/−0
• src/Wumpus/Core/OutputPostScript.hs +15/−11
• src/Wumpus/Core/OutputSVG.hs +28/−16
• src/Wumpus/Core/Picture.hs +148/−15
• src/Wumpus/Core/PictureInternal.hs +195/−30
• src/Wumpus/Core/Utils.hs +33/−16
• src/Wumpus/Core/VersionNumber.hs +1/−1
• src/Wumpus/Extra/PictureLanguage.hs +4/−4
• wumpus-core.cabal +75/−31

@@ -1,6 +1,55 @@+0.17.0 to 0.18.0:+  +  * Added instances of the affine operation classes (Scale, +    Rotate ...) for Primitives (path, text label, ellipse).++  * Added some picture composition functions to Core.Picture.+    These are useful for testing where the type class +    complications of Extra.PictureLanguage are an overhead.  ++  * Added iRGB to Core.Colour - create RGB colours with +    integer components [0..255] - and iHSB, iGrey.++  * Added some test modules for the affine transformations.+    These illustrate a quirk in Wumpus where, under affine +    transformation, Pictures may generate a larger bounding box +    than composite primitives.++  * Minor change - ztextlabal changed to use 24pt type rather +    than 12pt. ++  * Corrected the cabal file to include the correct files for +    the manual. The Haskell source file @WorldFrame.hs@ was +    missing with the generated file @WorldFrame.eps@ incorrectly +    included instead.++ 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 may change+    in detail, if not in spirit in the future as I'm not +    very happy with it. Also this module 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: 

@@ -0,0 +1,100 @@+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- ROTATE tests
+--------------------------------------------------------------------------------
+
+module AffineTest01 where
+
+
+import AffineTestBase
+import Wumpus.Core
+
+
+main :: IO ()
+main = runAlgs [ text_ata, circle_ata, ellipse_ata, path_ata ]
+               [ circle_cpa, ellipse_cpa, path_cpa ]
+
+
+rot30 :: (Rotate t, Fractional u, u ~ DUnit t) => t -> t
+rot30 = rotate30
+
+-- Primitive - Text
+
+
+text_ata :: AffineTrafoAlg
+text_ata = AffineTrafoAlg
+    { ata_console_msg       = "Rotate text..."
+    , ata_eps_file          = "./out/affine_test/rotate_text.eps"
+    , ata_svg_file          = "./out/affine_test/rotate_text.svg"
+    , ata_prim_constructor  = rgbLabel
+    , ata_pic_transformer   = rot30
+    , ata_prim_transformer  = rot30
+    }
+
+circle_ata :: AffineTrafoAlg
+circle_ata = AffineTrafoAlg 
+    { ata_console_msg       = "Rotate circle..."
+    , ata_eps_file          = "./out/affine_test/rotate_circle.eps"
+    , ata_svg_file          = "./out/affine_test/rotate_circle.svg"
+    , ata_prim_constructor  = rgbCircle
+    , ata_pic_transformer   = rot30
+    , ata_prim_transformer  = rot30
+    }
+
+
+ellipse_ata :: AffineTrafoAlg
+ellipse_ata = AffineTrafoAlg
+    { ata_console_msg       = "Rotate ellipse..."
+    , ata_eps_file          = "./out/affine_test/rotate_ellipse.eps"
+    , ata_svg_file          = "./out/affine_test/rotate_ellipse.svg"
+    , ata_prim_constructor  = rgbEllipse
+    , ata_pic_transformer   = rot30
+    , ata_prim_transformer  = rot30
+    }
+
+path_ata :: AffineTrafoAlg
+path_ata = AffineTrafoAlg
+    { ata_console_msg       = "Rotate path..."
+    , ata_eps_file          = "./out/affine_test/rotate_path.eps"
+    , ata_svg_file          = "./out/affine_test/rotate_path.svg"
+    , ata_prim_constructor  = rgbPath
+    , ata_pic_transformer   = rot30
+    , ata_prim_transformer  = rot30
+    }
+
+
+--------------------
+--------------------
+
+circle_cpa :: ControlPointAlg
+circle_cpa = ControlPointAlg 
+    { cpa_console_msg       = "Rotate circle (control points) ..."
+    , cpa_eps_file          = "./out/affine_test/rotate_crc_cp.eps"
+    , cpa_svg_file          = "./out/affine_test/rotate_crc_cp.svg"
+    , cpa_prim_constructor  = rgbCircle
+    , cpa_prim_transformer  = rot30
+    }
+
+
+
+ellipse_cpa :: ControlPointAlg
+ellipse_cpa = ControlPointAlg 
+    { cpa_console_msg       = "Rotate ellipse (control points) ..."
+    , cpa_eps_file          = "./out/affine_test/rotate_ell_cp.eps"
+    , cpa_svg_file          = "./out/affine_test/rotate_ell_cp.svg"
+    , cpa_prim_constructor  = rgbEllipse
+    , cpa_prim_transformer  = rot30
+    }
+
+
+path_cpa :: ControlPointAlg
+path_cpa = ControlPointAlg 
+    { cpa_console_msg       = "Rotate path (control points)..."
+    , cpa_eps_file          = "./out/affine_test/rotate_path_cp.eps"
+    , cpa_svg_file          = "./out/affine_test/rotate_path_cp.svg"
+    , cpa_prim_constructor  = rgbPath
+    , cpa_prim_transformer  = rot30 
+    }
+

@@ -0,0 +1,99 @@+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- SCALE tests
+--------------------------------------------------------------------------------
+
+
+module AffineTest02 where
+
+import AffineTestBase
+import Wumpus.Core
+
+main :: IO ()
+main = runAlgs [ text_ata, circle_ata, ellipse_ata, path_ata ]
+               [ circle_cpa, ellipse_cpa, path_cpa ]
+
+
+scale_onehalf_x_two :: (Scale t, Fractional u, u ~ DUnit t) => t -> t
+scale_onehalf_x_two = scale 1.5 2.0
+
+-- Primitive - Text
+
+
+text_ata :: AffineTrafoAlg
+text_ata = AffineTrafoAlg
+    { ata_console_msg       = "Scaled text..."
+    , ata_eps_file          = "./out/affine_test/scale_text.eps"
+    , ata_svg_file          = "./out/affine_test/scale_text.svg"
+    , ata_prim_constructor  = rgbLabel
+    , ata_pic_transformer   = scale_onehalf_x_two
+    , ata_prim_transformer  = scale_onehalf_x_two
+    }
+
+circle_ata :: AffineTrafoAlg
+circle_ata = AffineTrafoAlg 
+    { ata_console_msg       = "Scaled circle..."
+    , ata_eps_file          = "./out/affine_test/scale_circle.eps"
+    , ata_svg_file          = "./out/affine_test/scale_circle.svg"
+    , ata_prim_constructor  = rgbCircle
+    , ata_pic_transformer   = scale_onehalf_x_two
+    , ata_prim_transformer  = scale_onehalf_x_two
+    }
+
+
+ellipse_ata :: AffineTrafoAlg
+ellipse_ata = AffineTrafoAlg
+    { ata_console_msg       = "Scaled ellipse..."
+    , ata_eps_file          = "./out/affine_test/scale_ellipse.eps"
+    , ata_svg_file          = "./out/affine_test/scale_ellipse.svg"
+    , ata_prim_constructor  = rgbEllipse
+    , ata_pic_transformer   = scale_onehalf_x_two
+    , ata_prim_transformer  = scale_onehalf_x_two
+    }
+
+path_ata :: AffineTrafoAlg
+path_ata = AffineTrafoAlg
+    { ata_console_msg       = "Scaled path..."
+    , ata_eps_file          = "./out/affine_test/scale_path.eps"
+    , ata_svg_file          = "./out/affine_test/scale_path.svg"
+    , ata_prim_constructor  = rgbPath
+    , ata_pic_transformer   = scale_onehalf_x_two
+    , ata_prim_transformer  = scale_onehalf_x_two
+    }
+
+
+--------------------
+--------------------
+
+circle_cpa :: ControlPointAlg
+circle_cpa = ControlPointAlg 
+    { cpa_console_msg       = "Scaled circle (control points) ..."
+    , cpa_eps_file          = "./out/affine_test/scale_crc_cp.eps"
+    , cpa_svg_file          = "./out/affine_test/scale_crc_cp.svg"
+    , cpa_prim_constructor  = rgbCircle
+    , cpa_prim_transformer  = scale_onehalf_x_two
+    }
+
+
+
+ellipse_cpa :: ControlPointAlg
+ellipse_cpa = ControlPointAlg 
+    { cpa_console_msg       = "Scaled ellipse (control points) ..."
+    , cpa_eps_file          = "./out/affine_test/scale_ell_cp.eps"
+    , cpa_svg_file          = "./out/affine_test/scale_ell_cp.svg"
+    , cpa_prim_constructor  = rgbEllipse
+    , cpa_prim_transformer  = scale_onehalf_x_two
+    }
+
+
+path_cpa :: ControlPointAlg
+path_cpa = ControlPointAlg 
+    { cpa_console_msg       = "Path (control points)..."
+    , cpa_eps_file          = "./out/affine_test/scale_path_cp.eps"
+    , cpa_svg_file          = "./out/affine_test/scale_path_cp.svg"
+    , cpa_prim_constructor  = rgbPath
+    , cpa_prim_transformer  = scale_onehalf_x_two
+    }
+

@@ -0,0 +1,99 @@+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- TRANSLATE tests
+--------------------------------------------------------------------------------
+
+module AffineTest03 where
+
+
+import AffineTestBase
+import Wumpus.Core
+
+main :: IO ()
+main = runAlgs [ text_ata, circle_ata, ellipse_ata, path_ata ]
+               [ circle_cpa, ellipse_cpa, path_cpa ]
+
+
+translate_20x40 :: (Translate t, Fractional u, u ~ DUnit t) => t -> t
+translate_20x40 = translate 20.0 40.0
+
+-- Primitive - Text
+
+
+text_ata :: AffineTrafoAlg
+text_ata = AffineTrafoAlg
+    { ata_console_msg       = "Translate text..."
+    , ata_eps_file          = "./out/affine_test/trans_text.eps"
+    , ata_svg_file          = "./out/affine_test/trans_text.svg"
+    , ata_prim_constructor  = rgbLabel
+    , ata_pic_transformer   = translate_20x40
+    , ata_prim_transformer  = translate_20x40
+    }
+
+circle_ata :: AffineTrafoAlg
+circle_ata = AffineTrafoAlg 
+    { ata_console_msg       = "Translate circle..."
+    , ata_eps_file          = "./out/affine_test/trans_circle.eps"
+    , ata_svg_file          = "./out/affine_test/trans_circle.svg"
+    , ata_prim_constructor  = rgbCircle
+    , ata_pic_transformer   = translate_20x40
+    , ata_prim_transformer  = translate_20x40
+    }
+
+
+ellipse_ata :: AffineTrafoAlg
+ellipse_ata = AffineTrafoAlg
+    { ata_console_msg       = "Translate ellipse..."
+    , ata_eps_file          = "./out/affine_test/trans_ellipse.eps"
+    , ata_svg_file          = "./out/affine_test/trans_ellipse.svg"
+    , ata_prim_constructor  = rgbEllipse
+    , ata_pic_transformer   = translate_20x40
+    , ata_prim_transformer  = translate_20x40
+    }
+
+path_ata :: AffineTrafoAlg
+path_ata = AffineTrafoAlg
+    { ata_console_msg       = "Translate path..."
+    , ata_eps_file          = "./out/affine_test/trans_path.eps"
+    , ata_svg_file          = "./out/affine_test/trans_path.svg"
+    , ata_prim_constructor  = rgbPath
+    , ata_pic_transformer   = translate_20x40
+    , ata_prim_transformer  = translate_20x40
+    }
+
+
+--------------------
+--------------------
+
+circle_cpa :: ControlPointAlg
+circle_cpa = ControlPointAlg 
+    { cpa_console_msg       = "Translate circle (control points) ..."
+    , cpa_eps_file          = "./out/affine_test/trans_crc_cp.eps"
+    , cpa_svg_file          = "./out/affine_test/trans_crc_cp.svg"
+    , cpa_prim_constructor  = rgbCircle
+    , cpa_prim_transformer  = translate_20x40
+    }
+
+
+
+ellipse_cpa :: ControlPointAlg
+ellipse_cpa = ControlPointAlg 
+    { cpa_console_msg       = "Translate ellipse (control points) ..."
+    , cpa_eps_file          = "./out/affine_test/trans_ell_cp.eps"
+    , cpa_svg_file          = "./out/affine_test/trans_ell_cp.svg"
+    , cpa_prim_constructor  = rgbEllipse
+    , cpa_prim_transformer  = translate_20x40
+    }
+
+
+path_cpa :: ControlPointAlg
+path_cpa = ControlPointAlg 
+    { cpa_console_msg       = "Translate path (control points)..."
+    , cpa_eps_file          = "./out/affine_test/trans_path_cp.eps"
+    , cpa_svg_file          = "./out/affine_test/trans_path_cp.svg"
+    , cpa_prim_constructor  = rgbPath
+    , cpa_prim_transformer  = translate_20x40 
+    }
+

@@ -0,0 +1,99 @@+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- ROTATE_ABOUT tests
+--------------------------------------------------------------------------------
+
+module AffineTest04 where
+
+
+import AffineTestBase
+import Wumpus.Core
+
+main :: IO ()
+main = runAlgs [ text_ata, circle_ata, ellipse_ata, path_ata ]
+               [ circle_cpa, ellipse_cpa, path_cpa ]
+
+
+rot30_about_origin :: (RotateAbout t, Fractional u, u ~ DUnit t) => t -> t
+rot30_about_origin = rotate30About zeroPt
+
+-- Primitive - Text
+
+
+text_ata :: AffineTrafoAlg
+text_ata = AffineTrafoAlg
+    { ata_console_msg       = "Rotation about point, text..."
+    , ata_eps_file          = "./out/affine_test/rotate_about_text.eps"
+    , ata_svg_file          = "./out/affine_test/rotate_about_text.svg"
+    , ata_prim_constructor  = rgbLabel
+    , ata_pic_transformer   = rot30_about_origin
+    , ata_prim_transformer  = rot30_about_origin
+    }
+
+circle_ata :: AffineTrafoAlg
+circle_ata = AffineTrafoAlg 
+    { ata_console_msg       = "Rotation about point, circle..."
+    , ata_eps_file          = "./out/affine_test/rotate_about_circle.eps"
+    , ata_svg_file          = "./out/affine_test/rotate_about_circle.svg"
+    , ata_prim_constructor  = rgbCircle
+    , ata_pic_transformer   = rot30_about_origin
+    , ata_prim_transformer  = rot30_about_origin
+    }
+
+
+ellipse_ata :: AffineTrafoAlg
+ellipse_ata = AffineTrafoAlg
+    { ata_console_msg       = "Rotation about point, ellipse..."
+    , ata_eps_file          = "./out/affine_test/rotate_about_ellipse.eps"
+    , ata_svg_file          = "./out/affine_test/rotate_about_ellipse.svg"
+    , ata_prim_constructor  = rgbEllipse
+    , ata_pic_transformer   = rot30_about_origin
+    , ata_prim_transformer  = rot30_about_origin
+    }
+
+path_ata :: AffineTrafoAlg
+path_ata = AffineTrafoAlg
+    { ata_console_msg       = "Rotation about point, path..."
+    , ata_eps_file          = "./out/affine_test/rotate_about_path.eps"
+    , ata_svg_file          = "./out/affine_test/rotate_about_path.svg"
+    , ata_prim_constructor  = rgbPath
+    , ata_pic_transformer   = rot30_about_origin
+    , ata_prim_transformer  = rot30_about_origin
+    }
+
+
+--------------------
+--------------------
+
+circle_cpa :: ControlPointAlg
+circle_cpa = ControlPointAlg 
+    { cpa_console_msg       = "Rotation about point, circle (control points) ..."
+    , cpa_eps_file          = "./out/affine_test/rotate_about_crc_cp.eps"
+    , cpa_svg_file          = "./out/affine_test/rotate_about_crc_cp.svg"
+    , cpa_prim_constructor  = rgbCircle
+    , cpa_prim_transformer  = rot30_about_origin
+    }
+
+
+
+ellipse_cpa :: ControlPointAlg
+ellipse_cpa = ControlPointAlg 
+    { cpa_console_msg       = "Rotation about point, ellipse (control points) ..."
+    , cpa_eps_file          = "./out/affine_test/rotate_about_ell_cp.eps"
+    , cpa_svg_file          = "./out/affine_test/rotate_about_ell_cp.svg"
+    , cpa_prim_constructor  = rgbEllipse
+    , cpa_prim_transformer  = rot30_about_origin
+    }
+
+
+path_cpa :: ControlPointAlg
+path_cpa = ControlPointAlg 
+    { cpa_console_msg       = "Rotation about point, path (control points)..."
+    , cpa_eps_file          = "./out/affine_test/rotate_about_path_cp.eps"
+    , cpa_svg_file          = "./out/affine_test/rotate_about_path_cp.svg"
+    , cpa_prim_constructor  = rgbPath
+    , cpa_prim_transformer  = rot30_about_origin 
+    }
+

@@ -0,0 +1,186 @@+{-# OPTIONS -Wall #-}
+
+-- Common machinery for the affine tests.
+
+module AffineTestBase 
+  ( 
+    -- * test common code
+    runAlgs
+  , AffineTrafoAlg(..)
+  , ControlPointAlg(..)
+
+  , rgbLabel
+  , rgbCircle
+  , rgbEllipse
+  , rgbPath
+
+  ) where
+
+
+import Wumpus.Core
+import Wumpus.Core.Colour ( black, red, blue )
+
+
+
+import System.Directory
+
+
+light_blue :: DRGB
+light_blue = iRGB3 176 224 231
+
+
+runAlgs :: [AffineTrafoAlg] -> [ControlPointAlg] -> IO ()
+runAlgs ats cps = mkDirs >> mapM_ runATA ats >> mapM_ runCPA cps
+  where
+    mkDirs = createDirectoryIfMissing True "./out/affine_test/"
+
+
+data AffineTrafoAlg = AffineTrafoAlg
+      { ata_console_msg         :: String
+      , ata_eps_file            :: FilePath
+      , ata_svg_file            :: FilePath
+      , ata_prim_constructor    :: DRGB -> DPrimitive
+      , ata_pic_transformer     :: DPicture -> DPicture
+      , ata_prim_transformer    :: DPrimitive -> DPrimitive
+      }
+
+runATA :: AffineTrafoAlg -> IO ()
+runATA ata = do 
+    { putStrLn $ ata_console_msg ata
+    ; writeEPS_latin1 (ata_eps_file ata) pic
+    ; writeSVG_latin1 (ata_svg_file ata) pic 
+    }
+  where
+    pic = buildPictureATA (ata_prim_constructor ata) 
+                          (ata_pic_transformer  ata)
+                          (ata_prim_transformer ata)
+
+
+buildPictureATA :: (DRGB -> DPrimitive) 
+         -> (DPicture -> DPicture) 
+         -> (DPrimitive -> DPrimitive) 
+         -> DPicture
+buildPictureATA mk picF primF = 
+    picture1 `picBeside` picture2 `picBeside` picture3
+  where
+    picture1 :: DPicture
+    picture1 = illustrateBounds light_blue $ frame $ (mk black)
+  
+    picture2 :: DPicture
+    picture2 = illustrateBounds light_blue $ picF $ frame $ (mk blue)
+
+    picture3 :: DPicture
+    picture3 = illustrateBoundsPrim light_blue $ prim
+      where
+        prim :: DPrimitive
+        prim = primF $ mk red
+
+
+
+
+
+--------------------------------------------------------------------------------
+
+data ControlPointAlg = ControlPointAlg
+      { cpa_console_msg         :: String
+      , cpa_eps_file            :: FilePath
+      , cpa_svg_file            :: FilePath
+      , cpa_prim_constructor    :: DRGB -> DPrimitive
+      , cpa_prim_transformer    :: DPrimitive -> DPrimitive 
+      }
+
+runCPA :: ControlPointAlg -> IO ()
+runCPA cpa = do 
+    { putStrLn $ cpa_console_msg cpa
+    ; writeEPS_latin1 (cpa_eps_file cpa) pic
+    ; writeSVG_latin1 (cpa_svg_file cpa) pic
+    }
+  where
+    pic = cpPicture (cpa_prim_constructor cpa) (cpa_prim_transformer cpa)
+
+cpPicture :: (DRGB -> DPrimitive) -> (DPrimitive -> DPrimitive) -> DPicture
+cpPicture constr trafo = 
+    illustrateBounds light_blue $ illustrateControlPoints black 
+                                $ transformed_prim
+  where
+   transformed_prim :: DPrimitive
+   transformed_prim = trafo $ constr red
+
+
+--------------------------------------------------------------------------------
+
+rgbLabel :: DRGB -> DPrimitive
+rgbLabel rgb = textlabel rgb "Wumpus!" zeroPt
+
+rgbCircle :: DRGB -> DPrimitive
+rgbCircle rgb = ellipse rgb 60 60 zeroPt
+
+rgbEllipse :: DRGB -> DPrimitive
+rgbEllipse rgb = ellipse rgb 60 30 zeroPt
+
+rgbPath :: DRGB -> DPrimitive
+rgbPath rgb = ostroke rgb $ dog_kennel
+
+
+--------------------------------------------------------------------------------
+-- Hughes Lists for Hughes Paths
+
+-- At some point /wumpus-extra/ will have code along these lines...
+
+type H a = [a] -> [a]
+
+emptyH :: H a
+emptyH = id
+
+snocH :: H a -> a -> H a
+snocH hf a = hf . (a:)
+
+toListH :: H a -> [a]
+toListH = ($ [])
+
+
+
+--------------------------------------------------------------------------------
+-- /Hughes/ paths
+
+
+type HPath u = (Point2 u, H (PathSegment u))
+
+makePath :: HPath u -> Path u
+makePath (s,hf) = path s (toListH hf)
+
+
+start_path :: (u,u) -> HPath u
+start_path (x,y) = (P2 x y, emptyH)
+
+infixl 6 `line_to`, `curve_to`
+
+line_to :: HPath u -> (u,u) -> HPath u
+line_to (s,f) (x,y) = (s, f `snocH` lineTo (P2 x y))
+
+curve_to :: HPath u -> ((u,u),(u,u),(u,u)) -> HPath u
+curve_to (s,f) ((c1x,c1y),(c2x,c2y),(ex,ey)) = 
+    (s, f `snocH` curveTo (P2 c1x c1y) (P2 c2x c2y) (P2 ex ey))
+
+
+--
+-- vertical (length) & horizontal (length) might
+-- be handy...
+-- 
+-- But we would need to track current position, vis-a-vis a 
+-- state monad, so this is taking things towards a big module.
+--
+--
+
+--------------------------------------------------------------------------------
+-- Demo - draw a dog kennel...
+
+dog_kennel :: DPath
+dog_kennel = makePath $ 
+    start_path (0,0) `line_to`  (0,60)   `line_to` (40,100)
+                     `line_to`  (80,60)  `line_to` (80,0)
+                     `line_to`  (60,0)   `line_to` (60,30)
+                     `curve_to` ((60,50), (50,60), (40,60))
+                     `curve_to` ((30,60), (20,50), (20,30))
+                     `line_to`  (20,0)
+                        

@@ -13,8 +13,11 @@  import Data.List ( unfoldr ) +import System.Directory+ main :: IO () main = do +    createDirectoryIfMissing True "./out/"     writeEPS_latin1 "./out/font_courier.eps"   courier_pic     writeSVG_latin1 "./out/font_courier.svg"   courier_pic     writeEPS_latin1 "./out/font_times.eps"     times_pic

@@ -5,11 +5,13 @@ import Wumpus.Core import Wumpus.Extra.PictureLanguage +import System.Directory+ --------------------------------------------------------------------------------   -drawBounds :: (Fractional u, Ord u) => Picture u -> Picture u+drawBounds :: (Fractional u, Floating u, Ord u) => Picture u -> Picture u drawBounds p        = p `over` (frame $ cstroke () ph)    where     ph            = vertexPath $ [bl,br,tr,tl]@@ -151,8 +153,8 @@   main :: IO ()-main = sequence_-  [ demo01, demo02, demo03, demo04, demo05-  , demo06, demo07, demo08, demo09, demo10-  , demo11-  ]  +main = do +  createDirectoryIfMissing True "./out/"+  sequence_ [ demo01, demo02, demo03, demo04, demo05+            , demo06, demo07, demo08, demo09, demo10+            , demo11 ]  

@@ -5,6 +5,7 @@ import Wumpus.Core import Wumpus.Extra.PictureLanguage +import System.Directory  peru :: PSRgb peru = RGB3 0.804  0.522  0.247@@ -197,8 +198,8 @@   main :: IO ()-main = sequence_-  [ demo01, demo02, demo03, demo04, demo05-  , demo06, demo07, demo08, demo09, demo10-  , demo11, demo12, demo13, demo14-  ]+main = do +    createDirectoryIfMissing True "./out/"+    sequence_  [ demo01, demo02, demo03, demo04, demo05+               , demo06, demo07, demo08, demo09, demo10+               , demo11, demo12, demo13, demo14 ]

@@ -1,40 +0,0 @@-%!PS-Adobe-3.0 EPSF-3.0
-%%BoundingBox: 4 4 117 97
-%%CreationDate: (13:27:26 5 May 2010)
-%%EndComments
-gsave
-4.0 5.40625 translate
-[0.75 0.0 0.0 0.75 0.0 0.0] concat
-/Helvetica findfont
-10 scalefont
-setfont
-0.0 0.0 moveto
-((0,0)) show
-96.0 0.0 moveto
-((100,0)) show
-0.0 114.0 moveto
-((0,100)) show
-96.0 114.0 moveto
-((100,100)) show
-0.5 setlinewidth
-newpath
-10.0 10.0 moveto
-110.0 10.0 lineto
-stroke
-1.0 setlinewidth
-0.5 setlinewidth
-newpath
-10.0 10.0 moveto
-10.0 110.0 lineto
-stroke
-1.0 setlinewidth
-1.5 setlinewidth
-newpath
-11.0 11.0 moveto
-110.0 110.0 lineto
-stroke
-1.0 setlinewidth
-[1.333333 0.0 0.0 1.333333 0.0 0.0] concat
-grestore
-showpage
-%%EOF

@@ -0,0 +1,37 @@+{-# OPTIONS -Wall #-}++module WorldFrame where++import Wumpus.Core+import Wumpus.Core.Colour ( black )+++main :: IO ()+main = writeEPS_latin1 "WorldFrame.eps" world_frame++world_frame :: DPicture+world_frame = uniformScale 0.75 $ +    frameMulti [ ogin, btm_right, top_left, top_right+               , x_axis, y_axis, line1+               ]+  where+    ogin      = makeLabelPrim "(0,0)"     (P2 0  0)+    btm_right = makeLabelPrim "(100,0)"   (P2 96 0)+    top_left  = makeLabelPrim "(0,100)"   (P2 0  114)+    top_right = makeLabelPrim "(100,100)" (P2 96 114)+    +    x_axis    = makeLinePrim 0.5 (P2 10 10) (P2 110 10)+    y_axis    = makeLinePrim 0.5 (P2 10 10) (P2 10 110)+    line1     = makeLinePrim 1.5 (P2 11 11) (P2 110 110)++++makeLabelPrim :: String -> DPoint2 -> DPrimitive+makeLabelPrim = textlabel attrs +  where+    attrs     = (black, FontAttr "Helvetica" "Helvetica" SVG_REGULAR 10)++makeLinePrim :: Double -> DPoint2 -> DPoint2 -> DPrimitive+makeLinePrim lw a b = ostroke attrs $ path a [lineTo b]+  where+    attrs = (black, [LineWidth lw])

@@ -37,6 +37,8 @@   , obbox   , union    , trace+  , retrace+   , corners   , withinBB   , boundaryWidth@@ -158,6 +160,20 @@ 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"++-- | Perform the supplied transformation on the four corners of +-- the bounding box. Trace the new corners to calculate the +-- resulting bounding box.+-- +-- This helper function can be used to re-calculate a bounding +-- box after a rotation for example.+--+retrace :: (Num u, Ord u) +        => (Point2 u -> Point2 u) -> BoundingBox u -> BoundingBox u+retrace f = trace . map f . fromCorners . corners+  where+    fromCorners (bl,br,tr,tl) = [bl,br,tr,tl]+  -- | Generate all the corners of a bounding box, counter-clock  -- wise from the bottom left, i.e. @(bl, br, tr, tl)@.

@@ -36,6 +36,11 @@   , Gray(..)   , DGray +  -- * Utility constructor+  , iRGB3+  , iHSB3+  , iGray+     -- * Operations   , rgb2hsb   , hsb2rgb@@ -164,6 +169,30 @@   type Scalar (Gray a) = a   s *^ (Gray a) = Gray (s*a) ++--------------------------------------------------------------------------------+-- Utility constructors++-- | 'iRGB3' : @ red -> green -> blue -> rgb @+-- +-- Create an RGB colour with intergers in the range [0..255].+-- +-- 255 represents full sturation so red will be @ 255 0 0 @.+--+-- Integer values above 255 will be clamped to 255, similarly+-- values below 0 will be clamped to 0.+-- +iRGB3 :: (Fractional a, Ord a) => Int -> Int -> Int -> RGB3 a+iRGB3 r g b = RGB3 (rescaleZeroOne r) (rescaleZeroOne g) (rescaleZeroOne b)++iHSB3 :: (Fractional a, Ord a) => Int -> Int -> Int -> HSB3 a+iHSB3 h s b = HSB3 (rescaleZeroOne h) (rescaleZeroOne s) (rescaleZeroOne b)++iGray :: (Fractional a, Ord a) => Int -> Gray a+iGray i = Gray $ rescaleZeroOne i++rescaleZeroOne :: (Fractional a, Ord a) => Int -> a+rescaleZeroOne a = rescale (0,255.0) (0,1.0) (clamp 0 255 $ fromIntegral a)  -------------------------------------------------------------------------------- -- Operations

@@ -89,6 +89,9 @@   , r2d   , circularModulo +  -- * Bezier curves+  , bezierArc+   ) where  import Wumpus.Core.Utils ( CMinMax(..), PSUnit(..), oo )@@ -702,5 +705,26 @@     dec     :: Double     (i,dec) = properFraction $ r2d r ++--------------------------------------------------------------------------------+-- Bezier curves++-- | Create an arc - this construction is the analogue of +-- PostScript\'s @arc@ command, but the arc is created as a +-- Bezier curve so it should span less than 90deg.+--+-- CAVEAT - ang2 must be greater than ang1 +--+bezierArc :: Floating u +          => u -> Radian -> Radian -> Point2 u +          -> (Point2 u, Point2 u, Point2 u, Point2 u)+bezierArc r ang1 ang2 pt = (p0,p1,p2,p3)+  where+    theta = ang2 - ang1+    e     = r * fromRadian ((2 * sin (theta/2)) / (1+ 2* cos (theta/2))) +    p0    = pt .+^ avec ang1 r+    p1    = p0 .+^ avec (ang1 + pi/2) e+    p2    = p3 .+^ avec (ang2 - pi/2) e+    p3    = pt .+^ avec ang2 r  

@@ -294,21 +294,17 @@     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 -> 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...-                     ; ps_scale 1 (hh/hw)-                     ; outputArc dp c x y hw-                     ; ps_grestore-                     }+outputEllipse dp c (PrimEllipse (P2 x y) hw hh ctm) = +    concatInOut (ctm * scalingMatrix 1 (hh/hw)) (outputArc dp c x y hw) + outputArc :: (PSColour c, PSUnit u)            => DrawEllipse -> c -> u -> u -> u -> WumpusM () outputArc EFill        c x y r = updateColour c $ do @@ -322,10 +318,10 @@     ps_stroke  -outputLabel :: PSUnit u => Label u -> WumpusM ()-outputLabel (Label (P2 x y) entxt) = do+outputLabel :: (PSUnit u, Fractional u) => Label u -> WumpusM ()+outputLabel (Label (P2 x y) entxt ctm) = do     ps_moveto x y-    outputEncodedText entxt+    concatInOut ctm $ outputEncodedText entxt  outputEncodedText :: EncodedText -> WumpusM ()  outputEncodedText = mapM_ outputTextChunk . getEncodedText@@ -347,3 +343,11 @@               +concatInOut :: (PSUnit u, Fractional u) +            => Matrix3'3 u -> WumpusM a -> WumpusM ()+concatInOut m1 ma | m1 == identityMatrix  = ma >> return ()+                  | otherwise             = do { ps_concat $ toCTM m1+                                               ; _ <- ma +                                               ; ps_concat $ toCTM $ invert m1+                                               }+    

@@ -62,6 +62,8 @@ coordChange ::  (Num u, Ord u, Scale t, u ~ DUnit t) => t -> t coordChange = scale 1 (-1) +svg_reflection_matrix :: Num u => Matrix3'3 u+svg_reflection_matrix = M3'3  1 0 0    0 (-1) 0    0 0 1    -------------------------------------------------------------------------------- @@ -144,7 +146,7 @@  path :: PSUnit u => PathProps -> Path u -> SvgM Element path (c,dp) p = -    return $ element_path ps `rap` add_attrs (fill_a : stroke_a : opts)+    return $ element_path ps `snoc_attrs` (fill_a : stroke_a : opts)   where     (fill_a,stroke_a,opts) = drawProperties c dp     ps                     = svgPath dp p @@ -158,19 +160,19 @@ -- tspan element). --  label :: (Ord u, PSUnit u) => LabelProps -> Label u -> SvgM Element-label (c,FontAttr _ fam style sz) (Label pt entxt) = do +label (c,FontAttr _ fam style sz) (Label pt entxt ctm) = do       str <- encodedText entxt-     let tspan_elt = element_tspan str `rap` add_attrs [ attr_fill c ]-     return $ element_text tspan_elt `rap` add_attrs text_xs -                                     `rap` add_attrs (fontStyle style)+     let tspan_elt = element_tspan str `snoc_attrs` [ attr_fill c ]+     return $ element_text tspan_elt `snoc_attrs` text_xs +                                     `snoc_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 -                ]+    text_xs   = withCTM (ctm * svg_reflection_matrix) $ +                  [ attr_x x+                  , attr_y y +                  , attr_font_family fam+                  , attr_font_size sz +                  ]           @@ -210,14 +212,14 @@ -- If w==h the draw the ellipse as a circle  ellipse :: PSUnit u => EllipseProps -> PrimEllipse u -> SvgM Element-ellipse (c,dp) (PrimEllipse (P2 x y) w h) +ellipse (c,dp) (PrimEllipse (P2 x y) w h ctm)      | w == h    = return $ element_circle  -                         `rap` add_attrs (circle_attrs  ++ style_attrs)+                            `snoc_attrs` (circle_attrs  ++ style_attrs)     | otherwise = return $ element_ellipse -                         `rap` add_attrs (ellipse_attrs ++ style_attrs)+                            `snoc_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]+    circle_attrs  = withCTM ctm $ [attr_cx x, attr_cy y, attr_r w]+    ellipse_attrs = withCTM ctm $ [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 @@ -283,3 +285,13 @@  closePath :: SvgPath -> SvgPath  closePath xs = xs ++ ["Z"]++snoc_attrs :: Element -> [Attr] -> Element+snoc_attrs = flip add_attrs++withCTM :: PSUnit u => Matrix3'3 u -> [Attr] -> [Attr]+withCTM mtrx attrs | mtrx == identityMatrix = attrs+                   | otherwise              = mtrx_attr : attrs+  where+    mtrx_attr       = attr_transform $ val_matrix a b c d e f+    CTM a b c d e f = toCTM mtrx

@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE FlexibleInstances          #-} {-# OPTIONS -Wall #-} @@ -52,9 +53,13 @@   , extendBoundary  -  -- * Warning - don\'t use these are a temporary exports-  , movePic  -- re-export from PictureInternal+  -- * Minimal - picture composition+  , picMoveBy   , picOver+  , picBeside+  , illustrateBounds+  , illustrateBoundsPrim +  , illustrateControlPoints    ) where @@ -69,8 +74,6 @@ import Data.Semigroup  -- --------------------------------------------------------------------------------  -- Default attributes@@ -97,7 +100,7 @@  -- | Lift a 'Primitive' to a 'Picture', located in the standard frame. ---frame :: (Fractional u, Ord u) => Primitive u -> Picture u+frame :: (Fractional u, Floating u, Ord u) => Primitive u -> Picture u frame p = Single (stdFrame, boundary p) p   -- | Frame a picture within the supplied bounding box@@ -114,7 +117,8 @@ -- 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 :: (Fractional u, Floating 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 @@ -126,7 +130,8 @@ -- -- This function throws an error when supplied the empty list. ---frameMulti :: (Fractional u, Ord u) => [Primitive u] -> Picture u+frameMulti :: (Fractional u, Floating u, Ord u) +           => [Primitive u] -> Picture u frameMulti [] = error "Wumpus.Core.Picture.frameMulti - empty list" frameMulti xs = multi $ map frame xs @@ -141,7 +146,7 @@     sconcat []      = error err_msg     sconcat (x:xs)  = foldr append x xs -    ones            = fromListErr err_msg ps+    ones            = fromListErr ps err_msg      err_msg         = "Wumpus.Core.Picture.multi - empty list" @@ -312,13 +317,15 @@ -------------------------------------------------------------------------------- -- Labels to primitive -mkTextLabel :: PSRgb -> FontAttr -> String -> Point2 u -> Primitive u-mkTextLabel c attr txt pt = PLabel (c,attr) (Label pt $ lexLabel txt)+mkTextLabel :: Num u => PSRgb -> FontAttr -> String -> Point2 u -> Primitive u+mkTextLabel c attr txt pt = PLabel (c,attr) lbl +  where+    lbl = Label pt (lexLabel txt) identityMatrix  -- SVG seems to have an issue with /Courier/ and needs /Courier New/.  default_font :: FontAttr-default_font = FontAttr "Courier" "Courier New" SVG_REGULAR 12+default_font = FontAttr "Courier" "Courier New" SVG_REGULAR 24  -- | Create a text label. The string should not contain newline -- or tab characters. Use 'multilabel' to create text with @@ -333,7 +340,7 @@ -- The supplied point is is the bottom left corner. -- class TextLabel t where -  textlabel :: t -> String -> Point2 u -> Primitive u+  textlabel :: Num u => t -> String -> Point2 u -> Primitive u   instance TextLabel () where textlabel () = mkTextLabel psBlack default_font@@ -359,9 +366,9 @@ 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 +-- | Create a label where the font is @Courier@, text size is 24pt -- and colour is black.-ztextlabel :: String -> Point2 u -> Primitive u+ztextlabel :: Num u => String -> Point2 u -> Primitive u ztextlabel = mkTextLabel psBlack default_font  @@ -370,7 +377,7 @@  mkEllipse :: Num u            => PSRgb -> DrawEllipse -> u -> u -> Point2 u -> Primitive u-mkEllipse c dp hw hh pt = PEllipse (c,dp) (PrimEllipse pt hw hh)+mkEllipse c dp hw hh pt = PEllipse (c,dp) (PrimEllipse pt hw hh identityMatrix)   ellipseDefault :: EllipseProps@@ -473,7 +480,133 @@     posve n | n < 0     = 0             | otherwise = n  +--------------------------------------------------------------------------------+-- Minimal support for Picture composition++infixr 6 `picBeside`, `picOver`++-- | 'picOver' : @ picture -> picture -> picture @+--+-- Draw the first picture on to off the second picture - +-- neither picture will be moved.+-- 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)++-- | 'picMoveBy' : @ picture -> vector -> picture @+-- +--  Move a picture by the supplied vector. +--+picMoveBy :: Num u => Picture u -> Vec2 u -> Picture u+p `picMoveBy` v = v `movePic` p ++-- | 'picBeside' : @ picture -> picture -> picture @+--+-- Move the second picture to sit at the right side of the+-- first picture+--+picBeside :: (Num u, Ord u) => Picture u -> Picture u -> Picture u+a `picBeside` b = a `picOver` (b `picMoveBy` v) +  where +    v = hvec $ rightPlane (boundary a) - leftPlane (boundary b) ++-- | 'illustrateBounds' : @ colour -> picture -> picture @+-- +-- Draw the picture on top of an image of its bounding box.+-- The bounding box image will be drawn in the supplied colour.+--+illustrateBounds :: (Floating u, Ord u) => DRGB -> Picture u -> Picture u+illustrateBounds rgb p = p `picOver` (frameMulti $ boundsPrims rgb p) +++-- | 'illustrateBoundsPrim' : @ colour -> primitive -> picture @+-- +-- Draw the primitive on top of an image of its bounding box.+-- The bounding box image will be drawn in the supplied colour.+--+-- The result will be lifted from Primitive to Picture.+-- +illustrateBoundsPrim :: (Floating u, Ord u) +                     => DRGB -> Primitive u -> Picture u+illustrateBoundsPrim rgb p = frameMulti (boundsPrims rgb p ++ [p])++-- Note - above has to use snoc (++ [p]) to get the picture to+-- draw above the bounding box image.+++-- | Draw a the rectangle of a bounding box, plus cross lines+-- joining the corners.+--+boundsPrims :: (Num u, Ord u, Boundary t, u ~ DUnit t) +            => DRGB -> t -> [Primitive u]+boundsPrims rgb a = [ bbox_rect, bl_to_tr, br_to_tl ]+  where+    (bl,br,tr,tl) = corners $ boundary a+    bbox_rect     = cstroke rgb $ vertexPath [bl,br,tr,tl]+    bl_to_tr      = ostroke rgb $ vertexPath [bl,tr]+    br_to_tl      = ostroke rgb $ vertexPath [br,tl]+++-- | Generate the control points illustrating the Bezier +-- curves within a picture.+-- +-- This has no effect on TextLabels.+-- +-- Pseudo control points are generated for ellipses, +-- although strictly speaking ellipses do not use Bezier+-- curves - they are implemented with PostScript\'s +-- @arc@ command.  +--+illustrateControlPoints :: (Floating u, Ord u)+                        => DRGB -> Primitive u -> Picture u+illustrateControlPoints rgb prim = step prim+  where+    step (PEllipse _ e) = frameMulti (prim : ellipseCtrlLines rgb e)+    step (PPath    _ p) = frameMulti (prim : pathCtrlLines rgb p)+    step _              = frame prim++-- Genrate lines illustrating the control points of curves on +-- a Path.+--+-- Two lines are generated for a Bezier curve:+-- start-point to control-point1; control-point2 to end-point+--+-- Nothing is generated for a straight line.+--+pathCtrlLines :: (Num u, Ord u) => DRGB -> Path u -> [Primitive u]+pathCtrlLines rgb (Path start ss) = step start ss+  where +    -- trail the current end point through the recursion...+    step _ []                    = []+    step _ (PLineTo e:xs)        = step e xs+    step s (PCurveTo c1 c2 e:xs) = mkLine s c1 : mkLine c2 e : step e xs ++    mkLine s e                   = ostroke rgb (Path s [lineTo e]) +++-- Generate lines illustrating the control points of an +-- ellipse:+-- +-- Two lines for each quadrant: +-- start-point to control-point1; control-point2 to end-point+--+ellipseCtrlLines :: (Floating u, Ord u) +                     => DRGB -> PrimEllipse u -> [Primitive u]+ellipseCtrlLines rgb pe = start all_points+  where +    -- list in order: +    -- [s,cp1,cp2,e, cp1,cp2,e, cp1,cp2,e, cp1,cp2,e]++    all_points           = ellipseControlPoints pe++    start (s:c1:c2:e:xs) = mkLine s c1 : mkLine c2 e : rest e xs+    start _              = []++    rest s (c1:c2:e:xs)  = mkLine s c1 : mkLine c2 e : rest e xs+    rest _ _             = []++    mkLine s e           = ostroke rgb (Path s [lineTo e]) ++

@@ -50,6 +50,7 @@   , moveLocale   , extractFrame   , repositionProperties+  , ellipseControlPoints    ) where @@ -65,13 +66,11 @@ import Data.AffineSpace import Data.Semigroup -import Control.Applicative ( liftA2 )- import Text.PrettyPrint.Leijen   --- | Picture is a leaf attributed tree - where atttibutes are +-- | Picture is a leaf attributed tree - where attributes are  -- colour, line-width etc. It is parametric on the unit type  -- of points (typically Double). -- @@ -171,6 +170,7 @@ data Label u = Label        { label_bottom_left :: Point2 u       , label_text        :: EncodedText+      , label_CTM         :: Matrix3'3 u       }   deriving (Eq,Show) @@ -179,9 +179,10 @@ -- 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 +      { ellipse_center        :: Point2 u+      , ellipse_half_width    :: u+      , ellipse_half_height   :: u +      , ellispe_CTM           :: Matrix3'3 u       }    deriving (Eq,Show) @@ -260,13 +261,19 @@   pretty (PLineTo pt)           = text "--" <> pretty pt  instance Pretty u => Pretty (Label u) where-  pretty (Label pt s) = dquotes (pretty s) <> char '@' <> pretty pt+  pretty (Label pt s ctm) = dquotes (pretty s) <> char '@' <> pretty pt+                                               <+> ppMatrixCTM ctm  instance Pretty u => Pretty (PrimEllipse u) where-  pretty (PrimEllipse c w h) = pretty "ellipse" <+> pretty c-                                                <+> text "w:" <> pretty w-                                                <+> text "h:" <> pretty h+  pretty (PrimEllipse c w h ctm) = pretty "ellipse" <+> pretty c+                                                    <+> text "w:" <> pretty w+                                                    <+> text "h:" <> pretty h+                                                    <+> ppMatrixCTM ctm +ppMatrixCTM :: Pretty u => Matrix3'3 u -> Doc+ppMatrixCTM = pp . toCTM where+  pp (CTM a b  c d  x y) = list $ map pretty [a,b,c,d,x,y]+    -------------------------------------------------------------------------------- @@ -309,12 +316,38 @@ instance (Num u, Ord u) => Translate (Picture u) where   translate = translatePicture +instance (Real u, Floating u) => Rotate (Primitive u) where+  rotate ang (PPath    attr path) = PPath    attr $ rotatePath ang path+  rotate ang (PLabel   attr lbl)  = PLabel   attr $ rotateLabel ang lbl+  rotate ang (PEllipse attr ell)  = PEllipse attr $ rotateEllipse ang ell++instance (Real u, Floating u) => RotateAbout (Primitive u) where+  rotateAbout ang pt (PPath    attr path) = +      PPath    attr $ rotatePathAbout ang pt path++  rotateAbout ang pt (PLabel   attr lbl)  = +      PLabel   attr $ rotateLabelAbout ang pt lbl++  rotateAbout ang pt (PEllipse attr ell)  = +      PEllipse attr $ rotateEllipseAbout ang pt ell+++instance Num u => Scale (Primitive u) where+  scale x y (PPath    attr path) = PPath    attr $ scalePath x y path+  scale x y (PLabel   attr lbl)  = PLabel   attr $ scaleLabel x y lbl+  scale x y (PEllipse attr ell)  = PEllipse attr $ scaleEllipse x y ell++instance Num u => Translate (Primitive u) where+  translate x y (PPath    attr path) = PPath    attr $ translatePath x y path+  translate x y (PLabel   attr lbl)  = PLabel   attr $ translateLabel x y lbl+  translate x y (PEllipse attr ell)  = PEllipse attr $ translateEllipse x y ell+ --------------------------------------------------------------------------------  -- Helpers for the affine transformations  rotatePicture :: (Real u, Floating u) => Radian -> Picture u -> Picture u-rotatePicture = liftA2 transformPicture rotate rotate+rotatePicture ang = transformPicture (rotate ang) (rotate ang)   rotatePictureAbout :: (Real u, Floating u) @@ -338,7 +371,6 @@     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) @@ -358,43 +390,126 @@   ------------------------------------------------------------------------------------ Boundary+-- Paths -instance (Num u, Ord u) => Boundary (Path u) where-  boundary (Path st xs) = trace $ st : foldr f [] xs where-      f (PLineTo p1)        acc  = p1 : acc-      f (PCurveTo p1 p2 p3) acc  = p1 : p2 : p3 : acc +rotatePath :: (Real u, Floating u) => Radian -> Path u -> Path u+rotatePath ang = transformPath (rotate ang) +rotatePathAbout :: (Real u, Floating u) +                => Radian -> Point2 u -> Path u -> Path u+rotatePathAbout ang pt = transformPath (rotateAbout ang pt)  --- Note - this will calculate a very bad bounding box for text.--- Descenders will be transgress the boundary and width will be --- very long.+scalePath :: Num u => u -> u -> Path u -> Path u+scalePath x y = transformPath (scale x y) -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 _ e)               = boundary e+translatePath :: Num u => u -> u -> Path u -> Path u+translatePath x y = transformPath (translate x y) +transformPath :: (Point2 u -> Point2 u) -> Path u -> Path u+transformPath fp (Path start ss) = +    Path (fp start) (map (transformPathSegment fp) ss) -instance (Fractional u, Ord u) => Boundary (PrimEllipse u) where-  boundary (PrimEllipse c hw hh)        = BBox (c .-^ v) (c .+^ v) -    where v = V2 hw hh- +-- Path Segments  +transformPathSegment :: (Point2 u -> Point2 u) -> PathSegment u -> PathSegment u+transformPathSegment fp = pointwise fp +-- Labels++-- rotate CTM and pt or just CTM ??+rotateLabel :: (Real u, Floating u) => Radian -> Label u -> Label u+rotateLabel ang (Label pt txt ctm) = Label pt txt (ctm * rotationMatrix ang)++-- rotate CTM and pt or just CTM ??+rotateLabelAbout :: (Real u, Floating u) +                => Radian -> Point2 u -> Label u -> Label u+rotateLabelAbout ang rpt (Label pt txt ctm) = +    Label pt txt (ctm * originatedRotationMatrix ang rpt) ++scaleLabel :: Num u => u -> u -> Label u -> Label u+scaleLabel x y (Label pt txt ctm) = Label pt txt (ctm * scalingMatrix x y)++-- no need to change CTM for translation (??)+translateLabel :: Num u => u -> u -> Label u -> Label u+translateLabel x y (Label pt txt ctm) = Label (translate x y pt) txt ctm+++-- ++rotateEllipse :: (Real u, Floating u) +              => Radian -> PrimEllipse u -> PrimEllipse u+rotateEllipse ang (PrimEllipse pt hw hh ctm) = +    PrimEllipse pt hw hh (ctm * rotationMatrix ang)++rotateEllipseAbout :: (Real u, Floating u) +                   => Radian -> Point2 u -> PrimEllipse u -> PrimEllipse u+rotateEllipseAbout ang rpt (PrimEllipse pt hw hh ctm) = +    PrimEllipse pt hw hh (ctm * originatedRotationMatrix ang rpt)+++scaleEllipse :: Num u => u -> u -> PrimEllipse u -> PrimEllipse u+scaleEllipse x y (PrimEllipse pt hw hh ctm) = +    PrimEllipse pt hw hh (ctm * scalingMatrix x y)+++translateEllipse :: Num u => u -> u -> PrimEllipse u -> PrimEllipse u+translateEllipse x y (PrimEllipse pt hw hh ctm) = +    PrimEllipse (translate x y pt) hw hh ctm++--------------------------------------------------------------------------------+-- Boundary+ instance Boundary (Picture u) where   boundary (PicBlank (_,bb))     = bb   boundary (Single   (_,bb) _)   = bb   boundary (Picture  (_,bb) _)   = bb   boundary (Clip     (_,bb) _ _) = bb +instance (Num u, Ord u) => Boundary (Path u) where+  boundary (Path st xs) = trace $ st : foldr f [] xs where+      f (PLineTo p1)        acc  = p1 : acc+      f (PCurveTo p1 p2 p3) acc  = p1 : p2 : p3 : acc   +-- Note - this will calculate an approximate bounding box for +-- text. +instance (Fractional u, Floating u, Ord u) => Boundary (Primitive u) where+  boundary (PPath _ p)        = boundary p+  boundary (PLabel (_,a) l)   = primLabelBoundary a l +  boundary (PEllipse _ e)     = boundary e +primLabelBoundary :: (Fractional u, Ord u) +                  => FontAttr -> Label u -> BoundingBox u+primLabelBoundary attr (Label pt xs ctm) = retrace (ctm *#) untraf_bbox+  where+    untraf_bbox = textBounds (font_size attr) pt char_count+    char_count  = textLength xs++instance (Floating u, Ord u) => Boundary (PrimEllipse u) where+  boundary = ellipseBoundary++-- Find the bbox of an ellipse by drawing it as four bezier +-- curves then trace all the points and control points to find+-- the bbox.+-- +-- Note all_points takes three of the four points to avoid +-- duplicating+-- /matched/ start-end points+--++ellipseBoundary :: (Floating u, Ord u) => PrimEllipse u -> BoundingBox u+ellipseBoundary = trace . ellipseControlPoints++-- PROBLEM:+-- Currently a rotated circle has a different BBox to a +-- non-rotated circle, because of how tangents are selected...+-- +-- This is the same as a diamond having a larger BBox+-- than a square with same side-length+--+ -------------------------------------------------------------------------------- -- @@ -444,5 +559,55 @@       y  = 4 - lly       ll = P2 (llx+x) (lly+y)       ur = P2 (urx+x) (ury+y)  +++-- | Get the control points as a list+-- +-- There are no duplicates in the list except for the final +-- /wrap-around/. We take 4 points initially (start,cp1,cp2,end)+-- then (cp1,cp2,end) for the other three quadrants.+--+ellipseControlPoints :: (Floating u, Ord u)+                     => PrimEllipse u -> [Point2 u]+ellipseControlPoints (PrimEllipse ctr hw hh ctm) = +    map (new_mtrx *#) $ start circ+  where+    (radius,(dx,dy)) = circleScalingProps hw hh+    new_mtrx         = ctm * scalingMatrix dx dy+    circ             = bezierCircle radius ctr+    +    start ((a,b,c,d):xs)  = a:b:c:d : rest xs+    start _               = []      -- should be unreachable+    +    rest  ((_,b,c,d):xs)  = b:c:d : rest xs+    rest  _               = []++++--+-- I don't know how to calculate bezier arcs (and thus control+-- points) for an ellipse but I know how to do it for a circle...+--+-- So a make a circle with the largest of half-width and +-- half-height then apply a scale to the points+-- +circleScalingProps  :: (Fractional u, Ord u) => u -> u -> (u,(u,u))+circleScalingProps hw hh  = (radius, (dx,dy))+  where+    radius     = max hw hh+    (dx,dy)    = if radius == hw then (1, rescale (0,hw) (0,1) hh)+                                 else (rescale (0,hh) (0,1) hw, 1)++++-- | Make a circle from Bezier curves - @n@ is the number of +-- subdivsions per quadrant.+--+bezierCircle :: Floating u +             => u -> Point2 u -> [(Point2 u, Point2 u, Point2 u, Point2 u)]+bezierCircle radius pt = map mkQuad angs+  where+    angs         = [(0, pi*0.5), (pi*0.5,pi), (pi, pi*1.5), (pi*1.5, pi*2)]+    mkQuad (a,b) = bezierArc radius a b pt  

@@ -34,6 +34,8 @@   , truncateDouble   , roundup ++  , rescale   , clamp   , ramp   , ramp255@@ -184,8 +186,19 @@ ceilingi = ceiling  +-- rescale a (originally in the range amin to amax) within the +-- the range bmin to bmax.+--+rescale :: Fractional a => (a,a) -> (a,a) -> a -> a+rescale (amin,amax) (bmin,bmax) a = +    bmin + apos * (brange / arange)  +  where+    arange = amax - amin+    brange = bmax - bmin+    apos   = a - amin + clamp :: Ord a => a -> a -> a -> a -clamp a b x = max a (min b x)+clamp amin amax x = max amin (min amax x)  ramp :: Double -> Double ramp = clamp 0 1@@ -257,38 +270,42 @@  -------------------------------------------------------------------------------- -infixr 5 :++infixr 5 `Many` -data OneList a = One a | a :+ OneList a+data OneList a = One a | Many 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+     step (One a)     = shows a . showChar '}'+     step (Many a xs) = shows a . showChar ',' . step xs   mkList2 :: a -> a -> OneList a-mkList2 a b = a :+ One b+mkList2 a b = a `Many` 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+onesmapM_ f (One x)     = f x >> return ()+onesmapM_ f (Many x xs) = f x >> onesmapM_ f xs  toListWith :: (a -> b) -> OneList a -> [b]-toListWith f (One a)   = [f a]-toListWith f (a :+ xs) = f a : toListWith f xs+toListWith f (One x)     = [f x]+toListWith f (Many x xs) = f x : 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+toListWithM mf (One x)     = mf x >>= \a -> return [a]+toListWithM mf (Many x xs) = return (:) `ap` mf x `ap` toListWithM mf xs  -fromListErr :: String -> [a] -> OneList a-fromListErr msg []     = error msg-fromListErr _   [a]    = One a-fromListErr msg (a:xs) = a :+ fromListErr msg xs+-- Error msg is a parameter, so client code can supply a +-- meaningful warning.+-- +fromListErr :: [a] -> String -> OneList a+fromListErr xs0 msg = step xs0 where+   step []     = error msg+   step [a]    = One a+   step (a:xs) = Many a $ step xs   

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

@@ -493,12 +493,12 @@ type instance PUnit (Picture u) = u  instance (Num u, Ord u) => Horizontal (Picture u) where-  moveH a    = movePic (hvec a) +  moveH a p  = p `picMoveBy` (hvec a)    leftBound  = leftPlane . boundary   rightBound = rightPlane . boundary  instance (Num u, Ord u) => Vertical (Picture u) where-  moveV a     = movePic (vvec a) +  moveV a p   = p `picMoveBy` (vvec a)    topBound    = upperPlane . boundary   bottomBound = lowerPlane . boundary @@ -520,7 +520,7 @@   over = picOver         instance (Num u, Ord u) => Move (Picture u) where-  move x y = movePic (V2 x y)+  move x y p = p `picMoveBy` (V2 x y)   instance (Num u, Ord u) => Blank (Picture u) where@@ -540,7 +540,7 @@ -- -- An error is throw if the list of strings is empty -- -multilabel :: (Fractional u, Ord u, TextLabel t) +multilabel :: (Fractional u, Floating u, Ord u, TextLabel t)             => t -> u -> VAlign -> [String] -> Point2 u -> Picture u multilabel _    _ _  []     _  = error $      "Wumpus.Core.Picture.multilabel - empty list."

@@ -1,5 +1,5 @@ name:             wumpus-core-version:          0.17.0+version:          0.18.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -14,38 +14,59 @@   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 plain [1] and quite efficient -  (no unnecessary stack operations).+  generated PostScript code is plain [1] and reasonably +  efficient as the use of stack operations, i.e @gsave@ and +  @grestore@ is minimized.   .   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 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).+  coordinate-free style.    .-  With revision 0.15.0 I\'ve added three extra helper modules+  With recent revisions, I\'ve added some extra helper modules   that are not really part of the \"core\", but they provide -  lists of named colours and fonts.+  lists of named colours and /safe/ fonts, plus some code  +  (Extra.PictureLanguage) that has been moved out of the+  wumpus-core namespace because it is somewhat \"higher-level\".    .   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. +  With revision 0.18.0, I\'ve changed the internals a bit so that +  Primitives (paths, text labels) support affine transformations. +  In the end, this didn\'t changed the API significantly, though +  with the next revision, I want to look at changing the +  PostScript output - swapping some uses of @concat@ to @moveto@; +  so again there is the possibility of significant changes +  between this revision and the next one.   .+  Also the module, Core.BoundingBox, is still a candidate for +  reworking, as it has too many functions that do not offer +  distinct functionality. Some functions were removed in +  revision 0.17.0 and some more are likely to follow. +  .+  NOTE...+  .+  One consequence of adding affine transformations for primitives+  is that the bounding box of a primitive under transformation +  may be tighter than than the bounding box of transformed +  picture containing the same primitive, i.e.:+  . +  @liftToPicture (transform PRIM) /= transform (liftToPicture PRIM)@+  .+  Where liftToPicture is usually @frame@ from +  @Wumpus.Core.Picture@.+  .+  This is because the bounding box of a transformed picture is +  calculated by applying the transformation to the corner points +  of its (previous) bounding box rather than finding the bounding +  box union of all the composite primitives.+  .   GENERAL DRAWBACKS...   .   For actually drawing pictures, diagrams, etc. Wumpus is very -  low level. I\'ve worked on a complementary package +  low level. I\'m working 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.@@ -54,19 +75,12 @@   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 - +  systems. However, the design permits a simple implementation -    which is a priority. Text encoding an exception - I\'m not    sure how reasonable the design is. The current implementation -  appears okay for Latin 1 but I\'m not sure about other -  character sets, and I may have to revise it significantly.+  appears okay for Latin 1 but may be inadequate for other +  character sets, so I may have to revise it significantly.   .-  With revision 0.14.0, I've added the first draft of a user -  guide. Source for the guide is included as well as the PDF as -  there is an extra example picture.  @wumpus-extra@ hasn\'t -  received any more attention unfortunately, so Wumpus is still -  really a bit too primitive for general use. However, 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 a similar tool to @@ -74,6 +88,31 @@   .   Changelog:   .+  0.17.0 to 0.18.0:+  .+  * Added instances of the affine operation classes (Scale, +    Rotate ...) for Primitives (path, text label, ellipse).+  .+  * Added some picture composition functions to Core.Picture.+    These are useful for testing where the type class +    complications of Extra.PictureLanguage are an overhead.  +  .+  * Added iRGB to Core.Colour - create RGB colours with +    integer components [0..255] - and iHSB, iGrey.+  .+  * Added some test modules for the affine transformations.+    These illustrate a quirk in Wumpus where, under affine +    transformation, Pictures may generate a larger bounding box +    than composite primitives.+  .+  * Minor change - ztextlabal changed to use 24pt type rather +    than 12pt. +  .+  * Corrected the cabal file to include the correct files for +    the manual. The Haskell source file @WorldFrame.hs@ was +    missing with the generated file @WorldFrame.eps@ incorrectly +    included instead.+  .   0.16.0 to 0.17.0:   .   * Added Core.WumpusTypes to export opaque versions of@@ -81,9 +120,9 @@     the Haddock documentation more cohesive.   .    * Moved the Core.PictureLanguage module into the Extra-    namespace (Extra.PictureLanguage). This module change+    namespace (Extra.PictureLanguage). This module may change     in detail, if not in spirit in the future as I'm not -    to happy with it. Also this model is somewhat +    very happy with it. Also this module is somewhat      \"higher-level\" than the modules in wumpus-core, so      a different home seems fitting.    . @@ -129,13 +168,18 @@ extra-source-files:   CHANGES,   LICENSE,+  demo/AffineTest01.hs,+  demo/AffineTest02.hs,+  demo/AffineTest03.hs,+  demo/AffineTest04.hs,+  demo/AffineTestBase.hs,   demo/FontPic.hs,   demo/LabelPic.hs,   demo/Picture.hs,   doc/Guide.pdf,   doc-src/Guide.lhs,   doc-src/Makefile,-  doc-src/WorldFrame.eps+  doc-src/WorldFrame.hs