diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2008 Stephen Peter Tetley +Copyright (c) 2009-2010 Stephen Peter Tetley All rights reserved. diff --git a/demo/AffineTestBase.hs b/demo/AffineTestBase.hs --- a/demo/AffineTestBase.hs +++ b/demo/AffineTestBase.hs @@ -25,8 +25,8 @@ import System.Directory -light_blue :: DRGB -light_blue = iRGB3 176 224 231 +light_blue :: RGBi +light_blue = RGBi 176 224 231 runAlgs :: [AffineTrafoAlg] -> [ControlPointAlg] -> IO () @@ -39,7 +39,7 @@ { ata_console_msg :: String , ata_eps_file :: FilePath , ata_svg_file :: FilePath - , ata_prim_constructor :: DRGB -> DPrimitive + , ata_prim_constructor :: RGBi -> DPrimitive , ata_pic_transformer :: DPicture -> DPicture , ata_prim_transformer :: DPrimitive -> DPrimitive } @@ -56,7 +56,7 @@ (ata_prim_transformer ata) -buildPictureATA :: (DRGB -> DPrimitive) +buildPictureATA :: (RGBi -> DPrimitive) -> (DPicture -> DPicture) -> (DPrimitive -> DPrimitive) -> DPicture @@ -64,10 +64,10 @@ picture1 `picBeside` picture2 `picBeside` picture3 where picture1 :: DPicture - picture1 = illustrateBounds light_blue $ frame $ (mk black) + picture1 = illustrateBounds light_blue $ frame [mk black] picture2 :: DPicture - picture2 = illustrateBounds light_blue $ picF $ frame $ (mk blue) + picture2 = illustrateBounds light_blue $ picF $ frame [mk blue] picture3 :: DPicture picture3 = illustrateBoundsPrim light_blue $ prim @@ -85,7 +85,7 @@ { cpa_console_msg :: String , cpa_eps_file :: FilePath , cpa_svg_file :: FilePath - , cpa_prim_constructor :: DRGB -> DPrimitive + , cpa_prim_constructor :: RGBi -> DPrimitive , cpa_prim_transformer :: DPrimitive -> DPrimitive } @@ -98,7 +98,7 @@ where pic = cpPicture (cpa_prim_constructor cpa) (cpa_prim_transformer cpa) -cpPicture :: (DRGB -> DPrimitive) -> (DPrimitive -> DPrimitive) -> DPicture +cpPicture :: (RGBi -> DPrimitive) -> (DPrimitive -> DPrimitive) -> DPicture cpPicture constr trafo = illustrateBounds light_blue $ illustrateControlPoints black $ transformed_prim @@ -109,85 +109,29 @@ -------------------------------------------------------------------------------- -rgbLabel :: DRGB -> DPrimitive +rgbLabel :: RGBi -> DPrimitive rgbLabel rgb = textlabel rgb "Wumpus!" zeroPt -rgbCircle :: DRGB -> DPrimitive +rgbCircle :: RGBi -> DPrimitive rgbCircle rgb = ellipse rgb 60 60 zeroPt -rgbEllipse :: DRGB -> DPrimitive +rgbEllipse :: RGBi -> DPrimitive rgbEllipse rgb = ellipse rgb 60 30 zeroPt -rgbPath :: DRGB -> DPrimitive +rgbPath :: RGBi -> 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 - - --- NOTE - this is redundant if we want consH --- rather than snocH. --- --- Some of the drawings do appear to have problems with --- Z-order so we'll keep it for now. --- -consH :: a -> H a -> H a -consH a hf = 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, lineTo (P2 x y) `consH` f) - -curve_to :: HPath u -> ((u,u),(u,u),(u,u)) -> HPath u -curve_to (s,f) ((c1x,c1y),(c2x,c2y),(ex,ey)) = - (s, curveTo (P2 c1x c1y) (P2 c2x c2y) (P2 ex ey) `consH` f) - - --- --- 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) - + +dog_kennel :: DPrimPath +dog_kennel = path zeroPt [ lineTo (P2 0 60) + , lineTo (P2 40 100) + , lineTo (P2 80 60) + , lineTo (P2 80 0) + , lineTo (P2 60 0) + , lineTo (P2 60 30) + , curveTo (P2 60 50) (P2 50 60) (P2 40 60) + , curveTo (P2 30 60) (P2 20 50) (P2 20 30) + , lineTo (P2 20 0) + ] diff --git a/demo/FontMetrics.hs b/demo/FontMetrics.hs --- a/demo/FontMetrics.hs +++ b/demo/FontMetrics.hs @@ -17,15 +17,14 @@ writeSVG_latin1 "./out/font_metrics.svg" metrics_pic - -peru :: PSRgb -peru = RGB3 0.804 0.522 0.247 +peru :: RGBi +peru = RGBi 205 133 63 -plum :: PSRgb -plum = RGB3 0.867 0.627 0.867 +plum :: RGBi +plum = RGBi 221 160 221 -black :: PSRgb -black = RGB3 0 0 0 +black :: RGBi +black = RGBi 0 0 0 courier_attr :: FontAttr courier_attr = FontAttr 48 (FontFace "Courier" "Courier New" SVG_REGULAR) @@ -34,7 +33,7 @@ metrics_pic = char_pic `picOver` lines_pic lines_pic :: DPicture -lines_pic = frameMulti $ +lines_pic = frame $ [ ascender_line, numeral_line, xheight_line, baseline, descender_line ] where descender_pos = 0 - courier48_descender_depth @@ -48,7 +47,7 @@ char_pic :: Picture Double -char_pic = frameMulti $ zipWith ($) chars (iterate (.+^ hvec 32) zeroPt) +char_pic = frame $ zipWith ($) chars (iterate (.+^ hvec 32) zeroPt) where chars = (map letter "ABXabdgjxy12") ++ [agraveU] @@ -64,10 +63,10 @@ letter ch pt = textlabel (black, courier_attr) [ch] pt -vertLine :: DRGB -> Double -> DPoint2 -> DPrimitive +vertLine :: RGBi -> Double -> DPoint2 -> DPrimitive vertLine rgb height pt = ostroke rgb $ vertexPath [pt, pt .+^ vvec height] -haxis :: DRGB -> PtSize -> DPrimitive +haxis :: RGBi -> PtSize -> DPrimitive haxis rgb ypos = ostroke (rgb, dash_attr) $ vertexPath [ pt, pt .+^ hvec 440 ] where diff --git a/demo/LabelPic.hs b/demo/LabelPic.hs --- a/demo/LabelPic.hs +++ b/demo/LabelPic.hs @@ -12,10 +12,10 @@ drawBounds :: (Floating u, Real u, FromPtSize u) => Picture u -> Picture u -drawBounds p = p `picOver` (frame $ cstroke () ph) +drawBounds p = p `picOver` (frame [cstroke () ph]) where ph = vertexPath $ [bl,br,tr,tl] - (bl,br,tr,tl) = corners $ boundary p + (bl,br,tr,tl) = boundaryCorners $ boundary p -- | The center of a picture. @@ -28,22 +28,21 @@ -------------------------------------------------------------------------------- - -peru :: PSRgb -peru = RGB3 0.804 0.522 0.247 +peru :: RGBi +peru = RGBi 205 133 63 -plum :: PSRgb -plum = RGB3 0.867 0.627 0.867 +plum :: RGBi +plum = RGBi 221 160 221 -black :: PSRgb -black = RGB3 0 0 0 +black :: RGBi +black = RGBi 0 0 0 lbl1 :: Picture Double lbl1 = line1 `picBeside` line2 where - line1 = frame (textlabel attrs "Hello" zeroPt) - line2 = frame (textlabel attrs "World" zeroPt) + line1 = frame [textlabel attrs "Hello" zeroPt] + line2 = frame [textlabel attrs "World" zeroPt] attrs = (peru, FontAttr 12 (FontFace "Helvetica" "Helvetica" SVG_REGULAR)) @@ -90,8 +89,8 @@ bigB = bigLetter peru 'B' bigT = bigLetter plum 'T' -bigLetter :: PSRgb -> Char -> Picture Double -bigLetter col ch = uniformScale 5 $ frame $ textlabel attrs [ch] zeroPt +bigLetter :: RGBi -> Char -> Picture Double +bigLetter col ch = uniformScale 5 $ frame [textlabel attrs [ch] zeroPt] where attrs = (col, FontAttr 12 (FontFace "Helvetica" "Helvetica" SVG_REGULAR)) diff --git a/demo/MultiPic.hs b/demo/MultiPic.hs --- a/demo/MultiPic.hs +++ b/demo/MultiPic.hs @@ -18,7 +18,7 @@ pic1 :: DPicture -pic1 = uniformScale 2 $ frameMulti $ +pic1 = uniformScale 2 $ frame $ [ ellipse blue 10 10 zeroPt , ellipse red 10 10 (P2 40 40) , ztextlabel "Wumpus!" (P2 40 20) @@ -26,7 +26,7 @@ ] -square :: (Num u, Ord u) => DRGB -> u -> Point2 u -> Primitive u +square :: (Num u, Ord u) => RGBi -> u -> Point2 u -> Primitive u square rgb sidelen bl = fill rgb $ vertexPath $ [bl, bl .+^ hvec sidelen, bl .+^ V2 sidelen sidelen, bl .+^ vvec sidelen] diff --git a/demo/Rotated.hs b/demo/Rotated.hs --- a/demo/Rotated.hs +++ b/demo/Rotated.hs @@ -28,7 +28,7 @@ pic1 :: DPicture -pic1 = illustrateBounds grey $ frameMulti $ +pic1 = illustrateBounds grey $ frame $ [ rotatePrimitive deg45 $ square blue 50 (P2 100 100) , square red 50 (P2 100 100) ] @@ -37,7 +37,7 @@ -- both ellipses should share the same center pic2 :: DPicture -pic2 = illustrateBounds grey $ frameMulti $ +pic2 = illustrateBounds grey $ frame $ [ rotatePrimitive deg45 $ ellipseHH blue 25 (P2 100 100) , ellipseHH red 25 (P2 100 100) ] @@ -45,26 +45,26 @@ -- both labels should share the same bottom left corner pic3 :: DPicture -pic3 = illustrateBounds grey $ frameMulti $ +pic3 = illustrateBounds grey $ frame $ [ rotatePrimitive deg45 $ label blue (P2 100 100) , label red (P2 100 100) ] -square :: (Num u, Ord u) => DRGB -> u -> Point2 u -> Primitive u +square :: (Num u, Ord u) => RGBi -> u -> Point2 u -> Primitive u square rgb sidelen bl = fill rgb $ vertexPath $ [bl, bl .+^ hvec sidelen, bl .+^ V2 sidelen sidelen, bl .+^ vvec sidelen] -ellipseHH :: Fractional u => DRGB -> u -> Point2 u -> Primitive u +ellipseHH :: Fractional u => RGBi -> u -> Point2 u -> Primitive u ellipseHH rgb radius ctr = ellipse rgb radius (0.5*radius) ctr -label :: Num u => DRGB -> Point2 u -> Primitive u +label :: Num u => RGBi -> Point2 u -> Primitive u label rgb bl = textlabel rgb "Wumpus" bl -grey :: DRGB -grey = iRGB3 176 197 223 +grey :: RGBi +grey = RGBi 176 197 223 diff --git a/demo/Scaled.hs b/demo/Scaled.hs --- a/demo/Scaled.hs +++ b/demo/Scaled.hs @@ -23,7 +23,7 @@ -- both squares should share the bottom left corner pic1 :: DPicture -pic1 = illustrateBounds grey $ frameMulti $ +pic1 = illustrateBounds grey $ frame $ [ uniformScalePrimitive 0.5 $ square blue 50 (P2 100 100) , square red 50 (P2 100 100) ] @@ -31,7 +31,7 @@ -- both ellipses should share the same center pic2 :: DPicture -pic2 = illustrateBounds grey $ frameMulti $ +pic2 = illustrateBounds grey $ frame $ [ uniformScalePrimitive 0.5 $ ellipseHH blue 25 (P2 100 100) , ellipseHH red 25 (P2 100 100) ] @@ -39,25 +39,25 @@ -- both labels should share the same bottom left corner pic3 :: DPicture -pic3 = illustrateBounds grey $ frameMulti $ +pic3 = illustrateBounds grey $ frame $ [ uniformScalePrimitive 0.5 $ label blue (P2 100 100) , label red (P2 100 100) ] -square :: (Num u, Ord u) => DRGB -> u -> Point2 u -> Primitive u +square :: (Num u, Ord u) => RGBi -> u -> Point2 u -> Primitive u square rgb sidelen bl = fill rgb $ vertexPath $ [bl, bl .+^ hvec sidelen, bl .+^ V2 sidelen sidelen, bl .+^ vvec sidelen] -ellipseHH :: Fractional u => DRGB -> u -> Point2 u -> Primitive u +ellipseHH :: Fractional u => RGBi -> u -> Point2 u -> Primitive u ellipseHH rgb radius ctr = ellipse rgb radius (0.5*radius) ctr -label :: Num u => DRGB -> Point2 u -> Primitive u +label :: Num u => RGBi -> Point2 u -> Primitive u label rgb bl = textlabel rgb "Wumpus" bl -grey :: DRGB -grey = iRGB3 176 197 223 +grey :: RGBi +grey = RGBi 176 197 223 diff --git a/demo/Translated.hs b/demo/Translated.hs --- a/demo/Translated.hs +++ b/demo/Translated.hs @@ -22,38 +22,38 @@ -- both squares should share the bottom left coord... pic1 :: DPicture -pic1 = illustrateBounds grey $ frameMulti $ +pic1 = illustrateBounds grey $ frame $ [ translatePrimitive 100 10 $ square blue 50 (P2 100 100) , square red 50 (P2 100 100) ] pic2 :: DPicture -pic2 = illustrateBounds grey $ frameMulti $ +pic2 = illustrateBounds grey $ frame $ [ translatePrimitive 100 10 $ ellipseHH blue 25 (P2 100 100) , ellipseHH red 25 (P2 100 100) ] pic3 :: DPicture -pic3 = illustrateBounds grey $ frameMulti $ +pic3 = illustrateBounds grey $ frame $ [ translatePrimitive 100 10 $ label blue (P2 100 100) , label red (P2 100 100) ] -square :: (Num u, Ord u) => DRGB -> u -> Point2 u -> Primitive u +square :: (Num u, Ord u) => RGBi -> u -> Point2 u -> Primitive u square rgb sidelen bl = fill rgb $ vertexPath $ [bl, bl .+^ hvec sidelen, bl .+^ V2 sidelen sidelen, bl .+^ vvec sidelen] -ellipseHH :: Fractional u => DRGB -> u -> Point2 u -> Primitive u +ellipseHH :: Fractional u => RGBi -> u -> Point2 u -> Primitive u ellipseHH rgb radius ctr = ellipse rgb radius (0.5*radius) ctr -label :: Num u => DRGB -> Point2 u -> Primitive u +label :: Num u => RGBi -> Point2 u -> Primitive u label rgb bl = textlabel rgb "Wumpus" bl -grey :: DRGB -grey = iRGB3 176 197 223 +grey :: RGBi +grey = RGBi 176 197 223 diff --git a/demo/ZOrderPic.hs b/demo/ZOrderPic.hs new file mode 100644 --- /dev/null +++ b/demo/ZOrderPic.hs @@ -0,0 +1,35 @@ +{-# OPTIONS -Wall #-} + +module ZOrderPic where + +import Wumpus.Core +import Wumpus.Core.Colour + +import Data.AffineSpace -- package: vector-space + +import System.Directory + +main :: IO () +main = do + createDirectoryIfMissing True "./out/" + writeEPS_latin1 "./out/zorder01.eps" combined_pic + writeSVG_latin1 "./out/zorder01.svg" combined_pic + + +combined_pic :: DPicture +combined_pic = multi [pic1,pic2] + +pic1 :: DPicture +pic1 = frame $ prim_list zeroPt + +pic2 :: DPicture +pic2 = multi $ map (\a -> frame [a]) $ prim_list (P2 200 0) + + + +prim_list :: DPoint2 -> [DPrimitive] +prim_list = sequence [ ellipse red 20 20 + , \p -> ellipse green 20 20 (p .+^ hvec 20) + , \p -> ellipse blue 20 20 (p .+^ hvec 40) + ] + diff --git a/doc-src/Guide.lhs b/doc-src/Guide.lhs --- a/doc-src/Guide.lhs +++ b/doc-src/Guide.lhs @@ -164,25 +164,22 @@ Once labels and paths are assembled as a \emph{Picture} they are transformable with the usual affine transformations (scaling, -rotation, translation) and multiple pictures can be composed with -the operations provided by the \texttt{PictureLanguage} module. -The operations should be largely familiar from pretty-printing -libraries although here they are extended to 2 dimensions. +rotation, translation). Once assembled into pictures graphics properties (e.g. colour) are opaque - it is not possible to write a transformation function that turns a picture blue. In some ways this is a limitation - for instance, the \texttt{Diagrams} library appears to support -some notion of attribute overriding; however it is conceptually -simple. If one wanted to make blue arrows or red arrows with -\wumpuscore one would make colour a parameter of the arrow -creating function. +some notion of attribute overriding; however it does keep +\wumpuscore conceptually simple. If one wanted to draw blue or red +arrows with \wumpuscore, one would make drawing colour a parameter +of the arrow creation function. %----------------------------------------------------------------- \section{Affine transformations} %----------------------------------------------------------------- -For affine transformations Wumpus uses the \texttt{Matrix3} data +For affine transformations Wumpus uses the \texttt{Matrix3'3} data type to represent 3x3 matrices in row-major form. The constructor \texttt{(M3'3 a b c d e f g h i)} builds this matrix: @@ -220,7 +217,7 @@ not be very helpful in practice. Internally \wumpuscore only performs the transformation on the pictures bounding box - it needs to do this so transformed pictures can still be composed -with the picture language operations. +with the \texttt{picBeside} combinator. PostScript uses column-major form and uses a six element matrix rather than a nine element one. The translation matrix above @@ -231,7 +228,7 @@ \end{verbatim} Similarly, it would be communicated to SVG via a -\texttt{ } element: +\texttt{group} element: \begin{verbatim} ... @@ -239,11 +236,12 @@ For efficiency reasons \wumpuscore supports some transformations on Primitives. These are not affine transformations as Primitives -are not in an affine frame until they are lifted to Pictures. -For Paths, all the transformations are precomputed before the -output is generated. Unfortunately scaling and rotation cannot be -precomputed for labels and ellipses, so matrix operations are -generated in the PostScript and SVG output. +are not in an affine frame until they are lifted to Pictures +(Primitives have no notion of origin). For Paths, all the +transformations are precomputed before the output is generated. +Unfortunately scaling and rotation cannot be precomputed for +labels and ellipses, so matrix operations are generated in the +PostScript and SVG output. %----------------------------------------------------------------- @@ -255,20 +253,21 @@ label's string rather than the metrics of the individual letters encoded in the font. Accessing the glyph metrics in a font would require a font loader to read TrueType font files. This would be -a significant effort, probably larger than the effort put into -\wumpuscore itself; for \wumpuscore's intended use - producing -diagrams and pictures rather than high quality text - its -primitive font handling is not such a draw back. +a significant development effort, probably larger than the effort +put into \wumpuscore itself; for \wumpuscore's intended use - +producing diagrams and pictures rather than high quality text - +its primitive font handling is not such a draw back. In both PostScript and SVG mis-named fonts can cause somewhat inscrutable printing anomalies - usually falling back to a default -font but not always. PostScript may do no subsequent drawing after -a font load error. \wumpuscore uses @scalefont@ in the generated -PostScript, this semingly works for any integer size and not just -the regular font sizes (10, 12, 18, 24, 36). Older versions of -\wumpuscore mention that using non-standard sizes may cause font -loading problems, however this does not appear to be the case. +font but not always. At worst, PostScript may do no subsequent +drawing after a font load error. \wumpuscore uses @scalefont@ in +the generated PostScript, this semingly works for any integer size +and not just the regular font sizes (10, 12, 18, 24, 36). Older +versions of \wumpuscore mention that using non-standard sizes may +cause font loading problems, however this does not appear to be +the case. The following table lists PostScript fonts and their SVG diff --git a/doc-src/Makefile b/doc-src/Makefile --- a/doc-src/Makefile +++ b/doc-src/Makefile @@ -9,3 +9,5 @@ dvipdfm -o ./out/Guide.pdf ./out/Guide.dvi cp ./out/Guide.pdf ../doc +worldframe: WorldFrame.hs + runhaskell -i../src WorldFrame.hs diff --git a/doc-src/WorldFrame.hs b/doc-src/WorldFrame.hs --- a/doc-src/WorldFrame.hs +++ b/doc-src/WorldFrame.hs @@ -11,9 +11,9 @@ world_frame :: DPicture world_frame = uniformScale 0.75 $ - frameMulti [ ogin, btm_right, top_left, top_right - , x_axis, y_axis, line1 - ] + frame [ 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) @@ -29,7 +29,7 @@ makeLabelPrim :: String -> DPoint2 -> DPrimitive makeLabelPrim = textlabel attrs where - attrs = (black, FontAttr "Helvetica" "Helvetica" SVG_REGULAR 10) + attrs = (black, FontAttr 10 (FontFace "Helvetica" "Helvetica" SVG_REGULAR)) makeLinePrim :: Double -> DPoint2 -> DPoint2 -> DPrimitive makeLinePrim lw a b = ostroke attrs $ path a [lineTo b] diff --git a/doc/Guide.pdf b/doc/Guide.pdf Binary files a/doc/Guide.pdf and b/doc/Guide.pdf differ diff --git a/src/Wumpus/Core.hs b/src/Wumpus/Core.hs --- a/src/Wumpus/Core.hs +++ b/src/Wumpus/Core.hs @@ -8,7 +8,7 @@ -- -- Maintainer : Stephen Tetley -- Stability : unstable --- Portability : GHC with TypeFamilies and more +-- Portability : GHC -- -- Common interface to Wumpus.Core. -- @@ -75,7 +75,7 @@ import Wumpus.Core.Colour hiding ( black, white, red, green, blue ) import Wumpus.Core.FontSize import Wumpus.Core.Geometry -import Wumpus.Core.GraphicsState hiding ( CTM, ToCTM ) +import Wumpus.Core.GraphicsState hiding ( GraphicsState ) import Wumpus.Core.OutputPostScript import Wumpus.Core.OutputSVG import Wumpus.Core.Picture diff --git a/src/Wumpus/Core/AffineTrans.hs b/src/Wumpus/Core/AffineTrans.hs --- a/src/Wumpus/Core/AffineTrans.hs +++ b/src/Wumpus/Core/AffineTrans.hs @@ -11,7 +11,7 @@ -- -- Maintainer : stephen.tetley@gmail.com -- Stability : unstable --- Portability : GHC with TypeFamilies and more +-- Portability : GHC -- -- Affine transformations. -- @@ -31,7 +31,7 @@ -- -- To generate efficient PostScript, Wumpus relies on the matrix -- representations of the affine transformations being invertible. --- Please do not scale elements by zero. +-- Do not scale elements by zero! -- -------------------------------------------------------------------------------- @@ -77,7 +77,8 @@ -------------------------------------------------------------------------------- -- Affine transformations --- | Apply a matrix trasnformation directly. +-- | Apply a matrix transformation directly. +-- class Transform t where transform :: u ~ DUnit t => Matrix3'3 u -> t -> t @@ -103,6 +104,7 @@ -- | Type class for rotation about a point. +-- class RotateAbout t where rotateAbout :: u ~ DUnit t => Radian -> Point2 u -> t -> t @@ -118,27 +120,29 @@ -- Scale -- | Type class for scaling. +-- class Scale t where scale :: u ~ DUnit t => u -> u -> t -> t instance Num u => Scale (Point2 u) where - scale x y = ((scalingMatrix x y) *#) + scale sx sy = ((scalingMatrix sx sy) *#) instance Num u => Scale (Vec2 u) where - scale x y = ((scalingMatrix x y) *#) + scale sx sy = ((scalingMatrix sx sy) *#) -------------------------------------------------------------------------------- -- Translate --- | Type class for translations. +-- | Type class for translation. +-- class Translate t where translate :: DUnit t -> DUnit t -> t -> t instance Num u => Translate (Point2 u) where - translate x y = ((translationMatrix x y) *#) + translate dx dy (P2 x y) = P2 (x+dx) (y+dy) instance Num u => Translate (Vec2 u) where - translate x y = ((translationMatrix x y) *#) + translate dx dy (V2 x y) = V2 (x+dx) (y+dy) -------------------------------------------------------------------------------- @@ -147,42 +151,52 @@ -- | Rotate by 30 degrees about the origin. +-- rotate30 :: Rotate t => t -> t rotate30 = rotate (pi/6) -- | Rotate by 30 degrees about the supplied point. +-- rotate30About :: (RotateAbout t, DUnit t ~ u) => Point2 u -> t -> t rotate30About = rotateAbout (pi/6) -- | Rotate by 45 degrees about the origin. +-- rotate45 :: Rotate t => t -> t rotate45 = rotate (pi/4) -- | Rotate by 45 degrees about the supplied point. +-- rotate45About :: (RotateAbout t, DUnit t ~ u) => Point2 u -> t -> t rotate45About = rotateAbout (pi/4) -- | Rotate by 60 degrees about the origin. +-- rotate60 :: Rotate t => t -> t rotate60 = rotate (2*pi/3) -- | Rotate by 60 degrees about the supplied point. +-- rotate60About :: (RotateAbout t, DUnit t ~ u) => Point2 u -> t -> t rotate60About = rotateAbout (2*pi/3) -- | Rotate by 90 degrees about the origin. +-- rotate90 :: Rotate t => t -> t rotate90 = rotate (pi/2) -- | Rotate by 90 degrees about the supplied point. +-- rotate90About :: (RotateAbout t, DUnit t ~ u) => Point2 u -> t -> t rotate90About = rotateAbout (pi/2) -- | Rotate by 120 degrees about the origin. +-- rotate120 :: Rotate t => t -> t rotate120 = rotate (4*pi/3) -- | Rotate by 120 degrees about the supplied point. +-- rotate120About :: (RotateAbout t, DUnit t ~ u) => Point2 u -> t -> t rotate120About = rotateAbout (4*pi/3) @@ -192,21 +206,25 @@ -- Common scalings -- | Scale both x and y dimensions by the same amount. +-- uniformScale :: (Scale t, DUnit t ~ u) => u -> t -> t uniformScale a = scale a a -- | Reflect in the X-plane about the origin. +-- reflectX :: (Num u, Scale t, DUnit t ~ u) => t -> t reflectX = scale (-1) 1 -- | Reflect in the Y-plane about the origin. +-- reflectY :: (Num u, Scale t, DUnit t ~ u) => t -> t reflectY = scale 1 (-1) -------------------------------------------------------------------------------- --- translations +-- Translations -- | Translate by the x and y components of a vector. +-- translateBy :: (Translate t, DUnit t ~ u) => Vec2 u -> t -> t translateBy (V2 x y) = translate x y @@ -215,11 +233,13 @@ -- Translation and scaling -- | Reflect in the X plane that intersects the supplied point. +-- reflectXPlane :: (Num u, Scale t, Translate t, u ~ DUnit t) => Point2 u -> t -> t reflectXPlane (P2 x y) = translate x y . scale (-1) 1 . translate (-x) (-y) -- | Reflect in the Y plane that intersects the supplied point. +-- reflectYPlane :: (Num u, Scale t, Translate t, u ~ DUnit t) => Point2 u -> t -> t reflectYPlane (P2 x y) = translate x y . scale 1 (-1) . translate (-x) (-y) diff --git a/src/Wumpus/Core/BoundingBox.hs b/src/Wumpus/Core/BoundingBox.hs --- a/src/Wumpus/Core/BoundingBox.hs +++ b/src/Wumpus/Core/BoundingBox.hs @@ -9,7 +9,7 @@ -- -- Maintainer : stephen.tetley@gmail.com -- Stability : unstable --- Portability : GHC with TypeFamilies and more +-- Portability : GHC -- -- Bounding box with no notion of \'empty\'. -- @@ -17,10 +17,6 @@ -- simplifies the implementation of pictures themselves and -- bounding boxes. -- --- WARNING - this module is no so tightly designed, with some --- of the functions seeming superfluous in hindsight. It is --- likely to change in the future. --- -------------------------------------------------------------------------------- module Wumpus.Core.BoundingBox @@ -35,32 +31,26 @@ -- * Operations , bbox , obbox - , union + , destBoundingBox + , boundaryUnion , traceBoundary , retraceBoundary - , corners - , within + , boundaryCorners + , withinBoundary , boundaryWidth , boundaryHeight - , boundaryBottomLeft - , boundaryTopRight - , boundaryTopLeft - , boundaryBottomRight - , leftPlane - , rightPlane - , lowerPlane - , upperPlane + ) where import Wumpus.Core.AffineTrans +import Wumpus.Core.FormatCombinators import Wumpus.Core.Geometry - -import Data.Semigroup +import Wumpus.Core.Utils ( PSUnit(..) ) -import Text.PrettyPrint.Leijen hiding ( width ) +import Data.Semigroup -- package: algebra @@ -87,11 +77,12 @@ -- BBox is NOT monoidal - it\'s much simpler that way. instance Ord u => Semigroup (BoundingBox u) where - append = union + append = boundaryUnion -instance Pretty u => Pretty (BoundingBox u) where - pretty (BBox p0 p1) = text "|_" <+> pretty p0 <+> pretty p1 <+> text "_|" +instance PSUnit u => Format (BoundingBox u) where + format (BBox p0 p1) = parens (text "BBox" <+> text "ll=" <> format p0 + <+> text "ur=" <> format p1) -------------------------------------------------------------------------------- @@ -99,10 +90,27 @@ type instance DUnit (BoundingBox u) = u +pointTransform :: (Num u , Ord u) + => (Point2 u -> Point2 u) -> BoundingBox u -> BoundingBox u +pointTransform fn bb = traceBoundary $ map fn $ [bl,br,tr,tl] + where + (bl,br,tr,tl) = boundaryCorners bb + + +instance (Num u, Ord u) => Transform (BoundingBox u) where + transform mtrx = pointTransform (mtrx *#) + +instance (Real u, Floating u) => Rotate (BoundingBox u) where + rotate theta = pointTransform (rotate theta) + +instance (Real u, Floating u) => RotateAbout (BoundingBox u) where + rotateAbout theta pt = pointTransform (rotateAbout theta pt) + instance (Num u, Ord u) => Scale (BoundingBox u) where - scale x y bb = traceBoundary $ map (scale x y) $ [bl,br,tr,tl] - where (bl,br,tr,tl) = corners bb + scale sx sy = pointTransform (scale sx sy) +instance (Num u, Ord u) => Translate (BoundingBox u) where + translate dx dy = pointTransform (translate dx dy) -------------------------------------------------------------------------------- @@ -111,16 +119,8 @@ -- | Type class extracting the bounding box of an object - -- Picture, Path etc. -- -class Boundary a where - boundary :: DUnit a ~ u => a -> BoundingBox u - - --------------------------------------------------------------------------------- - - -instance Pointwise (BoundingBox u) where - type Pt (BoundingBox u) = Point2 u - pointwise f (BBox bl tr) = BBox (f bl) (f tr) +class Boundary t where + boundary :: u ~ DUnit t => t -> BoundingBox u -------------------------------------------------------------------------------- @@ -143,12 +143,22 @@ obbox :: Num u => u -> u -> BoundingBox u obbox w h = BBox zeroPt (P2 w h) +-- | Destructor for BoundingBox. +-- +-- Assembles a four-tuple @ (ll_x, ll_y, ur_x, ur_y) @. +-- +-- Arguably this is easier to pattern match upon as it removes a +-- layer of nesting. +-- +destBoundingBox :: BoundingBox u -> (u,u,u,u) +destBoundingBox (BBox (P2 llx lly) (P2 urx ury)) = (llx, lly, urx, ury) + -- | The union of two bounding boxes. This is also the @append@ -- of BoundingBox\'s @Semigroup@ instance. -- -union :: Ord u => BoundingBox u -> BoundingBox u -> BoundingBox u -BBox ll ur `union` BBox ll' ur' = BBox (minPt ll ll') (maxPt ur ur') +boundaryUnion :: Ord u => BoundingBox u -> BoundingBox u -> BoundingBox u +BBox ll ur `boundaryUnion` BBox ll' ur' = BBox (minPt ll ll') (maxPt ur ur') -- | Trace a list of points, retuning the BoundingBox that -- includes them. @@ -170,22 +180,22 @@ -- retraceBoundary :: (Num u, Ord u) => (Point2 u -> Point2 u) -> BoundingBox u -> BoundingBox u -retraceBoundary f = traceBoundary . map f . fromCorners . corners +retraceBoundary f = traceBoundary . map f . fromCorners . boundaryCorners 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)@. -corners :: BoundingBox u -> (Point2 u, Point2 u, Point2 u, Point2 u) -corners (BBox bl@(P2 x0 y0) tr@(P2 x1 y1)) = (bl, br, tr, tl) where +boundaryCorners :: BoundingBox u -> (Point2 u, Point2 u, Point2 u, Point2 u) +boundaryCorners (BBox bl@(P2 x0 y0) tr@(P2 x1 y1)) = (bl, br, tr, tl) where br = P2 x1 y0 tl = P2 x0 y1 -- | Within test - is the supplied point within the bounding box? -- -within :: Ord u => Point2 u -> BoundingBox u -> Bool -within p (BBox ll ur) = (minPt p ll) == ll && (maxPt p ur) == ur +withinBoundary :: Ord u => Point2 u -> BoundingBox u -> Bool +withinBoundary p (BBox ll ur) = (minPt p ll) == ll && (maxPt p ur) == ur -- | Extract the width of a bounding box. -- @@ -196,54 +206,6 @@ -- boundaryHeight :: Num u => BoundingBox u -> u boundaryHeight (BBox (P2 _ ymin) (P2 _ ymax)) = ymax - ymin - - --------------------------------------------------------------------------------- - --- Points on the boundary - --- | Extract the bottom-left corner of the bounding box. -boundaryBottomLeft :: BoundingBox u -> Point2 u -boundaryBottomLeft (BBox p0 _ ) = p0 - --- | Extract the top-right corner of the bounding box. -boundaryTopRight :: BoundingBox u -> Point2 u -boundaryTopRight (BBox _ p1) = p1 - --- | Extract the top-left corner of the bounding box. -boundaryTopLeft :: BoundingBox u -> Point2 u -boundaryTopLeft (BBox (P2 x _) (P2 _ y)) = P2 x y - --- | Extract the bottom-right corner of the bounding box. -boundaryBottomRight :: BoundingBox u -> Point2 u -boundaryBottomRight (BBox (P2 _ y) (P2 x _)) = P2 x y - - - - --------------------------------------------------------------------------------- - --- /planes/ on the bounding box - --- Are these really worthwhile ? ... - --- | Extract the unit of the left vertical plane. -leftPlane :: BoundingBox u -> u -leftPlane (BBox (P2 l _) _) = l - --- | Extract the unit of the right vertical plane. -rightPlane :: BoundingBox u -> u -rightPlane (BBox _ (P2 r _)) = r - --- | Extract the unit of the lower horizontal plane. -lowerPlane :: BoundingBox u -> u -lowerPlane (BBox (P2 _ l) _) = l - --- | Extract the unit of the upper horizontal plane. -upperPlane :: BoundingBox u -> u -upperPlane (BBox _ (P2 _ u)) = u - - diff --git a/src/Wumpus/Core/Colour.hs b/src/Wumpus/Core/Colour.hs --- a/src/Wumpus/Core/Colour.hs +++ b/src/Wumpus/Core/Colour.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- @@ -8,288 +6,88 @@ -- Copyright : (c) Stephen Tetley 2009-2010 -- License : BSD3 -- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC with TypeFamilies and more --- --- --- RGB, HSB, Gray colour types, and conversions between them. --- --- Internally Wumpus uses @RGB3 Double@ with range [0.0, 1..0] --- as the colour type. All colour values in the generated SVG or --- PostScript files will be RGB. +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC -- --- Colour have Num instances for convenience, though the --- operations of @Data.VectorSpace@ (instances also defined) --- seem more approriate. +-- Colour represented as RGB with each component in the range +-- [0..255]. +-- +-- Note - the predifined colours are hidden when importing the +-- /top-level/ module @Wumpus.Core@, import this module directly +-- to use them. -- -------------------------------------------------------------------------------- -module Wumpus.Core.Colour - ( - -- * Colour types - RGB3(..) - , DRGB - , HSB3(..) - , DHSB - , Gray(..) - , DGray - - -- * Utility constructor - , iRGB3 - , iHSB3 - , iGray - - -- * Operations - , rgb2hsb - , hsb2rgb +module Wumpus.Core.Colour + ( - , rgb2gray - , gray2rgb + -- * RGB colour type + RGBi(..) - , hsb2gray - , gray2hsb - -- * Predefined colours , black , white , red , green , blue - + ) where -import Wumpus.Core.Utils - - -import Data.VectorSpace +import Wumpus.Core.FormatCombinators --- | Red-Green-Blue - no alpha. --- -data RGB3 a = RGB3 !a !a !a - deriving (Eq,Show) +import Data.Word --- | RGB representated by Double - values should be in the range --- 0.0 to 1.0. +-- | Colours levels are in the range [0..255] -- --- 1.0 represents full saturation, for instance red is --- 1.0, 0.0, 0.0. --- -type DRGB = RGB3 Double - - --- | Hue-Saturation-Brightness. +-- Note - this is the format used by SVG, whereas PostScript uses +-- [0..1]. -- -data HSB3 a = HSB3 !a !a !a - deriving (Eq,Show) - --- | HSB represented by Double - values should be in the range --- 0.0 to 1.0. +-- It is more efficient to prefer SVG here. -- -type DHSB = HSB3 Double - --- | Gray scale. --- -newtype Gray a = Gray a - deriving (Eq,Num,Fractional,Ord,Show) - --- | Gray represented by a Double - values should be in the range --- 0.0 (black) to 1.0 (white). -type DGray = Gray Double +data RGBi = RGBi !Word8 !Word8 !Word8 + deriving (Eq,Ord,Show) -------------------------------------------------------------------------------- --- Num instances - -instance Num a => Num (RGB3 a) where - (+) (RGB3 a b c) (RGB3 x y z) = RGB3 (a+x) (b+y) (c+z) - (-) (RGB3 a b c) (RGB3 x y z) = RGB3 (a-x) (b-y) (c-z) - (*) (RGB3 a b c) (RGB3 x y z) = RGB3 (a*x) (b*y) (c*z) - abs (RGB3 a b c) = RGB3 (abs a) (abs b) (abs c) - negate (RGB3 a b c) = RGB3 (negate a) (negate b) (negate c) - signum (RGB3 a b c) = RGB3 (signum a) (signum b) (signum c) - fromInteger i = RGB3 (fromInteger i) (fromInteger i) (fromInteger i) - - -instance Num a => Num (HSB3 a) where - (+) (HSB3 a b c) (HSB3 x y z) = HSB3 (a+x) (b+y) (c+z) - (-) (HSB3 a b c) (HSB3 x y z) = HSB3 (a-x) (b-y) (c-z) - (*) (HSB3 a b c) (HSB3 x y z) = HSB3 (a*x) (b*y) (c*z) - abs (HSB3 a b c) = HSB3 (abs a) (abs b) (abs c) - negate (HSB3 a b c) = HSB3 (negate a) (negate b) (negate c) - signum (HSB3 a b c) = HSB3 (signum a) (signum b) (signum c) - fromInteger i = HSB3 (fromInteger i) (fromInteger i) (fromInteger i) - --- Num (Gray a) derived - - -instance Fractional a => Fractional (RGB3 a) where - (/) (RGB3 a b c) (RGB3 x y z) = RGB3 (a/x) (b/y) (c/z) - recip (RGB3 a b c) = RGB3 (recip a) (recip b) (recip c) - fromRational a = RGB3 (fromRational a) (fromRational a) (fromRational a) +-- instances -instance Fractional a => Fractional (HSB3 a) where - (/) (HSB3 a b c) (HSB3 x y z) = HSB3 (a/x) (b/y) (c/z) - recip (HSB3 a b c) = HSB3 (recip a) (recip b) (recip c) - fromRational a = HSB3 (fromRational a) (fromRational a) (fromRational a) +instance Format RGBi where + format (RGBi 0 0 0) = text "*black*" + format (RGBi 255 255 255) = text "*white*" + format (RGBi r g b) = integral r <> comma <> integral g + <> comma <> integral b --- Fractional (Gray a) derived - -------------------------------------------------------------------------------- --- Instances for VectorSpace - -instance Num a => AdditiveGroup (RGB3 a) where - zeroV = RGB3 0 0 0 - (^+^) = (+) - negateV = negate - -instance Num a => AdditiveGroup (HSB3 a) where - zeroV = HSB3 0 0 0 - (^+^) = (+) - negateV = negate -instance Num a => AdditiveGroup (Gray a) where - zeroV = Gray 0 -- black - (^+^) = (+) - negateV = negate - - -instance Num a => VectorSpace (RGB3 a) where - type Scalar (RGB3 a) = a - s *^ (RGB3 a b c) = RGB3 (s*a) (s*b) (s*c) - -instance Num a => VectorSpace (HSB3 a) where - type Scalar (HSB3 a) = a - s *^ (HSB3 a b c) = HSB3 (s*a) (s*b) (s*c) - -instance Num a => VectorSpace (Gray a) where - type Scalar (Gray a) = a - s *^ (Gray a) = Gray (s*a) - - --------------------------------------------------------------------------------- --- 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 - - -vE :: DRGB -vE = RGB3 1 1 1 - --- Acknowledgment - the conversion functions are derived from --- the documentation to Dr. Uwe Kern's xcolor LaTeX package - - --- | Covert RGB \[0,1\] to HSB \[0,1\]. -rgb2hsb :: DRGB -> DHSB -rgb2hsb (RGB3 r g b) = HSB3 hue sat bri - where - x = max3 r g b - y = med3 r g b - z = min3 r g b - - bri = x - - (sat,hue) = if x==z then (0,0) else ((x-z)/x, f $ (x-y)/(x-z)) - - f n | r >= g && g >= b = (1/6) * (1-n) - | g >= r && r >= b = (1/6) * (1+n) - | g >= b && b >= r = (1/6) * (3-n) - | b >= g && g >= r = (1/6) * (3+n) - | b >= r && r >= g = (1/6) * (5-n) - | otherwise = (1/6) * (5+n) - - --- | Covert HSB \[0,1\] to RGB \[0,1\]. -hsb2rgb :: DHSB -> DRGB -hsb2rgb (HSB3 hue sat bri) = bri *^ (vE - (sat *^ fV)) - where - i :: Int - i = floor $ (6 * hue) - f = (6 * hue) - fromIntegral i - fV | i == 0 = RGB3 0 (1-f) 1 - | i == 1 = RGB3 f 0 1 - | i == 2 = RGB3 1 0 (1-f) - | i == 3 = RGB3 1 f 0 - | i == 4 = RGB3 (1-f) 1 0 - | i == 5 = RGB3 0 1 f - | otherwise = RGB3 0 1 1 - --- | Covert RGB \[0,1\] to Gray \[0,1\]. -rgb2gray :: DRGB -> DGray -rgb2gray (RGB3 r g b) = Gray $ 0.3 * r + 0.59 * g + 0.11 * b - - --- | Covert Gray \[0,1\] to RGB \[0,1\]. -gray2rgb :: DGray -> DRGB -gray2rgb (Gray a) = a *^ vE - - --- | Covert HSB \[0,1\] to Gray \[0,1\]. -hsb2gray :: DHSB -> DGray -hsb2gray (HSB3 _ _ b) = Gray b - - --- | Covert Gray \[0,1\] to HSB \[0,1\]. -gray2hsb :: DGray -> DHSB -gray2hsb (Gray a) = HSB3 0 0 a - - - - --------------------------------------------------------------------------------- - -- Some colours -- There will be name clashes with the X11Colours / SVGColours. --- | Black - 0.0, 0.0, 0.0. +-- | Black - 0, 0, 0. -- -black :: DRGB -black = RGB3 0 0 0 +black :: RGBi +black = RGBi 0 0 0 --- | White - 1.0, 1.0, 1.0. +-- | White - 255, 255, 255. -- -white :: DRGB -white = RGB3 1 1 1 +white :: RGBi +white = RGBi 255 255 255 --- | Red - 1.0, 0.0, 0.0. +-- | Red - 255, 0, 0. -- -red :: DRGB -red = RGB3 1 0 0 +red :: RGBi +red = RGBi 255 0 0 --- | Green - 0.0, 1.0, 0.0. +-- | Green - 0, 255, 0. -- -green :: DRGB -green = RGB3 0 1 0 +green :: RGBi +green = RGBi 0 255 0 --- | Blue - 0.0, 0.0, 1.0. +-- | Blue - 0, 0, 255. -- -blue :: DRGB -blue = RGB3 0 0 1 - +blue :: RGBi +blue = RGBi 0 0 255 diff --git a/src/Wumpus/Core/FontSize.hs b/src/Wumpus/Core/FontSize.hs --- a/src/Wumpus/Core/FontSize.hs +++ b/src/Wumpus/Core/FontSize.hs @@ -8,7 +8,7 @@ -- -- Maintainer : stephen.tetley@gmail.com -- Stability : unstable --- Portability : GHC with TypeFamilies and more +-- Portability : GHC -- -- Font size calculation for Label\'s and their bounding boxes. -- diff --git a/src/Wumpus/Core/FormatCombinators.hs b/src/Wumpus/Core/FormatCombinators.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Core/FormatCombinators.hs @@ -0,0 +1,384 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Core.FormatCombinators +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Formatting combinators - pretty printers without the fitting. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Core.FormatCombinators + ( + Doc + , DocS + , Format(..) + , empty + , showsDoc + , (<>) + , (<+>) + , vconcat + , separate + , hcat + , hsep + , vcat + + , text + , char + , int + , integer + , integral + , float + , double + + , space + , comma + , semicolon + , line + + , fill + + , punctuate + , enclose + , squotes + , dquotes + , parens + , brackets + , braces + , angles + + , lparen + , rparen + , lbracket + , rbracket + , lbrace + , rbrace + , langle + , rangle + + , list + , tupled + , semiBraces + + , indent + + ) where + +import Data.Monoid +import Numeric + +-- | Doc is a Join List ... +-- +data Doc = Doc1 ShowS + | Join Doc Doc + | Line + | Indent !Int Doc + + +type DocS = Doc -> Doc + + +-- Join could be improved... +-- +unDoc :: Doc -> ShowS +unDoc = step 0 id + where + step _ acc (Doc1 sf) = acc . sf + step n acc (Join a b) = let acc' = step n acc a in step n acc' b + step n acc Line = acc . showChar '\n' . indentS n + step n acc (Indent i d) = step (n+i) (acc . (indentS i)) d + + +indentS :: Int -> ShowS +indentS i | i < 1 = id + | otherwise = showString $ replicate i ' ' + +runDoc :: Doc -> String +runDoc = ($ "") . unDoc + + +instance Show Doc where + show = runDoc + +instance Monoid Doc where + mempty = empty + mappend = (<>) + + +class Format a where format :: a -> Doc + +-------------------------------------------------------------------------------- + +infixr 6 <>, <+> + + + +-- | Create an empty, zero length document. +-- +empty :: Doc +empty = Doc1 id + +-- | Create a document from a ShowS function. +-- +showsDoc :: ShowS -> Doc +showsDoc = Doc1 + + +-- | Horizontally concatenate two documents with no space +-- between them. +-- +(<>) :: Doc -> Doc -> Doc +a <> b = Join a b + + +-- | Horizontally concatenate two documents with a single space +-- between them. +-- +(<+>) :: Doc -> Doc -> Doc +a <+> b = Join a (Join space b) + +-- | Vertical concatenate two documents with a line break. +-- +vconcat :: Doc -> Doc -> Doc +vconcat a b = a <> Line <> b + + + +separate :: Doc -> [Doc] -> Doc +separate _ [] = empty +separate sep (a:as) = step a as + where + step acc [] = acc + step acc (x:xs) = step (acc <> sep <> x) xs + +-- | Horizontally concatenate a list of documents with @(\<\>)@. +-- +hcat :: [Doc] -> Doc +hcat = foldr (<>) empty + +-- | Horizontally concatenate a list of documents with @(\<+\>)@. +-- +hsep :: [Doc] -> Doc +hsep = separate space + +-- | Vertically concatenate a list of documents, with a line +-- break between each doc. +-- +vcat :: [Doc] -> Doc +vcat [] = empty +vcat (x:xs) = step x xs + where + step acc (z:zs) = step (acc `vconcat` z) zs + step acc [] = acc + +-- | Create a document from a literal string. +-- +-- The string should not contain newlines (though this is not +-- enforced). +-- +text :: String -> Doc +text = Doc1 . showString + + +-- | Create a document from a literal character. +-- +-- The char should not be a tab or newline. +-- +char :: Char -> Doc +char = Doc1 . showChar + +-- | Show the Int as a Doc. +-- +-- > int = text . show +-- +int :: Int -> Doc +int = Doc1 . showInt + +-- | Show the Integer as a Doc. +-- +integer :: Integer -> Doc +integer = Doc1 . showInt + +-- | Show an \"integral value\" as a Doc via 'fromIntegral'. +-- +integral :: Integral a => a -> Doc +integral = Doc1 . showInt + +-- | Show the Float as a Doc. +-- +float :: Double -> Doc +float = Doc1 . showFloat + +-- | Show the Double as a Doc. +-- +double :: Double -> Doc +double = Doc1 . showFloat + +-- | Create a Doc containing a single space character. +-- +space :: Doc +space = char ' ' + +-- | Create a Doc containing a comma, \",\". +-- +comma :: Doc +comma = char ',' + +-- | Create a Doc containing a semi colon, \";\". +-- +semicolon :: Doc +semicolon = char ';' + +-- | Create a Doc containing newline, \"\\n\". +-- +line :: Doc +line = char '\n' + + +-------------------------------------------------------------------------------- + +-- | Fill a doc to the supplied length, padding the right-hand +-- side with spaces. +-- +-- Note - this function is expensive - it unrolls the functional +-- representation of the String. +-- +-- Also it should only be used for single line Doc\'s. +-- +fill :: Int -> Doc -> Doc +fill i d = Doc1 (padr i ' ' $ unDoc d) + +padr :: Int -> Char -> ShowS -> ShowS +padr i c df = step (length $ df []) + where + step len | len >= i = df + | otherwise = df . showString (replicate (i-len) c) + +-------------------------------------------------------------------------------- + +-- | Punctuate the Doc list with the separator, producing a Doc. +-- +punctuate :: Doc -> [Doc] -> Doc +punctuate _ [] = empty +punctuate _ [x] = x +punctuate s (x:xs) = x <> s <> punctuate s xs + + +-- | Enclose the final Doc within the first two. +-- +-- There are no spaces between the documents: +-- +-- > enclose l r d = l <> d <> r +-- +enclose :: Doc -> Doc -> Doc -> Doc +enclose l r d = l <> d <> r + + + +-- | Enclose the Doc within single quotes. +-- +squotes :: Doc -> Doc +squotes = enclose (char '\'') (char '\'') + +-- | Enclose the Doc within double quotes. +-- +dquotes :: Doc -> Doc +dquotes = enclose (char '"') (char '"') + +-- | Enclose the Doc within parens @()@. +-- +parens :: Doc -> Doc +parens = enclose lparen rparen + +-- | Enclose the Doc within square brackets @[]@. +-- +brackets :: Doc -> Doc +brackets = enclose lbracket rbracket + +-- | Enclose the Doc within curly braces @{}@. +-- +braces :: Doc -> Doc +braces = enclose lbrace rbrace + +-- | Enclose the Doc within angle brackets @\<\>@. +-- +angles :: Doc -> Doc +angles = enclose langle rangle + + + +-- | Create a Doc containing a left paren, \'(\'. +-- +lparen :: Doc +lparen = char '(' + +-- | Create a Doc containing a right paren, \')\'. +-- +rparen :: Doc +rparen = char ')' + +-- | Create a Doc containing a left square bracket, \'[\'. +-- +lbracket :: Doc +lbracket = char '[' + +-- | Create a Doc containing a right square bracket, \']\'. +-- +rbracket :: Doc +rbracket = char ']' + +-- | Create a Doc containing a left curly brace, \'{\'. +-- +lbrace :: Doc +lbrace = char '{' + +-- | Create a Doc containing a right curly brace, \'}\'. +-- +rbrace :: Doc +rbrace = char '}' + +-- | Create a Doc containing a left angle bracket, \'\<\'. +-- +langle :: Doc +langle = char '<' + +-- | Create a Doc containing a right angle bracket, \'\>\'. +-- +rangle :: Doc +rangle = char '>' + +-- | Comma separate the list of documents and enclose in square +-- brackets. +-- +list :: [Doc] -> Doc +list = brackets . punctuate comma + +-- | Comma separate the list of documents and enclose in parens. +-- +tupled :: [Doc] -> Doc +tupled = parens . punctuate comma + +-- | Separate the list with a semicolon and enclose in curly +-- braces. +-- +semiBraces :: [Doc] -> Doc +semiBraces = braces . punctuate semicolon + + +-- | Horizontally indent a Doc. +-- +-- Note - this space-prefixes the Doc on /the current line/. It +-- does not indent subsequent lines if the Doc spans multiple +-- lines. +-- +indent :: Int -> Doc -> Doc +indent i d | i < 1 = d + | otherwise = Indent i d + + diff --git a/src/Wumpus/Core/Geometry.hs b/src/Wumpus/Core/Geometry.hs --- a/src/Wumpus/Core/Geometry.hs +++ b/src/Wumpus/Core/Geometry.hs @@ -1,32 +1,31 @@ {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS -Wall #-} ------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- -- | -- Module : Wumpus.Core.Geometry -- Copyright : (c) Stephen Tetley 2009-2010 -- License : BSD3 -- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC with TypeFamilies and more +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC -- -- Objects and operations for 2D geometry. -- --- Vector, point, affine frame, 3x3 matrix, and radian --- representations, plus a type family @DUnit@ for parameterizing --- type classes with some /dimension/. +-- Vector, point, 3x3 matrix, and radian representations, +-- plus a type family @DUnit@ for parameterizing type classes +-- with some /dimension/. -- -------------------------------------------------------------------------------- -module Wumpus.Core.Geometry + +module Wumpus.Core.Geometry ( + -- * Type family DUnit @@ -35,17 +34,11 @@ , DVec2 , Point2(..) , DPoint2 - , Frame2(..) - , DFrame2 , Matrix3'3(..) , DMatrix3'3 - , Radian - - -- * Pointwise type class - , Pointwise(..) + , Radian - -- * Matrix multiply type class , MatrixMult(..) -- * Vector operations @@ -60,18 +53,9 @@ -- * Point operations , zeroPt - , minPt , maxPt - , langle - - -- * Frame operations - , ortho - , displaceOrigin - , pointInFrame - , frame2Matrix - , matrix2Frame - , frameProduct - , standardFrame + , minPt + , lineDirection -- * Matrix contruction , identityMatrix @@ -86,79 +70,71 @@ , transpose -- * Radian operations - , req , toRadian , fromRadian , d2r , r2d , circularModulo - -- * Bezier curves , bezierArc , bezierCircle ) where -import Wumpus.Core.Utils ( PSUnit(..), oo ) +import Wumpus.Core.FormatCombinators +import Wumpus.Core.Utils -import Data.AffineSpace +import Data.AffineSpace -- package: vector-space import Data.VectorSpace -import Text.PrettyPrint.Leijen hiding ( langle ) -import Data.Function ( on ) -import Data.Monoid + -------------------------------------------------------------------------------- -- | Some unit of dimension usually double. - +-- +-- This very useful for reducing the kind of type classes to *. +-- +-- Doing this then allows constraints on the Unit type on the +-- instances rather than in the class declaration. +-- type family DUnit a :: * + -- Datatypes -- | 2D Vector - both components are strict. -- -data Vec2 u = V2 !u !u +data Vec2 u = V2 + { vector_x :: !u + , vector_y :: !u + } deriving (Eq,Show) type DVec2 = Vec2 Double + + -- | 2D Point - both components are strict. -- -- Note - Point2 derives Ord so it can be used as a key in -- Data.Map etc. -- -data Point2 u = P2 !u !u +data Point2 u = P2 + { point_x :: !u + , point_y :: !u + } deriving (Eq,Ord,Show) type DPoint2 = Point2 Double --- | A two dimensional frame. --- --- The components are the two basis vectors @e0@ and @e1@ and --- the origin @o@. --- --- Typically these names for the elements will be used: --- --- > Frame2 (V2 e0x e0y) (V2 e1x e1y) (P2 ox oy) --- - -data Frame2 u = Frame2 (Vec2 u) (Vec2 u) (Point2 u) - deriving (Eq,Show) - -type DFrame2 = Frame2 Double - - - - - -- | 3x3 matrix, considered to be in row-major form. -- -- > (M3'3 a b c @@ -199,22 +175,20 @@ type DMatrix3'3 = Matrix3'3 Double - -- | Radian is represented with a distinct type. -- Equality and ordering are approximate where the epsilon -- is 0.0001. newtype Radian = Radian { getRadian :: Double } deriving (Num,Real,Fractional,Floating,RealFrac,RealFloat) - -------------------------------------------------------------------------------- -- Family instances type instance DUnit (Point2 u) = u type instance DUnit (Vec2 u) = u -type instance DUnit (Frame2 u) = u type instance DUnit (Matrix3'3 u) = u + -------------------------------------------------------------------------------- -- lifters / convertors @@ -222,7 +196,6 @@ lift2Vec2 op (V2 x y) (V2 x' y') = V2 (x `op` x') (y `op` y') - lift2Matrix3'3 :: (u -> u -> u) -> Matrix3'3 u -> Matrix3'3 u -> Matrix3'3 u lift2Matrix3'3 op (M3'3 a b c d e f g h i) (M3'3 m n o p q r s t u) = M3'3 (a `op` m) (b `op` n) (c `op` o) @@ -230,7 +203,6 @@ (g `op` s) (h `op` t) (i `op` u) - -------------------------------------------------------------------------------- -- instances @@ -245,24 +217,8 @@ instance Functor Matrix3'3 where - fmap f (M3'3 m n o p q r s t u) = - M3'3 (f m) (f n) (f o) (f p) (f q) (f r) (f s) (f t) (f u) - - --- Monoid - --- Vectors have a sensible Monoid instance as addition, points don't - -instance Num u => Monoid (Vec2 u) where - mempty = V2 0 0 - mappend = lift2Vec2 (+) - - --- Affine frames also have a sensible Monoid instance - -instance (Num u, InnerSpace (Vec2 u)) => Monoid (Frame2 u) where - mempty = ortho zeroPt - mappend = frameProduct + fmap f (M3'3 m n o p q r s t u) = + M3'3 (f m) (f n) (f o) (f p) (f q) (f r) (f s) (f t) (f u) -- Show @@ -289,6 +245,7 @@ signum = fmap signum fromInteger a = M3'3 a' a' a' a' a' a' a' a' a' where a' = fromInteger a +-------------------------------------------------------------------------------- -- Instances for Radian which are 'special'. instance Show Radian where @@ -300,32 +257,28 @@ compare a b | a `req` b = EQ | otherwise = getRadian a `compare` getRadian b + + -------------------------------------------------------------------------------- -- Pretty printing -instance Pretty u => Pretty (Vec2 u) where - pretty (V2 a b) = angles (char '|' <+> pretty a <+> pretty b <+> char '|') - -instance Pretty u => Pretty (Point2 u) where - pretty (P2 a b) = brackets (char '|' <+> pretty a <+> pretty b <+> char '|') +instance PSUnit u => Format (Vec2 u) where + format (V2 a b) = parens (text "Vec" <+> dtruncFmt a <+> dtruncFmt b) -instance Pretty u => Pretty (Frame2 u) where - pretty (Frame2 e0 e1 o) = braces $ - text "e0:" <> pretty e0 - <+> text "e1:" <> pretty e1 - <+> text "o:" <> pretty o +instance PSUnit u => Format (Point2 u) where + format (P2 a b) = parens (dtruncFmt a <> comma <+> dtruncFmt b) -instance PSUnit u => Pretty (Matrix3'3 u) where - pretty (M3'3 a b c d e f g h i) = - matline a b c <$> matline d e f <$> matline g h i +instance PSUnit u => Format (Matrix3'3 u) where + format (M3'3 a b c d e f g h i) = + vcat [matline a b c, matline d e f, matline g h i] where matline x y z = char '|' - <+> (hcat $ map (fill 12 . text . dtrunc) [x,y,z]) + <+> (hcat $ map (fill 12 . dtruncFmt) [x,y,z]) <+> char '|' -instance Pretty Radian where - pretty (Radian d) = double d <> text ":rad" +instance Format Radian where + format (Radian d) = double d <> text ":rad" -------------------------------------------------------------------------------- -- Vector space instances @@ -342,12 +295,12 @@ -- scalar (dot / inner) product via the class InnerSpace - +-- -- This definition mandates UndecidableInstances, but this seems -- in line with Data.VectorSpace... -- -instance (Num u, InnerSpace u, Scalar u ~ u) +instance (Num u, InnerSpace u, u ~ Scalar u) => InnerSpace (Vec2 u) where (V2 a b) <.> (V2 a' b') = (a <.> a') ^+^ (b <.> b') @@ -368,38 +321,11 @@ type Scalar (Matrix3'3 u) = u s *^ m = fmap (s*) m --------------------------------------------------------------------------------- --- | Pointwise is a Functor like type class, except that the --- container/element relationship is defined via an associated --- type rather than a type parameter. This means that applied --- function must be type preserving. --- -class Pointwise sh where - type Pt sh :: * - pointwise :: (Pt sh -> Pt sh) -> sh -> sh - - -instance Pointwise (a -> a) where - type Pt (a->a) = a - pointwise f pf = \a -> pf (f a) - -instance Pointwise a => Pointwise [a] where - type Pt [a] = Pt a - pointwise f pts = map (pointwise f) pts - -instance Pointwise (Vec2 u) where - type Pt (Vec2 u) = Vec2 u - pointwise f v = f v - -instance Pointwise (Point2 u) where - type Pt (Point2 u) = Point2 u - pointwise f pt = f pt - - -------------------------------------------------------------------------------- -- Matrix multiply + infixr 7 *# -- | Matrix multiplication - typically of points and vectors @@ -416,11 +342,13 @@ instance Num u => MatrixMult (Point2 u) where (M3'3 a b c d e f _ _ _) *# (P2 m n) = P2 (a*m+b*n+c*1) (d*m+e*n+f*1) + -------------------------------------------------------------------------------- -- Vectors --- | A synonym for the constructor 'V2' with a Num constraint on --- the arguments. + +-- | 'vec' - 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: @@ -445,14 +373,15 @@ vvec :: Num u => u -> Vec2 u vvec d = V2 0 d + -- | Construct a vector from an angle and magnitude. -- avec :: Floating u => Radian -> u -> Vec2 u -avec theta d = V2 x y where - ang = fromRadian theta - x = d * cos ang - y = d * sin ang - +avec theta d = V2 x y + where + ang = fromRadian theta + x = d * cos ang + y = d * sin ang -- | The vector between two points -- @@ -465,7 +394,7 @@ -- from the x-axis. -- direction :: (Floating u, Real u) => Vec2 u -> Radian -direction (V2 x y) = langle (P2 0 0) (P2 x y) +direction (V2 x y) = lineDirection (P2 0 0) (P2 x y) -- | Length of a vector. -- @@ -476,8 +405,9 @@ -- vangle :: (Floating u, Real u, InnerSpace (Vec2 u)) => Vec2 u -> Vec2 u -> Radian -vangle u v = realToFrac $ acos $ (u <.> v) / (on (*) magnitude u v) +vangle u v = realToFrac $ acos $ (u <.> v) / (magnitude u * magnitude v) + -------------------------------------------------------------------------------- -- Points @@ -508,12 +438,11 @@ maxPt :: Ord u => Point2 u -> Point2 u -> Point2 u maxPt (P2 x y) (P2 x' y') = P2 (max x x') (max y y') - -- | Calculate the counter-clockwise angle between two points -- and the x-axis. -- -langle :: (Floating u, Real u) => Point2 u -> Point2 u -> Radian -langle (P2 x1 y1) (P2 x2 y2) = step (x2 - x1) (y2 - y1) +lineDirection :: (Floating u, Real u) => Point2 u -> Point2 u -> Radian +lineDirection (P2 x1 y1) (P2 x2 y2) = step (x2 - x1) (y2 - y1) where -- north-east quadrant step x y | pve x && pve y = toRadian $ atan (y/x) @@ -530,81 +459,7 @@ pve a = signum a >= 0 - -------------------------------------------------------------------------------- --- Frame operations - --- | Create a frame with standard (orthonormal bases) at the --- supplied point. --- -ortho :: Num u => Point2 u -> Frame2 u -ortho o = Frame2 (V2 1 0) (V2 0 1) o - --- | Displace the origin of the frame by the supplied vector. --- -displaceOrigin :: Num u => Vec2 u -> Frame2 u -> Frame2 u -displaceOrigin v (Frame2 e0 e1 o) = Frame2 e0 e1 (o.+^v) - --- | \'World coordinate\' calculation of a point in the supplied --- frame. --- -pointInFrame :: Num u => Point2 u -> Frame2 u -> Point2 u -pointInFrame (P2 x y) (Frame2 vx vy o) = (o .+^ (vx ^* x)) .+^ (vy ^* y) - --- | Concatenate the elements of the frame as columns forming a --- 3x3 matrix. Points and vectors are considered homogeneous --- coordinates - triples where the least element is either 0 --- indicating a vector or 1 indicating a point: --- --- > Frame (V2 e0x e0y) (V2 e1x e1y) (P2 ox oy) --- --- becomes --- --- > (M3'3 e0x e1x ox --- > e0y e1y oy --- > 0 0 1 ) --- - -frame2Matrix :: Num u => Frame2 u -> Matrix3'3 u -frame2Matrix (Frame2 (V2 e0x e0y) (V2 e1x e1y) (P2 ox oy)) = - M3'3 e0x e1x ox - e0y e1y oy - 0 0 1 - - --- | Interpret the matrix as columns forming a frame. --- --- > (M3'3 e0x e1x ox --- > e0y e1y oy --- > 0 0 1 ) --- --- becomes --- --- > Frame (V2 e0x e0y) (V2 e1x e1y) (P2 ox oy) --- -matrix2Frame :: Matrix3'3 u -> Frame2 u -matrix2Frame (M3'3 e0x e1x ox - e0y e1y oy - _ _ _ ) = Frame2 (V2 e0x e0y) (V2 e1x e1y) (P2 ox oy) - - --- | /Multiplication/ of frames to form their product. --- -frameProduct :: (Num u, InnerSpace (Vec2 u)) - => Frame2 u -> Frame2 u -> Frame2 u -frameProduct = matrix2Frame `oo` on (*) frame2Matrix - - - --- | Is the origin at (0,0) and are the basis vectors orthogonal --- with unit length? --- -standardFrame :: Num u => Frame2 u -> Bool -standardFrame (Frame2 (V2 1 0) (V2 0 1) (P2 0 0)) = True -standardFrame _ = False - - --------------------------------------------------------------------------------- -- Matrix construction -- | Construct the identity matrix: @@ -743,36 +598,44 @@ + + -------------------------------------------------------------------------------- -- Radians -- | The epislion used for floating point equality on radians. +-- radian_epsilon :: Double radian_epsilon = 0.0001 -- | Equality on radians, this is the operation used for (==) in -- Radian\'s Eq instance. +-- req :: Radian -> Radian -> Bool req a b = (fromRadian $ abs (a-b)) < radian_epsilon -- | Convert to radians. +-- toRadian :: Real a => a -> Radian toRadian = Radian . realToFrac -- | Convert from radians. +-- fromRadian :: Fractional a => Radian -> a fromRadian = realToFrac . getRadian -- | Degrees to radians. +-- d2r :: (Floating a, Real a) => a -> Radian d2r = Radian . realToFrac . (*) (pi/180) -- | Radians to degrees. +-- r2d :: (Floating a, Real a) => Radian -> a r2d = (*) (180/pi) . fromRadian @@ -785,6 +648,8 @@ i :: Integer dec :: Double (i,dec) = properFraction $ r2d r + + -------------------------------------------------------------------------------- diff --git a/src/Wumpus/Core/GraphicsState.hs b/src/Wumpus/Core/GraphicsState.hs --- a/src/Wumpus/Core/GraphicsState.hs +++ b/src/Wumpus/Core/GraphicsState.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- @@ -10,8 +8,7 @@ -- -- Maintainer : stephen.tetley@gmail.com -- Stability : unstable --- Portability : GHC with TypeFamilies and more --- +-- Portability : GHC -- -- Data types for stroke and label attributes and type classes -- for conversion to PostScript\'s colour and matrix @@ -39,7 +36,6 @@ -- @findfont@ operations in the generated PostScript if -- subsequent elements share the same values. -- --- -- -------------------------------------------------------------------------------- @@ -47,9 +43,10 @@ module Wumpus.Core.GraphicsState ( -- * Data types + GraphicsState(..) -- ** Stroke attributes - StrokeAttr(..) + , StrokeAttr(..) , LineCap(..) , LineJoin(..) , DashPattern(..) @@ -59,26 +56,32 @@ , FontFace(..) , SVGFontStyle(..) - -- ** Colour - , PSRgb - - -- ** Current Translation Matrix - , CTM(..) - - -- * Convert to CTM - , ToCTM(..) - - -- * Convert to PSColour - , PSColour(..) + -- ** Default graphic state + , zeroGS ) where import Wumpus.Core.Colour -import Wumpus.Core.Geometry -import Wumpus.Core.Utils -- Graphics state datatypes +-- | Graphics state used by the rendering monads. +-- +-- This type is hidden by the top-level module @Wumpus.Core@. +-- +data GraphicsState = GraphicsState + { gs_draw_colour :: RGBi + , gs_font_size :: Int + , gs_font_face :: FontFace + , gs_line_width :: Double + , gs_miter_limit :: Double + , gs_line_cap :: LineCap + , gs_line_join :: LineJoin + , gs_dash_pattern :: DashPattern + } + deriving (Eq,Show) + + -- | Stroke attributes are an algebriac type rather than a -- record type. This is for convenience when attributing paths - -- paths can be attibuted with just the differences from the @@ -94,15 +97,18 @@ -- | Line cap - default in output is butt. +-- data LineCap = CapButt | CapRound | CapSquare deriving (Enum,Eq,Show) -- | Line join - default in output is miter. +-- data LineJoin = JoinMiter | JoinRound | JoinBevel deriving (Enum,Eq,Show) -- | Dash pattern - either a solid line or a list of on-off pairs -- together with an /offset/ into the dashes. +-- data DashPattern = Solid | Dash Int [(Int,Int)] deriving (Eq,Show) @@ -146,96 +152,18 @@ | SVG_OBLIQUE | SVG_BOLD_OBLIQUE deriving (Eq,Ord,Show) -type PSRgb = RGB3 Double - - --- | PostScript's current transformation matrix. --- --- PostScript and its documentation considers the matrix to be --- in this form: --- --- > | a b 0 | --- > | c d 0 | --- > | tx ty 1 | --- --- i.e it considers the homogeneous coordinates of an affine --- frame as /rows/ rather than /columns/ (Wumpus uses rows, as --- they were the usual representation in the geometry --- presentations that inspired it). --- --- Using the component names that we have used in the --- description of 'Frame2', the CTM is: --- --- > | e0x e0y 0 | --- > | e1x e1y 0 | --- > | ox oy 1 | --- --- The CTM is represented in PostScript as an array, using our --- names its layout is --- --- > [ e0x e0y e1x e1y ox oy ] --- --- Some examples, the scaling matrix: --- --- > | sx 0 0 | --- > | 0 sy 0 | = [ sx 0 0 sy 0 0 ] --- > | 0 0 1 | --- --- Translation (displacement) : --- --- > | 1 0 0 | --- > | 0 1 0 | = [ 1 0 0 1 tx ty ] --- > | tx ty 1 | --- --- Rotation: --- --- > | cos(a) sin(a) 0 | --- > | -sin(a) cos(a) 0 | = [ cos(a) sin(a) -sin(a) cos(a) 0 0 ] --- > | 0 0 1 | - -data CTM u = CTM !u !u !u !u !u !u - deriving (Eq,Show) - -type instance DUnit (CTM u) = u - --------------------------------------------------------------------------------- --- Conversion to CTM - --- | Convert to the CTM. Wumpus offshores affine transformations --- to PostScript as @concat@ commands. So frames and matrices --- must support being represented as the CTM. --- -class ToCTM a where - toCTM :: u ~ DUnit a => a -> CTM u - -instance ToCTM (Frame2 a) where - toCTM (Frame2 (V2 e0x e0y) (V2 e1x e1y) (P2 ox oy)) - = CTM e0x e0y e1x e1y ox oy - - -instance ToCTM (Matrix3'3 a) where - toCTM (M3'3 e0x e1x ox - e0y e1y oy - _ _ _ ) - = CTM e0x e0y e1x e1y ox oy - - --------------------------------------------------------------------------------- --- Conversion to PSColour - --- | Convert to RGB [0,1] for PostScript rendering. -class PSColour a where psColour :: a -> RGB3 Double - -instance PSColour (RGB3 Double) where - psColour (RGB3 r g b) = RGB3 (ramp r) (ramp g) (ramp b) - -instance PSColour (HSB3 Double) where - psColour = psColour . hsb2rgb - -instance PSColour (Gray Double) where - psColour = psColour . gray2rgb - - - +-- | The initial graphics state +zeroGS :: GraphicsState +zeroGS = GraphicsState { gs_draw_colour = black + , gs_font_size = (-1) + , gs_font_face = unmatchable_face + , gs_line_width = 1 + , gs_miter_limit = 1 + , gs_line_cap = CapButt + , gs_line_join = JoinMiter + , gs_dash_pattern = Solid + } + where + unmatchable_face = FontFace "DONT_MATCH" "" SVG_BOLD_OBLIQUE diff --git a/src/Wumpus/Core/OneList.hs b/src/Wumpus/Core/OneList.hs --- a/src/Wumpus/Core/OneList.hs +++ b/src/Wumpus/Core/OneList.hs @@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Core.OneList --- Copyright : (c) Stephen Tetley 2010 +-- Copyright : (c) Stephen Tetley 2009-2010 -- License : BSD3 -- -- Maintainer : Stephen Tetley @@ -12,16 +12,13 @@ -- -- Data type for non-empty lists. -- --- Structurally the same as OneMany - but used for a different --- purpose. --- -------------------------------------------------------------------------------- module Wumpus.Core.OneList ( -- OneMany OneList - , ViewOL(..) + , ViewL(..) , one , cons @@ -38,7 +35,7 @@ ) where -import Data.Semigroup -- package: algebra +import Data.Semigroup -- package: algebra import Control.Applicative import Data.Foldable @@ -47,14 +44,15 @@ import Prelude hiding ( head ) --- type OneMany a = OneList a data OneList a = One a | Many a (OneList a) deriving (Eq) -data ViewOL a = OneL a | a :<< (OneList a) +data ViewL a = OneL a | a :< (OneList a) deriving (Eq) + + -------------------------------------------------------------------------------- -- Instances @@ -105,9 +103,9 @@ head (One a) = a head (Many a _) = a -viewl :: OneList a -> ViewOL a +viewl :: OneList a -> ViewL a viewl (One a) = OneL a -viewl (Many a as) = a :<< as +viewl (Many a as) = a :< as -- | Construct Many. Not this function throws a error if the list has -- zero or one elements diff --git a/src/Wumpus/Core/OutputPostScript.hs b/src/Wumpus/Core/OutputPostScript.hs --- a/src/Wumpus/Core/OutputPostScript.hs +++ b/src/Wumpus/Core/OutputPostScript.hs @@ -1,22 +1,22 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | --- Module : Wumpus.Core.OutputPostScript +-- Module : Wumpus.Core.PostScript -- Copyright : (c) Stephen Tetley 2009-2010 -- License : BSD3 -- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC with TypeFamilies and more +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC -- -- Output PostScript - either PostScript (PS) files or -- EPS (Encapusulated PostScript) files can be generated. -- --- -------------------------------------------------------------------------------- -module Wumpus.Core.OutputPostScript +module Wumpus.Core.OutputPostScript ( -- * Output PostScript writePS @@ -29,22 +29,118 @@ import Wumpus.Core.BoundingBox import Wumpus.Core.Colour +import Wumpus.Core.FormatCombinators import Wumpus.Core.Geometry import Wumpus.Core.GraphicsState +import Wumpus.Core.OneList import Wumpus.Core.PictureInternal -import Wumpus.Core.PostScript +import Wumpus.Core.PostScriptDoc import Wumpus.Core.TextEncoder -import Wumpus.Core.TextEncodingInternal +import Wumpus.Core.TextInternal import Wumpus.Core.TextLatin1 import Wumpus.Core.Utils +import Control.Applicative hiding ( empty, some ) +import Control.Monad -import MonadLib hiding ( Label ) +import qualified Data.Foldable as F +import Data.Maybe +import Data.Time -import qualified Data.Foldable as F +-------------------------------------------------------------------------------- +-- PsMonad +-- PsMonad is at least a Reader and a State... +-- +-- Graphics state works differently to SVG - PostScript has no +-- nesting (at least not in the code Wumpus generates) so there +-- are no /savings/ by diffing from an outer environment, instead +-- the diff is with the last drawn object. +-- +newtype PsMonad a = PsMonad { + getPsMonad :: TextEncoder -> GraphicsState -> (a,GraphicsState) } + +instance Functor PsMonad where + fmap f mf = PsMonad $ \r s -> let (a,s1) = getPsMonad mf r s in (f a,s1) + +instance Applicative PsMonad where + pure a = PsMonad $ \_ s -> (a,s) + mf <*> ma = PsMonad $ \r s -> let (f,s1) = getPsMonad mf r s + (a,s2) = getPsMonad ma r s1 + in (f a,s2) + +instance Monad PsMonad where + return a = PsMonad $ \_ s -> (a,s) + m >>= k = PsMonad $ \r s -> let (a,s1) = getPsMonad m r s + in (getPsMonad . k) a r s1 + + +runPsMonad :: TextEncoder -> PsMonad a -> a +runPsMonad enc mf = fst $ getPsMonad mf enc zeroGS + +askCharCode :: Int -> PsMonad (Either GlyphName GlyphName) +askCharCode i = PsMonad $ \r s -> case lookupByCharCode i r of + Just n -> (Right n,s) + Nothing -> (Left $ ps_fallback r,s) + +runLocalGS :: GSUpdate -> PsMonad a -> PsMonad a +runLocalGS upd mf = + PsMonad $ \r s -> let (a,_) = getPsMonad mf r (getGSU upd s) in (a,s) + +getDrawColour :: PsMonad RGBi +getDrawColour = PsMonad $ \_ s -> (gs_draw_colour s, s) + +setDrawColour :: RGBi -> PsMonad () +setDrawColour a = PsMonad $ \_ s -> ((), s {gs_draw_colour=a}) + + +getFontAttr :: PsMonad FontAttr +getFontAttr = PsMonad $ \_ s -> let sz = gs_font_size s + ff = gs_font_face s + in (FontAttr sz ff, s) + +setFontAttr :: FontAttr -> PsMonad () +setFontAttr (FontAttr sz ff) = + PsMonad $ \_ s -> ((), s { gs_font_size=sz,gs_font_face=ff }) + + +getLineWidth :: PsMonad Double +getLineWidth = PsMonad $ \_ s -> (gs_line_width s, s) + +setLineWidth :: Double -> PsMonad () +setLineWidth a = PsMonad $ \_ s -> ((), s { gs_line_width=a }) + + +getMiterLimit :: PsMonad Double +getMiterLimit = PsMonad $ \_ s -> (gs_miter_limit s,s) + +setMiterLimit :: Double -> PsMonad () +setMiterLimit a = PsMonad $ \_ s -> ((), s { gs_miter_limit=a }) + + +getLineCap :: PsMonad LineCap +getLineCap = PsMonad $ \_ s -> (gs_line_cap s,s) + +setLineCap :: LineCap -> PsMonad () +setLineCap a = PsMonad $ \_ s -> ((), s { gs_line_cap=a }) + + +getLineJoin :: PsMonad LineJoin +getLineJoin = PsMonad $ \_ s -> (gs_line_join s,s) + +setLineJoin :: LineJoin -> PsMonad () +setLineJoin a = PsMonad $ \_ s -> ((), s { gs_line_join=a }) + + +getDashPattern :: PsMonad DashPattern +getDashPattern = PsMonad $ \_ s -> (gs_dash_pattern s,s) + +setDashPattern :: DashPattern -> PsMonad () +setDashPattern a = PsMonad $ \_ s -> ((), s { gs_dash_pattern=a }) + + -------------------------------------------------------------------------------- -- Render to PostScript @@ -53,9 +149,8 @@ -- writePS :: (Real u, Floating u, PSUnit u) => FilePath -> TextEncoder -> [Picture u] -> IO () -writePS filepath enc pic = do - timestamp <- mkTimeStamp - writeFile filepath $ psDraw timestamp enc pic +writePS filepath enc pic = + getZonedTime >>= \ztim -> writeFile filepath (show $ psDraw ztim enc pic) -- | Output a picture to an EPS (Encapsulated PostScript) file. -- The .eps file can then be imported or embedded in another @@ -63,301 +158,348 @@ -- writeEPS :: (Real u, Floating u, PSUnit u) => FilePath -> TextEncoder -> Picture u -> IO () -writeEPS filepath enc pic = do - timestamp <- mkTimeStamp - writeFile filepath $ epsDraw timestamp enc pic +writeEPS filepath enc pic = + getZonedTime >>= \ztim -> writeFile filepath (show $ epsDraw ztim enc pic) --- | Version of 'writePS' - using Latin1 encoding. +-- | Version of 'writePS' - using Latin1 encoding. +-- writePS_latin1 :: (Real u, Floating u, PSUnit u) - => FilePath -> [Picture u] -> IO () -writePS_latin1 filepath = writePS filepath latin1Encoder + => FilePath -> [Picture u] -> IO () +writePS_latin1 filepath = writePS filepath latin1Encoder -- | Version of 'writeEPS' - using Latin1 encoding. +-- writeEPS_latin1 :: (Real u, Floating u, PSUnit u) - => FilePath -> Picture u -> IO () + => FilePath -> Picture u -> IO () writeEPS_latin1 filepath = writeEPS filepath latin1Encoder - - -------------------------------------------------------------------------------- -- Internals -- | Draw a picture, generating PostScript output. +-- +-- Note - the bounding box may /below the origin/ - if it is, it +-- will need translating. +-- + psDraw :: (Real u, Floating u, PSUnit u) - => String -> TextEncoder -> [Picture u] -> PostScript -psDraw timestamp enc pics = runWumpus enc $ do - psHeader 1 timestamp - zipWithM_ psDrawPage pages pics - psFooter + => ZonedTime -> TextEncoder -> [Picture u] -> Doc +psDraw timestamp enc pics = + let body = vcat $ runPsMonad enc $ zipWithM psDrawPage pages pics + in vcat [ psHeader 1 timestamp + , body + , psFooter + ] where pages = map (\i -> (show i,i)) [1..] - -psDrawPage :: (Real u, Floating u, PSUnit u) - => (String,Int) -> Picture u -> WumpusM () -psDrawPage (lbl,ordinal) pic = do - dsc_Page lbl ordinal - ps_gsave - cmdtrans - outputPicture pic - ps_grestore - ps_showpage - where - (_,mbv) = repositionProperties pic - cmdtrans = maybe (return ()) (\(V2 x y) -> ps_translate x y) mbv - +-- | Note the bounding box may /below the origin/ - if it is, it +-- will need translating. +-- +psDrawPage :: (Real u, Floating u, PSUnit u) + => (String,Int) -> Picture u -> PsMonad Doc +psDrawPage (lbl,ordinal) pic = + let (_,cmdtrans) = imageTranslation pic in + (\doc -> vcat [ dsc_Page lbl ordinal + , ps_gsave + , cmdtrans + , doc + , ps_grestore + , ps_showpage + ]) + <$> picture pic --- | Note the bounding box may /below the origin/ - if it is, it +-- | Note the bounding box may /below the origin/ - if it is, it -- will need translating. -- -epsDraw :: (Real u, Floating u, PSUnit u) - => String -> TextEncoder -> Picture u -> PostScript -epsDraw timestamp enc pic = runWumpus enc $ do - epsHeader bb timestamp - ps_gsave - cmdtrans - outputPicture pic - ps_grestore - epsFooter - where - (bb,mbv) = repositionProperties pic - cmdtrans = maybe (return ()) (\(V2 x y) -> ps_translate x y) mbv - +epsDraw :: (Real u, Floating u, PSUnit u) + => ZonedTime -> TextEncoder -> Picture u -> Doc +epsDraw timestamp enc pic = + let (bb,cmdtrans) = imageTranslation pic + body = runPsMonad enc (picture pic) + in vcat [ epsHeader bb timestamp + , ps_gsave + , cmdtrans + , body + , ps_grestore + , epsFooter + ] -psHeader :: Int -> String -> WumpusM () -psHeader pagecount timestamp = do - bang_PS - dsc_Pages pagecount - dsc_CreationDate $ parens timestamp - dsc_EndComments +imageTranslation :: (Ord u, PSUnit u) => Picture u -> (BoundingBox u, Doc) +imageTranslation pic = case repositionDeltas pic of + (bb, Nothing) -> (bb, empty) + (bb, Just v) -> (bb, ps_translate v) -epsHeader :: PSUnit u => BoundingBox u -> String -> WumpusM () -epsHeader bb timestamp = do - bang_EPS - dsc_BoundingBox llx lly urx ury - dsc_CreationDate $ parens timestamp - dsc_EndComments + +-------------------------------------------------------------------------------- + + +picture :: (Real u, Floating u, PSUnit u) => Picture u -> PsMonad Doc +picture (Leaf (_,xs) ones) = bracketTrafos xs $ revConcat primitive ones +picture (Picture (_,xs) ones) = bracketTrafos xs $ revConcat picture ones +picture (Clip (_,xs) cp pic) = bracketTrafos xs $ + (vconcat <$> clipPath cp <*> picture pic) +picture (Group (_,xs) fn pic) = bracketTrafos xs (runLocalGS fn (picture pic)) + + +revConcat :: (a -> PsMonad Doc) -> OneList a -> PsMonad Doc +revConcat fn ones = some empty <$> F.foldrM step None ones where - (llx,lly,urx,ury) = getBounds bb + step e ac = (\d -> d `conc` ac) <$> fn e + conc d None = Some d + conc d (Some ac) = Some $ ac `vconcat` d -getBounds :: Num u => BoundingBox u -> (u,u,u,u) -getBounds (BBox (P2 llx lly) (P2 urx ury)) = (llx,lly,urx,ury) -psFooter :: WumpusM () -psFooter = dsc_EOF +primitive :: (Real u, Floating u, PSUnit u) => Primitive u -> PsMonad Doc +primitive (PPath props _ pp) = primPath props pp +primitive (PLabel props _ lbl) = primLabel props lbl +primitive (PEllipse props _ ell) = primEllipse props ell -epsFooter :: WumpusM () -epsFooter = do - ps_showpage - dsc_EOF +primPath :: PSUnit u + => PathProps -> PrimPath u -> PsMonad Doc +primPath (CFill rgb) p = + (\rgbd -> vcat [rgbd, makeStartPath p, ps_closepath, ps_fill]) + <$> deltaDrawColour rgb --- Create margins at the left and bottom of 4 points... +primPath (CStroke attrs rgb) p = + (\rgbd attrd -> vcat [ rgbd, attrd, makeStartPath p + , ps_closepath, ps_stroke ]) + <$> deltaDrawColour rgb <*> deltaStrokeAttrs attrs + +primPath (OStroke attrs rgb) p = + (\rgbd attrd -> vcat [rgbd, attrd, makeStartPath p, ps_stroke]) + <$> deltaDrawColour rgb <*> deltaStrokeAttrs attrs +primPath (CFillStroke fc attrs sc) p = + (\d1 d2 -> vcat [d1,d2]) + <$> primPath (CFill fc) p <*> primPath (CStroke attrs sc) p --- | outputPicture --- Frame changes, representing scalings translation, rotations... --- are drawn when they are encountered as a @concat@ statement in a --- block of @gsave ... grestore@. --- -outputPicture :: (Real u, Floating u, PSUnit u) => Picture u -> WumpusM () -outputPicture (PicBlank _) = return () -outputPicture (Single (fr,_) prim) = - updateFrame fr $ outputPrimitive prim -outputPicture (Picture (fr,_) ones) = - updateFrame fr $ F.foldrM (\p _ -> outputPicture p) () ones -outputPicture (Clip (fr,_) cp p) = - updateFrame fr $ do { clipPath cp ; outputPicture p } +clipPath :: PSUnit u => PrimPath u -> PsMonad Doc +clipPath p = pure $ vcat [makeStartPath p , ps_closepath, ps_clip] --- | @updateFrame@ relies on the current frame, when translated --- to a matrix being invertible. + +makeStartPath :: PSUnit u => PrimPath u -> Doc +makeStartPath (PrimPath start xs) = + vcat $ ps_newpath : ps_moveto start : map makePathSegment xs + + + +makePathSegment :: PSUnit u => PrimPathSegment u -> Doc +makePathSegment (PLineTo p1) = ps_lineto p1 +makePathSegment (PCurveTo p1 p2 p3) = ps_curveto p1 p2 p3 + + +-- | Drawing stroked ellipse has an unfortunate - but (probably) +-- unavoidable deficiency. -- --- This is an allowable optimization because the current frame --- is only manipulated with the affine transformations (scalings, --- rotations...) which are invertible. --- --- It also performs another optimization: +-- The use of PostScript\'s @concat@ operator to alter the arc +-- hw/hh will vary the line width during the drawing of a stroked +-- ellipse. -- --- If the frame is the standard frame @ [1 0 0 1 0 0] @ then --- the monadic action is run as-is rather than being nested --- in a block: --- --- > [1 0 0 1 0 0] concat --- > ... --- > [1 0 0 1 0 0] concat +-- For good stroked ellipses, Bezier curves constructed from +-- PrimPaths should be used. -- +primEllipse :: (Real u, Floating u, PSUnit u) + => EllipseProps -> PrimEllipse u -> PsMonad Doc +primEllipse props (PrimEllipse center hw hh ctm) = + bracketPrimCTM center (scaleCTM 1 (hh/hw) ctm) (drawF props) + where + drawF (EFill rgb) pt = fillArcPath rgb hw pt + drawF (EStroke attrs rgb) pt = strokeArcPath rgb attrs hw pt + drawF (EFillStroke fc attrs sc) pt = + vconcat <$> fillArcPath fc hw pt <*> strokeArcPath sc attrs hw pt + -updateFrame :: (Fractional u, PSUnit u) => Frame2 u -> WumpusM () -> WumpusM () -updateFrame frm ma - | standardFrame frm = ma - | otherwise = let m1 = frame2Matrix frm in - do { ps_concat $ toCTM m1 - ; ma - ; ps_concat $ toCTM $ invert m1 - } -outputPrimitive :: (Real u, Floating u, PSUnit u) => Primitive u -> WumpusM () -outputPrimitive (PPath (c,dp) p) = outputPath dp c p -outputPrimitive (PLabel props l) = updateFont props $ outputLabel l -outputPrimitive (PEllipse (c,dp) e) = outputEllipse dp c e +-- This will need to become monadic to handle /colour delta/. +-- +fillArcPath :: PSUnit u => RGBi -> u -> Point2 u -> PsMonad Doc +fillArcPath rgb radius pt = + (\rgbd -> vcat [ rgbd + , ps_newpath + , ps_arc pt radius 0 360 + , ps_closepath + , ps_fill ]) + <$> deltaDrawColour rgb -updateFont :: LabelProps -> WumpusM () -> WumpusM () -updateFont (c,fnt) ma = updateColour c $ do - mb_fnt <- deltaFontAttr fnt - maybe (return ()) fontCommand mb_fnt - ma - +strokeArcPath :: PSUnit u + => RGBi -> [StrokeAttr] -> u -> Point2 u -> PsMonad Doc +strokeArcPath rgb attrs radius pt = + (\rgbd attrd -> vcat [ rgbd + , attrd + , ps_newpath + , ps_arc pt radius 0 360 + , ps_closepath + , ps_stroke ]) + <$> deltaDrawColour rgb <*> deltaStrokeAttrs attrs -updateColour :: PSColour c => c -> WumpusM () -> WumpusM () -updateColour c ma = let rgbc = psColour c in do - mb_col <- deltaRgbColour rgbc - maybe (return ()) colourCommand mb_col - ma +-- Note - for the otherwise case, the x-and-y coordinates are +-- encoded in the matrix, hence the @ 0 0 moveto @. +-- +primLabel :: (Real u, Floating u, PSUnit u) + => LabelProps -> PrimLabel u -> PsMonad Doc +primLabel (LabelProps rgb font) (PrimLabel basept txt ctm) = + bracketPrimCTM basept ctm mf where - colourCommand :: DRGB -> WumpusM () - colourCommand (RGB3 r g b) = ps_setrgbcolor r g b - - + mf pt = (\rgbd fontd showd -> vcat [ rgbd, fontd, ps_moveto pt, showd ]) + <$> deltaDrawColour rgb <*> deltaFontAttrs font + <*> encodedText txt +encodedText :: EncodedText -> PsMonad Doc +encodedText etext = vcat <$> (mapM textChunk $ getEncodedText etext) -fontCommand :: FontAttr -> WumpusM () -fontCommand (FontAttr sz face) = do - ps_findfont (font_name face) - ps_scalefont sz - ps_setfont +textChunk :: TextChunk -> PsMonad Doc +textChunk (SText s) = pure (ps_show $ escapeSpecial s) +textChunk (EscStr s) = pure (ps_glyphshow s) +textChunk (EscInt i) = (either failk ps_glyphshow) <$> askCharCode i + where + failk gly_name = missingCharCode i gly_name +-------------------------------------------------------------------------------- +-- Stroke, font and drawing colour attribute delta - -outputPath :: (PSColour c, PSUnit u) - => DrawPath -> c -> Path u -> WumpusM () -outputPath CFill c p = updateColour c $ do - startPath p - ps_closepath - ps_fill +-- This needs more thought than SVG as there is no natural +-- nesting to benefit from... -outputPath (CStroke xs) c p = updatePen c xs $ do - startPath p - ps_closepath - ps_stroke +-- All graphics are annotated with colour - the graphics state +-- doesn\'t tell us the actual colour of anything, only if we +-- need to write a colour change to the output. +-- +-- So we compare the current colour with the state - if it is +-- different we put the new colour in the state and output a +-- @setrgbcolor@ message. +-- +-- +-- Note - because these combinators return /empty/ for no +-- difference some extraneous blank lines are produced in the +-- output. +-- -outputPath (OStroke xs) c p = updatePen c xs $ do - startPath p - ps_stroke - +deltaDrawColour :: RGBi -> PsMonad Doc +deltaDrawColour rgb = getDrawColour >>= \inh -> + if rgb==inh then return empty + else setDrawColour rgb >> return (ps_setrgbcolor rgb) -startPath :: PSUnit u => Path u -> WumpusM () -startPath (Path (P2 x y) xs) = do - ps_newpath - ps_moveto x y - mapM_ outputPathSeg xs +-- Note - the current way of handling Stroke Deltas for +-- PostScript uses an awful lot of operations. +-- +-- The GraphicsState data types need some more thought +-- +data StrokeDelta = StrokeDelta + { sd_line_width :: Double + , sd_miter_limit :: Double + , sd_line_cap :: LineCap + , sd_line_join :: LineJoin + , sd_dash_pattern :: DashPattern + } -clipPath :: PSUnit u => Path u -> WumpusM () -clipPath p = do - startPath p - ps_closepath - ps_clip +-- | Note - the values here must be in- sync with zeroGS. +-- +zeroSD :: StrokeDelta +zeroSD = StrokeDelta { sd_line_width = 1 + , sd_miter_limit = 1 + , sd_line_cap = CapButt + , sd_line_join = JoinMiter + , sd_dash_pattern = Solid + } +makeStrokeDelta :: [StrokeAttr] -> StrokeDelta +makeStrokeDelta = foldr fn zeroSD + where + fn (LineWidth a) sd = sd { sd_line_width = a } + fn (MiterLimit a) sd = sd { sd_miter_limit = a } + fn (LineCap a) sd = sd { sd_line_cap = a } + fn (LineJoin a) sd = sd { sd_line_join = a } + fn (DashPattern a) sd = sd { sd_dash_pattern = a} -updatePen :: PSColour c => c -> [StrokeAttr] -> WumpusM () -> WumpusM () -updatePen c xs ma = let (mset, mreset) = strokeSetReset xs in - updateColour c $ do { mset ; ma ; mreset } -strokeSetReset :: [StrokeAttr] -> (WumpusM (), WumpusM ()) -strokeSetReset = foldr (appro link cmd id) (return (), return ()) +deltaStrokeAttrs :: [StrokeAttr] -> PsMonad Doc +deltaStrokeAttrs xs = step $ makeStrokeDelta xs where - link Nothing funs = funs - link (Just (f,g)) (fs,gs) = (fs >> f, gs >> g) - - mkSetReset mf = maybe Nothing (\(a,b) -> Just (mf a, mf b)) - - cmd (LineWidth d) = mkSetReset ps_setlinewidth $ deltaStrokeWidth d - cmd (MiterLimit d) = mkSetReset ps_setmiterlimit $ deltaMiterLimit d - cmd (LineCap lc) = mkSetReset ps_setlinecap $ deltaLineCap lc - cmd (LineJoin lj) = mkSetReset ps_setlinejoin $ deltaLineJoin lj - cmd (DashPattern dp) = mkSetReset ps_setdash $ deltaDashPattern dp + step sd = (\d1 d2 d3 d4 d5 -> hcat $ catMaybes [d1,d2,d3,d4,d5]) + <$> lw sd <*> ml sd <*> lc sd <*> lj sd <*> dp sd + lw sd = let d = sd_line_width sd in + getLineWidth >>= \inh -> + if d == inh + then return Nothing + else setLineWidth d >> return (Just $ ps_setlinewidth d) -outputPathSeg :: PSUnit u => PathSegment u -> WumpusM () -outputPathSeg (PLineTo (P2 x y)) = ps_lineto x y -outputPathSeg (PCurveTo p1 p2 p3) = ps_curveto x1 y1 x2 y2 x3 y3 - where - P2 x1 y1 = p1 - P2 x2 y2 = p2 - P2 x3 y3 = p3 + ml sd = let d = sd_miter_limit sd in + getMiterLimit >>= \inh -> + if d==inh + then return Nothing + else setMiterLimit d >> return (Just $ ps_setmiterlimit d) + + lc sd = let d = sd_line_cap sd in + getLineCap >>= \inh -> + if d==inh + then return Nothing + else setLineCap d >> return (Just $ ps_setlinecap d) + + lj sd = let d = sd_line_join sd in + getLineJoin >>= \inh -> + if d==inh + then return Nothing + else setLineJoin d >> return (Just $ ps_setlinejoin d) + dp sd = let d = sd_dash_pattern sd in + getDashPattern >>= \inh -> + if d==inh + then return Nothing + else setDashPattern d >> return (Just $ ps_setdash d) --- | This is not very good - the use of PostScript's @concat@ --- operator will vary the line width during the drawing of a --- stroked ellipse. --- -outputEllipse :: (PSColour c, Real u, Floating u, PSUnit u) - => DrawEllipse -> c -> PrimEllipse u -> WumpusM () -outputEllipse dp c (PrimEllipse pt@(P2 x y) hw hh ctm) - | hw==hh && ctm == identityCTM = outputArc dp c x y hw - | otherwise = - let matrix = matrixRepCTM $ scaleCTM 1 (hh/hw) ctm - matrix' = invert matrix - (P2 dx dy) = matrix' *# pt - in do { ps_concat $ toCTM matrix - ; outputArc dp c dx dy hw - ; ps_concat $ toCTM $ matrix' - } -outputArc :: (PSColour c, PSUnit u) - => DrawEllipse -> c -> u -> u -> u -> WumpusM () -outputArc EFill c x y r = updateColour c $ do - ps_newpath - ps_arc x y r 0 360 - ps_closepath - ps_fill -outputArc (EStroke xs) c x y r = updatePen c xs $ do - ps_newpath - ps_arc x y r 0 360 - ps_closepath - ps_stroke +deltaFontAttrs :: FontAttr -> PsMonad Doc +deltaFontAttrs fa = getFontAttr >>= \inh -> + if fa==inh then return empty + else setFontAttr fa >> return (makeFontAttrs fa) +makeFontAttrs :: FontAttr -> Doc +makeFontAttrs (FontAttr sz face) = + vcat [ ps_findfont (font_name face), ps_scalefont sz, ps_setfont ] --- Note - for the otherwise case the x-and-y coordinates are --- encoded in the matrix, hence the @ 0 0 moveto @. --- -outputLabel :: (Real u, Floating u, PSUnit u) => Label u -> WumpusM () -outputLabel (Label (P2 x y) entxt ctm) - | ctm == identityCTM = do { ps_moveto x y; outputEncodedText entxt } - | otherwise = do { ps_concat $ toCTM matrix - ; ps_moveto 0 (0 :: Double) - ; outputEncodedText entxt - ; ps_concat $ toCTM $ invert matrix - } - where - matrix = translMatrixRepCTM x y ctm -outputEncodedText :: EncodedText -> WumpusM () -outputEncodedText = mapM_ outputTextChunk . getEncodedText +-------------------------------------------------------------------------------- +-- Bracket matrix and PrimCTM trafos -outputTextChunk :: TextChunk -> WumpusM () -outputTextChunk (SText s) = ps_show $ escapeStringPS s +bracketTrafos :: (Real u, Floating u, PSUnit u) + => [AffineTrafo u] -> PsMonad Doc -> PsMonad Doc +bracketTrafos xs ma = bracketMatrix (concatTrafos xs) ma -outputTextChunk (EscInt i) = - ask >>= \env -> maybe (failk env) ps_glyphshow $ lookupByCharCode i env +bracketMatrix :: (Fractional u, PSUnit u) + => Matrix3'3 u -> PsMonad Doc -> PsMonad Doc +bracketMatrix mtrx ma + | mtrx == identityMatrix = ma + | otherwise = (\doc -> vcat [inn, doc, out]) <$> ma where - failk = missingCode i . ps_fallback + inn = ps_concat $ mtrx + out = ps_concat $ invert mtrx -outputTextChunk (EscStr s) = ps_glyphshow s -missingCode :: CharCode -> GlyphName -> WumpusM () -missingCode i fallback = do - ps_comment $ "missing lookup for &#" ++ show i ++ ";" - ps_glyphshow fallback - +bracketPrimCTM :: forall u. (Real u, Floating u, PSUnit u) + => Point2 u -> PrimCTM u + -> (Point2 u -> PsMonad Doc) -> PsMonad Doc +bracketPrimCTM pt@(P2 x y) ctm mf + | ctm == identityCTM = mf pt + | otherwise = (\doc -> vcat [inn, doc, out]) <$> mf zeroPt' + where + zeroPt' :: Point2 u + zeroPt' = zeroPt + + mtrx = translMatrixRepCTM x y ctm + inn = ps_concat $ mtrx + out = ps_concat $ invert mtrx diff --git a/src/Wumpus/Core/OutputSVG.hs b/src/Wumpus/Core/OutputSVG.hs --- a/src/Wumpus/Core/OutputSVG.hs +++ b/src/Wumpus/Core/OutputSVG.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- @@ -7,9 +7,9 @@ -- Copyright : (c) Stephen Tetley 2009-2010 -- License : BSD3 -- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC with TypeFamilies and more +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC -- -- Output SVG. -- @@ -30,42 +30,96 @@ -- -------------------------------------------------------------------------------- -module Wumpus.Core.OutputSVG - ( - +module Wumpus.Core.OutputSVG + ( + -- * Output SVG writeSVG , writeSVG_latin1 - + ) where -import Wumpus.Core.AffineTrans +import Wumpus.Core.BoundingBox +import Wumpus.Core.Colour +import Wumpus.Core.FormatCombinators import Wumpus.Core.Geometry import Wumpus.Core.GraphicsState +import Wumpus.Core.OneList +import Wumpus.Core.PageTranslation import Wumpus.Core.PictureInternal -import Wumpus.Core.SVG +import Wumpus.Core.SVGDoc import Wumpus.Core.TextEncoder -import Wumpus.Core.TextEncodingInternal +import Wumpus.Core.TextInternal import Wumpus.Core.TextLatin1 import Wumpus.Core.Utils +import Control.Applicative hiding ( empty, some ) +import qualified Data.Foldable as F -import MonadLib hiding ( Label ) +-- SvgMonad is two Readers plus Int state for clip paths... +-- +newtype SvgMonad a = SvgMonad { + getSvgMonad :: TextEncoder -> GraphicsState -> Int -> (a,Int) } -import Text.XML.Light -import qualified Data.Foldable as F -type Clipped = Bool +instance Functor SvgMonad where + fmap f mf = SvgMonad $ \r1 r2 s -> let (a,s1) = getSvgMonad mf r1 r2 s + in (f a,s1) +instance Applicative SvgMonad where + pure a = SvgMonad $ \_ _ s -> (a,s) + mf <*> ma = SvgMonad $ \r1 r2 s -> let (f,s1) = getSvgMonad mf r1 r2 s + (a,s2) = getSvgMonad ma r1 r2 s1 + in (f a, s2) -coordChange :: (Num u, Scale t, u ~ DUnit t) => t -> t -coordChange = scale 1 (-1) +instance Monad SvgMonad where + return a = SvgMonad $ \_ _ s -> (a,s) + m >>= k = SvgMonad $ \r1 r2 s -> let (a,s1) = getSvgMonad m r1 r2 s + in (getSvgMonad . k) a r1 r2 s1 + -svg_reflection_matrix :: Num u => Matrix3'3 u -svg_reflection_matrix = scalingMatrix 1 (-1) +runSvgMonad :: TextEncoder -> SvgMonad a -> a +runSvgMonad enc mf = fst $ getSvgMonad mf enc zeroGS 0 + +newClipLabel :: SvgMonad String +newClipLabel = SvgMonad $ \_ _ s -> ('c':'l':'i':'p':show s, s+1) + +askGlyphName :: String -> SvgMonad (Either GlyphName GlyphName) +askGlyphName nm = SvgMonad $ \r1 _ s -> case lookupByGlyphName nm r1 of + Just a -> (Right $ escapeSpecial a, s) + Nothing -> (Left $ escapeSpecial $ svg_fallback r1, s) + +-- This is different to the PsMonad version, as SVG is nested +-- (and /graphics state/ is via a Reader), so it is the same as +-- local with a Reader monad. +-- +runLocalGS :: GSUpdate -> SvgMonad a -> SvgMonad a +runLocalGS upd mf = + SvgMonad $ \r1 r2 s -> getSvgMonad mf r1 (getGSU upd r2) s + + +askFontAttr :: SvgMonad FontAttr +askFontAttr = + SvgMonad $ \_ r2 s -> (FontAttr (gs_font_size r2) (gs_font_face r2), s) + +askLineWidth :: SvgMonad Double +askLineWidth = SvgMonad $ \_ r2 s -> (gs_line_width r2, s) + +askMiterLimit :: SvgMonad Double +askMiterLimit = SvgMonad $ \_ r2 s -> (gs_miter_limit r2, s) + +askLineCap :: SvgMonad LineCap +askLineCap = SvgMonad $ \_ r2 s -> (gs_line_cap r2, s) + +askLineJoin :: SvgMonad LineJoin +askLineJoin = SvgMonad $ \_ r2 s -> (gs_line_join r2, s) + +askDashPattern :: SvgMonad DashPattern +askDashPattern = SvgMonad $ \_ r2 s -> (gs_dash_pattern r2, s) + -------------------------------------------------------------------------------- -- | Output a picture to a SVG file. @@ -73,286 +127,258 @@ writeSVG :: (Real u, Floating u, PSUnit u) => FilePath -> TextEncoder -> Picture u -> IO () writeSVG filepath enc pic = - writeFile filepath $ unlines $ map ppContent $ svgDraw enc pic + writeFile filepath $ show $ svgDraw enc pic -- | Version of 'writeSVG' - using Latin1 encoding. -- writeSVG_latin1 :: (Real u, Floating u, PSUnit u) => FilePath -> Picture u -> IO () -writeSVG_latin1 filepath = writeSVG filepath latin1Encoder - - +writeSVG_latin1 filepath = writeSVG filepath latin1Encoder svgDraw :: (Real u, Floating u, PSUnit u) - => TextEncoder -> Picture u -> [Content] -svgDraw enc pic = runSVG enc $ do - elem1 <- picture False pic' - prefixXmlDecls (topLevelPic mbvec elem1) - where - pic' = coordChange pic - (_,mbvec) = repositionProperties pic' + => TextEncoder -> Picture u -> Doc +svgDraw enc original_pic = + let pic = trivialTranslation original_pic + (_,imgTrafo) = imageTranslation pic + body = runSvgMonad enc $ picture pic + in vcat [ xml_version, doctype, elem_svg $ imgTrafo body ] -prefixXmlDecls :: Element -> SvgM [Content] -prefixXmlDecls e = do - enc <- asks svg_encoding_name - let xmlv = xmlVersion enc - return $ [Text xmlv, Text svgDocType, Elem e] -topLevelPic :: PSUnit u => Maybe (Vec2 u) -> Element -> Element -topLevelPic Nothing p = svgElement [p] -topLevelPic (Just (V2 x y)) p = svgElement [gElement [trans_attr] [p]] - where - trans_attr = attr_transform $ val_translate x y +imageTranslation :: (Ord u, PSUnit u) + => Picture u -> (BoundingBox u, Doc -> Doc) +imageTranslation pic = case repositionDeltas pic of + (bb, Nothing) -> (bb, id) + (bb, Just v) -> let attr = attr_transform (val_translate v) + in (bb, elem_g attr) +-------------------------------------------------------------------------------- +-- Note - it will be wise to make coordinate remapping and output +-- separate passes (unlike in Wumpus-Core). Then I\'ll at least +-- be able to debug the remapped Picture. +-- -picture :: (Real u, Floating u, PSUnit u) - => Clipped -> Picture u -> SvgM Element -picture _ (PicBlank _) = return $ gElement [] [] -picture c (Single (fr,_) prim) = do - elt <- primitive c prim - return $ gElement (maybe [] return $ frameChange fr) [elt] -picture c (Picture (fr,_) ones) = do - -- Note - list in zorder, so we want to draw the tail first - es <- liftM toListH $ F.foldrM fn emptyH ones - return $ gElement (maybe [] return $ frameChange fr) es - where - fn e hl = picture c e >>= \a -> return $ hl `snocH` a - -picture _ (Clip (fr,_) p a) = do - cp <- clipPath p - e1 <- picture True a - return $ gElement (maybe [] return $ frameChange fr) [cp,e1] +picture :: (Real u, Floating u, PSUnit u) => Picture u -> SvgMonad Doc +picture (Leaf (_,xs) ones) = bracketTrafos xs $ revConcat primitive ones +picture (Picture (_,xs) ones) = bracketTrafos xs $ revConcat picture ones +picture (Clip (_,xs) cp pic) = + bracketTrafos xs $ do { lbl <- newClipLabel + ; d1 <- clipPath lbl cp + ; d2 <- picture pic + ; return (vconcat d1 (elem_g (attr_clip_path lbl) d2)) + } +picture (Group (_,xs) fn pic) = bracketTrafos xs (runLocalGS fn (picture pic)) -primitive :: (Real u, Floating u, PSUnit u) - => Clipped -> Primitive u -> SvgM Element -primitive c (PPath props p) = clipAttrib c $ path props p -primitive c (PLabel props l) = clipAttrib c $ label props l -primitive c (PEllipse props e) = clipAttrib c $ ellipse props e +-- This starts with an empty line... +-- --- All clipping paths are closed. -clipPath :: PSUnit u => Path u -> SvgM Element -clipPath p = do - name <- newClipLabel - return $ element_clippath ps `rap` add_attr (attr_id name) +revConcat :: (a -> SvgMonad Doc) -> OneList a -> SvgMonad Doc +revConcat fn ones = some empty <$> F.foldrM step None ones where - ps = closePath $ pathInstructions p + step e ac = (\d -> d `conc` ac) <$> fn e + conc d None = Some d + conc d (Some ac) = Some $ ac `vconcat` d -clipAttrib :: Clipped -> SvgM Element -> SvgM Element -clipAttrib False melt = melt -clipAttrib True melt = do - s <- currentClipLabel - elt <- melt - return $ add_attr (attr_clippath s) elt +primitive :: (Real u, Floating u, PSUnit u) => Primitive u -> SvgMonad Doc +primitive (PPath props xl pp) = drawXLink xl <$> primPath props pp +primitive (PLabel props xl lbl) = drawXLink xl <$> primLabel props lbl +primitive (PEllipse props xl ell) = drawXLink xl <$> primEllipse props ell + +drawXLink :: XLink -> Doc -> Doc +drawXLink NoLink doc = doc +drawXLink (XLinkHRef href) doc = elem_a_xlink href doc --- None of the remaining translation functions need to be in the --- SvgM monad. +clipPath :: PSUnit u => String -> PrimPath u -> SvgMonad Doc +clipPath clip_id pp = (\doc -> elem_clipPath (attr_id clip_id) doc) <$> path pp -path :: PSUnit u => PathProps -> Path u -> SvgM Element -path (c,dp) p = - return $ element_path ps `snoc_attrs` (fill_a : stroke_a : opts) - where - (fill_a,stroke_a,opts) = drawProperties c dp - ps = svgPath dp p +primPath :: PSUnit u => PathProps -> PrimPath u -> SvgMonad Doc +primPath props pp = (\(a,f) d -> elem_path a (f d)) + <$> pathProps props <*> path pp --- Labels need the coordinate system remapping otherwise --- the will be printed upside down. Both the start point and --- the label itself need transforming. --- --- Also rendering coloured text is convoluted (needing the --- tspan element). --- --- -label :: (Real u, Floating u, PSUnit u) - => LabelProps -> Label u -> SvgM Element -label (c,FontAttr sz face) (Label pt entxt ctm) = do - str <- encodedText entxt - let tspan_elt = element_tspan str `snoc_attrs` [ attr_fill c ] - return $ element_text tspan_elt `snoc_attrs` coord_attrs - `snoc_attrs` font_attrs - `snoc_attrs` (fontStyle style) - where - style = svg_font_style face - fam = svg_font_family face - coord_attrs = if ctm == identityCTM then simpleLabelAttrs pt - else transfLabelAttrs pt ctm - font_attrs = [ attr_font_family fam - , attr_font_size sz - ] -simpleLabelAttrs :: PSUnit u => Point2 u -> [Attr] -simpleLabelAttrs pt = [ attr_x x, attr_y y, attr_transform mtrx] - where - P2 x y = coordChange pt - mtrx = val_matrix 1 0 0 (-1) 0 (0::Double) - -transfLabelAttrs :: (Real u, Floating u, PSUnit u) - => Point2 u -> PrimCTM u -> [Attr] -transfLabelAttrs (P2 x y) ctm = - [ attr_x (0::Double), attr_y (0 :: Double), attr_transform vmtrx] +path :: PSUnit u => PrimPath u -> SvgMonad Doc +path (PrimPath start xs) = + pure $ path_m start <+> hsep (map seg xs) where - mtrx = translMatrixRepCTM x y ctm * svg_reflection_matrix - vmtrx = valMatrix mtrx + seg (PLineTo pt) = path_l pt + seg (PCurveTo p1 p2 p3) = path_c p1 p2 p3 +-- Return - drawing props, plus a function to close the path (or not). +-- +pathProps :: PathProps -> SvgMonad (Doc, Doc -> Doc) +pathProps props = fn props + where + fn (CFill rgb) = pure (fillNotStroke rgb, close) -encodedText :: EncodedText -> SvgM String -encodedText entxt = - let xs = getEncodedText entxt in mapM textChunk xs >>= return . concat + fn (CStroke attrs rgb) = + (\a -> (strokeNotFill rgb <+> a, close)) <$> deltaStrokeAttrs attrs --- | Unfortunately we can\'t readily put a comment in the --- generated SVG when glyph-name lookup fails. Doing similar in --- PostScript is easy because we are emiting /linear/ PostScript --- as we go along. For SVG we are building an abstract syntax --- tree. --- -textChunk :: TextChunk -> SvgM String -textChunk (SText s) = return s -textChunk (EscInt i) = return $ escapeCharCode i -textChunk (EscStr s) = - asks (lookupByGlyphName s) >>= maybe failk (return . escapeCharCode) - where - failk = asks svg_fallback >>= return . escapeCharCode + fn (OStroke attrs rgb) = + (\a -> (strokeNotFill rgb <+> a, id)) <$> deltaStrokeAttrs attrs -escapeCharCode :: CharCode -> String -escapeCharCode i = "&#" ++ show i ++ ";" + fn (CFillStroke fc attrs sc) = + (\a -> (fillAndStroke fc sc <+> a, close)) <$> deltaStrokeAttrs attrs + fillNotStroke rgb = attr_fill rgb <+> attr_stroke_none + strokeNotFill rgb = attr_stroke rgb <+> attr_fill_none + fillAndStroke a b = attr_fill a <+> attr_stroke b + close = (<+> char 'Z') -fontStyle :: SVGFontStyle -> [Attr] -fontStyle SVG_REGULAR = [] -fontStyle SVG_BOLD = [attr_font_weight "bold"] -fontStyle SVG_ITALIC = [attr_font_style "italic"] -fontStyle SVG_BOLD_ITALIC = - [attr_font_weight "bold", attr_font_style "italic"] -fontStyle SVG_OBLIQUE = [attr_font_style "oblique"] -fontStyle SVG_BOLD_OBLIQUE = - [attr_font_weight "bold", attr_font_style "oblique"] --- If w==h the draw the ellipse as a circle -ellipse :: (Real u, Floating u, PSUnit u) - => EllipseProps -> PrimEllipse u -> SvgM Element -ellipse (c,dp) (PrimEllipse pt hw hh ctm) - | hw == hh = return $ element_circle - `snoc_attrs` (circle_attrs ++ style_attrs) - | otherwise = return $ element_ellipse - `snoc_attrs` (ellipse_attrs ++ style_attrs) + + +-- Note - if hw==hh then draw the ellipse as a circle. +-- +primEllipse :: (Real u, Floating u, PSUnit u) + => EllipseProps -> PrimEllipse u -> SvgMonad Doc +primEllipse props (PrimEllipse pt hw hh ctm) + | hw == hh = (\a b -> elem_circle (a <+> circle_radius <+> b)) + <$> bracketPrimCTM pt ctm mkCXCY <*> ellipseProps props + | otherwise = (\a b -> elem_ellipse (a <+> ellipse_radius <+> b)) + <$> bracketPrimCTM pt ctm mkCXCY <*> ellipseProps props where - circle_attrs = if ctm == identityCTM - then simpleCircleAttrs pt hw - else transfCircleAttrs pt hw ctm + mkCXCY (P2 x y) = pure $ attr_cx x <+> attr_cy y + + circle_radius = attr_r hw + ellipse_radius = attr_rx hw <+> attr_ry hh - ellipse_attrs = if ctm == identityCTM - then simpleEllipseAttrs pt hw hh - else transfEllipseAttrs pt hw hh ctm + - style_attrs = fill_a : stroke_a : opts - where (fill_a,stroke_a,opts) = drawEllipse c dp +ellipseProps :: EllipseProps -> SvgMonad Doc +ellipseProps (EFill rgb) = + pure (attr_fill rgb <+> attr_stroke_none) -simpleCircleAttrs :: PSUnit u => Point2 u -> u -> [Attr] -simpleCircleAttrs (P2 x y) radius = [attr_cx x, attr_cy y, attr_r radius] +ellipseProps (EStroke attrs rgb) = + (\a -> attr_stroke rgb <+> attr_fill_none <+> a) <$> deltaStrokeAttrs attrs -simpleEllipseAttrs :: PSUnit u => Point2 u -> u -> u -> [Attr] -simpleEllipseAttrs (P2 x y) hw hh = - [attr_cx x, attr_cy y, attr_rx hw, attr_ry hh] +ellipseProps (EFillStroke frgb attrs srgb) = + (\a -> attr_fill frgb <+> attr_stroke srgb <+> a) <$> deltaStrokeAttrs attrs -transfCircleAttrs :: (Real u, Floating u, PSUnit u) - => Point2 u -> u -> PrimCTM u -> [Attr] -transfCircleAttrs (P2 x y) radius ctm = - [ attr_cx (0::Double), attr_cy (0::Double), attr_r radius - , attr_transform vmtrx ] + +-- Note - Rendering coloured text seemed convoluted +-- (mandating the tspan element). +-- +-- TO CHECK - is this really the case? +-- +-- + +primLabel :: (Real u, Floating u, PSUnit u) + => LabelProps -> PrimLabel u -> SvgMonad Doc +primLabel (LabelProps rgb attrs) (PrimLabel pt etext ctm) = + (\fa ca txt -> elem_text (fa <+> ca) txt) + <$> deltaFontAttrs attrs <*> bracketPrimCTM pt ctm mkXY + <*> tspan rgb etext where - mtrx = translMatrixRepCTM x y ctm * svg_reflection_matrix - vmtrx = valMatrix mtrx + mkXY (P2 x y) = pure $ attr_x x <+> attr_y y +tspan :: RGBi -> EncodedText -> SvgMonad Doc +tspan rgb enctext = + (\txt -> elem_tspan (attr_fill rgb) txt) + <$> encodedText enctext -transfEllipseAttrs :: (Real u, Floating u, PSUnit u) - => Point2 u -> u -> u -> PrimCTM u -> [Attr] -transfEllipseAttrs (P2 x y) hw hh ctm = - [ attr_cx (0::Double), attr_cy (0::Double), attr_rx hw, attr_ry hh - , attr_transform vmtrx ] +encodedText :: EncodedText -> SvgMonad Doc +encodedText enctext = hcat <$> mapM textChunk (getEncodedText enctext) + + +textChunk :: TextChunk -> SvgMonad Doc +textChunk (SText s) = pure $ text s +textChunk (EscInt i) = pure $ text $ escapeSpecial i +textChunk (EscStr s) = either text text <$> askGlyphName s + + +-------------------------------------------------------------------------------- +-- Stroke and font attribute delta + +deltaStrokeAttrs :: [StrokeAttr] -> SvgMonad Doc +deltaStrokeAttrs xs = hsep <$> mapM df xs where - mtrx = translMatrixRepCTM x y ctm * svg_reflection_matrix - vmtrx = valMatrix mtrx + df (LineWidth d) = (\inh -> if d==inh then empty + else attr_stroke_width d) + <$> askLineWidth + df (MiterLimit d) = (\inh -> if d==inh then empty + else attr_stroke_miterlimit d) + <$> askMiterLimit --- A rule of thumb seems to be that SVG (at least SVG in Firefox) --- will try to fill unless told not to. So always label paths --- with @fill=...@ even if fill is @\"none\"@. --- --- CFill ==> stroke="none" fill="..." --- CStroke ==> stroke="..." fill="none" --- OStroke ==> stroke="..." fill="none" --- + df (LineCap d) = (\inh -> if d==inh then empty + else attr_stroke_linecap d) + <$> askLineCap -drawProperties :: PSColour c => c -> DrawPath -> (Attr, Attr, [Attr]) -drawProperties = fn where - fn c CFill = (attr_fill c, attr_stroke_none, []) - fn c (OStroke xs) = (attr_fill_none, attr_stroke c, strokeAttributes xs) - fn c (CStroke xs) = (attr_fill_none, attr_stroke c, strokeAttributes xs) + df (LineJoin d) = (\inh -> if d==inh then empty + else attr_stroke_linejoin d) + <$> askLineJoin -drawEllipse :: PSColour c => c -> DrawEllipse -> (Attr, Attr, [Attr]) -drawEllipse = fn where - fn c EFill = (attr_fill c, attr_stroke_none, []) - fn c (EStroke xs) = (attr_fill_none, attr_stroke c, strokeAttributes xs) - + df (DashPattern d) = (\inh -> if d==inh then empty + else makeDashPattern d) + <$> askDashPattern -strokeAttributes :: [StrokeAttr] -> [Attr] -strokeAttributes = foldr fn [] where - fn (LineWidth a) = (:) (attr_stroke_width a) - fn (MiterLimit a) = (:) (attr_stroke_miterlimit a) - fn (LineCap lc) = (:) (attr_stroke_linecap lc) - fn (LineJoin lj) = (:) (attr_stroke_linejoin lj) - fn (DashPattern dp) = dash dp where - dash Solid = (:) (attr_stroke_dasharray_none) - dash (Dash _ []) = (:) (attr_stroke_dasharray_none) - dash (Dash i xs) = (:) (attr_stroke_dashoffset i) . - (:) (attr_stroke_dasharray $ conv xs) - conv = foldr (\(x,y) a -> x:y:a) [] +makeDashPattern :: DashPattern -> Doc +makeDashPattern Solid = attr_stroke_dasharray_none +makeDashPattern (Dash n xs) = + attr_stroke_dashoffset n <+> attr_stroke_dasharray xs -svgPath :: PSUnit u => DrawPath -> Path u -> SvgPath -svgPath (OStroke _) p = pathInstructions p -svgPath _ p = closePath $ pathInstructions p +deltaFontAttrs :: FontAttr -> SvgMonad Doc +deltaFontAttrs fa = + (\inh -> if fa ==inh then empty else makeFontAttrs fa) <$> askFontAttr -pathInstructions :: PSUnit u => Path u -> [String] -pathInstructions (Path (P2 x y) xs) = path_m x y : map pathSegment xs +makeFontAttrs :: FontAttr -> Doc +makeFontAttrs (FontAttr sz face) = + attr_font_family (svg_font_family face) <+> attr_font_size sz + <> suffix (svg_font_style face) + where + suffix SVG_REGULAR = empty -pathSegment :: PSUnit u => PathSegment u -> String -pathSegment (PLineTo (P2 x1 y1)) = path_l x1 y1 -pathSegment (PCurveTo (P2 x1 y1) (P2 x2 y2) (P2 x3 y3)) = - path_c x1 y1 x2 y2 x3 y3 + suffix SVG_BOLD = space <> attr_font_weight "bold" + suffix SVG_ITALIC = space <> attr_font_style "italic" + suffix SVG_BOLD_ITALIC = + space <> attr_font_weight "bold" <+> attr_font_style "italic" -frameChange :: PSUnit u => Frame2 u -> Maybe Attr -frameChange fr - | standardFrame fr = Nothing - | otherwise = Just $ attr_transform $ val_matrix a b c d e f - where - CTM a b c d e f = toCTM fr + suffix SVG_OBLIQUE = space <> attr_font_style "oblique" + suffix SVG_BOLD_OBLIQUE = + space <> attr_font_weight "bold" <+> attr_font_style "oblique" -closePath :: SvgPath -> SvgPath -closePath xs = xs ++ ["Z"] -snoc_attrs :: Element -> [Attr] -> Element -snoc_attrs = flip add_attrs +-------------------------------------------------------------------------------- +-- Bracket matrix and PrimCTM trafos +bracketTrafos :: (Real u, Floating u, PSUnit u) + => [AffineTrafo u] -> SvgMonad Doc -> SvgMonad Doc +bracketTrafos xs ma = bracketMatrix (concatTrafos xs) ma +bracketMatrix :: (Fractional u, PSUnit u) + => Matrix3'3 u -> SvgMonad Doc -> SvgMonad Doc +bracketMatrix mtrx ma + | mtrx == identityMatrix = (\doc -> elem_g_no_attrs doc) <$> ma + | otherwise = (\doc -> elem_g trafo doc) <$> ma + where + trafo = attr_transform $ val_matrix mtrx -valMatrix :: PSUnit u => Matrix3'3 u -> String -valMatrix m33 = val_matrix a b c d x y + +bracketPrimCTM :: forall u. (Real u, Floating u, PSUnit u) + => Point2 u -> PrimCTM u + -> (Point2 u -> SvgMonad Doc) -> SvgMonad Doc +bracketPrimCTM pt@(P2 x y) ctm pf + | ctm == identityCTM = pf pt + | otherwise = (\xy -> xy <+> attr_transform mtrx) <$> pf zeroPt' where - CTM a b c d x y = toCTM m33 + zeroPt' :: Point2 u + zeroPt' = zeroPt + + mtrx = val_matrix $ translMatrixRepCTM x y ctm diff --git a/src/Wumpus/Core/PageTranslation.hs b/src/Wumpus/Core/PageTranslation.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Core/PageTranslation.hs @@ -0,0 +1,65 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Core.PageTranslation +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Core page translation for SVG. +-- +-------------------------------------------------------------------------------- + + +module Wumpus.Core.PageTranslation + ( + + trivialTranslation + + ) where + +import Wumpus.Core.AffineTrans +import Wumpus.Core.PictureInternal + + + +-------------------------------------------------------------------------------- +-- trivial translation + +-- Rescale the entire image (1,-1), rescale the ellipse and +-- label primitives as they are encoutered (1,-1). No need to +-- worry about scaling the BoundingBox +-- + +trivialTranslation :: (Num u, Ord u) => Picture u -> Picture u +trivialTranslation pic = scale 1 (-1) (trivPic pic) + +trivPic :: Num u => Picture u -> Picture u +trivPic (Leaf lc ones) = Leaf lc $ fmap trivPrim ones +trivPic (Picture lc ones) = Picture lc $ fmap trivPic ones +trivPic (Clip lc pp pic) = Clip lc pp $ trivPic pic +trivPic (Group lc upd pic) = Group lc upd $ trivPic pic + +trivPrim :: Num u => Primitive u -> Primitive u +trivPrim (PPath a xl pp) = PPath a xl pp +trivPrim (PLabel a xl lbl) = PLabel a xl (trivLabel lbl) +trivPrim (PEllipse a xl ell) = PEllipse a xl (trivEllipse ell) + + +trivLabel :: Num u => PrimLabel u -> PrimLabel u +trivLabel (PrimLabel pt txt ctm) = PrimLabel pt txt (trivPrimCTM ctm) + +trivEllipse :: Num u => PrimEllipse u -> PrimEllipse u +trivEllipse (PrimEllipse ctr hw hh ctm) = + PrimEllipse ctr hw hh (trivPrimCTM ctm) + +-- Is the translation here just negating the angle with scaling +-- left untouched? +-- +trivPrimCTM :: Num u => PrimCTM u -> PrimCTM u +trivPrimCTM (PrimCTM sx sy theta) = PrimCTM sx (-sy) theta + diff --git a/src/Wumpus/Core/Picture.hs b/src/Wumpus/Core/Picture.hs --- a/src/Wumpus/Core/Picture.hs +++ b/src/Wumpus/Core/Picture.hs @@ -8,180 +8,133 @@ -- Copyright : (c) Stephen Tetley 2009-2010 -- License : BSD3 -- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC with TypeFamilies and more +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC -- -- Construction of pictures, paths and text labels. --- +-- -------------------------------------------------------------------------------- -module Wumpus.Core.Picture - ( - - -- * Construction - blankPicture - , frame - , frameWithin - , frameMulti - , multi +module Wumpus.Core.Picture + ( + -- * Construction + frame + , multi , path , lineTo , curveTo - , vertexPath + , vertexPath , curvedPath - - , wumpus_default_font + , xlinkhref -- * Constructing primitives , Stroke(..) , zostroke , zcstroke - , Fill(..) , zfill - + , Ellipse(..) + , zellipse + , clip , TextLabel(..) , ztextlabel - , Ellipse(..) - , zellipse - -- * Operations - , extendBoundary - + , extendBoundary - -- * Minimal - picture composition - , picMoveBy + -- * Picture composition , picOver + , picMoveBy , picBeside + + -- * Illustrating pictures and primitives + , printPicture , illustrateBounds - , illustrateBoundsPrim + , illustrateBoundsPrim , illustrateControlPoints ) where +import Wumpus.Core.AffineTrans import Wumpus.Core.BoundingBox import Wumpus.Core.Colour +import Wumpus.Core.FormatCombinators import Wumpus.Core.Geometry import Wumpus.Core.GraphicsState import Wumpus.Core.OneList import Wumpus.Core.PictureInternal import Wumpus.Core.PtSize -import Wumpus.Core.TextEncodingInternal +import Wumpus.Core.TextInternal +import Wumpus.Core.Utils -import Data.Semigroup +import Data.AffineSpace -- package: vector-space +import Data.Semigroup -- package: algebra --------------------------------------------------------------------------------- --- Default attributes -psBlack :: PSRgb -psBlack = RGB3 0 0 0 - --- aka the standard frame -stdFrame :: Num u => Frame2 u -stdFrame = ortho zeroPt - - -------------------------------------------------------------------------------- -- Construction - --- | Create a blank 'Picture' sized to the supplied bounding box. --- This is useful for spacing rows or columns of pictures. --- -blankPicture :: Num u => BoundingBox u -> Picture u -blankPicture bb = PicBlank (stdFrame, bb) - - --- | Lift a 'Primitive' to a 'Picture', located in the standard frame. --- -frame :: (Real u, Floating u, FromPtSize u) => Primitive u -> Picture u -frame p = Single (stdFrame, boundary p) p - --- | Frame a picture within the supplied bounding box --- --- A text label uses the supplied bounding box as is - no --- clipping is performed if the bounding box is --- smaller than the boundary size of the text. This may --- cause strange overlap for subsequent composite pictures, and --- incorrect bounding box annotations in the prologue of the --- generated EPS file. --- --- Paths and ellipses are bound within the union of the supplied --- bounding box and the inherent bounding box or the path or --- ellipse. Thus the bounding box will never reframed to a --- smaller size than the /natural/ bounding box. --- -frameWithin :: (Real u, Floating u, FromPtSize u) - => Primitive u -> BoundingBox u -> Picture u -frameWithin p@(PLabel _ _) bb = Single (stdFrame,bb) p -frameWithin p bb = Single (stdFrame,bb `append` boundary p) p - - - - --- | Lift a list of primitives to a composite picture, all --- primitives will be located within the standard frame. +-- | Lift a list of primitives to a composite picture. -- -- The order of the list maps to the zorder - the front of the -- list is drawn at the top. -- -- This function throws an error when supplied the empty list. -- -frameMulti :: (Real u, Floating u, FromPtSize u) - => [Primitive u] -> Picture u -frameMulti [] = error "Wumpus.Core.Picture.frameMulti - empty list" -frameMulti xs = multi $ map frame xs +frame :: (Real u, Floating u, FromPtSize u) => [Primitive u] -> Picture u +frame [] = error "Wumpus.Core.Picture.frame - empty list" +frame (p:ps) = let (bb,ones) = step p ps in Leaf (bb,[]) ones + where + step a [] = (boundary a, one a) + step a (x:xs) = let (bb', rest) = step x xs + in ( boundary a `append` bb', cons a rest ) --- | Place multiple pictures within the same affine frame. + +-- | Place multiple pictures within the standard affine frame. -- -- This function throws an error when supplied the empty list. -- multi :: (Fractional u, Ord u) => [Picture u] -> Picture u -multi ps = Picture (stdFrame, sconcat $ map boundary ps) $ step ps - where - sconcat [] = error err_msg - sconcat (x:xs) = foldr append x xs - - step [x] = one x - step (x:xs) = x `cons` step xs - step _ = error err_msg - - err_msg = "Wumpus.Core.Picture.multi - empty list" +multi [] = error "Wumpus.Core.Picture.multi - empty list" +multi (p:ps) = let (bb,ones) = step p ps in Picture (bb,[]) ones + where + step a [] = (boundary a, one a) + step a (x:xs) = let (bb', rest) = step x xs + in ( boundary a `append` bb', cons a rest ) --- | Create a Path from a start point and a list of --- PathSegments. -path :: Point2 u -> [PathSegment u] -> Path u -path = Path +-- | Create a Path from a start point and a list of PathSegments. +-- +path :: Point2 u -> [PrimPathSegment u] -> PrimPath u +path = PrimPath -- | Create a straight-line PathSegment. -- -lineTo :: Point2 u -> PathSegment u +lineTo :: Point2 u -> PrimPathSegment u lineTo = PLineTo -- | Create a curved PathSegment. -- -curveTo :: Point2 u -> Point2 u -> Point2 u -> PathSegment u +curveTo :: Point2 u -> Point2 u -> Point2 u -> PrimPathSegment u curveTo = PCurveTo -- | Convert the list of vertices to a path of straight line -- segments. -- -vertexPath :: [Point2 u] -> Path u +vertexPath :: [Point2 u] -> PrimPath u vertexPath [] = error "Picture.vertexPath - empty point list" -vertexPath (x:xs) = Path x (map PLineTo xs) +vertexPath (x:xs) = PrimPath x (map PLineTo xs) @@ -190,39 +143,29 @@ -- segment thereafter takes 3 points. /Spare/ points at the end -- are discarded. -- -curvedPath :: [Point2 u] -> Path u +curvedPath :: [Point2 u] -> PrimPath u curvedPath [] = error "Picture.curvedPath - empty point list" -curvedPath (x:xs) = Path x (fn xs) where - fn (a:b:c:ys) = PCurveTo a b c : fn ys - fn _ = [] - - - - - --- | Constant for the default font, which is @Courier@ (aliased --- to @Courier New@ for SVG) at 24 point. --- --- -wumpus_default_font :: FontAttr -wumpus_default_font = FontAttr 24 face +curvedPath (x:xs) = PrimPath x (step xs) where - face = FontFace { font_name = "Courier" - , svg_font_family = "Courier New" - , svg_font_style = SVG_REGULAR - } + step (a:b:c:ys) = PCurveTo a b c : step ys + step _ = [] +xlinkhref :: String -> XLink +xlinkhref = XLinkHRef -------------------------------------------------------------------------------- -- Take Paths to Primitives +-- *** Stroke -ostrokePath :: Num u => PSRgb -> [StrokeAttr] -> Path u -> Primitive u -ostrokePath c attrs p = PPath (c, OStroke attrs) p +ostrokePath :: Num u + => RGBi -> [StrokeAttr] -> XLink -> PrimPath u -> Primitive u +ostrokePath rgb attrs xlink p = PPath (OStroke attrs rgb) xlink p -cstrokePath :: Num u => PSRgb -> [StrokeAttr] -> Path u -> Primitive u -cstrokePath c attrs p = PPath (c, CStroke attrs) p +cstrokePath :: Num u + => RGBi -> [StrokeAttr] -> XLink -> PrimPath u -> Primitive u +cstrokePath rgb attrs xlink p = PPath (CStroke attrs rgb) xlink p -- | Create a open, stroked path (@ostroke@) or a closed, stroked -- path (@cstroke@). @@ -231,79 +174,74 @@ -- the path more convenient. -- class Stroke t where - ostroke :: Num u => t -> Path u -> Primitive u - cstroke :: Num u => t -> Path u -> Primitive u + ostroke :: Num u => t -> PrimPath u -> Primitive u + cstroke :: Num u => t -> PrimPath u -> Primitive u instance Stroke () where - ostroke () = ostrokePath psBlack [] - cstroke () = cstrokePath psBlack [] - -instance Stroke (RGB3 Double) where - ostroke c = ostrokePath (psColour c) [] - cstroke c = cstrokePath (psColour c) [] - -instance Stroke (HSB3 Double) where - ostroke c = ostrokePath (psColour c) [] - cstroke c = cstrokePath (psColour c) [] - -instance Stroke (Gray Double) where - ostroke c = ostrokePath (psColour c) [] - cstroke c = cstrokePath (psColour c) [] + ostroke () = ostrokePath black [] NoLink + cstroke () = cstrokePath black [] NoLink +instance Stroke RGBi where + ostroke rgb = ostrokePath rgb [] NoLink + cstroke rgb = cstrokePath rgb [] NoLink instance Stroke StrokeAttr where - ostroke x = ostrokePath psBlack [x] - cstroke x = cstrokePath psBlack [x] + ostroke x = ostrokePath black [x] NoLink + cstroke x = cstrokePath black [x] NoLink instance Stroke [StrokeAttr] where - ostroke xs = ostrokePath psBlack xs - cstroke xs = cstrokePath psBlack xs + ostroke xs = ostrokePath black xs NoLink + cstroke xs = cstrokePath black xs NoLink +instance Stroke XLink where + ostroke xlink = ostrokePath black [] xlink + cstroke xlink = cstrokePath black [] xlink -instance Stroke (RGB3 Double,StrokeAttr) where - ostroke (c,x) = ostrokePath (psColour c) [x] - cstroke (c,x) = cstrokePath (psColour c) [x] +instance Stroke (RGBi,StrokeAttr) where + ostroke (rgb,x) = ostrokePath rgb [x] NoLink + cstroke (rgb,x) = cstrokePath rgb [x] NoLink -instance Stroke (HSB3 Double,StrokeAttr) where - ostroke (c,x) = ostrokePath (psColour c) [x] - cstroke (c,x) = cstrokePath (psColour c) [x] +instance Stroke (RGBi,[StrokeAttr]) where + ostroke (rgb,xs) = ostrokePath rgb xs NoLink + cstroke (rgb,xs) = cstrokePath rgb xs NoLink -instance Stroke (Gray Double,StrokeAttr) where - ostroke (c,x) = ostrokePath (psColour c) [x] - cstroke (c,x) = cstrokePath (psColour c) [x] +instance Stroke (RGBi,XLink) where + ostroke (rgb,xlink) = ostrokePath rgb [] xlink + cstroke (rgb,xlink) = cstrokePath rgb [] xlink -instance Stroke (RGB3 Double,[StrokeAttr]) where - ostroke (c,xs) = ostrokePath (psColour c) xs - cstroke (c,xs) = cstrokePath (psColour c) xs +instance Stroke (StrokeAttr,XLink) where + ostroke (x,xlink) = ostrokePath black [x] xlink + cstroke (x,xlink) = cstrokePath black [x] xlink -instance Stroke (HSB3 Double,[StrokeAttr]) where - ostroke (c,xs) = ostrokePath (psColour c) xs - cstroke (c,xs) = cstrokePath (psColour c) xs +instance Stroke ([StrokeAttr],XLink) where + ostroke (xs,xlink) = ostrokePath black xs xlink + cstroke (xs,xlink) = cstrokePath black xs xlink -instance Stroke (Gray Double,[StrokeAttr]) where - ostroke (c,xs) = ostrokePath (psColour c) xs - cstroke (c,xs) = cstrokePath (psColour c) xs +instance Stroke (RGBi,StrokeAttr,XLink) where + ostroke (rgb,x,xlink) = ostrokePath rgb [x] xlink + cstroke (rgb,x,xlink) = cstrokePath rgb [x] xlink +instance Stroke (RGBi,[StrokeAttr],XLink) where + ostroke (rgb,xs,xlink) = ostrokePath rgb xs xlink + cstroke (rgb,xs,xlink) = cstrokePath rgb xs xlink + -- | Create an open stoke coloured black. -- -zostroke :: Num u => Path u -> Primitive u -zostroke = ostrokePath psBlack [] +zostroke :: Num u => PrimPath u -> Primitive u +zostroke = ostrokePath black [] NoLink -- | Create a closed stroke coloured black. -- -zcstroke :: Num u => Path u -> Primitive u -zcstroke = cstrokePath psBlack [] - - - - +zcstroke :: Num u => PrimPath u -> Primitive u +zcstroke = cstrokePath black [] NoLink +-- *** Fill -fillPath :: Num u => PSRgb -> Path u -> Primitive u -fillPath c p = PPath (c,CFill) p +fillPath :: Num u => RGBi -> XLink -> PrimPath u -> Primitive u +fillPath rgb xlink p = PPath (CFill rgb) xlink p -- | Create a filled path (@fill@). Fills only have one -- property - colour. But there are various representations of @@ -312,36 +250,51 @@ -- @ fill () @ will fill with the default colour - black. -- class Fill t where - fill :: Num u => t -> Path u -> Primitive u + fill :: Num u => t -> PrimPath u -> Primitive u -instance Fill () where fill () = fillPath psBlack -instance Fill (RGB3 Double) where fill = fillPath . psColour -instance Fill (HSB3 Double) where fill = fillPath . psColour -instance Fill (Gray Double) where fill = fillPath . psColour +instance Fill () where fill () = fillPath black NoLink +instance Fill RGBi where fill rgb = fillPath rgb NoLink +instance Fill XLink where fill xlink = fillPath black xlink +instance Fill (RGBi,XLink) where + fill (rgb,xlink) = fillPath rgb xlink + + -- | Create a filled path coloured black. -zfill :: Num u => Path u -> Primitive u -zfill = fillPath psBlack +zfill :: Num u => PrimPath u -> Primitive u +zfill = fillPath black NoLink -------------------------------------------------------------------------------- -- Clipping -- | Clip a picture with respect to the supplied path. -- -clip :: (Num u, Ord u) => Path u -> Picture u -> Picture u -clip cp p = Clip (ortho zeroPt, boundary cp) cp p - +clip :: (Num u, Ord u) => PrimPath u -> Picture u -> Picture u +clip cp p = Clip (pathBoundary cp, []) cp p -------------------------------------------------------------------------------- -- Labels to primitive -mkTextLabel :: Num u => PSRgb -> FontAttr -> String -> Point2 u -> Primitive u -mkTextLabel c attr txt pt = PLabel (c,attr) lbl +mkTextLabel :: Num u + => RGBi -> FontAttr -> XLink -> String -> Point2 u -> Primitive u +mkTextLabel rgb attr xlink txt pt = PLabel (LabelProps rgb attr) xlink lbl where - lbl = Label pt (lexLabel txt) identityCTM + lbl = PrimLabel pt (lexLabel txt) identityCTM +-- | Constant for the default font, which is @Courier@ (aliased +-- to @Courier New@ for SVG) at 14 point. +-- +-- +wumpus_default_font :: FontAttr +wumpus_default_font = FontAttr 14 face + where + face = FontFace { font_name = "Courier" + , svg_font_family = "Courier New" + , svg_font_style = SVG_REGULAR + } + -- | Create a text label. The string should not contain newline -- or tab characters. Use 'multilabel' to create text with -- multiple lines. @@ -349,7 +302,7 @@ -- @textlabel@ is overloaded to make attributing the label more -- convenient. -- --- Unless a 'FontAttr' is specified, the label will use 12pt +-- Unless a 'FontAttr' is specified, the label will use 14pt -- Courier. -- -- The supplied point is is the bottom left corner. @@ -359,45 +312,47 @@ instance TextLabel () where - textlabel () = mkTextLabel psBlack wumpus_default_font + textlabel () = mkTextLabel black wumpus_default_font NoLink -instance TextLabel (RGB3 Double) where - textlabel c = mkTextLabel (psColour c) wumpus_default_font +instance TextLabel RGBi where + textlabel rgb = mkTextLabel rgb wumpus_default_font NoLink -instance TextLabel (HSB3 Double) where - textlabel c = mkTextLabel (psColour c) wumpus_default_font +instance TextLabel FontAttr where + textlabel a = mkTextLabel black a NoLink -instance TextLabel (Gray Double) where - textlabel c = mkTextLabel (psColour c) wumpus_default_font +instance TextLabel XLink where + textlabel xlink = mkTextLabel black wumpus_default_font xlink -instance TextLabel FontAttr where - textlabel a = mkTextLabel psBlack a -instance TextLabel (RGB3 Double,FontAttr) where - textlabel (c,a) = mkTextLabel (psColour c) a +instance TextLabel (RGBi,FontAttr) where + textlabel (rgb,a) = mkTextLabel rgb a NoLink -instance TextLabel (HSB3 Double,FontAttr) where - textlabel (c,a) = mkTextLabel (psColour c) a +instance TextLabel (RGBi,XLink) where + textlabel (rgb,xlink) = mkTextLabel rgb wumpus_default_font xlink -instance TextLabel (Gray Double,FontAttr) where - textlabel (c,a) = mkTextLabel (psColour c) a +instance TextLabel (FontAttr,XLink) where + textlabel (a,xlink) = mkTextLabel black a xlink --- | Create a label where the font is @Courier@, text size is 24pt +instance TextLabel (RGBi,FontAttr,XLink) where + textlabel (rgb,a,xlink) = mkTextLabel rgb a xlink + +-- | Create a label where the font is @Courier@, text size is 14pt -- and colour is black. +-- ztextlabel :: Num u => String -> Point2 u -> Primitive u -ztextlabel = mkTextLabel psBlack wumpus_default_font - +ztextlabel = mkTextLabel black wumpus_default_font NoLink -------------------------------------------------------------------------------- mkEllipse :: Num u - => PSRgb -> DrawEllipse -> u -> u -> Point2 u -> Primitive u -mkEllipse c dp hw hh pt = PEllipse (c,dp) (PrimEllipse pt hw hh identityCTM) + => EllipseProps -> XLink -> u -> u -> Point2 u -> Primitive u +mkEllipse props xlink hw hh pt = + PEllipse props xlink (PrimEllipse pt hw hh identityCTM) ellipseDefault :: EllipseProps -ellipseDefault = (psBlack, EFill) +ellipseDefault = EFill black -- | Create an ellipse, the ellipse will be filled unless the @@ -420,65 +375,45 @@ class Ellipse t where ellipse :: Fractional u => t -> u -> u -> Point2 u -> Primitive u -instance Ellipse () where ellipse () = zellipse -instance Ellipse DrawEllipse where ellipse dp = mkEllipse psBlack dp -instance Ellipse StrokeAttr where - ellipse = mkEllipse psBlack . EStroke . return - -instance Ellipse [StrokeAttr] where - ellipse = mkEllipse psBlack . EStroke - -instance Ellipse (RGB3 Double) where - ellipse c = mkEllipse (psColour c) EFill - -instance Ellipse (HSB3 Double) where - ellipse c = mkEllipse (psColour c) EFill - -instance Ellipse (Gray Double) where - ellipse c = mkEllipse (psColour c) EFill - - -instance Ellipse (RGB3 Double,DrawEllipse) where - ellipse (c,dp) = mkEllipse (psColour c) dp +instance Ellipse () where ellipse () = zellipse -instance Ellipse (HSB3 Double,DrawEllipse) where - ellipse (c,dp) = mkEllipse (psColour c) dp +instance Ellipse RGBi where + ellipse rgb = mkEllipse (EFill rgb) NoLink -instance Ellipse (Gray Double,DrawEllipse) where - ellipse (c,dp) = mkEllipse (psColour c) dp +instance Ellipse StrokeAttr where + ellipse x = mkEllipse (EStroke [x] black) NoLink +instance Ellipse [StrokeAttr] where + ellipse xs = mkEllipse (EStroke xs black) NoLink -instance Ellipse (RGB3 Double,StrokeAttr) where - ellipse (c,x) = mkEllipse (psColour c) (EStroke [x]) +instance Ellipse XLink where + ellipse xlink = mkEllipse (EFill black) xlink -instance Ellipse (HSB3 Double,StrokeAttr) where - ellipse (c,x) = mkEllipse (psColour c) (EStroke [x]) +instance Ellipse (RGBi,StrokeAttr) where + ellipse (rgb,x) = mkEllipse (EStroke [x] rgb) NoLink -instance Ellipse (Gray Double,StrokeAttr) where - ellipse (c,x) = mkEllipse (psColour c) (EStroke [x]) +instance Ellipse (RGBi,[StrokeAttr]) where + ellipse (rgb,xs) = mkEllipse (EStroke xs rgb) NoLink -instance Ellipse (RGB3 Double,[StrokeAttr]) where - ellipse (c,xs) = mkEllipse (psColour c) (EStroke xs) +instance Ellipse (RGBi,XLink) where + ellipse (rgb,xlink) = mkEllipse (EFill rgb) xlink -instance Ellipse (HSB3 Double,[StrokeAttr]) where - ellipse (c,xs) = mkEllipse (psColour c) (EStroke xs) +instance Ellipse (StrokeAttr,XLink) where + ellipse (x,xlink) = mkEllipse (EStroke [x] black) xlink -instance Ellipse (Gray Double,[StrokeAttr]) where - ellipse (c,xs) = mkEllipse (psColour c) (EStroke xs) +instance Ellipse ([StrokeAttr],XLink) where + ellipse (xs,xlink) = mkEllipse (EStroke xs black) xlink +instance Ellipse (RGBi,[StrokeAttr],XLink) where + ellipse (rgb,xs,xlink) = mkEllipse (EStroke xs rgb) xlink -- | Create a black, filled ellipse. zellipse :: Num u => u -> u -> Point2 u -> Primitive u -zellipse = uncurry mkEllipse ellipseDefault - +zellipse hw hh pt = mkEllipse ellipseDefault NoLink hw hh pt -------------------------------------------------------------------------------- - --- Operations on pictures and paths - - - +-- Operations -- | Extend the bounding box of a picture. -- @@ -487,7 +422,7 @@ -- This function cannot be used to shrink a boundary. -- extendBoundary :: (Num u, Ord u) => u -> u -> Picture u -> Picture u -extendBoundary x y = mapLocale (\(fr,bb) -> (fr, extBB (posve x) (posve y) bb)) +extendBoundary x y = mapLocale (\(bb,xs) -> (extBB (posve x) (posve y) bb, xs)) where extBB x' y' (BBox (P2 x0 y0) (P2 x1 y1)) = BBox pt1 pt2 where pt1 = P2 (x0-x') (y0-y') @@ -507,16 +442,16 @@ -- neither picture will be moved. -- picOver :: (Num u, Ord u) => Picture u -> Picture u -> Picture u -a `picOver` b = Picture (ortho zeroPt, bb) (cons a $ one b) +a `picOver` b = Picture (bb,[]) (cons a $ one b) where - bb = union (boundary a) (boundary b) + bb = boundary a `append` 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 +picMoveBy :: (Num u, Ord u) => Picture u -> Vec2 u -> Picture u +p `picMoveBy` (V2 dx dy) = translate dx dy p -- | 'picBeside' : @ picture -> picture -> picture @ -- @@ -526,16 +461,27 @@ 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) + (P2 x1 _) = ur_corner $ boundary a + (P2 x2 _) = ll_corner $ boundary b + v = hvec $ x1 - x2 +-------------------------------------------------------------------------------- +-- Illustrating pictures and primitives + +-- | Print the syntax tree of a Picture to the console. +-- +printPicture :: (Num u, PSUnit u) => Picture u -> IO () +printPicture pic = putStrLn (show $ format pic) >> putStrLn [] + + -- | '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 :: (Real u, Floating u, FromPtSize u) - => DRGB -> Picture u -> Picture u -illustrateBounds rgb p = p `picOver` (frameMulti $ boundsPrims rgb p) + => RGBi -> Picture u -> Picture u +illustrateBounds rgb p = p `picOver` (frame $ boundsPrims rgb p) -- | 'illustrateBoundsPrim' : @ colour -> primitive -> picture @ @@ -546,26 +492,26 @@ -- The result will be lifted from Primitive to Picture. -- illustrateBoundsPrim :: (Real u, Floating u, FromPtSize u) - => DRGB -> Primitive u -> Picture u -illustrateBoundsPrim rgb p = frameMulti (boundsPrims rgb p ++ [p]) + => RGBi -> Primitive u -> Picture u +illustrateBoundsPrim rgb p = frame (p : boundsPrims rgb 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] + => RGBi -> 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] + (bl,br,tr,tl) = boundaryCorners $ boundary a + bbox_rect = cstroke (rgb, line_attr) $ vertexPath [bl,br,tr,tl] + bl_to_tr = ostroke (rgb, line_attr) $ vertexPath [bl,tr] + br_to_tl = ostroke (rgb, line_attr) $ vertexPath [br,tl] + line_attr = [LineCap $ CapRound, DashPattern $ Dash 0 [(1,2)]] + -- | Generate the control points illustrating the Bezier -- curves within a picture. -- @@ -577,12 +523,12 @@ -- @arc@ command. -- illustrateControlPoints :: (Real u, Floating u, FromPtSize u) - => DRGB -> Primitive u -> Picture u + => RGBi -> 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 + step (PEllipse _ _ e) = frame (prim : ellipseCtrlLines rgb e) + step (PPath _ _ p) = frame (prim : pathCtrlLines rgb p) + step _ = frame [prim] -- Genrate lines illustrating the control points of curves on -- a Path. @@ -592,15 +538,15 @@ -- -- 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 +pathCtrlLines :: (Num u, Ord u) => RGBi -> PrimPath u -> [Primitive u] +pathCtrlLines rgb (PrimPath 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]) + mkLine s e = ostroke rgb (PrimPath s [lineTo e]) -- Generate lines illustrating the control points of an @@ -610,7 +556,7 @@ -- start-point to control-point1; control-point2 to end-point -- ellipseCtrlLines :: (Real u, Floating u) - => DRGB -> PrimEllipse u -> [Primitive u] + => RGBi -> PrimEllipse u -> [Primitive u] ellipseCtrlLines rgb pe = start all_points where -- list in order: @@ -624,6 +570,41 @@ 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]) + mkLine s e = ostroke rgb (PrimPath s [lineTo e]) + + +-- | 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, Real u) + => PrimEllipse u -> [Point2 u] +ellipseControlPoints (PrimEllipse (P2 x y) hw hh ctm) = + map (disp . (new_mtrx *#)) circ + where + disp = (.+^ V2 x y) + (radius,(dx,dy)) = circleScalingProps hw hh + new_mtrx = matrixRepCTM $ scaleCTM dx dy ctm + circ = bezierCircle 1 radius (P2 0 0) + + -- subdivide the bezierCircle with 1 to get two + -- control points per quadrant. + + +-- +-- 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) diff --git a/src/Wumpus/Core/PictureInternal.hs b/src/Wumpus/Core/PictureInternal.hs --- a/src/Wumpus/Core/PictureInternal.hs +++ b/src/Wumpus/Core/PictureInternal.hs @@ -1,5 +1,4 @@ {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- @@ -8,80 +7,79 @@ -- Copyright : (c) Stephen Tetley 2009-2010 -- License : BSD3 -- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC with TypeFamilies and more +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC -- --- Internal representation of Pictures --- +-- Internal representation of Pictures. +-- -------------------------------------------------------------------------------- -module Wumpus.Core.PictureInternal - ( - -- * Data types + +module Wumpus.Core.PictureInternal + ( + Picture(..) , DPicture + , Locale + , AffineTrafo(..) + , GSUpdate(..) + , Primitive(..) , DPrimitive - , Path(..) - , DPath - , PathSegment(..) - , DPathSegment - , Label(..) - , DLabel - , PrimEllipse(..) - , DPrimEllipse - , PrimCTM - - , PathProps -- hide in Wumpus.Core export? - , LabelProps -- hide in Wumpus.Core export? - , EllipseProps -- - , DrawPath(..) -- hide in Wumpus.Core export? - , DrawEllipse(..) - , Locale - - -- * Type class - - , PSUnit(..) + , XLink(..) + , PrimPath(..) + , DPrimPath + , PathProps(..) + , PrimPathSegment(..) + , DPrimPathSegment + , PrimLabel(..) + , DPrimLabel + , LabelProps(..) + , PrimEllipse(..) + , EllipseProps(..) + , PrimCTM(..) - -- * Transformations on Primitives - , translatePrimitive - , rotatePrimitive - , scalePrimitive - , uniformScalePrimitive + , pathBoundary + , mapLocale -- * PrimCTM , identityCTM , scaleCTM + , rotateCTM , matrixRepCTM , translMatrixRepCTM - - -- * Extras - , mapLocale - , movePic - , moveLocale - , extractFrame - , repositionProperties - , ellipseControlPoints + , rotatePrimitive + , scalePrimitive + , uniformScalePrimitive + , translatePrimitive + + -- * Additional operations + , concatTrafos + , deconsMatrix + , repositionDeltas + + ) where import Wumpus.Core.AffineTrans import Wumpus.Core.BoundingBox +import Wumpus.Core.Colour import Wumpus.Core.FontSize +import Wumpus.Core.FormatCombinators import Wumpus.Core.Geometry import Wumpus.Core.GraphicsState import Wumpus.Core.OneList import Wumpus.Core.PtSize -import Wumpus.Core.TextEncodingInternal +import Wumpus.Core.TextInternal import Wumpus.Core.Utils -import Data.AffineSpace -import Data.Semigroup +import Data.AffineSpace -- package: vector-space -import Text.PrettyPrint.Leijen -- package: wl-pprint +import qualified Data.Foldable as F @@ -107,31 +105,71 @@ -- optimization to avoid generating excessive graphics state -- changes in the PostScript code. -- --- Apropos the constructors, Picture is a simple non-empty +-- Omitting some details, Picture is a simple non-empty -- leaf-labelled rose tree via: -- --- > Single (aka leaf) | Picture (OneList tree) +-- > Leaf primitives | Picture [tree] -- -- Where OneList is a variant of the standard list type that -- disallows empty lists. -- -- The additional constructors are convenience: -- --- @PicBlank@ has a bounding box but no content and is useful for --- some picture language operations (e.g. @hsep@). --- -- @Clip@ nests a picture (tree) inside a clipping path. -- +-- The @Group@ constructor allows local shared graphics state +-- updates for the SVG renderer - in some instances this can +-- improve the code size of the generated SVG. +-- +data Picture u = Leaf (Locale u) (OneList (Primitive u)) + | Picture (Locale u) (OneList (Picture u)) + | Clip (Locale u) (PrimPath u) (Picture u) + | Group (Locale u) GSUpdate (Picture u) + deriving (Show) -data Picture u = PicBlank (Locale u) - | Single (Locale u) (Primitive u) - | Picture (Locale u) (OneList (Picture u)) - | Clip (Locale u) (Path u) (Picture u) - deriving (Eq,Show) +-- | Update the graphics state for SVG rendering. +-- +-- Note - this does not change how any of the Primitives are +-- drawn, nor does it change the default colour or font style. +-- It is solely a backdoor into the SVG renderer to potential +-- allow some code size reductions. +-- +newtype GSUpdate = GSUpdate { getGSU :: GraphicsState -> GraphicsState } +instance Show GSUpdate where + show _ = "*function*" + +-- | Locale = (bounding box * current translation matrix) +-- +-- Pictures (and sub-pictures) are located frame consisting of a +-- bounding box and a translation matrix (represented as a list +-- of affine transformations). So that pictures can be arranged +-- via vertical and horizontal composition their bounding box is +-- cached. +-- +-- In Wumpus, affine transformations (scalings, rotations...) +-- transform the CTM rather than the constituent points of +-- the primitives. Changes of CTM are transmitted to PostScript +-- as @concat@ commands (and matrix transforms in SVG). +-- +-- So that picture composition is remains stable under affine +-- transformation, the corners of bounding boxes are transformed +-- pointwise when the picture is scaled, rotated etc. +-- +type Locale u = (BoundingBox u, [AffineTrafo u]) + type DPicture = Picture Double +-- | Affine transformations are represented as /syntax/ so they +-- can be manipulated easily. +-- +data AffineTrafo u = Matrix (Matrix3'3 u) + | Rotate Radian + | RotAbout Radian (Point2 u) + | Scale u u + | Translate u u + deriving (Eq,Show) -- | Wumpus\'s drawings are built from two fundamental -- primitives: paths (line segments and Bezier curves) and @@ -142,8 +180,8 @@ -- least eight curves. This is inconvenient for drawing dots -- which can otherwise be drawn with a single @arc@ command. -- --- Wumpus does not follow PostScript and employ arcs as general --- path primitives - they are used only to draw ellipses. This +-- Wumpus does not follow PostScript employing arc as a general +-- path primitive - arcs are used only to draw ellipses. This -- is because arcs do not enjoy the nice properties of Bezier -- curves, whereby the affine transformation of a Bezier curve -- can simply be achieved by the affine transformation of it\'s @@ -156,41 +194,68 @@ -- Though typically for affine transformations a Fractional -- constraint is also obliged. -- - -data Primitive u = PPath PathProps (Path u) - | PLabel LabelProps (Label u) - | PEllipse EllipseProps (PrimEllipse u) +data Primitive u = PPath PathProps XLink (PrimPath u) + | PLabel LabelProps XLink (PrimLabel u) + | PEllipse EllipseProps XLink (PrimEllipse u) deriving (Eq,Show) type DPrimitive = Primitive Double +-- | Primitives can be annotated with hyperlinks in SVG output. +-- +data XLink = NoLink + | XLinkHRef String + deriving (Eq,Show) --- | Path - start point and a list of path segments. +-- | PrimPath - start point and a list of path segments. -- -data Path u = Path (Point2 u) [PathSegment u] +data PrimPath u = PrimPath (Point2 u) [PrimPathSegment u] deriving (Eq,Show) -type DPath = Path Double +type DPrimPath = PrimPath Double --- | PathSegment - either a cubic Bezier curve or a line. --- -data PathSegment u = PCurveTo (Point2 u) (Point2 u) (Point2 u) - | PLineTo (Point2 u) +-- | PrimPathSegment - either a cubic Bezier curve or a line. +-- +data PrimPathSegment u = PCurveTo (Point2 u) (Point2 u) (Point2 u) + | PLineTo (Point2 u) deriving (Eq,Show) -type DPathSegment = PathSegment Double +type DPrimPathSegment = PrimPathSegment Double --- | Label - represented by bottom left corner and text. +-- | Note when drawn /filled/ and drawn /stroked/ the same +-- polygon will have (slightly) different size: -- -data Label u = Label - { label_bottom_left :: Point2 u - , label_text :: EncodedText - , label_ctm :: PrimCTM u +-- * A filled shape fills /within/ the boundary of the shape +-- +-- * A stroked shape draws a pen line around the boundary +-- of the shape. The actual size depends on the thickness +-- of the line (stroke width). +-- +data PathProps = CFill RGBi + | CStroke [StrokeAttr] RGBi + | OStroke [StrokeAttr] RGBi + | CFillStroke RGBi [StrokeAttr] RGBi + deriving (Eq,Show) + + +-- | Label - represented by /baseline/ left point and text. +-- +data PrimLabel u = PrimLabel + { label_baseline_left :: Point2 u + , label_text :: EncodedText + , label_ctm :: PrimCTM u } deriving (Eq,Show) -type DLabel = Label Double +type DPrimLabel = PrimLabel Double +data LabelProps = LabelProps + { label_colour :: RGBi + , label_font :: FontAttr + } + deriving (Eq,Ord,Show) + + -- Ellipse represented by center and half_width * half_height -- data PrimEllipse u = PrimEllipse @@ -201,9 +266,20 @@ } deriving (Eq,Show) -type DPrimEllipse = PrimEllipse Double +-- | Ellipses and circles are always closed. +-- +data EllipseProps = EFill RGBi + | EStroke [StrokeAttr] RGBi + -- Note - first colour fill, second colour stroke. + | EFillStroke RGBi [StrokeAttr] RGBi + deriving (Eq,Show) + + +-- Note - primitives are not considered to exist in an affine +-- space. +-- data PrimCTM u = PrimCTM { ctm_scale_x :: u , ctm_scale_y :: u @@ -212,146 +288,251 @@ deriving (Eq,Show) --- | Note when drawn /filled/ and drawn /stroked/ the same --- polygon will have (slightly) different size: --- --- * A filled shape fills /within/ the boundary of the shape --- --- * A stroked shape draws a pen line around the boundary --- of the shape. The actual size depends on the thickness --- of the line (stroke width). --- -data DrawPath = CFill | CStroke [StrokeAttr] | OStroke [StrokeAttr] - deriving (Eq,Show) +-------------------------------------------------------------------------------- +-- family instances --- | Ellipses and circles are always closed. -data DrawEllipse = EFill | EStroke [StrokeAttr] - deriving (Eq,Show) +type instance DUnit (Picture u) = u +type instance DUnit (Primitive u) = u +type instance DUnit (PrimEllipse u) = u -type PathProps = (PSRgb, DrawPath) -type LabelProps = (PSRgb, FontAttr) -type EllipseProps = (PSRgb, DrawEllipse) +-------------------------------------------------------------------------------- +-- instances --- | Locale = (current frame x bounding box) --- --- Pictures (and sub-pictures) are located within an affine frame. --- So pictures can be arranged (vertical and horizontal --- composition) their bounding box is cached. --- --- In Wumpus, affine transformations (scalings, rotations...) --- transform the frame rather than the constituent points of --- the primitives. Changes of frame are transmitted to PostScript --- as @concat@ commands (and matrix transforms in SVG) - the --- @point-in-world-coordinate@ of a point on a path is never --- calculated. --- --- So that picture composition is remains stable under affine --- transformation, the corners of bounding boxes are transformed --- pointwise when the picture is scaled, rotated etc. --- -type Locale u = (Frame2 u, BoundingBox u) +instance (Num u, PSUnit u) => Format (Picture u) where + format (Leaf m prims) = indent 2 $ vcat [ text "** Leaf-pic **" + , fmtLocale m + , fmtPrims prims ] + format (Picture m pics) = indent 2 $ vcat [ text "** Tree-pic **" + , fmtLocale m + , fmtPics pics ] + + format (Clip m path pic) = indent 2 $ vcat [ text "** Clip-path **" + , fmtLocale m + , format path + , format pic ] + format (Group m _ pic) = indent 2 $ vcat [ text "** Group **" + , fmtLocale m + , format pic ] --------------------------------------------------------------------------------- --- Pretty printing +fmtPics :: PSUnit u => OneList (Picture u) -> Doc +fmtPics ones = snd $ F.foldl' fn (0,empty) ones + where + fn (n,acc) e = (n+1, vcat [ acc, text "-- " <+> int n, format e, line]) -instance (Num u, Pretty u) => Pretty (Picture u) where - pretty (PicBlank m) = text "*BLANK*" <+> ppLocale m - pretty (Single m prim) = ppLocale m <$> indent 2 (pretty prim) - pretty (Picture m ones) = - ppLocale m <$> indent 2 (list $ toListF pretty ones) +fmtPrims :: PSUnit u => OneList (Primitive u) -> Doc +fmtPrims ones = snd $ F.foldl' fn (0,empty) ones + where + fn (n,acc) e = (n+1, vcat [ acc, text "-- leaf" <+> int n, format e, line]) - pretty (Clip m cpath p) = - text "Clip:" <+> ppLocale m <$> indent 2 (pretty cpath) - <$> indent 2 (pretty p) +fmtLocale :: (Num u, PSUnit u) => Locale u -> Doc +fmtLocale (bb,_) = format bb -ppLocale :: (Num u, Pretty u) => Locale u -> Doc -ppLocale (fr,bb) = align (ppfr <$> pretty bb) where - ppfr = if standardFrame fr then text "*std-frame*" else pretty fr +instance PSUnit u => Format (Primitive u) where + format (PPath props _ p) = + indent 2 $ vcat [ text "path:" <+> format props, format p ] -instance Pretty u => Pretty (Primitive u) where - pretty (PPath _ p) = pretty "path:" <+> pretty p - pretty (PLabel _ lbl) = pretty lbl - pretty (PEllipse _ e) = pretty e + format (PLabel props _ l) = + indent 2 $ vcat [ text "label:" <+> format props, format l ] + format (PEllipse props _ e) = + indent 2 $ vcat [ text "ellipse:" <+> format props, format e ] -instance Pretty u => Pretty (Path u) where - pretty (Path pt ps) = pretty pt <> hcat (map pretty ps) -instance Pretty u => Pretty (PathSegment u) where - pretty (PCurveTo p1 p2 p3) = text ".*" <> pretty p1 <> text ",," <> pretty p2 - <> text "*." <> pretty p3 - pretty (PLineTo pt) = text "--" <> pretty pt +instance PSUnit u => Format (PrimPath u) where + format (PrimPath pt ps) = vcat (start : map format ps) + where + start = text "start_point " <> format pt -instance Pretty u => Pretty (Label u) where - pretty (Label pt s ctm) = dquotes (pretty s) <> char '@' <> pretty pt - <+> pretty ctm +instance PSUnit u => Format (PrimPathSegment u) where + format (PCurveTo p1 p2 p3) = + text "curve_to " <> format p1 <+> format p2 <+> format p3 -instance Pretty u => Pretty (PrimEllipse u) where - pretty (PrimEllipse ctr w h ctm) = pretty "ellipse" <+> pretty ctr - <+> text "w:" <> pretty w - <+> text "h:" <> pretty h - <+> pretty ctm + format (PLineTo pt) = text "line_to " <> format pt + +instance PSUnit u => Format (PrimLabel u) where + format (PrimLabel pt s ctm) = + vcat [ dquotes (format s) + , text "baseline_left=" <> format pt + <+> text "ctm=" <> format ctm + ] + +instance PSUnit u => Format (PrimEllipse u) where + format (PrimEllipse ctr hw hh ctm) = text "center=" <> format ctr + <+> text "hw=" <> dtruncFmt hw + <+> text "hh=" <> dtruncFmt hh + <+> text "ctm=" <> format ctm -instance Pretty u => Pretty (PrimCTM u) where - pretty (PrimCTM x y ang) = - braces (pretty x <> comma <+> pretty y <> comma <+> pretty ang) +instance PSUnit u => Format (PrimCTM u) where + format (PrimCTM x y ang) = + parens (text "CTM" <+> text "sx=" <> dtruncFmt x + <+> text "sy=" <> dtruncFmt y + <+> text "ang=" <> format ang ) + +instance Format PathProps where + format (CFill rgb) = format rgb <+> text "Fill" + format (CStroke _ rgb) = format rgb <+> text "Closed-stroke" + format (OStroke _ rgb) = format rgb <+> text "Open-stroke" + format (CFillStroke f _ s) = format f <+> text "Fill" <> char '/' + <+> format s <+> text "Stroke" + + + +instance Format LabelProps where + format (LabelProps rgb attr) = format rgb + <+> text (font_name $ font_face attr) + +instance Format EllipseProps where + format (EFill rgb) = format rgb <+> text "Fill" + format (EStroke _ rgb) = format rgb <+> text "Stroke" + format (EFillStroke f _ s) = format f <+> text "Fill" <> char '/' + <+> format s <+> text "Stroke" + + + -------------------------------------------------------------------------------- --- | Paths are sensibly a Semigroup - there is no notion of --- /empty path/. +instance Boundary (Picture u) where + boundary (Leaf (bb,_) _) = bb + boundary (Picture (bb,_) _) = bb + boundary (Clip (bb,_) _ _) = bb + boundary (Group (bb,_) _ _) = bb -instance Semigroup (Path u) where - Path st xs `append` Path st' xs' = Path st (xs ++ (PLineTo st' : xs')) +instance (Real u, Floating u, FromPtSize u) => Boundary (Primitive u) where + boundary (PPath _ _ p) = pathBoundary p + boundary (PLabel a _ l) = labelBoundary (label_font a) l + boundary (PEllipse _ _ e) = ellipseBoundary e -instance Pointwise (Path u) where - type Pt (Path u) = Point2 u - pointwise f (Path st xs) = Path (f st) (map (pointwise f) xs) -instance Pointwise (PathSegment u) where - type Pt (PathSegment u) = Point2 u - pointwise f (PLineTo p) = PLineTo (f p) - pointwise f (PCurveTo p1 p2 p3) = PCurveTo (f p1) (f p2) (f p3) - +pathBoundary :: Ord u => PrimPath u -> BoundingBox u +pathBoundary (PrimPath st xs) = step (st,st) xs + where + step (lo,hi) [] = BBox lo hi + step (lo,hi) (PLineTo p1:rest) = step (lo2 lo p1, hi2 hi p1) rest + step (lo,hi) (PCurveTo p1 p2 p3:rest) = let lo' = lo4 lo p1 p2 p3 + hi' = hi4 hi p1 p2 p3 + in step (lo',hi') rest + lo2 (P2 x1 y1) (P2 x2 y2) = P2 (min x1 x2) (min y1 y2) + hi2 (P2 x1 y1) (P2 x2 y2) = P2 (max x1 x2) (max y1 y2) + + lo4 (P2 x1 y1) (P2 x2 y2) (P2 x3 y3) (P2 x4 y4) = + P2 (min x1 $ min x2 $ min x3 x4) (min y1 $ min y2 $ min y3 y4) + + hi4 (P2 x1 y1) (P2 x2 y2) (P2 x3 y3) (P2 x4 y4) = + P2 (max x1 $ max x2 $ max x3 x4) (max y1 $ max y2 $ max y3 y4) + + + +labelBoundary :: (Floating u, Real u, FromPtSize u) + => FontAttr -> PrimLabel u -> BoundingBox u +labelBoundary attr (PrimLabel (P2 x y) xs ctm) = + retraceBoundary (disp . (m33 *#)) untraf_bbox + where + disp = (.+^ V2 x y) + m33 = matrixRepCTM ctm + untraf_bbox = textBounds (font_size attr) zeroPt char_count + char_count = textLength xs + + + +-- | Ellipse bbox is the bounding rectangle, rotated as necessary +-- then retraced. +-- +ellipseBoundary :: (Real u, Floating u) => PrimEllipse u -> BoundingBox u +ellipseBoundary (PrimEllipse pt hw0 hh0 (PrimCTM sx sy theta)) = + traceBoundary $ applyIf (theta /= 0) (map (rotm *#)) [ll,lr,ur,ul] + where + hw = hw0 * sx + hh = hh0 * sy + ll = pt .+^ V2 (-hw) (-hh) + lr = pt .+^ V2 hw (-hh) + ur = pt .+^ V2 hw hh + ul = pt .+^ V2 (-hw) hh + rotm = rotationMatrix theta + + + -------------------------------------------------------------------------------- --- Affine trans instances +-- Affine transformations -type instance DUnit (Picture u) = u -type instance DUnit (Primitive u) = u -type instance DUnit (Path u) = u -type instance DUnit (PrimEllipse u) = u +-- Note YRange remains constant (as do the actually points +-- within the primitives). +-- +-- TO DO - this is potentially wrong... + instance (Num u, Ord u) => Transform (Picture u) where - transform ctm pic = trafoPicture (transform ctm) (transform ctm) pic + transform mtrx = + mapLocale $ \(bb,xs) -> (transform mtrx bb, Matrix mtrx:xs) +instance (Real u, Floating u) => Rotate (Picture u) where + rotate theta = + mapLocale $ \(bb,xs) -> (rotate theta bb, Rotate theta:xs) -instance (Floating u, Real u) => Rotate (Picture u) where - rotate = rotatePicture -instance (Floating u, Real u) => RotateAbout (Picture u) where - rotateAbout = rotatePictureAbout +instance (Real u, Floating u) => RotateAbout (Picture u) where + rotateAbout theta pt = + mapLocale $ \(bb,xs) -> (rotateAbout theta pt bb, RotAbout theta pt:xs) instance (Num u, Ord u) => Scale (Picture u) where - scale = scalePicture + scale sx sy = + mapLocale $ \(bb,xs) -> (scale sx sy bb, Scale sx sy : xs) instance (Num u, Ord u) => Translate (Picture u) where - translate = translatePicture + translate dx dy = + mapLocale $ \(bb,xs) -> (translate dx dy bb, Translate dx dy:xs) +mapLocale :: (Locale u -> Locale u) -> Picture u -> Picture u +mapLocale f (Leaf lc ones) = Leaf (f lc) ones +mapLocale f (Picture lc ones) = Picture (f lc) ones +mapLocale f (Clip lc pp pic) = Clip (f lc) pp pic +mapLocale f (Group lc upd pic) = Group (f lc) upd pic +-------------------------------------------------------------------------------- +-- Manipulating the PrimCTM --- Primitives +identityCTM :: Num u => PrimCTM u +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 sx sy ang) = PrimCTM (x1*sx) (y1*sy) ang + +rotateCTM :: Radian -> PrimCTM u -> PrimCTM u +rotateCTM ang1 (PrimCTM sx sy ang) = PrimCTM sx sy (circularModulo $ ang1+ang) + +matrixRepCTM :: (Floating u, Real u) => PrimCTM u -> Matrix3'3 u +matrixRepCTM (PrimCTM sx sy ang) = + rotationMatrix (circularModulo ang) * scalingMatrix sx sy + + +-- Note - the order of combining a translation (i.e. the +-- location of a point) and the CTM is crucial as matrix +-- multiplication is not commutative. +-- +-- This function encapsulates the correct order. +-- +translMatrixRepCTM :: (Floating u, Real u) + => u -> u -> PrimCTM u -> Matrix3'3 u +translMatrixRepCTM x y ctm = translationMatrix x y * matrixRepCTM ctm + + + +-------------------------------------------------------------------------------- +-- Transform primitives + + -- | Rotate a Primitive. -- -- Note - this is not an affine transformation as Primitives are @@ -370,9 +551,9 @@ -- rotatePrimitive :: (Real u, Floating u) => Radian -> Primitive u -> Primitive u -rotatePrimitive ang (PPath a path) = PPath a $ rotatePath ang path -rotatePrimitive ang (PLabel a lbl) = PLabel a $ rotateLabel ang lbl -rotatePrimitive ang (PEllipse a ell) = PEllipse a $ rotateEllipse ang ell +rotatePrimitive ang (PPath a xl path) = PPath a xl $ rotatePath ang path +rotatePrimitive ang (PLabel a xl lbl) = PLabel a xl $ rotateLabel ang lbl +rotatePrimitive ang (PEllipse a xl ell) = PEllipse a xl $ rotateEllipse ang ell -- | Scale a Primitive. @@ -398,9 +579,9 @@ -- \"cost-free\". -- scalePrimitive :: Num u => u -> u -> Primitive u -> Primitive u -scalePrimitive x y (PPath a path) = PPath a $ scalePath x y path -scalePrimitive x y (PLabel a lbl) = PLabel a $ scaleLabel x y lbl -scalePrimitive x y (PEllipse a ell) = PEllipse a $ scaleEllipse x y ell +scalePrimitive x y (PPath a xl path) = PPath a xl $ scalePath x y path +scalePrimitive x y (PLabel a xl lbl) = PLabel a xl $ scaleLabel x y lbl +scalePrimitive x y (PEllipse a xl ell) = PEllipse a xl $ scaleEllipse x y ell -- | Apply a uniform scale to a Primitive. -- @@ -418,61 +599,17 @@ -- the generated output. -- translatePrimitive :: Num u => u -> u -> Primitive u -> Primitive u -translatePrimitive x y (PPath a path) = PPath a $ translatePath x y path -translatePrimitive x y (PLabel a lbl) = PLabel a $ translateLabel x y lbl -translatePrimitive x y (PEllipse a ell) = PEllipse a $ translateEllipse x y ell - - --------------------------------------------------------------------------------- - --- Helpers for the affine transformations - -rotatePicture :: (Real u, Floating u) => Radian -> Picture u -> Picture u -rotatePicture ang = trafoPicture (rotate ang) (rotate ang) - -rotatePictureAbout :: (Real u, Floating u) - => Radian -> Point2 u -> Picture u -> Picture u -rotatePictureAbout ang pt = - trafoPicture (rotateAbout ang pt) (rotateAbout ang pt) - -scalePicture :: (Num u, Ord u) => u -> u -> Picture u -> Picture u -scalePicture x y = trafoPicture (scale x y) (scale x y) +translatePrimitive x y (PPath a xl path) = + PPath a xl $ translatePath x y path -translatePicture :: (Num u, Ord u) => u -> u -> Picture u -> Picture u -translatePicture x y = trafoPicture (translate x y) (translate x y) +translatePrimitive x y (PLabel a xl lbl) = + PLabel a xl $ translateLabel x y lbl --- TODO - the nameing for these functions is confusing now that --- I've added a Transform typeclass. --- --- Look to unifying the naming scheme in someway. --- -trafoPicture :: (Num u, Ord u) - => (Point2 u -> Point2 u) - -> (Vec2 u -> Vec2 u) - -> Picture u - -> Picture u -trafoPicture fp fv = - mapLocale $ \(frm,bb) -> (trafoFrame fp fv frm, trafoBBox fp bb) +translatePrimitive x y (PEllipse a xl ell) = + PEllipse a xl $ translateEllipse x y ell -trafoFrame :: Num u - => (Point2 u -> Point2 u) - -> (Vec2 u -> Vec2 u) - -> Frame2 u - -> Frame2 u -trafoFrame fp fv (Frame2 e0 e1 o) = Frame2 (fv e0) (fv e1) (fp o) - - --- Bounding boxes need recalculating after a transformation. --- For instance after a reflection in the y-axis br becomes bl. -trafoBBox :: (Num u, Ord u) - => (Point2 u -> Point2 u) -> BoundingBox u -> BoundingBox u -trafoBBox fp bb = traceBoundary $ map fp $ [bl,br,tl,tr] - where - (bl,br,tr,tl) = corners bb - - -------------------------------------------------------------------------------- -- Paths @@ -487,9 +624,10 @@ -- (0,0), but don\'t not basis vectors) so manipulating them -- cannot follow the standard affine interpretation. -- -rotatePath :: (Real u, Floating u) => Radian -> Path u -> Path u -rotatePath ang (Path start xs) = - Path start $ map (pointwise (rotateAbout ang start)) xs +rotatePath :: (Real u, Floating u) => Radian -> PrimPath u -> PrimPath u +rotatePath ang (PrimPath start xs) = PrimPath start $ map (mapSeg fn) xs + where + fn = rotateAbout ang start -- scalePath - scale the vector between each point and the start -- point. @@ -499,45 +637,24 @@ -- are lifted to Pictures their manipulation cannot correspond -- to the standard affine manipulations. -- -scalePath :: Num u => u -> u -> Path u -> Path u -scalePath x y (Path pt xs) = Path pt (map (pointwise fn) xs) +scalePath :: Num u => u -> u -> PrimPath u -> PrimPath u +scalePath x y (PrimPath pt xs) = PrimPath pt $ map (mapSeg fn) xs where fn p1 = let dif = p1 .-. pt in pt .+^ (scale x y $ dif) -- translatePath - move all points in the path by the supplied -- x and y values. -- -translatePath :: Num u => u -> u -> Path u -> Path u -translatePath x y = pointwise (translate x y) - +translatePath :: Num u => u -> u -> PrimPath u -> PrimPath u +translatePath x y = mapPath (translate x y) --------------------------------------------------------------------------------- --- Manipulating the Primitive CTM - -identityCTM :: Num u => PrimCTM u -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 (circularModulo $ ang1+ang) - -matrixRepCTM :: (Floating u, Real u) => PrimCTM u -> Matrix3'3 u -matrixRepCTM (PrimCTM x y ang) = - rotationMatrix (circularModulo ang) * scalingMatrix x y - +mapPath :: (Point2 u -> Point2 u) -> PrimPath u -> PrimPath u +mapPath fn (PrimPath st xs) = PrimPath (fn st) (map (mapSeg fn) xs) --- Note - the order of combining a translation (i.e. the --- location of a point) and the CTM is crucial as matrix --- multiplication is not commutative. --- --- The function encapsulated the correct order. --- -translMatrixRepCTM :: (Floating u, Real u) - => u -> u -> PrimCTM u -> Matrix3'3 u -translMatrixRepCTM x y ctm = translationMatrix x y * matrixRepCTM ctm +mapSeg :: (Point2 u -> Point2 u) -> PrimPathSegment u -> PrimPathSegment u +mapSeg fn (PLineTo p) = PLineTo (fn p) +mapSeg fn (PCurveTo p1 p2 p3) = PCurveTo (fn p1) (fn p2) (fn p3) -------------------------------------------------------------------------------- -- Labels @@ -547,17 +664,17 @@ -- Rotations on a (primitive) Label are interpreted as rotating -- about the bottom-left corner. -- -rotateLabel :: Radian -> Label u -> Label u -rotateLabel ang (Label pt txt ctm) = Label pt txt (rotateCTM ang ctm) +rotateLabel :: Radian -> PrimLabel u -> PrimLabel u +rotateLabel ang (PrimLabel pt txt ctm) = PrimLabel pt txt (rotateCTM ang ctm) -scaleLabel :: Num u => u -> u -> Label u -> Label u -scaleLabel x y (Label pt txt ctm) = Label pt txt (scaleCTM x y ctm) +scaleLabel :: Num u => u -> u -> PrimLabel u -> PrimLabel u +scaleLabel x y (PrimLabel pt txt ctm) = PrimLabel pt txt (scaleCTM x y ctm) -- Change the bottom-left corner. -- -translateLabel :: Num u => u -> u -> Label u -> Label u -translateLabel x y (Label pt txt ctm) = Label (translate x y pt) txt ctm +translateLabel :: Num u => u -> u -> PrimLabel u -> PrimLabel u +translateLabel x y (PrimLabel pt txt ctm) = PrimLabel (translate x y pt) txt ctm -------------------------------------------------------------------------------- -- Ellipse @@ -580,153 +697,56 @@ 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) = traceBoundary $ st : foldr f [] xs where - f (PLineTo p1) acc = p1 : acc - f (PCurveTo p1 p2 p3) acc = p1 : p2 : p3 : acc +-------------------------------------------------------------------------------- +-- Additional operations --- Note - this will calculate an approximate bounding box for --- text. - -instance (Real u, Floating u, FromPtSize u) => Boundary (Primitive u) where - boundary (PPath _ p) = boundary p - boundary (PLabel (_,a) l) = primLabelBoundary a l - boundary (PEllipse _ e) = boundary e +concatTrafos :: (Floating u, Real u) => [AffineTrafo u] -> Matrix3'3 u +concatTrafos = foldr (\e ac -> matrixRepr e * ac) identityMatrix +matrixRepr :: (Floating u, Real u) => AffineTrafo u -> Matrix3'3 u +matrixRepr (Matrix mtrx) = mtrx +matrixRepr (Rotate theta) = rotationMatrix theta +matrixRepr (RotAbout theta pt) = originatedRotationMatrix theta pt +matrixRepr (Scale sx sy) = scalingMatrix sx sy +matrixRepr (Translate dx dy) = translationMatrix dx dy -primLabelBoundary :: (Floating u, Real u, FromPtSize u) - => FontAttr -> Label u -> BoundingBox u -primLabelBoundary attr (Label (P2 x y) xs ctm) = - retraceBoundary (disp . (m33 *#)) untraf_bbox - where - disp = (.+^ V2 x y) - m33 = matrixRepCTM ctm - untraf_bbox = textBounds (font_size attr) zeroPt char_count - char_count = textLength xs - -instance (Real u, Floating 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 :: (Real u, Floating u) => PrimEllipse u -> BoundingBox u -ellipseBoundary = traceBoundary . ellipseControlPoints - --- PROBLEM: --- Currently a rotated circle has a different BBox to a --- non-rotated circle, because of how tangents are selected... +-- | Destructor for Matrix3'3. -- --- This is the same as a diamond having a larger BBox --- than a square with same side-length --- - --------------------------------------------------------------------------------- +-- Pattern matching on 6-tuple may be more convenient than using +-- the Matrix3'3 directly. -- - +-- > (M3'3 e0x e1x ox +-- > e0y e1y oy +-- > _ _ _ ) = (e0x,e0y, e1x,e1y, ox,oy) +-- +deconsMatrix :: Matrix3'3 u -> (u,u,u,u,u,u) +deconsMatrix (M3'3 e0x e1x ox + e0y e1y oy + _ _ _ ) = (e0x,e0y, e1x,e1y, ox,oy) -mapLocale :: (Locale u -> Locale u) -> Picture u -> Picture u -mapLocale f (PicBlank m) = PicBlank (f m) -mapLocale f (Single m prim) = Single (f m) prim -mapLocale f (Picture m ones) = Picture (f m) ones -mapLocale f (Clip m x p) = Clip (f m) x p - - -movePic :: Num u => Vec2 u -> Picture u -> Picture u -movePic v = mapLocale (moveLocale v) - - -moveLocale :: Num u => Vec2 u -> Locale u -> Locale u -moveLocale v (fr,bb) = (displaceOrigin v fr, pointwise (.+^ v) bb) - --------------------------------------------------------------------------------- - - --- | Should this really be public? -extractFrame :: Num u => Picture u -> Frame2 u -extractFrame (PicBlank (fr,_)) = fr -extractFrame (Single (fr,_) _) = fr -extractFrame (Picture (fr,_) _) = fr -extractFrame (Clip (fr,_) _ _) = fr - - --- This needs is for PostScript and SVG output - it should be --- hidden in the export list of Wumpus.Core - - -- If a picture has coordinates smaller than (P2 4 4) then it --- needs repositioning before it is drawn to PostSCript or SVG. +-- needs repositioning before it is drawn to PostScript or SVG. -- -- (P2 4 4) gives a 4 pt margin - maybe it sould be (0,0) or -- user defined. -- -repositionProperties :: (Num u, Ord u) - => Picture u -> (BoundingBox u, Maybe (Vec2 u)) -repositionProperties = fn . boundary where - fn bb@(BBox (P2 llx lly) (P2 urx ury)) - | llx < 4 || lly < 4 = (BBox ll ur, Just $ V2 x y) - | otherwise = (bb, Nothing) - where - x = 4 - llx - y = 4 - lly - ll = P2 (llx+x) (lly+y) - ur = P2 (urx+x) (ury+y) - - --- | 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, Real u) - => PrimEllipse u -> [Point2 u] -ellipseControlPoints (PrimEllipse (P2 x y) hw hh ctm) = - map (disp . (new_mtrx *#)) circ - where - disp = (.+^ V2 x y) - (radius,(dx,dy)) = circleScalingProps hw hh - new_mtrx = matrixRepCTM $ scaleCTM dx dy ctm - circ = bezierCircle 1 radius (P2 0 0) - - -- subdivide the bezierCircle with 1 to get two - -- control points per quadrant. - - --- --- 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)) +repositionDeltas :: (Num u, Ord u) + => Picture u -> (BoundingBox u, Maybe (Vec2 u)) +repositionDeltas = step . boundary 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) - - + step bb@(BBox (P2 llx lly) (P2 urx ury)) + | llx < 4 || lly < 4 = (BBox ll ur, Just $ V2 x y) + | otherwise = (bb, Nothing) + where + x = 4 - llx + y = 4 - lly + ll = P2 (llx+x) (lly+y) + ur = P2 (urx+x) (ury+y) diff --git a/src/Wumpus/Core/PostScript.hs b/src/Wumpus/Core/PostScript.hs deleted file mode 100644 --- a/src/Wumpus/Core/PostScript.hs +++ /dev/null @@ -1,544 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Core.PostScript --- Copyright : (c) Stephen Tetley 2009-2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC with TypeFamilies and more --- --- PostScript generation via a Writer monad. --- --- PostScript is emitted line by line - there is no abstract --- syntax tree representing PostScript. So we use a writer --- monad. ---- --------------------------------------------------------------------------------- - - -module Wumpus.Core.PostScript - ( - -- * Types - PostScript - , WumpusM - - , runWumpus - - -- * Escape sepcial characters - , escapeStringPS - - -- * Deltas - , deltaFontAttr - , deltaRgbColour - - , deltaStrokeWidth - , deltaMiterLimit - , deltaLineCap - , deltaLineJoin - , deltaDashPattern - - -- * Emit PostScript - , ps_comment - - , ps_gsave - , ps_grestore - , ps_setlinewidth - , ps_setlinecap - , ps_setlinejoin - , ps_setmiterlimit - , ps_setdash - , ps_setgray - , ps_setrgbcolor - , ps_sethsbcolor - , ps_translate - , ps_scale - , ps_concat - , ps_newpath - , ps_moveto - , ps_rmoveto - , ps_lineto - , ps_rlineto - , ps_arc - , ps_arcn - , ps_curveto - , ps_closepath - , ps_clip - , ps_fill - , ps_stroke - , ps_showpage - , ps_findfont - , ps_scalefont - , ps_setfont - , ps_show - , ps_glyphshow - , bang_PS - , bang_EPS - , dsc_comment - , dsc_BoundingBox - , dsc_CreationDate - , dsc_Pages - , dsc_Page - , dsc_EndComments - , dsc_EOF - - ) where - -import Wumpus.Core.Colour -import Wumpus.Core.GraphicsState -import Wumpus.Core.TextEncoder -import Wumpus.Core.Utils - - -import MonadLib - -import Data.List ( foldl' ) - - --- Graphics state for PostScript Rendering --- --- Values with no default value (e.g. font) in the graphics --- state of the PostScript interpreter (not Wumpus\'s renderer) --- are Maybes. --- --- The graphics state is considered successive - all elements --- have a colour and all text labels have a font. So during --- processing there are two situations: - --- (1) If font or colour is the same as the last no state --- change needs to be printed. --- --- (2) If the font or colour changes the update needs to be --- printed, but as the next element always has a colour (and a --- font if it is a label), no @undo@ needs to be printed. --- --- This contrasts with the behaviour for stroke attributes --- which needs @undo@. - -data PostScriptGS = PostScriptGS { - gs_font :: Maybe FontAttr, - gs_rgb_colour :: DRGB - } - deriving (Eq,Show) - - - --- | Stroke properties do not have to be fully specified in --- Wumpus\'s picture types - i.e. a Path might have it\'s stroke --- width set but nothing else. --- --- If a path changes any of the stroke properties, it --- immediately undoes the changes after drawing, returning the --- the stroke values to their PostScript defaults. --- --- This means Wumpus doesn't have to carry a nested environment --- around as it renders to PostScript. As stroke properties can --- only be assigned to leaves in the picture tree, a nested --- environment wouldn\'t really be an ideal fit anyway. - - -gs_stroke_width :: Double -gs_stroke_width = 1.0 - -gs_miter_limit :: Double -gs_miter_limit = 10.0 - -gs_line_cap :: LineCap -gs_line_cap = CapSquare - -gs_line_join :: LineJoin -gs_line_join = JoinMiter - -gs_dash_pattern :: DashPattern -gs_dash_pattern = Solid - - - -type PostScript = String - -type PsOutput = H Char - -type WumpusM a = PsT Id a - - -newtype PsT m a = PsT { - unPsT :: StateT PostScriptGS - (WriterT PsOutput (ReaderT TextEncoder m)) a } - -gs_init :: PostScriptGS -gs_init = PostScriptGS { gs_font = Nothing - , gs_rgb_colour = black - } - - -runPsT :: Monad m - => TextEncoder -> PsT m a -> m ((a,PostScriptGS),PsOutput) -runPsT i m = runReaderT i $ runWriterT $ runStateT gs_init $ unPsT m - -instance Monad m => Functor (PsT m) where - fmap f (PsT mf) = PsT $ fmap f mf - -instance Monad m => Monad (PsT m) where - return a = PsT $ return a - ma >>= f = PsT $ unPsT ma >>= unPsT . f - -instance Monad m => WriterM (PsT m) PsOutput where - put = PsT . put - -instance Monad m => ReaderM (PsT m) TextEncoder where - ask = PsT $ ask - -instance Monad m => StateM (PsT m) PostScriptGS where - set = PsT . set - get = PsT $ get - -instance MonadT PsT where - lift = PsT . lift . lift . lift - - -pstId :: TextEncoder -> PsT Id a -> ((a,PostScriptGS),PsOutput) -pstId = runId `oo` runPsT - --- | Drop state and result, take the Writer trace. -runWumpus :: TextEncoder -> WumpusM a -> String -runWumpus = (toListH . snd) `oo` pstId - --------------------------------------------------------------------------------- --- Escape special chars - --- | Escape these characters: --- --- > \\ - (, ), <, >, [, ], {, }, /, and % --- -escapeStringPS :: String -> String -escapeStringPS = foldr f "" where - f c ss | c `elem` ps_special = '\\' : c : ss - | otherwise = c : ss - -ps_special :: [Char] -ps_special = "\\()<>[]{}/%" - - --------------------------------------------------------------------------------- --- "Deltas" of the graphics state - -deltaFontAttr :: FontAttr -> WumpusM (Maybe FontAttr) -deltaFontAttr new = get >>= maybe update diff . gs_font - where - update :: WumpusM (Maybe FontAttr) - update = sets_ (\s -> s { gs_font = Just new }) >> return (Just new) - - diff :: FontAttr -> WumpusM (Maybe FontAttr) - diff old | old == new = return Nothing - | otherwise = update - - -deltaRgbColour :: DRGB -> WumpusM (Maybe DRGB) -deltaRgbColour new = get >>= diff . gs_rgb_colour - where - diff :: DRGB -> WumpusM (Maybe DRGB) - diff old | old == new = return Nothing - | otherwise = do { sets_ (\s -> s { gs_rgb_colour = new }) - ; return (Just new) - } - - -deltaStrokeWidth :: Double -> Maybe (Double,Double) -deltaStrokeWidth n - | n == gs_stroke_width = Nothing - | otherwise = Just (n,gs_stroke_width) - -deltaMiterLimit :: Double -> Maybe (Double,Double) -deltaMiterLimit n - | n == gs_miter_limit = Nothing - | otherwise = Just (n,gs_miter_limit) - - -deltaLineCap :: LineCap -> Maybe (LineCap,LineCap) -deltaLineCap lc - | lc == gs_line_cap = Nothing - | otherwise = Just (lc,gs_line_cap) - -deltaLineJoin :: LineJoin -> Maybe (LineJoin,LineJoin) -deltaLineJoin lj - | lj == gs_line_join = Nothing - | otherwise = Just (lj,gs_line_join) - -deltaDashPattern :: DashPattern -> Maybe (DashPattern,DashPattern) -deltaDashPattern p - | p == gs_dash_pattern = Nothing - | otherwise = Just (p,gs_dash_pattern) - - - --------------------------------------------------------------------------------- --- writer monad helpers - -tell :: WriterM m i => i -> m () -tell s = puts ((),s) - -writeChar :: WriterM m PsOutput => Char -> m () -writeChar = tell . showChar - - -write :: WriterM m PsOutput => String -> m () -write = tell . showString - - -writeln :: WriterM m PsOutput => String -> m () -writeln s = write s >> writeChar '\n' - - -writeArg :: WriterM m PsOutput => String -> m () -writeArg s = write s >> writeChar ' ' - - - - -type Command = String - -command :: Command -> [String] -> WumpusM () -command cmd xs = mapM_ writeArg xs >> writeln cmd - - - -showArray :: (a -> ShowS) -> [a] -> String -showArray _ [] = "[ ]" -showArray f (x:xs) = sfun "]" - where - sfun = foldl' (\a e -> a . (' ':) . f e) (('[':) . f x) xs - - - --- | @ %% ... @ -ps_comment :: String -> WumpusM () -ps_comment s = write "%% " >> writeln s - --------------------------------------------------------------------------------- --- graphics state operators - --- | @ gsave @ -ps_gsave :: WumpusM () -ps_gsave = command "gsave" [] - --- | @ grestore @ -ps_grestore :: WumpusM () -ps_grestore = command "grestore" [] - --- | @ ... setlinewidth @ -ps_setlinewidth :: PSUnit u => u -> WumpusM () -ps_setlinewidth = command "setlinewidth" . return . dtrunc - --- | @ ... setlinecap @ -ps_setlinecap :: LineCap -> WumpusM () -ps_setlinecap = command "setlinecap" . return . show . fromEnum - --- | @ ... setlinejoin @ -ps_setlinejoin :: LineJoin -> WumpusM () -ps_setlinejoin = command "setlinejoin" . return . show . fromEnum - --- | @ ... setmiterlimit @ -ps_setmiterlimit :: PSUnit u => u -> WumpusM () -ps_setmiterlimit = command "setmiterlimit" . return . dtrunc - --- | @ [... ...] ... setdash @ -ps_setdash :: DashPattern -> WumpusM () -ps_setdash Solid = command "setdash" ["[]", "0"] -ps_setdash (Dash n pairs) = command "setdash" [showArray shows arr, show n] - where - arr = foldr (\(x,y) a -> x:y:a) [] pairs - --- | @ ... setgray @ -ps_setgray :: PSUnit u => u -> WumpusM () -ps_setgray = command "setgray" . return . dtrunc - --- | @ ... ... ... setrgbcolor @ -ps_setrgbcolor :: PSUnit u => u -> u -> u -> WumpusM () -ps_setrgbcolor r g b = command "setrgbcolor" $ map dtrunc [r,g,b] - --- | @ ... ... ... sethsbcolor @ -ps_sethsbcolor :: PSUnit u => u -> u -> u -> WumpusM () -ps_sethsbcolor h s b = command "sethsbcolor" $ map dtrunc [h,s,b] - - --------------------------------------------------------------------------------- --- coordinate system and matrix operators - --- | @ ... ... translate @ -ps_translate :: PSUnit u => u -> u -> WumpusM () -ps_translate tx ty = do - command "translate" $ map dtrunc [tx,ty] - --- | @ ... ... scale @ -ps_scale :: PSUnit u => u -> u -> WumpusM () -ps_scale tx ty = do - command "scale" $ map dtrunc [tx,ty] - - --- Do not use setmatrix for changing the CTM use concat... - --- | @ [... ... ... ... ... ...] concat @ -ps_concat :: PSUnit u => CTM u -> WumpusM () -ps_concat (CTM a b c d e f) = command "concat" [mat] where - mat = showArray ((++) . dtrunc) [a,b,c,d,e,f] - - --------------------------------------------------------------------------------- --- Path construction operators - --- | @ newpath @ -ps_newpath :: WumpusM () -ps_newpath = command "newpath" [] - - --- Note - it is preferable to show doubles as 0.0 rather than 0. --- In PostScript the coercion from int to float is apparently --- quite expensive. - --- | @ ... ... moveto @ -ps_moveto :: PSUnit u => u -> u -> WumpusM () -ps_moveto x y = command "moveto" [dtrunc x, dtrunc y] - --- | @ ... ... rmoveto @ -ps_rmoveto :: PSUnit u => u -> u -> WumpusM () -ps_rmoveto x y = command "rmoveto" [dtrunc x, dtrunc y] - --- | @ ... ... lineto @ -ps_lineto :: PSUnit u => u -> u -> WumpusM () -ps_lineto x y = command "lineto" [dtrunc x, dtrunc y] - --- | @ ... ... rlineto @ -ps_rlineto :: PSUnit u => u -> u -> WumpusM () -ps_rlineto x y = command "rlineto" [dtrunc x, dtrunc y] - --- | @ ... ... ... ... ... arc @ -ps_arc :: PSUnit u => u -> u -> u -> u -> u -> WumpusM () -ps_arc x y r ang1 ang2 = - command "arc" $ map dtrunc [x,y,r,ang1,ang2] - --- | @ ... ... ... ... ... arcn @ -ps_arcn :: PSUnit u => u -> u -> u -> u -> u -> WumpusM () -ps_arcn x y r ang1 ang2 = - command "arcn" $ map dtrunc [x,y,r,ang1,ang2] - --- | @ ... ... ... ... ... ... curveto @ -ps_curveto :: PSUnit u => u -> u -> u -> u -> u -> u -> WumpusM () -ps_curveto x1 y1 x2 y2 x3 y3 = - command "curveto" $ map dtrunc [x1,y1, x2,y2, x3,y3] - --- | @ closepath @ -ps_closepath :: WumpusM () -ps_closepath = command "closepath" [] - --- | @ clip @ -ps_clip :: WumpusM () -ps_clip = command "clip" [] - --------------------------------------------------------------------------------- --- painting operators - --- | @ fill @ -ps_fill :: WumpusM () -ps_fill = command "fill" [] - --- | @ stroke @ -ps_stroke :: WumpusM () -ps_stroke = command "stroke" [] - - --------------------------------------------------------------------------------- --- Output operators - --- | @ showpage @ -ps_showpage :: WumpusM () -ps_showpage = command "showpage" [] - - - --------------------------------------------------------------------------------- --- Character and font operators - --- | The following fonts are expected to exist on most platforms: --- --- > Times-Roman Times-Italic Times-Bold Times-BoldItalic --- > Helvetica Helvetica-Oblique Helvetica-Bold Helvetica-Bold-Oblique --- > Courier Courier-Oblique Courier-Bold Courier-Bold-Oblique --- > Symbol --- --- List from Bill Casselman \'Mathematical Illustrations\' p279. - --- | @ /... findfont @ -ps_findfont :: String -> WumpusM () -ps_findfont = command "findfont" . return . ('/' :) - --- | @ ... scalefont @ -ps_scalefont :: Int -> WumpusM () -ps_scalefont = command "scalefont" . return . show - --- | @ setfont @ -ps_setfont :: WumpusM () -ps_setfont = command "setfont" [] - --- | @ (...) show @ -ps_show :: String -> WumpusM () -ps_show = command "show" . return . parens - --- | @ (...) show @ -ps_glyphshow :: String -> WumpusM () -ps_glyphshow = command "glyphshow" . return . ('/':) - - --------------------------------------------------------------------------------- --- document structuring conventions - --- | @ %!PS-Adobe-3.0 @ -bang_PS :: WumpusM () -bang_PS = writeln "%!PS-Adobe-3.0" - --- | @ %!PS-Adobe-3.0 EPSF-3.0 @ -bang_EPS :: WumpusM () -bang_EPS = writeln "%!PS-Adobe-3.0 EPSF-3.0" - --- | @ %%...: ... @ -dsc_comment :: String -> [String] -> WumpusM () -dsc_comment name [] = write "%%" >> writeln name -dsc_comment name xs = write "%%" >> write name >> write ": " >> writeln (hsep xs) - - --- | @ %%BoundingBox: ... ... ... ... @ /llx lly urx ury/ -dsc_BoundingBox :: PSUnit u => u -> u -> u -> u -> WumpusM () -dsc_BoundingBox llx lly urx ury = - dsc_comment "BoundingBox" (map (roundup . toDouble) [llx,lly,urx,ury]) - --- | @ %%CreationDate: ... @ --- --- The creation date is informational and never interpreted, --- thus the format is entirely arbitrary. -dsc_CreationDate :: String -> WumpusM () -dsc_CreationDate = dsc_comment "CreationDate" . return - --- | @ %%Pages: ... @ -dsc_Pages :: Int -> WumpusM () -dsc_Pages = dsc_comment "Pages" . return . show - - --- | @ %%Page: ... ... @ -dsc_Page :: String -> Int -> WumpusM () -dsc_Page label ordinal = - dsc_comment "Page" [label, show ordinal] - - --- | @ %%EndComments @ -dsc_EndComments :: WumpusM () -dsc_EndComments = dsc_comment "EndComments" [] - --- | @ %%EOF @ -dsc_EOF :: WumpusM () -dsc_EOF = dsc_comment "EOF" [] - diff --git a/src/Wumpus/Core/PostScriptDoc.hs b/src/Wumpus/Core/PostScriptDoc.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Core/PostScriptDoc.hs @@ -0,0 +1,350 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Core.PostScriptDoc +-- Copyright : (c) Stephen Tetley 2009-2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- PostScript Doc combinators. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Core.PostScriptDoc + ( + + escapeSpecial + + , psHeader + , epsHeader + , psFooter + , epsFooter + , dsc_Page + + , missingCharCode + + , command + , ps_comment + + , ps_gsave + , ps_grestore + , ps_setlinewidth + , ps_setlinecap + , ps_setlinejoin + , ps_setmiterlimit + , ps_setdash + , ps_setrgbcolor + + , ps_translate + , ps_concat + + , ps_newpath + , ps_moveto + , ps_lineto + , ps_arc + , ps_curveto + , ps_closepath + , ps_clip + + , ps_fill + , ps_stroke + + , ps_showpage + , ps_findfont + , ps_scalefont + , ps_setfont + , ps_show + , ps_glyphshow + + ) where + +import Wumpus.Core.BoundingBox +import Wumpus.Core.Colour +import Wumpus.Core.FormatCombinators +import Wumpus.Core.Geometry +import Wumpus.Core.GraphicsState +import Wumpus.Core.PictureInternal +import Wumpus.Core.TextEncoder +import Wumpus.Core.Utils + +import Data.Time + + + + +-------------------------------------------------------------------------------- +-- Escape special chars + +-- | Escape these characters: +-- +-- > \\ - (, ), <, >, [, ], {, }, /, and % +-- +escapeSpecial :: String -> String +escapeSpecial = foldr f "" + where + f c ss | c `elem` ps_special = '\\' : c : ss + | otherwise = c : ss + +ps_special :: [Char] +ps_special = "\\()<>[]{}/%" + + + +psHeader :: Int -> ZonedTime -> Doc +psHeader page_count tod = vcat $ + [ text "%!PS-Adobe-3.0" + , text "%%Pages:" <+> int page_count + , text "%%CreationDate:" <+> parens (showsDoc $ psTimeStamp tod) + , text "%%EndComments" + ] + + +epsHeader :: PSUnit u => BoundingBox u -> ZonedTime -> Doc +epsHeader bb tod = vcat $ + [ text "%!PS-Adobe-3.0 EPSF-3.0" + , text "%%BoundingBox:" <+> upint llx <+> upint lly + <+> upint urx <+> upint ury + , text "%%CreationDate:" <+> parens (showsDoc $ psTimeStamp tod) + , text "%%EndComments" + ] + where + upint = text . roundup . toDouble + (llx,lly,urx,ury) = destBoundingBox bb + + + +psFooter :: Doc +psFooter = text "%%EOF" + + +epsFooter :: Doc +epsFooter = vcat [ text "showpage", text "%%EOF" ] + + +-- | @ %%Page: ... ... @ +-- +dsc_Page :: String -> Int -> Doc +dsc_Page label ordinal = text "%%Page:" <+> text label <+> int ordinal + + +missingCharCode :: CharCode -> GlyphName -> Doc +missingCharCode i fallback = vcat $ + [ ps_comment $ "missing lookup for &#" ++ show i ++ ";" + , ps_glyphshow fallback + ] + +-------------------------------------------------------------------------------- + +formatArray :: (a -> Doc) -> [a] -> Doc +formatArray _ [] = brackets space +formatArray fn xs = brackets (separate space $ map fn xs) + +command :: String -> [Doc] -> Doc +command cmd [] = text cmd +command cmd ds = hsep ds <+> text cmd + + +-- | @ %% ... @ +-- +ps_comment :: String -> Doc +ps_comment ss = text "%%" <+> text ss + +-------------------------------------------------------------------------------- +-- Graphics state operators + +-- | @ gsave @ +-- +ps_gsave :: Doc +ps_gsave = command "gsave" [] + +-- | @ grestore @ +-- +ps_grestore :: Doc +ps_grestore = command "grestore" [] + + + +-- | @ ... setlinewidth @ +-- +ps_setlinewidth :: PSUnit u => u -> Doc +ps_setlinewidth u = command "setlinewidth" [dtruncFmt u] + +-- | @ ... setlinecap @ +-- +ps_setlinecap :: LineCap -> Doc +ps_setlinecap a = command "setlinecap" [int $ fromEnum a] + +-- | @ ... setlinejoin @ +-- +ps_setlinejoin :: LineJoin -> Doc +ps_setlinejoin a = command "setlinejoin" [int $ fromEnum a] + +-- | @ ... setmiterlimit @ +-- +ps_setmiterlimit :: PSUnit u => u -> Doc +ps_setmiterlimit u = command "setmiterlimit" [dtruncFmt u] + +-- | @ [... ...] ... setdash @ +-- +ps_setdash :: DashPattern -> Doc +ps_setdash Solid = command "setdash" [text "[]", char '0'] +ps_setdash (Dash n pairs) = command "setdash" [brackets $ step pairs, int n] + where + step [] = empty + step [(a,b)] = int a <+> int b + step ((a,b):xs) = int a <+> int b <+> step xs + +-- | @ ... ... ... setrgbcolor @ +-- +ps_setrgbcolor :: RGBi -> Doc +ps_setrgbcolor (RGBi r g b) = command "setrgbcolor" [fn r, fn g, fn b] + where + fn i = dtruncFmt $ (fromIntegral i / d255) + d255 :: Double + d255 = 255.0 + +-------------------------------------------------------------------------------- +-- coordinate system and matrix operators + +-- | @ ... ... translate @ +ps_translate :: PSUnit u => (Vec2 u) -> Doc +ps_translate (V2 dx dy) = command "translate" [dtruncFmt dx, dtruncFmt dy] + + +-- Note - Do not use @setmatrix@ for changing the CTM use +-- @concat@ instead. +-- +-- Using concat is harmonious with /nesting/. +-- + +-- | @ [... ... ... ... ... ...] concat @ +-- +ps_concat :: PSUnit u => Matrix3'3 u -> Doc +ps_concat mtrx = doc <+> text "concat" + where + (a,b,c,d,e,f) = deconsMatrix mtrx + doc = formatArray dtruncFmt [a,b,c,d,e,f] + +-------------------------------------------------------------------------------- +-- Path construction operators + +-- | @ newpath @ +-- +ps_newpath :: Doc +ps_newpath = command "newpath" [] + +-- Note - it is apparently preferable to show doubles as 0.0 +-- rather than 0. +-- +-- I have read that in PostScript the coercion from int to float +-- is apparently quite expensive (I ought to locate the reference +-- for this...). + +-- | @ ... ... moveto @ +-- +ps_moveto :: PSUnit u => Point2 u -> Doc +ps_moveto (P2 x y) = command "moveto" [dtruncFmt x, dtruncFmt y] + + +-- | @ ... ... lineto @ +-- +ps_lineto :: PSUnit u => Point2 u -> Doc +ps_lineto (P2 x y) = command "lineto" [dtruncFmt x, dtruncFmt y] + + +-- | @ ... ... ... ... ... arc @ +-- +ps_arc :: PSUnit u => Point2 u -> u -> Radian -> Radian -> Doc +ps_arc (P2 x y) radius ang1 ang2 = + command "arc" $ [ dtruncFmt x + , dtruncFmt y + , dtruncFmt radius + , dtruncFmt $ fromR ang1 + , dtruncFmt $ fromR ang2 + ] + where + fromR :: Radian -> Double + fromR = fromRadian + +-- | @ ... ... ... ... ... ... curveto @ +-- +ps_curveto :: PSUnit u => Point2 u -> Point2 u -> Point2 u -> Doc +ps_curveto (P2 x1 y1) (P2 x2 y2) (P2 x3 y3) = + command "curveto" $ map dtruncFmt [x1,y1, x2,y2, x3,y3] + +-- | @ closepath @ +-- +ps_closepath :: Doc +ps_closepath = command "closepath" [] + + +-- | @ clip @ +-- +ps_clip :: Doc +ps_clip = command "clip" [] + + +-------------------------------------------------------------------------------- +-- painting operators + +-- | @ fill @ +-- +ps_fill :: Doc +ps_fill = command "fill" [] + +-- | @ stroke @ +-- +ps_stroke :: Doc +ps_stroke = command "stroke" [] + +-------------------------------------------------------------------------------- +-- Output operators + +-- | @ showpage @ +ps_showpage :: Doc +ps_showpage = command "showpage" [] + + +-------------------------------------------------------------------------------- +-- Character and font operators + +-- | The following fonts are expected to exist on most platforms: +-- +-- > Times-Roman Times-Italic Times-Bold Times-BoldItalic +-- > Helvetica Helvetica-Oblique Helvetica-Bold Helvetica-Bold-Oblique +-- > Courier Courier-Oblique Courier-Bold Courier-Bold-Oblique +-- > Symbol +-- +-- List taken from Bill Casselman \'Mathematical Illustrations\' p279. +-- + + +-- | @ /... findfont @ +-- +ps_findfont :: String -> Doc +ps_findfont ss = command "findfont" [text $ '/':ss] + +-- | @ ... scalefont @ +-- +ps_scalefont :: Int -> Doc +ps_scalefont sz = command "scalefont" [int sz] + +-- | @ setfont @ +-- +ps_setfont :: Doc +ps_setfont = command "setfont" [] + +-- | @ (...) show @ +-- +ps_show :: String -> Doc +ps_show ss = command "show" [parens $ text ss] + +-- | @ (/...) show @ +-- +ps_glyphshow :: String -> Doc +ps_glyphshow ss = command "glyphshow" [text $ '/':ss] + diff --git a/src/Wumpus/Core/PtSize.hs b/src/Wumpus/Core/PtSize.hs --- a/src/Wumpus/Core/PtSize.hs +++ b/src/Wumpus/Core/PtSize.hs @@ -9,7 +9,7 @@ -- -- Maintainer : stephen.tetley@gmail.com -- Stability : unstable --- Portability : GHC with TypeFamilies and more +-- Portability : GHC -- -- Numeric type representing Point size (1/72 inch) which is -- PostScript and Wumpus-Core\'s internal unit size. @@ -34,7 +34,9 @@ ) where --- | Wumpus-Core +-- | Wrapped Double representing /Point size/ for font metrics +-- etc. +-- newtype PtSize = PtSize { ptSize :: Double } deriving (Eq,Ord,Num,Floating,Fractional) diff --git a/src/Wumpus/Core/SVG.hs b/src/Wumpus/Core/SVG.hs deleted file mode 100644 --- a/src/Wumpus/Core/SVG.hs +++ /dev/null @@ -1,436 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Core.SVG --- Copyright : (c) Stephen Tetley 2009-2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC with TypeFamilies and more --- --- SVG generation. --- --- SVG is represented using XML.Light. XML.Light is a simple, --- generic XML representation (almost) everything is an element --- with attributes. --- --- SVG output is monadic to handle clipping paths and --- configurable text encoding via a Reader monad. --- --- SVG does not achieve clipping by changing the graphics state --- (being /declarative/ SVG doesn\'t have a graphics state as --- such). Instead a clipping path has an id, subsequent elements --- that are bound by the clipping path are tagged with a --- @clip-path@ attribute that references the clipping path id: --- --- > clip-path=\"url(#clip1)\" --- --- --- The operations to build XML elements (e.g. element_path) don\'t --- take more parameters than necessary, and are expected to be --- augmented with attributes using 'add_attr' and 'add_attrs' from --- the XML.Light library. --- --------------------------------------------------------------------------------- - -module Wumpus.Core.SVG - ( - -- * SVG Monad - SvgM - , runSVG - , newClipLabel - , currentClipLabel - - - -- * Build SVG - , SvgPath - - , unqualAttr - , xmlVersion - , svgDocType - , gElement - , svgElement - - , element_circle - , element_ellipse - , attr_x - , attr_y - , attr_r - , attr_rx - , attr_ry - , attr_cx - , attr_cy - , element_path - , element_clippath - , element_text - , element_tspan - , content_text - , attr_font_family - , attr_font_size - , attr_font_weight - , attr_font_style - , attr_id - , attr_fill - , attr_fill_none - , attr_stroke - , attr_stroke_none - , attr_stroke_width - , attr_stroke_miterlimit - , attr_stroke_linecap - , attr_stroke_linejoin - - , attr_stroke_dasharray - , attr_stroke_dasharray_none - , attr_stroke_dashoffset - - , attr_color - , attr_clippath - , attr_transform - , val_matrix - , val_colour - , val_rgb - , val_url - , val_translate - , path_m - , path_l - , path_c - - - ) where - -import Wumpus.Core.Colour -import Wumpus.Core.GraphicsState -import Wumpus.Core.TextEncoder -import Wumpus.Core.Utils - - -import MonadLib hiding ( version ) -import Text.XML.Light - - -data SvgState = SvgSt { clipCount :: Int } - --- | The SVG monad - which wraps a state monad to generate --- fresh names. -type SvgM a = SvgT Id a - -newtype SvgT m a = SvgT { unSvgT :: StateT SvgState (ReaderT TextEncoder m) a } - -runSvgT :: Monad m => TextEncoder -> SvgT m a -> m (a,SvgState) -runSvgT i m = runReaderT i $ runStateT st0 $ unSvgT m where - st0 = SvgSt { clipCount = 0 } - -instance Monad m => Functor (SvgT m) where - fmap f (SvgT mf) = SvgT $ fmap f mf - -instance Monad m => Monad (SvgT m) where - return a = SvgT $ return a - ma >>= f = SvgT $ unSvgT ma >>= unSvgT . f - -instance Monad m => StateM (SvgT m) SvgState where - get = SvgT $ get - set = SvgT . set - -instance Monad m => ReaderM (SvgT m) TextEncoder where - ask = SvgT $ ask - -instance MonadT SvgT where - lift = SvgT . lift . lift - - -svgId :: TextEncoder -> SvgT Id a -> (a,SvgState) -svgId = runId `oo` runSvgT - --- | Run the SVG monad. -runSVG :: TextEncoder -> SvgM a -> a -runSVG = fst `oo` svgId - - --- | Get the current clip label. -currentClipLabel :: SvgM String -currentClipLabel = get >>= return . clipname . clipCount - --- | Generate a new clip label. -newClipLabel :: SvgM String -newClipLabel = do - i <- (get >>= return . clipCount) - sets_ (\s -> s { clipCount=i+1 }) - return $ clipname i - - -clipname :: Int -> String -clipname = ("clip" ++) . show - - --------------------------------------------------------------------------------- --- Helpers for XML.Light and /data in strings/. - --- | Helper for XML.Light -unqualAttr :: String -> String -> Attr -unqualAttr name val = Attr (unqual name) val - - --------------------------------------------------------------------------------- --- SVG helpers - -type SvgPath = [String] - - --- | @ \ @ --- -xmlVersion :: String -> CData -xmlVersion s = CData CDataRaw - ("") - (Just 1) - --- | --- > "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd" > --- -svgDocType :: CData -svgDocType = CData CDataRaw (line1 ++ "\n" ++ line2) (Just 1) - where - line1 = "" - --- | --- > ... --- --- Wumpus uses the g element (group) to achieve nesting. -gElement :: [Attr] -> [Element] -> Element -gElement xs ys = unode "g" (xs,ys) - --- | --- > --- > ... --- > --- -svgElement :: [Element] -> Element -svgElement xs = unode "svg" ([xmlns,version],xs) - where - xmlns = unqualAttr "xmlns" "http://www.w3.org/2000/svg" - version = unqualAttr "version" "1.1" - - --------------------------------------------------------------------------------- - - - --- | --- > --- -element_circle :: Element -element_circle = unode "circle" () - --- | --- > --- -element_ellipse :: Element -element_ellipse = unode "ellipse" () - - - --- | @ x=\"...\" @ -attr_x :: PSUnit u => u -> Attr -attr_x = unqualAttr "x" . dtrunc - --- | @ y=\"...\" @ -attr_y :: PSUnit u => u -> Attr -attr_y = unqualAttr "y" . dtrunc - --- | @ r=\"...\" @ -attr_r :: PSUnit u => u -> Attr -attr_r = unqualAttr "r" . dtrunc - - --- | @ rx=\"...\" @ -attr_rx :: PSUnit u => u -> Attr -attr_rx = unqualAttr "rx" . dtrunc - --- | @ ry=\"...\" @ -attr_ry :: PSUnit u => u -> Attr -attr_ry = unqualAttr "ry" . dtrunc - --- | @ cx=\"...\" @ -attr_cx :: PSUnit u => u -> Attr -attr_cx = unqualAttr "cx" . dtrunc - --- | @ cy=\"...\" @ -attr_cy :: PSUnit u => u -> Attr -attr_cy = unqualAttr "cy" . dtrunc - - - - --- | --- > --- --- Note the argument to this function is an attribute rather --- than content. We have no use for empty paths. -element_path :: SvgPath -> Element -element_path = unode "path" . attr_d - --- | --- > --- > ... --- > --- -element_clippath :: SvgPath -> Element -element_clippath = unode "clipPath" . element_path - --- | --- > ... --- -element_text :: Node t => t -> Element -element_text = unode "text" - --- | --- > ... --- -element_tspan :: String -> Element -element_tspan = unode "tspan" . content_text - - --- | Render the string as 'CDataText' - see XML.Light. -content_text :: String -> Content -content_text str = Text $ CData CDataRaw str Nothing - - --- | @ font-family=\"...\" @ -attr_font_family :: String -> Attr -attr_font_family = unqualAttr "font-family" - --- | @ font-size=\"...\" @ -attr_font_size :: Int -> Attr -attr_font_size = unqualAttr "font-size" . show - --- | @ font-weight=\"...\" @ -attr_font_weight :: String -> Attr -attr_font_weight = unqualAttr "font-weight" - --- | @ font-style=\"...\" @ -attr_font_style :: String -> Attr -attr_font_style = unqualAttr "font-style" - - --- | @ id=\"...\" @ -attr_id :: String -> Attr -attr_id = unqualAttr "id" - --- | @ d="..." @ -attr_d :: SvgPath -> Attr -attr_d = unqualAttr "d" . hsep - --- | @ fill=\"rgb(..., ..., ...)\" @ -attr_fill :: PSColour c => c -> Attr -attr_fill = unqualAttr "fill" . val_colour - --- | @ fill=\"none\" @ -attr_fill_none :: Attr -attr_fill_none = unqualAttr "fill" "none" - --- | @ stroke=\"rgb(..., ..., ...)\" @ -attr_stroke :: PSColour c => c -> Attr -attr_stroke = unqualAttr "stroke" . val_colour - --- | @ stroke=\"none\" @ -attr_stroke_none :: Attr -attr_stroke_none = unqualAttr "stroke" "none" - --- | @ stroke-width=\"...\" @ -attr_stroke_width :: PSUnit u => u -> Attr -attr_stroke_width = unqualAttr "stroke-width" . dtrunc - - --- | @ stroke-miterlimit=\"...\" @ -attr_stroke_miterlimit :: PSUnit u => u -> Attr -attr_stroke_miterlimit = unqualAttr "stroke-miterlimit" . dtrunc - --- | @ stroke-linejoin=\"...\" @ -attr_stroke_linejoin :: LineJoin -> Attr -attr_stroke_linejoin JoinMiter = unqualAttr "stroke-linejoin" "miter" -attr_stroke_linejoin JoinRound = unqualAttr "stroke-linejoin" "round" -attr_stroke_linejoin JoinBevel = unqualAttr "stroke-linejoin" "bevel" - - - -attr_stroke_linecap :: LineCap -> Attr -attr_stroke_linecap CapButt = unqualAttr "stroke-linecap" "butt" -attr_stroke_linecap CapRound = unqualAttr "stroke-linecap" "round" -attr_stroke_linecap CapSquare = unqualAttr "stroke-linecap" "square" - - --- | @ stroke-dasharray=\"...\" @ -attr_stroke_dasharray :: [Int] -> Attr -attr_stroke_dasharray = unqualAttr "stroke-dasharray" . commasep . map show - --- | @ stroke-dasharray=\"none\" @ -attr_stroke_dasharray_none :: Attr -attr_stroke_dasharray_none = unqualAttr "stroke-dasharray" "none" - --- | @ stroke-dashoffset=\"...\" @ -attr_stroke_dashoffset :: Int -> Attr -attr_stroke_dashoffset = unqualAttr "stroke-dashoffset" . show - --- | @ color=\"rgb(..., ..., ...)\" @ --- --- Gray or HSB values will be converted to and rendered as RGB. -attr_color :: PSColour c => c -> Attr -attr_color = unqualAttr "color" . val_colour - --- | @ clip-path=\"url(#...)\" @ -attr_clippath :: String -> Attr -attr_clippath = unqualAttr "clip-path" . val_url - --- | @ transform="..." @ -attr_transform :: String -> Attr -attr_transform = unqualAttr "transform" - --- | @ matrix(..., ..., ..., ..., ..., ...) @ -val_matrix :: PSUnit u => u -> u -> u -> u -> u -> u -> String -val_matrix a b c d e f = "matrix" ++ tupled (map dtrunc [a,b,c,d,e,f]) - - - --- | @ rgb(..., ..., ...) @ --- --- HSB and gray scale are translated to RGB values. -val_colour :: PSColour c => c -> String -val_colour = val_rgb . psColour - - --- | @ rgb(..., ..., ...) @ -val_rgb :: RGB3 Double -> String -val_rgb (RGB3 r g b) = "rgb" ++ show (ramp255 r,ramp255 g,ramp255 b) - - --- | @ url(#...) @ -val_url :: String -> String -val_url s = "url" ++ parens ('#':s) - --- | @ translate(..., ...) @ -val_translate :: PSUnit u => u -> u -> String -val_translate x y = "translate" ++ tupled (map dtrunc [x,y]) - --- | @ M ... ... @ --- --- c.f. PostScript's @moveto@. -path_m :: PSUnit u => u -> u -> String -path_m x y = hsep $ "M" : map dtrunc [x,y] - --- | @ L ... ... @ --- --- c.f. PostScript's @lineto@. -path_l :: PSUnit u => u -> u -> String -path_l x y = hsep $ "L" : map dtrunc [x,y] - --- | @ S ... ... ... ... ... ... @ --- --- c.f. PostScript's @curveto@. -path_c :: PSUnit u => u -> u -> u -> u -> u -> u -> String -path_c x1 y1 x2 y2 x3 y3 = hsep $ "C" : map dtrunc [x1,y1,x2,y2,x3,y3] - - diff --git a/src/Wumpus/Core/SVGDoc.hs b/src/Wumpus/Core/SVGDoc.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Core/SVGDoc.hs @@ -0,0 +1,382 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Core.SVGDoc +-- Copyright : (c) Stephen Tetley 2009-2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- SVG Doc combinators. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Core.SVGDoc + ( + escapeSpecial + + , xml_version + , doctype + , elem_svg + , elem_g + , elem_g_no_attrs + + , elem_a_xlink + , elem_clipPath + , elem_path + , elem_text + , elem_tspan + , elem_ellipse + , elem_circle + + , attr_id + , attr_x + , attr_y + , attr_r + , attr_rx + , attr_ry + , attr_cx + , attr_cy + + , path_m + , path_l + , path_c + + , val_rgb + + , attr_font_family + , attr_font_size + , attr_font_weight + , attr_font_style + + , attr_fill + , attr_fill_none + , attr_stroke + , attr_stroke_none + , attr_stroke_width + , attr_stroke_miterlimit + , attr_stroke_linecap + , attr_stroke_linejoin + + , attr_stroke_dasharray + , attr_stroke_dasharray_none + , attr_stroke_dashoffset + + , attr_clip_path + , attr_transform + , val_matrix + , val_translate + + ) where + +import Wumpus.Core.Colour +import Wumpus.Core.FormatCombinators +import Wumpus.Core.Geometry +import Wumpus.Core.GraphicsState +import Wumpus.Core.PictureInternal +import Wumpus.Core.TextEncoder +import Wumpus.Core.Utils + + +escapeSpecial :: CharCode -> String +escapeSpecial i = "&#" ++ show i ++ ";" + + +-- Note - it is easier put particular attrs at the end (esp. d +-- for paths) if attrs are treated as a Doc. + + +svgElem :: String -> Doc -> Doc +svgElem name attrs = angles (text name <+> attrs <+> char '/') + +svgElemB :: String -> Doc -> Doc -> Doc +svgElemB name attrs body = vcat [ open, indent 2 body, close ] + where + open = angles (text name <+> attrs) + close = angles (char '/' <> text name) + +svgElemB_no_attrs :: String -> Doc -> Doc +svgElemB_no_attrs name body = vcat [ open, indent 2 body, close ] + where + open = angles (text name) + close = angles (char '/' <> text name) + +-- 1 line version of svgElemB +-- +svgElemB1 :: String -> Doc -> Doc -> Doc +svgElemB1 name attrs body = open <> body <> close + where + open = angles (text name <+> attrs) + close = angles (char '/' <> text name) + + +svgAttr :: String -> Doc -> Doc +svgAttr name val = text name <> char '=' <> dquotes val + +dquoteText :: String -> Doc +dquoteText = dquotes . text + +-------------------------------------------------------------------------------- +xml_version :: Doc +xml_version = text "" + +doctype :: Doc +doctype = angles ( text "!DOCTYPE svg PUBLIC" + <+> dquoteText "-//W3C//DTD SVG 1.1//EN" + <+> dquoteText svg_url ) + where + svg_url = "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd" + + +elem_svg :: Doc -> Doc +elem_svg body = svgElemB "svg" (svgns <+> svgvn <+> xlink) body + where + svgns = svgAttr "xmlns" (text "http://www.w3.org/2000/svg") + svgvn = svgAttr "version" (text "1.1") + xlink = svgAttr "xmlns:xlink" (text "http://www.w3.org/1999/xlink") + +-- | @ \ ... \ @ +-- +elem_g :: Doc -> Doc -> Doc +elem_g attrs body = svgElemB "g" attrs body + +-- | @ \ ... \ @ +-- +elem_g_no_attrs :: Doc -> Doc +elem_g_no_attrs body = svgElemB_no_attrs "g" body + +-- | @ \ ... \ @ +-- +elem_clipPath :: Doc -> Doc -> Doc +elem_clipPath attrs body = svgElemB "clipPath" attrs body + + +elem_a_xlink :: String -> Doc -> Doc +elem_a_xlink href body = svgElemB "a" attrs body + where + attrs = svgAttr "xlink:href" (text href) + + + +-- | @ \ @ +-- +elem_path :: Doc -> Doc -> Doc +elem_path attrs path = svgElem "path" (attrs <+> svgAttr "d" path) + + +-- | @ \...\ @ +-- +elem_text :: Doc -> Doc -> Doc +elem_text attrs body = svgElemB "text" attrs body + + +-- | @ \...\ @ +-- +elem_tspan :: Doc -> Doc -> Doc +elem_tspan attrs body1 = svgElemB1 "tspan" attrs body1 + +-- @ \ +-- +elem_circle :: Doc -> Doc +elem_circle attrs = svgElem "circle" attrs + +-- @ \ +-- +elem_ellipse :: Doc -> Doc +elem_ellipse attrs = svgElem "ellipse" attrs + +-- | @ id=\"...\" @ +-- +attr_id :: String -> Doc +attr_id = svgAttr "id" . text + + +-- | @ x=\"...\" @ +-- +attr_x :: PSUnit u => u -> Doc +attr_x = svgAttr "x" . dtruncFmt + +-- | @ y=\"...\" @ +-- +attr_y :: PSUnit u => u -> Doc +attr_y = svgAttr "y" . dtruncFmt + +-- | @ r=\"...\" @ +-- +attr_r :: PSUnit u => u -> Doc +attr_r = svgAttr "r" . dtruncFmt + + +-- | @ rx=\"...\" @ +-- +attr_rx :: PSUnit u => u -> Doc +attr_rx = svgAttr "rx" . dtruncFmt + +-- | @ ry=\"...\" @ +-- +attr_ry :: PSUnit u => u -> Doc +attr_ry = svgAttr "ry" . dtruncFmt + +-- | @ cx=\"...\" @ +-- +attr_cx :: PSUnit u => u -> Doc +attr_cx = svgAttr "cx" . dtruncFmt + +-- | @ cy=\"...\" @ +-- +attr_cy :: PSUnit u => u -> Doc +attr_cy = svgAttr "cy" . dtruncFmt + + + + +-------------------------------------------------------------------------------- +-- Path Segments, encoded as string values. + + +-- | @ M ... ... @ +-- +-- c.f. PostScript's @moveto@. +-- +path_m :: PSUnit u => Point2 u -> Doc +path_m (P2 x y) = char 'M' <+> dtruncFmt x <+> dtruncFmt y + +-- | @ L ... ... @ +-- +-- c.f. PostScript's @lineto@. +-- +path_l :: PSUnit u => Point2 u -> Doc +path_l (P2 x y) = char 'L' <+> dtruncFmt x <+> dtruncFmt y + +-- | @ C ... ... ... ... ... ... @ +-- +-- c.f. PostScript's @curveto@. +-- +path_c :: PSUnit u => Point2 u -> Point2 u -> Point2 u -> Doc +path_c (P2 x1 y1) (P2 x2 y2) (P2 x3 y3) = + char 'C' <+> dtruncFmt x1 <+> dtruncFmt y1 + <+> dtruncFmt x2 <+> dtruncFmt y2 + <+> dtruncFmt x3 <+> dtruncFmt y3 + + +val_rgb :: RGBi -> Doc +val_rgb (RGBi r g b) = + text "rgb" <> tupled [integral r, integral g, integral b] + + +-- | @ font-family=\"...\" @ +-- +attr_font_family :: String -> Doc +attr_font_family = svgAttr "font-family" . text + +-- | @ font-size=\"...\" @ +-- +attr_font_size :: Int -> Doc +attr_font_size = svgAttr "font-size" . int + +-- | @ font-weight=\"...\" @ +-- +attr_font_weight :: String -> Doc +attr_font_weight = svgAttr "font-weight" . text + +-- | @ font-style=\"...\" @ +-- +attr_font_style :: String -> Doc +attr_font_style = svgAttr "font-style" . text + + +-- | @ fill=\"rgb(..., ..., ...)\" @ +-- +attr_fill :: RGBi -> Doc +attr_fill = svgAttr "fill" . val_rgb + +-- | @ fill=\"none\" @ +-- +attr_fill_none :: Doc +attr_fill_none = svgAttr "fill" (text "none") + +-- | @ stroke=\"rgb(..., ..., ...)\" @ +-- +attr_stroke :: RGBi -> Doc +attr_stroke = svgAttr "stroke" . val_rgb + +-- | @ stroke=\"none\" @ +-- +attr_stroke_none :: Doc +attr_stroke_none = svgAttr "stroke" (text "none") + +-- | @ stroke-width=\"...\" @ +-- +attr_stroke_width :: PSUnit u => u -> Doc +attr_stroke_width = svgAttr "stroke-width" . dtruncFmt + + +-- | @ stroke-miterlimit=\"...\" @ +-- +attr_stroke_miterlimit :: PSUnit u => u -> Doc +attr_stroke_miterlimit = svgAttr "stroke-miterlimit" . dtruncFmt + +-- | @ stroke-linejoin=\"...\" @ +-- +attr_stroke_linejoin :: LineJoin -> Doc +attr_stroke_linejoin = svgAttr "stroke-linejoin" . step + where + step JoinMiter = text "miter" + step JoinRound = text "round" + step JoinBevel = text "bevel" + + +-- | @ stroke-linecap=\"...\" @ +-- +attr_stroke_linecap :: LineCap -> Doc +attr_stroke_linecap = svgAttr "stroke-linecap" . step + where + step CapButt = text "butt" + step CapRound = text "round" + step CapSquare = text "square" + + +-- | @ stroke-dasharray=\"...\" @ +-- +attr_stroke_dasharray :: [(Int,Int)] -> Doc +attr_stroke_dasharray = svgAttr "stroke-dasharray" . step + where + step [] = empty + step [(a,b)] = int a <> comma <> int b + step ((a,b):xs) = int a <> comma <> int b <> step xs + +-- | @ stroke-dasharray=\"none\" @ +-- +attr_stroke_dasharray_none :: Doc +attr_stroke_dasharray_none = svgAttr "stroke-dasharray" (text "none") + +-- | @ stroke-dashoffset=\"...\" @ +-- +attr_stroke_dashoffset :: Int -> Doc +attr_stroke_dashoffset = svgAttr "stroke-dashoffset" . int + +-- | @ clip_path="url(#...)" @ +-- +attr_clip_path :: String -> Doc +attr_clip_path ss = svgAttr "transform" (text "url" <> parens (text $ '#':ss)) + + +-- | @ transform="..." @ +-- +attr_transform :: Doc -> Doc +attr_transform = svgAttr "transform" + +-- | @ matrix(..., ..., ..., ..., ..., ...) @ +-- +val_matrix :: PSUnit u => Matrix3'3 u -> Doc +val_matrix mtrx = text "matrix" <> tupled (map dtruncFmt [a,b,c,d,e,f]) + where + (a,b,c,d,e,f) = deconsMatrix mtrx + +-- | @ translate(..., ..., ..., ..., ..., ...) @ +-- +val_translate :: PSUnit u => Vec2 u -> Doc +val_translate (V2 x y) = text "translate" <> tupled [dtruncFmt x, dtruncFmt y] diff --git a/src/Wumpus/Core/TextEncoder.hs b/src/Wumpus/Core/TextEncoder.hs --- a/src/Wumpus/Core/TextEncoder.hs +++ b/src/Wumpus/Core/TextEncoder.hs @@ -8,7 +8,7 @@ -- -- Maintainer : stephen.tetley@gmail.com -- Stability : unstable --- Portability : GHC with TypeFamilies and more +-- Portability : GHC -- -- Extended character code handling. -- @@ -48,8 +48,8 @@ -type GlyphName = String -type CharCode = Int +type GlyphName = String +type CharCode = Int type PostScriptLookup = CharCode -> Maybe GlyphName type SVGLookup = GlyphName -> Maybe CharCode diff --git a/src/Wumpus/Core/TextEncodingInternal.hs b/src/Wumpus/Core/TextEncodingInternal.hs deleted file mode 100644 --- a/src/Wumpus/Core/TextEncodingInternal.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Core.TextEncodingInternal --- Copyright : (c) Stephen Tetley 2009-2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC with TypeFamilies and more --- --- Extended character handling... --- --------------------------------------------------------------------------------- - -module Wumpus.Core.TextEncodingInternal - ( - - EncodedText(..) - , TextChunk(..) - - , textLength - , lookupByCharCode - , lookupByGlyphName - - , lexLabel - - ) where - -import Wumpus.Core.TextEncoder - -import Text.PrettyPrint.Leijen hiding ( SText ) - -import Data.Char - -newtype EncodedText = EncodedText { getEncodedText :: [TextChunk] } - deriving (Eq,Show) - - -data TextChunk = SText String - | EscInt Int - | EscStr GlyphName - deriving (Eq,Show) - - --------------------------------------------------------------------------------- - -instance Pretty EncodedText where - pretty = hcat . map pretty . getEncodedText - -instance Pretty TextChunk where - pretty (SText s) = string s - pretty (EscInt i) = text "&#" <> int i <> semi - pretty (EscStr s) = text "&#" <> text s <> semi - --------------------------------------------------------------------------------- - -textLength :: EncodedText -> Int -textLength = foldr add 0 . getEncodedText where - add (SText s) n = n + length s - add _ n = n + 1 - - -lookupByCharCode :: CharCode -> TextEncoder -> Maybe GlyphName -lookupByCharCode i enc = (ps_lookup enc) i - -lookupByGlyphName :: GlyphName -> TextEncoder -> Maybe CharCode -lookupByGlyphName i enc = (svg_lookup enc) i - - --- | Output to PostScript as @ /egrave glyphshow @ - --- Output to SVG as an escaped decimal, e.g. @ è @ --- --- Note, HTML entity names do not seem to be supported in SVG, --- @ è @ does not work in FireFox or Chrome. - - -lexLabel :: String -> EncodedText -lexLabel = EncodedText . lexer - -lexer :: String -> [TextChunk] -lexer [] = [] - -lexer ('&':'#':xs) = esc xs - where - esc (c:cs) | isDigit c = let (s,cs') = span isDigit cs - in intval (c:s) cs' - | otherwise = let (s,cs') = span isAlpha cs - in EscStr (c:s) : optsemi cs' - esc [] = [] - - optsemi (';':cs) = lexer cs -- let ill-formed go through - optsemi cs = lexer cs - - intval [] rest = optsemi rest - intval cs rest = EscInt (read cs) : optsemi rest - -lexer (x:xs) = let (s,xs') = span (/= '&') xs - in SText (x:s) : lexer xs' diff --git a/src/Wumpus/Core/TextInternal.hs b/src/Wumpus/Core/TextInternal.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Core/TextInternal.hs @@ -0,0 +1,100 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Core.TextInternal +-- Copyright : (c) Stephen Tetley 2009-2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Extended character handling. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Core.TextInternal + ( + + EncodedText(..) + , TextChunk(..) + + , textLength + , lookupByCharCode + , lookupByGlyphName + + , lexLabel + + ) where + +import Wumpus.Core.FormatCombinators +import Wumpus.Core.TextEncoder + +import Data.Char + +newtype EncodedText = EncodedText { getEncodedText :: [TextChunk] } + deriving (Eq,Show) + + +data TextChunk = SText String + | EscInt Int + | EscStr GlyphName + deriving (Eq,Show) + + +-------------------------------------------------------------------------------- + +instance Format EncodedText where + format = hcat . map format . getEncodedText + +instance Format TextChunk where + format (SText s) = text s + format (EscInt i) = text "&#" <> int i <> semicolon + format (EscStr s) = text "&#" <> text s <> semicolon + +-------------------------------------------------------------------------------- + +textLength :: EncodedText -> Int +textLength = foldr add 0 . getEncodedText where + add (SText s) n = n + length s + add _ n = n + 1 + + +lookupByCharCode :: CharCode -> TextEncoder -> Maybe GlyphName +lookupByCharCode i enc = (ps_lookup enc) i + +lookupByGlyphName :: GlyphName -> TextEncoder -> Maybe CharCode +lookupByGlyphName i enc = (svg_lookup enc) i + + +-- | Output to PostScript as @ /egrave glyphshow @ + +-- Output to SVG as an escaped decimal, e.g. @ è @ +-- +-- Note, HTML entity names do not seem to be supported in SVG, +-- @ è @ does not work in FireFox or Chrome. + + +lexLabel :: String -> EncodedText +lexLabel = EncodedText . lexer + +lexer :: String -> [TextChunk] +lexer [] = [] + +lexer ('&':'#':xs) = esc xs + where + esc (c:cs) | isDigit c = let (s,cs') = span isDigit cs + in intval (c:s) cs' + | otherwise = let (s,cs') = span isAlpha cs + in EscStr (c:s) : optsemi cs' + esc [] = [] + + optsemi (';':cs) = lexer cs -- let ill-formed go through + optsemi cs = lexer cs + + intval [] rest = optsemi rest + intval cs rest = EscInt (read cs) : optsemi rest + +lexer (x:xs) = let (s,xs') = span (/= '&') xs + in SText (x:s) : lexer xs' diff --git a/src/Wumpus/Core/TextLatin1.hs b/src/Wumpus/Core/TextLatin1.hs --- a/src/Wumpus/Core/TextLatin1.hs +++ b/src/Wumpus/Core/TextLatin1.hs @@ -8,7 +8,7 @@ -- -- Maintainer : stephen.tetley@gmail.com -- Stability : unstable --- Portability : GHC with TypeFamilies and more +-- Portability : GHC -- -- A TextEncoder record instance for Latin1 characters. -- diff --git a/src/Wumpus/Core/Utils.hs b/src/Wumpus/Core/Utils.hs --- a/src/Wumpus/Core/Utils.hs +++ b/src/Wumpus/Core/Utils.hs @@ -11,7 +11,7 @@ -- Stability : highly unstable -- Portability : GHC -- --- Utility functions and a OneList (non-empty list) data type. +-- Utility functions and a Hughes list. -- -------------------------------------------------------------------------------- @@ -19,82 +19,66 @@ module Wumpus.Core.Utils ( + -- | Opt - maybe strict in Some + Opt(..) + , some - -- * Three values - max3 - , min3 - , med3 + -- | Conditional application + , applyIf + , rescale -- * Truncate / print a double , PSUnit(..) + , dtruncFmt + , truncateDouble , roundup + - , rescale - , clamp - , ramp - , ramp255 - - -- * PostScript timetmap - , mkTimeStamp - - -- * Pretty printers for strings - , parens - , hsep - , commasep - , tupled - - -- * Extras - , sequenceA - , (<:>) + -- * PostScript time stamp + , psTimeStamp -- * Hughes list , H , emptyH - , toListH + , wrapH + , consH , snocH - - - -- * specs etc. from Data.Aviary - , appro - , oo - , ooo - , oooo - , rap - + , appendH + , toListH ) where +import qualified Wumpus.Core.FormatCombinators as Fmt -import Control.Applicative -import Data.List ( intersperse ) + import Data.Ratio import Data.Time - - --------------------------------------------------------------------------------- - +data Opt a = None | Some !a + deriving (Eq,Show) --- | max of 3 -max3 :: Ord a => a -> a -> a -> a -max3 a b c = max (max a b) c +some :: a -> Opt a -> a +some dflt None = dflt +some _ (Some a) = a --- | min of 3 -min3 :: Ord a => a -> a -> a -> a -min3 a b c = min (min a b) c +applyIf :: Bool -> (a -> a) -> a -> a +applyIf cond fn a = if cond then fn a else a --- | median of 3 -med3 :: Ord a => a -> a -> a -> a -med3 a b c = if c <= x then x else if c > y then y else c - where - (x,y) = order a b - order p q | p <= q = (p,q) - | otherwise = (q,p) +-- 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 -------------------------------------------------------------------------------- @@ -119,7 +103,10 @@ instance PSUnit (Ratio Int) where toDouble = realToFrac +dtruncFmt :: PSUnit a => a -> Fmt.Doc +dtruncFmt = Fmt.text . dtrunc + -- | Truncate the printed decimal representation of a Double. -- The is prefered to 'showFFloat' from Numeric as it produces -- shorter representations where appropriate. @@ -147,80 +134,37 @@ 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 amin amax x = max amin (min amax x) -ramp :: Double -> Double -ramp = clamp 0 1 - --- | Scale a Double between 0.0 and 1.0 to be an Int between 0 --- and 255. -ramp255 :: Double -> Int -ramp255 = clamp 0 255 . ceiling . (*255) +-------------------------------------------------------------------------------- --------------------------------------------------------------------------------- +-- | To be used with getZonedTime --- | Generate a time stamp for the output files. Note PostScript --- does no interpretation of the time stamp, it is solely for --- information and so the representation is arbitrary. +psTimeStamp :: ZonedTime -> ShowS +psTimeStamp zt = localTimeS . showChar ' ' . localDayS + where + local_tim = zonedTimeToLocalTime zt + localTimeS = timeOfDay $ localTimeOfDay $ local_tim + localDayS = showString $ showGregorian $ localDay local_tim -mkTimeStamp :: IO String -mkTimeStamp = getZonedTime >>= return . format . zonedTimeToLocalTime +timeOfDay :: TimeOfDay -> ShowS +timeOfDay t = + fn todHour . showChar ':' . fn todMin . showChar ':' . fn (floori . todSec) where - format t = mkTime t ++ " " ++ mkDate t - mkTime = concat . intersperse ":" . sequenceA tfuns . localTimeOfDay - mkDate = showGregorian . localDay - tfuns = [ pad2 . todHour, pad2 . todMin, pad2 . floori . todSec ] - pad2 i | i < 10 = '0' : show i - | otherwise = show i + fn f = pad2 (f t) -floori :: RealFrac a => a -> Int -floori = floor +pad2 :: Int -> ShowS +pad2 i | i < 10 = ('0':) . shows i + | otherwise = shows i --------------------------------------------------------------------------------- --- | Enclose string in parens. -parens :: String -> String -parens s = "(" ++ s ++ ")" - --- | Separate with a space. -hsep :: [String] -> String -hsep = concat . intersperse " " - -commasep :: [String] -> String -commasep = concat . intersperse "," - --- | @ (..., ...)@ -tupled :: [String] -> String -tupled = parens . concat . intersperse ", " +floori :: RealFrac a => a -> Int +floori = floor --- | Applicative version of (monadic) 'sequence'. --- Because we use MonadLib we don't want to bring in --- Control.Monad.Instances () -sequenceA :: Applicative f => [f a] -> f [a] -sequenceA = foldr (<:>) (pure []) - - --- | Applicative 'cons'. -infixr 6 <:> -(<:>) :: Applicative f => f a -> f [a] -> f [a] -(<:>) a b = (:) <$> a <*> b - -------------------------------------------------------------------------------- -- Hughes list @@ -229,64 +173,20 @@ emptyH :: H a emptyH = id -toListH :: H a -> [a] -toListH = ($ []) -snocH :: H a -> a -> H a -snocH hl a = hl . (a:) - --------------------------------------------------------------------------------- - --- | A variant of the @D2@ or dovekie combinator - the argument --- order has been changed to be more satisfying for Haskellers: --- --- > (appro comb f g) x y --- --- > (f x) `comb` (g y) --- --- @on@ from Data.Function is similar but less general, where --- the two intermediate results are formed by applying the same --- function to the supplied arguments: --- --- > on = (appro comb f f) --- -appro :: (c -> d -> e) -> (a -> c) -> (b -> d) -> a -> b -> e -appro comb f g x y = comb (f x) (g y) - - --------------------------------------------------------------------------------- --- Specs - blackbird, bunting, ... - --- Alleviate your composing-sectioning mania with specs! --- --- E.g.: --- (abs .) . (*) ==> abs `oo` (*) --- --- The family name /specs/ (glasses, specs, lunettes) is a --- visual pun when infix directives @`oo`@ are included. The --- @o@\'s of individual combinators are a fraternal nod to --- Clean and ML who use @o@ as function composition. Naturally --- we don\'t defined @o@ here and waste a good variable on a --- redundant combinator. +wrapH :: a -> H a +wrapH a = consH a id --- | Compose an arity 1 function with an arity 2 function. --- B1 - blackbird -oo :: (c -> d) -> (a -> b -> c) -> a -> b -> d -oo f g = (f .) . g +consH :: a -> H a -> H a +consH a f = (a:) . f --- | Compose an arity 1 function with an arity 3 function. --- B2 - bunting -ooo :: (d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e -ooo f g = ((f .) .) . g +snocH :: H a -> a -> H a +snocH hl a = hl . (a:) --- | Compose an arity 1 function with an arity 4 function. -oooo :: (e -> f) -> (a -> b -> c -> d -> e) -> a -> b -> c -> d -> f -oooo f g = (((f .) .) .) . g +appendH :: H a -> H a -> H a +appendH f g = f . g +toListH :: H a -> [a] +toListH = ($ []) --- ($) reversed - aka T - aka (#) --- -infixl 1 `rap` -rap :: a -> (a -> b) -> b -rap a f = f a diff --git a/src/Wumpus/Core/VersionNumber.hs b/src/Wumpus/Core/VersionNumber.hs --- a/src/Wumpus/Core/VersionNumber.hs +++ b/src/Wumpus/Core/VersionNumber.hs @@ -8,9 +8,9 @@ -- -- Maintainer : stephen.tetley@gmail.com -- Stability : unstable --- Portability : GHC with TypeFamilies and more +-- Portability : GHC -- --- Version number +-- Version number. -- -------------------------------------------------------------------------------- @@ -20,9 +20,9 @@ ) where --- | Version number +-- | Version number. -- --- > (0,23,0) +-- > (0,30,0) -- wumpus_core_version :: (Int,Int,Int) -wumpus_core_version = (0,23,0) +wumpus_core_version = (0,30,0) diff --git a/src/Wumpus/Core/WumpusTypes.hs b/src/Wumpus/Core/WumpusTypes.hs --- a/src/Wumpus/Core/WumpusTypes.hs +++ b/src/Wumpus/Core/WumpusTypes.hs @@ -8,7 +8,7 @@ -- -- Maintainer : Stephen Tetley -- Stability : unstable --- Portability : GHC with TypeFamilies and more +-- Portability : GHC -- -- This module re-exports types and functions from -- "Wumpus.Core.PictureInternal" but makes them opaque. @@ -28,27 +28,28 @@ -- * Picture types Picture , DPicture + , GSUpdate , Primitive , DPrimitive - , Path - , DPath - , PathSegment - , DPathSegment - , Label - , DLabel + , PrimPath + , DPrimPath + , PrimPathSegment + , DPrimPathSegment + , PrimLabel + , DPrimLabel -- * Drawing styles , PathProps , LabelProps , EllipseProps - , DrawPath - , DrawEllipse + + -- * Transformations on Primitives - , translatePrimitive , rotatePrimitive , scalePrimitive , uniformScalePrimitive + , translatePrimitive -- * Printable unit for PostScript @@ -58,5 +59,5 @@ import Wumpus.Core.PictureInternal -import Wumpus.Core.Utils () +import Wumpus.Core.Utils ( PSUnit(..) ) diff --git a/wumpus-core.cabal b/wumpus-core.cabal --- a/wumpus-core.cabal +++ b/wumpus-core.cabal @@ -1,5 +1,5 @@ name: wumpus-core -version: 0.23.0 +version: 0.30.0 license: BSD3 license-file: LICENSE copyright: Stephen Tetley @@ -29,9 +29,9 @@ . For actually drawing pictures, diagrams, etc. Wumpus is very low level. There is a supplemantary package @wumpus-basic@ - available that helps create certain types of diagram, but even - this lacks the higher-level stuff (polygons, arrows etc.) that - would make creating general drawings easy. + available that helps create certain types of diagram, but it is + experimental - functionality is added an dropped between + releases. . Some of the design decisions made for wumpus-core are not sophisticated (e.g. how attributes like colour are handled, @@ -43,14 +43,7 @@ appears okay for Latin 1 but may be inadequate for other character sets, so I may have to revise it significantly. . - WARNING... . - The module @Core.BoundingBox@ is likely to be reworked - significantly in the future. 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. - . - . \[1\] Because the output is simple, straight-line PostScript code, it is possible to use GraphicsMagick or a similar tool to convert Wumpus'\s EPS files to many other formats @@ -58,6 +51,47 @@ . Changelog: . + 0.23.0 to 0.30.0: + . + * Substantial changes - the output machinery has been heavily + modified, the intention was to reduce the use of matrix + transformations in SVG output. Though this goal has not been + achieved, some code-size improvements in the SVG output have + been made. + . + * The code generation monads have been changed - Wumpus no + longer uses a writer monad for code generation, but it will + keep the Wumpus name. + . + * Added support for hyperlinks in the SVG output. + . + * Improved internal pretty printing and added the function + @printPicture@ for debugging. + . + * The @Core.Colour@ module has been simplified to support just + one (new) type - RGBi, and the conversion type class + @PSColour@ has been eliminated. + . + * @Core.Picture@ - the type of the @frame@ function has been + changed to take a list of Primitives rather than a single + Primitive. The function @frameMulti@ which previously + provided this functionality has been removed. SVG hyperlinks + are now supported for Primitives. + . + * The default font size has been changed to 14 pt. + . + * The Path datatype has been renamed PrimPath, likewise Ellipse + is now PrimEllispe and Label becomes PrimLabel. + . + * @Core.Geometry@ now longer defines an affine frame datatype. + . + * @Core.BoundingBox@ module changed significantly. The corner + functions (@boundaryBottomLeft@, etc.) have been removed, + along with the plane functions (@leftPlane@, etc.). Some + functions have been given more verbose names - @corners@ is + now @boundaryCorners@, @within@ is now @withinBoundary@ and + @union@ is now @boundaryUnion@. + . 0.22.0 TO 0.23.0: . * @Basic.GraphicsState@ - extracted the font face fields from @@ -94,10 +128,11 @@ demo/AffineTestBase.hs, demo/FontMetrics.hs demo/LabelPic.hs, - demo/MultiPic.hs - demo/Rotated.hs - demo/Scaled.hs - demo/Translated.hs + demo/MultiPic.hs, + demo/Rotated.hs, + demo/Scaled.hs, + demo/Translated.hs, + demo/ZOrderPic.hs, doc/Guide.pdf, doc-src/Guide.lhs, doc-src/Makefile, @@ -107,10 +142,11 @@ library hs-source-dirs: src - build-depends: base < 5, containers, - time >= 1.1.3 && < 1.2, - wl-pprint, vector-space, - monadLib, xml, algebra + build-depends: base < 5, + containers >= 0.3 && <= 0.4, + time >= 1.1.3 && < 1.2, + vector-space >= 0.6 && < 1.0, + algebra >= 0.0.0.1 exposed-modules: Wumpus.Core, @@ -130,11 +166,13 @@ Wumpus.Core.WumpusTypes other-modules: + Wumpus.Core.FormatCombinators, + Wumpus.Core.PageTranslation, Wumpus.Core.PictureInternal, - Wumpus.Core.PostScript, - Wumpus.Core.SVG, + Wumpus.Core.PostScriptDoc, + Wumpus.Core.SVGDoc, Wumpus.Core.OneList, - Wumpus.Core.TextEncodingInternal, + Wumpus.Core.TextInternal, Wumpus.Core.Utils extensions: