-- Few Scum
import Data.Char
import Text.Read
import Control.Applicative
import Data.Ratio
import Numeric
import Data.List
import Data.Maybe
data Token
    =TLetter Char
    |TNumf Rational
    |TOp Char
    |LBrace
    |RBrace
    deriving (Show, Eq)
data Expr
    =Letter Char
    |Numf Rational
    |Op Char Expr Expr
    |Diff Expr
instance Show Expr where
    show (Letter c)     = [c]
    show (Op c el er)   = '(' : show el ++ ')' :
        c : '(' : show er ++ ")"
    show (Numf v)       = show $ toDouble v
    show (Diff e)       = '(' : show e ++ ")'"

toDouble r = fromRational r :: Double
readUnsignedRationalMaybe f = getParseResult $ parseValue f where
    parseValue f = {- readSigned -} readFloat f :: [(Rational, String)]
    getParseResult [(value, "")] = Just value
    getParseResult _ = Nothing

-- Разбиваем строку на элементы, возаращает перевернутый список токенов
tokenize ""                     = Nothing
tokenize sourceExpressionString = tok [] sourceExpressionString where
    tok [] (c:s)
        | c == '-'                  = tok [TOp '-', TNumf 0] s
    tok r@(LBrace:_) (c:s)
        | c == '-'                  = tok (TOp '-':TNumf 0:r) s
    tok r (c:s)
        | c == '('                  = tok (LBrace:r) s
        | c == ')'                  = tok (RBrace:r) s
        | isLetter c                = tok (TLetter c:r) s
        | isOperation c             = tok (TOp c:r) s
        | isNumber c                = parseNumf r (c:s)
    tok r ""                        = Just r
    tok resultParsedTokens sourceExpressionString = Nothing
    isOperation     = (`elem` "+-*/")
    isNumf c        = isNumber c || c == '.'
    parseNumf r s   = maybeNumber >>= makeResult where
        (numberString, tail) = span isNumf s
        maybeNumber = readUnsignedRationalMaybe numberString--readMaybe numberString
        makeResult number = tok (TNumf number:r) tail

-- Дерево выражений из списка токенов
parse reversedTokens             = reversedTokens >>= makeTree where
    priorityOps         = ["+-","/*"]
    subExpr             = splitIntoOperationAndSubExpressions
    splitIntoOperationAndSubExpressions reversedTokens =
        id =<< find isJust (map (findOp reversedTokens [] 0) priorityOps)
    findOp (LBrace:_) _ 0 _         = Nothing -- dont checked on left expression, probably can safety removed
    findOp (RBrace:l) r b ops       = findOp l (RBrace:r) (b+1) ops
    findOp (LBrace:l) r b ops       = findOp l (LBrace:r) (b-1) ops
    findOp (TOp c:l) r 0 ops
        | c `elem` ops              = Just (c, l, reverse r)
        | otherwise                 = findOp l (TOp c:r) 0 ops
    findOp leftSubExpression [] b operationsForFind
        | b > 0                     = Nothing
    findOp (c:l) r b ops            = findOp l (c:r) b ops
    findOp [] rightSubExpression braceAmount operationsForFind = Nothing
    makeTree reversedTokens     = mt reversedTokens $ subExpr reversedTokens
    mt t@(RBrace:tt) Nothing
        | last t == LBrace      = mt (init tt) $ subExpr (init tt)
    mt [TLetter v] Nothing      = Just $ Letter v
    mt [TNumf v] Nothing        = Just $ Numf v
    mt _ Nothing                = Nothing
    mt _ (Just (o, l, r))       = makeOperationExpression leftExpressionTree rightExpressionTree o where
        leftExpressionTree          = mt l $ subExpr l
        rightExpressionTree         = mt r $ subExpr r
        makeOperationExpression = moe
        moe Nothing _ _         = Nothing
        moe _ Nothing _         = Nothing
        moe (Just leftExpressionTree) (Just rightExpressionTree) operation = Just $ Op operation leftExpressionTree rightExpressionTree

-- Простейшее упрощение выражений
firstSimplify e     = simplifyTreeHeightTimes <$> e where
    stepSimplify = fs
    fs (Op '*' e (Numf 1))           = e
    fs (Op '*' (Numf 1) e)           = e
    fs (Op '+' e (Numf 0))           = e
    fs (Op '+' (Numf 0) e)           = e
    fs (Op '/' e (Numf 1))           = e
    fs (Op '-' e (Numf 0))           = e
    fs (Op '*' (Numf 0) _)           = Numf 0
    fs (Op '*' _ (Numf 0))           = Numf 0
    fs (Op '/' (Numf 0) _)           = Numf 0
    fs (Op '/' (Letter l) (Letter r))
        | l == r                     = Numf 1
    fs (Op '-' (Letter l) (Letter r))
        | l == r                     = Numf 0
    fs (Op o (Numf l) (Numf r))
        | o == '+'                   = Numf $ l + r
        | o == '-'                   = Numf $ l - r
        | o == '*'                   = Numf $ l * r
        | o == '/'                   = Numf $ l / r
    fs (Op o l r)                    = Op o (fs l) (fs r)
    fs (Diff e)                      = fs e
    fs e                             = e
    treeHeight (Letter _)     = 1
    treeHeight (Op _ l r)     = max (treeHeight l) (treeHeight r) + 1
    treeHeight (Numf _)       = 1
    treeHeight (Diff e)       = treeHeight e + 1
    simplifyTreeHeightTimes e = (last . take (1 + treeHeight e) . iterate stepSimplify) e

-- Производная df/dx из дерева выражений
diff e dx           = df <$> e where
    df (Numf _)                      = Numf 0
    df (Letter c)
        | c == dx                    = Numf 1
        | otherwise                  = Numf 0
    df (Op o l r)
        | o == '+' || o == '-'       = Op o (df l) (df r)
        | o == '*'                   = Op '+' (Op '*' (df l) r) (Op '*' l (df r))
        | o == '/'                   =
                Op '/' (Op '-' (Op '*' (df l) r) (Op '*' l (df r))) (Op '*' r r)
    df e                             = Diff e

-- Очень грязный кот (:
main = do
    let sourceExpression = "-13.5*(x*(-13))"
    let dx = 'x'
    print "dx: "
    print dx
    print "SourceExpression: "
    print sourceExpression
    let tokens = tokenize sourceExpression
    print "Source tokens: "
    print $ reverse <$> tokens
    print "Reversed source tokens: "
    print tokens
    let expr = parse tokens
    print "Source expression tree: "
    print expr
    let fsexpr = firstSimplify expr
    print "Simplified source expression tree: "
    print fsexpr
    let df = diff fsexpr dx
    print "Diff expression tree: "
    print df
    let fsdf = firstSimplify df
    print "Simplied diff expression tree: "
    print fsdf