module Text.TeXMath.LaTeX (toTeXMath) where
import Text.TeXMath.Types
import Data.List (intersperse)
import Text.TeXMath.UnicodeToLaTeX (getLaTeX)
import qualified Text.TeXMath.Shared as S
import Data.Maybe (fromMaybe)
import Data.Generics (everywhere, mkT)
toTeXMath :: DisplayType -> [Exp] -> String
toTeXMath _ es = concatMap (writeExp . fixTree) es
square :: [String]
square = ["\\sqrt"]
writeExp :: Exp -> String
writeExp (ENumber s) = getLaTeX s
writeExp (EGrouped es) = concatMap writeExp es
writeExp (EDelimited open close es) =
"\\left" ++
getLaTeX open ++
concatMap writeExp es ++
"\\right" ++
getLaTeX close
writeExp (EIdentifier s) = inBraces $ getLaTeX s
writeExp o@(EMathOperator s) =
fromMaybe ("\\operatorname" ++ (inBraces $ escapeSpace $ getLaTeX s)) (getOperator o)
writeExp (ESymbol _ s) = getLaTeX s
writeExp (ESpace width) = " " ++ S.getSpaceCommand width
writeExp (EBinary s e1 e2)
| s `elem` square = s ++ (evalInSquare e1) ++ (evalInBraces e2) ++ " "
| otherwise = s ++ (evalInBraces e1) ++ (evalInBraces e2) ++ " "
writeExp (ESub b e1) = under b e1
writeExp (ESuper b e1) = over b e1
writeExp (ESubsup b e1 e2) = underOver b e1 e2
writeExp (EOver b e1) =
case b of
(EMathOperator _) -> over b e1
_ -> "\\overset" ++ evalInBraces e1 ++ evalInBraces b
writeExp (EUnder b e1) =
case b of
(EMathOperator _) -> under b e1
_ -> "\\underset" ++ evalInBraces e1 ++ evalInBraces b
writeExp (EUnderover b e1 e2) =
case b of
(EMathOperator _) -> underOver b e1 e2
_ -> writeExp $ EUnder (EOver b e2) e1
writeExp (EUp b e1) = over b e1
writeExp (EDown b e1) = under b e1
writeExp (EDownup b e1 e2) = underOver b e1 e2
writeExp (EUnary s e) = s ++ evalInBraces e
writeExp (EScaled size e) = fromMaybe "" (S.getScalerCommand size) ++ evalInBraces e
writeExp (EStretchy (ESymbol Open e)) =
let e' = getLaTeX e in
case e' of {"" -> ""; _ -> "\\left" ++ e' ++ " "}
writeExp (EStretchy (ESymbol Close e)) =
let e' = getLaTeX e in
case e' of {"" -> ""; _ -> "\\right" ++ e' ++ " "}
writeExp (EStretchy e) = writeExp e
writeExp (EArray aligns rows) = table aligns rows
writeExp (EText ttype s) = getLaTeXTextCommand ttype ++ inBraces (escapeSpace $ getLaTeX s)
table :: [Alignment] -> [ArrayLine] -> String
table as rows = "\\begin{array}" ++ inBraces columnAligns ++ "\n" ++ concatMap row rows ++ "\\end{array}"
where
columnAligns = map alignmentToLetter as
alignmentToLetter AlignLeft = 'l'
alignmentToLetter AlignCenter = 'c'
alignmentToLetter AlignRight = 'r'
alignmentToLetter AlignDefault = 'c'
row :: ArrayLine -> String
row cells = (concat (intersperse " & " (map cell cells))) ++ " \\\\\n"
where
cell es = concatMap writeExp es
formats :: [String]
formats = ["\\mathrm", "\\mathit", "\\mathsf", "\\mathtt", "\\mathfrak", "\\mathcal"]
alts :: [(String, String)]
alts = [ ("\\mathbfit", "\\mathbf"), ("\\mathbfsfup", "\\mathbf"), ("\\mathbfsfit", "\\mathbf")
, ("\\mathbfscr", "\\mathcal"), ("\\mathbffrak", "\\mathfrak"), ("\\mathsfit", "\\mathsf")]
getLaTeXTextCommand :: TextType -> String
getLaTeXTextCommand t
| cmd `elem` formats = cmd
| otherwise = fromMaybe "\\mathrm" (lookup cmd alts)
where
cmd = S.getLaTeXTextCommand t
escapeSpace :: String -> String
escapeSpace = concatMap (\c -> if c == ' ' then "\\ " else [c])
under :: Exp -> Exp -> String
under = bin "_"
over :: Exp -> Exp -> String
over = bin "^"
underOver :: Exp -> Exp -> Exp -> String
underOver b e1 e2 = bin "_" b e1 ++ "^" ++ evalInBraces e2
bin :: String -> Exp -> Exp -> String
bin s b e = evalInBraces b ++ s ++ evalInBraces e
evalInBraces :: Exp -> String
evalInBraces = inBraces . writeExp
inBraces :: String -> String
inBraces = around "{" "}"
around :: String -> String -> String -> String
around o c s = o ++ s ++ c
evalInSquare :: Exp -> String
evalInSquare = around "[" "]" . writeExp
removeAccentStretch :: Exp -> Exp
removeAccentStretch (EStretchy e@(ESymbol Accent _)) = e
removeAccentStretch x = x
reorderDiacritical' :: Position -> Exp -> Exp -> Exp
reorderDiacritical' p b e@(ESymbol Accent a) =
case S.getDiacriticalCommand p a of
Just accentCmd -> EUnary accentCmd b
Nothing -> EBinary def e b
where
def = case p of
Over -> "\\overset"
Under -> "\\underset"
reorderDiacritical' _ _ _ = error "Must be called with Accent"
reorderDiacritical :: Exp -> Exp
reorderDiacritical (EOver b e@(ESymbol Accent _)) =
reorderDiacritical' Over b e
reorderDiacritical (EUnder b e@(ESymbol Accent _)) =
reorderDiacritical' Under b e
reorderDiacritical (EUnderover b e@(ESymbol Accent _) e1) =
reorderDiacritical' Under (EOver b e1) e
reorderDiacritical (EUnderover b e1 e@(ESymbol Accent _)) =
reorderDiacritical' Over (EUnder b e1) e
reorderDiacritical x = x
matchStretch' :: [Exp] -> Int
matchStretch' [] = 0
matchStretch' ((EStretchy (ESymbol Open s)): xs) =
let s' = getLaTeX s in
case s' of {"" -> 0; _ -> 1} + (matchStretch' xs)
matchStretch' ((EStretchy (ESymbol Close s)): xs) =
let s' = getLaTeX s in
case s' of {"" -> 0; _ -> (1)} + (matchStretch' xs)
matchStretch' (_:xs) = matchStretch' xs
matchStretch :: [Exp] -> [Exp]
matchStretch es
| n < 0 = (replicate (0 n) $ EStretchy (ESymbol Open ".")) ++ es
| n > 0 = es ++ (replicate n $ EStretchy (ESymbol Close "."))
| otherwise = es
where
n = matchStretch' es
ms :: Exp -> Exp
ms (EGrouped xs) = EGrouped (matchStretch xs)
ms (EDelimited o c xs) = EDelimited o c (matchStretch xs)
ms (EArray as rs) = EArray as (map (map matchStretch) rs)
ms x = x
fixTree :: Exp -> Exp
fixTree = everywhere
( mkT ms
. mkT reorderDiacritical
. mkT removeAccentStretch )
getOperator :: Exp -> Maybe String
getOperator = flip lookup operators
operators :: [(Exp, String)]
operators =
[ (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") ]