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