{-# LANGUAGE OverloadedStrings #-}

-- | Process content stream operators maintaining graphics state
--
-- It is pretty experimental

module Pdf.Content.Processor
(
  Processor(..),
  GraphicsState(..),
  GlyphDecoder,
  Glyph(..),
  Span(..),
  initialGraphicsState,
  mkProcessor,
  processOp
)
where

import Pdf.Core
import Pdf.Core.Object.Util
import Pdf.Core.Util

import Pdf.Content.Ops
import Pdf.Content.Transform

import Data.ByteString (ByteString)
import Data.Text (Text)
import qualified Data.Scientific as Scientific
import qualified Data.Vector as Vector
import Control.Monad

-- | Given font name and string, it should return list of glyphs
-- and their widths.
--
-- Note: it should not try to position or scale glyphs to user space,
-- bounding boxes should be defined in glyph space.
--
-- Note: glyph width is a distance between the glyph's origin and
-- the next glyph's origin, so it generally can't be calculated
-- from bounding box
--
-- Note: the 'Processor' actually doesn't cares about glyph's
-- bounding box, so you can return anything you want
type GlyphDecoder = Name -> ByteString -> [(Glyph, Double)]

-- | Glyph
data Glyph = Glyph {
  -- | The code as read from content stream
  glyphCode :: Int,
  -- | Top-left corner of glyph's bounding box
  glyphTopLeft :: Vector Double,
  -- | Bottom-right corner of glyph's bounding box
  glyphBottomRight :: Vector Double,
  -- | Text ectracted from the glyph
  glyphText :: Maybe Text
  }
  deriving Show

-- | Graphics state
data GraphicsState = GraphicsState {
  gsInText :: Bool,    -- ^ Indicates that we are inside text object
  gsCurrentTransformMatrix :: Transform Double,
  gsFont :: Maybe Name,
  gsFontSize :: Maybe Double,
  gsTextMatrix :: Transform Double,      -- ^ Defined only inside text object
  gsTextLineMatrix :: Transform Double,  -- ^ Defined only inside text object
  gsTextLeading :: Double,
  gsTextCharSpacing :: Double,
  gsTextWordSpacing :: Double
  }
  deriving Show

-- | Empty graphics state
initialGraphicsState :: GraphicsState
initialGraphicsState = GraphicsState {
  gsInText = False,
  gsCurrentTransformMatrix = identity,
  gsFont = Nothing,
  gsFontSize = Nothing,
  gsTextMatrix = identity,
  gsTextLineMatrix = identity,
  gsTextLeading = 0,
  gsTextCharSpacing = 0,
  gsTextWordSpacing = 0
  }

-- | Glyphs drawn in one shot
data Span = Span
  { spGlyphs :: [Glyph]
  , spFontName :: Name
  }

-- | Processor maintains graphics state
data Processor = Processor {
  prState :: GraphicsState,
  prStateStack :: [GraphicsState],
  prGlyphDecoder :: GlyphDecoder,
  prSpans :: [Span]
  -- ^ Each element is a list of glyphs, drawn in one shot
  }

-- | Create processor in initial state
mkProcessor :: Processor
mkProcessor = Processor {
  prState = initialGraphicsState,
  prStateStack = [],
  prGlyphDecoder = \_ _ -> [],
  prSpans = mempty
  }

-- | Process one operation
processOp :: Operator -> Processor -> Either String Processor

processOp (Op_q, []) p = Right p {prStateStack = prState p : prStateStack p}
processOp (Op_q, args) _ = Left ("Op_q: wrong number of arguments: "
                                ++ show args)

processOp (Op_Q, []) p =
  case prStateStack p of
    [] -> Left "Op_Q: state is empty"
    (x:xs) -> Right p {prState = x, prStateStack = xs}
processOp (Op_Q, args) _ = Left ("Op_Q: wrong number of arguments: "
                                ++ show args)

processOp (Op_BT, []) p = do
  ensureInTextObject False p
  let gstate = prState p
  return p {prState = gstate {
    gsInText = True,
    gsTextMatrix = identity,
    gsTextLineMatrix = identity
    }}
processOp (Op_BT, args) _ = Left ("Op_BT: wrong number of arguments: "
                                  ++ show args)

processOp (Op_ET, []) p = do
  ensureInTextObject True p
  let gstate = prState p
  return p {prState = gstate {
    gsInText = False
    }}
processOp (Op_ET, args) _ = Left ("Op_ET: wrong number of arguments: "
                                  ++ show args)

processOp (Op_Td, [txo, tyo]) p = do
  ensureInTextObject True p
  tx <- realValue txo `notice` "Td: x should be a real value"
  ty <- realValue tyo `notice` "Td: y should be a real value"
  let gstate = prState p
      tm = translate tx ty $ gsTextLineMatrix gstate
  Right p {prState = gstate {
    gsTextMatrix = tm,
    gsTextLineMatrix = tm
    }}
processOp (Op_Td, args) _ = Left ("Op_Td: wrong number of arguments: "
                                  ++ show args)

processOp (Op_TD, [txo, tyo]) p = do
  l <- realValue tyo `notice` "TD: y should be a real value"
  p' <- processOp (Op_TL, [Number $ Scientific.fromFloatDigits $ negate l]) p
  processOp (Op_Td, [txo, tyo]) p'
processOp (Op_TD, args) _ = Left ("Op_TD: wrong number of arguments: "
                                  ++ show args)

processOp (Op_Tm, [a', b', c', d', e', f']) p = do
  ensureInTextObject True p
  a <- realValue a' `notice` "Tm: a should be a real value"
  b <- realValue b' `notice` "Tm: b should be a real value"
  c <- realValue c' `notice` "Tm: c should be a real value"
  d <- realValue d' `notice` "Tm: d should be a real value"
  e <- realValue e' `notice` "Tm: e should be a real value"
  f <- realValue f' `notice` "Tm: f should be a real value"
  let gstate = prState p
      tm = Transform a b c d e f
  return p {prState = gstate {
    gsTextMatrix = tm,
    gsTextLineMatrix = tm
    }}
processOp (Op_Tm, args) _ = Left ("Op_Tm: wrong number of arguments: "
                                  ++ show args)

processOp (Op_T_star, []) p = do
  ensureInTextObject True p
  let gstate = prState p
      l = gsTextLeading gstate
  processOp (Op_TD, map (Number . Scientific.fromFloatDigits) [0, negate l]) p
processOp (Op_T_star, args) _ = Left ("Op_T_star: wrong number of arguments: "
                                      ++ show args)

processOp (Op_TL, [lo]) p = do
  l <- realValue lo `notice` "TL: l should be a real value"
  let gstate = prState p
  return p {prState = gstate {
    gsTextLeading = l
    }}
processOp (Op_TL, args) _ = Left ("Op_TL: wrong number of arguments: "
                                  ++ show args)

processOp (Op_cm, [a', b', c', d', e', f']) p = do
  a <- realValue a' `notice` "cm: a should be a real value"
  b <- realValue b' `notice` "cm: b should be a real value"
  c <- realValue c' `notice` "cm: c should be a real value"
  d <- realValue d' `notice` "cm: d should be a real value"
  e <- realValue e' `notice` "cm: e should be a real value"
  f <- realValue f' `notice` "cm: f should be a real value"
  let gstate = prState p
      ctm = Transform a b c d e f `multiply` gsCurrentTransformMatrix gstate
  return p {prState = gstate {
    gsCurrentTransformMatrix = ctm
    }}
processOp (Op_cm, args) _ = Left ("Op_cm: wrong number of arguments: "
                                  ++ show args)

processOp (Op_Tf, [fontO, szO]) p = do
  font <- nameValue fontO `notice` "Tf: font should be a name"
  sz <- realValue szO `notice` "Tf: size should be a real value"
  let gstate = prState p
  return p {prState = gstate {
    gsFont = Just font,
    gsFontSize = Just sz
    }}
processOp (Op_Tf, args) _ = Left ("Op_Tf: wrong number of agruments: "
                                  ++ show args)

processOp (Op_Tj, [String str]) p = do
  let gstate = prState p
  fontName <-
    case gsFont gstate of
      Nothing -> Left "Op_Tj: font not set"
      Just fn -> return fn
  fontSize <-
    case gsFontSize gstate of
      Nothing -> Left "Op_Tj: font size not set"
      Just fs -> return fs
  let (tm, glyphs) = positionGlyghs
                       fontSize
                       (gsCurrentTransformMatrix gstate)
                       (gsTextMatrix gstate)
                       (gsTextCharSpacing gstate)
                       (gsTextWordSpacing gstate)
                       (prGlyphDecoder p fontName str)
  let sp = Span
        { spGlyphs = glyphs
        , spFontName = fontName
        }
  return p {
    prSpans = sp : prSpans p,
    prState = gstate {
      gsTextMatrix = tm
      }
    }
processOp (Op_Tj, args) _ = Left ("Op_Tj: wrong number of agruments:"
                                  ++ show args)

processOp (Op_TJ, [Array array]) p = do
  let gstate = prState p
  fontName <-
    case gsFont gstate of
      Nothing -> Left "Op_Tj: font not set"
      Just fn -> return fn
  fontSize <-
    case gsFontSize gstate of
      Nothing -> Left "Op_Tj: font size not set"
      Just fs -> return fs
  let (textMatrix, glyphs) = loop (gsTextMatrix gstate) []
                                  (Vector.toList array)
        where
        loop tm res [] = (tm, reverse res)
        loop tm res (String str : rest) =
          let (tm', gs) = positionGlyghs fontSize
                                         (gsCurrentTransformMatrix gstate)
                                         tm
                                         (gsTextCharSpacing gstate)
                                         (gsTextWordSpacing gstate)
                                         (prGlyphDecoder p fontName str)
          in loop tm' (gs : res) rest
        loop tm res (Number n : rest) =
          let d = Scientific.toRealFloat n
          in loop (translate (-d * fontSize / 1000) 0 tm) res rest
        loop tm res (_:rest) = loop tm res rest

  let mkSpan gs = Span
        { spGlyphs = gs
        , spFontName = fontName
        }
  return p {
    prSpans = reverse (map mkSpan glyphs) ++ prSpans p,
    prState = gstate {
      gsTextMatrix = textMatrix
      }
    }
processOp (Op_TJ, args) _ = Left ("Op_TJ: wrong number of agruments:"
                                  ++ show args)

processOp (Op_Tc, [o]) p = do
  spacing <- realValue o `notice` "Tc: spacing should be a real value"
  let gstate = prState p
  return p {
    prState = gstate {
      gsTextCharSpacing = spacing
      }
    }
processOp (Op_Tc, args) _ = Left ("Op_Tc: wrong number of agruments:"
                                  ++ show args)

processOp (Op_Tw, [o]) p = do
  spacing <- realValue o `notice` "Tw: spacing should be a real value"
  let gstate = prState p
  return p {
    prState = gstate {
      gsTextWordSpacing = spacing
      }
    }
processOp (Op_Tw, args) _ = Left ("Op_Tw: wrong number of agruments:"
                                  ++ show args)

processOp (Op_apostrophe, [o]) p = do
  p' <- processOp (Op_T_star, []) p
  processOp (Op_Tj, [o]) p'
processOp (Op_apostrophe, args) _ =
  Left ("Op_apostrophe: wrong number of agruments:" ++ show args)

processOp _ p = return p

ensureInTextObject :: Bool -> Processor -> Either String ()
ensureInTextObject inText p =
  unless (inText == gsInText (prState p)) $
    Left $ "ensureInTextObject: expected: " ++ show inText ++ ", found: "
          ++ show (gsInText $ prState p)

positionGlyghs :: Double
               -> Transform Double
               -> Transform Double
               -> Double
               -> Double
               -> [(Glyph, Double)]
               -> (Transform Double, [Glyph])
positionGlyghs fontSize ctm textMatrix charSpacing wordSpacing
  = go textMatrix []
  where
  go tm res [] = (tm, reverse res)
  go tm res ((g, width):gs) =
    let g' = g {
          glyphTopLeft = transform (multiply tm ctm) topLeft,
          glyphBottomRight = transform (multiply tm ctm) bottomRight
          }
        topLeft = transform (scale fontSize fontSize) $ glyphTopLeft g
        bottomRight = transform (scale fontSize fontSize) $ glyphBottomRight g
        spacing = charSpacing + case glyphText g of
                                  Just " " -> wordSpacing
                                  _ -> 0
        tm' = translate (width * fontSize + spacing) 0 tm
    in go tm' (g':res) gs