src/RMCA/Translator/Jack.hs

   1 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
   2
   3 -- Contains all the information and functions necessary to run a Jack
   4 -- port and exchange information through reactive values and Yampa.
   5 module RMCA.Translator.Jack ( jackSetup
   6                             ) where
   7
   8 import           Control.Arrow
   9 import qualified Control.Monad.Exception.Synchronous as Sync
  10 import qualified Control.Monad.Trans.Class           as Trans
  11 import           Data.CBRef
  12 import           Data.Foldable                       hiding (concat, mapM_)
  13 import qualified Data.IntMap                         as M
  14 import           Data.Maybe
  15 import           Data.ReactiveValue
  16 import qualified Foreign.C.Error                     as E
  17 import           Graphics.UI.Gtk
  18 import           RMCA.IOClockworks
  19 import           RMCA.Layer.LayerConf
  20 import           RMCA.ReactiveValueAtomicUpdate
  21 import           RMCA.Semantics
  22 import           RMCA.Translator.Message
  23 import           RMCA.Translator.RV
  24 import           RMCA.Translator.Translator
  25 import qualified Sound.JACK                          as Jack
  26 import qualified Sound.JACK.Exception                as JackExc
  27 import qualified Sound.JACK.MIDI                     as JMIDI
  28
  29 rmcaName :: String
  30 rmcaName = "arpeggigon"
  31
  32 inPortName :: String
  33 inPortName = "input"
  34
  35 outPortName :: String
  36 outPortName = "output"
  37
  38 handleErrorJack :: JackExc.All -> IO ()
  39 handleErrorJack _ = postGUIAsync $ do
  40   diag <- messageDialogNewWithMarkup
  41           Nothing [] MessageError ButtonsClose
  42           "No running instance of Jack could be found!"
  43   widgetShow diag
  44   resp <- dialogRun diag
  45   mainQuit
  46
  47 -- Starts a default client with an input and an output port. Doesn't
  48 -- do anything as such.
  49 jackSetup :: (ReactiveValueAtomicUpdate board
  50               (M.IntMap ([Note],[Message])) IO
  51              , ReactiveValueRead tempo Tempo IO
  52              , ReactiveValueAtomicUpdate layerConfs (M.IntMap LayerConf) IO
  53              ) =>
  54              IOTick
  55           -> board
  56           -> tempo
  57           -> layerConfs
  58           -> IO ()
  59 jackSetup tc boardQueue tempoRV layerMapRV = Sync.resolveT handleErrorJack $ do
  60   toProcessRV <- Trans.lift $ newCBRef []
  61   Jack.withClientDefault rmcaName $ \client -> do
  62     sr <- Trans.lift $ Jack.getSampleRate client
  63     Jack.withPort client outPortName $ \output ->
  64       Jack.withPort client inPortName  $ \input ->
  65       Jack.withProcess client (jackCallBack tc sr input output
  66                                toProcessRV boardQueue tempoRV layerMapRV) $
  67       Jack.withActivation client $ Trans.lift $ do
  68       putStrLn $ "Started " ++ rmcaName ++ " JACK client."
  69       Jack.waitForBreak
  70       return ()
  71
  72 -- The callback function. It pumps value out of the input port, mix
  73 -- them with value coming from the machine itself and stuff them into
  74 -- the output port. When this function is not running, events are
  75 -- processed.
  76 jackCallBack :: ( ReactiveValueAtomicUpdate toProcess [(Frames, RawMessage)] IO
  77                 , ReactiveValueAtomicUpdate board
  78                   (M.IntMap ([Note],[Message])) IO
  79                 , ReactiveValueRead tempo Tempo IO
  80                 , ReactiveValueAtomicUpdate layerConfs (M.IntMap LayerConf) IO
  81                 ) =>
  82                 IOTick
  83              -> SampleRate
  84              -> JMIDI.Port Jack.Input
  85              -> JMIDI.Port Jack.Output
  86              -> toProcess
  87              -> board
  88              -> tempo
  89              -> layerConfs
  90              -> Jack.NFrames
  91              -> Sync.ExceptionalT E.Errno IO ()
  92 jackCallBack tc sr input output toProcessRV boardQueue tempoRV layerMapRV
  93   nframes@(Jack.NFrames nframesInt') = do
  94   let inMIDIRV = inMIDIEvent input nframes
  95       outMIDIRV = outMIDIEvent output nframes
  96       nframesInt = fromIntegral nframesInt' :: Int
  97   Trans.lift $ do
  98     tempo <- reactiveValueRead tempoRV
  99     inMIDI <- reactiveValueRead inMIDIRV
 100     let (unchangedMessages,toBeTreatedMessages) =
 101           break (\(_,m) -> fromMaybe False $ do
 102                     mess <- fromRawMessage m
 103                     return (isInstrument mess || isVolume mess)) inMIDI
 104     reactiveValueAppend toProcessRV unchangedMessages
 105     let (volume,instruments) = break (isInstrument . snd) $
 106           map (second (fromJust . fromRawMessage)) toBeTreatedMessages
 107     mapM_ ((\(Volume c v) -> reactiveValueUpdate layerMapRV
 108             (M.adjust (\(st,d,s) -> (st,d,s { volume = v }))
 109              (fromChannel c))) . snd) volume
 110     mapM_ ((\(Instrument c p) -> reactiveValueUpdate layerMapRV
 111             (M.adjust (\(st,d,s) -> (st,d,s { instrument = fromProgram p }))
 112               (fromChannel c))) . snd) instruments
 113     toProcess <- reactiveValueRead toProcessRV
 114     {-fmap (concat . toList . gatherMessages sr tempo)
 115          (reactiveValueEmpty boardQueue) >>=
 116       reactiveValueAppend toProcessRV-}
 117     fmap ((`removeRepeat` toProcess) . concat . toList . getMessages sr tempo)
 118          (reactiveValueEmpty boardQueue) >>=
 119       reactiveValueWrite toProcessRV
 120     (go, old') <- fmap (schedule nframesInt) (reactiveValueRead toProcessRV)
 121     {-if not $ null $ map (second fromRawMessage) go then
 122       do print $ toShow $ map (second fromRawMessage) go
 123     else
 124       do putChar ' '-}
 125     let old = map (first (+ (- nframesInt))) old'
 126     reactiveValueWrite outMIDIRV go
 127     reactiveValueWrite toProcessRV old
 128     tickIOTick tc
 129   --------------
 130
 131 toShow :: [(Frames, Maybe Message)] -> String
 132 toShow as = case as of
 133           [] -> []
 134           (v, Just n@(NoteOn _ p _)) : xs -> show p++"-NoteOn "++toShow xs
 135           (v, Just n@(NoteOff _ p _)) : xs -> show p++"-NoteOff "++toShow xs
 136           x : xs -> toShow xs
 137
 138 fromRaws :: [(Frames, RawMessage)] -> [(Frames, Message)]
 139 fromRaws = fst . sortRawMessages
 140
 141 toRaws :: [(Frames, Message)] -> [(Frames, RawMessage)]
 142 toRaws = map (second toRawMessage)
 143
 144 removeRepeat :: [(Frames, Message)] -> [(Frames, RawMessage)] -> [(Frames, RawMessage)]
 145 removeRepeat fms frs = toRaws $ checkAndInsert fms (fromRaws frs)
 146     where checkAndInsert :: [(Frames, Message)] -> [(Frames, Message)] -> [(Frames, Message)]
 147           checkAndInsert fms [] = fms
 148           checkAndInsert fms (fm@(_, m) : fromRaws) | isNoteOff m = searchNoteOn fms fm : checkAndInsert fms fromRaws
 149                                                     | otherwise   = fm : checkAndInsert fms fromRaws
 150
 151 searchNoteOn :: [(Frames, Message)] -> (Frames, Message) -> (Frames, Message)
 152 searchNoteOn [] fm = fm
 153 searchNoteOn ((frames, NoteOn _ p' _) : fms) fm@(_, m@(NoteOff _ p _)) = case p' == p of
 154                                                     True -> (frames, m)
 155                                                     False -> searchNoteOn fms fm
 156 searchNoteOn (fm' : fms) fm = searchNoteOn fms fm