module Graphics.PS.PS (ps) where

import Graphics.PS.Pt
import qualified Graphics.PS.Matrix as M
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
import Data.List
import System.IO

data PS = Name    String
        | LName   String
        | Op      String
        | Comment String
        | Int     Int
        | Double  Double
        | String  String
        | Matrix  M.Matrix
        | 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 :: PS
header = Comment "!PS-Adobe-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]

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 = Seq [Op "matrix", Op "currentmatrix"]

restore :: PS
restore = Op "setmatrix"

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 -> PS
moveTo (Pt x y) = Seq [Double x, Double y, Op "m"]

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

transform :: M.Matrix -> PS
transform m = Seq [Matrix m, Op "cm"]

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

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 (PTransform m p)   = Seq [ save
                              , transform m
                              , path p
                              , restore ]
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 [ save
                               , transform m
                               , image i
                               , restore ]
image (I.Over a b) = Seq [image b, image a]

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 ()
bracket f o c p g = 
    let h a = f a >> f " "
    in h o >> mapM_ 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 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

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)

ps :: String -> P.Paper -> [I.Image] -> IO ()
ps f d p = do 
  h <- openFile f WriteMode
  let g = put (hPutStr h)
      (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

{--

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"]

--}