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 (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 ()) 
  
  unsafeInitGUIForThreadedRTS --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
  
  onChanged combobox $ do
    b <- isEmptyMVar mVarKeyboardActive
    if b
      then return ()
      else do
        mi <- comboBoxGetActive combobox
        case mi of
          Nothing -> return ()
          Just i  -> 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
    mi <- comboBoxGetActive combobox
    case mi of
      Nothing -> return ()
      Just i  -> 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