Text.hs

---------------------------------------------------------
-- |
-- Copyright   : (c) alpha 2007
-- License     : BSD-style
--
-- Maintainer  : misc@NOSPAMalpheccar.org
-- Stability   : experimental
-- Portability : portable
--
-- PDF Text
---------------------------------------------------------

module Graphics.PDF.Text(
   -- * Text
   -- ** Types
     PDFFont(..)
   , FontName(..)
   , TextMode(..)
   , PDFText
   , UnscaledUnit
   -- ** Functions
   , drawText
   , text
   , toPDFString
   , startNewLine
   , displayText
   , textStart
   , setFont
   , leading
   , charSpace
   , wordSpace
   , textScale
   , renderMode
   , rise
   , setTextMatrix
   , textWidth
   , getDescent
   , getHeight
   , textBox
 ) where

import Graphics.PDF.LowLevel.Types
import Graphics.PDF.Draw
import Control.Monad.State
import Graphics.PDF.Resources
import qualified Data.ByteString.Lazy as B
import Control.Monad.Writer
import Control.Monad.Trans
import qualified Data.Set as Set
import Graphics.PDF.Coordinates
import Data.Word
import Graphics.PDF.LowLevel.Kern(kerns)
import qualified Data.Map as M(findWithDefault)
import Graphics.PDF.Shapes
import qualified Data.ByteString.Lazy.Char8 as B(words,unwords)

foreign import ccall "ctext.h c_getLeading" cgetLeading :: Int -> Int
foreign import ccall "ctext.h c_getAdvance" cgetAdvance :: Int -> Word8 -> Int
foreign import ccall "ctext.h c_getDescent" cgetDescent :: Int -> Int
foreign import ccall "ctext.h c_hasKern" hasKern :: Int -> Bool

-- pixel size / 2048 gives factor 

-- | Convert a dimension in font unit to device unit
trueSize :: Int -> Int -> PDFFloat
trueSize fontSize textSize = (fromIntegral (textSize*fontSize)) / 1000.0

getDescent :: PDFFont -> PDFFloat
getDescent (PDFFont n s) = trueSize s (cgetDescent (fromEnum n))

getHeight :: PDFFont -> PDFFloat
getHeight (PDFFont n s) = trueSize s (cgetLeading (fromEnum n))

-- | Get the kern value for a given font and pair of charcode
getKern :: (Int,Word8,Word8) -> Int
getKern k = M.findWithDefault 0 k kerns

textWidth :: PDFFont -> PDFString -> PDFFloat
textWidth (PDFFont n s) (PDFString t) = let w = sum . map (cgetAdvance (fromEnum n))  . B.unpack $ t in
 if hasKern (fromEnum n)
   then
      trueSize s (w + (sum . map getKern $ [(fromEnum n,ca,cb) | (ca,cb) <- B.zip t (B.tail t)]))
   else
      trueSize s w
    
type FontState = (Set.Set FontName)

data TextParameter = TextParameter { tc :: !PDFFloat
                                   , tw :: !PDFFloat
                                   , tz :: !PDFFloat
                                   , tl :: !PDFFloat
                                   , ts :: !PDFFloat
                                   , fontState :: FontState
                                   }
defaultParameters :: TextParameter
defaultParameters = TextParameter 0 0 100 0 0 (Set.empty)

-- | Tolerance value when text is too long. We accept to overflow a little
tolerance :: PDFFloat
tolerance = 0.2

-- | Format a text string inside a rectangle. Experimental and will be replaced by a better typesetting
-- system in a next version
textBox :: PDFFont -- ^ Font to use
        -> PDFString -- ^ Text to draw
        -> Rectangle -- ^ Where to draw
        -> Draw ()
textBox f@(PDFFont _ size) (PDFString s) (Rectangle xa _ xb yb) = do
    let width = xb -xa
        ws = textWidth f (toPDFString " ")
        getLines _ l [] = [B.unwords . reverse $ l]
        getLines c l (h:t) = let c' = c + ws + textWidth f (PDFString h) in
                             if c' > width + tolerance * (fromIntegral size)
                                 then
                                     (B.unwords . reverse $ l):getLines 0 [] (h:t)
                                 else
                                     getLines c' (h:l) t
    drawText $ do
        setFont f
        leading $ getHeight f
        textStart xa (yb + getDescent f)
        startNewLine
        mapM_ (\x -> displayText x >> startNewLine) (map PDFString . getLines 0 [] $ (B.words s))
    
     
     
-- | The text monad 
newtype PDFText a = PDFText {unText :: WriterT B.ByteString (State TextParameter) a}          
#ifndef __HADDOCK__                    
  deriving(Monad,Functor,MonadWriter B.ByteString)
#else
instance Monad PDFText
instance Functor PDFText
instance MonadWriter B.ByteString PDFText
#endif
    
instance MonadPath PDFText

-- | Unscaled unit (not scaled by the font size)
type UnscaledUnit = PDFFloat  

-- | Rendering mode for text display
data TextMode = FillText
              | StrokeText
              | FillAndStrokeText
              | InvisibleText
              | FillTextAndAddToClip
              | StrokeTextAndAddToClip
              | FillAndStrokeTextAndAddToClip
              | AddToClip
              deriving(Eq,Ord,Enum)

-- | Select a font to use
setFont :: PDFFont -> PDFText ()
setFont (PDFFont n size) = PDFText $ do
    lift (modifyStrict $ \s -> s {fontState = Set.insert n (fontState s)})
    writeCmd $ "\n/" ++ (show n) ++ " " ++ (show size) ++ " Tf"
  
-- | Draw a text in the draw monad
drawText :: PDFText a
         -> Draw a
drawText t = do
    let ((a,w),s) = (runState . runWriterT . unText $ t) defaultParameters
    mapM_ addFontRsrc (Set.elems (fontState s))
    writeCmd "\nBT"
    tell w
    writeCmd "\nET"
    return a
 where
   addFontRsrc f = modifyStrict $ \s -> s { rsrc = addResource (PDFName "Font") (PDFName (show f)) (toRsrc (PDFFont f 0)) (rsrc s)}
   
-- | Set position for the text beginning
textStart :: PDFFloat
          -> PDFFloat
          -> PDFText ()
textStart x y = writeCmd $ "\n" ++ (show x) ++ " " ++ (show y) ++ " Td"         

-- | Display some text
displayText :: PDFString
            -> PDFText ()
displayText t = do
    tell . toPDF $ t
    writeCmd " Tj"

 
-- | Start a new line (leading value must have been set)
startNewLine :: PDFText ()
startNewLine = writeCmd "\nT*"    

-- | Set leading value
leading :: UnscaledUnit -> PDFText ()
leading v = PDFText $ do
    lift (modifyStrict $ \s -> s {tl = v})
    writeCmd $ "\n" ++ (show v) ++ " TL"

-- | Set the additional char space
charSpace :: UnscaledUnit -> PDFText ()
charSpace v = PDFText $ do
    lift (modifyStrict $ \s -> s {tc = v})
    writeCmd $ "\n" ++ (show v) ++ " Tc"

-- | Set the additional word space
wordSpace :: UnscaledUnit -> PDFText ()
wordSpace v = PDFText $ do
    lift (modifyStrict $ \s -> s {tw = v})
    writeCmd $ "\n" ++ (show v) ++ " Tw"

-- | Set scaling factor for text
textScale :: PDFFloat -> PDFText ()
textScale v = PDFText $ do
    lift (modifyStrict $ \s -> s {tz = v})
    writeCmd $ "\n" ++ (show v) ++ " Tz"

-- | Choose the text rendering mode
renderMode :: TextMode -> PDFText ()
renderMode v = writeCmd $ "\n" ++ (show . fromEnum $ v) ++ " Tr"

-- | Set the rise value
rise :: UnscaledUnit -> PDFText ()
rise v = PDFText $ do
    lift (modifyStrict $ \s -> s {ts = v})
    writeCmd $ "\n" ++ (show v) ++ " Ts"

-- | Set the text transformation matrix
setTextMatrix :: Matrix -> PDFText()
setTextMatrix (Matrix a b c d e f) = 
    writeCmd $ "\n" ++ show (a) ++ " " ++ show (b) ++ " " ++ show (c) ++ " " ++ show (d) ++ " " ++ show (e) ++ " " ++ show (f) ++ " Tm"

-- | Utility function to quickly display one line of text
text :: PDFFont
     -> PDFFloat
     -> PDFFloat
     -> PDFString
     -> PDFText ()
text f x y t = do
    setFont f
    textStart x y
    displayText t