module Main where

import Control.Applicative (pure, (<$>))
import Control.Concurrent (forkIO)
import Control.Concurrent.MVar
import Control.Monad (unless, when, msum)

import Data.Char (ord)
import Data.Int (Int8, Int16)
import Data.IORef
import Data.Maybe (fromMaybe)
import Data.Monoid

import Foreign.Marshal (mallocArray, free)
import Foreign.Ptr
import Foreign.Storable

import FRP.Reactive
import FRP.Reactive.LegacyAdapters
import FRP.Reactive.Internal.Reactive (runE)

import Sound.OpenAL (
  -- Nice AL types
  Gain, Frequency, Format, SourceRelative(..),
  -- Nasty AL types
  ALfloat, BufferData(..), MemoryRegion(..),
  -- Nice GL types
  Vertex3(..), Vector3(..),
  -- GL internal bits
  ($=), get)
import qualified Sound.OpenAL as AL
import Sound.ALUT.Sleep (sleep)

import System.IO

-- | Buffer size in samples. This will normally be about 0.1s, which seems to
--   be a reasonable tradeoff between stable audio and low latency.
bufferSize :: Int
bufferSize = 40960

data PosVel = PosVel {
  posVelRel :: SourceRelative,
  posVelPos :: Vertex3 ALfloat,
  posVelVel :: Vertex3 ALfloat
}

-- | A sound source somewhere in 3D space.
data Source = Source {
  source                  :: Behaviour Double,
  sourcePosVel            :: Behaviour PosVel,
  sourceGain              :: Behaviour Gain,
  sourceDirection         :: Behaviour (Vector3 ALfloat),
  sourceGainBounds        :: Behaviour (Gain, Gain),
  sourceReferenceDistance :: Behaviour ALfloat,
  sourceRolloffFactor     :: Behaviour ALfloat,
  sourceMaxDistance       :: Behaviour ALfloat,
  sourceConeAngles        :: Behaviour (ALfloat, ALfloat),
  sourceConeOuterGain     :: Behaviour Gain
}

maxFloat = f 1 :: Float where
  f x | 2*x == 4*x = x
      | otherwise  = f (2*x)

-- | A default, silent Source, positioned over the listener.
defaultSource = Source {
  source                  = pure 0,
  sourcePosVel            = pure $ PosVel World (Vertex3 0 0 0) (Vertex3 0 0 0),
  sourceGain              = pure 1,
  sourceDirection         = pure (Vector3 0 0 0),
  sourceGainBounds        = pure (0, 1),
  sourceReferenceDistance = pure 1,
  sourceRolloffFactor     = pure 1,
  sourceMaxDistance       = pure maxFloat,
  sourceConeAngles        = pure (360, 360),
  sourceConeOuterGain     = pure 1
}


class (Num a, Storable a) => Sample a where
  -- | Compute the format for the sample. The value of the argument is not used.
  sampleFormat :: a -> Format

instance Sample Int8 where sampleFormat _ = AL.Mono8
instance Sample Int16 where sampleFormat _ = AL.Mono16
--instance Sample (Int8, Int8) where sampleFormat _ = AL.Stereo8
--instance Sample (Int16, Int16) where sampleFormat _ = AL.Stereo16


behaviourType :: Behaviour a -> a
behaviourType = undefined

freqAttr :: AL.ContextAttribute -> Maybe Frequency
freqAttr (AL.Frequency f) = Just f
freqAttr _ = Nothing

playSamples :: Sample a => Behaviour a -> IO ()
playSamples a = do
  Just device <- AL.openDevice Nothing -- FIXME accept device name
  Just context <- AL.createContext device []
  AL.currentContext $= Just context
  contextAttrs <- get (AL.allAttributes device)
  [source] <- AL.genObjectNames 1
  bufNames <- AL.genObjectNames 2
  contents <- mallocArray bufferSize
  bufs <- newIORef (cycle bufNames)

  let frequency :: Frequency
      frequency = realToFrac . fromMaybe 44100 . msum $ map freqAttr contextAttrs
      bufferInterval :: TimeT
      bufferInterval = fromIntegral bufferSize / realToFrac frequency
      sampleType = behaviourType a
      bufferSizeBytes = fromIntegral (bufferSize * sizeOf sampleType)

  let fillBuffer t = do
        buf:rest <- readIORef bufs
        state <- get (AL.sourceState source)
        unless (state == AL.Playing) $ do
          putStrLn "Start playing!"
          AL.play [source]
        let sampler = atTimes (take bufferSize [t-bufferInterval,t-bufferInterval+1/realToFrac frequency..])
            samples = snapshot (countE_ sampler) a
            fillE = ((\(n,v) -> when (n `mod` 1000 == 0) (print n) >> pokeElemOff contents (n - 1) v) <$> samples)
        putStrLn "Buffer"
        --adaptE fillE
        runE mempty fillE
        putStrLn "Filled"
        b <- get (AL.buffer source)
        state <- get (AL.sourceState source)
        when (b == Just buf && state == AL.Playing) $ do
          -- Trying to replace the currently-playing buffer. We've got out of sync with
          -- the audio playback. Try again.
          AL.stop [source]
        AL.unqueueBuffers source [buf]
        AL.bufferData buf $= BufferData (MemoryRegion contents bufferSizeBytes) (sampleFormat sampleType) frequency
        AL.queueBuffers source [buf]
        writeIORef bufs rest

  adaptE (fillBuffer <$> withTimeE_ (atTimes [bufferInterval, 2*bufferInterval..]))

  -- adaptE does not finish; this will never happen...
  free contents
  AL.deleteObjectNames [source]
  AL.deleteObjectNames bufNames
  AL.currentContext $= Nothing
  AL.destroyContext context
  AL.closeDevice device
  return ()

playSource :: Source -> IO ()
playSource s = playSamples (floor <$> 32767 * source s :: Behaviour Int16)

-- Final interface:
-- play :: Event [Source] -> Event ListenerState -> IO ()

mkKeys :: IO (Event Char)
mkKeys = do
  (a, b) <- makeEvent =<< makeClock
  hSetBuffering stdin NoBuffering
  forkIO $ mapM_ b =<< getContents
  return a

main = do
  keys <- mkKeys
  let tone = stepper 0 (fromIntegral . ord <$> keys)
  --forkIO $ adaptE (print <$> snapshot_ (atTimes [0,0.1..]) tone)
  playSource defaultSource { source = sin ( 10 * tone * time) }
  --playSource defaultSource { source = sin (1000 * time) / 2 + sin ( 100 * time) / 2 }