{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.Core.OutputPostScript
-- Copyright   :  (c) Stephen Tetley 2009-2010
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC with TypeFamilies and more
--
-- Output PostScript - either PostScript (PS) files or 
-- EPS (Encapusulated PostScript) files can be generated. 
--
--
--------------------------------------------------------------------------------

module Wumpus.Core.OutputPostScript 
  ( 
  -- * Output PostScript
    writePS
  , writeEPS
  
  , writePS_latin1
  , writeEPS_latin1

  ) where

import Wumpus.Core.BoundingBox
import Wumpus.Core.Colour
import Wumpus.Core.Geometry
import Wumpus.Core.GraphicsState
import Wumpus.Core.PictureInternal
import Wumpus.Core.PostScript
import Wumpus.Core.TextEncoder
import Wumpus.Core.TextEncodingInternal
import Wumpus.Core.TextLatin1
import Wumpus.Core.Utils


import MonadLib hiding ( Label )

import qualified Data.Foldable as F



--------------------------------------------------------------------------------
-- Render to PostScript

-- | Output a series of pictures to a Postscript file. Each 
-- picture will be printed on a separate page. 
--
writePS :: (Real u, Floating u, PSUnit u) 
        => FilePath -> TextEncoder -> [Picture u] -> IO ()
writePS filepath enc pic = do 
    timestamp <- mkTimeStamp
    writeFile filepath $ psDraw timestamp enc pic

-- | Output a picture to an EPS (Encapsulated PostScript) file. 
-- The .eps file can then be imported or embedded in another 
-- document.
--
writeEPS :: (Real u, Floating u, PSUnit u)  
         => FilePath -> TextEncoder -> Picture u -> IO ()
writeEPS filepath enc pic = do
    timestamp <- mkTimeStamp
    writeFile filepath $ epsDraw timestamp enc pic


-- | Version of 'writePS' - using Latin1 encoding. 
writePS_latin1 :: (Real u, Floating u, PSUnit u) 
        => FilePath -> [Picture u] -> IO ()
writePS_latin1 filepath = writePS filepath latin1Encoder 

-- | Version of 'writeEPS' - using Latin1 encoding. 
writeEPS_latin1 :: (Real u, Floating u, PSUnit u)  
         => FilePath -> Picture u -> IO ()
writeEPS_latin1 filepath = writeEPS filepath latin1Encoder



--------------------------------------------------------------------------------
-- Internals


-- | Draw a picture, generating PostScript output.
psDraw :: (Real u, Floating u, PSUnit u) 
       => String -> TextEncoder -> [Picture u] -> PostScript
psDraw timestamp enc pics = runWumpus enc $ do
    psHeader 1 timestamp
    zipWithM_ psDrawPage pages pics
    psFooter
  where
    pages = map (\i -> (show i,i)) [1..]


psDrawPage :: (Real u, Floating u, PSUnit u) 
           => (String,Int) -> Picture u -> WumpusM ()
psDrawPage (lbl,ordinal) pic = do
    dsc_Page lbl ordinal
    ps_gsave
    cmdtrans
    outputPicture pic
    ps_grestore
    ps_showpage
  where
    (_,mbv)   = repositionProperties pic
    cmdtrans  = maybe (return ()) (\(V2 x y) -> ps_translate x y) mbv
  


-- | Note the bounding box may /below the origin/ - if it is, it 
-- will need translating.
--
epsDraw :: (Real u, Floating u, PSUnit u) 
        => String -> TextEncoder -> Picture u -> PostScript
epsDraw timestamp enc pic = runWumpus enc $ do 
    epsHeader bb timestamp      
    ps_gsave
    cmdtrans
    outputPicture pic
    ps_grestore
    epsFooter  
  where
    (bb,mbv)  = repositionProperties pic
    cmdtrans  = maybe (return ()) (\(V2 x y) -> ps_translate x y) mbv
     

psHeader :: Int -> String -> WumpusM ()
psHeader pagecount timestamp = do
    bang_PS
    dsc_Pages pagecount
    dsc_CreationDate $ parens timestamp
    dsc_EndComments


epsHeader :: PSUnit u => BoundingBox u -> String -> WumpusM ()
epsHeader bb timestamp = do
    bang_EPS
    dsc_BoundingBox llx lly urx ury
    dsc_CreationDate $ parens timestamp
    dsc_EndComments
  where
    (llx,lly,urx,ury) = getBounds bb

getBounds :: Num u => BoundingBox u -> (u,u,u,u)
getBounds (BBox (P2 llx lly) (P2 urx ury)) = (llx,lly,urx,ury)

psFooter :: WumpusM ()
psFooter = dsc_EOF


epsFooter :: WumpusM ()
epsFooter = do
    ps_showpage
    dsc_EOF

-- Create margins at the left and bottom of 4 points...


-- | outputPicture 
-- Frame changes, representing scalings translation, rotations...
-- are drawn when they are encountered as a @concat@ statement in a 
-- block of @gsave ... grestore@.
--
outputPicture :: (Real u, Floating u, PSUnit u) => Picture u -> WumpusM ()
outputPicture (PicBlank  _)             = return ()
outputPicture (Single (fr,_) prim)      = 
    updateFrame fr $ outputPrimitive prim
outputPicture (Picture (fr,_) ones)     =
    updateFrame fr $ F.foldrM (\p _ -> outputPicture p) () ones
outputPicture (Clip (fr,_) cp p)        = 
    updateFrame fr $ do { clipPath cp ; outputPicture p }


-- | @updateFrame@ relies on the current frame, when translated
-- to a matrix being invertible.
--
-- This is an allowable optimization because the current frame
-- is only manipulated with the affine transformations (scalings, 
-- rotations...) which are invertible. 
-- 
-- It also performs another optimization:
--
-- If the frame is the standard frame @ [1 0 0 1 0 0] @ then 
-- the monadic action is run as-is rather than being nested
-- in a block:
-- 
-- > [1 0 0 1 0 0] concat
-- > ...
-- > [1 0 0 1 0 0] concat
--

updateFrame :: (Fractional u, PSUnit u) => Frame2 u -> WumpusM () -> WumpusM ()
updateFrame frm ma 
  | standardFrame frm = ma
  | otherwise         = let m1 = frame2Matrix frm in 
                        do { ps_concat $ toCTM m1
                           ; ma 
                           ; ps_concat $ toCTM $ invert m1
                           }

outputPrimitive :: (Real u, Floating u, PSUnit u) => Primitive u -> WumpusM ()
outputPrimitive (PPath (c,dp) p)    = outputPath dp c p 
outputPrimitive (PLabel props l)    = updateFont props $ outputLabel l
outputPrimitive (PEllipse (c,dp) e) = outputEllipse dp c e

updateFont :: LabelProps -> WumpusM () -> WumpusM ()
updateFont (c,fnt) ma = updateColour c $ do 
    mb_fnt <- deltaFontAttr fnt
    maybe (return ()) fontCommand mb_fnt
    ma
    


updateColour :: PSColour c => c -> WumpusM () -> WumpusM ()
updateColour c ma = let rgbc = psColour c in do 
    mb_col  <- deltaRgbColour rgbc
    maybe (return ()) colourCommand mb_col
    ma
  where
    colourCommand :: DRGB -> WumpusM ()
    colourCommand (RGB3 r g b) = ps_setrgbcolor r g b
 
    


fontCommand :: FontAttr -> WumpusM ()
fontCommand (FontAttr name _ _ sz) = do
    ps_findfont name
    ps_scalefont sz
    ps_setfont



    
outputPath :: (PSColour c, PSUnit u) 
           => DrawPath -> c -> Path u -> WumpusM ()
outputPath CFill        c p = updateColour c $ do  
    startPath p
    ps_closepath
    ps_fill

outputPath (CStroke xs) c p = updatePen c xs $ do
    startPath p
    ps_closepath
    ps_stroke

outputPath (OStroke xs) c p = updatePen c xs $ do
    startPath p
    ps_stroke
  

startPath :: PSUnit u => Path u -> WumpusM ()
startPath (Path (P2 x y) xs) = do
    ps_newpath
    ps_moveto x y
    mapM_ outputPathSeg xs



clipPath :: PSUnit u => Path u -> WumpusM ()
clipPath p = do 
    startPath p
    ps_closepath
    ps_clip



updatePen :: PSColour c => c -> [StrokeAttr] -> WumpusM () -> WumpusM ()
updatePen c xs ma = let (mset, mreset) = strokeSetReset xs in 
                    updateColour c $ do { mset ; ma ; mreset }

strokeSetReset :: [StrokeAttr] -> (WumpusM (), WumpusM ())
strokeSetReset = foldr (appro link cmd id) (return (), return ())
  where
    link Nothing      funs    = funs 
    link (Just (f,g)) (fs,gs) = (fs >> f, gs >> g)
    
    mkSetReset mf        = maybe Nothing (\(a,b) -> Just (mf a, mf b))
    
    cmd (LineWidth d)    = mkSetReset ps_setlinewidth  $ deltaStrokeWidth d
    cmd (MiterLimit d)   = mkSetReset ps_setmiterlimit $ deltaMiterLimit d
    cmd (LineCap lc)     = mkSetReset ps_setlinecap    $ deltaLineCap lc
    cmd (LineJoin lj)    = mkSetReset ps_setlinejoin   $ deltaLineJoin lj
    cmd (DashPattern dp) = mkSetReset ps_setdash       $ deltaDashPattern dp


outputPathSeg :: PSUnit u => PathSegment u -> WumpusM ()
outputPathSeg (PLineTo (P2 x y))  = ps_lineto x y
outputPathSeg (PCurveTo p1 p2 p3) = ps_curveto x1 y1 x2 y2 x3 y3 
  where
    P2 x1 y1 = p1
    P2 x2 y2 = p2
    P2 x3 y3 = p3


-- | This is not very good - the use of PostScript's @concat@ 
-- operator will vary the line width during the drawing of a 
-- stroked ellipse.
--
outputEllipse :: (PSColour c, Real u, Floating u, PSUnit u)
              => DrawEllipse -> c -> PrimEllipse u -> WumpusM ()
outputEllipse dp c (PrimEllipse pt@(P2 x y) hw hh ctm)
    | hw==hh  && ctm == identityCTM = outputArc dp c x y hw
    | otherwise                     = 
          let matrix     =  matrixRepCTM $ scaleCTM 1 (hh/hw) ctm
              matrix'    = invert matrix
              (P2 dx dy) = matrix' *# pt 
          in do { ps_concat $ toCTM matrix
                ; outputArc dp c dx dy hw
                ; ps_concat $ toCTM $ matrix'
                }

outputArc :: (PSColour c, PSUnit u) 
          => DrawEllipse -> c -> u -> u -> u -> WumpusM ()
outputArc EFill        c x y r = updateColour c $ do 
    ps_newpath
    ps_arc x y r 0 360 
    ps_closepath
    ps_fill

outputArc (EStroke xs) c x y r = updatePen c xs $ do 
    ps_newpath
    ps_arc x y r 0 360 
    ps_closepath
    ps_stroke


-- Note - for the otherwise case the x-and-y coordinates are 
-- encoded in the matrix, hence the @ 0 0 moveto @.
--
outputLabel :: (Real u, Floating u, PSUnit u) => Label u -> WumpusM ()
outputLabel (Label (P2 x y) entxt ctm) 
    | ctm == identityCTM  = do { ps_moveto x y; outputEncodedText entxt }
    | otherwise           = do { ps_concat $ toCTM matrix
                               ; ps_moveto 0 (0 :: Double)
                               ; outputEncodedText entxt
                               ; ps_concat $ toCTM $ invert matrix
                               }
  where
    matrix = translMatrixRepCTM x y ctm

outputEncodedText :: EncodedText -> WumpusM () 
outputEncodedText = mapM_ outputTextChunk . getEncodedText

outputTextChunk :: TextChunk -> WumpusM () 
outputTextChunk (SText s)  = ps_show $ escapeStringPS s

outputTextChunk (EscInt i) = 
    ask >>= \env -> maybe (failk env) ps_glyphshow $ lookupByCharCode i env
  where
    failk = missingCode i . ps_fallback  

outputTextChunk (EscStr s) = ps_glyphshow s 

missingCode :: CharCode -> GlyphName -> WumpusM ()
missingCode i fallback =  do
    ps_comment $ "missing lookup for &#" ++ show i ++ ";" 
    ps_glyphshow fallback