]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - RMCA/Unknown/Reactogon.hs
Pieces can now safely be moved without causing crashes or inconsistencies.
[tmp/julm/arpeggigon.git] / RMCA / Unknown / Reactogon.hs
1 module Main where
2
3 import Auxiliary
4 import MIDI
5 import ClientState
6 import Reactimation
7
8 import qualified Sound.JACK as Jack
9 import qualified Sound.JACK.MIDI as JMIDI
10 import qualified Sound.MIDI.Message as MIDI
11 import qualified Sound.MIDI.Message.Channel as Channel
12 import qualified Sound.MIDI.Message.Channel.Voice as Voice
13 import qualified Sound.MIDI.Message.Class.Construct as MidiCons
14
15 import Control.Concurrent
16 import Control.Monad
17 import qualified Control.Monad.Exception.Synchronous as Sync
18 import qualified Control.Monad.Trans.Class as Trans
19 import qualified Data.EventList.Absolute.TimeBody as EventListAbs
20 import qualified Data.EventList.Relative.TimeBody as EventList
21 import qualified Data.EventList.Relative.TimeMixed as EventListTM
22 import qualified Foreign.C.Error as E
23
24 import qualified Data.Map as M
25 import FRP.Yampa
26
27 import Debug.Trace
28 {-
29 -- | List of absolute times (at which events should occur) and events.
30 -- We assume that the list is sorted.
31 outLoop :: [(Time,MIDI.T)]
32 outLoop = concat [[(t,MIDI.Channel $ Channel.Cons
33 { Channel.messageChannel = Channel.toChannel 4
34 , Channel.messageBody =
35 Channel.Voice $ Voice.NoteOn (Voice.toPitch 60) (Voice.toVelocity 100)
36 }),(t+0.5,MIDI.Channel $ Channel.Cons
37 { Channel.messageChannel = Channel.toChannel 4
38 , Channel.messageBody =
39 Channel.Voice $ Voice.NoteOff (Voice.toPitch 60) (Voice.toVelocity 100)
40 })] | t <- [0,2..]]
41 -}
42
43 rmcaName :: String
44 rmcaName = "RMCA"
45
46 inPortName :: String
47 inPortName = "input"
48
49 outPortName :: String
50 outPortName = "output"
51
52 fsPortName :: String
53 fsPortName = "fluidsynth:midi"
54
55 main = do
56 inState <- newMVar M.empty
57 outState <- newMVar M.empty
58 Jack.handleExceptions $
59 Jack.withClientDefault rmcaName $ \client ->
60 Jack.withPort client outPortName $ \output ->
61 Jack.withPort client inPortName $ \input -> do
62 clientState <- Trans.lift $ newEmptyMVar
63 Jack.withProcess client
64 (jackLoop client clientState inState outState input output) $
65 Jack.withActivation client $ do
66 frpid <- Trans.lift $ forkIO $ mainReact inState outState clientState
67 Jack.connect client (rmcaName ++ ":" ++ outPortName) fsPortName
68 Trans.lift $ putStrLn $ "Started " ++ rmcaName
69 Trans.lift $ Jack.waitForBreak
70
71 jackLoop :: Jack.Client
72 -> MVar ClientState -- ^ MVar containing the client state (rate and buff size)
73 -> MVar EventQueue -- ^ MVar containing incoming events
74 -> MVar EventQueue -- ^ MVar containing exiting events
75 -> JMIDI.Port Jack.Input -- ^ Jack input port
76 -> JMIDI.Port Jack.Output -- ^ Jack output port
77 -> Jack.NFrames -- ^ Buffer size for the ports
78 -> Sync.ExceptionalT E.Errno IO ()
79 jackLoop client clientState inRef outRef
80 input output nframes@(Jack.NFrames nframesInt) = do
81 Trans.lift $ print "Entering Jack."
82 rate <- Trans.lift $ Jack.getSampleRate client
83 lframe <- Trans.lift $ Jack.lastFrameTime client
84 isEmptyState <- Trans.lift $ isEmptyMVar clientState
85 let updateClient = if isEmptyState
86 then putMVar
87 else \c v -> void $ swapMVar c v
88 rateD = fromIntegral rate
89 (Jack.NFrames lframeInt) = lframe
90 currentTime = fromIntegral lframeInt / rateD
91 Trans.lift $ updateClient clientState $ ClientState { rate = rate
92 , buffSize = nframes
93 , clientClock = currentTime
94 }
95 outEvents <- Trans.lift $ takeMVar outRef
96 inEventsT <- JMIDI.readEventsFromPort input nframes
97 let inEvents :: EventQueue
98 inEvents = M.mapMaybe fromRawMessage $
99 M.fromList $
100 map (\(Jack.NFrames n,e) -> (currentTime + fromIntegral n/rateD, e)) $
101 EventListAbs.toPairList inEventsT
102 Trans.lift $ print "In the middle."
103 Trans.lift $ putMVar inRef inEvents
104 Trans.lift $ print "In the middle."
105 let playableEvents = M.filterWithKey
106 (\t _ -> t - currentTime > - fromIntegral nframesInt / rateD) $
107 M.union inEvents outEvents
108 (processableEvents, futureEvents) = breakMap currentTime playableEvents
109 processableEvents' = M.toList processableEvents
110 Trans.lift $ print currentTime
111 Trans.lift $ putMVar outRef futureEvents
112 let smartSub x y = if x < y then y - x else x - y
113 (firstTime,_) = head processableEvents'
114 Trans.lift $ print $
115 map ((* rateD) . smartSub firstTime . fst) processableEvents'
116 JMIDI.writeEventsToPort output nframes $
117 EventListAbs.fromPairList $
118 map (\(t,e) -> (Jack.NFrames $ floor $ rateD * smartSub t currentTime
119 , toRawMessage e)) $
120 M.toList processableEvents
121 Trans.lift $ print "Exiting Jack."
122 {-
123 else JMIDI.writeEventsToPort output nframes $
124 EventListAbs.mapTime Jack.NFrames $
125 EventList.toAbsoluteEventList 0 $
126 EventList.mapTime (\(Jack.NFrames n) -> n) $
127 EventList.fromPairList processableEvents
128 -}