Initial commit based on computorv1

2 files changed, 194 insertions, 0 deletions

diff --git a/src/equation.hs b/src/equation.hs
new file mode 100644
index 0000000..f332131
--- /dev/null
+++ b/src/equation.hs
@@ -0,0 +1,95 @@
+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 e) = ""
+    show (Term c 0) = show (round c)
+    show (Term c e) = show (round 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 [] 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
+          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 + mySqrt phi) / (2.0 * a) -- not alowed
+                  , (-b - mySqrt phi) / (2.0 * a)
+                  ]
+    where phi = b * b - 4.0 * a * c
+
+solveDegree1 :: Float -> Float -> Float
+solveDegree1 b c = -c / b
+
+solve :: Polynomial -> [Float]
+solve [t0]         = []
+solve [t0, t1]     = [solveDegree1 (coefficient t1) (coefficient t0)]
+solve [t0, t1, t2] = solveDegree2 (coefficient t2) (coefficient t1) (coefficient t0)
+solve _            = undefined
+
+mySqrt :: Float -> Float
+mySqrt n
+  | n < 0     = undefined
+  | otherwise = mySqrt' (n / 2)
+    where mySqrt' x = if abs (x * x - n) < 0.01
+                         then x
+                         else mySqrt' xn
+            where xn = b - (a * a) / (2 * b)
+                    where a = (n - x * x) / (2 * x)
+                          b = x + a
diff --git a/src/parser.hs b/src/parser.hs
new file mode 100644
index 0000000..d523001
--- /dev/null
+++ b/src/parser.hs
@@ -0,0 +1,99 @@
+module Parser
+( parse
+, equationP
+) where
+
+import Control.Applicative
+import Control.Monad
+import Data.Char
+
+import Equation
+
+
+newtype Parser a = Parser (String -> Maybe (a, String))
+
+parse :: Parser a -> String -> Maybe (a, String)
+parse (Parser p) input = p input
+
+instance Functor Parser where
+    -- fmap :: (a -> b) -> Parser a -> Parser b
+    fmap f (Parser p) = Parser new_p
+        where new_p s = do
+                (x, s') <- p s
+                return (f x, s')
+
+instance Applicative Parser where
+    -- pure :: a -> Parser a
+    pure x = Parser (\s -> Just (x, s))
+    -- (<*>) :: Parser (a -> b) -> Parser a -> Parser b
+    (Parser p1) <*> (Parser p2) = Parser new_p
+        where new_p s = do
+                (f, s') <- p1 s
+                (x, s'') <- p2 s'
+                return (f x, s'')
+
+instance Alternative Parser where
+    -- empty :: Parser a
+    empty = Parser (\_ -> Nothing)
+    -- (<|>) :: Parser a -> Parser a -> Parser a
+    (Parser p1) <|> (Parser p2) = Parser new_p
+        where new_p s = p1 s <|> p2 s
+
+
+satisfy :: (Char -> Bool) -> Parser Char
+satisfy f = Parser p
+    where p []     = Nothing
+          p (c:cs) = if f c then Just (c, cs)
+                            else Nothing
+
+charP :: Char -> Parser Char
+charP c = satisfy (c ==)
+
+digitsP :: Parser String
+digitsP = some (satisfy isDigit) -- at least one digit to avoid read exception
+
+spacesP :: Parser String
+spacesP = many (satisfy isSpace)
+
+sepBy :: Parser b -> Parser a -> Parser [a]
+sepBy sep x = many (sep *> x)
+
+naturalP :: Parser Int
+naturalP = read <$> digitsP
+
+floatPositiveP :: Parser Float
+floatPositiveP = (f <$> digitsP <*> charP '.' <*> digitsP) <|> (read <$> digitsP)
+    where f pos dot dec = read $ pos ++ [dot] ++ dec
+
+-- Equation parsers
+
+unsignedTermP :: Parser Term
+unsignedTermP = fullP <|> varExpP <|> varConstP <|> constP
+    where
+        -- 1 * X ^ 1
+        fullP     = (\c e -> Term c e) <$> floatPositiveP <* mulP <* varP <* expP <*> naturalP
+        -- X ^ 1
+        varExpP   = (\e -> Term 1 e)   <$> (varP *> expP *> naturalP)
+        -- 1 * X
+        varConstP = (\c -> Term c 1)   <$> floatPositiveP <* mulP <* varP
+        -- 1
+        constP    = (\c -> Term c 0)   <$> floatPositiveP
+
+        mulP = spacesP *> charP '*' *> spacesP
+        varP = spacesP *> charP 'X' *> spacesP
+        expP = spacesP *> charP '^' *> spacesP
+
+signedTermP :: Parser Term
+signedTermP = signF <$> signP <* spacesP <*> unsignedTermP
+    where signP = charP '-' <|> charP '+'
+          signF '-' (Term c e) = Term (-c) e
+          signF _   t          = t
+
+polynomialP :: Parser Polynomial
+polynomialP = (:) <$> firstTermP <* spacesP <*> (sepBy spacesP signedTermP)
+    where firstTermP = signedTermP <|> unsignedTermP
+
+equationP :: Parser Equation
+equationP = (\l r -> Equation l r)
+             <$> polynomialP
+             <*> (spacesP *> charP '=' *> spacesP *> polynomialP)