Math.hs

-----------------------------------------------------------------------------
-- Copyright 2019, Advise-Me project team. This file is distributed under 
-- the terms of the Apache License 2.0. For more information, see the files
-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer  :  bastiaan.heeren@ou.nl
-- Stability   :  provisional
-- Portability :  portable (depends on ghc)
--
-- Defines the `Math` type and closely associated functions.
--
-----------------------------------------------------------------------------

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 was moved from Util module
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 -- ^ original parsed string
   , getResult :: Either MathParseError Expr -- ^ Either a parse error or a successfully parsed expression
   } 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 ' ')

-- | Returns the parsed expression or fails
getExpr :: Monad m => Math -> m Expr
getExpr = either (fail . asString) return . getResult

-- | Returns the parsed relation or fails
getRelation :: Monad m => Math -> m (Relation Expr)
getRelation = getExpr >=> getRelationE

-- | Returns the parsed relation or fails
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

-- Some Math symbols
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