Added polynom solver from computorv1, Added matrix multipilcation

8 files changed, 239 insertions, 124 deletions

diff --git a/src/Evaluation.hs b/src/Evaluation.hs
index db2c2b2..9b45010 100644
--- a/src/Evaluation.hs
+++ b/src/Evaluation.hs
@@ -1,37 +1,2 @@
 module Evaluation where
 
-import           Data.Map as M
-
-import           Expr     as E
-
-
-type LabelMap a = Map String a
-data Context = Context { variables :: LabelMap Expr
-                       , functions :: LabelMap (String, Expr)
-                       }
-
-eval :: Context -> Expr -> Maybe Expr
-
-eval c (Add e1 e2) = evalInfix c e1 e2 add
-eval c (Sub e1 e2) = evalInfix c e1 e2 sub
-eval c (Mul e1 e2) = evalInfix c e1 e2 mul
-eval c (Div e1 e2) = evalInfix c e1 e2 E.div
-eval c (Mod e1 e2) = evalInfix c e1 e2 E.mod
-eval c (Exp e1 e2) = evalInfix c e1 e2 E.exp
-eval c (Dot e1 e2) = evalInfix c e1 e2 dot
-
-eval c (Variable name) = name `M.lookup` (variables c) >>= eval c
-
-eval (Context vars funcs) (Function name e) =
-    do arg <- eval (Context vars funcs) e
-       (argName, functionExpr) <- name `M.lookup` funcs
-       let localVars = insert argName arg vars
-       eval (Context localVars funcs) functionExpr
-
-eval c x = Just x
-
-
-evalInfix :: Context -> Expr -> Expr -> (Expr -> Expr -> Maybe Expr) -> Maybe Expr
-evalInfix c e1 e2 f = do a <- eval c e1
-                         b <- eval c e2
-                         f a b
diff --git a/src/Expr.hs b/src/Expr.hs
index 2e38d61..96c2fe6 100644
--- a/src/Expr.hs
+++ b/src/Expr.hs
@@ -1,6 +1,9 @@
 module Expr where
 
 import           Data.List
+import qualified Data.Map  as M
+import Control.Monad
+
 
 data Expr
     = Rational Float
@@ -35,6 +38,11 @@ instance Show Expr where
     show (Matrix rows)     = intercalate "\n" $ map showRow rows
         where showRow r = "[ " ++ (intercalate ", " $ map show r) ++ " ]"
 
+isLitteral :: Expr -> Bool
+isLitteral (Rational _)  = True
+isLitteral (Imaginary _) = True
+isLitteral (Complex _ _) = True
+isLitteral _             = False
 
 -------------------------------------------------------------------------------
 -- Operators
@@ -99,5 +107,53 @@ exp _ _ = Nothing
 
 
 dot :: Expr -> Expr -> Maybe Expr
-dot (Matrix a) (Matrix b) = undefined
+dot (Matrix a) (Matrix b)
+    | shape a == shape bT = Matrix <$> mapM (\ai -> mapM (dotProd ai) bT) a
+    | otherwise           = Nothing
+    where bT = transpose b
+          shape m = [length m, length (head m)]
+
+          dotProd :: [Expr] -> [Expr] -> Maybe Expr
+          dotProd r c = foldM add (Rational 0) =<< zipWithM mul r c
+
 dot _ _                   = Nothing
+
+
+-------------------------------------------------------------------------------
+-- Evaluation
+-------------------------------------------------------------------------------
+
+type LabelMap a = M.Map String a
+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
+
+eval (Variable name) c = name `M.lookup` (variables c) >>= (\e -> eval e c)
+
+eval (Function name e) (Context vars funcs) =
+    do arg <- eval e (Context vars funcs)
+       (argName, functionExpr) <- name `M.lookup` funcs
+       let localVars = M.insert argName arg vars
+       eval functionExpr (Context localVars funcs)
+
+eval (Matrix m) c = Matrix <$> mapM (mapM (\e -> eval e c)) m
+
+eval 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
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
index 0000000..1f99b39
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,61 @@
+import           Data.Char
+import qualified Data.Map         as M
+import           System.IO
+
+import           Expr             as E
+import           Parser.Core
+import           Parser.Statement
+
+
+main :: IO ()
+main = promptLoop (Context M.empty M.empty)
+
+promptLoop :: Context -> IO ()
+promptLoop context = do
+    putStr "> "
+    hFlush stdout
+    eof <- isEOF
+    if eof
+        then return ()
+        else do line <- getLine
+                if line /= "exit"
+                   then loop line context >>= promptLoop
+                   else return ()
+
+loop :: String -> Context -> IO Context
+loop input context =
+    do
+        case runParserStrict statementP (filter (not . isSpace) input) of
+            Left err -> putStrLn ("Error parsing: " ++ err) >> return context
+            Right s  -> Main.eval s context
+
+
+
+eval :: Statement -> Context -> IO Context
+
+eval (Evaluation e) c = do case E.eval e c of
+                             Just evaluated -> putStrLn $ show evaluated
+                             Nothing        -> putStrLn "Error: couldn't evaluate expression"
+                           return c
+
+eval (VariableDeclaration name value) (Context vars funcs) =
+    case E.eval value context of
+        Just e  -> do putStrLn $ show e
+                      return $ Context (M.insert name e vars) funcs
+        Nothing -> putStrLn "Error: couldn't evaluate expression" >> return context
+    where context = Context vars funcs
+
+eval (FunctionDeclaration name argName e) (Context vars funcs) =
+    -- case evalIgnore e context argName of
+    --     Just e  -> do putStrLn $ show e
+    --                   return $ Context vars (M.insert name (argName, e) funcs)
+    --     Nothing -> putStrLn "Error: couldn't evaluate expression" >> return context
+    --
+    -- where context = Context vars funcs
+    return $ Context vars (M.insert name (argName, e) funcs)
+
+eval _ c = return c
+-- eval (PolynomEvaluation left right) c = do l <- eval left  -- count number of unknoewn
+--                                            r <- eval right
+
+
diff --git a/src/Polynomial.hs b/src/Polynomial.hs
new file mode 100644
index 0000000..15922e9
--- /dev/null
+++ b/src/Polynomial.hs
@@ -0,0 +1,90 @@
+module Equation
+( Equation (..)
+, Polynomial
+, Term (..)
+, degree
+, reduce
+, solve
+, filterNull
+) where
+
+import           Data.List
+
+
+data Equation = Equation { left :: Polynomial, right :: Polynomial }
+type Polynomial = [Term]
+data Term = Term { coefficient :: Float, exponent :: Int }
+
+instance Eq Term where
+    (Term _ e1) == (Term _ e2) = e1 == e2
+
+instance Ord Term where
+    compare (Term _ e1) (Term _ e2) = compare e1 e2
+
+instance Show Term where
+    show (Term 0 _) = ""
+    show (Term c 0) = show c
+    show (Term c e) = show c ++ " * X^" ++ show e
+
+instance Show Equation where
+    show (Equation l r) = showPolynomial (filterNull l)
+                          ++ " = "
+                          ++ showPolynomial (filterNull r)
+        where showPolynomial [] = "0"
+              showPolynomial p  = dropWhile (`elem` " +") $ foldl f "" (map show p)
+                where f s "" = s
+                      f s (c:cs)
+                        | c == '-'  = s ++ " - " ++ cs
+                        | otherwise = s ++ " + " ++ (c:cs)
+
+
+filterNull :: Polynomial -> Polynomial
+filterNull = filter (\t -> coefficient t /= 0)
+
+equationMap :: (Polynomial -> Polynomial) -> Equation -> Equation
+equationMap f (Equation l r) = Equation (f l) (f r)
+
+degree :: Polynomial -> Int
+degree [] = 0
+degree p  = Equation.exponent (maximum p)
+
+reduce :: Equation -> Equation
+reduce equ = Equation (merge (left stdForm) (right stdForm)) []
+
+    where stdForm = equationMap (\a -> (reducePolynomial $ sort a)) equ
+
+          merge :: [Term] -> [Term] -> [Term]
+          merge [] rs = rs
+          merge ls [] = ls
+          merge (l:ls) (r:rs)
+            | l == r = (subTerm l r) : merge ls rs
+            | l < r  = l : merge ls (r:rs)
+            | r < l  = r : merge (l:ls) rs
+            where subTerm (Term c1 e) (Term c2 _) = Term (c1 - c2) e
+          merge _ _ = undefined
+
+          reducePolynomial []         = []
+          reducePolynomial [t]        = [t]
+          reducePolynomial (t1:t2:ts)
+            | t1 == t2  = (addTerm t1 t2) : reducePolynomial ts
+            | otherwise = t1 : reducePolynomial (t2:ts)
+            where addTerm (Term c1 e) (Term c2 _) = Term (c1 + c2) e
+
+solveDegree2 :: Float -> Float -> Float -> [Float]
+solveDegree2 a b c
+    | phi < 0   = []
+    | phi == 0  = [(-b) / (2.0 * a)]
+    | phi > 0   = [ (-b + sqrt phi) / (2.0 * a)
+                  , (-b - sqrt phi) / (2.0 * a)
+                  ]
+    where phi = b * b - 4.0 * a * c
+solveDegree2 _ _ _= undefined
+
+solveDegree1 :: Float -> Float -> Float
+solveDegree1 b c = -c / b
+
+solve :: Polynomial -> [Float]
+solve [_]          = []
+solve [t0, t1]     = [solveDegree1 (coefficient t1) (coefficient t0)]
+solve [t0, t1, t2] = solveDegree2 (coefficient t2) (coefficient t1) (coefficient t0)
+solve _            = undefined
diff --git a/src/main.hs b/src/main.hs
deleted file mode 100644
index 58c8ea7..0000000
--- a/src/main.hs
+++ /dev/null
@@ -1,52 +0,0 @@
-import           Data.Char
-import qualified Data.Map         as M
-import           System.IO
-
-import           Evaluation       as E
-import           Expr
-import           Parser.Core
-import           Parser.Expr
-import           Parser.Statement
-
-
-main :: IO ()
-main = promptLoop (Context M.empty M.empty)
-
-promptLoop :: Context -> IO ()
-promptLoop context = do
-    putStr "> "
-    hFlush stdout
-    line <- getLine
-    return ()
-    if line /= "q"
-       then loop line context >>= promptLoop
-       else return ()
-
-loop :: String -> Context -> IO Context
-loop input context =
-    do
-        statement <- case runParserStrict statementP (filter (not . isSpace) input) of
-                        Left err -> fail ("Error: " ++ err)
-                        Right s  -> return s
-        Main.eval context statement
-
-
-eval :: Context -> Statement -> IO Context
-
-eval c (Evaluation e) = do case E.eval c e of
-                             Just evaluated -> putStrLn $ show evaluated
-                             Nothing        -> putStrLn "Error: couldn't evaluate expression"
-                           return c
-
-eval (Context vars funcs) (VariableDeclaration name e) =
-    case E.eval context e of
-        Just evaluated -> return $ Context (M.insert name e vars) funcs
-        Nothing        -> putStrLn "Error: couldn't evaluate expression" >> return context
-    where context = Context vars funcs
-
-eval (Context vars funcs) (FunctionDeclaration name argName e) =
-    -- case E.eval context e of
-        -- Just evaluated -> return $ Context vars (M.insert name (argName, e) funcs)
-        -- Nothing        -> putStrLn "Error: couldn't evaluate expression" >> return context
-        return $ Context vars (M.insert name (argName, e) funcs)
-    -- where context = Context vars funcs
diff --git a/src/parser/Core.hs b/src/parser/Core.hs
index 08ac1a9..5928fe4 100644
--- a/src/parser/Core.hs
+++ b/src/parser/Core.hs
@@ -3,9 +3,9 @@
 module Parser.Core where
 
 import           Control.Applicative
-import           Control.Monad
 import           Data.Char
 
+
 newtype Parser a = Parser { runParser :: String -> Either String (a, String) }
 
 runParserStrict :: Parser a -> String -> Either String a
@@ -76,12 +76,6 @@ string s = sequenceA $ char <$> s
 sepBy :: Parser a -> Parser b -> Parser [a]
 sepBy x sepatator = (:) <$> x <*> (many (sepatator *> x))
 
--- sepByMap :: (b -> a -> a) -> Parser b -> Parser a -> Parser [a]
--- sepByMap f sep x = (:) <$> x <*> (many (f <$> sep <*> x))
-
--- chainl :: Parser a -> Parser (a -> a -> a) -> a -> Parser a
--- chainl p op a = chainl1 p op <|> pure a
-
 -- Parse one or more occurences of p separated by op
 -- Apply op in a left associative maner on each value in p
 chainl1 :: Parser a -> Parser (a -> a -> a) -> Parser a
@@ -106,8 +100,13 @@ choice :: [Parser a] -> Parser a
 choice []     = empty
 choice (p:ps) = p <|> choice ps
 
-alphaStringP :: Parser String
-alphaStringP = some (satisfyChar isAlpha)
+-- verify :: (a -> Bool) -> Parser a -> Parser a
+-- verify predicate p = do a <- p
+--                         if predicate a then p else Parser (\_ -> Left "Bonjour")
+
+-- Parse a string of alpha character, converted to lower case
+labelP :: Parser String
+labelP = (map toLower) <$> some (satisfyChar isAlpha)
 
 
 floatP :: Parser Float
@@ -116,7 +115,7 @@ floatP = signed unsignedP
         unsignedP :: Parser Float
         unsignedP = read <$> p
             where p = do pos <- digitsP
-                         char '.'
+                         _ <- char '.'
                          dec <- digitsP
                          return (pos ++ "." ++ dec)
                       <|> digitsP
@@ -124,7 +123,7 @@ floatP = signed unsignedP
                   digitsP = some $ satisfyChar isDigit -- at least one digit to avoid read exception
 
         signed :: Num a => Parser a -> Parser a
-        signed p = do char '-'
+        signed p = do _ <- char '-'
                       x <- p
                       return (-x)
                      <|> p
diff --git a/src/parser/Expr.hs b/src/parser/Expr.hs
index 6a721f8..221d669 100644
--- a/src/parser/Expr.hs
+++ b/src/parser/Expr.hs
@@ -1,4 +1,4 @@
-module Parser.Expr where
+module Parser.Expr (exprP) where
 
 import Control.Applicative
 
@@ -6,20 +6,6 @@ import Parser.Core
 import Expr
 
 
-imaginaryP :: Parser Expr
-imaginaryP = Imaginary <$> (floatP <* char 'i')
-
-rationalP :: Parser Expr
-rationalP = Rational <$> floatP
-
--- Parse a matrix in the following format:
--- [ [a, b]; [c, d] ]
-matrixP :: Parser Expr
-matrixP = Matrix <$> brackets (matrixRowP `sepBy` (char ';'))
-    where matrixRowP = brackets (exprP `sepBy` (char ','))
-          brackets = between "[" "]"
-
-
 -- Parse expression separated by one infix operator of the operator list
 operatorChoiceChain :: Parser a -> [Parser (a -> a -> a)] -> Parser a
 operatorChoiceChain x operators = x `chainl1` choice operators
@@ -42,12 +28,19 @@ termP =  operatorChoiceChain factorP
 factorP :: Parser Expr
 factorP =  choice [ parenthesizedExprP
                   , imaginaryP
-                  , rationalP
+                  , Rational <$> floatP
                   , matrixP
-                  , functionP
-                  , variableP
+                  , Function <$> labelP <*> parenthesizedExprP
+                  , Variable <$> labelP
                   ] `chainl1` (infixOp "^" Exp)
+    where
+        parenthesizedExprP = parenthesis exprP
+
+        imaginaryP = Imaginary <$> (floatP <|> pure 1.0) <* char 'i'
 
-    where variableP = Variable <$> alphaStringP
-          functionP = Function <$> alphaStringP <*> parenthesizedExprP
-          parenthesizedExprP = parenthesis exprP
+        -- Parse a matrix in the following format:
+        -- [ [a, b]; [c, d] ]
+        matrixP :: Parser Expr
+        matrixP = Matrix <$> brackets (matrixRowP `sepBy` (char ';'))
+            where matrixRowP = brackets (exprP `sepBy` (char ','))
+                  brackets = between "[" "]"
diff --git a/src/parser/Statement.hs b/src/parser/Statement.hs
index ca16eca..889f24f 100644
--- a/src/parser/Statement.hs
+++ b/src/parser/Statement.hs
@@ -9,19 +9,22 @@ import           Parser.Expr
 
 data Statement
     = Evaluation Expr
+    | PolynomEvaluation Expr Expr
     | VariableDeclaration String Expr
     | FunctionDeclaration String String Expr
 
 statementP :: Parser Statement
-statementP = functionDeclarationP <|> variableDeclarationP <|> evaluationP
+statementP = functionDeclarationP <|> variableDeclarationP <|> polynomEvaluationP <|> evaluationP
     where
         functionDeclarationP = FunctionDeclaration
-                                    <$> alphaStringP
-                                    <*> parenthesis alphaStringP
+                                    <$> labelP
+                                    <*> parenthesis labelP
                                     <*> (char '=' *> exprP)
 
         variableDeclarationP = VariableDeclaration
-                                    <$> alphaStringP
+                                    <$> labelP
                                     <*> (char '=' *> exprP)
 
+        polynomEvaluationP   = PolynomEvaluation <$>  exprP <*> (char '=' *> exprP <* char '?')
+
         evaluationP          = Evaluation <$> exprP <* char '=' <* char '?'