module Recognize.Data.Op where
import Control.Monad
import Domain.Math.Expr
import Ideas.Text.XML
import Ideas.Utils.Prelude (readM)
import Ideas.Utils.Uniplate
import Test.QuickCheck
import Util.XML
data Op = Add Expr | Sub Expr | Mul Expr | Div Expr
deriving (Eq, Ord)
instance Show Op where
show (Add e) = "+" ++ show e
show (Sub e) = "-" ++ show e
show (Mul e) = "*" ++ show e
show (Div e) = "/" ++ show e
instance Read Op where
readsPrec _ ('+':xs) = [(Add (read xs :: Expr), "")]
readsPrec _ ('-':xs) = [(Sub (read xs :: Expr), "")]
readsPrec _ ('*':xs) = [(Mul (read xs :: Expr), "")]
readsPrec _ ('/':xs) = [(Div (read xs :: Expr), "")]
readsPrec _ _ = []
instance Arbitrary Op where
arbitrary = oneof
[ Add <$> arbitrary
, Mul <$> arbitrary
, Div <$> arbitrary
, Sub <$> arbitrary
]
instance ToXML Op where
toXML e = makeXML "op" (text e)
instance InXML Op where
fromXML xml = do
unless (name xml == "op") $ fail "expecting <op> element"
readM (getData xml)
fromOp :: Op -> Expr -> Expr
fromOp (Add v) a = a + v
fromOp (Sub v) a = a - v
fromOp (Mul v) a = a * v
fromOp (Div v) a = a / v
fromOp' :: Op -> Expr -> Expr
fromOp' op@(Mul _) a = nestRight op a
fromOp' op@(Div _) a = nestRight op a
fromOp' op a = fromOp op a
nestRight :: Op -> Expr -> Expr
nestRight op (e1 :+: e2) = e1 :+: nestRight op e2
nestRight op (e1 :*: e2) = e1 :*: nestRight op e2
nestRight op (e1 :-: e2) = e1 :-: nestRight op e2
nestRight op (e1 :/: e2) = e1 :/: nestRight op e2
nestRight op a = fromOp op a
fromOps :: [Op] -> Expr -> Expr
fromOps = flip (foldl (flip fromOp))
substOp :: Expr -> Op -> Op
substOp a (Add v) = Add (substitute a v)
substOp a (Sub v) = Sub (substitute a v)
substOp a (Mul v) = Mul (substitute a v)
substOp a (Div v) = Div (substitute a v)
substitute :: Expr -> Expr -> Expr
substitute a = rec
where
rec (Var "x") = toExpr a
rec expr = descend rec expr
formExpr :: Expr -> Expr -> [Op] -> Expr
formExpr x a ops = fromOps (map (substOp x) ops) a