Ugly and not working function value reduction, main evaluation refactoringHEADmaster

4 files changed, 84 insertions, 81 deletions

diff --git a/src/Evaluation.hs b/src/Evaluation.hs
deleted file mode 100644
index 9b45010..0000000
--- a/src/Evaluation.hs
+++ /dev/null
@@ -1,2 +0,0 @@
-module Evaluation where
-
diff --git a/src/Expr.hs b/src/Expr.hs
index 93828d9..e2cd256 100644
--- a/src/Expr.hs
+++ b/src/Expr.hs
@@ -4,25 +4,6 @@ import           Control.Monad
 import           Data.List
 import qualified Data.Map      as M
 
--- data Operand
---     = Rational Float
---     | Complex Float Float
---     | Matrix [[Operand]]
---
---
--- data (Operable a, Operable b) => Operator a b
---     = Add a b
---     | Sub a b
---     | Mul a b
---     | Div a b
---     | Mod a b
---     | Exp a b
---     | Dot a b
---
--- data Label
---     = Variable String
---     | Function String Expr
-
 data Expr
     = Rational Float  -- values
     | Complex Float Float
@@ -61,47 +42,48 @@ isLitteral (Rational _)  = True
 isLitteral (Complex _ _) = True
 isLitteral _             = False
 
+isIgnored :: Expr -> Bool
+isIgnored (Variable _) = True
+-- isIgnored (Function _ _) = True
+isIgnored (Add _ _) = True
+isIgnored (Sub _ _) = True
+isIgnored (Mul _ _) = True
+isIgnored (Div _ _) = True
+isIgnored (Mod _ _) = True
+isIgnored (Exp _ _) = True
+isIgnored (Dot _ _) = True
+isIgnored _ = False
+
 -------------------------------------------------------------------------------
 -- Operators
 -------------------------------------------------------------------------------
 
 add :: Expr -> Expr -> Maybe Expr
-
 add (Rational a)    (Rational b)    = Just $ Rational (a + b)
 add (Rational a)    (Complex br bi) = Just $ Complex (br + a) bi
-
 add (Complex ar ai) (Complex br bi) = Just $ Complex (ar + br) (ai + bi)
 add (Complex ar ai) (Rational b)    = Just $ Complex (ar + b) ai
-
-add _ _                             = Nothing
-
+add a b                   = ignoreCheck a b Add
 
 sub :: Expr -> Expr -> Maybe Expr
 sub a b = add a =<< Rational (-1) `mul` b
 
-
 mul :: Expr -> Expr -> Maybe Expr
 mul (Rational a) (Rational b)     = Just $ Rational (a * b)
 mul (Rational a) (Complex br bi)  = Just $ Complex (a * br) (a * bi)
-
-
-mul _ _                           = Nothing
-
+mul a b                   = ignoreCheck a b Mul
 
 div :: Expr -> Expr -> Maybe Expr
 div _ (Rational 0)  = Nothing
 div _ (Complex 0 0) = Nothing
 div a b             = mul a =<< b `Expr.exp` Rational (-1)
 
-
 mod :: Expr -> Expr -> Maybe Expr
-mod _ _ = Nothing
-
+mod a b                   = ignoreCheck a b Mod
 
 exp :: Expr -> Expr -> Maybe Expr
 exp (Rational a)  (Rational b) = Just $ Rational (a ** b)
-exp _ _ = Nothing
-
+exp a b                   = ignoreCheck a b Exp
 
 dot :: Expr -> Expr -> Maybe Expr
 dot (Matrix a) (Matrix b)
@@ -113,7 +95,13 @@ dot (Matrix a) (Matrix b)
           dotProd :: [Expr] -> [Expr] -> Maybe Expr
           dotProd r c = foldM add (Rational 0) =<< zipWithM mul r c
 
-dot _ _                   = Nothing
+dot a b                   = ignoreCheck a b Dot
+
+
+ignoreCheck :: Expr -> Expr -> (Expr -> Expr -> Expr) -> Maybe Expr
+ignoreCheck a b constructor
+    | isIgnored a || isIgnored b = Just $ constructor a b
+    | otherwise = Nothing
 
 
 -------------------------------------------------------------------------------
@@ -125,32 +113,57 @@ data Context = Context { variables :: LabelMap Expr
                        , functions :: LabelMap (String, Expr)
                        }
 
-eval :: Expr -> Context -> Maybe Expr
-
-eval (Add e1 e2) c = evalInfix e1 e2 add c
-eval (Sub e1 e2) c = evalInfix e1 e2 sub c
-eval (Mul e1 e2) c = evalInfix e1 e2 mul c
-eval (Div e1 e2) c = evalInfix e1 e2 Expr.div c
-eval (Mod e1 e2) c = evalInfix e1 e2 Expr.mod c
-eval (Exp e1 e2) c = evalInfix e1 e2 Expr.exp c
-eval (Dot e1 e2) c = evalInfix e1 e2 dot c
+evalIgnored :: Expr -> Context -> String -> Maybe Expr
 
-eval (Variable name) c = name `M.lookup` (variables c) >>= (\e -> eval e c)
+evalIgnored (Variable name) c i
+    | name == i = Just $ Variable name
+    | otherwise = name `M.lookup` (variables c) >>= (\e -> evalIgnored e c i)
 
-eval (Function name e) (Context vars funcs) =
-    do arg <- eval e (Context vars funcs)
+evalIgnored (Function name e) (Context vars funcs) i =
+    do arg <- evalIgnored e (Context vars funcs) i
        (argName, functionExpr) <- name `M.lookup` funcs
        let localVars = M.insert argName arg vars
-       eval functionExpr (Context localVars funcs)
+       evalIgnored functionExpr (Context localVars funcs) i
+
+evalIgnored (Matrix m) c i = Matrix <$> mapM (mapM (\e -> evalIgnored e c i)) m
 
-eval (Matrix m) c = Matrix <$> mapM (mapM (\e -> eval e c)) m
+evalIgnored (Add e1 e2) c i = evalIgnoredInfix e1 e2 Add add c i
+evalIgnored (Sub e1 e2) c i = evalIgnoredInfix e1 e2 Sub sub c i
+evalIgnored (Mul e1 e2) c i = evalIgnoredInfix e1 e2 Mul mul c i
+evalIgnored (Div e1 e2) c i = evalIgnoredInfix e1 e2 Div Expr.div c i
+evalIgnored (Mod e1 e2) c i = evalIgnoredInfix e1 e2 Mod Expr.mod c i
+evalIgnored (Exp e1 e2) c i = evalIgnoredInfix e1 e2 Exp Expr.exp c i
+evalIgnored (Dot e1 e2) c i = evalIgnoredInfix e1 e2 Dot dot c i
 
-eval x _
+evalIgnored x _ _
     | isLitteral x = Just x
     | otherwise    = Nothing
 
 
-evalInfix :: Expr -> Expr -> (Expr -> Expr -> Maybe Expr) -> Context -> Maybe Expr
-evalInfix e1 e2 f c = do a <- eval e1 c
-                         b <- eval e2 c
-                         f a b
+evalIgnoredInfix :: Expr -> Expr ->
+        (Expr -> Expr -> Expr) ->
+        (Expr -> Expr -> Maybe Expr) ->
+        Context -> String -> Maybe Expr
+evalIgnoredInfix e1 e2 cons f c i
+
+    | isVariable e1 && varName e1 == i && isVariable e2 && varName e2 == i = Just $ cons e1 e2
+
+    | isVariable e1 && varName e1 == i = evalIgnored e2 c i >>= (\x -> Just $ cons e1 x)
+
+    | isVariable e2 && varName e2 == i = evalIgnored e1 c i >>= (\x -> Just $ cons x e2)
+
+    | otherwise = do a <- evalIgnored e1 c i
+                     b <- evalIgnored e2 c i
+                     f a b
+    where varName (Variable name) = name
+          varName _ = ""
+          isVariable (Variable _) = True
+          isVariable _ = False
+
+
+-- bubbleVariable :: String -> Expr -> Expr -- with tree rotation
+-- bubbleVariable i (Add l r)
+
+
+eval :: Expr -> Context -> Maybe Expr
+eval e c = evalIgnored e c ""
diff --git a/src/Main.hs b/src/Main.hs
index f54cf7a..9a87d99 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -26,32 +26,24 @@ promptLoop context = do
 
 eval :: Statement -> Context -> InputT IO Context
 
-eval (Evaluation e) c = do case E.eval e c of
-                             Just evaluated -> outputStrLn $ show evaluated
-                             Nothing        -> outputStrLn "Error: couldn't evaluate expression"
-                           return c
+eval (Evaluation e) c = evalOutput (E.eval e c) c (id . const)
 
-eval (VariableDeclaration name value) (Context vars funcs) =
-    case E.eval value context of
-        Just e  -> do outputStrLn $ show e
-                      return $ Context (M.insert name e vars) funcs
-        Nothing -> outputStrLn "Error: couldn't evaluate expression" >> return context
-    where context = Context vars funcs
+eval (VariableDeclaration name value) c = evalOutput (E.eval value c) c nextContext
+    where nextContext (Context vs fs) e = Context (M.insert name e vs) fs
 
-eval (FunctionDeclaration name argName e) (Context vars funcs) =
-    -- case evalIgnore e context argName of
-    --     Just e  -> do outputStrLn $ show e
-    --                   return $ Context vars (M.insert name (argName, e) funcs)
-    --     Nothing -> outputStrLn "Error: couldn't evaluate expression" >> return context
-    --
-    -- where context = Context vars funcs
-    return $ Context vars (M.insert name (argName, e) funcs)
+eval (FunctionDeclaration name argName value) c = evalOutput (evalIgnored value c argName) c nextContext
+    where nextContext (Context vs fs) e = Context vs (M.insert name (argName, e) fs)
 
 eval _ c = return c
 -- eval (PolynomEvaluation left right) c = do l <- eval left  -- count number of unknoewn
 --                                            r <- eval right
 
 
+evalOutput :: Maybe Expr -> Context -> (Context -> Expr -> Context) -> InputT IO Context
+evalOutput (Just evaluated) c f = do outputStrLn $ show evaluated
+                                     return $ f c evaluated
+evalOutput Nothing c _ = outputStrLn "Error: couldn't evaluate expression" >> return c
+
 
 putEnv :: Context -> InputT IO Context
 putEnv (Context vars funcs) = do
diff --git a/src/parser/Core.hs b/src/parser/Core.hs
index 64e0b84..85652a0 100644
--- a/src/parser/Core.hs
+++ b/src/parser/Core.hs
@@ -6,12 +6,13 @@ import           Control.Applicative
 import           Data.Char
 
 
-newtype Parser a = Parser { runParser :: String -> Either String (a, String) }
+type Result a = Either String a
+newtype Parser a = Parser { runParser :: String -> Result (a, String) }
 
-runParserStrict :: Parser a -> String -> Either String a
+runParserStrict :: Parser a -> String -> Result a
 runParserStrict p input = case runParser p input of
     Right (a, "")   -> Right a
-    Right (_, rest) -> Left $ "Unconsumed input: \"" ++ rest ++ "\""
+    Right (_, rest) -> Left $ "Unexpected string: \"" ++ rest ++ "\""
     Left err        -> Left err
 
 -------------------------------------------------------------------------------
@@ -43,15 +44,15 @@ instance Monad Parser where
 
 -- instance for Either String so that it can be used in the Alternative for Parser
 instance Alternative (Either String) where
-    -- empty :: Either String a
+    -- empty :: Result a
     empty = Left ""
-    -- (<|>) :: Either String a -> Either String a -> Either String a
+    -- (<|>) :: Result a -> Result a -> Result a
     Left _ <|> x2 = x2
     x1     <|> _  = x1
 
 instance Alternative Parser where
     -- empty :: Parser a
-    empty = Parser (\_ -> Left "Empty")
+    empty = Parser (\_ -> empty)
     -- (<|>) :: Parser a -> Parser a -> Parser a
     (Parser p1) <|> (Parser p2) = Parser $ \s -> p1 s <|> p2 s
 
@@ -111,7 +112,6 @@ varLabelP = (map toLower <$> some (satisfyChar isAlpha)) >>= verify (/= "i")
 funLabelP :: Parser String
 funLabelP = map toLower <$> some (satisfyChar isAlpha)
 
-
 floatP :: Parser Float
 floatP = signed unsignedP
     where