Commit 7f49283e authored by Guerric Chupin's avatar Guerric Chupin

Sound works with multiple layers, but strange shift problem.

parent ee7c94ce
......@@ -89,10 +89,44 @@ executable RMCA.prof
-Wall
-fno-warn-name-shadowing
-fno-warn-unused-do-bind
--fprof-auto
--prof
--auto-all
-eventlog
-debug
--"-with-rtsopts=-P -S -T -h -i0.1 -xt"
"-with-rtsopts=-ls"
\ No newline at end of file
-fprof-auto
-prof
-auto-all
"-with-rtsopts=-P -S -T -h -i0.1 -xt"
executable RMCA.debug
main-is: RMCA/Main.hs
other-modules: Paths_RMCA
other-extensions: MultiParamTypeClasses
, ScopedTypeVariables
, Arrows
, FlexibleInstances
, TypeSynonymInstances
, FlexibleContexts
, GeneralizedNewtypeDeriving
build-depends: base >=4.8 && <4.10
, array >=0.5 && <0.6
, cairo >=0.13 && <0.14
, keera-hails-reactivevalues >=0.2 && <0.3
, Yampa >=0.10 && <0.11
, gtk-helpers >=0.0 && <0.1
, gtk >=0.14 && <0.15
, keera-hails-reactive-gtk >=0.3 && <0.4
, keera-hails-reactive-yampa >=0.0 && <0.1
, containers >=0.5 && <0.6
, jack >=0.7 && <0.8
, midi >=0.2 && <0.3
, explicit-exception >=0.1 && <0.2
, transformers >=0.4 && <0.6
, event-list >=0.1 && <0.2
, keera-callbacks >=0.1 && <0.2
, glib >=0.13 && <0.14
hs-source-dirs: src
build-tools: hsc2hs
default-language: Haskell2010
ghc-options: -O2
-threaded
-Wall
-fno-warn-name-shadowing
-fno-warn-unused-do-bind
-debug
\ No newline at end of file
......@@ -13,6 +13,9 @@ import FRP.Yampa
-- General functions
--------------------------------------------------------------------------------
(<$$>) :: (Functor f) => f a -> (a -> b) -> f b
(<$$>) = flip (<$>)
($>) :: (Functor f) => f a -> b -> f b
($>) = flip (<$)
......@@ -114,6 +117,10 @@ reactiveValueAppend :: (Monoid b, ReactiveValueReadWrite a b m) =>
reactiveValueAppend rv v = do ov <- reactiveValueRead rv
reactiveValueWrite rv (ov `mappend` v)
reactiveValueEmpty :: (Monoid b, ReactiveValueReadWrite a b m) =>
a -> m ()
reactiveValueEmpty rv = reactiveValueWrite rv mempty
reactiveValueWriteOnNotEq :: ( Eq b
, ReactiveValueReadWrite a b m) =>
a -> b -> m ()
......@@ -121,12 +128,6 @@ reactiveValueWriteOnNotEq rv nv = do
ov <- reactiveValueRead rv
when (ov /= nv) $ reactiveValueWrite rv nv
emptyRW :: (Monoid b, ReactiveValueReadWrite a b m) => a -> m b
emptyRW rv = do
val <- reactiveValueRead rv
reactiveValueWrite rv mempty
return val
-- Update when the value is an Event. It would be nice to have that
-- even for Maybe as well.
(>:>) :: (ReactiveValueRead a (Event b) IO, ReactiveValueWrite c b IO) =>
......
......@@ -207,7 +207,7 @@ initBoardRV :: BIO.Board Int Tile (Player,GUICell)
initBoardRV board@BIO.Board { boardPieces = (GameBoard gArray) } = do
-- RV creation
phMVar <- newCBMVar []
notBMVar <- mkClockRV 10
notBMVar <- mkClockRV 50
let getterB :: IO Board
getterB = do
(boardArray :: [((Int,Int),Maybe (Player,GUICell))]) <- getAssocs gArray
......
......@@ -2,19 +2,22 @@
module RMCA.GUI.LayerSettings where
import Data.Maybe
import Data.ReactiveValue
import Data.String
import Data.Tuple
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Reactive
import RMCA.Auxiliary
import RMCA.GUI.NoteSettings
import RMCA.Layer.Layer
import RMCA.MCBMVar
import RMCA.Semantics
import RMCA.Translator.Instruments
import RMCA.Translator.Message
import qualified Data.IntMap as M
import Data.Maybe
import Data.ReactiveValue
import Data.String
import Data.Tuple
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Reactive
import RMCA.Auxiliary
import RMCA.GUI.NoteSettings
import RMCA.Layer.Layer
import RMCA.MCBMVar
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) =>
......@@ -31,11 +34,12 @@ mkVScale s adj = do
boxPackStart hBox boxScale PackNatural 0
return (hBox,boxScale)
layerSettings :: (ReactiveValueReadWrite board ([Note],[Message]) IO) =>
board -> IO ( VBox
, MCBMVar Layer
, MCBMVar Int
)
layerSettings :: (ReactiveValueReadWrite board (M.IntMap ([(LTempo,Note)],[Message])) IO) =>
board
-> IO ( VBox
, MCBMVar Layer
, MCBMVar Int
)
layerSettings boardQueue = do
------------------------------------------------------------------------------
-- GUI Boxes
......@@ -86,27 +90,13 @@ layerSettings boardQueue = do
comboBoxIndexRV instrumentCombo
instrMCBMVar <- newMCBMVar =<< reactiveValueRead instrumentComboRV
{-
ins <- reactiveValueRead instrumentComboRV
chan <- reactiveValueRead chanRV
reactiveValueAppend boardQueue ([],[Instrument (mkChannel chan)
(mkProgram ins)])
reactiveValueOnCanRead instrumentComboRV changeInst
-}
layPitchRV <- newCBMVarRW 1
let layTempoRV = floatConv $ scaleValueReactive layTempoScale
strengthRV = floatConv $ scaleValueReactive layStrengthScale
bpbRV = spinButtonValueIntReactive bpbButton
layVolumeRV = liftRW (bijection (floor, fromIntegral)) $
scaleValueReactive layVolumeScale
{-
f1 Layer { relTempo = d
, relPitch = p
, strength = s
, beatsPerBar = bpb
, volume = v
} = (d,p,s,bpb,v)-}
f2 d p s bpb v = Layer { relTempo = d
, relPitch = p
, strength = s
......@@ -114,12 +104,8 @@ layerSettings boardQueue = do
, volume = v
}
{-
layerRV = liftRW5 (bijection (f1,f2))
layTempoRV layPitchRV strengthRV bpbRV layVolumeRV
-}
layerMCBMVar <- newMCBMVar =<< reactiveValueRead (liftR5 f2 layTempoRV layPitchRV strengthRV bpbRV layVolumeRV)
layerMCBMVar <- newMCBMVar =<< reactiveValueRead
(liftR5 f2 layTempoRV layPitchRV strengthRV bpbRV layVolumeRV)
reactiveValueOnCanRead layerMCBMVar $ postGUIAsync $ do
nLayer <- reactiveValueRead layerMCBMVar
......@@ -129,11 +115,16 @@ layerSettings boardQueue = do
reactiveValueWriteOnNotEq bpbRV $ beatsPerBar nLayer
reactiveValueWriteOnNotEq layVolumeRV $ volume nLayer
syncRightOnLeftWithBoth (\nt ol -> ol { relTempo = nt }) layTempoRV layerMCBMVar
syncRightOnLeftWithBoth (\np ol -> ol { relPitch = np }) layPitchRV layerMCBMVar
syncRightOnLeftWithBoth (\ns ol -> ol { strength = ns }) strengthRV layerMCBMVar
syncRightOnLeftWithBoth (\nb ol -> ol { beatsPerBar = nb}) bpbRV layerMCBMVar
syncRightOnLeftWithBoth (\nv ol -> ol { volume = nv }) layVolumeRV layerMCBMVar
syncRightOnLeftWithBoth (\nt ol -> ol { relTempo = nt })
layTempoRV layerMCBMVar
syncRightOnLeftWithBoth (\np ol -> ol { relPitch = np })
layPitchRV layerMCBMVar
syncRightOnLeftWithBoth (\ns ol -> ol { strength = ns })
strengthRV layerMCBMVar
syncRightOnLeftWithBoth (\nb ol -> ol { beatsPerBar = nb})
bpbRV layerMCBMVar
syncRightOnLeftWithBoth (\nv ol -> ol { volume = nv })
layVolumeRV layerMCBMVar
{-
reactiveValueOnCanRead layVolumeRV $ do
......
......@@ -30,7 +30,7 @@ createNotebook :: ( ReactiveValueRead addLayer () IO
-> MCBMVar GUICell
-> IO ( Notebook
, ReactiveFieldRead IO (M.IntMap Board)
, ReactiveFieldReadWrite IO (M.IntMap Layer)
, ReactiveFieldRead IO (M.IntMap Layer)
, ReactiveFieldRead IO
(M.IntMap (ReactiveFieldWrite IO [PlayHead]))
)
......@@ -226,4 +226,4 @@ createNotebook addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
chanMap <- reactiveValueRead chanMapRV
mapM (reactiveValueRead . \(b,_,_) -> b) chanMap
return (n, boardMapRV, layerMapRV, phMapRV)
return (n, boardMapRV, readOnly layerMapRV, phMapRV)
......@@ -206,46 +206,6 @@ noteSettingsBox = do
getNAttr (cellAction nCell))
updateNaBox nCell
{-
state <- newEmptyMVar
boardOnPress board
(\iPos -> liftIO $ do
postGUIAsync $ void $ tryPutMVar state iPos
return True
)
boardOnRelease board
(\fPos -> do
button <- eventButton
liftIO $
postGUIAsync $ do
mp <- boardGetPiece fPos board
mstate <- tryTakeMVar state
when (fPos `elem` validArea && isJust mp) $ do
let piece = snd $ fromJust mp
when (button == RightButton && maybe False (== fPos) mstate) $
boardSetPiece fPos (BF.second rotateGUICell (Player,piece)) board
nmp <- boardGetPiece fPos board
when (button == LeftButton && isJust nmp) $ do
let nC = snd $ fromJust nmp
reactiveValueWrite setRV (fPos,nC)
fromMaybeM_ $ reactiveValueWrite artComboRV . naArt <$>
getNAttr (cellAction nC)
fromMaybeM_ $
reactiveValueWrite slideComboRV . ornSlide . naOrn <$> getNAttr (cellAction nC)
reactiveValueWrite rCountRV $ repeatCount nC
fromMaybeM_ $ reactiveValueWrite noteDurRV . naDur <$>
getNAttr (cellAction nC)
return True
)
reactiveValueOnCanRead setRV (reactiveValueRead setRV >>= updateNaBox . snd)
widgetShow pieceBox
widgetShow naBox
-}
--setMCBMVar <- newMCBMVar =<< reactiveValueRead setRV
--setMCBMVar =:= setRV
widgetShow pieceBox
widgetShow naBox
return (pieceBox,setRV)
......@@ -8,18 +8,6 @@ import FRP.Yampa
import RMCA.Auxiliary
import RMCA.Semantics
{-
-- The initial value is arbitrary but never appears because the switch
-- is immediate.
metronome :: SF Tempo (Event Beat)
metronome = switch (repeatedly (tempoToQNoteIvl 120) ()
&&&
onChange') metronome'
where metronome' :: Tempo -> SF Tempo (Event Beat)
metronome' t = switch (repeatedly (tempoToQNoteIvl t) ()
&&&
onChange) metronome'
-}
metronome :: SF Tempo (Event Beat)
metronome = repeatedlyS () <<^ tempoToQNoteIvl
......
......@@ -21,11 +21,14 @@ singleBoard iPh = proc (board, Layer { relPitch = rp
accumBy advanceHeads' (iPh,[]) -< ebno `tag` (board, fromEvent ebno, rp, s)
where advanceHeads' (ph,_) (board,bno,rp,s) = uncurry5 advanceHeads (board,bno,rp,s,ph)
boardSF :: SF (Board, Layer, Tempo, BoardRun) (Event ([PlayHead], [Note]))
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)
ess <- onChange -< br
boardSwitch [] -< ((board, l, ebno), ess `tag` (br, startHeads board))
ephn <- boardSwitch [] -< ((board, l, ebno), ess `tag` (br, startHeads board))
returnA -< fmap (second (zip (repeat lt))) ephn
boardSwitch :: [PlayHead]
-> SF ((Board, Layer,Event BeatNo), Event (BoardRun, [PlayHead]))
......@@ -54,9 +57,9 @@ lengthChange iSig = edgeBy diffSig ik <<^ M.keys <<^ fst
| otherwise = Just (oL \\ nL, nL \\ oL)
boardRun' :: M.IntMap (SF (Board,Layer,Tempo,BoardRun)
(Event ([PlayHead],[Note])))
(Event ([PlayHead],[(LTempo,Note)])))
-> SF (M.IntMap (Board,Layer,Tempo,BoardRun))
(M.IntMap (Event ([PlayHead],[Note])))
(M.IntMap (Event ([PlayHead],[(LTempo,Note)])))
boardRun' iSF = boardRun'' iSF (lengthChange iSF)
where boardRun'' iSF swSF = pSwitch routeBoard iSF swSF contSwitch
contSwitch contSig (oldSig, newSig) = boardRun'' newSF
......@@ -66,5 +69,5 @@ boardRun' iSF = boardRun'' iSF (lengthChange iSF)
boardRun :: M.IntMap (Board,Layer,Tempo,BoardRun)
-> SF (M.IntMap (Board,Layer,Tempo,BoardRun))
(M.IntMap (Event ([PlayHead],[Note])))
(M.IntMap (Event ([PlayHead],[(LTempo,Note)])))
boardRun iSig = boardRun' (iSig $> boardSF)
......@@ -93,8 +93,7 @@ main = do
noteMap = M.map (eventToList . snd . splitE) out
sequence_ $ M.mapWithKey writePh $
M.map (fst . fromEvent) $ M.filter isEvent out
--reactiveValueAppend boardQueue $ M.map (,[]) noteMap
reactiveValueAppend boardQueue $ M.map (,[]) noteMap
{-
......@@ -105,7 +104,7 @@ main = do
-- supposedly is no guaranty of order but apparently there is…
putStrLn "Board started."
-- Jack setup
--forkIO $ jackSetup tempoRV boardQueue
forkIO $ jackSetup boardQueue
widgetShowAll window
------------------------------------------------------------
......
-- Contains function for scheduling and filtering events given the
-- correct informations.
module RMCA.Translator.Filter where
import Data.Bifunctor as BF
import Data.List (sortBy)
import Data.Ord
import RMCA.Translator.Message
-- 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
-- arguments are kept in the case where two would come into
-- contact. On the left are the events that can be thrown into the
-- buffer, on the right are the events that will need to wait. Both
-- list are sorted.
--
-- /!\ The frame number is relative. A preprocessing operation
-- removing all events too soon to be happening and shifting them is
-- necessary.
schedule :: Frames
-> [(Frames, a)]
-> ([(Frames,a)], [(Frames,a)])
schedule size = BF.first scatterEvents
. break ((>= size) . fst) . sortBy (comparing fst)
-- When to events are at the same frame, shift them so that they are
-- all separated by one frame. Then take every list and make sure that
-- the first frame of the next list is at least one frame after the
-- last frame of that list.
scatterEvents :: [(Frames, a)] -> [(Frames, a)]
scatterEvents (x@(n,_):(m,b):xs) = x:scatterEvents ((m',b):xs)
where m' = m + max 0 (1 + n - m)
scatterEvents [x] = [x]
scatterEvents _ = []
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
-- Contains all the information and functions necessary to run a Jack
-- port and exchange information through reactive values and Yampa.
......@@ -9,18 +9,22 @@ 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.Filter
import RMCA.Translator.Message
import RMCA.Translator.RV
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"
......@@ -32,88 +36,50 @@ outPortName = "output"
-- Starts a default client with an input and an output port. Doesn't
-- do anything as such.
jackSetup :: ( ReactiveValueRead tempo LTempo IO
, ReactiveValueRead channel Int IO
, ReactiveValueReadWrite board ([Note],[Message]) IO) =>
tempo
-> channel
-> board
jackSetup :: (ReactiveValueReadWrite board
(M.IntMap ([(LTempo,Note)],[Message])) IO) =>
board
-> IO ()
jackSetup tempoRV chanRV boardInRV = Jack.handleExceptions $ do
toProcessRV <- Trans.lift $ toProcess <$> newCBMVar []
jackSetup boardQueue = 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 tempoRV chanRV boardInRV) $
toProcessRV boardQueue) $
Jack.withActivation client $ Trans.lift $ do
putStrLn $ "Started " ++ rmcaName ++ " JACK client."
Jack.waitForBreak
{-
-- Loop that does nothing except setting up a callback function
-- (called when Jack is ready to take new inputs).
jackRun :: (JExc.ThrowsErrno e) =>
Jack.Client
-> (Jack.NFrames -> Sync.ExceptionalT E.Errno IO ())
-> Sync.ExceptionalT e IO ()
jackRun client callback =
Jack.withProcess client callback $ do
Trans.lift $ putStrLn $ "Startedbbb " ++ rmcaName
Trans.lift $ Jack.waitForBreak
-}
defaultTempo :: Tempo
defaultTempo = 96
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
, ReactiveValueRead tempo LTempo IO
, ReactiveValueRead channel Int IO
, ReactiveValueReadWrite board ([Note],[Message]) IO) =>
, ReactiveValueReadWrite board
(M.IntMap ([(LTempo,Note)],[Message])) IO) =>
Jack.Client
-> JMIDI.Port Jack.Input
-> JMIDI.Port Jack.Output
-> toProcess
-> tempo
-> channel
-> board
-> Jack.NFrames
-> Sync.ExceptionalT E.Errno IO ()
jackCallBack client input output toProcessRV tempoRV chanRV outBoard
nframes@(Jack.NFrames nframesInt') = do
jackCallBack client input output toProcessRV boardQueue nframes@(Jack.NFrames nframesInt') = do
let inMIDIRV = inMIDIEvent input nframes
outMIDIRV = outMIDIEvent output nframes
nframesInt = fromIntegral nframesInt' :: Int
-- This gets the sample rate of the client and the last frame number
-- it processed. We then use it to calculate the current absolute time
sr <- Trans.lift $ Jack.getSampleRate client
--(Jack.NFrames lframeInt) <- Trans.lift $ Jack.lastFrameTime client
--Trans.lift (reactiveValueRead inMIDIRV >>= (print . map (fst)))
-- We write the content of the input buffer to the input of a
-- translation signal function.
-- /!\ Should maybe be moved elsewhere
(inRaw, outPure) <- Trans.lift $ yampaReactiveDual [] readMessages
Trans.lift (inMIDIRV =:> inRaw)
tempo <- Trans.lift $ reactiveValueRead tempoRV
chan <- Trans.lift $ reactiveValueRead chanRV
(notes,ctrl) <- Trans.lift $ reactiveValueRead outBoard
Trans.lift $ emptyRW outBoard
let boardIn = (zip (repeat 0) notes, zip (repeat 0) ctrl, [])
outMIDI <- Trans.lift $ reactiveValueRead outPure
-- We translate all signals to be sent into low level signals and
-- write them to the output buffer.
(inPure, outRaw) <- Trans.lift $ yampaReactiveDual
(defaultTempo, sr, chan, ([],[],[])) gatherMessages
-- This should all go in its own IO action
Trans.lift $ do
reactiveValueWrite inPure (tempo, sr, chan, boardIn `mappend` outMIDI)
reactiveValueRead outRaw >>= reactiveValueAppend toProcessRV
--map fst <$> reactiveValueRead toProcessRV >>= print . ("toProcess " ++) . show
concat . toList . gatherMessages nframesInt <$>
reactiveValueRead boardQueue >>=
reactiveValueAppend toProcessRV
reactiveValueEmpty boardQueue
(go, old') <- schedule nframesInt <$> reactiveValueRead toProcessRV
let old = map (BF.first (+ (- nframesInt))) old'
print $ map fst go
reactiveValueWrite outMIDIRV go
reactiveValueWrite toProcessRV old
--------------
{-# LANGUAGE Arrows #-}
module RMCA.Translator.Note where
import Data.Ratio
import FRP.Yampa
import RMCA.Global.Clock
import RMCA.Semantics
import RMCA.Translator.Message
messageToNote :: Message -> Note
messageToNote (NoteOn _ p s) = Note { notePch = p
, noteStr = s
, noteDur = 1 % 4
, noteOrn = noOrn
}
messageToNote m = error $ "In messageToNote: the message "
++ show m ++ " is not a note message"
-- noteToMessage gives a pair of two time-stamped messages. The one on
-- the left is a note message, the other a note off.
noteToMessages :: LTempo
-> SampleRate
-> Int -- Channel number
-> (Frames,Note) -- Note to convert
-> [(Frames,Message)]
noteToMessages layTempo sr chan =
proc (t,n@Note { noteDur = d }) -> do
nm <- noteOnToMessage chan -< n
let dt :: Double
dt = fromRational (d * toRational (tempoToQNoteIvl layTempo))
dn :: Int
dn = floor $ dt * fromIntegral sr
returnA -< [(t,nm),(t + dn,switchOnOff nm)]
noteOnToMessage :: Int -> Note -> Message
noteOnToMessage c Note { notePch = p
, noteStr = s
} = NoteOn (mkChannel c) p s
......@@ -52,13 +52,3 @@ outMIDIEvent output nframes@(Jack.NFrames nframesInt') =
map (BF.first (Jack.NFrames . fromIntegral)) .
takeWhile ((< nframesInt) . fst) . L.sortBy (comparing fst)
nframesInt = fromIntegral nframesInt'
toProcess :: CBMVar [(Frames, RawMessage)]
-> ReactiveFieldReadWrite IO [(Frames, RawMessage)]
toProcess mvar = ReactiveFieldReadWrite setter getter notifier
where setter :: [(Frames, RawMessage)] -> IO ()
setter = writeCBMVar mvar
getter :: IO [(Frames, RawMessage)]
getter = readCBMVar mvar
notifier :: IO () -> IO ()
notifier = installCallbackCBMVar mvar
-- The idea is that the stream of data coming from the MIDI input port
-- will be sorted in three categories: note on events, controller
-- events and other events. The latter will be transmitted as is
-- through the whole systems.
module RMCA.Translator.SortMessage where
import qualified Data.Bifunctor as BF
import Data.Function (on)
import Data.List (groupBy)
import Data.Maybe
import RMCA.Semantics
import RMCA.Translator.Message
import RMCA.Translator.Note
sortRawMessages :: [(Frames, RawMessage)]
-> ([(Frames,Message)], [(Frames,RawMessage)])
sortRawMessages = sortRawMessages' ([],[])
where sortRawMessages' r [] = r
sortRawMessages' (m, rm) (x@(n,xm):xs)
| isNothing nm = sortRawMessages' (m, x:rm) xs
| otherwise = sortRawMessages' ((n,fromJust nm) :m, rm) xs
where nm = fromRawMessage xm
-- Direct each message to a specific channel.
-- /!\ To be modified.
sortChannel :: [Message] -> [(Int,[Message])]
sortChannel = map ((,) <$> (fst . head) <*> map snd)
. groupBy ((==) `on` fst) . map sortChannel'
where sortChannel' :: Message -> (Int, Message)
sortChannel' m = let c = getChannel m in (c,m)
-- NoteOn messages are on the right, other Control messages are on the
-- left. For now we throw away NoteOff messages.
sortNotes :: [(Frames, Message)]
-> ([(Frames,Message)], [(Frames,Message)])
sortNotes = sortNotes' ([],[])
where sortNotes' r [] = r
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
| otherwise = sortNotes' (n,c) xs
-- Note messages are converted to PlayHeads
convertMessages :: [(Frames,Message)] -> [(Frames,Note)]
convertMessages = map (BF.second messageToNote)
{-# LANGUAGE Arrows #-}
module RMCA.Translator.Translator ( readMessages
, gatherMessages
) where
module RMCA.Translator.Translator where
import qualified Data.Bifunctor as BF
import Control.Arrow
import Data.Function (on)
import qualified Data.IntMap as M
import Data.List (groupBy, sortBy)
import Data.Maybe
import Data.Ord
import Data.Ratio
import FRP.Yampa
import RMCA.Auxiliary
import RMCA.Global.Clock
import RMCA.Semantics
import RMCA.Translator.Message
import RMCA.Translator.Note
import RMCA.Translator.SortMessage
messageToNote :: Message -> Note
messageToNote (NoteOn _ p s) = Note { notePch = p
, noteStr = s
, noteDur = 1 % 4
, noteOrn = noOrn
}
messageToNote m = error $ "In messageToNote: the message "
++ show m ++ " is not a note message"
-- noteToMessage gives a pair of two time-stamped messages. The one on
-- the left is a note message, the other a note off.
noteToMessages :: SampleRate
-> Int -- channel number
-> LTempo
-> (Frames,Note)
-> [(Frames,Message)]
noteToMessages sr chan lt (t,n@Note { noteDur = d }) =
[(t,nm),(t + dn,switchOnOff nm)]
where nm = noteOnToMessage chan n
dt :: Double
dt = fromRational (d * toRational (tempoToQNoteIvl lt))
dn = floor $ dt * fromIntegral sr
noteOnToMessage :: Int -> Note -> Message
noteOnToMessage c Note { notePch = p
, noteStr = s
} = NoteOn (mkChannel c) p s
sortRawMessages :: [(Frames, RawMessage)]
-> ([(Frames,Message)], [(Frames,RawMessage)])
sortRawMessages = sortRawMessages' ([],[])
where sortRawMessages' r [] = r
sortRawMessages' (m, rm) (x@(n,xm):xs)
| isNothing nm = sortRawMessages' (m, x:rm) xs
| otherwise = sortRawMessages' ((n,fromJust nm) :m, rm) xs
where nm = fromRawMessage xm
-- Direct each message to a specific channel.
-- /!\ To be modified.
sortChannel :: [Message] -> [(Int,[Message])]
sortChannel = map ((,) <$> (fst . head) <*> map snd)
. groupBy ((==) `on` fst) . map sortChannel'
where sortChannel' :: Message -> (Int, Message)
sortChannel' m = let c = getChannel m in (c,m)
-- NoteOn messages are on the right, other Control messages are on the
-- left. For now we throw away NoteOff messages.
sortNotes :: [(Frames, Message)]
-> ([(Frames,Message)], [(Frames,Message)])
sortNotes = sortNotes' ([],[])
where sortNotes' r [] = r
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
| otherwise = sortNotes' (n,c) xs
-- Note messages are converted to PlayHeads
convertMessages :: [(Frames,Message)] -> [(Frames,Note)]
convertMessages = map (second messageToNote)
-- Uses function defined in SortMessage. This is a pure function and
-- it might not need to be a signal function.
......@@ -18,13 +82,13 @@ readMessages' :: [(Frames,RawMessage)]
-> ([(Frames,Note)], [(Frames,Message)], [(Frames,RawMessage)])
readMessages' = proc r -> do
(mes, raw) <- sortRawMessages -< r
(notes, ctrl) <- BF.first convertMessages <<< sortNotes -< mes
(notes, ctrl) <- first convertMessages <<< sortNotes -< mes
returnA -< (notes, ctrl, raw)
readMessages :: SF [(Frames, RawMessage)]
([(Frames,Note)], [(Frames,Message)], [(Frames,RawMessage)])
([(Frames,Note)], [(Frames,Message)], [(Frames,RawMessage)])
readMessages = arr readMessages'
{-