import Data.Char
import Data.Ratio

data Tree = TNum Rational | TVar String | TFunc String [Tree] | TOp Char [Tree] | TBinOp Char Tree Tree deriving Show
data OStack = OFunc | OOp Char deriving Show

errorComma = error "co tu hlada ciarka?"
errorPar = error "zatvorkovy mismatch"
errorUndef = error "chyba"

isOp :: Char -> Bool
isOp '+' = True
isOp '-' = True
isOp '*' = True
isOp '/' = True
isOp '^' = True
isOp _ = False

isLeft :: Char -> Bool
isLeft '+' = True
isLeft '-' = True
isLeft '*' = True
isLeft '/' = True
isLeft '^' = False
isLeft _ = False

opPrec :: Char -> Int
opPrec '^' = 4
opPrec '*' = 3
opPrec '/' = 3
opPrec '+' = 2
opPrec '-' = 2

isIdent :: Char -> Bool
isIdent '_' = True
isIdent x = (isAlpha x) || (isDigit x)

opToken :: Char -> String -> [Tree] -> [OStack] -> Tree
opToken x xs out [] = nextToken xs out [OOp x]
opToken x xs (o2:o1:out) ((OOp op):ops)
	| op /= '(' && precedence x op = opToken x xs ((TBinOp op o1 o2):out) ops
	| otherwise = nextToken xs (o2:o1:out) ((OOp x):(OOp op):ops)
	where	precedence op1 op2
			| opPrec op1 < opPrec op2                = True
			| opPrec op1 == opPrec op2 && isLeft op1 = True
			| otherwise                              = False
opToken x xs out ops = nextToken xs out ((OOp x):ops)

numToken :: String -> Integer -> [Tree] -> [OStack] -> Tree
numToken (x:xs) n out ops
	| isDigit x = numToken xs (n*10 + xval) out ops
	| otherwise = nextToken (x:xs) ((TNum (n % 1)):out) ops
	where	xval = fromIntegral (ord x) - fromIntegral (ord '0')
numToken [] n out ops = nextToken [] ((TNum (n % 1)):out) ops

identToken :: String -> String -> [Tree] -> [OStack] -> Tree
identToken (x:xs) ident out ops
	| isIdent x = identToken xs (ident ++ [x]) out ops
	| x == '('  = nextToken (x:xs) ((TFunc ident []):out) (OFunc:ops)
	| isSpace x = skipSpaces xs ident out ops
	| otherwise = nextToken (x:xs) ((TVar ident):out) ops
	where	skipSpaces (x:xs) ident out ops
			| isSpace x = skipSpaces xs ident out ops
			| x == '('  = nextToken (x:xs) ((TFunc ident []):out) (OFunc:ops)
			| otherwise = nextToken (x:xs) ((TVar ident):out) ops
		skipSpaces [] ident out ops = nextToken [] ((TVar ident):out) ops
identToken [] ident out ops = nextToken [] ((TVar ident):out) ops

rightParToken :: String -> [Tree] -> [OStack] -> Tree
rightParToken xs (o2:o1:out) ((OOp op):ops)
	| op /= '(' = rightParToken xs ((TBinOp op o1 o2):out) ops
rightParToken xs (o:(TFunc ident par):out) ((OOp '('):OFunc:ops) = nextToken xs ((TFunc ident (par ++ [o])):out) ops
rightParToken xs out ((OOp '('):ops) = nextToken xs out ops
rightParToken _ _ _ = errorPar

commaToken :: String -> [Tree] -> [OStack] -> Tree
commaToken xs (o2:o1:out) ((OOp op):ops)
	| op /= '(' = commaToken xs ((TBinOp op o1 o2):out) ops
commaToken xs (o:(TFunc ident par):out) ((OOp '('):ops) = nextToken xs ((TFunc ident (par ++ [o])):out) ((OOp '('):ops)
commaToken _ _ _ = errorComma

nextToken :: String -> [Tree] -> [OStack] -> Tree
nextToken (x:xs) out ops
	| isOp x    = opToken x xs out ops
	| isDigit x = numToken (x:xs) 0 out ops
	| isIdent x = identToken (x:xs) "" out ops
	| x == '('  = nextToken xs out ((OOp x):ops)
	| x == ')'  = rightParToken xs out ops
	| x == ','  = commaToken xs out ops
	| isSpace x = nextToken xs out ops
	| otherwise = errorUndef
nextToken [] (o2:o1:out) ((OOp op):ops)
	| op == '(' = errorPar
	| otherwise = nextToken [] ((TBinOp op o1 o2):out) ops
nextToken [] [out] [] = out
nextToken _ _ _ = errorUndef

parse :: String -> Tree
parse s = nextToken s [] []

t2s :: Tree -> Char -> String
t2s (TBinOp op a b) prevop
	| opPrec op < opPrec prevop = '(':(tree2str (TBinOp op a b)) ++ ")"
t2s (TOp op (a:args)) prevop
	| opPrec op < opPrec prevop = '(':(tree2str (TOp op (a:args))) ++ ")"
t2s a _ = tree2str a

tree2str :: Tree -> String
tree2str (TNum a)
	| denominator a == 1 = show (numerator a)
	| otherwise          = (show (numerator a)) ++ ' ':'/':' ':(show (denominator a))
tree2str (TVar v) = v
tree2str (TFunc f []) = f ++ "()"
tree2str (TFunc f (a:args)) = f ++ '(':(foldr (\x y -> x ++ ',':' ':y) (tree2str a) (map tree2str args)) ++ ")"
tree2str (TBinOp op a b) = (t2s a op) ++ ' ':op:' ':(t2s b op)
tree2str (TOp op (a:args)) = foldl (\x y -> x ++ ' ':op:' ':y) (t2s a op) (map (flip t2s op) args)

derivative :: Tree -> String -> Tree
derivative (TNum _) _ = TNum (0 % 1)
derivative (TVar x) var
	| x == var  = TNum (1 % 1)
	| otherwise = TNum (0 % 1)
derivative (TOp '+' xs) var = TOp '+' (der xs)
	where	der [] = []
		der (x:xs) = (derivative x var):(der xs)
derivative (TOp '*' (x:xs)) var = TOp '+' (der [] x xs)
	where	der a b [] = [TOp '*' (a ++ [derivative b var])]
		der a b (c:d) = (TOp '*' (a ++ ((derivative b var):c:d))):(der (a ++ [b]) c d)

unBinOps :: Tree -> Tree
unBinOps (TOp '+' [a]) = a
unBinOps (TOp '*' [a]) = a
unBinOps (TOp '+' ((TOp '+' (x:xs)):ys)) = unBinOps $ TOp '+' (x:(map unBinOps (xs ++ ys)))
unBinOps (TOp '*' ((TOp '*' (x:xs)):ys)) = unBinOps $ TOp '*' (x:(map unBinOps (xs ++ ys)))
unBinOps (TOp o xs) = TOp o (map unBinOps xs)
unBinOps (TBinOp '+' a b) = unBinOps $ TOp '+' (map unBinOps [a,b])
unBinOps (TBinOp '*' a b) = unBinOps $ TOp '*' (map unBinOps [a,b])
unBinOps (TBinOp '-' a b) = unBinOps $ TBinOp '+' a (TBinOp '*' (TNum (-1 % 1)) b)
unBinOps (TBinOp '/' a (TNum b)) = unBinOps $ TBinOp '*' a (TNum (1 / b))
unBinOps (TBinOp '/' a b) = unBinOps $ TBinOp '*' a (TBinOp '^' b (TNum (-1 % 1)))
unBinOps (TBinOp o a b) = TBinOp o (unBinOps a) (unBinOps b)
unBinOps (TFunc f xs) = TFunc f (map unBinOps xs)
unBinOps x = x

isNum :: Tree -> Bool
isNum (TNum _) = True
isNum _ = False

isVar :: Tree -> Bool
isVar (TVar _) = True
isVar _ = False

getNum :: Tree -> Rational
getNum (TNum x) = x

{-collapse :: [Tree] -> [Tree]
collapse (TVar x):xs =
	where	isVarName n (TVar n') = n == n'
		isVarName n (TBinOp '^' (TVar n') _) = n == n'
		xs' = filter (isVarName x) xs
		os' = filter (not . (isVarName x)) xs
	| x == y = collapse ((TBinOp '^' (TVar x) (TNum (2 % 1))):xs)
collapse (TBinOp '^' (TVar x) y):(TBinOp '^' (TVar x') y'):xs
	| x == x' = collapse $ (TBinOp '^' (TVar x) (poly (TOp '+' [y,y']))):xs-}

poly :: Tree -> Tree
poly (TOp '+' xs') = unBinOps $ TOp '+' ((TNum sum):vars)
	where	xs = map (unBinOps . poly) xs'
		nums = filter isNum xs
		sum = foldr (+) 0 (map getNum nums)
		vars = filter (not . isNum) xs
poly (TOp '*' xs') = unBinOps $ TOp '*' ((TNum prod):vars)
	where	xs = map (unBinOps . poly) xs'
		nums = filter isNum xs
		prod = foldr (*) 1 (map getNum nums)
		vars = filter (not . isNum) xs
poly (TBinOp '/' a b) = unBinOps $ TBinOp '/' (poly a) (poly b)
poly (TBinOp '^' a b)
	| otherwise = unBinOps $ TBinOp '^' (poly a) (poly b)
poly (TFunc f xs) = TFunc f (map poly xs)
poly x = x