1 import Data.Char 2 import Data.Ratio 3 4 data Tree = TNum Rational | TVar String | TFunc String [Tree] | TOp Char [Tree] | TBinOp Char Tree Tree deriving Show 5 data OStack = OFunc | OOp Char deriving Show 6 7 errorComma = error "co tu hlada ciarka?" 8 errorPar = error "zatvorkovy mismatch" 9 errorUndef = error "chyba" 10 11 isOp :: Char -> Bool 12 isOp '+' = True 13 isOp '-' = True 14 isOp '*' = True 15 isOp '/' = True 16 isOp '^' = True 17 isOp _ = False 18 19 isLeft :: Char -> Bool 20 isLeft '+' = True 21 isLeft '-' = True 22 isLeft '*' = True 23 isLeft '/' = True 24 isLeft '^' = False 25 isLeft _ = False 26 27 opPrec :: Char -> Int 28 opPrec '^' = 4 29 opPrec '*' = 3 30 opPrec '/' = 3 31 opPrec '+' = 2 32 opPrec '-' = 2 33 34 isIdent :: Char -> Bool 35 isIdent '_' = True 36 isIdent x = (isAlpha x) || (isDigit x) 37 38 opToken :: Char -> String -> [Tree] -> [OStack] -> Tree 39 opToken x xs out [] = nextToken xs out [OOp x] 40 opToken x xs (o2:o1:out) ((OOp op):ops) 41 | op /= '(' && precedence x op = opToken x xs ((TBinOp op o1 o2):out) ops 42 | otherwise = nextToken xs (o2:o1:out) ((OOp x):(OOp op):ops) 43 where precedence op1 op2 44 | opPrec op1 < opPrec op2 = True 45 | opPrec op1 == opPrec op2 && isLeft op1 = True 46 | otherwise = False 47 opToken x xs out ops = nextToken xs out ((OOp x):ops) 48 49 numToken :: String -> Integer -> [Tree] -> [OStack] -> Tree 50 numToken (x:xs) n out ops 51 | isDigit x = numToken xs (n*10 + xval) out ops 52 | otherwise = nextToken (x:xs) ((TNum (n % 1)):out) ops 53 where xval = fromIntegral (ord x) - fromIntegral (ord '0') 54 numToken [] n out ops = nextToken [] ((TNum (n % 1)):out) ops 55 56 identToken :: String -> String -> [Tree] -> [OStack] -> Tree 57 identToken (x:xs) ident out ops 58 | isIdent x = identToken xs (ident ++ [x]) out ops 59 | x == '(' = nextToken (x:xs) ((TFunc ident []):out) (OFunc:ops) 60 | isSpace x = skipSpaces xs ident out ops 61 | otherwise = nextToken (x:xs) ((TVar ident):out) ops 62 where skipSpaces (x:xs) ident out ops 63 | isSpace x = skipSpaces xs ident out ops 64 | x == '(' = nextToken (x:xs) ((TFunc ident []):out) (OFunc:ops) 65 | otherwise = nextToken (x:xs) ((TVar ident):out) ops 66 skipSpaces [] ident out ops = nextToken [] ((TVar ident):out) ops 67 identToken [] ident out ops = nextToken [] ((TVar ident):out) ops 68 69 rightParToken :: String -> [Tree] -> [OStack] -> Tree 70 rightParToken xs (o2:o1:out) ((OOp op):ops) 71 | op /= '(' = rightParToken xs ((TBinOp op o1 o2):out) ops 72 rightParToken xs (o:(TFunc ident par):out) ((OOp '('):OFunc:ops) = nextToken xs ((TFunc ident (par ++ [o])):out) ops 73 rightParToken xs out ((OOp '('):ops) = nextToken xs out ops 74 rightParToken _ _ _ = errorPar 75 76 commaToken :: String -> [Tree] -> [OStack] -> Tree 77 commaToken xs (o2:o1:out) ((OOp op):ops) 78 | op /= '(' = commaToken xs ((TBinOp op o1 o2):out) ops 79 commaToken xs (o:(TFunc ident par):out) ((OOp '('):ops) = nextToken xs ((TFunc ident (par ++ [o])):out) ((OOp '('):ops) 80 commaToken _ _ _ = errorComma 81 82 nextToken :: String -> [Tree] -> [OStack] -> Tree 83 nextToken (x:xs) out ops 84 | isOp x = opToken x xs out ops 85 | isDigit x = numToken (x:xs) 0 out ops 86 | isIdent x = identToken (x:xs) "" out ops 87 | x == '(' = nextToken xs out ((OOp x):ops) 88 | x == ')' = rightParToken xs out ops 89 | x == ',' = commaToken xs out ops 90 | isSpace x = nextToken xs out ops 91 | otherwise = errorUndef 92 nextToken [] (o2:o1:out) ((OOp op):ops) 93 | op == '(' = errorPar 94 | otherwise = nextToken [] ((TBinOp op o1 o2):out) ops 95 nextToken [] [out] [] = out 96 nextToken _ _ _ = errorUndef 97 98 parse :: String -> Tree 99 parse s = nextToken s [] [] 100 101 t2s :: Tree -> Char -> String 102 t2s (TBinOp op a b) prevop 103 | opPrec op < opPrec prevop = '(':(tree2str (TBinOp op a b)) ++ ")" 104 t2s (TOp op (a:args)) prevop 105 | opPrec op < opPrec prevop = '(':(tree2str (TOp op (a:args))) ++ ")" 106 t2s a _ = tree2str a 107 108 tree2str :: Tree -> String 109 tree2str (TNum a) 110 | denominator a == 1 = show (numerator a) 111 | otherwise = (show (numerator a)) ++ ' ':'/':' ':(show (denominator a)) 112 tree2str (TVar v) = v 113 tree2str (TFunc f []) = f ++ "()" 114 tree2str (TFunc f (a:args)) = f ++ '(':(foldr (\x y -> x ++ ',':' ':y) (tree2str a) (map tree2str args)) ++ ")" 115 tree2str (TBinOp op a b) = (t2s a op) ++ ' ':op:' ':(t2s b op) 116 tree2str (TOp op (a:args)) = foldl (\x y -> x ++ ' ':op:' ':y) (t2s a op) (map (flip t2s op) args) 117 118 derivative :: Tree -> String -> Tree 119 derivative (TNum _) _ = TNum (0 % 1) 120 derivative (TVar x) var 121 | x == var = TNum (1 % 1) 122 | otherwise = TNum (0 % 1) 123 derivative (TOp '+' xs) var = TOp '+' (der xs) 124 where der [] = [] 125 der (x:xs) = (derivative x var):(der xs) 126 derivative (TOp '*' (x:xs)) var = TOp '+' (der [] x xs) 127 where der a b [] = [TOp '*' (a ++ [derivative b var])] 128 der a b (c:d) = (TOp '*' (a ++ ((derivative b var):c:d))):(der (a ++ [b]) c d) 129 130 unBinOps :: Tree -> Tree 131 unBinOps (TOp '+' [a]) = a 132 unBinOps (TOp '*' [a]) = a 133 unBinOps (TOp '+' ((TOp '+' (x:xs)):ys)) = unBinOps $ TOp '+' (x:(map unBinOps (xs ++ ys))) 134 unBinOps (TOp '*' ((TOp '*' (x:xs)):ys)) = unBinOps $ TOp '*' (x:(map unBinOps (xs ++ ys))) 135 unBinOps (TOp o xs) = TOp o (map unBinOps xs) 136 unBinOps (TBinOp '+' a b) = unBinOps $ TOp '+' (map unBinOps [a,b]) 137 unBinOps (TBinOp '*' a b) = unBinOps $ TOp '*' (map unBinOps [a,b]) 138 unBinOps (TBinOp '-' a b) = unBinOps $ TBinOp '+' a (TBinOp '*' (TNum (-1 % 1)) b) 139 unBinOps (TBinOp '/' a (TNum b)) = unBinOps $ TBinOp '*' a (TNum (1 / b)) 140 unBinOps (TBinOp '/' a b) = unBinOps $ TBinOp '*' a (TBinOp '^' b (TNum (-1 % 1))) 141 unBinOps (TBinOp o a b) = TBinOp o (unBinOps a) (unBinOps b) 142 unBinOps (TFunc f xs) = TFunc f (map unBinOps xs) 143 unBinOps x = x 144 145 isNum :: Tree -> Bool 146 isNum (TNum _) = True 147 isNum _ = False 148 149 isVar :: Tree -> Bool 150 isVar (TVar _) = True 151 isVar _ = False 152 153 getNum :: Tree -> Rational 154 getNum (TNum x) = x 155 156 {-collapse :: [Tree] -> [Tree] 157 collapse (TVar x):xs = 158 where isVarName n (TVar n') = n == n' 159 isVarName n (TBinOp '^' (TVar n') _) = n == n' 160 xs' = filter (isVarName x) xs 161 os' = filter (not . (isVarName x)) xs 162 | x == y = collapse ((TBinOp '^' (TVar x) (TNum (2 % 1))):xs) 163 collapse (TBinOp '^' (TVar x) y):(TBinOp '^' (TVar x') y'):xs 164 | x == x' = collapse $ (TBinOp '^' (TVar x) (poly (TOp '+' [y,y']))):xs-} 165 166 poly :: Tree -> Tree 167 poly (TOp '+' xs') = unBinOps $ TOp '+' ((TNum sum):vars) 168 where xs = map (unBinOps . poly) xs' 169 nums = filter isNum xs 170 sum = foldr (+) 0 (map getNum nums) 171 vars = filter (not . isNum) xs 172 poly (TOp '*' xs') = unBinOps $ TOp '*' ((TNum prod):vars) 173 where xs = map (unBinOps . poly) xs' 174 nums = filter isNum xs 175 prod = foldr (*) 1 (map getNum nums) 176 vars = filter (not . isNum) xs 177 poly (TBinOp '/' a b) = unBinOps $ TBinOp '/' (poly a) (poly b) 178 poly (TBinOp '^' a b) 179 | otherwise = unBinOps $ TBinOp '^' (poly a) (poly b) 180 poly (TFunc f xs) = TFunc f (map poly xs) 181 poly x = x