Gtk.hs

module Player.Gtk (Player.Gtk.play) where

import Paths_YampaSynth (getDataFileName)

import Player.OpenAL

import Codec.Midi
import Data.Audio

import FRP.Yampa

import Data.Int
import qualified Data.Map as Map
import Data.IORef
import Control.Concurrent
import Foreign.Storable
import Foreign.Marshal.Alloc

import Graphics.UI.Gtk hiding (eventKeyName)
import Graphics.UI.Gtk.Gdk.Events hiding (Event)
import Graphics.UI.Gtk.Glade

import Sound.OpenAL

play :: Int -> Int -> SF (Event [Message]) (Sample, Event ()) -> IO ()
play sampleRate' sampleNumber' synth = do
  (device,context,pSource,pBuffer) <- initOpenAL
  mVarMessage <- newEmptyMVar
  mVarReplyGui <- newEmptyMVar
  mVarKeyboardActive <- newEmptyMVar
  refKeyboardStatus <- newIORef $ (Map.empty :: Map.Map String ())

  _ <- initGUI

  guiDescFile <- getDataFileName "gui/YampaSynth.glade"
  Just xml <- xmlNew guiDescFile

  window   <- xmlGetWidget xml castToWindow "window1"
  _ <- onDestroy window $ do
    deInitOpenAL device context pSource pBuffer
    mainQuit
  let
    onKeyPressWindow e = do
      b <- isEmptyMVar mVarKeyboardActive
      if b
        then return ()
        else do
          let k = eventKeyName e
          m <- readIORef refKeyboardStatus
          if Map.member k m
            then return ()
            else do
              writeIORef refKeyboardStatus (Map.insert k () m)
              putMVar mVarMessage (NoteOn  {channel = 0, key = str2key k, velocity = 85})
      return True
    onKeyReleaseWindow e = do
      b <- isEmptyMVar mVarKeyboardActive
      if b
        then return ()
        else do
          let k = eventKeyName e
          modifyIORef refKeyboardStatus (\m -> Map.delete k m)
          putMVar mVarMessage (NoteOff  {channel = 0, key = str2key k, velocity = 85})
      return True
  _ <- onKeyPress window onKeyPressWindow
  _ <- onKeyRelease window onKeyReleaseWindow

  combobox <- xmlGetWidget xml castToComboBox "combobox1"
  comboBoxSetActive combobox 0

  _ <- on combobox changed $ do
    b <- isEmptyMVar mVarKeyboardActive
    if b
      then return ()
      else do
        i <- comboBoxGetActive combobox
        if i < 0
          then return ()
          else putMVar mVarMessage (ProgramChange { channel = 0,  preset = fromIntegral i })
        return ()

  playButton <- xmlGetWidget xml castToButton "button1"
  stopButton <- xmlGetWidget xml castToButton "button2"
  widgetSetSensitivity stopButton False

  _ <- onClicked playButton $ do
    _ <- forkIO $ runSynth sampleRate' sampleNumber' pSource pBuffer
                           mVarMessage mVarReplyGui synth
    widgetSetSensitivity playButton False
    widgetSetSensitivity stopButton True
    i <- comboBoxGetActive combobox
    if i < 0
      then return ()
      else putMVar mVarMessage (ProgramChange { channel = 0,  preset = fromIntegral i })
    putMVar mVarKeyboardActive ()

  _ <- onClicked stopButton $ do
    putMVar mVarMessage TrackEnd
    takeMVar mVarReplyGui
    widgetSetSensitivity stopButton False
    widgetSetSensitivity playButton True
    takeMVar mVarKeyboardActive

  widgetShowAll window
  mainGUI

runSynth :: Int -> Int -> Source -> Buffer -> MVar Message -> MVar ()
  ->  SF (Event [Message]) (Sample, Event ()) -> IO ()
runSynth sampleRate' sampleNumber' pSource pBuffer mVarMessage mVarReplyGui synth = do

  mVarMaybeChunk <- newEmptyMVar
  mVarReplyPlayer <- newEmptyMVar

  _ <- forkIO $ process sampleRate' pSource pBuffer mVarMaybeChunk mVarReplyPlayer

  ir <- newIORef (0 :: Int)
  let sampleSize = sizeOf (undefined :: Int16)
      chunkSize' = sampleNumber' * sampleSize
  chunkData' <- mallocBytes chunkSize'

  let chunk = Chunk chunkData' chunkSize'
      sense _ = do
        let dt = 1.0 / fromIntegral sampleRate'
        maybeMsg <- tryTakeMVar mVarMessage
        case maybeMsg of
          Nothing -> return (dt, Just noEvent)
          Just msg -> return (dt, Just (Event [msg]))
      actuate _ (s,e) = if (isEvent e)
        then return True
        else do
          i <- readIORef ir
          pokeElemOff (chunkData chunk) i (fromSample s)
          if i == (sampleNumber' - 1)
            then do
              putMVar mVarMaybeChunk (Just chunk)
              takeMVar mVarReplyPlayer
              writeIORef ir 0
              return False
            else do
              writeIORef ir (i + 1)
              return False

  reactimate (return noEvent) sense actuate synth

  i <- readIORef ir
  putMVar mVarMaybeChunk (Just $ chunk {chunkSize = i * sampleSize})
  takeMVar mVarReplyPlayer
  putMVar mVarMaybeChunk Nothing
  takeMVar mVarReplyPlayer

  free (chunkData chunk)
  putMVar mVarReplyGui ()


str2key :: String -> Key
str2key s = case s of
  "p" -> 64
  "0" -> 63
  "o" -> 62
  "9" -> 61
  "i" -> 60
  "u" -> 59
  "7" -> 58
  "y" -> 57
  "6" -> 56
  "t" -> 55
  "5" -> 54
  "r" -> 53
  "e" -> 52
  "3" -> 51
  "w" -> 50
  "2" -> 49
  "q" -> 48

  "m" -> 59 - 12
  "j" -> 58 - 12
  "n" -> 57 - 12
  "h" -> 56 - 12
  "b" -> 55 - 12
  "g" -> 54 - 12
  "v" -> 53 - 12
  "c" -> 52 - 12
  "d" -> 51 - 12
  "x" -> 50 - 12
  "s" -> 49 - 12
  "z" -> 48 - 12

  _   -> 0