{-# LANGUAGE 
        MultiParamTypeClasses, 
        TypeSynonymInstances, 
        FlexibleContexts    #-}

-- | Arithmetic operators

module CsoundExpr.Base.Arithmetic 
	(Opr2, (<+>), neg, (<->), (<*>), (</>), (<^>), (<%>), (^*))
where

import Prelude hiding (div)

import Control.Applicative(liftA2, (<$>))
import Data.Function(on)

import CsoundExpr.Translator.Types 
import CsoundExpr.Translator.Cs.CsTree
import CsoundExpr.Translator.ExprTree.ExprTree
import CsoundExpr.Base.UserDefined

import CsoundExpr.Base.Types (Irate(..), Krate(..), Arate(..))

import CsoundExpr.Base.Boolean

infixr 9  ^* 
infixr 8  <^>
infixr 7  <*>, </>
infixr 6  <+>, <->, <%>


subst :: (IM d a, IM d b, IM d c) => (d -> d -> c) -> (a -> b -> c)
subst f x y = f (to x) (to y)

opr1 :: IM CsTree a => Name -> (Double -> Double) -> CsTree -> a
opr1 name fun a = maybe (unaryInfixOperation name a) 
			from (optim1 fun a)

opr1p :: IM CsTree a => Name -> (Double -> Double) -> CsTree -> a
opr1p name fun a = maybe (prefixOperation name $ return a)
			 from (optim1 fun a)	

opr2 :: IM CsTree a => Name -> (Double -> Double -> Double) -> CsTree -> CsTree -> a
opr2 name fun a b = maybe (infixOperation name [a, b])
			  from (optim2 fun a b)

optim1 :: (Double -> Double) -> CsTree -> Maybe CsTree
optim1 fun a
	| isVal a'  = fmap (double . fun) $ toDouble $ value a'
 	| otherwise = Nothing
	where a' = exprOp $ exprTreeTag a

optim2 :: (Double -> Double -> Double) -> CsTree -> CsTree -> Maybe CsTree
optim2 fun a b  
	| isVal a' && isVal b' = fmap double $
				 (liftA2 fun `on` toDouble . value) a' b' 
	| otherwise            = Nothing
	where a' = exprOp $ exprTreeTag a 
	      b' = exprOp $ exprTreeTag b	


----------------------------------------------------------
-- Type inference

(<+>), (<->), (<*>), (</>), (<^>), (<%>) :: (X a, X b, X (Opr2 a b)) => a -> b -> Opr2 a b

(<+>) = subst $ opr2 "+" (+)
(<->) = subst $ opr2 "-" (-)
(<*>) = subst $ opr2 "*" (*)
(</>) = subst $ opr2 "/" (/)

-- | "power of" operator
(<^>) = subst $ opr2 "^" (**)

-- | modulus operator
(<%>) = subst $ opr2 "%" modDouble

-- | negation
neg :: (X a) => a -> a
neg = opr1 "-" negate . to

-- | scaling
(^*) :: X a => Irate -> a -> a
(^*) = subst $ opr2 "*" (*)


modDouble :: Double -> Double -> Double
modDouble a b = signum a * until ( < b') (+ (-b')) a'
    where a' = abs a
          b' = abs b

----------------------------------------------------------
-- Num instances
--

instance Eq Arate where
    (==) = error "(==) is undefined"
    (/=) = error "(/=) is undefined"

instance Eq Krate where
    (==) = error "(==) is undefined"
    (/=) = error "(/=) is undefined"

instance Eq Irate where
    (==) = error "(==) is undefined"
    (/=) = error "(/=) is undefined"



instance Num Arate where
    (+) = (<+>)
    (*) = (<*>)
    abs = opr1p "abs" abs . to
    signum x = ifB (krate x >* num 0) 1 $ ifB (krate x <* num 0) (-1) 0
    (-) = (<->)
    fromInteger = double . fromInteger


instance Fractional Arate where
    (/) = (</>)
    fromRational = double . fromRational


instance Num Krate where
    (+) = (<+>)
    (*) = (<*>)
    abs = opr1p "abs" abs . to
    signum x = ifB (x >* num 0) 1 $ ifB (x <* num 0) (-1) 0 
    (-) = (<->)
    fromInteger = double . fromInteger


instance Fractional Krate where
    (/) = (</>)
    fromRational = double . fromRational


instance Num Irate where
    (+) = (<+>)
    (*) = (<*>)
    abs = opr1p "abs" abs . to
    signum x = ifB (x >* num 0) 1 $ ifB (x <* num 0) (-1) 0 
    (-) = (<->)
    fromInteger = double . fromInteger

num :: Irate -> Irate
num = id

instance Fractional Irate where
    (/) = (</>)
    fromRational = double . fromRational

--------------------------------------------------
--