fork(5) download 
  1. -- Few Scum
  2. import Data.Char
  3. import Text.Read
  4. import Control.Applicative
  5. import Data.Ratio
  6. import Numeric
  7. import Data.List
  8. import Data.Maybe
  9. data Token
  10.     =TLetter Char
  11.     |TNumf Rational
  12.     |TOp Char
  13.     |LBrace
  14.     |RBrace
  15.     deriving (Show, Eq)
  16. data Expr
  17.     =Letter Char
  18.     |Numf Rational
  19.     |Op Char Expr Expr
  20.     |Diff Expr
  21. instance Show Expr where
  22.     show (Letter c)     = [c]
  23.     show (Op c el er)   = '(' : show el ++ ')' :
  24.         c : '(' : show er ++ ")"
  25.     show (Numf v)       = show $ toDouble v
  26.     show (Diff e)       = '(' : show e ++ ")'"
  27.  
  28. toDouble r = fromRational r :: Double
  29. readUnsignedRationalMaybe f = getParseResult $ parseValue f where
  30.     parseValue f = {- readSigned -} readFloat f :: [(Rational, String)]
  31.     getParseResult [(value, "")] = Just value
  32.     getParseResult _ = Nothing
  33.  
  34. -- Разбиваем строку на элементы, возаращает перевернутый список токенов
  35. tokenize ""                     = Nothing
  36. tokenize sourceExpressionString = tok [] sourceExpressionString where
  37.     tok [] (c:s)
  38.         | c == '-'                  = tok [TOp '-', TNumf 0] s
  39.     tok r@(LBrace:_) (c:s)
  40.         | c == '-'                  = tok (TOp '-':TNumf 0:r) s
  41.     tok r (c:s)
  42.         | c == '('                  = tok (LBrace:r) s
  43.         | c == ')'                  = tok (RBrace:r) s
  44.         | isLetter c                = tok (TLetter c:r) s
  45.         | isOperation c             = tok (TOp c:r) s
  46.         | isNumber c                = parseNumf r (c:s)
  47.     tok r ""                        = Just r
  48.     tok resultParsedTokens sourceExpressionString = Nothing
  49.     isOperation     = (`elem` "+-*/")
  50.     isNumf c        = isNumber c || c == '.'
  51.     parseNumf r s   = maybeNumber >>= makeResult where
  52.         (numberString, tail) = span isNumf s
  53.         maybeNumber = readUnsignedRationalMaybe numberString--readMaybe numberString
  54.         makeResult number = tok (TNumf number:r) tail
  55.  
  56. -- Дерево выражений из списка токенов
  57. parse reversedTokens             = reversedTokens >>= makeTree where
  58.     priorityOps         = ["+-","/*"]
  59.     subExpr             = splitIntoOperationAndSubExpressions
  60.     splitIntoOperationAndSubExpressions reversedTokens =
  61.         id =<< find isJust (map (findOp reversedTokens [] 0) priorityOps)
  62.     findOp (LBrace:_) _ 0 _         = Nothing -- dont checked on left expression, probably can safety removed
  63.     findOp (RBrace:l) r b ops       = findOp l (RBrace:r) (b+1) ops
  64.     findOp (LBrace:l) r b ops       = findOp l (LBrace:r) (b-1) ops
  65.     findOp (TOp c:l) r 0 ops
  66.         | c `elem` ops              = Just (c, l, reverse r)
  67.         | otherwise                 = findOp l (TOp c:r) 0 ops
  68.     findOp leftSubExpression [] b operationsForFind
  69.         | b > 0                     = Nothing
  70.     findOp (c:l) r b ops            = findOp l (c:r) b ops
  71.     findOp [] rightSubExpression braceAmount operationsForFind = Nothing
  72.     makeTree reversedTokens     = mt reversedTokens $ subExpr reversedTokens
  73.     mt t@(RBrace:tt) Nothing
  74.         | last t == LBrace      = mt (init tt) $ subExpr (init tt)
  75.     mt [TLetter v] Nothing      = Just $ Letter v
  76.     mt [TNumf v] Nothing        = Just $ Numf v
  77.     mt _ Nothing                = Nothing
  78.     mt _ (Just (o, l, r))       = makeOperationExpression leftExpressionTree rightExpressionTree o where
  79.         leftExpressionTree          = mt l $ subExpr l
  80.         rightExpressionTree         = mt r $ subExpr r
  81.         makeOperationExpression = moe
  82.         moe Nothing _ _         = Nothing
  83.         moe _ Nothing _         = Nothing
  84.         moe (Just leftExpressionTree) (Just rightExpressionTree) operation = Just $ Op operation leftExpressionTree rightExpressionTree
  85.  
  86. -- Простейшее упрощение выражений
  87. firstSimplify e     = simplifyTreeHeightTimes <$> e where
  88.     stepSimplify = fs
  89.     fs (Op '*' e (Numf 1))           = e
  90.     fs (Op '*' (Numf 1) e)           = e
  91.     fs (Op '+' e (Numf 0))           = e
  92.     fs (Op '+' (Numf 0) e)           = e
  93.     fs (Op '/' e (Numf 1))           = e
  94.     fs (Op '-' e (Numf 0))           = e
  95.     fs (Op '*' (Numf 0) _)           = Numf 0
  96.     fs (Op '*' _ (Numf 0))           = Numf 0
  97.     fs (Op '/' (Numf 0) _)           = Numf 0
  98.     fs (Op '/' (Letter l) (Letter r))
  99.         | l == r                     = Numf 1
  100.     fs (Op '-' (Letter l) (Letter r))
  101.         | l == r                     = Numf 0
  102.     fs (Op o (Numf l) (Numf r))
  103.         | o == '+'                   = Numf $ l + r
  104.         | o == '-'                   = Numf $ l - r
  105.         | o == '*'                   = Numf $ l * r
  106.         | o == '/'                   = Numf $ l / r
  107.     fs (Op o l r)                    = Op o (fs l) (fs r)
  108.     fs (Diff e)                      = fs e
  109.     fs e                             = e
  110.     treeHeight (Letter _)     = 1
  111.     treeHeight (Op _ l r)     = max (treeHeight l) (treeHeight r) + 1
  112.     treeHeight (Numf _)       = 1
  113.     treeHeight (Diff e)       = treeHeight e + 1
  114.     simplifyTreeHeightTimes e = (last . take (1 + treeHeight e) . iterate stepSimplify) e
  115.  
  116. -- Производная df/dx из дерева выражений
  117. diff e dx           = df <$> e where
  118.     df (Numf _)                      = Numf 0
  119.     df (Letter c)
  120.         | c == dx                    = Numf 1
  121.         | otherwise                  = Numf 0
  122.     df (Op o l r)
  123.         | o == '+' || o == '-'       = Op o (df l) (df r)
  124.         | o == '*'                   = Op '+' (Op '*' (df l) r) (Op '*' l (df r))
  125.         | o == '/'                   =
  126.                 Op '/' (Op '-' (Op '*' (df l) r) (Op '*' l (df r))) (Op '*' r r)
  127.     df e                             = Diff e
  128.  
  129. -- Очень грязный кот (:
  130. main = do
  131.     let sourceExpression = "-13.5*(x*(-13))"
  132.     let dx = 'x'
  133.     print "dx: "
  134.     print dx
  135.     print "SourceExpression: "
  136.     print sourceExpression
  137.     let tokens = tokenize sourceExpression
  138.     print "Source tokens: "
  139.     print $ reverse <$> tokens
  140.     print "Reversed source tokens: "
  141.     print tokens
  142.     let expr = parse tokens
  143.     print "Source expression tree: "
  144.     print expr
  145.     let fsexpr = firstSimplify expr
  146.     print "Simplified source expression tree: "
  147.     print fsexpr
  148.     let df = diff fsexpr dx
  149.     print "Diff expression tree: "
  150.     print df
  151.     let fsdf = firstSimplify df
  152.     print "Simplied diff expression tree: "
  153.     print fsdf
Success #stdin #stdout 0s 4844KB
comments (?)
stdin 
Standard input is empty
stdout 
"dx: "
'x'
"SourceExpression: "
"-13.5*(x*(-13))"
"Source tokens: "
Just [TNumf (0 % 1),TOp '-',TNumf (27 % 2),TOp '*',LBrace,TLetter 'x',TOp '*',LBrace,TNumf (0 % 1),TOp '-',TNumf (13 % 1),RBrace,RBrace]
"Reversed source tokens: "
Just [RBrace,RBrace,TNumf (13 % 1),TOp '-',TNumf (0 % 1),LBrace,TOp '*',TLetter 'x',LBrace,TOp '*',TNumf (27 % 2),TOp '-',TNumf (0 % 1)]
"Source expression tree: "
Just (0.0)-((13.5)*((x)*((0.0)-(13.0))))
"Simplified source expression tree: "
Just (0.0)-((13.5)*((x)*(-13.0)))
"Diff expression tree: "
Just (0.0)-(((0.0)*((x)*(-13.0)))+((13.5)*(((1.0)*(-13.0))+((x)*(0.0)))))
"Simplied diff expression tree: "
Just 175.5
https://ideone.com/Bottp0
language:
Haskell (ghc 8.4.4)
created:
10 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!