module Language.XDsp.Implementations.HaskellNative
where
import Language.XDsp.Semantics
import Control.Applicative
import Control.Monad.Reader
import Data.Data
import Data.Array.Unboxed
type RType = (Integer, Integer)
defaultRType :: RType
defaultRType = (44100,16)
newtype HN a = HN { unHn :: Reader RType a }
deriving (Functor, Applicative, Monad, Typeable)
evalHn :: HN a -> RType -> a
evalHn = runReader . unHn
instance MonadReader HN where
type EnvType HN = RType
ask = HN ask
local f = HN . local f . unHn
instance Dsp HN where
data (ASig HN) = HN_A (ZipList Double)
data (KSig HN) = HN_K (ZipList Double)
data (INum HN) = HN_I Double
getSr = fst <$> ask
getKsmps = snd <$> ask
instance Constants HN where
csig = return . HN_A . pure
ckig = return . HN_K . pure
cnst = return . HN_I
instance Show (ASig HN) where
show _ = "audio signal"
instance Eq (ASig HN) where
(HN_A z1) /= (HN_A z2) = getZipList z1 /= getZipList z2
instance Num (ASig HN) where
(HN_A z1) + (HN_A z2) = HN_A $ (+) <$> z1 <*> z2
(HN_A z1) * (HN_A z2) = HN_A $ (*) <$> z1 <*> z2
abs (HN_A z) = HN_A $ abs <$> z
signum (HN_A z) = HN_A $ signum <$> z
fromInteger = HN_A . pure . fromInteger
instance Fractional (ASig HN) where
(HN_A z1) / (HN_A z2) = HN_A $ (/) <$> z1 <*> z2
fromRational = HN_A . pure . fromRational
instance Show (KSig HN) where
show _ = "control signal"
instance Eq (KSig HN) where
(HN_K z1) /= (HN_K z2) = getZipList z1 /= getZipList z2
instance Num (KSig HN) where
(HN_K z1) + (HN_K z2) = HN_K $ (+) <$> z1 <*> z2
(HN_K z1) * (HN_K z2) = HN_K $ (*) <$> z1 <*> z2
abs (HN_K z) = HN_K $ abs <$> z
signum (HN_K z) = HN_K $ signum <$> z
fromInteger = HN_K . pure . fromInteger
instance Fractional (KSig HN) where
(HN_K z1) / (HN_K z2) = HN_K $ (/) <$> z1 <*> z2
fromRational = HN_K . pure . fromRational
instance Show (INum HN) where
show _ = "control signal"
instance Eq (INum HN) where
(HN_I z1) /= (HN_I z2) = z1 /= z2
(HN_I z1) == (HN_I z2) = z1 == z2
instance Num (INum HN) where
(HN_I z1) + (HN_I z2) = HN_I $ z1 + z2
(HN_I z1) * (HN_I z2) = HN_I $ z1 * z2
abs (HN_I z) = HN_I $ abs z
signum (HN_I z) = HN_I $ signum z
fromInteger = HN_I . fromInteger
instance Fractional (INum HN) where
(HN_I z1) / (HN_I z2) = HN_I $ z1 / z2
fromRational = HN_I . fromRational
instance Show s => Show (HN s) where
show s = show $ evalHn s defaultRType
instance Eq s => Eq (HN s) where
e1 == e2 = evalHn (liftM2 (==) e1 e2) defaultRType
instance Num e => Num (HN e) where
(+) = liftM2 (+)
(*) = liftM2 (*)
abs = fmap abs
signum = fmap signum
fromInteger = pure . fromInteger
instance Fractional e => Fractional (HN e) where
(/) = liftM2 (/)
recip = fmap recip
fromRational = pure . fromRational
instance Buffer HN where
type Buf HN = UArray Int Double
emptyBuffer sz = return . listArray (0,sz1) $ replicate sz 0
instance (Integral a) => BufferR HN Double a where
lookupAt buf i = return $ buf ! (fromIntegral i)
lookupInterp :: UArray Int Double -> Double -> Double
lookupInterp arr d1 = v1 + frc * (v2v1)
where
i = Prelude.floor d1
v1 = arr ! i
v2 = arr ! i+1
frc = d1 (fromIntegral i)
instance BufferR HN Double Double where
lookupAt buf ix = return $ lookupInterp buf ix
instance BufferR HN Double (INum HN) where
lookupAt buf (HN_I ix) = lookupAt buf ix
instance BufferR HN (ASig HN) (ASig HN) where
lookupAt buf (HN_A ix) = return . HN_A $ fmap (lookupInterp buf) ix
instance BufferR HN (KSig HN) (KSig HN) where
lookupAt buf (HN_K ix) = return . HN_K $ fmap (lookupInterp buf) ix
phasor' :: Integer -> Double -> Double -> Double
phasor' sr frq last = if next <= 1
then next
else next(fromIntegral $ Prelude.floor next)
where next = last + (frq/(fromIntegral sr))
instance Phasor HN (KSig HN) (INum HN) where
phasor (HN_I frq') = f frq' <$> getSr
where f frq sr = let phsfn = phasor' sr frq
phs n = n : phs (phsfn n)
in HN_K . ZipList $ phs 0
instance Phasor HN (KSig HN) (KSig HN) where
phasor (HN_K frq') = f frq' <$> getSr
where f zk sr =
let phs = ZipList $ 0 : getZipList ((phasor' sr) <$> zk <*> phs)
in HN_K phs
instance Phasor HN (ASig HN) (INum HN) where
phasor (HN_I frq') = f frq' <$> getSr
where f frq sr = let phsfn = phasor' sr frq
phs n = n : phs (phsfn n)
in HN_A . ZipList $ phs 0
instance Phasor HN (ASig HN) (ASig HN) where
phasor (HN_A frq') = f frq' <$> getSr
where f zk sr =
let phs = ZipList $ 0 : getZipList ((phasor' sr) <$> zk <*> phs)
in HN_A phs
instance Phasor HN (ASig HN) (KSig HN) where
phasor (HN_K (ZipList frq')) = f frq' <$> getSr <*> getKsmps
where f k sr ksmps =
let phs = replicate (fromIntegral ksmps) 0
: zipWith (\frq -> map (phasor' sr frq)) k phs
in HN_A . ZipList $ concat phs