Commit 1e3f6286 authored by Henrik Nilsson's avatar Henrik Nilsson

Changes to make Arpeggigon compile and run with GHC 7.8.3 and base 4.7.

parent bef57335
...@@ -27,7 +27,8 @@ executable arpeggigon ...@@ -27,7 +27,8 @@ executable arpeggigon
, TypeSynonymInstances , TypeSynonymInstances
, FlexibleContexts , FlexibleContexts
, GeneralizedNewtypeDeriving , GeneralizedNewtypeDeriving
build-depends: base >=4.8 && <4.10 build-depends: base >=4.7 && <4.10
, bifunctors >= 5.4.1 && < 6
, array >=0.5 && <0.6 , array >=0.5 && <0.6
, keera-hails-reactivevalues >=0.2 && <0.3 , keera-hails-reactivevalues >=0.2 && <0.3
, Yampa >=0.10 && <0.11 , Yampa >=0.10 && <0.11
...@@ -127,4 +128,4 @@ executable arpeggigon ...@@ -127,4 +128,4 @@ executable arpeggigon
-- -Wall -- -Wall
-- -fno-warn-name-shadowing -- -fno-warn-name-shadowing
-- -fno-warn-unused-do-bind -- -fno-warn-unused-do-bind
-- -debug -- -debug
\ No newline at end of file
...@@ -6,6 +6,7 @@ import FRP.Yampa ...@@ -6,6 +6,7 @@ import FRP.Yampa
-- |= General functions -- |= General functions
{-
-- | Reversed version of '(\<$\>)'. -- | Reversed version of '(\<$\>)'.
(<$$>) :: (Functor f) => f a -> (a -> b) -> f b (<$$>) :: (Functor f) => f a -> (a -> b) -> f b
(<$$>) = flip (<$>) (<$$>) = flip (<$>)
...@@ -13,6 +14,7 @@ import FRP.Yampa ...@@ -13,6 +14,7 @@ import FRP.Yampa
-- | Reversed version of '(<$)'. -- | Reversed version of '(<$)'.
($>) :: (Functor f) => f a -> b -> f b ($>) :: (Functor f) => f a -> b -> f b
($>) = flip (<$) ($>) = flip (<$)
-}
-- | @bound (min,max)@ behaves like identity if the supplied value is between @min@ and @max@, otherwise it is replaced either by @min@ or by @max@. -- | @bound (min,max)@ behaves like identity if the supplied value is between @min@ and @max@, otherwise it is replaced either by @min@ or by @max@.
bound :: (Ord a) => (a, a) -> a -> a bound :: (Ord a) => (a, a) -> a -> a
......
...@@ -18,6 +18,18 @@ countTo n = count >>^ filterE (== n) ...@@ -18,6 +18,18 @@ countTo n = count >>^ filterE (== n)
-- Event b => . a . . . b . . . c . . . . . . d . e . f . . . . . g . . -- Event b => . a . . . b . . . c . . . . . . d . e . f . . . . . g . .
-- wairFor => . . . . . 1 . . . 2 . . . . . . 4 . . . 5 . . . . . 6 . . -- wairFor => . . . . . 1 . . . 2 . . . . . . 4 . . . 5 . . . . . 6 . .
-- A more direct approach, and without any use of *> to avoid depending
-- on applicatives.
waitForEvent :: SF (Event a, Event b) (Event a)
waitForEvent = sscanPrim procEvts NoEvent NoEvent
where
procEvts eaPrev (NoEvent, NoEvent) = Just (eaPrev, NoEvent)
procEvts _ (ea@(Event _), NoEvent) = Just (ea, NoEvent)
procEvts eaPrev (NoEvent, Event _) = Just (NoEvent, eaPrev)
procEvts _ (ea@(Event _), Event _) = Just (NoEvent, ea)
{-
waitForEvent :: SF (Event a, Event b) (Event a) waitForEvent :: SF (Event a, Event b) (Event a)
waitForEvent = proc (ea,eb) -> do waitForEvent = proc (ea,eb) -> do
em <- arr $ uncurry $ mapMerge Left Right (\_ b -> Right b) -< (ea,eb) em <- arr $ uncurry $ mapMerge Left Right (\_ b -> Right b) -< (ea,eb)
...@@ -27,6 +39,7 @@ waitForEvent = proc (ea,eb) -> do ...@@ -27,6 +39,7 @@ waitForEvent = proc (ea,eb) -> do
accumulator _ (Left a) = Event a accumulator _ (Left a) = Event a
accumulator _ (Right _) = NoEvent accumulator _ (Right _) = NoEvent
--accumulator _ (Right b) = --accumulator _ (Right b) =
-}
{- {-
waitForEvent :: SF (Event b, Event a) (Event b) waitForEvent :: SF (Event b, Event a) (Event b)
...@@ -81,7 +94,7 @@ integralMod x = intMod' 0 ...@@ -81,7 +94,7 @@ integralMod x = intMod' 0
where intMod' x0 = switch (intMod'' x0) (\y -> intMod' (y - x)) where intMod' x0 = switch (intMod'' x0) (\y -> intMod' (y - x))
intMod'' x0 = proc t -> do intMod'' x0 = proc t -> do
it <- (+ x0) ^<< integral -< t it <- (+ x0) ^<< integral -< t
es <- edgeBy (\_ y -> maybeIf (y > x) $> y) 0 -< it es <- edgeBy (\_ y -> if y > x then Just y else Nothing) 0 -< it
returnA -< (it,es) returnA -< (it,es)
...@@ -92,7 +105,7 @@ varFreqSine = sin ^<< (2*pi*) ^<< integralMod 1 <<^ (1/) ...@@ -92,7 +105,7 @@ varFreqSine = sin ^<< (2*pi*) ^<< integralMod 1 <<^ (1/)
-- | Generates an 'Event' with a regular period, which is given as an input to the signal function. -- | Generates an 'Event' with a regular period, which is given as an input to the signal function.
repeatedlyS :: a -> SF DTime (Event a) repeatedlyS :: a -> SF DTime (Event a)
repeatedlyS x = edgeBy (\a b -> maybeIf (a * b < 0) $> x) 0 repeatedlyS x = edgeBy (\a b -> if a * b < 0 then Just x else Nothing) 0
<<< varFreqSine <<^ (2*) <<< varFreqSine <<^ (2*)
repeatedlyS' :: a -> SF DTime (Event a) repeatedlyS' :: a -> SF DTime (Event a)
......
...@@ -37,7 +37,7 @@ toggleButtonNewFromStock s = do ...@@ -37,7 +37,7 @@ toggleButtonNewFromStock s = do
buttonBox <- hBoxNew False 0 buttonBox <- hBoxNew False 0
buttonImg <- imageNewFromStock s IconSizeButton buttonImg <- imageNewFromStock s IconSizeButton
stockTxt <- stockLookupItem s stockTxt <- stockLookupItem s
buttonLabel <- labelNew (siLabel <$> stockTxt) buttonLabel <- labelNew (fmap siLabel stockTxt)
labelSetUseUnderline buttonLabel True labelSetUseUnderline buttonLabel True
packButton button buttonBox buttonLabel buttonImg packButton button buttonBox buttonLabel buttonImg
......
...@@ -94,12 +94,13 @@ createNotebook boardQueue tc addLayerRV rmLayerRV ...@@ -94,12 +94,13 @@ createNotebook boardQueue tc addLayerRV rmLayerRV
when (button == LeftButton && isJust nmp) $ do when (button == LeftButton && isJust nmp) $ do
let nCell = snd $ fromJust nmp let nCell = snd $ fromJust nmp
mOHid <- tryTakeMVar guiCellHidMVar mOHid <- tryTakeMVar guiCellHidMVar
forM_ mOHid $ removeCallbackMCBMVar guiCellMCBMVar maybe (return ()) (removeCallbackMCBMVar guiCellMCBMVar) mOHid
reactiveValueWrite guiCellMCBMVar nCell reactiveValueWrite guiCellMCBMVar nCell
nHid <- installCallbackMCBMVar guiCellMCBMVar $ do nHid <- installCallbackMCBMVar guiCellMCBMVar $ do
cp <- reactiveValueRead curChanRV cp <- reactiveValueRead curChanRV
guiVal <- reactiveValueRead guiCellMCBMVar guiVal <- reactiveValueRead guiCellMCBMVar
mChanRV <- M.lookup cp <$> reactiveValueRead chanMapRV mChanRV <- fmap (M.lookup cp)
(reactiveValueRead chanMapRV)
when (isNothing mChanRV) $ error "Can't get piece array!" when (isNothing mChanRV) $ error "Can't get piece array!"
let (_,pieceArrRV,_) = fromJust mChanRV let (_,pieceArrRV,_) = fromJust mChanRV
reactiveValueWrite (pieceArrRV ! fPos) guiVal reactiveValueWrite (pieceArrRV ! fPos) guiVal
...@@ -126,8 +127,8 @@ createNotebook boardQueue tc addLayerRV rmLayerRV ...@@ -126,8 +127,8 @@ createNotebook boardQueue tc addLayerRV rmLayerRV
layerMapRV <- newCBRef $ M.insert fstP defaultLayerConf M.empty layerMapRV <- newCBRef $ M.insert fstP defaultLayerConf M.empty
reactiveValueOnCanRead layerMapRV $ do reactiveValueOnCanRead layerMapRV $ do
synth <- fmap (\(_,_,s) -> s) <$> reactiveValueRead layerMapRV synth <- fmap (fmap (\(_,_,s) -> s)) (reactiveValueRead layerMapRV)
sequence_ $ M.mapWithKey sequence_ $ M.elems $ M.mapWithKey
(\chan mess -> reactiveValueAppend boardQueue $ (\chan mess -> reactiveValueAppend boardQueue $
M.singleton chan $ ([],) $ synthMessage chan mess) synth M.singleton chan $ ([],) $ synthMessage chan mess) synth
...@@ -252,9 +253,21 @@ createNotebook boardQueue tc addLayerRV rmLayerRV ...@@ -252,9 +253,21 @@ createNotebook boardQueue tc addLayerRV rmLayerRV
boardMapRV = ReactiveFieldRead getter notifier boardMapRV = ReactiveFieldRead getter notifier
where notifier io = do where notifier io = do
chanMap <- reactiveValueRead chanMapRV chanMap <- reactiveValueRead chanMapRV
mapM_ ((`reactiveValueOnCanRead` io) . \(b,_,_) -> b) chanMap intMapMapM_ ((`reactiveValueOnCanRead` io) . \(b,_,_) -> b) chanMap
getter = do getter = do
chanMap <- reactiveValueRead chanMapRV chanMap <- reactiveValueRead chanMapRV
mapM (reactiveValueRead . \(b,_,_) -> b) chanMap intMapMapM (reactiveValueRead . \(b,_,_) -> b) chanMap
return (n, boardMapRV, layerMapRV, phMapRV) return (n, boardMapRV, layerMapRV, phMapRV)
------------------------------------------------------------------------------
-- IntMap versions of mapM etc. to make code work with GHC 7.8.3
------------------------------------------------------------------------------
intMapMapM_ :: (Functor m, Monad m) => (a -> m b) -> M.IntMap a -> m ()
intMapMapM_ f im = mapM_ f (M.elems im)
intMapMapM :: (Functor m, Monad m) => (a -> m b) -> M.IntMap a -> m (M.IntMap b)
intMapMapM f im = fmap (M.fromList . zip ks) (mapM f es)
where
(ks, es) = unzip (M.toList im)
...@@ -120,7 +120,8 @@ noteSettingsBox = do ...@@ -120,7 +120,8 @@ noteSettingsBox = do
\for the duration.") $ lookup d noteDurIndex \for the duration.") $ lookup d noteDurIndex
noteDurRV = bijection (indexToDur, durToIndex) `liftRW` noteDurRV = bijection (indexToDur, durToIndex) `liftRW`
comboBoxIndexRV noteDurCombo comboBoxIndexRV noteDurCombo
noteDurLabel <- labelNew =<< (`lookup` symbolString) <$> reactiveValueRead noteDurRV noteDurLabel <- labelNew =<< fmap (`lookup` symbolString)
(reactiveValueRead noteDurRV)
let noteDurLabelRV = labelTextReactive noteDurLabel let noteDurLabelRV = labelTextReactive noteDurLabel
boxPackStart naBox noteDurBox PackNatural 0 boxPackStart naBox noteDurBox PackNatural 0
boxPackStart noteDurBox noteDurCombo PackNatural 0 boxPackStart noteDurBox noteDurCombo PackNatural 0
...@@ -140,14 +141,15 @@ noteSettingsBox = do ...@@ -140,14 +141,15 @@ noteSettingsBox = do
nDur <- reactiveValueRead noteDurRV nDur <- reactiveValueRead noteDurRV
oCell <- reactiveValueRead setRV oCell <- reactiveValueRead setRV
let nCa :: Maybe NoteAttr let nCa :: Maybe NoteAttr
nCa = (\na -> na { naDur = nDur }) <$> getNAttr (cellAction oCell) nCa = fmap (\na -> na { naDur = nDur }) (getNAttr (cellAction oCell))
nCell :: GUICell nCell :: GUICell
nCell = if isJust nCa nCell = if isJust nCa
then oCell { cellAction = then oCell { cellAction =
setNAttr (fromJust nCa) (cellAction oCell) } setNAttr (fromJust nCa) (cellAction oCell) }
else oCell else oCell
reactiveValueWriteOnNotEq setRV nCell reactiveValueWriteOnNotEq setRV nCell
fromMaybeM_ $ reactiveValueWrite noteDurLabelRV <$> lookup nDur symbolString fromMaybeM_ $ fmap (reactiveValueWrite noteDurLabelRV)
(lookup nDur symbolString)
reactiveValueOnCanRead rCountRV $ do reactiveValueOnCanRead rCountRV $ do
...@@ -160,8 +162,8 @@ noteSettingsBox = do ...@@ -160,8 +162,8 @@ noteSettingsBox = do
nSlide <- reactiveValueRead slideComboRV nSlide <- reactiveValueRead slideComboRV
oCell <- reactiveValueRead setRV oCell <- reactiveValueRead setRV
let nCa :: Maybe NoteAttr let nCa :: Maybe NoteAttr
nCa = (\na -> na { naOrn = (naOrn na) { ornSlide = nSlide } }) <$> nCa = fmap (\na -> na { naOrn = (naOrn na) { ornSlide = nSlide } })
getNAttr (cellAction oCell) (getNAttr (cellAction oCell))
nCell :: GUICell nCell :: GUICell
nCell = if isJust nCa nCell = if isJust nCa
then oCell { cellAction = then oCell { cellAction =
...@@ -174,7 +176,7 @@ noteSettingsBox = do ...@@ -174,7 +176,7 @@ noteSettingsBox = do
nArt <- reactiveValueRead artComboRV nArt <- reactiveValueRead artComboRV
oCell <- reactiveValueRead setRV oCell <- reactiveValueRead setRV
let nCa :: Maybe NoteAttr let nCa :: Maybe NoteAttr
nCa = (\na -> na { naArt = nArt }) <$> getNAttr (cellAction oCell) nCa = fmap (\na -> na { naArt = nArt }) (getNAttr (cellAction oCell))
nCell :: GUICell nCell :: GUICell
nCell = if isJust nCa nCell = if isJust nCa
then oCell { cellAction = then oCell { cellAction =
...@@ -200,13 +202,14 @@ noteSettingsBox = do ...@@ -200,13 +202,14 @@ noteSettingsBox = do
reactiveValueOnCanRead setRV $ postGUIAsync $ do reactiveValueOnCanRead setRV $ postGUIAsync $ do
nCell <- reactiveValueRead setRV nCell <- reactiveValueRead setRV
fromMaybeM_ (reactiveValueWriteOnNotEq artComboRV . naArt <$> fromMaybeM_ (fmap (reactiveValueWriteOnNotEq artComboRV . naArt)
getNAttr (cellAction nCell)) (getNAttr (cellAction nCell)))
fromMaybeM_ (reactiveValueWriteOnNotEq slideComboRV . ornSlide . naOrn <$> fromMaybeM_ (fmap (reactiveValueWriteOnNotEq slideComboRV
getNAttr (cellAction nCell)) . ornSlide . naOrn)
(getNAttr (cellAction nCell)))
reactiveValueWriteOnNotEq rCountRV $ repeatCount nCell reactiveValueWriteOnNotEq rCountRV $ repeatCount nCell
fromMaybeM_ (reactiveValueWriteOnNotEq noteDurRV . naDur <$> fromMaybeM_ (fmap (reactiveValueWriteOnNotEq noteDurRV . naDur)
getNAttr (cellAction nCell)) (getNAttr (cellAction nCell)))
updateNaBox nCell updateNaBox nCell
widgetShow pieceBox widgetShow pieceBox
......
...@@ -50,7 +50,7 @@ stopIOMetronome (IOMetronome (_,tid)) = killThread tid ...@@ -50,7 +50,7 @@ stopIOMetronome (IOMetronome (_,tid)) = killThread tid
newtype IOTick = IOTick (MVar [IO ()]) newtype IOTick = IOTick (MVar [IO ()])
newIOTick :: IO IOTick newIOTick :: IO IOTick
newIOTick = IOTick <$> newMVar [] newIOTick = fmap IOTick (newMVar [])
tickIOTick :: IOTick -> IO () tickIOTick :: IOTick -> IO ()
tickIOTick (IOTick mvar) = readMVar mvar >>= sequence_ tickIOTick (IOTick mvar) = readMVar mvar >>= sequence_
......
...@@ -18,7 +18,8 @@ layerMetronome StaticLayerConf { beatsPerBar = bpb ...@@ -18,7 +18,8 @@ layerMetronome StaticLayerConf { beatsPerBar = bpb
} = } =
proc (eb, DynLayerConf { layerBeat = r proc (eb, DynLayerConf { layerBeat = r
}) -> do }) -> do
ewbno <- accumFilter (\_ (ab,r) -> ((),selectBeat (ab,r))) () -< (,r) <$> eb ewbno <- accumFilter (\_ (ab,r) -> ((),selectBeat (ab,r))) ()
-< fmap (,r) eb
accumBy (flip nextBeatNo) 0 -< ewbno `tag` bpb accumBy (flip nextBeatNo) 0 -< ewbno `tag` bpb
where selectBeat (absBeat, layBeat) = where selectBeat (absBeat, layBeat) =
maybeIf ((absBeat - 1) `mod` maybeIf ((absBeat - 1) `mod`
...@@ -84,8 +85,8 @@ layers imap = proc (t,erun,map) -> do ...@@ -84,8 +85,8 @@ layers imap = proc (t,erun,map) -> do
(Stopped,_) -> (nRS,Just nRS) (Stopped,_) -> (nRS,Just nRS)
(Running, Stopped) -> (Stopped,Just Stopped) (Running, Stopped) -> (Stopped,Just Stopped)
_ -> (oRS,Nothing)) Stopped -< erun _ -> (oRS,Nothing)) Stopped -< erun
eabs <- rSwitch metronome -< (t, newMetronome <$> erun') eabs <- rSwitch metronome -< (t, fmap newMetronome erun')
rpSwitch routing (imap $> layer) -< ((eabs,erun,map),e) rpSwitch routing (fmap (const layer) imap) -< ((eabs,erun,map),e)
where routing (eabs,erun,map) sfs = M.intersectionWith (,) where routing (eabs,erun,map) sfs = M.intersectionWith (,)
(fmap (\(b,l,er) -> (eabs,b,l,erun `lMerge` er)) map) sfs (fmap (\(b,l,er) -> (eabs,b,l,erun `lMerge` er)) map) sfs
......
...@@ -32,13 +32,13 @@ newtype HandlerId a = HandlerId Integer deriving(Eq, Show, Ord) ...@@ -32,13 +32,13 @@ newtype HandlerId a = HandlerId Integer deriving(Eq, Show, Ord)
newtype MCBMVar a = MCBMVar (MVar (a, (HandlerId a,CallbackMap))) newtype MCBMVar a = MCBMVar (MVar (a, (HandlerId a,CallbackMap)))
newMCBMVar :: a -> IO (MCBMVar a) newMCBMVar :: a -> IO (MCBMVar a)
newMCBMVar = (MCBMVar <$>) . newMVar . (,(HandlerId 0,M.empty)) newMCBMVar = (fmap MCBMVar) . newMVar . (,(HandlerId 0,M.empty))
readMCBMVar :: MCBMVar a -> IO a readMCBMVar :: MCBMVar a -> IO a
readMCBMVar (MCBMVar x) = fst <$> readMVar x readMCBMVar (MCBMVar x) = fmap fst (readMVar x)
runCallBacks :: MCBMVar a -> IO () runCallBacks :: MCBMVar a -> IO ()
runCallBacks (MCBMVar x) = readMVar x >>= sequence_ . snd . snd runCallBacks (MCBMVar x) = readMVar x >>= sequence_ . M.elems . snd . snd
writeMCBMVar :: MCBMVar a -> a -> IO () writeMCBMVar :: MCBMVar a -> a -> IO ()
writeMCBMVar w@(MCBMVar x) y = do writeMCBMVar w@(MCBMVar x) y = do
......
...@@ -3,6 +3,7 @@ ...@@ -3,6 +3,7 @@
module Main where module Main where
import Control.Concurrent import Control.Concurrent
import Data.Monoid
import qualified Data.IntMap as M import qualified Data.IntMap as M
import Data.ReactiveValue import Data.ReactiveValue
import FRP.Yampa import FRP.Yampa
...@@ -96,9 +97,9 @@ main = do ...@@ -96,9 +97,9 @@ main = do
let noteMap = M.map fromEvent $ M.filter isEvent $ M.map fst out let noteMap = M.map fromEvent $ M.filter isEvent $ M.map fst out
writePh chan val = writePh chan val =
fromMaybeM_ $ (`reactiveValueWrite` val) <$> fromMaybeM_ $ fmap (`reactiveValueWrite` val)
M.lookup chan phRVMap (M.lookup chan phRVMap)
sequence_ $ M.mapWithKey writePh $ M.map snd out sequence_ $ M.elems $ M.mapWithKey writePh $ M.map snd out
reactiveValueAppend boardQueue $ M.map (,[]) noteMap reactiveValueAppend boardQueue $ M.map (,[]) noteMap
putStrLn "Board started." putStrLn "Board started."
......
...@@ -3,7 +3,7 @@ ...@@ -3,7 +3,7 @@
module RMCA.ReactiveValueAtomicUpdate where module RMCA.ReactiveValueAtomicUpdate where
import Control.Monad import Data.Monoid
import Data.CBRef import Data.CBRef
import Data.ReactiveValue import Data.ReactiveValue
...@@ -19,7 +19,7 @@ class (ReactiveValueReadWrite a b m) => ReactiveValueAtomicUpdate a b m where ...@@ -19,7 +19,7 @@ class (ReactiveValueReadWrite a b m) => ReactiveValueAtomicUpdate a b m where
reactiveValueUpdate_ :: (ReactiveValueAtomicUpdate a b m) => reactiveValueUpdate_ :: (ReactiveValueAtomicUpdate a b m) =>
a -> (b -> b) -> m () a -> (b -> b) -> m ()
reactiveValueUpdate_ rv f = void $ reactiveValueUpdate rv f reactiveValueUpdate_ rv f = reactiveValueUpdate rv f >> return ()
reactiveValueAppend :: (Monoid b, ReactiveValueAtomicUpdate a b m) => reactiveValueAppend :: (Monoid b, ReactiveValueAtomicUpdate a b m) =>
a -> b -> m () a -> b -> m ()
......
...@@ -9,7 +9,7 @@ import Control.Arrow ...@@ -9,7 +9,7 @@ import Control.Arrow
import qualified Control.Monad.Exception.Synchronous as Sync import qualified Control.Monad.Exception.Synchronous as Sync
import qualified Control.Monad.Trans.Class as Trans import qualified Control.Monad.Trans.Class as Trans
import Data.CBRef import Data.CBRef
import Data.Foldable import Data.Foldable hiding (mapM_,concat)
import qualified Data.IntMap as M import qualified Data.IntMap as M
import Data.Maybe import Data.Maybe
import Data.ReactiveValue import Data.ReactiveValue
...@@ -109,10 +109,10 @@ jackCallBack tc input output toProcessRV boardQueue tempoRV layerMapRV ...@@ -109,10 +109,10 @@ jackCallBack tc input output toProcessRV boardQueue tempoRV layerMapRV
mapM_ ((\(Instrument c p) -> reactiveValueUpdate layerMapRV mapM_ ((\(Instrument c p) -> reactiveValueUpdate layerMapRV
(M.adjust (\(st,d,s) -> (st,d,s { instrument = fromProgram p })) (M.adjust (\(st,d,s) -> (st,d,s { instrument = fromProgram p }))
(fromChannel c))) . snd) instruments (fromChannel c))) . snd) instruments
concat . toList . gatherMessages tempo nframesInt <$> fmap (concat . toList . gatherMessages tempo nframesInt)
reactiveValueEmpty boardQueue >>= (reactiveValueEmpty boardQueue) >>=
reactiveValueAppend toProcessRV reactiveValueAppend toProcessRV
(go, old') <- schedule nframesInt <$> reactiveValueRead toProcessRV (go, old') <- fmap (schedule nframesInt) (reactiveValueRead toProcessRV)
let old = map (first (+ (- nframesInt))) old' let old = map (first (+ (- nframesInt))) old'
--putStrLn ("Out: " ++ show (map fst go)) --putStrLn ("Out: " ++ show (map fst go))
reactiveValueWrite outMIDIRV go reactiveValueWrite outMIDIRV go
......
...@@ -3,6 +3,7 @@ ...@@ -3,6 +3,7 @@
module RMCA.Translator.RV where module RMCA.Translator.RV where
import Control.Monad.Exception.Synchronous (ExceptionalT, resolveT) import Control.Monad.Exception.Synchronous (ExceptionalT, resolveT)
import Data.Monoid hiding (All)
import qualified Data.Bifunctor as BF import qualified Data.Bifunctor as BF
import qualified Data.EventList.Absolute.TimeBody as EventListAbs import qualified Data.EventList.Absolute.TimeBody as EventListAbs
import qualified Data.List as L import qualified Data.List as L
...@@ -24,8 +25,8 @@ inMIDIEvent :: JMIDI.Port Jack.Input ...@@ -24,8 +25,8 @@ inMIDIEvent :: JMIDI.Port Jack.Input
-> ReactiveFieldRead IO [(Frames,RawMessage)] -> ReactiveFieldRead IO [(Frames,RawMessage)]
inMIDIEvent input nframes = ReactiveFieldRead getter notifier inMIDIEvent input nframes = ReactiveFieldRead getter notifier
where getter :: IO [(Frames, RawMessage)] where getter :: IO [(Frames, RawMessage)]
getter = handleError $ transform <$> getter = handleError $
JMIDI.readEventsFromPort input nframes fmap transform (JMIDI.readEventsFromPort input nframes)
transform :: EventListAbs.T Jack.NFrames t -> [(Frames, t)] transform :: EventListAbs.T Jack.NFrames t -> [(Frames, t)]
transform = map (BF.first (\(Jack.NFrames n) -> fromIntegral n)) . transform = map (BF.first (\(Jack.NFrames n) -> fromIntegral n)) .
......
...@@ -52,6 +52,13 @@ sortRawMessages = sortRawMessages' ([],[]) ...@@ -52,6 +52,13 @@ sortRawMessages = sortRawMessages' ([],[])
| otherwise = sortRawMessages' ((n,fromJust nm) :m, rm) xs | otherwise = sortRawMessages' ((n,fromJust nm) :m, rm) xs
where nm = fromRawMessage xm where nm = fromRawMessage xm
-- Direct each message to a specific channel.
-- (Simplified version not using <$> or <*>
sortChannel :: [Message] -> [(Int,[Message])]
sortChannel ms = [ (getChannel (head ms'), ms')
| ms' <- groupBy ((==) `on` getChannel) ms ]
{-
-- Direct each message to a specific channel. -- Direct each message to a specific channel.
-- /!\ To be modified. -- /!\ To be modified.
sortChannel :: [Message] -> [(Int,[Message])] sortChannel :: [Message] -> [(Int,[Message])]
...@@ -59,6 +66,7 @@ sortChannel = map ((,) <$> (fst . head) <*> map snd) ...@@ -59,6 +66,7 @@ sortChannel = map ((,) <$> (fst . head) <*> map snd)
. groupBy ((==) `on` fst) . map sortChannel' . groupBy ((==) `on` fst) . map sortChannel'
where sortChannel' :: Message -> (Int, Message) where sortChannel' :: Message -> (Int, Message)
sortChannel' m = let c = getChannel m in (c,m) sortChannel' m = let c = getChannel m in (c,m)
-}
-- NoteOn messages are on the right, other Control messages are on the -- NoteOn messages are on the right, other Control messages are on the
-- left. For now we throw away NoteOff messages. -- left. For now we throw away NoteOff messages.
......
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