added logical operators

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@(BNum _)] = x
-eval [x@(BFloat _)] = 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@(BNum _):xy) ops nums = treeEval xy ops (x:nums)
-treeEval (x@(BFloat _):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)) =
+handleOp expr (op:ops) ((BNum op2):((BNum op1):nums)) =
-    treeEval expr ops ((evalOp op op1 op2):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
+findOp x = case binOp x of
-evalOp (BOp "/") (BInt x) (BInt y) = BInt $ quot x y
+            Just op -> \a -> \b -> (BNum $ op a b)
-evalOp (BOp "+") (BInt x) (BInt y) = BInt $ x + y
+            Nothing ->
-evalOp (BOp "-") (BInt x) (BInt y) = BInt $ x - y
+              case logicalOp x of
-evalOp (BOp "^") (BInt x) (BInt y) = BInt $ x ^ y
+                Just lop -> \a -> \b -> (BBool $ lop a b)
-evalOp (BOp "*") (BFloat x) (BInt y) = BFloat $ x * fromIntegral y
+                Nothing -> \a -> \b -> (BNum $ BInt 0)
-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
+logicalOp :: Value -> Maybe (Number -> Number -> Bool)
-evalOp (BOp "^") (BFloat x) (BInt y) = BFloat $ x ** fromIntegral y
+logicalOp (BOp ">") = Just (>)
-evalOp (BOp "*") (BInt x) (BFloat y) = BFloat $ fromIntegral x * y
+logicalOp (BOp "<") = Just (<)
-evalOp (BOp "/") (BInt x) (BFloat y) = BFloat $ fromIntegral x / y
+logicalOp (BOp ">=") = Just (>=)
-evalOp (BOp "+") (BInt x) (BFloat y) = BFloat $ fromIntegral x + y
+logicalOp (BOp "<=") = Just (<=)
-evalOp (BOp "-") (BInt x) (BFloat y) = BFloat $ fromIntegral x - y
+logicalOp (BOp "==") = Just (==)
-evalOp (BOp "^") (BInt x) (BFloat y) = BFloat $ fromIntegral x ** y
+logicalOp (BOp "!=") = Just (/=)
-evalOp (BOp "*") (BFloat x) (BFloat y) = BFloat $ x * y
+logicalOp _ = Nothing
-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
+binOp :: Value -> Maybe (Number -> Number -> Number)
-evalOp (BOp "^") (BFloat x) (BFloat y) = BFloat $ x ** y
+binOp (BOp "*") = Just (*)
-evalOp _ _ _ = BInt 0
+binOp (BOp "/") = Just (/)
+binOp (BOp "+") = Just (+)
+binOp (BOp "-") = Just (-)
+binOp (BOp "^") = Just (**)
+binOp _ = Nothing

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)
+      Just "-" -> (return . BNum . BFloat . read) ("-" ++ x ++ "." ++ y)
-      _        -> (return . 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)
+      Just "-" -> (return . BNum . BInt . read) ("-" ++ x)
-      _        -> (return . BInt . read) x
+      _        -> (return . BNum . BInt . read) x
 
 
 bool :: P.Parser Value

src/BC/Types.hs

@@ -1,26 +1,76 @@
 module BC.Types where
 
-data Value = BInt Integer
+data Value = BNum Number
-           | BFloat Double
            | 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 "^") = 5
-precedence (BOp "*") = 2
+precedence (BOp "*") = 4
-precedence (BOp "/") = 2
+precedence (BOp "/") = 4
-precedence (BOp "-") = 1
+precedence (BOp "-") = 3
-precedence (BOp "+") = 1
+precedence (BOp "+") = 3
-precedence (BOp "%") = 2
+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