From 37e52bff39a1fe4d442cb253773252030c1cab8a Mon Sep 17 00:00:00 2001 From: Charles Date: Thu, 12 Mar 2020 14:23:01 +0100 Subject: Basic expression parsing --- src/complex.hs | 17 +++++++ src/equation.hs | 95 ---------------------------------- src/expr.hs | 24 +++++++++ src/manifest | 31 ++++++++++++ src/matrix.hs | 10 ++++ src/parser.hs | 138 +++++++++++++++++++++++++++++++------------------- src/parser/complex.hs | 0 src/parser/matrix.hs | 0 src/polynomial.hs | 95 ++++++++++++++++++++++++++++++++++ src/rational.hs | 3 ++ 10 files changed, 265 insertions(+), 148 deletions(-) create mode 100644 src/complex.hs delete mode 100644 src/equation.hs create mode 100644 src/expr.hs create mode 100644 src/manifest create mode 100644 src/matrix.hs create mode 100644 src/parser/complex.hs create mode 100644 src/parser/matrix.hs create mode 100644 src/polynomial.hs create mode 100644 src/rational.hs diff --git a/src/complex.hs b/src/complex.hs new file mode 100644 index 0000000..220fe1f --- /dev/null +++ b/src/complex.hs @@ -0,0 +1,17 @@ +module Complex where + +type Imaginary = Float + +data Complex = Complex Float Imaginary + +-- instance Num Complex where +-- (Complex r1 i1) + (Complex r2 i2) = Complex (r1 + r2) (i1 + i2) +-- (Complex r1 i1) * (Complex r2 i2) = undefined +-- negate (Complex r1 i1) = undefined +-- abs (Complex r1 i1) = undefined +-- signum (Complex r1 i1) = undefined + -- fromInteger r = Complex r 0 + +instance Show Complex where + show (Complex r i) = show r ++ showI ++ "i" + where showI = if i < 0 then " - " ++ show (-i) else " + " ++ show i diff --git a/src/equation.hs b/src/equation.hs deleted file mode 100644 index f332131..0000000 --- a/src/equation.hs +++ /dev/null @@ -1,95 +0,0 @@ -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/expr.hs b/src/expr.hs new file mode 100644 index 0000000..3cada63 --- /dev/null +++ b/src/expr.hs @@ -0,0 +1,24 @@ +module Expr where + +-- data X = Expr | Imag | Matrix + +data Expr = Expr Term Expr | ExprSingle Term +data Term = Term Factor Term | TermSingle Factor +data Factor = Factor Base Factor | FactorSingle Base +data Base = Base Expr | BaseSingle Float + +instance Show Expr where + show (ExprSingle t) = show t + show (Expr t e) = show t ++ " + " ++ show e + +instance Show Term where + show (TermSingle f) = show f + show (Term f t) = show f ++ " * " ++ show t + +instance Show Factor where + show (FactorSingle b) = show b + show (Factor b f) = show b ++ " ^ " ++ show f + +instance Show Base where + show (BaseSingle x) = show x + show (Base e) = "( " ++ show e ++ " )" diff --git a/src/manifest b/src/manifest new file mode 100644 index 0000000..dc03948 --- /dev/null +++ b/src/manifest @@ -0,0 +1,31 @@ +Data struct: + - expression + - matrix + - complex + + - polynomial + +State Data struct: + - function + - variable + + +1. ( ) +2. ^ +3. * / % ** +4. + - + +expr ::= (+ | -) | +term ::= (* | / | % | **)? | -- default to '*' +factor ::= '^' | +base ::= '(' ')' | ( | | ) + +imag ::= '*'? 'i' +real ::= [0-9]+ + +matrix ::= '[' ( ';')* ']' +line ::= '[' ( ',')* ']' + +func ::= [a-zA-Z]+ '(' ')' +var ::= [a-zA-Z]+ +endpoint ::= ( | ) '=' diff --git a/src/matrix.hs b/src/matrix.hs new file mode 100644 index 0000000..21c85f0 --- /dev/null +++ b/src/matrix.hs @@ -0,0 +1,10 @@ +module Matrix where + +import Data.List + + +newtype Matrix a = Matrix { getMatrix :: [[a]] } + +instance Show a => Show (Matrix a) where + show (Matrix m) = intercalate "\n" (map showLine m) + where showLine l = "[ " ++ intercalate " , " (map show l) ++ " ]" diff --git a/src/parser.hs b/src/parser.hs index d523001..f402b80 100644 --- a/src/parser.hs +++ b/src/parser.hs @@ -1,13 +1,15 @@ -module Parser -( parse -, equationP -) where +module Parser where +-- ( parse +-- , equationP +-- ) where import Control.Applicative import Control.Monad import Data.Char -import Equation +import Expr +-- import Equation +-- import Complex newtype Parser a = Parser (String -> Maybe (a, String)) @@ -39,61 +41,91 @@ instance Alternative Parser where (Parser p1) <|> (Parser p2) = Parser new_p where new_p s = p1 s <|> p2 s +instance Monad Parser where + -- return :: a -> Parser a + return x = pure x + -- (>>=) :: Parser a -> (a -> Parser b) -> Parser b + (Parser p1) >>= f = Parser new_p + where new_p s = do + (x, s') <- p1 s + parse (f x) s' + -satisfy :: (Char -> Bool) -> Parser Char -satisfy f = Parser p +satisfyChar :: (Char -> Bool) -> Parser Char +satisfyChar f = Parser p where p [] = Nothing p (c:cs) = if f c then Just (c, cs) else Nothing +sepBy :: Parser b -> Parser a -> Parser [a] +sepBy sep x = many (sep *> x) + +sepByMap :: (b -> a -> a) -> Parser b -> Parser a -> Parser [a] +sepByMap f sep x = many (f <$> sep <*> x) + +signed :: Num a => Parser a -> Parser a +signed p = do charP '-' + x <- p + return (-x) + <|> p + +readParser :: Read a => Parser String -> Parser a +readParser p = read <$> p + charP :: Char -> Parser Char -charP c = satisfy (c ==) +charP c = satisfyChar (c ==) + +alphaP :: Parser Char +alphaP = satisfyChar isAlpha digitsP :: Parser String -digitsP = some (satisfy isDigit) -- at least one digit to avoid read exception +digitsP = some (satisfyChar 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) +spacesP = many (satisfyChar isSpace) + +unsignedIntP :: Parser Int +unsignedIntP = readParser digitsP + +intP :: Parser Int +intP = signed unsignedIntP + +unsignedFloatP :: Parser Float +unsignedFloatP = readParser p + where p = do pos <- digitsP + charP '.' + dec <- digitsP + return (pos ++ "." ++ dec) + <|> digitsP + +floatP :: Parser Float +floatP = signed unsignedFloatP + +-- imaginaryP :: Parser Imaginary +-- imaginaryP = floatP <* charP 'i' + +exprP :: Parser Expr +exprP = do x <- termP + charP '+' + y <- exprP + return (Expr x y) + <|> (ExprSingle <$> termP) + +termP :: Parser Term +termP = do f <- factorP + charP '*' + t <- termP + return (Term f t) + <|> (TermSingle <$> factorP) + + +factorP :: Parser Factor +factorP = do b <- baseP + charP '^' + e <- factorP + return (Factor b e) + <|> (FactorSingle <$> baseP) + +baseP :: Parser Base +baseP = (charP '(' *> (Base <$> exprP) <* charP ')') + <|> (BaseSingle <$> floatP) diff --git a/src/parser/complex.hs b/src/parser/complex.hs new file mode 100644 index 0000000..e69de29 diff --git a/src/parser/matrix.hs b/src/parser/matrix.hs new file mode 100644 index 0000000..e69de29 diff --git a/src/polynomial.hs b/src/polynomial.hs new file mode 100644 index 0000000..f332131 --- /dev/null +++ b/src/polynomial.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/rational.hs b/src/rational.hs new file mode 100644 index 0000000..7eb1785 --- /dev/null +++ b/src/rational.hs @@ -0,0 +1,3 @@ +module Rational where + +type Rational = Float -- cgit