- 001
- 002
- 003
- 004
- 005
- 006
- 007
- 008
- 009
- 010
- 011
- 012
- 013
- 014
- 015
- 016
- 017
- 018
- 019
- 020
- 021
- 022
- 023
- 024
- 025
- 026
- 027
- 028
- 029
- 030
- 031
- 032
- 033
- 034
- 035
- 036
- 037
- 038
- 039
- 040
- 041
- 042
- 043
- 044
- 045
- 046
- 047
- 048
- 049
- 050
- 051
- 052
- 053
- 054
- 055
- 056
- 057
- 058
- 059
- 060
- 061
- 062
- 063
- 064
- 065
- 066
- 067
- 068
- 069
- 070
- 071
- 072
- 073
- 074
- 075
- 076
- 077
- 078
- 079
- 080
- 081
- 082
- 083
- 084
- 085
- 086
- 087
- 088
- 089
- 090
- 091
- 092
- 093
- 094
- 095
- 096
- 097
- 098
- 099
- 100
-- 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))
Follow us!