Phase.hs

module Synthesizer.Basic.Phase
   (T,
    fromRepresentative,
    toRepresentative,
    increment,
    decrement,
    multiply,
   ) where

import qualified Algebra.RealField             as RealField
import qualified Algebra.Ring                  as Ring
import qualified Algebra.Additive              as Additive

import qualified Algebra.ToInteger             as ToInteger

import System.Random (Random(..))
import Test.QuickCheck (Arbitrary(..), choose)

import Foreign.Storable (Storable(..), )
import Foreign.Ptr (castPtr, )

import Data.Tuple.HT (mapFst, )
import qualified NumericPrelude as NP


newtype T a = Cons {decons :: a}
   deriving Eq


instance Show a => Show (T a) where
   showsPrec p x =
      showParen (p >= 10)
         (showString "Phase.fromRepresentative " . showsPrec 11 (toRepresentative x))

instance Storable a => Storable (T a) where
   {-# INLINE sizeOf #-}
   sizeOf = sizeOf . toRepresentative
   {-# INLINE alignment #-}
   alignment = alignment . toRepresentative
   {-# INLINE peek #-}
   peek ptr = fmap Cons $ peek (castPtr ptr)
   {-# INLINE poke #-}
   poke ptr = poke (castPtr ptr) . toRepresentative


instance (Ring.C a, Random a) => Random (T a) where
   randomR = error "Phase.randomR makes no sense"
   random = mapFst Cons . randomR (NP.zero, NP.one)

instance (Ring.C a, Random a) => Arbitrary (T a) where
   arbitrary = fmap Cons $ choose (NP.zero, NP.one)
   coarbitrary = error "Phase.coarbitrary not implemented"



{-# INLINE fromRepresentative #-}
fromRepresentative :: RealField.C a => a -> T a
fromRepresentative = Cons . RealField.fraction

{-# INLINE toRepresentative #-}
toRepresentative :: T a -> a
toRepresentative = decons

{-# INLINE increment #-}
increment :: RealField.C a => a -> T a -> T a
increment d = lift (d Additive.+)

{-# INLINE decrement #-}
decrement :: RealField.C a => a -> T a -> T a
decrement d = lift (Additive.subtract d)

{-# INLINE multiply #-}
multiply :: (RealField.C a, ToInteger.C b) => b -> T a -> T a
multiply n x = fromRepresentative (toRepresentative x Ring.* NP.fromIntegral n)


instance RealField.C a => Additive.C (T a) where
   {-# INLINE zero #-}
   {-# INLINE (+) #-}
   {-# INLINE (-) #-}
   {-# INLINE negate #-}
   zero = Cons Additive.zero
   x + y = fromRepresentative (toRepresentative x Additive.+ toRepresentative y)
   x - y = fromRepresentative (toRepresentative x Additive.- toRepresentative y)
   negate = lift Additive.negate

{-# INLINE lift #-}
lift :: RealField.C a => (a -> a) -> T a -> T a
lift f =
   fromRepresentative . f . toRepresentative