module Language.Egison.Numerical where
import Language.Egison.Types
import Control.Monad.Error
import Data.Array
boolBinop :: (Bool -> Bool -> Bool) -> [EgisonVal] -> ThrowsError EgisonVal
boolBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal
boolBinop op aparams = mapM unpackBool aparams >>= return . Bool . foldl1 op
numericSglop :: (Integer -> Integer) -> [EgisonVal] -> ThrowsError EgisonVal
numericSglop op [x] = unpackNum x >>= return . Number . op
numericSglop _ params = throwError $ NumArgs 1 params
floatSglop :: (Double -> Double) -> [EgisonVal] -> ThrowsError EgisonVal
floatSglop op [x] = unpackFloat x >>= return . Float . op
floatSglop _ params = throwError $ NumArgs 1 params
floatNumSglop :: (Double -> Integer) -> [EgisonVal] -> ThrowsError EgisonVal
floatNumSglop op [x] = unpackFloat x >>= return . Number . op
floatNumSglop _ params = throwError $ NumArgs 1 params
numericBinop :: (Integer -> Integer -> Integer) -> [EgisonVal] -> ThrowsError EgisonVal
numericBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal
numericBinop op aparams = mapM unpackNum aparams >>= return . Number . foldl1 op
floatBinop :: (Double -> Double -> Double) -> [EgisonVal] -> ThrowsError EgisonVal
floatBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal
floatBinop op aparams = mapM unpackFloat aparams >>= return . Float . foldl1 op
stringBinop :: (String -> String -> String) -> [EgisonVal] -> ThrowsError EgisonVal
stringBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal
stringBinop op aparams = mapM unpackString aparams >>= return . String . foldl1 op
charBoolBinop :: (Char -> Char -> Bool) -> [EgisonVal] -> ThrowsError EgisonVal
charBoolBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal
charBoolBinop op aparams = mapM unpackChar aparams >>= doOp
where doOp [a, b] = return $ Bool $ op a b
doOp _ = throwError $ Default "Unexpected error in numCharBinop"
strBoolBinop :: (String -> String -> Bool) -> [EgisonVal] -> ThrowsError EgisonVal
strBoolBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal
strBoolBinop op aparams = mapM unpackString aparams >>= doOp
where doOp [a, b] = return $ Bool $ op a b
doOp _ = throwError $ Default "Unexpected error in numCharBinop"
numBoolBinop :: (Integer -> Integer -> Bool) -> [EgisonVal] -> ThrowsError EgisonVal
numBoolBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal
numBoolBinop op aparams = mapM unpackNum aparams >>= doOp
where doOp [a, b] = return $ Bool $ op a b
doOp _ = throwError $ Default "Unexpected error in numBoolBinop"
floatBoolBinop :: (Double -> Double -> Bool) -> [EgisonVal] -> ThrowsError EgisonVal
floatBoolBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal
floatBoolBinop op aparams = mapM unpackFloat aparams >>= doOp
where doOp [a, b] = return $ Bool $ op a b
doOp _ = throwError $ Default "Unexpected error in floatBoolBinop"
foldlM :: Monad m => (a -> b -> m a) -> a -> [b] -> m a
foldlM f v (x : xs) = (f v x) >>= \ a -> foldlM f a xs
foldlM _ v [] = return v
foldl1M :: Monad m => (a -> a -> m a) -> [a] -> m a
foldl1M f (x : xs) = foldlM f x xs
foldl1M _ _ = error "Unexpected error in foldl1M"
floatRound, floatFloor, floatCeiling, floatTruncate :: [EgisonVal] -> ThrowsError EgisonVal
floatRound [(Float n)] = return $ Float $ fromInteger $ round n
floatRound [x] = throwError $ TypeMismatch "floatber" [x]
floatRound badArgList = throwError $ NumArgs 1 badArgList
floatFloor [(Float n)] = return $ Float $ fromInteger $ floor n
floatFloor [x] = throwError $ TypeMismatch "number" [x]
floatFloor badArgList = throwError $ NumArgs 1 badArgList
floatCeiling [(Float n)] = return $ Float $ fromInteger $ ceiling n
floatCeiling [x] = throwError $ TypeMismatch "number" [x]
floatCeiling badArgList = throwError $ NumArgs 1 badArgList
floatTruncate [(Float n)] = return $ Float $ fromInteger $ truncate n
floatTruncate [x] = throwError $ TypeMismatch "number" [x]
floatTruncate badArgList = throwError $ NumArgs 1 badArgList
numSqrt, numExpt :: [EgisonVal] -> ThrowsError EgisonVal
numSqrt [(Float n)] = if n >= 0 then return $ Float $ sqrt n
else throwError $ Default "negative number to sqrt"
numSqrt [x] = throwError $ TypeMismatch "number" [x]
numSqrt badArgList = throwError $ NumArgs 1 badArgList
numExpt [(Number n), (Number p)] = return $ Float $ (fromInteger n) ^ p
numExpt [(Float n), (Number p)] = return $ Float $ n ^ p
numExpt [_, y] = throwError $ TypeMismatch "integer" [y]
numExpt badArgList = throwError $ NumArgs 2 badArgList
numExp :: [EgisonVal] -> ThrowsError EgisonVal
numExp [(Number n)] = return $ Float $ exp $ fromInteger n
numExp [(Float n)] = return $ Float $ exp n
numExp [x] = throwError $ TypeMismatch "number" [x]
numExp badArgList = throwError $ NumArgs 1 badArgList
numLog :: [EgisonVal] -> ThrowsError EgisonVal
numLog [(Number n)] = return $ Float $ log $ fromInteger n
numLog [(Float n)] = return $ Float $ log n
numLog [x] = throwError $ TypeMismatch "number" [x]
numLog badArgList = throwError $ NumArgs 1 badArgList
isEgisonEOF :: [EgisonVal] -> ThrowsError EgisonVal
isEgisonEOF [EOF] = return $ Bool True
isEgisonEOF [_] = return $ Bool False
isEgisonEOF badArgList = throwError $ NumArgs 1 badArgList
unpackBool :: EgisonVal -> ThrowsError Bool
unpackBool (Bool b) = return b
unpackBool notBool = throwError $ TypeMismatch "bool" [notBool]
unpackChar :: EgisonVal -> ThrowsError Char
unpackChar (Char c) = return c
unpackChar notChar = throwError $ TypeMismatch "char" [notChar]
unpackString :: EgisonVal -> ThrowsError String
unpackString (String str) = return str
unpackString notString = throwError $ TypeMismatch "string" [notString]
unpackNum :: EgisonVal -> ThrowsError Integer
unpackNum (Number n) = return n
unpackNum notNum = throwError $ TypeMismatch "number" [notNum]
unpackFloat :: EgisonVal -> ThrowsError Double
unpackFloat (Float n) = return n
unpackFloat notFloat = throwError $ TypeMismatch "float" [notFloat]
tupleToCollection :: [EgisonVal] -> ThrowsError EgisonVal
tupleToCollection vals = return $ Collection $ map Element vals
collectionToTuple :: [EgisonVal] -> ThrowsError EgisonVal
collectionToTuple [(Collection innerVals)] = do
let vals = innerValsToList innerVals
case vals of
[val] -> return val
_ -> return $ Tuple $ map Element vals
collectionToTuple [x] = throwError $ TypeMismatch "collection" [x]
collectionToTuple badArgList = throwError $ NumArgs 1 badArgList
stringToChars :: [EgisonVal] -> ThrowsError EgisonVal
stringToChars [(String str)] = return $ Collection $ map (\c -> Element $ Char c) str
stringToChars [x] = throwError $ TypeMismatch "string" [x]
stringToChars badArgList = throwError $ NumArgs 1 badArgList
charsToString :: [EgisonVal] -> ThrowsError EgisonVal
charsToString [(Collection innerVals)] = do
let chars = innerValsToList innerVals
cs <- mapM (\char -> case char of
Char c -> return c
_ -> throwError $ TypeMismatch "chars" [char])
chars
return $ String cs
charsToString [x] = throwError $ TypeMismatch "collection of chars" [x]
charsToString badArgList = throwError $ NumArgs 1 badArgList
arrayDimension :: [EgisonVal] -> ThrowsError EgisonVal
arrayDimension [(Array d _ _)] = return $ Number d
arrayDimension [x] = throwError $ TypeMismatch "array" [x]
arrayDimension badArgList = throwError $ NumArgs 1 badArgList
arrayRange :: [EgisonVal] -> ThrowsError EgisonVal
arrayRange [(Array _ ns _)] = return $ Tuple $ map (Element . Number) ns
arrayRange [x] = throwError $ TypeMismatch "array" [x]
arrayRange badArgList = throwError $ NumArgs 1 badArgList
arraySize :: [EgisonVal] -> ThrowsError EgisonVal
arraySize [(Number m), (Array _ ns _)] = return $ Number $ nth m ns
arraySize [x, y] = throwError $ TypeMismatch "number, array" [x, y]
arraySize badArgList = throwError $ NumArgs 2 badArgList
arrayKeys :: [EgisonVal] -> ThrowsError EgisonVal
arrayKeys [(Array _ ms _)] = return $ Collection $ map (\iss -> (Element . Tuple) $ map (Element . Number) iss) $ indexList ms
arrayKeys [x] = throwError $ TypeMismatch "array" [x]
arrayKeys badArgList = throwError $ NumArgs 1 badArgList
arrayIsRange :: [EgisonVal] -> ThrowsError EgisonVal
arrayIsRange [key, (Array _ ms _)] = do
ns <- mapM (\val -> case val of
Number n -> return n
_ -> throwError $ TypeMismatch "number" [val])
(tupleToList key)
return $ Bool $ helper ns ms
where helper [] [] = True
helper (n:ns) (m:ms) = if (n > 0 && n <= m)
then helper ns ms
else False
arrayIsRange [x, y] = throwError $ TypeMismatch "key, array" [x, y]
arrayIsRange badArgList = throwError $ NumArgs 2 badArgList
arrayRef :: [EgisonVal] -> ThrowsError EgisonVal
arrayRef [tuple, (Array _ ms arr)] = do
ns <- mapM unpackNum $ tupleToList tuple
let i = integersToInteger ms ns
return $ (arr ! i)
arrayRef [x, y] = throwError $ TypeMismatch "tuple of number, array" [x, y]
arrayRef badArgList = throwError $ NumArgs 2 badArgList