From e3af38f50be45190e76e371a197e561f5d50646a Mon Sep 17 00:00:00 2001
From: Guerric Chupin <guerric.chupin@gmail.com>
Date: Wed, 13 Jul 2016 15:52:31 +0100
Subject: [PATCH] Instrument change enabled.
---
src/RMCA/Auxiliary/RV.hs | 34 +++-------
src/RMCA/GUI/LayerSettings.hs | 94 +++++++++++++++++++++++++++
src/RMCA/GUI/NoteSettings.hs | 11 ++--
src/RMCA/Main.hs | 100 ++++-------------------------
src/RMCA/Translator/Controller.hs | 11 ----
src/RMCA/Translator/Jack.hs | 13 ++--
src/RMCA/Translator/Message.hs | 15 ++++-
src/RMCA/Translator/Note.hs | 2 +-
src/RMCA/Translator/SortMessage.hs | 15 ++---
src/RMCA/Translator/Translator.hs | 14 ++--
10 files changed, 149 insertions(+), 160 deletions(-)
create mode 100644 src/RMCA/GUI/LayerSettings.hs
delete mode 100644 src/RMCA/Translator/Controller.hs
diff --git a/src/RMCA/Auxiliary/RV.hs b/src/RMCA/Auxiliary/RV.hs
index b97cabe..01e5c22 100644
--- a/src/RMCA/Auxiliary/RV.hs
+++ b/src/RMCA/Auxiliary/RV.hs
@@ -12,11 +12,11 @@ leftSyncWith :: (ReactiveValueRead a b m, ReactiveValueWrite c d m) =>
(b -> d) -> a -> c -> m ()
leftSyncWith f a c = reactiveValueOnCanRead a
(reactiveValueRead a >>= reactiveValueWrite c . f)
-
+{-
(=:$:>) :: (ReactiveValueRead a b m, ReactiveValueWrite c d m) =>
(b -> d) -> a -> c -> m ()
(=:$:>) = leftSyncWith
-
+-}
newCBMVarRW :: forall a. a -> IO (ReactiveFieldReadWrite IO a)
newCBMVarRW val = do
mvar <- newCBMVar val
@@ -37,6 +37,11 @@ emptyRW rv = do
emptyW :: (Monoid b, ReactiveValueWrite a b m) => a -> m ()
emptyW rv = reactiveValueWrite rv mempty
+reactiveValueAppend :: (Monoid b, ReactiveValueReadWrite a b m) =>
+ a -> b -> m ()
+reactiveValueAppend rv v = do ov <- reactiveValueRead rv
+ reactiveValueWrite rv (ov `mappend` v)
+
onTick :: (ReactiveValueRead a b m, ReactiveValueRead c d m) =>
a -> c -> ReactiveFieldRead m d
onTick notif rv = ReactiveFieldRead getter notifier
@@ -51,10 +56,7 @@ addHandlerR :: (ReactiveValueRead a b m) =>
-> ReactiveFieldRead m b
addHandlerR x h = ReactiveFieldRead (reactiveValueRead x)
(\p -> reactiveValueOnCanRead x p >> h p)
-{-
-notif ^:> rv =
- reactiveValueOnCanRead notif (reactiveValueOnCanRead rv (return ()))
--}
+
-- 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) =>
@@ -63,26 +65,6 @@ eventRV >:> rv = reactiveValueOnCanRead eventRV syncOnEvent
where syncOnEvent = do
erv <- reactiveValueRead eventRV
when (isEvent erv) $ reactiveValueWrite rv $ fromEvent erv
-{-
-liftR3 :: ( Monad m
- , ReactiveValueRead a b m
- , ReactiveValueRead c d m
- , ReactiveValueRead e f m) =>
- ((b,d,f) -> i)
- -> a
- -> c
- -> e
- -> ReactiveFieldRead m i
-liftR3 f a b c = ReactiveFieldRead getter notifier
- where getter = do
- x1 <- reactiveValueRead a
- x2 <- reactiveValueRead b
- x3 <- reactiveValueRead c
- return $ f (x1, x2, x3)
- notifier p = reactiveValueOnCanRead a p >>
- reactiveValueOnCanRead b p >>
- reactiveValueOnCanRead c p
--}
liftW3 :: ( Monad m
, ReactiveValueWrite a b m
diff --git a/src/RMCA/GUI/LayerSettings.hs b/src/RMCA/GUI/LayerSettings.hs
new file mode 100644
index 0000000..1dc837e
--- /dev/null
+++ b/src/RMCA/GUI/LayerSettings.hs
@@ -0,0 +1,94 @@
+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TupleSections #-}
+
+module RMCA.GUI.LayerSettings where
+
+import Data.ReactiveValue
+import Data.String
+import Data.Tuple
+import Graphics.UI.Gtk
+import Graphics.UI.Gtk.Reactive
+import RMCA.Auxiliary.RV
+import RMCA.GUI.NoteSettings
+import RMCA.Layer.Layer
+import RMCA.Semantics
+import RMCA.Translator.Instruments
+import RMCA.Translator.Message
+
+floatConv :: (ReactiveValueReadWrite a b m,
+ Real c, Real b, Fractional c, Fractional b) =>
+ a -> ReactiveFieldReadWrite m c
+floatConv = liftRW $ bijection (realToFrac, realToFrac)
+
+layerSettings :: ( ReactiveValueReadWrite board ([Note],[Message]) IO
+ , ReactiveValueRead chan Int IO) =>
+ chan -> board -> IO (VBox, ReactiveFieldReadWrite IO Layer)
+layerSettings chanRV boardQueue = do
+ layerSettingsVBox <- vBoxNew True 10
+ layerSettingsBox <- hBoxNew True 10
+ boxPackStart layerSettingsVBox layerSettingsBox PackNatural 0
+
+ layTempoBox <- hBoxNew False 10
+ boxPackStart layerSettingsBox layTempoBox PackNatural 0
+ layTempoLabel <- labelNew (Just "Layer tempo")
+ labelSetAngle layTempoLabel 90
+ boxPackStart layTempoBox layTempoLabel PackNatural 0
+ layTempoAdj <- adjustmentNew 1 0 2 1 1 1
+ layTempoScale <- vScaleNew layTempoAdj
+ boxPackStart layTempoBox layTempoScale PackNatural 0
+
+ strBox <- hBoxNew False 10
+ boxPackStart layerSettingsBox strBox PackNatural 0
+ strLabel <- labelNew (Just "Strength")
+ labelSetAngle strLabel 90
+ boxPackStart strBox strLabel PackNatural 0
+ strAdj <- adjustmentNew 1 0 1 0.01 0.01 0
+ layStrengthScale <- vScaleNew strAdj
+ boxPackStart strBox layStrengthScale PackNatural 0
+
+ bpbBox <- vBoxNew False 10
+ 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
+
+ instrumentCombo <- comboBoxNewText
+ instrumentIndex <- mapM (\(ind,ins) ->
+ do i <- comboBoxAppendText instrumentCombo $
+ fromString ins
+ return (i, ind)) instrumentList
+ comboBoxSetActive instrumentCombo 0
+ boxPackStart layerSettingsVBox instrumentCombo PackNatural 10
+ let indexToInstr i = case (lookup i instrumentIndex) of
+ Nothing -> error "Can't get the selected instrument."
+ Just x -> x
+ instrToIndex ins = case (lookup ins $ map swap instrumentIndex) of
+ Nothing -> error "Can't retrieve the index for the instrument."
+ Just x -> x
+ instrumentComboRV = bijection (indexToInstr, instrToIndex) `liftRW`
+ comboBoxIndexRV instrumentCombo
+
+ reactiveValueOnCanRead instrumentComboRV $ do
+ ins <- reactiveValueRead instrumentComboRV
+ chan <- reactiveValueRead chanRV
+ reactiveValueAppend boardQueue ([],[Instrument (mkChannel chan) (mkProgram ins)])
+
+ layPitchRV <- newCBMVarRW 1
+ let layTempoRV = floatConv $ scaleValueReactive layTempoScale
+ strengthRV = floatConv $ scaleValueReactive layStrengthScale
+ bpbRV = spinButtonValueIntReactive bpbButton
+ f1 Layer { relTempo = d
+ , relPitch = p
+ , strength = s
+ , beatsPerBar = bpb
+ } = (d,p,s,bpb)
+ f2 (d,p,s,bpb) = Layer { relTempo = d
+ , relPitch = p
+ , strength = s
+ , beatsPerBar = bpb
+ }
+ layerRV =
+ liftRW4 (bijection (f1,f2)) layTempoRV layPitchRV strengthRV bpbRV
+ return (layerSettingsVBox, layerRV)
diff --git a/src/RMCA/GUI/NoteSettings.hs b/src/RMCA/GUI/NoteSettings.hs
index 854d1ac..6bfea8c 100644
--- a/src/RMCA/GUI/NoteSettings.hs
+++ b/src/RMCA/GUI/NoteSettings.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE ScopedTypeVariables, TupleSections #-}
+{-# LANGUAGE ScopedTypeVariables, TupleSections, FlexibleContexts #-}
module RMCA.GUI.NoteSettings where
@@ -60,7 +60,8 @@ comboBoxIndexRV box = ReactiveFieldReadWrite setter getter notifier
setter = comboBoxSetActive box
notifier = void . on box changed
-clickHandling :: Array Pos (ReactiveFieldWrite IO GUICell)
+clickHandling :: (ReactiveValueWrite cell GUICell IO) =>
+ Array Pos cell
-> IOBoard -> VBox -> IO VBox
clickHandling pieceArrRV board pieceBox = do
naBox <- vBoxNew False 10
@@ -74,11 +75,11 @@ clickHandling pieceArrRV board pieceBox = do
comboBoxSetActive artCombo 0
boxPackStart naBox artCombo PackNatural 10
let indexToArt i = case lookup i $ map swap artIndex of
- Nothing -> error "In indexToArt: failed\
+ Nothing -> error "In indexToArt: failed \
\to find the selected articulation."
Just art -> art
artToIndex a = case lookup a artIndex of
- Nothing -> error "In artToIndex: failed\
+ Nothing -> error "In artToIndex: failed \
\to find the correct index for the articulation."
Just i -> i
artComboRV = bijection (indexToArt,artToIndex) `liftRW`
@@ -126,7 +127,7 @@ clickHandling pieceArrRV board pieceBox = do
boxPackStart noteDurBox noteDurLabel PackNatural 10
-- Repeat count box
- rCountAdj <- adjustmentNew 1 0 10 1 1 0
+ rCountAdj <- adjustmentNew 1 0 100 1 1 0
rCount <- spinButtonNew rCountAdj 1 0
boxPackStart pieceBox rCount PackNatural 10
let rCountRV = spinButtonValueIntReactive rCount
diff --git a/src/RMCA/Main.hs b/src/RMCA/Main.hs
index fe0c52d..0d7cf59 100644
--- a/src/RMCA/Main.hs
+++ b/src/RMCA/Main.hs
@@ -1,33 +1,24 @@
-{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-}
+{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, TupleSections #-}
module Main where
import Control.Concurrent
import Data.ReactiveValue
-import Data.String
-import Data.Tuple
import FRP.Yampa
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Board.BoardLink
import Graphics.UI.Gtk.Layout.BackgroundContainer
-import Graphics.UI.Gtk.Reactive
import Hails.Yampa
import RMCA.Auxiliary.RV
import RMCA.GUI.Board
import RMCA.GUI.Buttons
+import RMCA.GUI.LayerSettings
import RMCA.GUI.MainSettings
import RMCA.GUI.NoteSettings
import RMCA.Layer.Board
-import RMCA.Layer.Layer
import RMCA.Semantics
-import RMCA.Translator.Instruments
import RMCA.Translator.Jack
-floatConv :: (ReactiveValueReadWrite a b m,
- Real c, Real b, Fractional c, Fractional b) =>
- a -> ReactiveFieldReadWrite m c
-floatConv = liftRW $ bijection (realToFrac, realToFrac)
-
main :: IO ()
main = do
-- GUI
@@ -41,6 +32,9 @@ main = do
]
windowMaximize window
+ boardQueue <- newCBMVarRW mempty
+ chanRV <- newCBMVarRW 0
+
settingsBox <- vBoxNew False 0
boxPackEnd mainBox settingsBox PackNatural 0
(globalSettingsBox, tempoRV) <- globalSettings
@@ -48,81 +42,11 @@ main = do
globalSep <- hSeparatorNew
boxPackStart settingsBox globalSep PackNatural 0
- layerSettingsVBox <- vBoxNew True 10
+ (layerSettingsVBox, layerRV) <- layerSettings chanRV boardQueue
boxPackStart settingsBox layerSettingsVBox PackNatural 0
- layerSettingsBox <- hBoxNew True 10
- boxPackStart layerSettingsVBox layerSettingsBox PackNatural 0
-
- layTempoBox <- hBoxNew False 10
- boxPackStart layerSettingsBox layTempoBox PackNatural 0
- layTempoLabel <- labelNew (Just "Layer tempo")
- labelSetAngle layTempoLabel 90
- boxPackStart layTempoBox layTempoLabel PackNatural 0
- layTempoAdj <- adjustmentNew 1 0 2 1 1 1
- layTempoScale <- vScaleNew layTempoAdj
- boxPackStart layTempoBox layTempoScale PackNatural 0
laySep <- hSeparatorNew
-
- strBox <- hBoxNew False 10
- boxPackStart layerSettingsBox strBox PackNatural 0
- strLabel <- labelNew (Just "Strength")
- labelSetAngle strLabel 90
- boxPackStart strBox strLabel PackNatural 0
- strAdj <- adjustmentNew 1 0 1 0.01 0.01 0
- layStrengthScale <- vScaleNew strAdj
- boxPackStart strBox layStrengthScale PackNatural 0
-
- bpbBox <- vBoxNew False 10
- 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
-
- instrumentCombo <- comboBoxNewText
- instrumentIndex <- mapM (\(ind,ins) ->
- do i <- comboBoxAppendText instrumentCombo $
- fromString ins
- return (i, ind)) instrumentList
- comboBoxSetActive instrumentCombo 0
- boxPackStart layerSettingsVBox instrumentCombo PackNatural 10
- let indexToInstr i = case (lookup i instrumentIndex) of
- Nothing -> error "Can't get the selected instrument."
- Just x -> x
- instrToIndex ins = case (lookup ins $ map swap instrumentIndex) of
- Nothing -> error "Can't retrieve the index for the instrument."
- Just x -> x
- instrumentComboRV = bijection (indexToInstr, instrToIndex) `liftRW`
- comboBoxIndexRV instrumentCombo
-{-
- reactiveValueOnCanRead instrumentComboRV $ do
- ins <- reactiveValueRead instrumentComboRV
- bq <- reactiveValueRead boardQueue
- let body = ProgramChange $ toProgram ins
-
- reactiveValueWrite boardQueue (bq ++
- -}
boxPackStart settingsBox laySep PackNatural 0
- layPitchRV <- newCBMVarRW 1
- let layTempoRV = floatConv $ scaleValueReactive layTempoScale
- strengthRV = floatConv $ scaleValueReactive layStrengthScale
- bpbRV = spinButtonValueIntReactive bpbButton
- f1 Layer { relTempo = d
- , relPitch = p
- , strength = s
- , beatsPerBar = bpb
- } = (d,p,s,bpb)
- f2 (d,p,s,bpb) = Layer { relTempo = d
- , relPitch = p
- , strength = s
- , beatsPerBar = bpb
- }
- layerRV =
- liftRW4 (bijection (f1,f2)) layTempoRV layPitchRV strengthRV bpbRV
-
(buttonBox, playRV, stopRV, pauseRV, recordRV) <- getButtons
boxPackEnd settingsBox buttonBox PackNatural 0
@@ -136,7 +60,6 @@ main = do
boxPackStart mainBox boardCont PackNatural 0
--boxPackStart mainBox boardCont PackNatural 0
------------------------------------------------------------------------------
- boardQueue <- newCBMVarRW []
-- Board setup
layer <- reactiveValueRead layerRV
tempo <- reactiveValueRead tempoRV
@@ -152,17 +75,16 @@ main = do
boardRV layerRV phRV tempoRV'
--let inRV = onTick clock inRV
inRV =:> inBoard
- reactiveValueOnCanRead outBoard $ do
- bq <- reactiveValueRead boardQueue
- ob <- reactiveValueRead $ liftR (event [] id <<< snd <<< splitE) outBoard
- reactiveValueWrite boardQueue (bq ++ ob)
+ reactiveValueOnCanRead outBoard $
+ reactiveValueRead (liftR (event mempty (,[]) <<< snd <<< splitE) outBoard) >>=
+ reactiveValueAppend boardQueue
-- This needs to be set last otherwise phRV is written to, so
-- inBoard is written to and the notes don't get played. There
-- supposedly is no guaranty of order but apparently there isâ¦
- (fst <$>) <^> outBoard >:> phRV
+ fmap fst <^> outBoard >:> phRV
putStrLn "Board started."
-- Jack setup
- forkIO $ jackSetup tempoRV (constR 0) boardQueue
+ forkIO $ jackSetup tempoRV chanRV boardQueue
widgetShowAll window
pieceBox <- clickHandling pieceArrRV guiBoard =<< vBoxNew False 10
-- Piece characteristic
diff --git a/src/RMCA/Translator/Controller.hs b/src/RMCA/Translator/Controller.hs
deleted file mode 100644
index 20605e3..0000000
--- a/src/RMCA/Translator/Controller.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module RMCA.Translator.Controller where
-
-import RMCA.Translator.Message
-
-data Controller = Lol
-
-messageToController :: Message -> Controller
-messageToController _ = Lol
-
-controllerToMessages :: Controller -> Message
-controllerToMessages = undefined
diff --git a/src/RMCA/Translator/Jack.hs b/src/RMCA/Translator/Jack.hs
index a8a4138..4114152 100644
--- a/src/RMCA/Translator/Jack.hs
+++ b/src/RMCA/Translator/Jack.hs
@@ -5,7 +5,6 @@
module RMCA.Translator.Jack ( jackSetup
) where
-import Control.Applicative ((<**>))
import qualified Control.Monad.Exception.Synchronous as Sync
import qualified Control.Monad.Trans.Class as Trans
import qualified Data.Bifunctor as BF
@@ -35,7 +34,7 @@ outPortName = "output"
-- do anything as such.
jackSetup :: ( ReactiveValueRead tempo LTempo IO
, ReactiveValueRead channel Int IO
- , ReactiveValueReadWrite board [Note] IO) =>
+ , ReactiveValueReadWrite board ([Note],[Message]) IO) =>
tempo
-> channel
-> board
@@ -73,7 +72,7 @@ defaultTempo = 96
jackCallBack :: ( ReactiveValueReadWrite toProcess [(Frames, RawMessage)] IO
, ReactiveValueRead tempo LTempo IO
, ReactiveValueRead channel Int IO
- , ReactiveValueReadWrite board [Note] IO) =>
+ , ReactiveValueReadWrite board ([Note],[Message]) IO) =>
Jack.Client
-> JMIDI.Port Jack.Input
-> JMIDI.Port Jack.Output
@@ -100,9 +99,9 @@ jackCallBack client input output toProcessRV tempoRV chanRV outBoard
Trans.lift (inMIDIRV =:> inRaw)
tempo <- Trans.lift $ reactiveValueRead tempoRV
chan <- Trans.lift $ reactiveValueRead chanRV
- boardIn' <- Trans.lift $ reactiveValueRead outBoard
+ (notes,ctrl) <- Trans.lift $ reactiveValueRead outBoard
Trans.lift $ emptyRW outBoard
- let boardIn = (zip (repeat 0) boardIn',[],[])
+ 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.
@@ -111,9 +110,7 @@ jackCallBack client input output toProcessRV tempoRV chanRV outBoard
-- This should all go in its own IO action
Trans.lift $ do
reactiveValueWrite inPure (tempo, sr, chan, boardIn `mappend` outMIDI)
- reactiveValueRead outRaw <**>
- (mappend <$> reactiveValueRead toProcessRV) >>=
- reactiveValueWrite toProcessRV
+ reactiveValueRead outRaw >>= reactiveValueAppend toProcessRV
--map fst <$> reactiveValueRead toProcessRV >>= print . ("toProcess " ++) . show
(go, old') <- schedule nframesInt <$> reactiveValueRead toProcessRV
let old = map (BF.first (+ (- nframesInt))) old'
diff --git a/src/RMCA/Translator/Message.hs b/src/RMCA/Translator/Message.hs
index 3462fbe..cd92458 100644
--- a/src/RMCA/Translator/Message.hs
+++ b/src/RMCA/Translator/Message.hs
@@ -25,6 +25,7 @@ type Frames = Int
-- /!\ This is dangerous as it only treats unipolar control values.
data Message = NoteOn Channel Pitch Strength
| NoteOff Channel Pitch Strength
+ | Instrument Channel Voice.Program
| Control Channel ControllerIdx UCtrl
deriving(Show)
@@ -32,9 +33,13 @@ getChannel :: Message -> Int
getChannel (NoteOn c _ _) = Channel.fromChannel c
getChannel (NoteOff c _ _) = Channel.fromChannel c
getChannel (Control c _ _) = Channel.fromChannel c
+getChannel (Instrument c _ ) = Channel.fromChannel c
-makeChannel :: Int -> Channel
-makeChannel = Channel.toChannel
+mkChannel :: Int -> Channel
+mkChannel = Channel.toChannel
+
+mkProgram :: Int -> Channel.Program
+mkProgram = Channel.toProgram
-- Function to go back and forth with the representations of pitches,
-- as they are different in our model and in the Jack API model.
@@ -72,6 +77,9 @@ fromRawMessage (Message.Channel (Channel.Cons c
fromRawMessage (Message.Channel (Channel.Cons c
(Channel.Voice (Voice.Control n v)))) =
Just $ Control c n (toUCtrl v)
+fromRawMessage (Message.Channel (Channel.Cons c
+ (Channel.Voice (Voice.ProgramChange p)))) =
+ Just $ Instrument c p
fromRawMessage _ = Nothing
toRawMessage :: Message -> RawMessage
@@ -84,3 +92,6 @@ toRawMessage (NoteOff c p v) =
toRawMessage (Control c n v) =
Message.Channel (Channel.Cons c
(Channel.Voice (Voice.Control n (fromUCtrl v))))
+toRawMessage (Instrument c p) =
+ Message.Channel (Channel.Cons c
+ (Channel.Voice (Voice.ProgramChange p)))
diff --git a/src/RMCA/Translator/Note.hs b/src/RMCA/Translator/Note.hs
index f3865c3..306b4d2 100644
--- a/src/RMCA/Translator/Note.hs
+++ b/src/RMCA/Translator/Note.hs
@@ -36,4 +36,4 @@ noteToMessages layTempo sr chan =
noteOnToMessage :: Int -> Note -> Message
noteOnToMessage c Note { notePch = p
, noteStr = s
- } = NoteOn (makeChannel c) p s
+ } = NoteOn (mkChannel c) p s
diff --git a/src/RMCA/Translator/SortMessage.hs b/src/RMCA/Translator/SortMessage.hs
index 57f1c8d..26ba60f 100644
--- a/src/RMCA/Translator/SortMessage.hs
+++ b/src/RMCA/Translator/SortMessage.hs
@@ -7,13 +7,12 @@
module RMCA.Translator.SortMessage where
-import qualified Data.Bifunctor as BF
-import Data.Function (on)
-import Data.List (groupBy)
+import qualified Data.Bifunctor as BF
+import Data.Function (on)
+import Data.List (groupBy)
import Data.Maybe
import FRP.Yampa
import RMCA.Semantics
-import RMCA.Translator.Controller
import RMCA.Translator.Message
import RMCA.Translator.Note
@@ -47,9 +46,5 @@ sortNotes = sortNotes' ([],[])
| otherwise = sortNotes' (n,c) xs
-- Note messages are converted to PlayHeads
-convertMessages :: ([(Frames,Message)], [(Frames,Message)])
- -> ([(Frames,Note)], [(Frames,Controller)])
-convertMessages = proc (notes, ctrl) -> do
- notes' <- arr $ map (BF.second messageToNote) -< notes
- ctrl' <- arr $ map (BF.second messageToController) -< ctrl
- returnA -< (notes', ctrl')
+convertMessages :: [(Frames,Message)] -> [(Frames,Note)]
+convertMessages = map (BF.second messageToNote)
diff --git a/src/RMCA/Translator/Translator.hs b/src/RMCA/Translator/Translator.hs
index 6358025..63e2cbf 100644
--- a/src/RMCA/Translator/Translator.hs
+++ b/src/RMCA/Translator/Translator.hs
@@ -8,7 +8,6 @@ import qualified Data.Bifunctor as BF
import FRP.Yampa
import RMCA.Auxiliary.Curry
import RMCA.Semantics
-import RMCA.Translator.Controller
import RMCA.Translator.Message
import RMCA.Translator.Note
import RMCA.Translator.SortMessage
@@ -16,30 +15,29 @@ import RMCA.Translator.SortMessage
-- Uses function defined in SortMessage. This is a pure function and
-- it might not need to be a signal function.
readMessages' :: [(Frames,RawMessage)]
- -> ([(Frames,Note)], [(Frames,Controller)], [(Frames,RawMessage)])
+ -> ([(Frames,Note)], [(Frames,Message)], [(Frames,RawMessage)])
readMessages' = proc r -> do
(mes, raw) <- sortRawMessages -< r
- (notes, ctrl) <- convertMessages <<< sortNotes -< mes
+ (notes, ctrl) <- BF.first convertMessages <<< sortNotes -< mes
returnA -< (notes, ctrl, raw)
readMessages :: SF [(Frames, RawMessage)]
- ([(Frames,Note)], [(Frames,Controller)], [(Frames,RawMessage)])
+ ([(Frames,Note)], [(Frames,Message)], [(Frames,RawMessage)])
readMessages = arr readMessages'
gatherMessages' :: LTempo
-> SampleRate
-> Int
- -> ([(Frames,Note)],[(Frames,Controller)],[(Frames,RawMessage)])
+ -> ([(Frames,Note)],[(Frames,Message)],[(Frames,RawMessage)])
-> [(Frames, RawMessage)]
gatherMessages' layTempo sr chan = proc (notes, ctrl, raw) -> do
notes' <- concat <<< map (noteToMessages layTempo sr chan) -< notes
- ctrl' <- map (BF.second controllerToMessages) -< ctrl
rawNotes <- map (BF.second toRawMessage) -< notes'
- rawCtrl <- map (BF.second toRawMessage) -< ctrl'
+ rawCtrl <- map (BF.second toRawMessage) -< ctrl
returnA -< rawNotes ++ rawCtrl ++ raw
gatherMessages :: SF
( LTempo, SampleRate, Int
- , ([(Frames,Note)],[(Frames,Controller)],[(Frames,RawMessage)]))
+ , ([(Frames,Note)],[(Frames,Message)],[(Frames,RawMessage)]))
[(Frames, RawMessage)]
gatherMessages = arr $ uncurry4 gatherMessages'
--
2.47.2