-- | Postscript generator.
module Graphics.PS.PS (ps,eps,stringFromPS) where

import Data.CG.Minus {- hcg-minus -}
import Data.List
import Data.Monoid (Monoid, mappend, mempty, mconcat, Endo(Endo,appEndo), )
import System.IO

import Graphics.PS.Path
import Graphics.PS.Font
import Graphics.PS.Unit
import Graphics.PS.GS
import qualified Graphics.PS.Paper as P
import qualified Graphics.PS.Image as I

data PS = Name String
        | LName String
        | Op String
        | Comment String
        | Int Int
        | Double Double
        | String String
        | Transform (Matrix Double)
        | Array [PS]
        | Proc [PS]
        | Dict [(PS,PS)]
        | Seq [PS]

dsc :: String -> [String] -> PS
dsc k [] = Comment ('%' : k)
dsc k v = Comment (concat ("%" : k : ": " : intersperse " " v))

header,headerEps :: PS
header = Comment "!PS-Adobe-3.0"
headerEps = Comment "!PS-Adobe-3.0 EPSF-3.0"

title :: String -> PS
title t = dsc "Title" [t]

creator :: String -> PS
creator t = dsc "Creator" [t]

languageLevel :: Int -> PS
languageLevel n = dsc "LanguageLevel" [show n]

pages :: Int -> PS
pages n = dsc "Pages" [show n]

bbox :: P.BBox -> PS
bbox (P.BBox i j k l) = dsc "BoundingBox" [show i,show j,show k,show l]
bbox (P.HRBBox i j k l i' j' k' l') =
    Seq [dsc "BoundingBox" [show i,show j,show k,show l],
         dsc "HiResBoundingBox" [show i',show j',show k',show l']]

endComments :: PS
endComments = dsc "EndComments" []

page :: (Show a) => String -> a -> PS
page t n = dsc "Page" [t, show n]

trailer :: PS
trailer = dsc "Trailer" []

eof :: PS
eof = dsc "EOF" []

documentMedia :: String -> Int -> Int -> PS
documentMedia tag w h = dsc "DocumentMedia" [tag, show w, show h, "0", "()", "()"]

alias :: String -> String -> PS
alias o a = Seq [LName a, Proc [Name o], Op "def"]

pdfCompat :: [(String, String)]
pdfCompat = [("gsave",                "q"),
             ("grestore",             "Q"),
             ("stroke",               "S"),
             ("fill",                 "f"),
             ("setrgbcolor",          "RG"),
             ("setlinewidth",         "w"),
             ("setlinecap",           "J"),
             ("setlinejoin",          "j"),
             ("setdash",              "d"),
             ("setmiterlimit",        "M"),
             ("moveto",               "m"),
             ("lineto",               "l"),
             ("curveto",              "c"),
             ("closepath",            "h"),
             ("concat",               "cm"),
             ("show",                 "Tj"),
             ("selectfont",           "Tf"),
             ("clip",                 "W")]

prolog :: PS
prolog =
    let f (a,b) = alias a b
    in Seq (map f pdfCompat)

stroke :: PS
stroke = Op "S"

fill :: PS
fill = Op "f"

false :: PS
false = Name "false"

save :: PS
save = Op "q"

restore :: PS
restore = Op "Q"

showPage :: PS
showPage = Op "showpage"

rgb :: Color -> PS
rgb (RGB r g b) = Seq [Double r, Double g, Double b, Op "RG"]

lineWidth :: Double -> PS
lineWidth w = Seq [Double w, Op "w"]

lineCap :: (Enum a) => a -> PS
lineCap c = Seq [Int (fromEnum c), Op "j"]

lineJoin :: (Enum a) => a -> PS
lineJoin j = Seq [Int (fromEnum j), Op "J"]

dash :: [Int] -> Int -> PS
dash d o = Seq [Array (map Int d), Int o, Op "d"]

miterLimit :: Double -> PS
miterLimit m = Seq [Double m, Op "M"]

moveTo :: Pt Double -> PS
moveTo (Pt x y) = Seq [Double x, Double y, Op "m"]

lineTo :: Pt Double -> PS
lineTo (Pt x y) = Seq [Double x, Double y, Op "l"]

transform :: Matrix Double -> PS
transform m = Seq [Transform m, Op "cm"]

curveTo :: Pt Double -> Pt Double -> Pt Double -> PS
curveTo a b c = Seq (map Double (ls_xy [a,b,c]) ++ [Op "c"])

closePath :: Pt Double -> PS
closePath (Pt x y) = Seq [Double x, Double y, Op "h"]

selectFont :: Font -> PS
selectFont (Font f n) = Seq [LName f, Double n, Op "Tf"]

charPath :: String -> PS
charPath g = Seq [String g, false, Op "charpath"]

gs :: GS -> PS
gs (GS c w k j (d, o) m) =
    Seq [rgb c
        ,lineWidth w
        ,lineCap k
        ,lineJoin j
        ,dash d o
        ,miterLimit m]

path :: Path -> PS
path (MoveTo p) = moveTo p
path (LineTo p) = lineTo p
path (Text f g) = Seq [selectFont f, charPath g]
path (CurveTo c1 c2 p) = curveTo c1 c2 p
path (ClosePath p) = closePath p
path (PTransform m p) = Seq [transform m, path p]
path (Join a b) = Seq [path a, path b]

image :: I.Image -> PS
image I.Empty = Comment "Empty"
image (I.Stroke g p) = Seq [path p, gs g, stroke]
image (I.Fill g p) = Seq [path p, gs g, fill]
image (I.ITransform m i) = Seq [transform m, image i]
image (I.Over a b) = Seq [save
                         ,image b
                         ,restore
                         ,image a]

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 >+> mconcat (map g p) >+> h c

escape :: String -> String
escape = concatMap (\c -> if elem c "()" then ['\\', c] else [c])

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 (Transform m) = put f (Array (map Double (mx_list m)))
put f (Dict d) =
    let g = concatMap (\(a,b) -> [a,b])
    in bracket f "<<" ">>" (g d) (put f)
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]

paper_ps :: P.Paper -> P.Paper
paper_ps (P.Paper w h) =
    let f n = floor (mm_pt (fromIntegral n)::Double)
    in P.Paper (f w) (f h)

-- | Write a postscript file.  The list of images are written
--   one per page.
ps :: FilePath -> P.Paper -> [I.Image] -> IO ()
ps f d p =
  writeFile f (stringFromPS f d p)

-- | Generate postscript data given /title/, page size, and a set of
-- page 'I.Images'.
stringFromPS :: String -> P.Paper -> [I.Image] -> String
stringFromPS t d p =
  let g = put (\s -> Endo (s++))
      (P.Paper width height) = paper_ps d
  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 =
  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]

{--

data Orientation = Portrait
                 | Landscape
                   deriving (Show)

orientation :: Orientation -> PS
orientation o = dsc "Orientation" [show o]

creationDate :: String -> PS
creationDate t = dsc "CreationDate" [t]

setFont :: PS
setFont = Op "setfont"

show :: String -> PS
show g = [String g, Op "h"]

translate :: Double -> Double -> PS
translate x y = [Double x, Double y, Op "translate"]

scale :: Double -> Double -> PS
scale x y = [Double x, Double y, Op "scale"]

rotate :: Double -> PS
rotate a = [Double a, Op "rotate"]

findFont :: Font -> PS
findFont (Font f _) = [LName f, Op "findfont"]

scaleFont :: Font -> PS
scaleFont (Font _ n) = [Double n, Op "scalefont"]

--}