content: {-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
  {-
  Copyright (C) 2014 Matthew Pickering <matthewtpickering@gmail.com>
  
  This program is free software; you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation; either version 2 of the License, or
  (at your option) any later version.
  
  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.
  
  You should have received a copy of the GNU General Public License
  along with this program; if not, write to the Free Software
  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  -}
  module Text.TeXMath.Shared
    ( getMMLType
    , getTextType
    , getLaTeXTextCommand
    , getScalerCommand
    , getScalerValue
    , scalers
    , getSpaceWidth
    , getSpaceChars
    , getDiacriticalCommand
    , diacriticals
    , getOperator
    , readLength
    , fixTree
    , isEmpty
    , empty
    , handleDownup
    , isUppercaseGreek
    , toPrimes
    , isRLSequence
    ) where
  
  
  import Text.TeXMath.Types
  import Text.TeXMath.TeX
  import qualified Data.Map as M
  import qualified Data.Set as Set
  import qualified Data.Text as T
  import Data.Maybe (fromMaybe)
  import Data.Ratio ((%))
  import Data.List (sort)
  import Control.Monad (guard)
  import Text.Parsec (Parsec, parse, getInput, digit, char, many1, option)
  import Data.Generics (everywhere, mkT)
  
  -- As we constuct from the bottom up, this situation can occur.
  removeNesting :: Exp -> Exp
  removeNesting (EDelimited o c [Right (EDelimited "" "" xs)]) = EDelimited o c xs
  removeNesting (EDelimited "" "" [x]) = either (ESymbol Ord) id x
  removeNesting (EGrouped [x]) = x
  removeNesting x = x
  
  removeEmpty :: [Exp] -> [Exp]
  removeEmpty xs = filter (not . isEmpty) xs
  
  -- | An empty group of expressions
  empty :: Exp
  empty = EGrouped []
  
  -- | Test to see whether an expression is @empty@.
  isEmpty :: Exp -> Bool
  isEmpty (EGrouped []) = True
  isEmpty _ = False
  
  -- | Walks over a tree of expressions, removing empty expressions, and
  -- fixing delimited expressions with no delimiters and unnecessarily
  -- grouped expressions.
  fixTree :: Exp -> Exp
  fixTree = everywhere (mkT removeNesting) . everywhere (mkT removeEmpty)
  
  -- | Maps TextType to the corresponding MathML mathvariant
  getMMLType :: TextType -> T.Text
  getMMLType t = fromMaybe "normal" (fst <$> M.lookup t textTypesMap)
  
  -- | Maps TextType to corresponding LaTeX command
  getLaTeXTextCommand :: Env -> TextType -> T.Text
  getLaTeXTextCommand e t =
    let textCmd = fromMaybe "\\mathrm"
                    (snd <$> M.lookup t textTypesMap) in
    if textPackage textCmd e
      then textCmd
      else fromMaybe "\\mathrm" (M.lookup textCmd alts)
  
  -- | Maps MathML mathvariant to the corresponing TextType
  getTextType :: T.Text -> TextType
  getTextType s = fromMaybe TextNormal (M.lookup s revTextTypesMap)
  
  -- | Maps a LaTeX scaling command to the percentage scaling
  getScalerCommand :: Rational -> Maybe T.Text
  getScalerCommand width =
    case sort [ (w, cmd) | (cmd, w) <- scalers, w >= width ] of
         ((_,cmd):_) -> Just cmd
         _           -> Nothing
    -- note, we don't use a Map here because we need the first
    -- match:  \Big, not \Bigr
  
  -- | Gets percentage scaling from LaTeX scaling command
  getScalerValue :: T.Text -> Maybe Rational
  getScalerValue command = lookup command scalers
  
  -- | Given a diacritical mark, returns the corresponding LaTeX command
  getDiacriticalCommand  :: Position -> T.Text -> Maybe T.Text
  getDiacriticalCommand pos symbol = do
    command <- M.lookup symbol diaMap
    let below = command `elem` under
    case pos of
      Under -> if below then Just command else Nothing
      Over -> if not below then Just command else Nothing
    where
      diaMap = M.fromList diacriticals
  
  -- Operator Table
  
  getOperator :: Exp -> Maybe TeX
  getOperator op = fmap ControlSeq $ M.lookup op operators
  
  operators :: M.Map Exp T.Text
  operators = M.fromList
             [ (EMathOperator "arccos", "\\arccos")
             , (EMathOperator "arcsin", "\\arcsin")
             , (EMathOperator "arctan", "\\arctan")
             , (EMathOperator "arg", "\\arg")
             , (EMathOperator "cos", "\\cos")
             , (EMathOperator "cosh", "\\cosh")
             , (EMathOperator "cot", "\\cot")
             , (EMathOperator "coth", "\\coth")
             , (EMathOperator "csc", "\\csc")
             , (EMathOperator "deg", "\\deg")
             , (EMathOperator "det", "\\det")
             , (EMathOperator "dim", "\\dim")
             , (EMathOperator "exp", "\\exp")
             , (EMathOperator "gcd", "\\gcd")
             , (EMathOperator "hom", "\\hom")
             , (EMathOperator "inf", "\\inf")
             , (EMathOperator "ker", "\\ker")
             , (EMathOperator "lg", "\\lg")
             , (EMathOperator "lim", "\\lim")
             , (EMathOperator "liminf", "\\liminf")
             , (EMathOperator "limsup", "\\limsup")
             , (EMathOperator "ln", "\\ln")
             , (EMathOperator "log", "\\log")
             , (EMathOperator "max", "\\max")
             , (EMathOperator "min", "\\min")
             , (EMathOperator "Pr", "\\Pr")
             , (EMathOperator "sec", "\\sec")
             , (EMathOperator "sin", "\\sin")
             , (EMathOperator "sinh", "\\sinh")
             , (EMathOperator "sup", "\\sup")
             , (EMathOperator "tan", "\\tan")
             , (EMathOperator "tanh", "\\tanh") ]
  
  -- | Attempts to convert a string into
  readLength :: T.Text -> Maybe Rational
  readLength s = do
    (n, unit) <- case (parse parseLength "" s) of
                    Left _ -> Nothing
                    Right v -> Just v
    (n *) <$> unitToMultiplier unit
  
  
  parseLength :: Parsec T.Text () (Rational, T.Text)
  parseLength = do
      neg <- option "" ((:[]) <$> char '-')
      dec <- many1 digit
      frac <- option "" ((:) <$> char '.' <*> many1 digit)
      unit <- getInput
      -- This is safe as dec and frac must be a double of some kind
      case reads (neg ++ dec ++ frac) of
         [(n :: Double, [])] -> return (round (n * 18) % 18, unit)
         _ -> fail $ "Could not parse " ++ neg ++ dec ++ frac ++ " as Double"
  
  textTypesMap :: M.Map TextType (T.Text, T.Text)
  textTypesMap = M.fromList textTypes
  
  revTextTypesMap :: M.Map T.Text TextType
  revTextTypesMap = M.fromList $ map (\(k, (v,_)) -> (v,k)) textTypes
  
  --TextType to (MathML, LaTeX)
  textTypes :: [(TextType, (T.Text, T.Text))]
  textTypes =
    [ ( TextNormal       , ("normal", "\\mathrm"))
    , ( TextBold         , ("bold", "\\mathbf"))
    , ( TextItalic       , ("italic","\\mathit"))
    , ( TextMonospace    , ("monospace","\\mathtt"))
    , ( TextSansSerif    , ("sans-serif","\\mathsf"))
    , ( TextDoubleStruck , ("double-struck","\\mathbb"))
    , ( TextScript       , ("script","\\mathcal"))
    , ( TextFraktur      , ("fraktur","\\mathfrak"))
    , ( TextBoldItalic          , ("bold-italic","\\mathbfit"))
    , ( TextSansSerifBold       , ("bold-sans-serif","\\mathbfsfup"))
    , ( TextSansSerifBoldItalic , ("sans-serif-bold-italic","\\mathbfsfit"))
    , ( TextBoldScript          , ("bold-script","\\mathbfscr"))
    , ( TextBoldFraktur         , ("bold-fraktur","\\mathbffrak"))
    , ( TextSansSerifItalic     , ("sans-serif-italic","\\mathsfit")) ]
  
  unicodeMath, base :: Set.Set T.Text
  unicodeMath = Set.fromList
    ["\\mathbfit", "\\mathbfsfup", "\\mathbfsfit", "\\mathbfscr",
     "\\mathbffrak", "\\mathsfit"]
  base = Set.fromList
    ["\\mathbb", "\\mathrm", "\\mathbf", "\\mathit", "\\mathsf",
     "\\mathtt", "\\mathfrak", "\\mathcal"]
  
  alts :: M.Map T.Text T.Text
  alts = M.fromList
    [ ("\\mathbfit", "\\mathbf")
    , ("\\mathbfsfup", "\\mathbf")
    , ("\\mathbfsfit", "\\mathbf")
    , ("\\mathbfscr", "\\mathcal")
    , ("\\mathbffrak", "\\mathfrak")
    , ("\\mathsfit", "\\mathsf")
    ]
  
  textPackage :: T.Text -> [T.Text] -> Bool
  textPackage s e
    | s `Set.member` unicodeMath = "unicode-math" `elem` e
    | s `Set.member` base    = True
    | otherwise = True
  
  -- | Mapping between LaTeX scaling commands and the scaling factor
  scalers :: [(T.Text, Rational)]
  scalers =
            [ ("\\bigg", widthbigg)
            , ("\\biggl", widthbigg)
            , ("\\biggr", widthbigg)
            , ("\\Bigg", widthBigg)
            , ("\\Biggl", widthBigg)
            , ("\\Biggr", widthBigg)
            , ("\\big", widthbig)
            , ("\\bigl", widthbig)
            , ("\\bigr", widthbig)
            , ("\\Big", widthBig)
            , ("\\Bigl", widthBig)
            , ("\\Bigr", widthBig)
            ]
    where widthbig = 6 / 5
          widthBig = 9 / 5
          widthbigg = 12 / 5
          widthBigg = 3
  
  -- | Returns the space width for a unicode space character, or Nothing.
  getSpaceWidth :: Char -> Maybe Rational
  getSpaceWidth ' '      = Just (4/18)
  getSpaceWidth '\xA0'   = Just (4/18)
  getSpaceWidth '\x2000' = Just (1/2)
  getSpaceWidth '\x2001' = Just 1
  getSpaceWidth '\x2002' = Just (1/2)
  getSpaceWidth '\x2003' = Just 1
  getSpaceWidth '\x2004' = Just (1/3)
  getSpaceWidth '\x2005' = Just (4/18)
  getSpaceWidth '\x2006' = Just (1/6)
  getSpaceWidth '\x2007' = Just (1/3) -- ? width of a digit
  getSpaceWidth '\x2008' = Just (1/6) -- ? width of a period
  getSpaceWidth '\x2009' = Just (1/6)
  getSpaceWidth '\x200A' = Just (1/9)
  getSpaceWidth '\x200B' = Just 0
  getSpaceWidth '\x202F' = Just (3/18)
  getSpaceWidth '\x205F' = Just (4/18)
  getSpaceWidth _        = Nothing
  
  -- | Returns the sequence of unicode space characters closest to the
  -- specified width.
  getSpaceChars :: Rational -> T.Text
  getSpaceChars r
    | n < 0 = "\x200B" -- no negative space chars in unicode
    | otherwise = fracSpaces f <> emQuads n
    where
      (n, f) = properFraction r
      emQuads x = T.replicate x "\x2001"
      fracSpaces x
        | x <= 2/18 = "\x200A"
        | x <= 3/18 = "\x2006"
        | x <= 4/18 = "\xA0"   -- could also be "\x2005"
        | x <= 5/18 = "\x2005"
        | x <= 7/18 = "\x2004"
        | x <= 9/18 = "\x2000"
        | otherwise = T.cons '\x2000' $ fracSpaces (x - (1/2))
  
  -- Accents which go under the character
  under :: [T.Text]
  under = ["\\underbrace", "\\underline", "\\underbar", "\\underbracket"]
  
  -- | Mapping between unicode combining character and LaTeX accent command
  diacriticals :: [(T.Text, T.Text)]
  diacriticals =
                 [ ("\x00B4", "\\acute")
                 , ("\x0301", "\\acute")
                 , ("\x0060", "\\grave")
                 , ("\x0300", "\\grave")
                 , ("\x02D8", "\\breve")
                 , ("\x0306", "\\breve")
                 , ("\x02C7", "\\check")
                 , ("\x030C", "\\check")
                 , ("\x307", "\\dot")
                 , ("\x308", "\\ddot")
                 , ("\x20DB", "\\dddot")
                 , ("\x20DC", "\\ddddot")
                 , ("\x00B0", "\\mathring")
                 , ("\x030A", "\\mathring")
                 , ("\x20D7", "\\vec")
                 , ("\x20D7", "\\overrightarrow")
                 , ("\x20D6", "\\overleftarrow")
                 , ("\x005E", "\\hat")
                 , ("\x02C6", "\\widehat")
                 , ("\x0302", "\\widehat")
                 , ("\x02DC", "\\widetilde")
                 , ("\x0303", "\\tilde")
                 , ("\x0303", "\\widetilde")
                 , ("\x0304", "\\bar")
                 , ("\x203E", "\\bar")
                 , ("\x23DE", "\\overbrace")
                 , ("\x23B4", "\\overbracket") -- Only availible in mathtools
                 , ("\x00AF", "\\overline")
                 , ("\x0305", "\\overline")
                 , ("\x23DF", "\\underbrace")
                 , ("\x23B5", "\\underbracket") -- mathtools
                 , ("\x0332", "\\underline")
                 , ("_", "\\underline")
                 , ("\x0333", "\\underbar")
                 ]
  
  
  
  
  -- Converts unit to multiplier to reach em
  unitToMultiplier :: T.Text -> Maybe Rational
  unitToMultiplier s = M.lookup s units
    where
      units = M.fromList  [ ( "pt" , 10)
                          , ( "mm" , (351/10))
                          , ( "cm" , (35/100))
                          , ( "in" , (14/100))
                          , ( "ex" , (232/100))
                          , ( "em" , 1)
                          , ( "mu" , 18)
                          , ( "dd" , (93/100))
                          , ( "bp" , (996/1000))
                          , ( "pc" , (83/100)) ]
  
  handleDownup :: DisplayType -> Exp -> Exp
  handleDownup DisplayInline (EUnder True x y)       = ESub x y
  handleDownup DisplayInline (EOver True x y)        = ESuper x y
  handleDownup DisplayInline (EUnderover True x y z) = ESubsup x y z
  handleDownup DisplayBlock  (EUnder True x y)       = EUnder False x y
  handleDownup DisplayBlock  (EOver True x y)        = EOver False  x y
  handleDownup DisplayBlock  (EUnderover True x y z) = EUnderover False x y z
  handleDownup _             x                       = x
  
  isUppercaseGreek :: T.Text -> Bool
  isUppercaseGreek t = not (T.null t) && T.all isUGreek t
   where
    isUGreek c = c >= '\x0391' && c <= '\x03A9'
  
  toPrimes :: Exp -> Maybe T.Text
  toPrimes (ESymbol ty s) | ty == Pun || ty == Ord = go s
   where
    go t =
      case T.uncons t of
        Nothing -> Just ""
        Just ('\'', t') -> ("'" <>) <$> go t'
        Just ('\x2032', t') -> ("'" <>) <$> go t'
        Just ('\x2033', t') -> ("''" <>) <$> go t'
        Just ('\x2034', t') -> ("'''" <>) <$> go t'
        Just ('\x2057', t') -> ("''''" <>) <$> go t'
        _ -> Nothing
  toPrimes _ = Nothing
  
  isRLSequence :: [Alignment] -> Bool
  isRLSequence [AlignRight, AlignLeft] = True
  isRLSequence (AlignRight : AlignLeft : as) = isRLSequence as
  isRLSequence _ = False
  