Initial demonstration of image import.

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

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"