]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Translator/Jack.hs
Deleted 'Unknown' directory.
[tmp/julm/arpeggigon.git] / src / RMCA / Translator / Jack.hs
1 {-# LANGUAGE FlexibleContexts #-}
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.Applicative ((<**>))
9 import qualified Control.Monad.Exception.Synchronous as Sync
10 import qualified Control.Monad.Trans.Class as Trans
11 import qualified Data.Bifunctor as BF
12 import Data.CBMVar
13 import Data.ReactiveValue
14 import qualified Foreign.C.Error as E
15 import Hails.Yampa
16 import RMCA.Auxiliary.RV
17 import RMCA.Semantics
18 import RMCA.Translator.Filter
19 import RMCA.Translator.Message
20 import RMCA.Translator.RV
21 import RMCA.Translator.Translator
22 import qualified Sound.JACK as Jack
23 import qualified Sound.JACK.MIDI as JMIDI
24
25 rmcaName :: String
26 rmcaName = "RMCA"
27
28 inPortName :: String
29 inPortName = "input"
30
31 outPortName :: String
32 outPortName = "output"
33
34 -- Starts a default client with an input and an output port. Doesn't
35 -- do anything as such.
36 jackSetup :: ( ReactiveValueRead tempo LTempo IO
37 , ReactiveValueRead channel Int IO
38 , ReactiveValueReadWrite board [Note] IO) =>
39 tempo
40 -> channel
41 -> board
42 -> IO ()
43 jackSetup tempoRV chanRV boardInRV = Jack.handleExceptions $ do
44 toProcessRV <- Trans.lift $ toProcess <$> newCBMVar []
45 Jack.withClientDefault rmcaName $ \client ->
46 Jack.withPort client outPortName $ \output ->
47 Jack.withPort client inPortName $ \input ->
48 Jack.withProcess client (jackCallBack client input output
49 toProcessRV tempoRV chanRV boardInRV) $
50 Jack.withActivation client $ Trans.lift $ do
51 putStrLn $ "Started " ++ rmcaName ++ " JACK client."
52 Jack.waitForBreak
53
54 {-
55 -- Loop that does nothing except setting up a callback function
56 -- (called when Jack is ready to take new inputs).
57 jackRun :: (JExc.ThrowsErrno e) =>
58 Jack.Client
59 -> (Jack.NFrames -> Sync.ExceptionalT E.Errno IO ())
60 -> Sync.ExceptionalT e IO ()
61 jackRun client callback =
62 Jack.withProcess client callback $ do
63 Trans.lift $ putStrLn $ "Startedbbb " ++ rmcaName
64 Trans.lift $ Jack.waitForBreak
65 -}
66 defaultTempo :: Tempo
67 defaultTempo = 96
68
69 -- The callback function. It pumps value out of the input port, mix
70 -- them with value coming from the machine itself and stuff them into
71 -- the output port. When this function is not running, events are
72 -- processed.
73 jackCallBack :: ( ReactiveValueReadWrite toProcess [(Frames, RawMessage)] IO
74 , ReactiveValueRead tempo LTempo IO
75 , ReactiveValueRead channel Int IO
76 , ReactiveValueReadWrite board [Note] IO) =>
77 Jack.Client
78 -> JMIDI.Port Jack.Input
79 -> JMIDI.Port Jack.Output
80 -> toProcess
81 -> tempo
82 -> channel
83 -> board
84 -> Jack.NFrames
85 -> Sync.ExceptionalT E.Errno IO ()
86 jackCallBack client input output toProcessRV tempoRV chanRV outBoard
87 nframes@(Jack.NFrames nframesInt') = do
88 let inMIDIRV = inMIDIEvent input nframes
89 outMIDIRV = outMIDIEvent output nframes
90 nframesInt = fromIntegral nframesInt' :: Int
91 -- This gets the sample rate of the client and the last frame number
92 -- it processed. We then use it to calculate the current absolute time
93 sr <- Trans.lift $ Jack.getSampleRate client
94 --(Jack.NFrames lframeInt) <- Trans.lift $ Jack.lastFrameTime client
95 --Trans.lift (reactiveValueRead inMIDIRV >>= (print . map (fst)))
96 -- We write the content of the input buffer to the input of a
97 -- translation signal function.
98 -- /!\ Should maybe be moved elsewhere
99 (inRaw, outPure) <- Trans.lift $ yampaReactiveDual [] readMessages
100 Trans.lift (inMIDIRV =:> inRaw)
101 tempo <- Trans.lift $ reactiveValueRead tempoRV
102 chan <- Trans.lift $ reactiveValueRead chanRV
103 boardIn' <- Trans.lift $ reactiveValueRead outBoard
104 Trans.lift $ emptyRW outBoard
105 let boardIn = (zip (repeat 0) boardIn',[],[])
106 outMIDI <- Trans.lift $ reactiveValueRead outPure
107 -- We translate all signals to be sent into low level signals and
108 -- write them to the output buffer.
109 (inPure, outRaw) <- Trans.lift $ yampaReactiveDual
110 (defaultTempo, sr, chan, ([],[],[])) gatherMessages
111 -- This should all go in its own IO action
112 Trans.lift $ do
113 reactiveValueWrite inPure (tempo, sr, chan, boardIn `mappend` outMIDI)
114 reactiveValueRead outRaw <**>
115 (mappend <$> reactiveValueRead toProcessRV) >>=
116 reactiveValueWrite toProcessRV
117 --map fst <$> reactiveValueRead toProcessRV >>= print . ("toProcess " ++) . show
118 (go, old') <- schedule nframesInt <$> reactiveValueRead toProcessRV
119 let old = map (BF.first (+ (- nframesInt))) old'
120 reactiveValueWrite outMIDIRV go
121 reactiveValueWrite toProcessRV old
122 --------------