Commit a603f3ae by Guerric Chupin

MIDI influences the GUI back.

parent 080d8882
......@@ -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
......@@ -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)
......@@ -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
......
......@@ -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
......
......@@ -105,7 +105,7 @@ main = do
putStrLn "Board started."
forkIO $ jackSetup tc boardQueue tempoRV
forkIO $ jackSetup tc boardQueue tempoRV layerMapRV
widgetShowAll window
------------------------------------------------------------
......
......@@ -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
......
......@@ -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))
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment