diff --git a/src/Kind/CompileJS.hs b/src/Kind/CompileJS.hs index af3651883..5248afbc4 100644 --- a/src/Kind/CompileJS.hs +++ b/src/Kind/CompileJS.hs @@ -545,6 +545,7 @@ fnToJS book fnName ct@(getArguments -> (fnArgs, fnBody)) = do operToJS XOR = "^" operToJS LSH = "<<" operToJS RSH = ">>" + operToJS _ = "" -- Compiles a CType to TS tyToTS :: CT -> Int -> String @@ -750,12 +751,17 @@ fnToJS book fnName ct@(getArguments -> (fnArgs, fnBody)) = do fstStmt <- ctToJS False fstName fst dep sndStmt <- ctToJS False sndName snd dep - - let retExpr = case typ of - CF64 -> concat [fstName, " ", opr', " ", sndName] - CU64 -> concat ["BigInt.asUintN(64, ", fstName, " ", opr', " ", sndName, ")"] + let retExpr = case (typ, opr) of + (CF64, COS) -> concat ["Math.cos(", fstName, ")"] + (CF64, SIN) -> concat ["Math.sin(", fstName, ")"] + (CF64, TAN) -> concat ["Math.tan(", fstName, ")"] + (CF64, ATAN) -> concat ["Math.atan(", fstName, ")"] + (CF64, ATAN2) -> concat ["Math.atan2(", fstName, ", ", sndName, ")"] + (CF64, ROUND) -> concat ["(Math.round(", fstName, " * Math.pow(10, 2)) / Math.pow(10, 2))"] + (CF64, _) -> concat [fstName, " ", opr', " ", sndName] + (CU64, _) -> concat ["BigInt.asUintN(64, ", fstName, " ", opr', " ", sndName, ")"] _ -> error ("Invalid type for binary operation: " ++ showCT typ dep) - + retStmt <- set var retExpr return $ concat [fstStmt, sndStmt, retStmt] go (CLog msg nxt) = do diff --git a/src/Kind/Parse.hs b/src/Kind/Parse.hs index 409b5b27c..eed23029b 100644 --- a/src/Kind/Parse.hs +++ b/src/Kind/Parse.hs @@ -14,6 +14,7 @@ import Kind.Equal import Kind.Reduce import Kind.Show import Kind.Type +import Kind.Util import Prelude hiding (EQ, LT, GT) import System.Console.ANSI import Text.Parsec ((), (<|>), getPosition, sourceLine, sourceColumn, getState, setState) @@ -530,7 +531,9 @@ parseOp2 = withSrc $ do char_skp '(' opr <- parseOper fst <- parseTerm - snd <- parseTerm + snd <- if isUnary opr + then return (Flt 0.0) -- Fill snd with `Flt 0.0` for unary operators + else parseTerm -- Parse the second term for binary operators char ')' return $ Op2 opr fst snd @@ -608,6 +611,12 @@ parseOper = P.choice , P.try (string_skp "&") >> return AND , P.try (string_skp "|") >> return OR , P.try (string_skp "^") >> return XOR + , P.try (string_skp "cos") >> return COS + , P.try (string_skp "sin") >> return SIN + , P.try (string_skp "tan") >> return TAN + , P.try (string_skp "atan2") >> return ATAN2 + , P.try (string_skp "atan") >> return ATAN + , P.try (string_skp "round") >> return ROUND ] "Binary operator" parseSuffix :: Term -> Parser Term diff --git a/src/Kind/Reduce.hs b/src/Kind/Reduce.hs index ed2a03ae9..95669ce8d 100644 --- a/src/Kind/Reduce.hs +++ b/src/Kind/Reduce.hs @@ -85,6 +85,11 @@ reduce book fill lv term = red term where op2 XOR (Num fst) (Num snd) = Num (fst `xor` snd) op2 LSH (Num fst) (Num snd) = Num (shiftL fst (fromIntegral snd)) op2 RSH (Num fst) (Num snd) = Num (shiftR fst (fromIntegral snd)) + op2 COS (Num _) _ = error "COS operation not supported for integer values" + op2 SIN (Num _) _ = error "SIN operation not supported for integer values" + op2 ATAN (Num _) _ = error "ATAN2 operation not supported for integer values" + op2 ATAN2 (Num _) (Num _) = error "ATAN2 operation not supported for integer values" + op2 ROUND (Num _) _ = error "ROUND operation not supported for integer values" op2 op (Ref nam) (Flt snd) | lv > 0 = op2 op (ref nam) (Flt snd) op2 op (Flt fst) (Ref nam) | lv > 0 = op2 op (Flt fst) (ref nam) op2 ADD (Flt fst) (Flt snd) = Flt (fst + snd) @@ -101,6 +106,12 @@ reduce book fill lv term = red term where op2 AND (Flt _) (Flt _) = error "Bitwise AND not supported for floating-point numbers" op2 OR (Flt _) (Flt _) = error "Bitwise OR not supported for floating-point numbers" op2 XOR (Flt _) (Flt _) = error "Bitwise XOR not supported for floating-point numbers" + op2 COS (Flt fst) _ = Flt (cos fst) + op2 SIN (Flt fst) _ = Flt (sin fst) + op2 TAN (Flt fst) _ = Flt (tan fst) + op2 ATAN (Flt fst) _ = Flt (atan fst) + op2 ATAN2 (Flt fst) (Flt snd) = Flt (atan2 fst snd) + op2 ROUND (Flt fst) (Flt _) = Flt (fromIntegral (round (fst * 100)) / 100) op2 opr fst snd = Op2 opr fst snd ref nam | lv > 0 = case M.lookup nam book of diff --git a/src/Kind/Show.hs b/src/Kind/Show.hs index 36203d050..a03fe05ad 100644 --- a/src/Kind/Show.hs +++ b/src/Kind/Show.hs @@ -174,6 +174,12 @@ showOper OR = "|" showOper XOR = "^" showOper LSH = "<<" showOper RSH = ">>" +showOper COS = "cos" +showOper SIN = "sin" +showOper TAN = "tan" +showOper ATAN = "atan" +showOper ATAN2 = "atan2" +showOper ROUND = "round" -- Pretty Printing (Sugars) -- ------------------------ diff --git a/src/Kind/Type.hs b/src/Kind/Type.hs index 39c84cccd..b4d9ce1b7 100644 --- a/src/Kind/Type.hs +++ b/src/Kind/Type.hs @@ -122,10 +122,12 @@ data Cod = Cod Loc Loc -- Numeric Operators data Oper - = ADD | SUB | MUL | DIV - | MOD | EQ | NE | LT - | GT | LTE | GTE | AND - | OR | XOR | LSH | RSH + = ADD | SUB | MUL | DIV + | MOD | EQ | NE | LT + | GT | LTE | GTE | AND + | OR | XOR | LSH | RSH + | COS | SIN | TAN | ATAN + | ATAN2 | ROUND deriving Show -- Telescope diff --git a/src/Kind/Util.hs b/src/Kind/Util.hs index 5d0bcf837..8395043e9 100644 --- a/src/Kind/Util.hs +++ b/src/Kind/Util.hs @@ -162,6 +162,12 @@ getOpReturnType MUL U64 = U64 getOpReturnType MUL F64 = F64 getOpReturnType DIV U64 = U64 getOpReturnType DIV F64 = F64 +getOpReturnType COS F64 = F64 +getOpReturnType SIN F64 = F64 +getOpReturnType TAN F64 = F64 +getOpReturnType ATAN F64 = F64 +getOpReturnType ATAN2 F64 = F64 +getOpReturnType ROUND F64 = F64 getOpReturnType MOD U64 = U64 getOpReturnType EQ _ = U64 getOpReturnType NE _ = U64 @@ -182,3 +188,10 @@ checkValidType typ validTypes dep = foldr (\t acc -> do if isEqual then return True else acc ) (return False) validTypes +isUnary :: Oper -> Bool +isUnary COS = True +isUnary SIN = True +isUnary TAN = True +isUnary ATAN = True +isUnary ROUND = True +isUnary _ = False