Hi Rohan,
I wanted to generate a small animation. First I tried cairo, which is
not quite easy to build. When I saw, that this much resembles PostScript
and also generates PostScript output, I thought I can also program
PostScript directly. To that end I found your package hps easy to use:
Simple installation, Haskell 98, nicely organized. See my code at
http://code.haskell.org/~thielema/firework/src/Credits.hs
Now I found it attractive to feed GhostScript directly with the output
of hps. This way I do no longer generate a temporary postscript file of
several megatons. See the attached patch.
My idea is to generate the whole PostScript string lazily and write it
with a single writeFile call. However in order to reduce restructuring
of your code I just have replaced the IO code by code on a Monoid. That
monoid can be either an Endo monoid that creates the whole string in the
DiffList way, or the monoid can be (IO ()), where mappend = (>>). I have
only added stringFromPS to the API. If you like it, you may add
stringFromEPS in the same way. The function stringFromPS also allows us
to generate GZipped postscript on the fly.
Regards,
Henning
diff -rN -u old-postscript/Graphics/PS/PS.hs new-postscript/Graphics/PS/PS.hs
--- old-postscript/Graphics/PS/PS.hs 2010-09-14 17:12:20.000000000 +0200
+++ new-postscript/Graphics/PS/PS.hs 2010-09-14 17:12:21.000000000 +0200
@@ -1,4 +1,4 @@
-module Graphics.PS.PS (ps, eps) where
+module Graphics.PS.PS (ps, eps, stringFromPS, ) where
import Graphics.PS.Pt
import qualified Graphics.PS.Matrix as M
@@ -10,6 +10,8 @@
import qualified Graphics.PS.Image as I
import Data.List
import System.IO
+import Data.Monoid (Monoid, mappend, mempty, mconcat, Endo(Endo,appEndo), )
+
data PS = Name String
| LName String
@@ -181,29 +183,35 @@
mlist :: M.Matrix -> [Double]
mlist (M.Matrix a b c d e f) = [a,b,c,d,e,f]
-bracket :: (String -> IO ()) -> String -> String -> [a] -> (a -> IO ()) -> IO ()
+infixl 1 >+>
+
+(>+>) :: Monoid m => m -> m -> m
+(>+>) = mappend
+
+bracket :: (Monoid m) =>
+ (String -> m) -> String -> String -> [a] -> (a -> m) -> m
bracket f o c p g =
- let h a = f a >> f " "
- in h o >> mapM_ g p >> h c
+ let h a = f a >+> f " "
+ in h o >+> mconcat (map g p) >+> h c
escape :: String -> String
escape = concatMap (\c -> if elem c "()" then ['\\', c] else [c])
-put :: (String -> IO ()) -> PS -> IO ()
-put f (Name n) = f n >> f " "
-put f (LName n) = f "/" >> f n >> f " "
-put f (Op o) = f o >> f "\n"
-put f (Comment o) = f "%" >> f o >> f "\n"
-put f (Int n) = f (show n) >> f " "
-put f (Double n) = f (show n) >> f " "
-put f (String s) = f "(" >> f (escape s) >> f ") "
+put :: (Monoid m) => (String -> m) -> PS -> m
+put f (Name n) = f n >+> f " "
+put f (LName n) = f "/" >+> f n >+> f " "
+put f (Op o) = f o >+> f "\n"
+put f (Comment o) = f "%" >+> f o >+> f "\n"
+put f (Int n) = f (show n) >+> f " "
+put f (Double n) = f (show n) >+> f " "
+put f (String s) = f "(" >+> f (escape s) >+> f ") "
put f (Array a) = bracket f "[" "]" a (put f)
put f (Proc p) = bracket f "{" "}" p (put f)
put f (Matrix m) = put f (Array (map Double (mlist m)))
put f (Dict d) =
let g = concatMap (\(a,b) -> [a,b])
in bracket f "<<" ">>" (g d) (put f)
-put f (Seq a) = mapM_ (put f) a
+put f (Seq a) = mconcat (map (put f) a)
ps' :: (I.Image, Int) -> PS
ps' (p, n) = Seq [page "Graphics.PS" n, image p, showPage]
@@ -215,40 +223,51 @@
-- | Write a postscript file. The list of images are written
-- one per page.
-ps :: String -> P.Paper -> [I.Image] -> IO ()
-ps f d p = do
- h <- openFile f WriteMode
- let g = put (hPutStr h)
+ps :: FilePath -> P.Paper -> [I.Image] -> IO ()
+ps f d p =
+ writeFile f (stringFromPS f d p)
+
+stringFromPS :: String -> P.Paper -> [I.Image] -> String
+stringFromPS t d p =
+ let g = put (\s -> Endo (s++))
(P.Paper width height) = paper_ps d
- mapM_ g [header
- ,title ("Graphics.PS: " ++ f)
- ,creator "Graphics.PS"
- ,languageLevel 2
- ,pages (length p)
- ,documentMedia "Default" width height
- ,endComments
- ,prolog]
- mapM_ g (map ps' (zip p [1..]))
- mapM_ g [trailer
- ,eof]
- hClose h
-
+ in flip appEndo "" $
+ g header >+>
+ g (title t) >+>
+ g (creator "Graphics.PS") >+>
+ g (languageLevel 2) >+>
+ g (pages (length p)) >+>
+ g (documentMedia "Default" width height) >+>
+ g endComments >+>
+ g prolog >+>
+ mconcat (map (g . ps') (zip p [1..])) >+>
+ g trailer >+>
+ g eof
+
+
+newtype MonadMonoid m = MonadMonoid {appMonadMonoid :: m ()}
+
+instance Monad m => Monoid (MonadMonoid m) where
+ mempty = MonadMonoid (return ())
+ mappend (MonadMonoid a) (MonadMonoid b) =
+ MonadMonoid (a >> b)
+ mconcat = MonadMonoid . mapM_ appMonadMonoid
-- | Write an encapsulated postscript file. The single image
-- is written.
eps :: String -> P.BBox -> I.Image -> IO ()
-eps f d p = do
- h <- openFile f WriteMode
- let g = put (hPutStr h)
- mapM_ g [headerEps
- ,title ("Graphics.PS: " ++ f)
- ,creator "Graphics.PS"
- ,languageLevel 2
- ,bbox d
- ,endComments
- ,prolog
- ,image p]
- hClose h
+eps f d p =
+ withFile f WriteMode $ \h ->
+ let g = put (MonadMonoid . hPutStr h)
+ in mapM_ (appMonadMonoid . g) $
+ [headerEps
+ ,title ("Graphics.PS: " ++ f)
+ ,creator "Graphics.PS"
+ ,languageLevel 2
+ ,bbox d
+ ,endComments
+ ,prolog
+ ,image p]
{--
_______________________________________________
haskell-art mailing list
haskell-art@lurk.org
http://lists.lurk.org/mailman/listinfo/haskell-art
