{-# LANGUAGE
     NoMonomorphismRestriction
    ,TypeFamilies
    ,DeriveFunctor
    ,DeriveDataTypeable
    ,GeneralizedNewtypeDeriving
    ,MultiParamTypeClasses
    ,FlexibleInstances
    ,OverlappingInstances #-}

module Language.XDsp.Implementations.HaskellNative

where

import           Language.XDsp.Semantics

import           Control.Applicative
import           Control.Monad.Reader
import           Data.Data
import           Data.Array.Unboxed

-- Basic audio evaluator

type RType = (Integer, Integer) -- SR, ksmps

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

-- ---------------------------------
-- ---------------------------------
-- basic language extensions

-- ---------------------------------
-- ---------------------------------
-- Buffers (function tables)

instance Buffer HN where
  type Buf HN = UArray Int Double
  emptyBuffer sz = return . listArray (0,sz-1) $ 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 * (v2-v1)
 where
  i  = Prelude.floor d1
  v1 = arr ! i
  v2 = arr ! i+1
  frc = d1 - (fromIntegral i)

-- | table lookup with linear interpolation
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 and oscillators

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