added logical operators

2017-05-11 18:50:16 +02:00
parent 5603728a9b
commit 0a07021ef0
3 changed files with 95 additions and 43 deletions
--- a/src/BC/Eval.hs
+++ b/src/BC/Eval.hs
@@ -3,8 +3,7 @@ module BC.Eval (eval) where
 import BC.Types

 eval :: [Value] -> Value
-eval [x@(BInt _)] = x
-eval [x@(BFloat _)] = x
+eval [x@(BNum _)] = x
 eval [x@(BBool _)] = x
 eval [x@(BErr _)] = x
 eval [(BOp x)] = BErr ("operation " ++ x ++ " requires arguments")
@@ -14,10 +13,9 @@ eval l = treeEval l [] []
 treeEval :: [Value] -> [Value] -> [Value] -> Value
 treeEval [] [] (num:_) = num
 treeEval [] ops nums = handleOp [] ops nums
-treeEval (x@(BInt _):xy) ops nums = treeEval xy ops (x:nums)
-treeEval (x@(BFloat _):xy) ops nums = treeEval xy ops (x:nums)
+treeEval (x@(BNum _):xy) ops nums = treeEval xy ops (x:nums)
 treeEval ((BBool x):xy) ops nums =
-    treeEval xy ops ((BInt $ if x then 1 else 0):nums)
+    treeEval xy ops ((BNum $ BInt $ if x then 1 else 0):nums)
 treeEval expr@(x@(BOp _):xy) ops@(op:_) nums =
    if precedence x > precedence op
      then treeEval xy (x:ops) nums
@@ -25,29 +23,33 @@ treeEval expr@(x@(BOp _):xy) ops@(op:_) nums =
 treeEval (x@(BOp _):xy) [] nums = treeEval xy [x] nums

 handleOp :: [Value] -> [Value] -> [Value] -> Value
-handleOp expr (op:ops) (op2:(op1:nums)) =
-    treeEval expr ops ((evalOp op op1 op2):nums)
+handleOp expr (op:ops) ((BNum op2):((BNum op1):nums)) =
+    treeEval expr ops (((findOp op) op1 op2):nums)
 handleOp expr ((BOp op):ops) _ = BErr ("Not enough arguments to operation " ++ op)

-evalOp :: Value -> Value -> Value -> Value
-evalOp (BOp "*") (BInt x) (BInt y) = BInt $ x * y
-evalOp (BOp "/") (BInt x) (BInt y) = BInt $ quot x y
-evalOp (BOp "+") (BInt x) (BInt y) = BInt $ x + y
-evalOp (BOp "-") (BInt x) (BInt y) = BInt $ x - y
-evalOp (BOp "^") (BInt x) (BInt y) = BInt $ x ^ y
-evalOp (BOp "*") (BFloat x) (BInt y) = BFloat $ x * fromIntegral y
-evalOp (BOp "/") (BFloat x) (BInt y) = BFloat $ x / fromIntegral y
-evalOp (BOp "+") (BFloat x) (BInt y) = BFloat $ x + fromIntegral y
-evalOp (BOp "-") (BFloat x) (BInt y) = BFloat $ x - fromIntegral y
-evalOp (BOp "^") (BFloat x) (BInt y) = BFloat $ x ** fromIntegral y
-evalOp (BOp "*") (BInt x) (BFloat y) = BFloat $ fromIntegral x * y
-evalOp (BOp "/") (BInt x) (BFloat y) = BFloat $ fromIntegral x / y
-evalOp (BOp "+") (BInt x) (BFloat y) = BFloat $ fromIntegral x + y
-evalOp (BOp "-") (BInt x) (BFloat y) = BFloat $ fromIntegral x - y
-evalOp (BOp "^") (BInt x) (BFloat y) = BFloat $ fromIntegral x ** y
-evalOp (BOp "*") (BFloat x) (BFloat y) = BFloat $ x * y
-evalOp (BOp "/") (BFloat x) (BFloat y) = BFloat $ x / y
-evalOp (BOp "+") (BFloat x) (BFloat y) = BFloat $ x + y
-evalOp (BOp "-") (BFloat x) (BFloat y) = BFloat $ x - y
-evalOp (BOp "^") (BFloat x) (BFloat y) = BFloat $ x ** y
-evalOp _ _ _ = BInt 0
+
+findOp x = case binOp x of
+            Just op -> \a -> \b -> (BNum $ op a b)
+            Nothing ->
+              case logicalOp x of
+                Just lop -> \a -> \b -> (BBool $ lop a b)
+                Nothing -> \a -> \b -> (BNum $ BInt 0)
+
+
+logicalOp :: Value -> Maybe (Number -> Number -> Bool)
+logicalOp (BOp ">") = Just (>)
+logicalOp (BOp "<") = Just (<)
+logicalOp (BOp ">=") = Just (>=)
+logicalOp (BOp "<=") = Just (<=)
+logicalOp (BOp "==") = Just (==)
+logicalOp (BOp "!=") = Just (/=)
+logicalOp _ = Nothing
+
+
+binOp :: Value -> Maybe (Number -> Number -> Number)
+binOp (BOp "*") = Just (*)
+binOp (BOp "/") = Just (/)
+binOp (BOp "+") = Just (+)
+binOp (BOp "-") = Just (-)
+binOp (BOp "^") = Just (**)
+binOp _ = Nothing
--- a/src/BC/Parse.hs
+++ b/src/BC/Parse.hs
@@ -21,8 +21,8 @@ float = do
    _ <- P.string "."
    y <- P.many1 P.digit
    case neg of
-      Just "-" -> (return . BFloat . read) ("-" ++ x ++ "." ++ y)
-      _        -> (return . BFloat . read) (x ++ "." ++ y)
+      Just "-" -> (return . BNum . BFloat . read) ("-" ++ x ++ "." ++ y)
+      _        -> (return . BNum . BFloat . read) (x ++ "." ++ y)


 integer :: P.Parser Value
@@ -30,8 +30,8 @@ integer = do
    neg <- P.optionMaybe (P.string "-")
    x <- P.many1 P.digit
    case neg of
-      Just "-" -> (return . BInt . read) ("-" ++ x)
-      _        -> (return . BInt . read) x
+      Just "-" -> (return . BNum . BInt . read) ("-" ++ x)
+      _        -> (return . BNum . BInt . read) x


 bool :: P.Parser Value
--- a/src/BC/Types.hs
+++ b/src/BC/Types.hs
@@ -1,26 +1,76 @@
 module BC.Types where

-data Value = BInt Integer
-           | BFloat Double
+data Value = BNum Number
           | BBool Bool
           | BOp String
           | BErr String
 instance Show Value where
-  show (BInt i) = show i
-  show (BFloat f) = show f
  show (BBool b) = if b then "true" else "false"
  show (BOp  o) = o
+  show (BNum n) = show n
  show (BErr e) = "error: " ++ e

+
+-- sorry, this is a little hacky
+data Number = BInt Integer
+            | BFloat Double
+  deriving (Ord, Eq)
+instance Show Number where
+  show (BInt i) = show i
+  show (BFloat f) = show f
+
+instance Fractional Number where
+  (BInt x) / (BInt y) = BInt $ quot x y
+  (BFloat x) / (BFloat y) = BFloat $ x / y
+  (BInt x) / (BFloat y) = BFloat $ fromIntegral x / y
+  (BFloat x) / (BInt y) = BFloat $ x / fromIntegral y
+
+instance Floating Number where
+    (BFloat x) ** (BFloat y) = BFloat $ x ** y
+    (BFloat x) ** (BInt y) = BFloat $ x ** fromIntegral y
+    (BInt x) ** (BFloat y) = BFloat $ fromIntegral x ** y
+    (BInt x) ** (BInt y) = BInt $ x ^ y
+    logBase x y =  log y / log x
+    sqrt x = x ** (BFloat 0.5)
+    tan  x = sin x / cos x
+    tanh x =  sinh x / cosh x
+
+instance Num Number where
+  (BInt x) + (BInt y) = BInt $ x * y
+  (BFloat x) + (BFloat y) = BFloat $ x * y
+  (BInt x) + (BFloat y) = BFloat $ fromIntegral x * y
+  (BFloat x) + (BInt y) = BFloat $ x * fromIntegral y
+  (BInt x) * (BInt y) = BInt $ x * y
+  (BFloat x) * (BFloat y) = BFloat $ x * y
+  (BInt x) * (BFloat y) = BFloat $ fromIntegral x * y
+  (BFloat x) * (BInt y) = BFloat $ x * fromIntegral y
+  abs (BInt x) = BInt $ abs x
+  abs (BFloat x) = BFloat $ abs x
+  signum (BInt x) = BInt $ signum x
+  signum (BFloat x) = BFloat $ signum x
+  fromInteger x = BInt x
+  negate (BInt x) = BInt $ negate x
+  negate (BFloat x) = BFloat $ negate x
+
+
 isErr :: Value -> Bool
 isErr (BErr _) = True
 isErr _        = False

+
 precedence :: Value -> Int
-precedence (BOp "^") = 3
-precedence (BOp "*") = 2
-precedence (BOp "/") = 2
-precedence (BOp "-") = 1
-precedence (BOp "+") = 1
-precedence (BOp "%") = 2
+precedence (BOp "^") = 5
+precedence (BOp "*") = 4
+precedence (BOp "/") = 4
+precedence (BOp "-") = 3
+precedence (BOp "+") = 3
+precedence (BOp "%") = 4
+precedence (BOp "||") = 1
+precedence (BOp "&&") = 1
+precedence (BOp "<") = 2
+precedence (BOp ">") = 2
+precedence (BOp "<=") = 2
+precedence (BOp ">=") = 2
+precedence (BOp "==") = 2
+precedence (BOp "!=") = 2
 precedence _         = 0