module Synthesizer.Basic.Phase (
T,
fromRepresentative,
toRepresentative,
increment,
decrement,
multiply,
) where
import qualified Algebra.ToInteger as ToInteger
import qualified Algebra.RealRing as RealRing
import qualified Algebra.Ring as Ring
import qualified Algebra.Additive as Additive
import System.Random (Random(..))
import Test.QuickCheck (Arbitrary(arbitrary), choose)
import Foreign.Storable (Storable(..), )
import Foreign.Ptr (castPtr, )
import Data.Tuple.HT (mapFst, )
import qualified NumericPrelude.Numeric as NP
import NumericPrelude.Numeric
import NumericPrelude.Base
import Prelude ()
import qualified GHC.Float as GHC
newtype T a = Cons {forall a. T a -> a
decons :: a}
deriving T a -> T a -> Bool
(T a -> T a -> Bool) -> (T a -> T a -> Bool) -> Eq (T a)
forall a. Eq a => T a -> T a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => T a -> T a -> Bool
== :: T a -> T a -> Bool
$c/= :: forall a. Eq a => T a -> T a -> Bool
/= :: T a -> T a -> Bool
Eq
instance Show a => Show (T a) where
showsPrec :: Int -> T a -> ShowS
showsPrec Int
p T a
x =
Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
10)
(String -> ShowS
showString String
"Phase.fromRepresentative " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 (T a -> a
forall a. T a -> a
toRepresentative T a
x))
instance Storable a => Storable (T a) where
{-# INLINE sizeOf #-}
sizeOf :: T a -> Int
sizeOf = a -> Int
forall a. Storable a => a -> Int
sizeOf (a -> Int) -> (T a -> a) -> T a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T a -> a
forall a. T a -> a
toRepresentative
{-# INLINE alignment #-}
alignment :: T a -> Int
alignment = a -> Int
forall a. Storable a => a -> Int
alignment (a -> Int) -> (T a -> a) -> T a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T a -> a
forall a. T a -> a
toRepresentative
{-# INLINE peek #-}
peek :: Ptr (T a) -> IO (T a)
peek Ptr (T a)
ptr = (a -> T a) -> IO a -> IO (T a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> T a
forall a. a -> T a
Cons (IO a -> IO (T a)) -> IO a -> IO (T a)
forall a b. (a -> b) -> a -> b
$ Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek (Ptr (T a) -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr Ptr (T a)
ptr)
{-# INLINE poke #-}
poke :: Ptr (T a) -> T a -> IO ()
poke Ptr (T a)
ptr = Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr (T a) -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr Ptr (T a)
ptr) (a -> IO ()) -> (T a -> a) -> T a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T a -> a
forall a. T a -> a
toRepresentative
instance (Ring.C a, Random a) => Random (T a) where
randomR :: forall g. RandomGen g => (T a, T a) -> g -> (T a, g)
randomR = String -> (T a, T a) -> g -> (T a, g)
forall a. HasCallStack => String -> a
error String
"Phase.randomR makes no sense"
random :: forall g. RandomGen g => g -> (T a, g)
random = (a -> T a) -> (a, g) -> (T a, g)
forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst a -> T a
forall a. a -> T a
Cons ((a, g) -> (T a, g)) -> (g -> (a, g)) -> g -> (T a, g)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, a) -> g -> (a, g)
forall g. RandomGen g => (a, a) -> g -> (a, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (a
forall a. C a => a
zero, a
forall a. C a => a
one)
instance (Ring.C a, Random a) => Arbitrary (T a) where
arbitrary :: Gen (T a)
arbitrary = (a -> T a) -> Gen a -> Gen (T a)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> T a
forall a. a -> T a
Cons (Gen a -> Gen (T a)) -> Gen a -> Gen (T a)
forall a b. (a -> b) -> a -> b
$ (a, a) -> Gen a
forall a. Random a => (a, a) -> Gen a
choose (a
forall a. C a => a
zero, a
forall a. C a => a
one)
{-# INLINE fromRepresentative #-}
fromRepresentative :: RealRing.C a => a -> T a
fromRepresentative :: forall a. C a => a -> T a
fromRepresentative = a -> T a
forall a. a -> T a
Cons (a -> T a) -> (a -> a) -> a -> T a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
forall a. C a => a -> a
RealRing.fraction
{-# INLINE toRepresentative #-}
toRepresentative :: T a -> a
toRepresentative :: forall a. T a -> a
toRepresentative = T a -> a
forall a. T a -> a
decons
{-# INLINE increment #-}
increment :: RealRing.C a => a -> T a -> T a
increment :: forall a. C a => a -> T a -> T a
increment a
d = (a -> a) -> T a -> T a
forall b a. C b => (a -> b) -> T a -> T b
lift (a
d a -> a -> a
forall a. C a => a -> a -> a
Additive.+)
{-# INLINE decrement #-}
decrement :: RealRing.C a => a -> T a -> T a
decrement :: forall a. C a => a -> T a -> T a
decrement a
d = (a -> a) -> T a -> T a
forall b a. C b => (a -> b) -> T a -> T b
lift (a -> a -> a
forall a. C a => a -> a -> a
Additive.subtract a
d)
{-# INLINE add #-}
add :: (Ring.C a, Ord a) => T a -> T a -> T a
add :: forall a. (C a, Ord a) => T a -> T a -> T a
add (Cons a
x) (Cons a
y) =
let z :: a
z = a
xa -> a -> a
forall a. C a => a -> a -> a
+a
y
in a -> T a
forall a. a -> T a
Cons (a -> T a) -> a -> T a
forall a b. (a -> b) -> a -> b
$ if a
za -> a -> Bool
forall a. Ord a => a -> a -> Bool
>=a
forall a. C a => a
one then a
za -> a -> a
forall a. C a => a -> a -> a
-a
forall a. C a => a
one else a
z
{-# INLINE sub #-}
sub :: (Ring.C a, Ord a) => T a -> T a -> T a
sub :: forall a. (C a, Ord a) => T a -> T a -> T a
sub (Cons a
x) (Cons a
y) =
let z :: a
z = a
xa -> a -> a
forall a. C a => a -> a -> a
-a
y
in a -> T a
forall a. a -> T a
Cons (a -> T a) -> a -> T a
forall a b. (a -> b) -> a -> b
$ if a
za -> a -> Bool
forall a. Ord a => a -> a -> Bool
<a
forall a. C a => a
zero then a
za -> a -> a
forall a. C a => a -> a -> a
+a
forall a. C a => a
one else a
z
{-# INLINE neg #-}
neg :: (Ring.C a, Ord a) => T a -> T a
neg :: forall a. (C a, Ord a) => T a -> T a
neg (Cons a
x) =
a -> T a
forall a. a -> T a
Cons (a -> T a) -> a -> T a
forall a b. (a -> b) -> a -> b
$ if a
xa -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
forall a. C a => a
zero then a
forall a. C a => a
zero else a
forall a. C a => a
onea -> a -> a
forall a. C a => a -> a -> a
-a
x
{-# INLINE multiply #-}
multiply :: (RealRing.C a, ToInteger.C b) => b -> T a -> T a
multiply :: forall a b. (C a, C b) => b -> T a -> T a
multiply b
n = (a -> a) -> T a -> T a
forall b a. C b => (a -> b) -> T a -> T b
lift (b -> a
forall a b. (C a, C b) => a -> b
NP.fromIntegral b
n a -> a -> a
forall a. C a => a -> a -> a
Ring.*)
instance RealRing.C a => Additive.C (T a) where
{-# INLINE zero #-}
{-# INLINE (+) #-}
{-# INLINE (-) #-}
{-# INLINE negate #-}
zero :: T a
zero = a -> T a
forall a. a -> T a
Cons a
forall a. C a => a
Additive.zero
+ :: T a -> T a -> T a
(+) = T a -> T a -> T a
forall a. (C a, Ord a) => T a -> T a -> T a
add
(-) = T a -> T a -> T a
forall a. (C a, Ord a) => T a -> T a -> T a
sub
negate :: T a -> T a
negate = T a -> T a
forall a. (C a, Ord a) => T a -> T a
neg
{-# INLINE lift #-}
lift :: (RealRing.C b) =>
(a -> b) -> T a -> T b
lift :: forall b a. C b => (a -> b) -> T a -> T b
lift a -> b
f =
b -> T b
forall a. C a => a -> T a
fromRepresentative (b -> T b) -> (T a -> b) -> T a -> T b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f (a -> b) -> (T a -> a) -> T a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T a -> a
forall a. T a -> a
toRepresentative
{-# INLINE customFromRepresentative #-}
customFromRepresentative ::
(Additive.C a) =>
(a -> i) -> (i -> a) -> a -> T a
customFromRepresentative :: forall a i. C a => (a -> i) -> (i -> a) -> a -> T a
customFromRepresentative a -> i
toInt i -> a
fromInt a
x =
a -> T a
forall a. a -> T a
Cons (a
x a -> a -> a
forall a. C a => a -> a -> a
Additive.- i -> a
fromInt (a -> i
toInt a
x))
{-# INLINE customLift #-}
customLift ::
(Additive.C b) =>
(b -> i) -> (i -> b) ->
(a -> b) -> T a -> T b
customLift :: forall b i a. C b => (b -> i) -> (i -> b) -> (a -> b) -> T a -> T b
customLift b -> i
toInt i -> b
fromInt a -> b
f =
(b -> i) -> (i -> b) -> b -> T b
forall a i. C a => (a -> i) -> (i -> a) -> a -> T a
customFromRepresentative b -> i
toInt i -> b
fromInt (b -> T b) -> (T a -> b) -> T a -> T b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f (a -> b) -> (T a -> a) -> T a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T a -> a
forall a. T a -> a
toRepresentative
{-# INLINE customMultiply #-}
customMultiply ::
(Ring.C a, Ord a, ToInteger.C b) =>
(a -> i) -> (i -> a) ->
b -> T a -> T a
customMultiply :: forall a b i.
(C a, Ord a, C b) =>
(a -> i) -> (i -> a) -> b -> T a -> T a
customMultiply a -> i
toInt i -> a
fromInt b
n (Cons a
x) =
(a -> i) -> (i -> a) -> a -> T a
forall a i. C a => (a -> i) -> (i -> a) -> a -> T a
customFromRepresentative a -> i
toInt i -> a
fromInt (a -> T a) -> a -> T a
forall a b. (a -> b) -> a -> b
$
if b
nb -> b -> Bool
forall a. Ord a => a -> a -> Bool
<b
forall a. C a => a
zero Bool -> Bool -> Bool
&& a
xa -> a -> Bool
forall a. Ord a => a -> a -> Bool
>a
forall a. C a => a
zero
then (a
forall a. C a => a
onea -> a -> a
forall a. C a => a -> a -> a
-a
x) a -> a -> a
forall a. C a => a -> a -> a
* b -> a
forall a b. (C a, C b) => a -> b
NP.fromIntegral (b -> b
forall a. C a => a -> a
NP.negate b
n)
else a
x a -> a -> a
forall a. C a => a -> a -> a
* b -> a
forall a b. (C a, C b) => a -> b
NP.fromIntegral b
n
{-# RULES
"Phase.multiply @ Float" multiply = customMultiply GHC.float2Int GHC.int2Float;
"Phase.multiply @ Double" multiply = customMultiply GHC.double2Int GHC.int2Double;
"Phase.increment @ Float" increment = \d -> customLift GHC.float2Int GHC.int2Float (+d);
"Phase.increment @ Double" increment = \d -> customLift GHC.double2Int GHC.int2Double (+d);
"Phase.decrement @ Float" decrement = \d -> customLift GHC.float2Int GHC.int2Float (subtract d);
"Phase.decrement @ Double" decrement = \d -> customLift GHC.double2Int GHC.int2Double (subtract d);
#-}