MathML.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}
module EqManips.InputParser.MathML ( mathMlToEqLang
                                   , mathMlToEqLang'
                                   ) where

import Control.Applicative
import EqManips.Algorithm.Utils
import qualified EqManips.UnicodeSymbols as Uni

import Text.XML.HaXml.Parse
import Text.XML.HaXml.Types

-- | Type used to reduce the complexity of XML
-- tree and favor an easier pattern matching
data ReducedXmlTree =
      Xop String
    | Xsymb String
    | Xnum String
    | Xsqrt ReducedXmlTree
    | Xfrac ReducedXmlTree ReducedXmlTree
    | Xsup ReducedXmlTree ReducedXmlTree
    | XunderOver ReducedXmlTree ReducedXmlTree ReducedXmlTree
    | Xfenced String String ReducedXmlTree
    | Xrow [ReducedXmlTree]
    | Xtable [[ReducedXmlTree]]
    deriving (Show)

mathMlToEqLang' :: String -> String
mathMlToEqLang' = either id id . mathMlToEqLang

-- | Input XML code encoded in a string
-- output a string in Eq Language, ready to
-- be parsed by the usual meanings.
mathMlToEqLang :: String -> Either String String
mathMlToEqLang text =
    xmlParse' "mathml" text >>= simplifyXml >>= toProgramString

toProgramString :: ReducedXmlTree -> Either String String
toProgramString tree = (\s -> s "") <$> translate tree

simplifyXml :: Document a -> Either String ReducedXmlTree
simplifyXml (Document a b (Elem "m:math" c lst) l) =
    simplifyXml (Document a b (Elem "math" c lst) l)
simplifyXml (Document _ _ (Elem "math" _ lst) _) =
    Xrow <$> eitherMap (map simplifyContent lst)
simplifyXml _ = error "The xml document has the wrong format"

strOfContent :: Content a -> String
strOfContent (CString _ txt _) = txt
strOfContent _ = error "Xml string waited at this point"

elemOfContent :: Content a -> Element a
elemOfContent (CElem e _) = e
elemOfContent _ = error "Xml element waited at this point"

-- | Helper to simplify content
simplifyContent :: Content a -> Either String ReducedXmlTree
simplifyContent = simplify . elemOfContent

instance Applicative (Either a) where
    pure = Right
    (<*>) (Left a) _ = Left a
    (<*>) (Right _) (Left b) = Left b
    (<*>) (Right f) (Right v) = Right (f v)

instance Monad (Either a) where
    return = Right
    (>>=) (Left a) _ = Left a
    (>>=) (Right v) f = f v

eitherMap :: [Either a b] -> Either a [b]
eitherMap [] = Right []
eitherMap lst = foldr mapper (Right []) lst
    where mapper (Left a) _ = Left a
          mapper _ (Left a) = Left a
          mapper (Right v) (Right list) = Right (v:list)

-- | Really transform an XML file to a simplified tree
-- to make a better pattern matching
simplify :: Element a -> Either String ReducedXmlTree
-- This rule is for mathML generated by microsoft math input
-- panel whom got the bad habit of prefixing it by 'm:'
simplify (Elem ('m':':':xs) att cont) = simplify (Elem xs att cont)
simplify (Elem "mi" _ [c]) = Right . Xsymb $ strOfContent c
simplify (Elem "mn" _ [c]) = Right . Xnum $ strOfContent c
simplify (Elem "mo" _ [c]) = Right . Xop $ strOfContent c
simplify (Elem "mrow" _ lst) = Xrow <$> eitherMap (map simplifyContent lst)
simplify (Elem "msqrt" _ lst) = Xsqrt . Xrow <$> eitherMap (map simplifyContent lst)
simplify (Elem "mfrac" _ [a,b]) = Xfrac <$> simplifyContent a <*> simplifyContent b
simplify (Elem "msup" _ [a,b]) = Xsup <$> simplifyContent a <*> simplifyContent b
simplify (Elem "munderover" _ [a,b,c]) = 
    XunderOver <$> simplifyContent a <*> simplifyContent b <*> simplifyContent c

simplify (Elem "mtable" _ lst) = Xtable <$> lineList
    where lineList = eitherMap $ map (unrow . elemOfContent) lst

          unrow (Elem "m:mtr" a b) = unrow (Elem "mtr" a b)
          unrow (Elem "mtr" _ cells) = eitherMap $ map (uncell . elemOfContent) cells
          unrow _ = Left "Ill formed MathML Matrix"

          uncell (Elem "m:mtd" a b) = uncell (Elem "mtd" a b)
          uncell (Elem "mtd" _ cellList) = Xrow <$> eitherMap (map simplifyContent cellList)
          uncell _ = Left "Ill format MathML Matrix cell"

simplify (Elem "mfenced" [ ("open", AttValue [Left openChar])
                         , ("close", AttValue [Left closeChar]) ] lst) =

    Xfenced openChar closeChar . Xrow <$> eitherMap (map simplifyContent lst)

simplify (Elem "mfenced" attrs _lst) = Left $ show attrs
    
simplify (Elem elemName _ _) = Left $ "Unknown MathMl element : " ++ elemName

str :: String -> String -> String
str = (++)

char :: Char -> String -> String
char = (:)

uniSymbolTranslation :: [(Int, String)]
uniSymbolTranslation =
    [ (Uni.pi, "pi")
    , (Uni.infinity, "infinite") 
    ]

unicodeTranslation :: [(Int, String)]
unicodeTranslation =
    [ (Uni.logicalAnd, "&&")
    , (Uni.logicalOr, "||")
    , (Uni.logicalNot, "not")
    , (Uni.identicalTo, "==")
    , (Uni.lessThanOrEqualTo, "<=")
    , (Uni.greaterThanOrEqualTo, ">=")
    , (Uni.multiplicationSign , "*")
    ]

vardeclFinder :: [ReducedXmlTree]
              -> Maybe ([ReducedXmlTree],[ReducedXmlTree], String)
vardeclFinder = declFind []
    where declFind   _ [] = Nothing
          declFind acc (Xop [op]:next) 
            | fromEnum op == Uni.doubleStruckItalicSmalld = obtainVar acc next
          declFind acc (Xsymb ['d']:next) = obtainVar acc next
          declFind acc (Xsymb ['d', var]:next) = Just (reverse acc, next, [var])
          declFind acc (Xrow lst:next) = declFind acc (lst ++ next)
          declFind acc (x:xs) = declFind (x:acc) xs

          obtainVar _ [] = Nothing
          obtainVar acc (Xsymb var:next) = Just (reverse acc, next, var)
          obtainVar acc (Xrow lst:next) = obtainVar acc (lst ++ next)
          obtainVar _ _ = Nothing

-- | Real transformation =)
translate :: ReducedXmlTree -> Either String ShowS
translate (Xop [s]) = case lookup (fromEnum s) unicodeTranslation of
       Nothing -> Right $ char s
       Just v -> Right $ str v

translate (Xsymb [s]) = case lookup (fromEnum s) uniSymbolTranslation of
       Nothing -> Right $ char s
       Just v -> Right $ str v

-- Special case to handle matrix
translate (Xfenced op en body@(Xtable _)) 
    | (op == "(" && en == ")") || (op == "[" && en == "]") = translate body
translate (Xfenced op en (Xrow [body@(Xtable _)]))
    | (op == "(" && en == ")") || (op == "[" && en == "]") = translate body

translate (Xfenced "(" ")" body) =
    (\sub -> char '(' . sub . char ')') <$> translate body
translate (Xfenced "|" "|" body) =
    (\sub -> str "abs(" . sub . char ')') <$> translate body
translate (Xfenced str1 str2 body) =
    (\sub -> shows body . str str1 . sub . str str2) <$> translate body

translate (Xrow ((XunderOver (Xop [bigop]) lowerBound upperBound):rs))
    | fromEnum bigop == Uni.sum =
        (\ini end what -> str "sum(" . ini . char ',' . end . char ','
                                     . what . char ')')
                <$> translate lowerBound
                <*> translate upperBound
                <*> translate (Xrow rs)
    | fromEnum bigop == Uni.product =
        (\ini end what -> str "product(" . ini . char ',' . end . char ','
                                         . what . char ')')
                <$> translate lowerBound
                <*> translate upperBound
                <*> translate (Xrow rs)
    | fromEnum bigop == Uni.integral = case vardeclFinder rs of
            Nothing -> Left "Invalid integral definition, cannot be handled"
            Just (acc,rest,var) ->
                (\lower upper what rest' ->
                    str "integrate(" . lower . char ',' . upper
                                     . char ',' . what . char ',' 
                                     . str var . char ')' . rest')
                    <$> translate lowerBound
                    <*> translate upperBound
                    <*> translate (Xrow acc)
                    <*> translate (Xrow rest)
    | otherwise = Left "Unrecognized big operator"

translate (XunderOver _ _ _) = Left "Unrecognized operator"
translate (Xop s) = Right $ str s
translate (Xsymb s) = Right $ str s
translate (Xnum s) = Right $ str s
translate (Xsqrt subTree) = (\sub -> str "sqrt(" . sub . char ')')
                         <$> translate subTree 
translate (Xfrac a b) = (\a' b' -> char '(' . a' . str ") / (" . b' . char ')')
                     <$> translate a 
                     <*> translate b

translate (Xsup a b) = (\a' b' -> char '(' . a' . str ") ^ (" . b' . char ')')
                    <$> translate a 
                    <*> translate b

translate (Xrow []) = Right id
translate (Xrow lst) = concatS <$> eitherMap (map translate lst)

translate (Xtable []) = Left "Wrong table format"
translate (Xtable lst) =
    (\elems -> str "matrix( " . shows lineCount . char ',' . shows columncount . char ','
                              . interspereseS (char ',') elems . char ')')
        <$> (eitherMap . map translate $ concat lst) 
    where lineCount = length lst
          columncount = length $ head lst