{-# LANGUAGE OverloadedStrings #-}
module Koneko.Math (initCtx) where
import Control.Exception (throwIO)
import Control.Monad (when)
import Data.Foldable (traverse_)
import Koneko.Data
initCtx :: Context -> IO ()
initCtx :: Context -> IO ()
initCtx Context
ctxMain = do
Context
ctx <- Identifier -> Context -> IO Context
forkContext Identifier
"math" Context
ctxMain
(Builtin -> IO ()) -> [Builtin] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Context -> Builtin -> IO ()
defPrim Context
ctx) [
Identifier -> Evaluator -> Builtin
mkBltn Identifier
"sign" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (Either Integer Double -> KValue) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 ((Either Integer Double -> KValue) -> Evaluator)
-> (Either Integer Double -> KValue) -> Evaluator
forall a b. (a -> b) -> a -> b
$ (Integer -> KValue)
-> (Double -> KValue) -> Either Integer Double -> KValue
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Integer -> KValue
int (Integer -> KValue) -> (Integer -> Integer) -> Integer -> KValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer
forall a. Num a => a -> a
signum) (Double -> KValue
float (Double -> KValue) -> (Double -> Double) -> Double -> KValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double
forall a. Num a => a -> a
signum),
Builtin
pow, Identifier -> (Double -> Double -> Double) -> Builtin
op2 Identifier
"**" Double -> Double -> Double
forall a. Floating a => a -> a -> a
(**), Identifier -> Evaluator -> Builtin
mkBltn Identifier
"pi" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (Stack -> IO Stack) -> Evaluator
forall a b. a -> b -> a
const ((Stack -> IO Stack) -> Evaluator)
-> (Stack -> IO Stack) -> Evaluator
forall a b. (a -> b) -> a -> b
$ (Stack -> Double -> IO Stack) -> Double -> Stack -> IO Stack
forall a b c. (a -> b -> c) -> b -> a -> c
flip Stack -> Double -> IO Stack
forall a. ToVal a => Stack -> a -> IO Stack
rpush1 (Double
forall a. Floating a => a
pi :: Double),
Identifier -> (Double -> Double) -> Builtin
op1 Identifier
"exp" Double -> Double
forall a. Floating a => a -> a
exp, Identifier -> (Double -> Double) -> Builtin
op1 Identifier
"log" Double -> Double
forall a. Floating a => a -> a
log, Identifier -> (Double -> Double) -> Builtin
op1 Identifier
"sqrt" Double -> Double
forall a. Floating a => a -> a
sqrt,
Identifier -> (Double -> Double) -> Builtin
op1 Identifier
"sin" Double -> Double
forall a. Floating a => a -> a
sin, Identifier -> (Double -> Double) -> Builtin
op1 Identifier
"cos" Double -> Double
forall a. Floating a => a -> a
cos, Identifier -> (Double -> Double) -> Builtin
op1 Identifier
"tan" Double -> Double
forall a. Floating a => a -> a
tan,
Identifier -> (Double -> Double) -> Builtin
op1 Identifier
"asin" Double -> Double
forall a. Floating a => a -> a
asin, Identifier -> (Double -> Double) -> Builtin
op1 Identifier
"acos" Double -> Double
forall a. Floating a => a -> a
acos, Identifier -> (Double -> Double) -> Builtin
op1 Identifier
"atan" Double -> Double
forall a. Floating a => a -> a
atan,
Identifier -> (Double -> Double) -> Builtin
op1 Identifier
"sinh" Double -> Double
forall a. Floating a => a -> a
sinh, Identifier -> (Double -> Double) -> Builtin
op1 Identifier
"cosh" Double -> Double
forall a. Floating a => a -> a
cosh, Identifier -> (Double -> Double) -> Builtin
op1 Identifier
"tanh" Double -> Double
forall a. Floating a => a -> a
tanh,
Identifier -> (Double -> Double) -> Builtin
op1 Identifier
"asinh" Double -> Double
forall a. Floating a => a -> a
asinh, Identifier -> (Double -> Double) -> Builtin
op1 Identifier
"acosh" Double -> Double
forall a. Floating a => a -> a
acosh, Identifier -> (Double -> Double) -> Builtin
op1 Identifier
"atanh" Double -> Double
forall a. Floating a => a -> a
atanh,
Identifier -> (Double -> Double -> Double) -> Builtin
op2 Identifier
"atan2" Double -> Double -> Double
forall a. RealFloat a => a -> a -> a
atan2
]
op1 :: Identifier -> (Double -> Double) -> Builtin
op1 :: Identifier -> (Double -> Double) -> Builtin
op1 Identifier
name Double -> Double
op = Identifier -> Evaluator -> Builtin
mkBltn Identifier
name (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (Double -> Double) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 Double -> Double
op
op2 :: Identifier -> (Double -> Double -> Double) -> Builtin
op2 :: Identifier -> (Double -> Double -> Double) -> Builtin
op2 Identifier
name Double -> Double -> Double
op = Identifier -> Evaluator -> Builtin
mkBltn Identifier
name (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ (Double -> Double -> Double) -> Evaluator
forall a b c.
(FromVal a, FromVal b, ToVal c) =>
(a -> b -> c) -> Evaluator
pop2push1 Double -> Double -> Double
op
pow :: Builtin
pow :: Builtin
pow = Identifier -> Evaluator -> Builtin
mkBltn Identifier
"^" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
_ Stack
s -> do
((Integer
x, Integer
y), Stack
s') <- Stack -> IO ((Integer, Integer), Stack)
forall a b. (FromVal a, FromVal b) => Stack -> IO ((a, b), Stack)
pop2' Stack
s
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
y Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ KException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (KException -> IO ()) -> KException -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> KException
RangeError String
"negative exponent"
Stack -> Integer -> IO Stack
forall a. ToVal a => Stack -> a -> IO Stack
rpush1 Stack
s' (Integer -> IO Stack) -> Integer -> IO Stack
forall a b. (a -> b) -> a -> b
$ (Integer
x :: Integer) Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
y :: Integer)