Sign.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
module Data.Array.Accelerate.Fourier.Sign where

import Data.Array.Accelerate.Data.Complex (Complex((:+)), )

import qualified Data.Array.Accelerate as A
import Data.Array.Accelerate (Lift(lift), Unlift(unlift), Plain, Exp)
import Data.Array.Accelerate.Sugar.Elt (Elt)

import Data.Typeable (Typeable, )

import qualified Test.QuickCheck as QC


-- cf. colour-accelerate-0.4.0.0
newtype Sign a = Sign {getSign :: a}
   deriving (Eq, Show, Typeable, A.Generic)

{-# COMPLETE Sign_ #-}
pattern Sign_ :: Elt a => Exp a -> Exp (Sign a)
pattern Sign_ x = A.Pattern x

instance Elt a => Elt (Sign a)

instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Sign a) where
   type Plain (Sign a) = Sign (Plain a)
   lift (Sign a) = Sign_ (lift a)

instance Elt a => Unlift Exp (Sign (Exp a)) where
   unlift (Sign_ a) = Sign a


forward, inverse :: Num a => Sign a
forward = Sign (-1)
inverse = Sign 1

forwardExp, inverseExp :: (A.Num a) => Exp (Sign a)
forwardExp = lift $ Sign (-1 :: (A.Num a) => Exp a)
inverseExp = lift $ Sign ( 1 :: (A.Num a) => Exp a)

toSign :: (Elt a) => Exp (Sign a) -> Exp a
toSign = getSign . unlift

cis ::
   (A.RealFloat a) =>
   Exp (Sign a) -> Exp a -> Exp (Complex a)
cis sign w  =  A.lift $ cos w :+ toSign sign * sin w

cisRat ::
   (A.RealFloat a, A.FromIntegral Int a) =>
   Exp (Sign a) -> Exp Int -> Exp Int -> Exp (Complex a)
cisRat sign denom numer =
   cis sign $ 2*pi * A.fromIntegral numer / A.fromIntegral denom


instance (Num a) => QC.Arbitrary (Sign a) where
   arbitrary = QC.elements [forward, inverse]