--  --                                                          ; {{{1
--
--  File        : Koneko/Math.hs
--  Maintainer  : Felix C. Stegerman <flx@obfusk.net>
--  Date        : 2020-02-02
--
--  Copyright   : Copyright (C) 2020  Felix C. Stegerman
--  Version     : v0.0.1
--  License     : GPLv3+
--
--  --                                                          ; }}}1

{-# 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)

-- vim: set tw=70 sw=2 sts=2 et fdm=marker :