module Recognize.Data.Math where
import Control.Monad
import Data.Char
import Data.Either
import Data.List
import Domain.Math.Data.Relation
import Domain.Math.Expr.Data
import Ideas.Common.Rewriting
import Ideas.Text.HTML
import Ideas.Text.HTML.W3CSS
import Ideas.Text.OpenMath.Dictionary.Relation1
import Ideas.Text.XML
import Test.QuickCheck
import Util.Parentheses
import Util.W3CSSHTML
import Util.XML
ppExpr :: Expr -> String
ppExpr (Sym s [x, y]) | s == newSymbol eqSymbol =
show x ++ " = " ++ show y
ppExpr (Sym s xs) | s == chainedEqSymbol = intercalate " = " (map show xs)
ppExpr e = show e
isFunctionDefinition :: Expr -> Bool
isFunctionDefinition (Sym s [Var _]) | isFunctionCallSymbol s = True
isFunctionDefinition _ = False
isDefinition :: Expr -> Bool
isDefinition = (||) <$> isVariable <*> isFunctionDefinition
data Math = M
{ getString :: String
, getResult :: Either MathParseError Expr
} deriving (Eq)
newtype MathParseError = MathParseError { asString :: String }
deriving (Eq)
instance Show MathParseError where
show (MathParseError e) = e
instance Arbitrary MathParseError where
arbitrary = MathParseError <$> arbitraryPrintable
instance ToXML MathParseError where
toXML s = makeXML "MathParseError" (string (asString s))
instance InXML MathParseError where
fromXML e = case name e of
"MathParseError" -> pure $ MathParseError (unescape (getData e))
_ -> fail "Util.Either:InXML.String"
instance ToXML Math where
toXML m = makeXML "math" $ mconcat [ "getString" .=. getString m
, builderXML (getResult m)]
instance InXML Math where
fromXML xml = do
unless (name xml == "math") $ fail "expecting <math> element"
s <- findAttribute "getString" xml
res <- case children xml of
[a] -> fromXML a
_ -> fail "invalid <math> element"
return $ M (unescapeAttr s) res
instance Arbitrary Math where
arbitrary = M <$> arbitraryPrintable <*> arbitrary
instance ToHTML Math where
listToHTML = w3list . map toHTML
toHTML a =
case getExpr a of
Just xs -> string (ppExpr xs)
Nothing -> background Red (string (getString a))
arbitraryPrintable :: Gen String
arbitraryPrintable = listOf (arbitrary `suchThat` isPrint)
mathListHtml :: [Math] -> HTMLBuilder
mathListHtml [] = mempty
mathListHtml xs = (tableAll . w3class "w3-small" . mconcat . make . map toHTML) xs
where
make = map (\x -> tr [td x])
isParseError :: Math -> Bool
isParseError = isLeft . getResult
printMath :: Math -> String
printMath (M s r) = "M { " ++ s ++ ", " ++ show r ++ " }"
instance Show Math where
show x =
case getResult x of
Left _ ->
let msg = if balanced (getString x) then "" else " (unbalanced)"
in "ERROR: " ++ getString x ++ msg
Right e -> show e
makeMath :: Expr -> Math
makeMath e = M (show e) (Right e)
showMathList :: [Math] -> String
showMathList xs = unlines (zipWith f as bs)
where
as = map getString xs
bs = map show xs
n = maximum (map length as)
f x y = ">> " ++ ljustify n x ++ " : " ++ y
ljustify n s = take (n `max` length s) (s ++ repeat ' ')
getExpr :: Monad m => Math -> m Expr
getExpr = either (fail . asString) return . getResult
getRelation :: Monad m => Math -> m (Relation Expr)
getRelation = getExpr >=> getRelationE
getRelationE :: Monad m => Expr -> m (Relation Expr)
getRelationE = isRelation
where
isRelation (Sym s [x, y]) | Just (rel,(_,_)) <- find ((==s).snd.snd) relationSymbols
= return $ makeType rel x y
isRelation _ = fail "not an equation"
getEq :: Monad m => Math -> m (Equation Expr)
getEq = getExpr >=> getEqE
getEqE :: Monad m => Expr -> m (Equation Expr)
getEqE (Sym s [x, y]) | s == newSymbol eqSymbol = return (x :==: y)
getEqE _ = fail "not an equation"
getChainedEq :: Monad m => Math -> m [Expr]
getChainedEq = getExpr >=> isChained
where
isChained (Sym s xs) | s == chainedEqSymbol = return xs
isChained _ = fail "not a chained equation"
isEq :: Expr -> Bool
isEq (Sym s [_,_]) = s == newSymbol eqSymbol
isEq _ = False
chainedEqSymbol :: Symbol
chainedEqSymbol = newSymbol "chained-eq"
functionCallSymbol :: Symbol
functionCallSymbol = newSymbol "function-call"
isChainedEqSymbol :: Symbol -> Bool
isChainedEqSymbol = (== chainedEqSymbol)
isChainedEq :: Expr -> Bool
isChainedEq (Sym s _) = isChainedEqSymbol s
isFunctionCallSymbol :: Symbol -> Bool
isFunctionCallSymbol = (== functionCallSymbol)
isFunctionCall :: Expr -> Bool
isFunctionCall (Sym s _) = isFunctionCallSymbol s
isFunctionCall _ = False