Commit af96cacb authored by Guerric Chupin's avatar Guerric Chupin

Refactored parallel boards.

parent 7f49283e
......@@ -48,6 +48,12 @@ eventToList :: Event [a] -> [a]
eventToList NoEvent = []
eventToList (Event x) = x
eventIf :: Bool -> Event ()
eventIf b = if b then Event () else NoEvent
maybeIf :: Bool -> Maybe ()
maybeIf b = if b then Just () else Nothing
--------------------------------------------------------------------------------
-- FRP
--------------------------------------------------------------------------------
......@@ -97,9 +103,6 @@ onChange' = proc x -> do
if x'' == x then NoEvent else Event x
returnA -< makeEvent x x'
updateRV :: (ReactiveValueReadWrite a b m) => a -> m ()
updateRV rv = reactiveValueRead rv >>= reactiveValueWrite rv
--------------------------------------------------------------------------------
-- Reactive Values
--------------------------------------------------------------------------------
......@@ -145,6 +148,9 @@ syncRightOnLeftWithBoth f l r = reactiveValueOnCanRead l $ do
or <- reactiveValueRead r
reactiveValueWrite r (f nl or)
updateRV :: (ReactiveValueReadWrite a b m) => a -> m ()
updateRV rv = reactiveValueRead rv >>= reactiveValueWrite rv
liftW3 :: ( Monad m
, ReactiveValueWrite a b m
, ReactiveValueWrite c d m
......
......@@ -17,8 +17,6 @@ import RMCA.Semantics
import RMCA.Translator.Instruments
import RMCA.Translator.Message
import Debug.Trace
floatConv :: (ReactiveValueReadWrite a b m,
Real c, Real b, Fractional c, Fractional b) =>
a -> ReactiveFieldReadWrite m c
......@@ -34,7 +32,8 @@ mkVScale s adj = do
boxPackStart hBox boxScale PackNatural 0
return (hBox,boxScale)
layerSettings :: (ReactiveValueReadWrite board (M.IntMap ([(LTempo,Note)],[Message])) IO) =>
layerSettings :: (ReactiveValueReadWrite board
(M.IntMap ([Note],[Message])) IO) =>
board
-> IO ( VBox
, MCBMVar Layer
......@@ -44,31 +43,67 @@ layerSettings boardQueue = do
------------------------------------------------------------------------------
-- GUI Boxes
------------------------------------------------------------------------------
layerSettingsVBox <- vBoxNew False 10
layerSettingsVBox <- vBoxNew True 10
layerSettingsBox <- hBoxNew True 10
boxPackStart layerSettingsVBox layerSettingsBox PackNatural 0
layBeatBox <- hBoxNew False 10
layBeatCombo <- comboBoxNewText
layBeatIndex <- mapM (\(str,dur) -> do i <- comboBoxAppendText layBeatCombo
(fromString str)
return (dur,i)) noteList'
comboBoxSetActive layBeatCombo 0
let indexToDur i =
fromMaybe (error "In indexToDur: failed \
\to find the correct \
\ duration for the \
\selected index.") $ lookup i $ map swap layBeatIndex
durToIndex d =
fromMaybe (error "In durToIndex: \
\failed to find \
\the correct index \
\for the duration.") $ lookup d layBeatIndex
layBeatRV = bijection (indexToDur, durToIndex) `liftRW`
comboBoxIndexRV layBeatCombo
layBeatLabel <- labelNew (Just "Layer beat"){-=<<
(`lookup` symbolString) <$> reactiveValueRead layBeatRV-}
--labelSetAngle layBeatLabel 90
labelSetLineWrap layBeatLabel True
let layBeatLabelRV = labelTextReactive layBeatLabel
boxPackStart layerSettingsBox layBeatBox PackNatural 0
auxLayBeatBox <- vBoxNew False 0
boxPackEnd layBeatBox auxLayBeatBox PackRepel 0
boxPackStart auxLayBeatBox layBeatLabel PackRepel 0
boxPackStart auxLayBeatBox layBeatCombo PackNatural 0
layVolumeAdj <- adjustmentNew 100 0 100 1 1 1
(layVolumeBox,layVolumeScale) <- mkVScale "Volume" layVolumeAdj
boxPackStart layerSettingsBox layVolumeBox PackNatural 0
(Requisition layVolW layVolH) <- widgetSizeRequest layVolumeScale
widgetSetSizeRequest layerSettingsBox layVolW (max layVolH 100)
scaleSetDigits layVolumeScale 0
{-
layTempoAdj <- adjustmentNew 1 0 2 0.1 0.1 1
(layTempoBox, layTempoScale) <- mkVScale "Layer tempo" layTempoAdj
boxPackStart layerSettingsBox layTempoBox PackNatural 0
-}
strAdj <- adjustmentNew 0.8 0 2 0.1 0.1 0
(strBox, layStrengthScale) <- mkVScale "Strength" strAdj
boxPackStart layerSettingsBox strBox PackNatural 0
bpbBox <- vBoxNew False 10
bpbBox <- vBoxNew False 0
boxPackStart layerSettingsBox bpbBox PackNatural 0
bpbLabel <- labelNew (Just "Beat per bar")
labelSetLineWrap bpbLabel True
boxPackStart bpbBox bpbLabel PackNatural 0
bpbAdj <- adjustmentNew 4 1 16 1 1 0
bpbButton <- spinButtonNew bpbAdj 1 0
boxPackStart bpbBox bpbButton PackNatural 0
auxBpbBox <- vBoxNew False 0
centerAl <- alignmentNew 0.5 0.5 0 0
containerAdd auxBpbBox centerAl
boxPackStart bpbBox auxBpbBox PackRepel 0
boxPackStart auxBpbBox bpbLabel PackGrow 0
boxPackStart auxBpbBox bpbButton PackGrow 0
instrumentCombo <- comboBoxNewText
instrumentIndex <- mapM (\(ind,ins) ->
......@@ -77,7 +112,6 @@ layerSettings boardQueue = do
return (i, ind)) instrumentList
comboBoxSetActive instrumentCombo 0
boxPackStart layerSettingsVBox instrumentCombo PackNatural 10
------------------------------------------------------------------------------
-- RVs
------------------------------------------------------------------------------
......@@ -92,12 +126,11 @@ layerSettings boardQueue = do
instrMCBMVar <- newMCBMVar =<< reactiveValueRead instrumentComboRV
layPitchRV <- newCBMVarRW 1
let layTempoRV = floatConv $ scaleValueReactive layTempoScale
strengthRV = floatConv $ scaleValueReactive layStrengthScale
let strengthRV = floatConv $ scaleValueReactive layStrengthScale
bpbRV = spinButtonValueIntReactive bpbButton
layVolumeRV = liftRW (bijection (floor, fromIntegral)) $
scaleValueReactive layVolumeScale
f2 d p s bpb v = Layer { relTempo = d
f2 d p s bpb v = Layer { layerBeat = d
, relPitch = p
, strength = s
, beatsPerBar = bpb
......@@ -105,18 +138,18 @@ layerSettings boardQueue = do
}
layerMCBMVar <- newMCBMVar =<< reactiveValueRead
(liftR5 f2 layTempoRV layPitchRV strengthRV bpbRV layVolumeRV)
(liftR5 f2 layBeatRV layPitchRV strengthRV bpbRV layVolumeRV)
reactiveValueOnCanRead layerMCBMVar $ postGUIAsync $ do
nLayer <- reactiveValueRead layerMCBMVar
reactiveValueWriteOnNotEq layTempoRV $ relTempo nLayer
reactiveValueWriteOnNotEq layBeatRV $ layerBeat nLayer
reactiveValueWriteOnNotEq layPitchRV $ relPitch nLayer
reactiveValueWriteOnNotEq strengthRV $ strength nLayer
reactiveValueWriteOnNotEq bpbRV $ beatsPerBar nLayer
reactiveValueWriteOnNotEq layVolumeRV $ volume nLayer
syncRightOnLeftWithBoth (\nt ol -> ol { relTempo = nt })
layTempoRV layerMCBMVar
syncRightOnLeftWithBoth (\nt ol -> ol { layerBeat = nt })
layBeatRV layerMCBMVar
syncRightOnLeftWithBoth (\np ol -> ol { relPitch = np })
layPitchRV layerMCBMVar
syncRightOnLeftWithBoth (\ns ol -> ol { strength = ns })
......
......@@ -75,8 +75,7 @@ createNotebook addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
let piece = snd $ fromJust mp
when (button == RightButton && maybe False (== fPos) mstate) $ do
let nCell = rotateGUICell piece
--boardSetPiece fPos nPiece ioBoard
reactiveValueWrite guiCellMCBMVar nCell
boardSetPiece fPos (Player,nCell) ioBoard
nmp <- boardGetPiece fPos ioBoard
when (button == LeftButton && isJust nmp) $ do
let nCell = snd $ fromJust nmp
......@@ -221,7 +220,7 @@ createNotebook addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
boardMapRV = ReactiveFieldRead getter notifier
where notifier io = do
chanMap <- reactiveValueRead chanMapRV
mapM_ ((\val -> reactiveValueOnCanRead val io) . \(b,_,_) -> b) chanMap
mapM_ ((`reactiveValueOnCanRead` io) . \(b,_,_) -> b) chanMap
getter = do
chanMap <- reactiveValueRead chanMapRV
mapM (reactiveValueRead . \(b,_,_) -> b) chanMap
......
......@@ -38,6 +38,9 @@ symbolString = map (\(_,y,z) -> (z,y)) noteSymbList
noteList :: [(String,Duration)]
noteList = map (\(x,_,y) -> (x,y)) noteSymbList
noteList' :: [(String,Duration)]
noteList' = map (\(x,y,z) -> (x ++ " " ++ y,z)) noteSymbList
noteSymbList :: [(String, String, Duration)]
noteSymbList = sortBy (comparing (\(_,_,x) -> x))
[ ("♩", "Quarter note", 1 % 4)
......
......@@ -8,8 +8,19 @@ import FRP.Yampa
import RMCA.Auxiliary
import RMCA.Semantics
metronome :: SF Tempo (Event Beat)
metronome = repeatedlyS () <<^ tempoToQNoteIvl
-- The absolute beat is the beat number of the global clock, there are
-- 16 starting from 1.
type AbsBeat = BeatNo
maxAbsBeat :: AbsBeat
maxAbsBeat = 16
-- The global system tempo beats every 16th note, each beat is tagged
-- 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 () <<^ (/4) <<^ tempoToQNoteIvl
-- Tempo is the number of quarter notes per minute.
tempoToQNoteIvl :: Tempo -> DTime
......
......@@ -4,10 +4,11 @@ module RMCA.Layer.Board ( boardRun
, BoardRun (..)
) where
import qualified Data.IntMap as M
import Data.List ((\\))
import qualified Data.IntMap as M
import Data.List ((\\))
import FRP.Yampa
import RMCA.Auxiliary
import RMCA.Global.Clock
import RMCA.Layer.Layer
import RMCA.Semantics
......@@ -19,55 +20,58 @@ singleBoard iPh = proc (board, Layer { relPitch = rp
, strength = s
}, ebno) ->
accumBy advanceHeads' (iPh,[]) -< ebno `tag` (board, fromEvent ebno, rp, s)
where advanceHeads' (ph,_) (board,bno,rp,s) = uncurry5 advanceHeads (board,bno,rp,s,ph)
where advanceHeads' (ph,_) (board,bno,rp,s) = advanceHeads board bno rp s ph
boardSF :: SF (Board, Layer, Tempo, BoardRun)
(Event ([PlayHead], [(LTempo,Note)]))
boardSF = proc (board, l, t, br) -> do
lt <- layerTempo -< (t,l)
ebno <- layerMetronome -< (t,l)
boardSF :: SF (Event AbsBeat, Board, Layer, BoardRun)
(Event ([PlayHead], [Note]))
boardSF = proc (eabs, board, l, br) -> do
ebno <- layerMetronome -< (eabs,l)
ess <- onChange -< br
ephn <- boardSwitch [] -< ((board, l, ebno), ess `tag` (br, startHeads board))
returnA -< fmap (second (zip (repeat lt))) ephn
boardSwitch [] -< ((board, l, ebno), ess `tag` (br, startHeads board))
boardSwitch :: [PlayHead]
-> SF ((Board, Layer,Event BeatNo), Event (BoardRun, [PlayHead]))
(Event ([PlayHead],[Note]))
-> SF ((Board, Layer, Event BeatNo), Event (BoardRun, [PlayHead]))
(Event ([PlayHead],[Note]))
boardSwitch rPh = dSwitch (singleBoard rPh *** (identity >>> notYet)) fnSwitch
where fnSwitch (BoardStart, iPh) = boardSwitch iPh
fnSwitch (BoardStop, _) = boardSwitch []
--------------------------------------------------------------------------------
-- Machinery to make parallel boards run
-- Machinery to make boards run in parallel
--------------------------------------------------------------------------------
routeBoard :: M.IntMap a -> M.IntMap sf -> M.IntMap (a,sf)
routeBoard = M.intersectionWith (,)
-- On the left are the disappearing signals, on the right the
-- appearing one.
lengthChange :: M.IntMap b -> SF (M.IntMap a, M.IntMap sf) (Event ([Int],[Int]))
lengthChange iSig = edgeBy diffSig ik <<^ M.keys <<^ fst
where ik = M.keys iSig
-- Old elements removed in nL are on the left, new elements added to
-- nL are on the right.
diffSig :: [Int] -> [Int] -> Maybe ([Int],[Int])
diffSig oL nL
| oL == nL = Nothing
| otherwise = Just (oL \\ nL, nL \\ oL)
boardRun' :: M.IntMap (SF (Board,Layer,Tempo,BoardRun)
(Event ([PlayHead],[(LTempo,Note)])))
-> SF (M.IntMap (Board,Layer,Tempo,BoardRun))
(M.IntMap (Event ([PlayHead],[(LTempo,Note)])))
{-
routeBoard :: (a -> b -> c) -> (a, M.IntMap b) -> M.IntMap sf -> M.IntMap (c,sf)
routeBoard formInput (glob, locs) sfs =
M.intersectionWith (,) (formInput glob <$> locs) sfs
-}
boardRun' :: M.IntMap (SF (Event AbsBeat,Board,Layer,BoardRun)
(Event ([PlayHead],[Note])))
-> SF (Event AbsBeat, BoardRun, (M.IntMap (Board,Layer)))
(M.IntMap (Event ([PlayHead],[Note])))
boardRun' iSF = boardRun'' iSF (lengthChange iSF)
where boardRun'' iSF swSF = pSwitch routeBoard iSF swSF contSwitch
where boardRun'' iSF swSF = pSwitch (routeBoard) iSF swSF contSwitch
contSwitch contSig (oldSig, newSig) = boardRun'' newSF
(lengthChange newSF >>> notYet)
where newSF = foldr (\k m -> M.insert k boardSF m)
(foldr M.delete contSig oldSig) newSig
lengthChange iSig = edgeBy diffSig ik <<^ M.keys <<^ (\(_,_,x) -> x) <<^ fst
where ik = M.keys iSig
-- Old elements removed in nL are on the left, new elements added to
-- nL are on the right.
diffSig :: [Int] -> [Int] -> Maybe ([Int],[Int])
diffSig oL nL
| oL == nL = Nothing
| otherwise = Just (oL \\ nL, nL \\ oL)
routeBoard :: (Event AbsBeat,BoardRun,M.IntMap (Board,Layer))
-> M.IntMap sf
-> M.IntMap ((Event AbsBeat,Board,Layer,BoardRun),sf)
routeBoard (evs,br,map) sfs =
M.intersectionWith (,) ((\(b,l) -> (evs,b,l,br)) <$> map) sfs
boardRun :: M.IntMap (Board,Layer,Tempo,BoardRun)
-> SF (M.IntMap (Board,Layer,Tempo,BoardRun))
(M.IntMap (Event ([PlayHead],[(LTempo,Note)])))
boardRun iSig = boardRun' (iSig $> boardSF)
boardRun :: (Tempo, BoardRun, M.IntMap (Board,Layer))
-> SF (Tempo, BoardRun, M.IntMap (Board,Layer))
(M.IntMap (Event ([PlayHead],[Note])))
boardRun (_,_,iMap) = mkBeat >>> boardRun' (iMap $> boardSF)
where mkBeat = proc (t,x,y) -> do
e <- metronome -< t
returnA -< (e,x,y)
......@@ -3,29 +3,35 @@
module RMCA.Layer.Layer where
import Data.CBMVar
import Data.Ratio
import Data.ReactiveValue
import FRP.Yampa
import RMCA.Auxiliary
import RMCA.Global.Clock
import RMCA.Semantics
-- Data representing the state of a layer. It is updated continuously.
data Layer = Layer { relTempo :: Double
data Layer = Layer { layerBeat :: Rational
, relPitch :: RelPitch
, strength :: Strength
, beatsPerBar :: BeatsPerBar
, volume :: Int
} deriving (Show,Read, Eq)
layerTempo :: SF (Tempo, Layer) LTempo
layerTempo = proc (t, Layer { relTempo = r }) ->
returnA -< floor $ r * fromIntegral t
} deriving (Show,Read,Eq)
layerMetronome :: SF (Event AbsBeat, Layer) (Event BeatNo)
layerMetronome = proc (eb, Layer { layerBeat = r
, beatsPerBar = bpb }) -> do
ewbno <- accumFilter (\_ (ab,r) -> ((),selectBeat (ab,r))) () -< (,r) <$> eb
accumBy (flip nextBeatNo) 1 -< ewbno `tag` bpb
where selectBeat (absBeat, layBeat) =
maybeIf ((absBeat - 1) `mod` floor (fromIntegral maxAbsBeat * layBeat) == 0)
{-
-- /!\ To be changed in the initialization of the bpb /!\
layerMetronome :: SF (Tempo, Layer) (Event BeatNo)
layerMetronome = proc (t,l@Layer { beatsPerBar = bpb }) -> do
eb <- metronome <<< layerTempo -< (t,l)
accumBy (flip nextBeatNo) 1 -< eb `tag` bpb
-}
layerRV :: CBMVar Layer -> ReactiveFieldReadWrite IO Layer
layerRV mvar = ReactiveFieldReadWrite setter getter notifier
where setter :: Layer -> IO ()
......@@ -41,7 +47,7 @@ getDefaultLayerRV :: IO (ReactiveFieldReadWrite IO Layer)
getDefaultLayerRV = layerRV <$> newCBMVar defaultLayer
defaultLayer :: Layer
defaultLayer = Layer { relTempo = 1
defaultLayer = Layer { layerBeat = 1 % 4
, relPitch = 0
, strength = 1
, beatsPerBar = 4
......
......@@ -11,7 +11,6 @@ import Graphics.UI.Gtk.Board.BoardLink
import Graphics.UI.Gtk.Layout.BackgroundContainer
import Hails.Yampa
import RMCA.Auxiliary
import RMCA.Auxiliary
import RMCA.Configuration
import RMCA.GUI.Board
import RMCA.GUI.Buttons
......@@ -44,7 +43,7 @@ main = do
(globalSettingsBox, tempoRV) <- globalSettings
boxPackStart settingsBox globalSettingsBox PackNatural 0
globalSep <- hSeparatorNew
boxPackStart settingsBox globalSep PackNatural 0
boxPackStart settingsBox globalSep PackNatural 10
(buttonBox,
playRV,stopRV,pauseRV,recordRV,
......@@ -73,12 +72,10 @@ main = do
layerMap <- reactiveValueRead layerMapRV
tempo <- reactiveValueRead tempoRV
let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
inRV :: ReactiveFieldRead IO (M.IntMap (Board,Layer,Tempo,BoardRun))
inRV = liftR4 (\bm lm t br -> M.map (\(b,l) -> (b,l,t,br)) $
M.intersectionWith (,) bm lm)
inRV = liftR4 (\bm lm t br -> (t,br,M.intersectionWith (,) bm lm))
boardMapRV layerMapRV tempoRV' boardRunRV
initSF <- reactiveValueRead inRV
(inBoard, outBoard) <- yampaReactiveDual initSF (boardRun initSF)
initSig <- reactiveValueRead inRV
(inBoard, outBoard) <- yampaReactiveDual initSig (boardRun initSig)
--reactiveValueOnCanRead inRV (reactiveValueRead inRV >>= print . M.keys)
inRV =:> inBoard
reactiveValueOnCanRead outBoard $ do
......@@ -88,7 +85,7 @@ main = do
let eventsMap = M.filter isEvent out
writePh chan val =
fromMaybeM_ $ fmap (\ph -> reactiveValueWrite ph val) $
fromMaybeM_ $ fmap (`reactiveValueWrite` val) $
M.lookup chan phRVMap
noteMap = M.map (eventToList . snd . splitE) out
sequence_ $ M.mapWithKey writePh $
......@@ -104,7 +101,7 @@ main = do
-- supposedly is no guaranty of order but apparently there is…
putStrLn "Board started."
-- Jack setup
forkIO $ jackSetup boardQueue
forkIO $ jackSetup boardQueue tempoRV
widgetShowAll window
------------------------------------------------------------
......
......@@ -83,9 +83,6 @@ type LTempo = Tempo
-- Beats and Bars
-- A beat as such is nothing.
type Beat = ()
-- Beats per Bar: number of beats per bar in the time signature of a layer.
-- Non-negative.
type BeatsPerBar = Int
......
......@@ -5,15 +5,13 @@
module RMCA.Translator.Jack ( jackSetup
) where
import Control.Arrow
import qualified Control.Monad.Exception.Synchronous as Sync
import qualified Control.Monad.Trans.Class as Trans
import qualified Data.Bifunctor as BF
import Data.CBMVar
import Data.Foldable
import qualified Data.IntMap as M
import Data.ReactiveValue
import qualified Foreign.C.Error as E
import Hails.Yampa
import RMCA.Auxiliary
import RMCA.Semantics
import RMCA.Translator.Message
......@@ -22,9 +20,6 @@ import RMCA.Translator.Translator
import qualified Sound.JACK as Jack
import qualified Sound.JACK.MIDI as JMIDI
import Control.Arrow
import Debug.Trace
rmcaName :: String
rmcaName = "RMCA"
......@@ -37,49 +32,51 @@ outPortName = "output"
-- Starts a default client with an input and an output port. Doesn't
-- do anything as such.
jackSetup :: (ReactiveValueReadWrite board
(M.IntMap ([(LTempo,Note)],[Message])) IO) =>
(M.IntMap ([Note],[Message])) IO
, ReactiveValueRead tempo Tempo IO) =>
board
-> tempo
-> IO ()
jackSetup boardQueue = Jack.handleExceptions $ do
jackSetup boardQueue tempoRV = Jack.handleExceptions $ do
toProcessRV <- Trans.lift $ newCBMVarRW []
Jack.withClientDefault rmcaName $ \client ->
Jack.withPort client outPortName $ \output ->
Jack.withPort client inPortName $ \input ->
Jack.withProcess client (jackCallBack client input output
toProcessRV boardQueue) $
Jack.withProcess client (jackCallBack input output
toProcessRV boardQueue tempoRV) $
Jack.withActivation client $ Trans.lift $ do
putStrLn $ "Started " ++ rmcaName ++ " JACK client."
Jack.waitForBreak
defaultTempo :: Tempo
defaultTempo = 120
-- The callback function. It pumps value out of the input port, mix
-- them with value coming from the machine itself and stuff them into
-- the output port. When this function is not running, events are
-- processed.
jackCallBack :: ( ReactiveValueReadWrite toProcess [(Frames, RawMessage)] IO
, ReactiveValueReadWrite board
(M.IntMap ([(LTempo,Note)],[Message])) IO) =>
Jack.Client
-> JMIDI.Port Jack.Input
(M.IntMap ([Note],[Message])) IO
, ReactiveValueRead tempo Tempo IO) =>
JMIDI.Port Jack.Input
-> JMIDI.Port Jack.Output
-> toProcess
-> board
-> tempo
-> Jack.NFrames
-> Sync.ExceptionalT E.Errno IO ()
jackCallBack client input output toProcessRV boardQueue nframes@(Jack.NFrames nframesInt') = do
jackCallBack input output toProcessRV boardQueue tempoRV
nframes@(Jack.NFrames nframesInt') = do
let inMIDIRV = inMIDIEvent input nframes
outMIDIRV = outMIDIEvent output nframes
nframesInt = fromIntegral nframesInt' :: Int
Trans.lift $ do
concat . toList . gatherMessages nframesInt <$>
reactiveValueRead boardQueue >>=
reactiveValueAppend toProcessRV
tempo <- reactiveValueRead tempoRV
concat . toList . gatherMessages tempo nframesInt <$>
reactiveValueRead boardQueue >>= \bq ->
reactiveValueAppend toProcessRV bq >> putStrLn ("BoardQueue: " ++ show (map fst bq))
reactiveValueEmpty boardQueue
(go, old') <- schedule nframesInt <$> reactiveValueRead toProcessRV
let old = map (BF.first (+ (- nframesInt))) old'
print $ map fst go
let old = map (first (+ (- nframesInt))) old'
putStrLn ("Out: " ++ show (map fst go))
reactiveValueWrite outMIDIRV go
reactiveValueWrite toProcessRV old
--------------
{-# LANGUAGE Arrows #-}
{-# LANGUAGE Arrows, TupleSections #-}
module RMCA.Translator.Translator where
......@@ -108,14 +108,17 @@ gatherMessages = arr $ uncurry4 gatherMessages'
-}
gatherMessages :: SampleRate
-> M.IntMap ([(LTempo,Note)],[Message])
-> Tempo
-> M.IntMap ([Note],[Message])
-> M.IntMap [(Frames,RawMessage)]
gatherMessages sr = M.map (map (second toRawMessage)) . M.mapWithKey gatherMessages'
where gatherMessages' :: Int -> ([(LTempo,Note)],[Message])
gatherMessages sr t = M.map (map (second toRawMessage)) .
M.mapWithKey gatherMessages'
where gatherMessages' :: Int
-> ([Note],[Message])
-> [(Frames,Message)]
gatherMessages' chan (notes,messages) =
zip (repeat 0) messages ++
concatMap (\(lt,n) -> noteToMessages sr chan lt (0,n)) notes
concatMap (noteToMessages sr chan t . (0,)) notes
-- Takes a list of time stamped "things", a sample rate and a buffer
-- size. The function argument is a function that needs to tell which
......
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