Commit e3af38f5 authored by Guerric Chupin's avatar Guerric Chupin

Instrument change enabled.

parent a25011e1
......@@ -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
......
{-# 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)
{-# 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
......
{-# 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
......
module RMCA.Translator.Controller where
import RMCA.Translator.Message
data Controller = Lol
messageToController :: Message -> Controller
messageToController _ = Lol
controllerToMessages :: Controller -> Message
controllerToMessages = undefined
......@@ -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'
......
......@@ -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)))
......@@ -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
......@@ -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)
......@@ -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'
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