wumpus-core 0.21.0 → 0.22.0

raw patch · 14 files changed

+273/−874 lines, 14 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGES +27/−5
• demo/FontMetrics.hs +75/−0
• demo/LabelPic.hs +31/−54
• demo/Picture.hs +0/−207
• doc-src/Guide.lhs +1/−9
• doc/Guide.pdf binary
• src/Wumpus/Core.hs +1/−1
• src/Wumpus/Core/FontSize.hs +76/−28
• src/Wumpus/Core/Geometry.hs +15/−0
• src/Wumpus/Core/PictureInternal.hs +7/−3
• src/Wumpus/Core/VersionNumber.hs +5/−2
• src/Wumpus/Core/WumpusTypes.hs +4/−0
• src/Wumpus/Extra/PictureLanguage.hs +0/−554
• wumpus-core.cabal +31/−11

@@ -1,11 +1,33 @@ +0.21.0 to 0.22.0:++  * Moved the deprecated module @Wumpus.Extra.PictureLanguage@+    into the package Wumpus-Basic along with the example +    @Picture.hs@.++  * Added vec as a synonym for the constructor V2.++  * Changed some of the Core.FontSize to use better terminology. +    Thus some of the constants have changed. Added a new example+    @FontMetrics.hs@ to illustrate how FontSize works. +    Particularly, the function @capHeight@ has been replaced with+    the function @numeralHeight@ which has better semantics.++  * The CTM data type and ToCTM class are now hidden in the+    top-level import module @Wumpus.Core@. They can be accessed+    by importing @Wumpus.Core.GraphicsState@ directly.++  * Exposed the PSUnit type class. ++ 0.20.0 to 0.21.0: -  * Removed the instances of the Affine transformation. They have-    been replaced with special transformation functions: -    @rotatePrimitive@, @scalePrimitive@, @translatePrimitive@.-    As Primitives are not in an affine frame until they are lifted -    to Pictures the affine instances had ill-conceived semantics.+  * Removed the Primitive instances of the Affine transformation +    classes. They have been replaced with special transformation +    functions: @rotatePrimitive@, @scalePrimitive@, +    @translatePrimitive@. As Primitives are not in an affine +    frame until they are lifted to Pictures the affine instances +    had ill-conceived semantics.    * Due to changes to accommodate the new non-affine       transformations, many of the class obligations have changed 

@@ -0,0 +1,75 @@+{-# OPTIONS -Wall #-}++module FontMetrics where++import Wumpus.Core++import Data.AffineSpace                 -- package: vector-space++import System.Directory++++main :: IO ()+main = do +    createDirectoryIfMissing True "./out/"+    writeEPS_latin1 "./out/font_metrics.eps" metrics_pic+    writeSVG_latin1 "./out/font_metrics.svg" metrics_pic++++peru :: PSRgb+peru = RGB3 0.804  0.522  0.247++plum :: PSRgb+plum = RGB3 0.867  0.627  0.867++black :: PSRgb+black = RGB3 0 0 0 ++courier_attr :: FontAttr+courier_attr = FontAttr "Courier" "Courier New" SVG_REGULAR 48++metrics_pic :: DPicture+metrics_pic = char_pic `picOver` lines_pic++lines_pic   :: DPicture+lines_pic   = frameMulti $ +    [ ascender_line, numeral_line, xheight_line, baseline, descender_line ]+  where+    descender_pos   = 0 - courier48_descender_depth+  +    ascender_line   = haxis peru (descender_pos + courier48_height)+    numeral_line    = haxis peru courier48_numeral_height+    xheight_line    = haxis peru courier48_xheight+    baseline        = haxis peru 0+    descender_line  = haxis peru descender_pos++++char_pic :: Picture Double+char_pic = frameMulti $ zipWith ($) chars (iterate (.+^ hvec 32) zeroPt)+  where+    chars = (map letter "ABXabdgjxy12") ++ [agraveU]++type PrimF = DPoint2 -> DPrimitive++bodyHeight  :: PrimF+bodyHeight  = vertLine peru courier48_numeral_height++agraveU     :: PrimF+agraveU     = textlabel (black, courier_attr) "&#Agrave"++letter :: Char -> DPoint2 -> DPrimitive+letter ch pt = textlabel (black, courier_attr) [ch] pt+++vertLine :: DRGB -> Double -> DPoint2 -> DPrimitive+vertLine rgb height pt = ostroke rgb $ vertexPath [pt, pt .+^ vvec height]++haxis :: DRGB -> Double -> DPrimitive+haxis rgb ypos = +    ostroke (rgb, dash_attr) $ vertexPath [ pt, pt .+^ hvec 440 ]+  where+    dash_attr = DashPattern (Dash 0 [(2,2)])+    pt        = P2 0 ypos

@@ -1,9 +1,9 @@+{-# LANGUAGE TypeFamilies               #-} {-# OPTIONS -Wall #-}  module LabelPic where  import Wumpus.Core-import Wumpus.Extra.PictureLanguage  import System.Directory @@ -12,11 +12,20 @@   drawBounds :: (Floating u, Real u) => Picture u -> Picture u-drawBounds p        = p `over` (frame $ cstroke () ph) +drawBounds p        = p `picOver` (frame $ cstroke () ph)    where     ph            = vertexPath $ [bl,br,tr,tl]     (bl,br,tr,tl) = corners $ boundary p ++-- | The center of a picture.+center :: (Boundary a, Fractional u, DUnit a ~ u) => a -> Point2 u+center a = P2 hcenter vcenter +  where  +    BBox (P2 x0 y0) (P2 x1 y1) = boundary a+    hcenter                    = x0 + 0.5 * (x1 - x0)+    vcenter                    = y0 + 0.5 * (y1 - y0)+ --------------------------------------------------------------------------------  @@ -32,7 +41,7 @@   lbl1 :: Picture Double-lbl1 = line1 -//- line2 where+lbl1 = line1 `picBeside` line2 where   line1 = frame (textlabel attrs "Hello" zeroPt)   line2 = frame (textlabel attrs "World" zeroPt)   attrs = (peru, FontAttr "Helvetica" "Helvetica" SVG_REGULAR 12) @@ -48,16 +57,18 @@     writeEPS_latin1 "./out/label02.eps" p1     writeSVG_latin1 "./out/label02.svg" p1   where-    p1 = lbl1 ->- lbl1 ->- (rotateAbout (pi/4) (center lbl1) lbl1) ->- lbl1+    p1 = lbl1 `picBeside` lbl1 +              `picBeside` (rotateAbout (pi/4) (center lbl1) lbl1) +              `picBeside` lbl1  demo03 :: IO () demo03 = do      writeEPS_latin1 "./out/label03.eps" p1     writeSVG_latin1 "./out/label03.svg" p1   where-    p1 = (drawBounds lbl1) ->- -         (drawBounds lbl1) ->- -         (drawBounds $ rotateAbout (pi/4) (center lbl1) lbl1) ->- +    p1 = (drawBounds lbl1) `picBeside` +         (drawBounds lbl1) `picBeside` +         (drawBounds $ rotateAbout (pi/4) (center lbl1) lbl1) `picBeside`           (drawBounds lbl1)  @@ -67,9 +78,9 @@     writeEPS_latin1 "./out/label04.eps" p1     writeSVG_latin1 "./out/label04.svg" p1   where-    p1 =        (drawBounds lbl1) -         `over` (drawBounds $ scale 2 2 lbl1)-         `over` (drawBounds $ scale 3 3 lbl1)+    p1 =           (drawBounds lbl1) +         `picOver` (drawBounds $ scale 2 2 lbl1)+         `picOver` (drawBounds $ scale 3 3 lbl1)   @@ -91,16 +102,20 @@     writeEPS_latin1 "./out/label05.eps" p1     writeSVG_latin1 "./out/label05.svg" p1   where-    p1 = uniformScale 10 $ stackOntoCenter [bigA, bigB] bigT+    p1 = uniformScale 10 $ bigA `picOver` bigB `picOver` bigT  + demo06 :: IO () demo06 = do      writeEPS_latin1 "./out/label06.eps" p1     writeSVG_latin1 "./out/label06.svg" p1   where-    p1 = hsep 20 (fn 'a') (map fn "abcdefg")-    fn = drawBounds . bigLetter peru+    p1 = pA `picBeside` pB `picBeside` pC `picBeside` pA+    +    pA = drawBounds bigA+    pB = drawBounds $ uniformScale 2 bigB+    pC = drawBounds $ picMoveBy `flip` (vec 0 10) $ bigLetter peru 'C'   demo07 :: IO ()@@ -108,53 +123,15 @@     writeEPS_latin1 "./out/label07.eps" p1     writeSVG_latin1 "./out/label07.svg" p1   where-    p1 = pA ->- pB ->- pC ->- pA-    -    pA = drawBounds bigA-    pB = drawBounds $ uniformScale 2 bigB-    pC = drawBounds $ move 0 10 $ bigLetter peru 'C'---demo08 :: IO ()-demo08 = do -    writeEPS_latin1 "./out/label08.eps" p1-    writeSVG_latin1 "./out/label08.svg" p1-  where-    p1 = hcat pA [pA, pB, pC]+    p1 = pA `picBeside` pB `picBeside` pC          pA = drawBounds bigA     pB = drawBounds $ uniformScale 2 bigB-    pC = drawBounds $ move 0 10 $ bigLetter peru 'C'--demo09 :: IO ()-demo09 = do -    writeEPS_latin1 "./out/label09.eps" p1-    writeSVG_latin1 "./out/label09.svg" p1-  where-    p1 = (bigA `above` bigB) ->- (bigA `below` bigB) -    -demo10 :: IO ()-demo10 = do -    writeEPS_latin1 "./out/label10.eps" p1-    writeSVG_latin1 "./out/label10.svg" p1-  where-    p1 :: Picture Double-    p1 = frame $ textlabel () "myst&#egrave;re" zeroPt--demo11 :: IO ()-demo11 = do-    writeEPS_latin1 "./out/label11.eps" pic-    writeSVG_latin1 "./out/label11.svg" pic-  where-    pic :: Picture Double-    pic = p1 `over` p2-    p1  = multilabel plum 3 VLeft ["Hello", "from", "Wumpus"] (P2 50 50)-    p2  = bigA `at` P2 50 50+    pC = drawBounds $ picMoveBy `flip` (vec 0 10) $ bigLetter peru 'C'   main :: IO () main = do    createDirectoryIfMissing True "./out/"   sequence_ [ demo01, demo02, demo03, demo04, demo05-            , demo06, demo07, demo08, demo09, demo10-            , demo11 ]  +            , demo06, demo07 ]

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

@@ -103,7 +103,7 @@ 
 \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...
+perhaps under-cooked although it appears adequate for Latin-1.
 
 \item[\texttt{Wumpus.Core.TextLatin1.}]
 A instance of the TextEncoder type for mapping Latin 1 characters
@@ -117,14 +117,6 @@ presents them as opaque types - i.e. their constructors are 
 hidden. 
 \end{description}
-
-The package also contains a deprecated module defining
-picture composition operators, 
-\texttt{Wumpus.Extra.PictureLanguage}. 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. At some point in the future 
-\texttt{wumpus-basic} should supercede this module.
 
 %-----------------------------------------------------------------
 \section{Drawing model}

binary file changed (56739 → 56794 bytes)

@@ -70,7 +70,7 @@ import Wumpus.Core.Colour hiding ( black, white, red, green, blue ) import Wumpus.Core.FontSize import Wumpus.Core.Geometry-import Wumpus.Core.GraphicsState+import Wumpus.Core.GraphicsState hiding ( CTM, ToCTM ) import Wumpus.Core.OutputPostScript import Wumpus.Core.OutputSVG import Wumpus.Core.Picture

@@ -17,7 +17,10 @@ -- calculated for other font families will usually have longer  -- width than is necessary for the printed text.  -- --- This is a deficiency of Wumpus, but alternatives would have+-- This is a deficiency of Wumpus, and limits its text handling+-- capabilities (for example, text cannot be automatically +-- centered). However, alternatives would need access to font +-- metrics - this would require a font loader and add  -- significant implementation complexity. --  --------------------------------------------------------------------------------@@ -31,9 +34,11 @@    -- * Courier metrics at 48 point   , courier48_width-  , courier48_body_height   , courier48_height+  , courier48_numeral_height+  , courier48_xheight   , courier48_descender_depth+  , courier48_ascender_height   , courier48_spacer_width  @@ -41,7 +46,8 @@   , widthAt48pt   , textWidth   , textHeight-  , capHeight+  , numeralHeight+  , xcharHeight   , descenderDepth   , textBounds @@ -55,48 +61,84 @@ type CharCount = Int type FontSize = Int +-- NOTE - I\'ve largely tried to follow the terminoly from +-- Edward Tufte\'s /Visual Explantions/, page 99.+--++ -- | The width of a letter in Courier at 48 pt. -- -- The value is not entirely accurate but it is satisfactory. --+-- > width = 26.0 +-- courier48_width :: Num u => u courier48_width = 26 ---- | The height of a letter without accents, ascenders or --- descenders in Courier at 48 pt .+-- | The point size of a character in Courier at 48 pt. ----- The value is not entirely accurate but it is satisfactory - --- some letters are taller than others (e.g. numbers are taller --- then capitals).+-- \*\* Naturally the height is 48.0 \*\*. ---courier48_body_height :: Num u => u -courier48_body_height = 30+courier48_height :: Num u => u+courier48_height = 48  --- | The /common maximum/ height of a letter in Courier at 48pt.++-- | The height of a numeral without accents, ascenders or +-- descenders in Courier at 48 pt. ----- By common maximum the letter is allowed to have both an accent --- or ascender and a descender.+-- Note - the height of a numeral in Courier is slightly +-- larger than a upper-case letter. ----- Naturally the height is 48.0.+-- > numeral_height = 30.0  ---courier48_height :: Num u => u-courier48_height = 48+courier48_numeral_height :: Num u => u +courier48_numeral_height = 30 +-- | The height of the body of a lower-case letter +--  (typically the letter  \'x\') in Courier at 48 pt. +--+-- This is also known as the \"body height\".+--+-- > xheight = 20.0 +-- +courier48_xheight :: Num u => u +courier48_xheight = 20 + -- | The depth of a descender in Courier at 48 pt. -- --- Also the height of an ascender.+-- > descender_depth = 9.0+--  courier48_descender_depth :: Num u => u  courier48_descender_depth = 9 +-- | The depth of an ascender in Courier at 48 pt.+-- +-- > ascender_height = 10.0+-- +-- Note - for Courier point size is not the sum of+-- descender, ascender and xheight and lower-case letters with+-- ascenders are slightly taller than upper-case letters:+--+-- > descender_depth + xheight + ascender_height /= point_size+--+-- > xheight + ascender_height /= cap_height+--+-- > xheight + ascender_height == numeral_height+--+courier48_ascender_height :: Num u => u +courier48_ascender_height = 10   -- | The spacing between letters printed directly with  -- PostScript\'s show command for Courier at 48 pt. ----- The value is not entirely accurate but it is satisfactory.+-- The value is not entirely accurate but it is satisfactory+-- for bounding box calculations.+--+-- > spacer_width = 3.0+-- courier48_spacer_width :: Num u => u courier48_spacer_width = 3 @@ -117,21 +159,27 @@ textWidth sz n = (fromIntegral sz)/48 * widthAt48pt n  --- | Text height is just identity/double-coercion, i.e. --- @18 == 18.0@. The /size/ of a font is the maximum height:------ > body + descender max + ascender max+-- | Text height is just identity/double-coercion of the Point size.+-- i.e. @18 == 18.0@. The /size/ of a font is the maximum height: -- textHeight :: Num u =>  FontSize -> u textHeight = fromIntegral --- The height of an upper case letter (without ascender or --- descender).+-- | Approximate the height of a numeral using metrics derived +-- from the Courier monospaced font. ---capHeight :: Fractional u => FontSize -> u-capHeight sz = textHeight sz - (2 * descenderDepth sz)+numeralHeight :: Fractional u => FontSize -> u+numeralHeight sz = textHeight sz * (courier48_numeral_height / courier48_height) --- | Descender depth for font size @sz@.+-- | Approximate the height of the lower-case char \'x\' using +-- metrics derived from the Courier monospaced font.+--+xcharHeight :: Fractional u => FontSize -> u+xcharHeight sz = textHeight sz * (courier48_xheight / courier48_height)+++-- | Approximate the descender depth for font size @sz@ using+-- metrics derived from the Courier monospaced font. --  descenderDepth :: Fractional u => FontSize -> u descenderDepth sz =  (fromIntegral sz) / 48 * courier48_descender_depth

@@ -49,6 +49,7 @@   , MatrixMult(..)    -- * Vector operations+  , vec   , direction   , hvec   , vvec@@ -417,6 +418,20 @@ -------------------------------------------------------------------------------- -- Vectors +-- | A synonym for the constructor 'V2' with a Num constraint on +-- the arguments.+--+-- Essentially superfluous, but it can be slightly more +-- typographically pleasant when used in lists of vectors:+--+-- > [ vec 2 2, vvec 4, hvec 4, vec 2 2 ]+--+-- Versus:+--+-- > [ V2 2 2, vvec 4, hvec 4, V2 2 2 ]+--  +vec :: Num u => u -> u -> Vec2 u+vec = V2  -- | Direction of a vector - i.e. the counter-clockwise angle  -- from the x-axis.

@@ -203,7 +203,11 @@ type DPrimEllipse = PrimEllipse Double  -data PrimCTM u = PrimCTM { _xscale :: u, _yscale :: u, _rot :: Radian }+data PrimCTM u = PrimCTM +      { ctm_scale_x     :: u+      , ctm_scale_y     :: u+      , ctm_rotation    :: Radian +      }   deriving (Eq,Show)  @@ -511,13 +515,13 @@ -- Manipulating the Primitive CTM  identityCTM :: Num u => PrimCTM u-identityCTM = PrimCTM 1 1 0+identityCTM = PrimCTM { ctm_scale_x = 1, ctm_scale_y = 1, ctm_rotation = 0 }  scaleCTM :: Num u => u -> u -> PrimCTM u -> PrimCTM u scaleCTM x1 y1 (PrimCTM x y ang) = PrimCTM (x1*x) (y1*y) ang  rotateCTM :: Radian -> PrimCTM u -> PrimCTM u-rotateCTM ang1 (PrimCTM x y ang) = PrimCTM x y (ang1+ang)+rotateCTM ang1 (PrimCTM x y ang) = PrimCTM x y (circularModulo $ ang1+ang)  matrixRepCTM :: (Floating u, Real u) => PrimCTM u -> Matrix3'3 u matrixRepCTM (PrimCTM x y ang) = 

@@ -20,6 +20,9 @@    ) where -+-- | Version number+--+-- > (0,22,0)+-- wumpus_core_version :: (Int,Int,Int)-wumpus_core_version = (0,21,0)+wumpus_core_version = (0,22,0)

@@ -51,8 +51,12 @@   , uniformScalePrimitive  +  -- * Printable unit for PostScript+  , PSUnit(..)+   ) where   import Wumpus.Core.PictureInternal+import Wumpus.Core.Utils () 

@@ -1,554 +0,0 @@-{-# 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 p  = p `picMoveBy` (hvec a) -  leftBound  = leftPlane . boundary-  rightBound = rightPlane . boundary--instance (Num u, Ord u) => Vertical (Picture u) where-  moveV a p   = p `picMoveBy` (vvec a) -  topBound    = upperPlane . boundary-  bottomBound = lowerPlane . boundary---- Note - picture is a binary tree and drawing is depth-first,--- left-to-right so pictures in the right of the tree potentially--- are drawn on top of pictures on the left.------ So to print picture a _over_ picture b we form this node:------ >  locale --- >    /\--- >   /  \--- >  b    a------ Hence `over` flips b and a---instance (Num u, Ord u) => Composite (Picture u) where-  over = picOver       --instance (Num u, Ord u) => Move (Picture u) where-  move x y p = p `picMoveBy` (V2 x y)---instance (Num u, Ord u) => Blank (Picture u) where-  blank w h = blankPicture (bbox zeroPt (P2 w h))--------------------------------------------------------------------------------------- ----- | Create multiple lines of text.------ The dimension argument is the linespacing, measured as the--- distance between the upper lines descender and the lower --- lines ascender.------ An error is throw if the list of strings is empty--- -multilabel :: (Real u, Floating u, TextLabel t) -           => t -> u -> VAlign -> [String] -> Point2 u -> Picture u-multilabel _    _ _  []     _  = error $ -    "Wumpus.Core.PictureLanguage.multilabel - empty list."--multilabel attr n va (x:xs) pt = -    moveAll $ vsepA va n line1 (map mkPic xs)-  where-    line1     = mkPic x-    mkPic s   = frame $ textlabel attr s zeroPt-    vdelta p  = boundaryHeight (boundary p) - boundaryHeight (boundary line1)-    moveAll p = moveV (vdelta p) $ p `at` pt

@@ -1,5 +1,5 @@ name:             wumpus-core-version:          0.21.0+version:          0.22.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -21,8 +21,8 @@   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+  applied to geometric objects. Unlike PostScript there is no +  notion of a current point, Wumpus builds pictures in a   coordinate-free style.    .   GENERAL DRAWBACKS...@@ -61,13 +61,34 @@   .   Changelog:   .+  0.21.0 to 0.22.0:+  .+  * Moved the deprecated module @Wumpus.Extra.PictureLanguage@+    into the package Wumpus-Basic along with the example +    @Picture.hs@.+  .+  * Added vec as a synonym for the constructor V2.+  .+  * Changed some of the Core.FontSize to use better terminology. +    Thus some of the constants have changed. Added a new example+    @FontMetrics.hs@ to illustrate how FontSize works. +    Particularly, the function @capHeight@ has been replaced with+    the function @numeralHeight@ which has better semantics.+  .+  * The CTM data type and ToCTM class are now hidden in the+    top-level import module @Wumpus.Core@. They can be accessed+    by importing @Wumpus.Core.GraphicsState@ directly.+  .+  * Exposed the PSUnit type class. +  .   0.20.0 to 0.21.0:   .-  * Removed the instances of the Affine transformation. They have-    been replaced with special transformation functions: -    @rotatePrimitive@, @scalePrimitive@, @translatePrimitive@.-    As Primitives are not in an affine frame until they are lifted -    to Pictures the affine instances had ill-conceived semantics.+  * Removed the Primitive instances of the Affine transformation +    classes. They have been replaced with special transformation +    functions: @rotatePrimitive@, @scalePrimitive@, +    @translatePrimitive@. As Primitives are not in an affine +    frame until they are lifted to Pictures the affine instances +    had ill-conceived semantics.   .   * Due to changes to accommodate the new non-affine       transformations, many of the class obligations have changed @@ -100,9 +121,9 @@   demo/AffineTest02.hs,   demo/AffineTest03.hs,   demo/AffineTestBase.hs,+  demo/FontMetrics.hs   demo/LabelPic.hs,   demo/MultiPic.hs-  demo/Picture.hs,   demo/Rotated.hs   demo/Scaled.hs   demo/Translated.hs@@ -134,8 +155,7 @@     Wumpus.Core.TextEncoder,     Wumpus.Core.TextLatin1,     Wumpus.Core.VersionNumber,-    Wumpus.Core.WumpusTypes,-    Wumpus.Extra.PictureLanguage+    Wumpus.Core.WumpusTypes    other-modules:     Wumpus.Core.PictureInternal,