MIDI influences the GUI back.

diff --git a/src/RMCA/Auxiliary/Yampa.hs b/src/RMCA/Auxiliary/Yampa.hs
index 008e80546609534b459afe83a0c63460bfb6a3d2..bc172dc765395e6c56ce96674ece06431a888c78 100644 (file)
--- a/src/RMCA/Auxiliary/Yampa.hs
+++ b/src/RMCA/Auxiliary/Yampa.hs
@@ -66,5 +66,8 @@ repeatedlyS :: a -> SF DTime (Event a)
 repeatedlyS x = edgeBy (\a b -> maybeIf (a * b < 0) $> x) 0
                 <<< varFreqSine <<^ (2*)
 
+repeatedlyS' :: a -> SF DTime (Event a)
+repeatedlyS' x = (repeatedlyS x &&& now x) >>> arr (uncurry lMerge)
+
 -- |
 -- = Curry and uncurry functions

diff --git a/src/RMCA/GUI/MultiBoard.hs b/src/RMCA/GUI/MultiBoard.hs
index 55e347b936318e32087c179fbde220bd188a6a70..450556861d79fd2c55889ed52ee8a56a64adfd51 100644 (file)
--- a/src/RMCA/GUI/MultiBoard.hs
+++ b/src/RMCA/GUI/MultiBoard.hs
@@ -6,6 +6,7 @@ import           Control.Concurrent.MVar
 import           Control.Monad
 import           Control.Monad.IO.Class
 import           Data.Array
+import           Data.CBRef
 import qualified Data.IntMap                                as M
 import           Data.List
 import           Data.Maybe
@@ -40,7 +41,7 @@ createNotebook :: ( ReactiveValueRead addLayer () IO
                -> MCBMVar GUICell
                -> IO ( Notebook
                      , ReactiveFieldRead IO (M.IntMap Board)
-                     , ReactiveFieldRead IO (M.IntMap LayerConf)
+                     , CBRef (M.IntMap LayerConf)
                      , ReactiveFieldRead IO
                        (M.IntMap (ReactiveFieldWrite IO [PlayHead]))
                      )
@@ -123,13 +124,17 @@ createNotebook boardQueue tc addLayerRV rmLayerRV
   reactiveValueRead pageChanRV >>=
     reactiveValueWrite pageChanRV . (\pc -> pc ++ [foundHole pc])
 
-  layerMapRV <- newCBMVarRW $ M.insert fstP defaultLayerConf M.empty
+  layerMapRV <- newCBRef $ M.insert fstP defaultLayerConf M.empty
+  reactiveValueOnCanRead layerMapRV $ do
+    synth <- fmap (\(_,_,s) -> s) <$> reactiveValueRead layerMapRV
+    sequence_ $ M.mapWithKey
+      (\chan mess -> reactiveValueAppend boardQueue $
+        M.singleton chan $ ([],) $ synthMessage chan mess) synth
 
   let updateDynLayer cp = do
         nDyn <- reactiveValueRead dynMCBMVar
-        reactiveValueRead layerMapRV >>=
-          reactiveValueWrite layerMapRV .
-          M.adjust (\(stat,_,synth) -> (stat,nDyn,synth)) cp
+        reactiveValueUpdate_ layerMapRV
+          (M.adjust (\(stat,_,synth) -> (stat,nDyn,synth)) cp)
       updateSynth cp = do
         synthState <- reactiveValueRead synthMCBMVar
         reactiveValueAppend boardQueue $
@@ -247,4 +252,4 @@ createNotebook boardQueue tc addLayerRV rmLayerRV
                 chanMap <- reactiveValueRead chanMapRV
                 mapM (reactiveValueRead . \(b,_,_) -> b) chanMap
 
-  return (n, boardMapRV, readOnly layerMapRV, phMapRV)
+  return (n, boardMapRV, layerMapRV, phMapRV)

diff --git a/src/RMCA/Global/Clock.hs b/src/RMCA/Global/Clock.hs
index 3e40252cdeed56751f64561ac406537a419fa80b..e59d8b585eb44f85df8f6278103d305594c69d2c 100644 (file)
--- a/src/RMCA/Global/Clock.hs
+++ b/src/RMCA/Global/Clock.hs
@@ -21,8 +21,8 @@ maxAbsBeat = 16
 -- with a beat number modulo sixteen. Each layer is then beating at
 -- its own fraction, discarding the unecessary beats.
 metronome :: SF Tempo (Event AbsBeat)
-metronome = accumBy (\pb _ -> nextBeatNo maxAbsBeat pb) 1 <<<
-            repeatedlyS () <<^ (15*) <<^ (1/) <<^ fromIntegral
+metronome = accumBy (\pb _ -> nextBeatNo maxAbsBeat pb) 0 <<<
+            repeatedlyS' () <<^ (15*) <<^ (1/) <<^ fromIntegral
 
 -- Tempo is the number of quarter notes per minute.
 tempoToQNoteIvl :: Tempo -> DTime

diff --git a/src/RMCA/Layer/Board.hs b/src/RMCA/Layer/Board.hs
index a685f4af2fde192c073047da870dbae9ff6fb48b..fa6b6c304ea61b14d419ba85d954283476d949b1 100644 (file)
--- a/src/RMCA/Layer/Board.hs
+++ b/src/RMCA/Layer/Board.hs
@@ -10,6 +10,8 @@ import           RMCA.Global.Clock
 import           RMCA.Layer.LayerConf
 import           RMCA.Semantics
 
+import           Debug.Trace
+
 data RunStatus = Running | Stopped
 
 automaton :: [PlayHead]
@@ -44,7 +46,7 @@ layer = layerStopped
           returnA            -< ((en,phs),e)
 
         lrAux slc iphs = proc (eab, b, (slc',dlc,_), ers) -> do
-          ebno  <- layerMetronome slc -< (eab, dlc)
+          ebno  <- layerMetronome slc -< (traceShow eab eab, dlc)
           enphs@(_,phs) <- automaton iphs -< (b, dlc, ebno)
           r <- (case repeatCount slc of
                   Nothing -> never

diff --git a/src/RMCA/Main.hs b/src/RMCA/Main.hs
index 89bff099f6d6e62ec0ccc9da76be7a2ac654a18c..ad523419211521bc56fb32d0c1178b269fe69056 100644 (file)
--- a/src/RMCA/Main.hs
+++ b/src/RMCA/Main.hs
@@ -105,7 +105,7 @@ main = do
 
   putStrLn "Board started."
 
-  forkIO $ jackSetup tc boardQueue tempoRV
+  forkIO $ jackSetup tc boardQueue tempoRV layerMapRV
 
   widgetShowAll window
   ------------------------------------------------------------

diff --git a/src/RMCA/ReactiveValueAtomicUpdate.hs b/src/RMCA/ReactiveValueAtomicUpdate.hs
index b97c40db5b52df167bb6a1f2cd9517065853af32..818d68728c6a7d4b9fed07539425335e653856b2 100644 (file)
--- a/src/RMCA/ReactiveValueAtomicUpdate.hs
+++ b/src/RMCA/ReactiveValueAtomicUpdate.hs
@@ -16,9 +16,13 @@ reactiveValueNonAtomicUpdate rv f = do
 class (ReactiveValueReadWrite a b m) => ReactiveValueAtomicUpdate a b m where
   reactiveValueUpdate :: a -> (b -> b) -> m b
 
+reactiveValueUpdate_ :: (ReactiveValueAtomicUpdate a b m) =>
+                        a -> (b -> b) -> m ()
+reactiveValueUpdate_ rv f = void $ reactiveValueUpdate rv f
+
 reactiveValueAppend :: (Monoid b, ReactiveValueAtomicUpdate a b m) =>
                        a -> b -> m ()
-reactiveValueAppend rv val = void $ reactiveValueUpdate rv (`mappend` val)
+reactiveValueAppend rv val = reactiveValueUpdate_ rv (`mappend` val)
 
 reactiveValueEmpty :: (Monoid b, ReactiveValueAtomicUpdate a b m) =>
                       a -> m b

diff --git a/src/RMCA/Translator/Jack.hs b/src/RMCA/Translator/Jack.hs
index 0046cecb75086ae0ac3b6b245b7ae131635d5944..ebbf5c4e529e20c47885d4195256c01104852612 100644 (file)
--- a/src/RMCA/Translator/Jack.hs
+++ b/src/RMCA/Translator/Jack.hs
@@ -11,10 +11,12 @@ import qualified Control.Monad.Trans.Class           as Trans
 import           Data.CBRef
 import           Data.Foldable
 import qualified Data.IntMap                         as M
+import           Data.Maybe
 import           Data.ReactiveValue
 import qualified Foreign.C.Error                     as E
 import           Graphics.UI.Gtk
 import           RMCA.IOClockworks
+import           RMCA.Layer.LayerConf
 import           RMCA.ReactiveValueAtomicUpdate
 import           RMCA.Semantics
 import           RMCA.Translator.Message
@@ -47,18 +49,21 @@ handleErrorJack _ = postGUIAsync $ do
 -- do anything as such.
 jackSetup :: (ReactiveValueAtomicUpdate board
               (M.IntMap ([Note],[Message])) IO
-             , ReactiveValueRead tempo Tempo IO) =>
+             , ReactiveValueRead tempo Tempo IO
+             , ReactiveValueAtomicUpdate layerConfs (M.IntMap LayerConf) IO
+             ) =>
              IOTick
           -> board
           -> tempo
+          -> layerConfs
           -> IO ()
-jackSetup tc boardQueue tempoRV = Sync.resolveT handleErrorJack $ do
+jackSetup tc boardQueue tempoRV layerMapRV = Sync.resolveT handleErrorJack $ do
   toProcessRV <- Trans.lift $ newCBRef []
   Jack.withClientDefault rmcaName $ \client ->
     Jack.withPort client outPortName $ \output ->
     Jack.withPort client inPortName  $ \input ->
     Jack.withProcess client (jackCallBack tc input output
-                              toProcessRV boardQueue tempoRV) $
+                              toProcessRV boardQueue tempoRV layerMapRV) $
     Jack.withActivation client $ Trans.lift $ do
     putStrLn $ "Started " ++ rmcaName ++ " JACK client."
     --newEmptyMVar >>= takeMVar
@@ -72,26 +77,42 @@ jackSetup tc boardQueue tempoRV = Sync.resolveT handleErrorJack $ do
 jackCallBack :: ( ReactiveValueAtomicUpdate toProcess [(Frames, RawMessage)] IO
                 , ReactiveValueAtomicUpdate board
                   (M.IntMap ([Note],[Message])) IO
-                , ReactiveValueRead tempo Tempo IO) =>
+                , ReactiveValueRead tempo Tempo IO
+                , ReactiveValueAtomicUpdate layerConfs (M.IntMap LayerConf) IO
+                ) =>
                 IOTick
              -> JMIDI.Port Jack.Input
              -> JMIDI.Port Jack.Output
              -> toProcess
              -> board
              -> tempo
+             -> layerConfs
              -> Jack.NFrames
              -> Sync.ExceptionalT E.Errno IO ()
-jackCallBack tc input output toProcessRV boardQueue tempoRV
+jackCallBack tc input output toProcessRV boardQueue tempoRV layerMapRV
   nframes@(Jack.NFrames nframesInt') = do
   let inMIDIRV = inMIDIEvent input nframes
       outMIDIRV = outMIDIEvent output nframes
       nframesInt = fromIntegral nframesInt' :: Int
   Trans.lift $ do
     tempo <- reactiveValueRead tempoRV
+    inMIDI <- reactiveValueRead inMIDIRV
+    let (unchangedMessages,toBeTreatedMessages) =
+          break (\(_,m) -> fromMaybe False $ do
+                    mess <- fromRawMessage m
+                    return (isInstrument mess || isVolume mess)) inMIDI
+    reactiveValueAppend toProcessRV unchangedMessages
+    let (volume,instruments) = break (isInstrument . snd) $
+          map (second (fromJust . fromRawMessage)) toBeTreatedMessages
+    mapM_ ((\(Volume c v) -> reactiveValueUpdate layerMapRV
+            (M.adjust (\(st,d,s) -> (st,d,s { volume = v }))
+             (fromChannel c))) . snd) volume
+    mapM_ ((\(Instrument c p) -> reactiveValueUpdate layerMapRV
+            (M.adjust (\(st,d,s) -> (st,d,s { instrument = fromProgram p }))
+              (fromChannel c))) . snd) instruments
     concat . toList . gatherMessages tempo nframesInt <$>
-      reactiveValueRead boardQueue >>= \bq ->
-      reactiveValueAppend toProcessRV bq-- >> putStrLn ("BoardQueue: " ++ show (map fst bq))
-    reactiveValueEmpty  boardQueue
+      reactiveValueEmpty boardQueue >>=
+      reactiveValueAppend toProcessRV
     (go, old') <- schedule nframesInt <$> reactiveValueRead toProcessRV
     let old = map (first (+ (- nframesInt))) old'
     --putStrLn ("Out: " ++ show (map fst go))

diff --git a/src/RMCA/Translator/Message.hs b/src/RMCA/Translator/Message.hs
index 8a6c006508e7eac813809bf0aa4fa8862dc01339..19d5d3d667f7eb76963daffd434e0e832633beed 100644 (file)
--- a/src/RMCA/Translator/Message.hs
+++ b/src/RMCA/Translator/Message.hs
@@ -41,9 +41,15 @@ getChannel (Instrument c _ ) = Channel.fromChannel c
 mkChannel :: Int -> Channel
 mkChannel = Channel.toChannel
 
+fromChannel :: Channel -> Int
+fromChannel = Channel.fromChannel
+
 mkProgram :: Int -> Channel.Program
 mkProgram = Channel.toProgram
 
+fromProgram :: Channel.Program -> Int
+fromProgram = Channel.fromProgram
+
 -- Function to go back and forth with the representations of pitches,
 -- as they are different in our model and in the Jack API model.
 fromRawPitch :: Voice.Pitch -> Pitch
@@ -60,10 +66,13 @@ isNoteOff :: Message -> Bool
 isNoteOff NoteOff {} = True
 isNoteOff _ = False
 
+isVolume :: Message -> Bool
+isVolume Volume {} = True
+isVolume _ = False
 
-isControl :: Message -> Bool
-isControl Volume {} = True
-isControl _ = False
+isInstrument :: Message -> Bool
+isInstrument Instrument {} = True
+isInstrument _ = False
 
 switchOnOff :: Message -> Message
 switchOnOff (NoteOn  c p v) = NoteOff c p v

diff --git a/src/RMCA/Translator/Translator.hs b/src/RMCA/Translator/Translator.hs
index edff9f7489ca71acd0fa0aa1ad7c7666da5e0756..60859325ba0c52d5fbed806258b5289aa44a406a 100644 (file)
--- a/src/RMCA/Translator/Translator.hs
+++ b/src/RMCA/Translator/Translator.hs
@@ -69,7 +69,7 @@ sortNotes = sortNotes' ([],[])
         sortNotes' (n, c) (x@(_,m):xs)
           | isNoteOn m = sortNotes' (x:n, c) xs
           | isNoteOff m = sortNotes' (n,c) xs
-          | isControl m = sortNotes' (n,x:c) xs
+          | isVolume m || isInstrument m = sortNotes' (n,x:c) xs
           | otherwise = sortNotes' (n,c) xs
 
 -- Note messages are converted to PlayHeads