fork(4) download
copy 
  1. import Data.Char (isDigit)
  2. import Control.Arrow (first, second)
  3.  
  4. type Order = (Int, Bool)
  5. type D = Double
  6. type DD = D -> D
  7. type DDD = D -> D -> D
  8.  
  9. data Oper = Prinfix (DD, Order) | Prefix DD | Postfix DD | Infix (DDD, Order)
  10. data Expr = Operand D | Operator Oper | Statement [Expr]
  11.  
  12. toOp' d xs l = lookup l xs >>= Just . Operator . d
  13.  
  14. toOp 0 = toOp' Prinfix [("-", (negate, (5, True)))] 
  15. toOp 1 = toOp' Prefix [("sqr", (^2))]
  16. toOp 3 = toOp' Postfix [("!", \x -> product [1..x])]
  17. toOp 4 = toOp' Infix [("+", ((+), (5, True))), ("-", ((-), (5, True))),
  18. 	("*", ((*), (6, True))), ("/", ((/), (6, True))), ("^", ((**), (7, False)))]
  19.  
  20. parse = fmap fst . parse' . takeWhile (not . null) . map fst . 
  21. 	tail . iterate (head . lex . snd) . (,) "" . (++ ")") where
  22. 	(opg, ff) = (Operator $ Prinfix (id, (1, True)), fmap . first)
  23. 	add i t = ff (t :) . parse'' i
  24. 	parse' = ff Statement . add 0 opg
  25. 	parse'' pos (l:ls)
  26. 		| isDigit (head l) = ifp (<= 2) $ add 3 (Operand $ read l) ls
  27. 		| l == "(" = ifp (<= 2) $ uncurry (add 3) =<< parse' ls
  28. 		| l == ")" = ifp (>= 3) $ Just ([opg], ls)
  29. 		| pos <= 1 = choose 1
  30. 		| pos <= 4 = choose 4 where
  31. 		ifp g x = if g pos then x else Nothing
  32. 		choose i = flip (uncurry add) ls =<< case (toOp i l, ifp (< i) $ toOp (i - 1) l) of
  33. 			(Just t, Nothing) -> Just (i `rem` 2 + 1, t)
  34. 			(Nothing, Just t) -> Just (i, t)
  35. 			_ -> Nothing
  36.  
  37. eval (Operand t) = t
  38. eval (Statement t) = fst . snd $ eval' (0, True) (undefined, t) where
  39. 	(opg, sf) = ((10, undefined), second . first)
  40. 	cond (pr1, as1) (pr2, as2) = pr1 > pr2 || pr1 == pr2 && if as1 == as2 then as1
  41. 		else error "cannot mix two operators"
  42. 	eval' _ (n, (Operator (Prefix g) : ts)) = sf g $ eval' opg (undefined, ts)
  43. 	eval' op (n, (Operator (Postfix g) : ts)) = eval' op (g n, ts)
  44. 	eval' op (n, tts@(Operator o : ts))
  45. 		| cond op opt = (opt, (n, tts))
  46. 		| otherwise = sf oper $ until (cond opt . fst) (eval' opt . snd) (opg, (n, ts)) 
  47. 		where (oper, opt) = case o of
  48. 			Prinfix t -> t
  49. 			Infix t -> first ($ n) t
  50. 	eval' op (n, t : ts) = eval' op (eval t, ts)
  51.  
  52. calc = fmap eval . parse
  53.  
  54. main = mapM_ (print . calc) 
  55. 	[ "2 + 3"
  56.     , "4 - 3"
  57.     , "2 + (-3)"
  58.     , "4 * 5"
  59.     , "6/4"
  60.     , "1.2 + 1/2"
  61.     , "1/(-3)"
  62.     , "0.5 + 0.2"
  63.     , "3 ^ 2 ^ 2"
  64.     , "17654/342"
  65.     , "2/3 ^ 2"
  66.     , "(2/3) ^ 2"
  67. 	, "(2 + 3) / (2 - 2)"
  68. 	, "2 + 345 + + + + 6"
  69. 	, "  - sqr 5! +(-sqr(1 - 2^ 3) ^sqr 2 *9 !)    "
  70. 	, "5 + 9 3"
  71. 	, "sqr sqr 3"
  72. 	]
Success #stdin #stdout 0s 6392KB
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/QR7OfU
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!