{-# LANGUAGE GeneralizedNewtypeDeriving, RecordWildCards #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Postscript
-- Copyright   :  (c) 2013 diagrams team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- Generic tools for generating Postscript files.  There is some
-- limited support for tracking the state of the renderer when
-- given a side-effecting (in the Postscript) command.  Only drawing
-- operations are supported, not general Postscript language generation.
--
-- In the future the tracking of rendering state could lead to optimizing
-- output, but for now little optimization is attempted.  Most systems are
-- equiped with tools to optimize Postscript such as 'eps2eps'.
--
-- For details on the PostScript language see the PostScript(R) Language
-- Reference: <http://www.adobe.com/products/postscript/pdfs/PLRM.pdf>
-----------------------------------------------------------------------------
module Graphics.Rendering.Postscript
  ( Render
  , RenderState
  , Surface
  , PSWriter(..)
  , renderWith
  , renderPagesWith
  , withEPSSurface
  , newPath
  , moveTo
  , lineTo
  , curveTo
  , relLineTo
  , relCurveTo
  , arc
  , closePath
  , stroke
  , fill
  , fillPreserve
  , transform
  , save
  , restore
  , gsave
  , grestore
  , saveMatrix
  , restoreMatrix
  , translate
  , scale
  , rotate
  , strokeColor
  , fillColor
  , lineWidth
  , lineCap
  , lineJoin
  , setDash
  , setFillRule
  , showText
  , showTextCentered
  , showTextAlign
  , showTextInBox
  , clip
  
  , FontSlant(..)
  , FontWeight(..)
  , setFontFace
  , setFontSlant
  , setFontWeight
  , setFontSize
  ) where

import Diagrams.Attributes(Color(..),LineCap(..),LineJoin(..),colorToSRGBA)
import Diagrams.TwoD.Path hiding (stroke)
import Control.Monad.Writer
import Control.Monad.State
import Control.Monad(when)
import Data.List(intersperse)
import Data.DList(DList,toList,fromList)
import Data.Word(Word8)
import Data.Char(ord,isPrint)
import Numeric(showIntAtBase)
import System.IO (openFile, hPutStr, IOMode(..), hClose)

-- Here we want to mirror the state of side-effecting calls
-- that we have emitted into the postscript file (at least
-- ones that we do not protect in other ways).
data DrawState = DS
                 { _fillRule :: FillRule
                 , _font     :: PostscriptFont
                 } deriving (Eq)

-- This reflects the defaults from the standard.
emptyDS :: DrawState
emptyDS = DS Winding defaultFont

data RenderState = RS
                   { _drawState :: DrawState   -- The current state.
                   , _saved     :: [DrawState] -- A stack of passed states pushed by save and poped with restore.
                   }

emptyRS :: RenderState
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))

-- | 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)

-- | Abstraction of the drawing surface details.
data Surface = Surface { header :: Int -> String, footer :: Int -> String, width :: Int, height :: Int, fileName :: String } 

doRender :: Render a -> PSWriter a
doRender r = evalStateT (runRender r) emptyRS

-- | Handles opening and closing the file associated with the
--   passed 'Surface' and renders the commands built up in the
--   'Render' argument.
renderWith :: MonadIO m => Surface -> Render a -> m a
renderWith s r = liftIO $ do 
    (v,ss) <- runWriterT . runPSWriter . doRender $ r
    h <- openFile (fileName s) WriteMode
    hPutStr h (header s 1)
    mapM_ (hPutStr h) (toList ss)
    hPutStr h (footer s 1)
    hClose h
    return v

-- | Renders multiple pages given as a list of 'Render' actions
--   to the file associated with the 'Surface' argument.
renderPagesWith :: MonadIO m => Surface -> [Render a] -> m [a]
renderPagesWith s rs = liftIO $ do 
    h <- openFile (fileName s) WriteMode
    hPutStr h (header s (length rs))
    
    vs <- mapM (page h) (zip rs [1..])
    
    hClose h
    return vs
  where 
    page h (r,i) = do
      (v,ss) <- runWriterT . runPSWriter . doRender $ r
      mapM_ (hPutStr h) (toList ss)
      hPutStr h (footer s i)
      return v

-- | Builds a surface and performs an action on that surface.
withEPSSurface :: String -> Int -> Int -> (Surface -> IO a) -> IO a
withEPSSurface file w h f = f s
  where s = Surface (epsHeader w h) epsFooter w h file

renderPS :: String -> Render ()
renderPS s = Render . lift . tell $ fromList [s, "\n"]

-- | Clip with the current path.
clip :: Render ()
clip = renderPS "clip"

mkPSCall :: Show a => String -> [a] -> Render()
mkPSCall n vs = renderPS . concat $ intersperse " " (map show vs) ++ [" ", n]

mkPSCall' :: String -> [String] -> Render()
mkPSCall' n vs = renderPS . concat $ intersperse " " vs ++ [" ", n]

-- | Start a new path.
newPath :: Render ()
newPath = renderPS "newpath"

-- | Close the current path.
closePath :: Render ()
closePath = renderPS "closepath"

-- | Draw an arc given a center, radius, start, and end angle.
arc :: Double -- ^ x-coordinate of center.
    -> Double -- ^ y-coordiante of center.
    -> Double -- ^ raidus.
    -> Double -- ^ start angle in radians.
    -> Double -- ^ end angle in radians.
    -> Render ()
arc a b c d e = mkPSCall "arc" [a,b,c, d * 180 / pi, e* 180 / pi]

-- | Move the current point.
moveTo :: Double -> Double -> Render ()
moveTo x y = mkPSCall "moveto" [x,y]

-- | Add a line to the current path from the current point to the given point.
--   The current point is also moved with this command.
lineTo :: Double -> Double -> Render ()
lineTo x y = mkPSCall "lineto" [x,y]

-- | Add a cubic Bézier curve segment to the current path from the current point.
--   The current point is also moved with this command.
curveTo :: Double -> Double -> Double -> Double -> Double -> Double -> Render ()
curveTo ax ay bx by cx cy = mkPSCall "curveto" [ax,ay,bx,by,cx,cy]

-- | Add a line segment to the current path using relative coordinates.
relLineTo :: Double -> Double -> Render ()
relLineTo x y = mkPSCall "rlineto" [x,y]

-- | Add a cubic Bézier curve segment to the current path from the current point
--   using relative coordinates.
relCurveTo :: Double -> Double -> Double -> Double -> Double -> Double -> Render ()
relCurveTo ax ay bx by cx cy = mkPSCall "rcurveto" [ax,ay,bx,by,cx,cy]

-- | Stroke the current path.
stroke :: Render ()
stroke = renderPS "s"

-- | Fill the current path.
fill :: Render ()
fill = do
    (RS (DS {..}) _) <- get
    case _fillRule of
        Winding -> renderPS "fill"
        EvenOdd -> renderPS "eofill"

-- | Fill the current path without affecting the graphics state.
fillPreserve :: Render ()
fillPreserve = do
    gsave
    fill
    grestore

-- | Draw a string at the current point.
showText :: String -> Render ()
showText s = do
    renderFont
    stringPS s
    renderPS " show"

-- | Draw a string by first measuring the width then offseting by half.
showTextCentered :: String -> Render ()
showTextCentered s = do
    renderFont
    stringPS s
    renderPS " showcentered"

-- | Draw a string uniformally scaling to fit within a bounding box.
showTextInBox :: (Double,Double) -> (Double,Double) -> String -> Render ()
showTextInBox (a,b) (c,d) s = do
    renderFont
    renderPS . unwords . map show $ [a,b,c,d]
    stringPS s
    renderPS " showinbox"

-- | Draw a string with offset factors from center relative to the width and height.
showTextAlign :: Double -> Double -> String -> Render ()
showTextAlign xt yt s = do
    renderFont
    renderPS . unwords . map show $ [xt, yt]
    stringPS s
    renderPS " showalign"

-- | Apply a transform matrix to the current transform.
transform :: Double -> Double -> Double -> Double -> Double -> Double -> Render ()
transform ax ay bx by tx ty = when (vs /= [1.0,0.0,0.0,1.0,0.0,0.0]) $
      renderPS (matrixPS vs ++ " concat")
    where vs  = [ax,ay,bx,by,tx,ty]

matrixPS :: Show a => [a] -> String
matrixPS vs = unwords ("[" : map show vs ++ ["]"])

-- | Push the current state of the renderer onto the state stack.
save :: Render ()
save = do
    renderPS "save"
    modify $ \rs@(RS{..}) -> rs { _saved = _drawState : _saved }

-- | Replace the current state by popping the state stack.
restore :: Render ()
restore = do
    renderPS "restore"
    modify go
  where
    go rs@(RS{_saved = d:ds}) = rs { _drawState = d, _saved = ds }
    go rs = rs

-- | Push the current graphics state.
gsave :: Render ()
gsave = do
    renderPS "gsave"
    modify $ \rs@(RS{..}) -> rs { _saved = _drawState : _saved }

-- | Pop the current graphics state.
grestore :: Render ()
grestore = do
    renderPS "grestore"
    modify go
  where
    go rs@(RS{_saved = d:ds}) = rs { _drawState = d, _saved = ds }
    go rs = rs

-- | Push the current transform matrix onto the execution stack.
saveMatrix :: Render ()
saveMatrix = renderPS "matrix currentmatrix"

-- | Set the current transform matrix to be the matrix found by popping
--   the execution stack.
restoreMatrix :: Render ()
restoreMatrix = renderPS "setmatrix"

colorPS :: Color c => c -> [Double]
colorPS c = [ r, g, b ]
  where (r,g,b,_) = colorToSRGBA c

-- | Set the color of the stroke.
strokeColor :: (Color c) => c -> Render ()
strokeColor c = mkPSCall "setrgbcolor" (colorPS c)

-- | Set the color of the fill.
fillColor :: (Color c) => c -> Render ()
fillColor c = mkPSCall "setrgbcolor" (colorPS c)

-- | Set the line width.
lineWidth :: Double -> Render ()
lineWidth w = mkPSCall "setlinewidth" [w]

-- | Set the line cap style.
lineCap :: LineCap -> Render ()
lineCap lc = mkPSCall "setlinecap" [fromLineCap lc] 

-- | Set the line join method.
lineJoin :: LineJoin -> Render ()
lineJoin lj = mkPSCall "setlinejoin" [fromLineJoin lj]

-- | Set the dash style.
setDash :: [Double] -- ^ Dash pattern (even indices are "on").
        -> Double   -- ^ Offset.
        -> Render ()
setDash as offset = mkPSCall' "setdash" [showArray as, show offset]

-- | Set the fill rule.
setFillRule :: FillRule -> Render ()
setFillRule r = modify (\rs@(RS ds _) -> rs { _drawState = ds { _fillRule = r } })

showArray :: Show a => [a] -> String
showArray as = concat ["[", concat $ intersperse " " (map show as), "]"]

fromLineCap :: LineCap -> Int
fromLineCap LineCapRound  = 1
fromLineCap LineCapSquare = 2
fromLineCap _             = 0

fromLineJoin :: LineJoin -> Int
fromLineJoin LineJoinRound = 1
fromLineJoin LineJoinBevel = 2
fromLineJoin _             = 0

-- | Translate the current transform matrix.
translate :: Double -> Double -> Render ()
translate x y = mkPSCall "translate" [x,y]

-- | Scale the current transform matrix.
scale :: Double -> Double -> Render ()
scale x y = mkPSCall "scale" [x,y]

-- | Rotate the current transform matrix.
rotate :: Double -> Render ()
rotate t = mkPSCall "rotate" [t]

stringPS :: String -> Render ()
stringPS ss = Render $ lift (tell (fromList ("(" : map escape ss)) >> tell (fromList [")"]))
  where escape '\n' = "\\n"
        escape '\r' = "\\r"
        escape '\t' = "\\t"
        escape '\b' = "\\b"
        escape '\f' = "\\f"
        escape '\\' = "\\"
        escape '('  = "\\("
        escape ')'  = "\\)"
        escape c | isPrint c = [c]
                 | otherwise = '\\' : showIntAtBase 7 ("01234567"!!) (ord c) ""

epsHeader w h pages = concat
          [ "%!PS-Adobe-3.0", if pages == 1 then " EPSF-3.0\n" else "\n"
          , "%%Creator: diagrams-postscript 0.1\n"
          , "%%BoundingBox: 0 0 ", show w, " ", show h, "\n"
          , "%%Pages: ", show pages, "\n"
          , "%%EndComments\n\n"
          , "%%BeginProlog\n"
          , "%%BeginResource: procset diagrams-postscript 0 0\n"
          , "/s { 0.0 currentlinewidth ne { stroke } if } bind def\n"
          , "/nvhalf { 2 div neg exch 2 div neg exch } bind def\n"
          , "/showcentered { dup stringwidth nvhalf moveto show } bind def\n"
          , "/stringbbox { 0 0 moveto true charpath flattenpath pathbbox } bind def\n"
          , "/wh { 1 index 4 index sub 1 index 4 index sub } bind def\n"
          , "/showinbox { gsave dup stringbbox wh 11 7 roll mark 11 1 roll "
          , "wh dup 7 index div 2 index 9 index div 1 index 1 index lt "
          , "{ pop dup 9 index mul neg 3 index add 2 div 7 index add "
          , " 6 index 13 index abs add } "
          , "{ exch pop 6 index 12 index abs 2 index mul 7 index add } "
          , "ifelse 17 3 roll cleartomark 4 1 roll translate dup scale "
          , "0 0 moveto show grestore } bind def\n"
          , "/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"
          , "%%EndResource\n"
          , "%%EndProlog\n"
          , "%%BeginSetup\n"
          , "%%EndSetup\n"
          , "%%Page: 1 1\n"
          ]
epsFooter page = concat
          [ "showpage\n"
          , "%%PageTrailer\n"
          , "%%EndPage: ", show page, "\n"
          ]

---------------------------
-- Font
data PostscriptFont = PostscriptFont
    { _face   :: String
    , _slant  :: FontSlant
    , _weight :: FontWeight
    , _size   :: Double
    } deriving (Eq, Show)

data FontSlant = FontSlantNormal
               | FontSlantItalic
               | FontSlantOblique
               | FontSlant Double
            deriving (Show, Eq)

data FontWeight = FontWeightNormal
                | FontWeightBold
            deriving (Show, Eq)

defaultFont :: PostscriptFont
defaultFont = PostscriptFont "Helvetica" FontSlantNormal FontWeightNormal 1

renderFont :: Render ()
renderFont = do
    (RS (DS _ (PostscriptFont {..})) _) <- get
    renderPS $ concat ["/", fontFromName _face _slant _weight, " ", show _size, " selectfont"]

-- This is a little hacky.  I'm not sure there are good options.
fontFromName :: String -> FontSlant -> FontWeight -> String
fontFromName n s w = font ++ bold w ++ italic s
  where
    font = map f n
    f ' ' = '-'
    f c   = c

    bold FontWeightNormal = ""
    bold FontWeightBold   = "Bold"

    italic FontSlantNormal = ""
    italic FontSlantItalic = "Italic"
    italic FontSlantOblique = "Oblique"
    italic _                = ""

-- | Set the font face.
setFontFace :: String -> Render ()
setFontFace n = modify (\rs@(RS ds@(DS {..})  _) -> rs { _drawState = ds { _font = _font { _face = n } } })

-- | Set the font slant.
setFontSlant :: FontSlant -> Render ()
setFontSlant s = modify (\rs@(RS ds@(DS {..})  _) -> rs { _drawState = ds { _font = _font { _slant = s } } })

-- | Set the font weight.
setFontWeight :: FontWeight -> Render ()
setFontWeight w = modify (\rs@(RS ds@(DS {..})  _) -> rs { _drawState = ds { _font = _font { _weight = w } } })

-- | Set the font size.
setFontSize :: Double -> Render ()
setFontSize s = modify (\rs@(RS ds@(DS {..})  _) -> rs { _drawState = ds { _font = _font { _size = s } } })