diff --git a/src/Diagrams/Backend/Postscript.hs b/src/Diagrams/Backend/Postscript.hs index ebdf65a..0d195cb 100644 --- a/src/Diagrams/Backend/Postscript.hs +++ b/src/Diagrams/Backend/Postscript.hs @@ -222,6 +222,34 @@ instance Renderable (Path R2) Postscript where uncurry C.moveTo (unp2 p) renderC tr +instance Renderable Image Postscript where + render _ (Image file sz tr) = C $ do + if ".eps" `isSuffixOf` file || ".ps" `isSuffixOf` file + then do + C.save + f <- liftIO (try $ readFile file :: IO (Either IOError String)) + case f of + Right s -> do + case C.parseBoundingBox s of + Right (llx,lly,urx,ury) -> do + let w = urx - llx; h = ury - lly + postscriptTransf (tr <> requiredScaleT sz (w,h) <> translation (r2 (llx - w/2,lly - h/2))) + C.epsImage s + Left s -> + liftIO . putStr . unlines $ + [ "Warning: failed to parse file <" ++ file ++ ">" + , " " ++ s + ] + Left _ -> do + liftIO . putStrLn $ + "Warning: can't read image file <" ++ file ++ ">" + C.restore + else + liftIO . putStr . unlines $ + [ "Warning: Postscript backend can currently only render embedded" + , " images in .eps or .ps format. Ignoring <" ++ file ++ ">." + ] + instance Renderable Text Postscript where render _ (Text tr al str) = C $ do C.save diff --git a/src/Graphics/Rendering/Postscript.hs b/src/Graphics/Rendering/Postscript.hs index 8011de5..2c531bc 100644 --- a/src/Graphics/Rendering/Postscript.hs +++ b/src/Graphics/Rendering/Postscript.hs @@ -54,6 +54,9 @@ module Graphics.Rendering.Postscript , lineJoin , setDash , setFillRule + , runImage + , epsImage + , parseBoundingBox , showText , showTextCentered , showTextAlign @@ -76,6 +79,9 @@ import Control.Monad(when) import Data.List(intersperse) import Data.DList(DList,toList,fromList) import Data.Word(Word8) +import Data.Maybe +import Data.List +import Data.List.Split import Data.Char(ord,isPrint) import Numeric(showIntAtBase) import System.IO (openFile, hPutStr, IOMode(..), hClose) @@ -104,11 +110,11 @@ emptyRS = RS emptyDS [] -- | Type for a monad that writes Postscript using the commands we will define later. newtype PSWriter m = PSWriter { runPSWriter :: WriterT (DList String) IO m } - deriving (Functor, Monad, MonadWriter (DList String)) + deriving (Functor, Monad, MonadWriter (DList String), MonadIO) -- | Type of the monad that tracks the state from side-effecting commands. newtype Render m = Render { runRender :: StateT RenderState PSWriter m } - deriving (Functor, Monad, MonadState RenderState) + deriving (Functor, Monad, MonadState RenderState, MonadIO) -- | Abstraction of the drawing surface details. data Surface = Surface { header :: Int -> String, footer :: Int -> String, width :: Int, height :: Int, fileName :: String } @@ -224,6 +230,34 @@ fillPreserve = do fill grestore +-- | Run an external file rendering an image from a file reference. +runImage :: String -> Render () +runImage f = do + stringPS f + renderPS " run" + +-- | Embed an EPS file. +epsImage :: String -> Render () +epsImage f = do + renderPS "beginEPS" + renderPS f + renderPS "endEPS" + +-- | Parse some EPS to find the bounding box comment. +parseBoundingBox :: Num n => String -> Either String (n,n,n,n) +parseBoundingBox f = + case filter ("%%BoundingBox:" `isPrefixOf`) $ lines f of + (l:_) -> case map fromIntegral . catMaybes . map (readMaybe :: String -> Maybe Int) . splitOn " " . drop 14 $ l of + (a:b:c:d:_) -> Right (a,b,c,d) + _ -> Left "Failed to parse '%%BoundingBox:' line." + _ -> Left "Failed to find '%%BoundingBox:'." + +readMaybe :: (Read a) => String -> Maybe a +readMaybe s = + case reads s of + [(x, "")] -> Just x + _ -> Nothing + -- | Draw a string at the current point. showText :: String -> Render () showText s = do @@ -397,6 +431,9 @@ epsHeader w h pages = concat , "/showalign { dup mark exch stringbbox wh 10 -1 roll exch 10 1 roll mul " , "neg 9 -2 roll mul 4 index add neg 8 2 roll cleartomark 3 1 roll moveto " , "show } bind def\n" + , "/beginEPS { save /showpage {} def 0 setgray 0 setlinecap 1 setlinewidth " + , "0 setlinejoin 10 setmiterlimit [ ] 0 setdash newpath } bind def\n" + , "/endEPS { restore } bind def\n" , "%%EndResource\n" , "%%EndProlog\n" , "%%BeginSetup\n"