fork(1) download
copy 
  1. import Data.Char
  2. import Data.Maybe
  3. import Control.Monad
  4. import Control.Arrow
  5.  
  6. newtype StateT s m a = StateT { runStateT :: s -> m (a,s) }
  7.  
  8. instance (Monad m) => Monad (StateT s m) where
  9.     return a = StateT $ \s -> return (a, s)
  10.     m >>= k  = StateT $ \s -> do
  11.         ~(a, s') <- runStateT m s
  12.         runStateT (k a) s'
  13.  
  14. instance (MonadPlus m) => MonadPlus (StateT s m) where
  15.     mzero = StateT $ \_ -> mzero
  16.     m `mplus` n = StateT $ \s -> runStateT m s `mplus` runStateT n s
  17.  
  18. evalStateT m s = do
  19.     ~(a, _) <- runStateT m s
  20.     return a
  21. --------------------------------------------------------------------------------------------------------------------
  22. type Order = (Int, Bool)
  23. type D = Double
  24. type DD = D -> D
  25. type DDD = D -> D -> D
  26.  
  27. data Oper = Prinfix (DD, Order) | Prefix DD | Postfix DD | Infix (DDD, Order)
  28. data Expr = Operand D | Operator Oper | Statement [Expr]
  29.  
  30. (leftass, rightass) = (True, False)
  31. makeGuard d g = Operator $ d (g, (1, True))
  32.  
  33. toOp' d xs l = lookup l xs >>= Just . Operator . d
  34.  
  35. toOp 0 = toOp' Prinfix [("-", (negate, (5, leftass)))]
  36. toOp 1 = toOp' Prefix [("sqr", (^2))]
  37. toOp 3 = toOp' Postfix [("!", \x -> product [1..x])]
  38. toOp 4 = toOp' Infix [("+", ((+), (5, leftass))), ("-", ((-), (5, leftass))), 
  39. 	("*", ((*), (6, leftass))), ("/", ((/), (6, leftass))), ("^", ((**), (7, rightass)))]
  40.  
  41. modifyVal g s = s >>= return . g
  42.  
  43. parse = modifyVal (Statement . (makeGuard Prinfix id :)) $ parse' 0 where
  44. 	add i t = modifyVal (t :) $ parse' i
  45. 	parse' i = StateT (listToMaybe . lex) >>= parse'' i
  46. 	parse'' pos l
  47. 		| l == "" || l == ")" = guard (pos >= 3) >> return [makeGuard Infix undefined]
  48. 		| isDigit $ head l = guard (pos <= 2) >> add 3 (Operand $ read l)
  49. 		| l == "(" = guard (pos <= 2) >> parse >>= add 3
  50. 		| pos <= 1 = choose 1
  51. 		| pos <= 4 = choose 4
  52. 		where choose i = uncurry add =<< case (toOp i l, guard (pos < i) >> toOp (i - 1) l) of
  53. 				(Just t, Nothing) -> return (i `rem` 2 + 1, t)
  54. 				(Nothing, Just t) -> return (i, t)
  55. 				_ -> mzero
  56.  
  57. eval (Operand t) = t
  58. eval (Statement t) = fst . snd $ eval' (0, True) (undefined, t) where
  59. 	cond (pr1, as1) (pr2, as2) = pr1 > pr2 || pr1 == pr2 && if as1 == as2 then as1
  60. 		else error "cannot mix two operators"
  61. 	eval' op (n, ots@(Operator o : ts)) = case o of
  62. 		Prefix g -> h g $ uncurry eval'
  63. 		Postfix g -> eval' op (g n, ts)
  64. 		Prinfix (g, opt) -> h g $ until (cond opt . fst) (eval' opt . snd)
  65. 		Infix (g, opt) -> (,) opt . (,) n $ if cond op opt then ots else Operator (Prinfix (g n, opt)) : ts
  66. 		where h g f = second (first g) $ f ((10, undefined), (undefined, ts))
  67. 	eval' op (n, t : ts) = eval' op (eval t, ts)
  68.  
  69. calc = fmap eval . evalStateT parse
  70.  
  71. main = mapM_ (print . calc)
  72. 	[ "2 + 3"
  73. 	, "4 - 3"
  74. 	, "2 + (-3)"
  75. 	, "4 * 5"
  76. 	, "6/4"
  77. 	, "1.2 + 1/2"
  78. 	, "1/(-3)"
  79. 	, "0.5 + 0.2"
  80. 	, "3 ^ 2 ^ 2"
  81. 	, "17654/342"
  82. 	, "2/3 ^ 2"
  83. 	, "(2/3) ^ 2"
  84. 	, "(2 + 3) / (2 - 2)"
  85. 	, "2 + 345 + + + + 6"
  86. 	, " - sqr 5! +(-sqr(1 - 2^ 3) ^sqr 2 *9 !) "
  87. 	, "5 + 9 3"
  88. 	, "sqr sqr 3"
  89. 	]
Success #stdin #stdout 0s 6352KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
Just 5.0
Just 1.0
Just (-1.0)
Just 20.0
Just 1.5
Just 1.7
Just (-0.3333333333333333)
Just 0.7
Just 81.0
Just 51.619883040935676
Just 0.2222222222222222
Just 0.4444444444444444
Just Infinity
Nothing
Just (-2.09193100128e12)
Nothing
Nothing
https://ideone.com/kb1UYo
language:
Haskell (ghc 8.4.4)
created:
10 years ago
visibility:
secret

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!