]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Translator/Jack.hs
Refactored parallel boards.
[tmp/julm/arpeggigon.git] / 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.Foldable
12 import qualified Data.IntMap as M
13 import Data.ReactiveValue
14 import qualified Foreign.C.Error as E
15 import RMCA.Auxiliary
16 import RMCA.Semantics
17 import RMCA.Translator.Message
18 import RMCA.Translator.RV
19 import RMCA.Translator.Translator
20 import qualified Sound.JACK as Jack
21 import qualified Sound.JACK.MIDI as JMIDI
22
23 rmcaName :: String
24 rmcaName = "RMCA"
25
26 inPortName :: String
27 inPortName = "input"
28
29 outPortName :: String
30 outPortName = "output"
31
32 -- Starts a default client with an input and an output port. Doesn't
33 -- do anything as such.
34 jackSetup :: (ReactiveValueReadWrite board
35 (M.IntMap ([Note],[Message])) IO
36 , ReactiveValueRead tempo Tempo IO) =>
37 board
38 -> tempo
39 -> IO ()
40 jackSetup boardQueue tempoRV = Jack.handleExceptions $ do
41 toProcessRV <- Trans.lift $ newCBMVarRW []
42 Jack.withClientDefault rmcaName $ \client ->
43 Jack.withPort client outPortName $ \output ->
44 Jack.withPort client inPortName $ \input ->
45 Jack.withProcess client (jackCallBack input output
46 toProcessRV boardQueue tempoRV) $
47 Jack.withActivation client $ Trans.lift $ do
48 putStrLn $ "Started " ++ rmcaName ++ " JACK client."
49 Jack.waitForBreak
50
51 -- The callback function. It pumps value out of the input port, mix
52 -- them with value coming from the machine itself and stuff them into
53 -- the output port. When this function is not running, events are
54 -- processed.
55 jackCallBack :: ( ReactiveValueReadWrite toProcess [(Frames, RawMessage)] IO
56 , ReactiveValueReadWrite board
57 (M.IntMap ([Note],[Message])) IO
58 , ReactiveValueRead tempo Tempo IO) =>
59 JMIDI.Port Jack.Input
60 -> JMIDI.Port Jack.Output
61 -> toProcess
62 -> board
63 -> tempo
64 -> Jack.NFrames
65 -> Sync.ExceptionalT E.Errno IO ()
66 jackCallBack input output toProcessRV boardQueue tempoRV
67 nframes@(Jack.NFrames nframesInt') = do
68 let inMIDIRV = inMIDIEvent input nframes
69 outMIDIRV = outMIDIEvent output nframes
70 nframesInt = fromIntegral nframesInt' :: Int
71 Trans.lift $ do
72 tempo <- reactiveValueRead tempoRV
73 concat . toList . gatherMessages tempo nframesInt <$>
74 reactiveValueRead boardQueue >>= \bq ->
75 reactiveValueAppend toProcessRV bq >> putStrLn ("BoardQueue: " ++ show (map fst bq))
76 reactiveValueEmpty boardQueue
77 (go, old') <- schedule nframesInt <$> reactiveValueRead toProcessRV
78 let old = map (first (+ (- nframesInt))) old'
79 putStrLn ("Out: " ++ show (map fst go))
80 reactiveValueWrite outMIDIRV go
81 reactiveValueWrite toProcessRV old
82 --------------