Commit 180da363 authored by Guerric Chupin's avatar Guerric Chupin

Volume modification.

parent 6502ab09
......@@ -153,3 +153,70 @@ liftRW4 bij a b c d =
where ReactiveFieldRead getter notifier = liftR4 f2 a b c d
ReactiveFieldWrite setter = liftW4 f1 a b c d
(f1, f2) = (direct bij, inverse bij)
liftR5 :: ( ReactiveValueRead a b m
, ReactiveValueRead c d m
, ReactiveValueRead e f m
, ReactiveValueRead g h m
, ReactiveValueRead i j m) =>
((b,d,f,h,j) -> k)
-> a
-> c
-> e
-> g
-> i
-> ReactiveFieldRead m k
liftR5 f a b c d e = ReactiveFieldRead getter notifier
where getter = do
x1 <- reactiveValueRead a
x2 <- reactiveValueRead b
x3 <- reactiveValueRead c
x4 <- reactiveValueRead d
x5 <- reactiveValueRead e
return $ f (x1, x2, x3, x4, x5)
notifier p = do
reactiveValueOnCanRead a p
reactiveValueOnCanRead b p
reactiveValueOnCanRead c p
reactiveValueOnCanRead d p
reactiveValueOnCanRead e p
liftW5 :: ( Monad m
, ReactiveValueWrite a b m
, ReactiveValueWrite c d m
, ReactiveValueWrite e f m
, ReactiveValueWrite g h m
, ReactiveValueWrite i j m) =>
(k -> (b,d,f,h,j))
-> a
-> c
-> e
-> g
-> i
-> ReactiveFieldWrite m k
liftW5 f a b c d e = ReactiveFieldWrite setter
where setter x = do
let (x1,x2,x3,x4,x5) = f x
reactiveValueWrite a x1
reactiveValueWrite b x2
reactiveValueWrite c x3
reactiveValueWrite d x4
reactiveValueWrite e x5
liftRW5 :: ( ReactiveValueReadWrite a b m
, ReactiveValueReadWrite c d m
, ReactiveValueReadWrite e f m
, ReactiveValueReadWrite g h m
, ReactiveValueReadWrite i j m) =>
BijectiveFunc k (b,d,f,h,j)
-> a
-> c
-> e
-> g
-> i
-> ReactiveFieldReadWrite m k
liftRW5 bij a b c d e =
ReactiveFieldReadWrite setter getter notifier
where ReactiveFieldRead getter notifier = liftR5 f2 a b c d e
ReactiveFieldWrite setter = liftW5 f1 a b c d e
(f1, f2) = (direct bij, inverse bij)
......@@ -26,11 +26,6 @@ data GUICell = GUICell { cellAction :: Action
, asPh :: Bool
} deriving(Show)
rotateGUICell :: GUICell -> GUICell
rotateGUICell g = g { cellAction = rotateAction $ cellAction g }
where rotateAction (ChDir b na d) = ChDir b na (nextDir d)
rotateAction x = x
newtype GUIBoard = GUIBoard { toGS :: GameState Int Tile Player GUICell }
type IOBoard = BIO.Board Int Tile (Player,GUICell)
......@@ -38,6 +33,11 @@ type IOBoard = BIO.Board Int Tile (Player,GUICell)
data Tile = Tile
data Player = Player deriving(Show)
rotateGUICell :: GUICell -> GUICell
rotateGUICell g = g { cellAction = rotateAction $ cellAction g }
where rotateAction (ChDir b na d) = ChDir b na (nextDir d)
rotateAction x = x
-- Takes a GUI coordinate and give the corresponding coordinate on the
-- internal board
fromGUICoords :: (Int,Int) -> (Int,Int)
......
......@@ -2,6 +2,7 @@
module RMCA.GUI.LayerSettings where
import Data.Maybe
import Data.ReactiveValue
import Data.String
import Data.Tuple
......@@ -19,31 +20,37 @@ floatConv :: (ReactiveValueReadWrite a b m,
a -> ReactiveFieldReadWrite m c
floatConv = liftRW $ bijection (realToFrac, realToFrac)
mkVScale :: String -> Adjustment -> IO (HBox,VScale)
mkVScale s adj = do
hBox <- hBoxNew False 10
boxLabel <- labelNew (Just s)
labelSetAngle boxLabel 90
boxPackStart hBox boxLabel PackNatural 0
boxScale <- vScaleNew adj
boxPackStart hBox boxScale PackNatural 0
return (hBox,boxScale)
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
layerSettingsVBox <- vBoxNew False 10
layerSettingsBox <- hBoxNew True 10
boxPackStart layerSettingsVBox layerSettingsBox PackNatural 0
layTempoBox <- hBoxNew False 10
layVolumeAdj <- adjustmentNew 100 0 100 1 1 1
(layVolumeBox,layVolumeScale) <- mkVScale "Volume" layVolumeAdj
boxPackStart layerSettingsBox layVolumeBox PackNatural 0
scaleSetDigits layVolumeScale 0
layTempoAdj <- adjustmentNew 1 0 2 0.1 0.1 1
(layTempoBox, layTempoScale) <- mkVScale "Layer tempo" layTempoAdj
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
strAdj <- adjustmentNew 0.8 0 2 0.1 0.1 0
(strBox, layStrengthScale) <- mkVScale "Strength" strAdj
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
......@@ -61,34 +68,46 @@ layerSettings chanRV boardQueue = do
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
let indexToInstr i = fromMaybe (error "Can't get the selected instrument.") $
lookup i instrumentIndex
instrToIndex ins =
fromMaybe (error "Can't retrieve the index for the instrument.") $
lookup ins $ map swap instrumentIndex
instrumentComboRV = bijection (indexToInstr, instrToIndex) `liftRW`
comboBoxIndexRV instrumentCombo
reactiveValueOnCanRead instrumentComboRV $ do
ins <- reactiveValueRead instrumentComboRV
chan <- reactiveValueRead chanRV
reactiveValueAppend boardQueue ([],[Instrument (mkChannel chan) (mkProgram ins)])
changeInst = do
ins <- reactiveValueRead instrumentComboRV
chan <- reactiveValueRead chanRV
reactiveValueAppend boardQueue
([],[Instrument (mkChannel chan) (mkProgram ins)])
changeInst
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
} = (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
, volume = v
} = (d,p,s,bpb,v)
f2 (d,p,s,bpb,v) = Layer { relTempo = d
, relPitch = p
, strength = s
, beatsPerBar = bpb
, volume = v
}
layerRV = liftRW5 (bijection (f1,f2))
layTempoRV layPitchRV strengthRV bpbRV layVolumeRV
reactiveValueOnCanRead layVolumeRV $ do
vol <- reactiveValueRead layVolumeRV
chan <- reactiveValueRead chanRV
let vol' = floor ((fromIntegral vol / 100) * 127)
reactiveValueAppend boardQueue ([],[Volume (mkChannel chan) vol'])
return (layerSettingsVBox, layerRV)
......@@ -13,6 +13,7 @@ data Layer = Layer { relTempo :: Double
, relPitch :: RelPitch
, strength :: Strength
, beatsPerBar :: BeatsPerBar
, volume :: Int
} deriving (Show)
layerTempo :: SF (Tempo, Layer) LTempo
......@@ -43,8 +44,9 @@ layerRV mvar = ReactiveFieldReadWrite setter getter notifier
getDefaultLayerRV :: IO (ReactiveFieldReadWrite IO Layer)
getDefaultLayerRV = layerRV <$> newCBMVar dl
where dl = Layer { relTempo = 1
, relPitch = 0
, strength = 1
where dl = Layer { relTempo = 1
, relPitch = 0
, strength = 1
, beatsPerBar = 4
, volume = 127
}
......@@ -24,17 +24,6 @@ schedule :: Frames
schedule size = BF.first scatterEvents
. break ((>= size) . fst) . sortBy (comparing fst)
{- Rendered useless
-- The function choose between the event in case two are in conflict.
--
-- /!\ That functional argument is a bit unsatisfying, it would be
-- probably better if we'd try to push events to the next frame if
-- they conflict and only remove them if it's impossible to do
-- otherwise.
nubDuplicate :: (Eq a) => ([a] -> a) -> [(Frames, a)] -> [(Frames, a)]
nubDuplicate f = map (BF.second f) . scatterEvents
. map (\l@((n,_):_) -> (n,map snd l)) . group
-}
-- 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
......
module RMCA.Translator.Message where
import RMCA.Semantics
import Sound.MIDI.Controller (volume)
import qualified Sound.MIDI.Message as Message
import qualified Sound.MIDI.Message.Channel as Channel
import qualified Sound.MIDI.Message.Channel.Voice as Voice
......@@ -26,13 +27,15 @@ type Frames = Int
data Message = NoteOn Channel Pitch Strength
| NoteOff Channel Pitch Strength
| Instrument Channel Voice.Program
| Control Channel ControllerIdx UCtrl
| Volume Channel Int
-- | Control Channel ControllerIdx UCtrl
deriving(Show)
getChannel :: Message -> Int
getChannel (NoteOn c _ _) = Channel.fromChannel c
getChannel (NoteOff c _ _) = Channel.fromChannel c
getChannel (Control c _ _) = Channel.fromChannel c
getChannel (Volume c _) = Channel.fromChannel c
--getChannel (Control c _) = Channel.fromChannel c
getChannel (Instrument c _ ) = Channel.fromChannel c
mkChannel :: Int -> Channel
......@@ -49,7 +52,6 @@ fromRawPitch p = Pitch $ Voice.fromPitch p
toRawPitch :: Pitch -> Voice.Pitch
toRawPitch (Pitch p) = Voice.toPitch p
isNoteOn :: Message -> Bool
isNoteOn NoteOn {} = True
isNoteOn _ = False
......@@ -58,8 +60,9 @@ isNoteOff :: Message -> Bool
isNoteOff NoteOff {} = True
isNoteOff _ = False
isControl :: Message -> Bool
isControl Control {} = True
isControl Volume {} = True
isControl _ = False
switchOnOff :: Message -> Message
......@@ -74,12 +77,13 @@ fromRawMessage (Message.Channel (Channel.Cons c
fromRawMessage (Message.Channel (Channel.Cons c
(Channel.Voice (Voice.NoteOff p v)))) =
Just $ NoteOff c (fromRawPitch p) (toUCtrl $ Voice.fromVelocity v)
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 (Message.Channel (Channel.Cons c
(Channel.Voice (Voice.Control n v))))
| n == volume = Just $ Volume c v
| otherwise = Nothing
fromRawMessage _ = Nothing
toRawMessage :: Message -> RawMessage
......@@ -89,9 +93,9 @@ toRawMessage (NoteOn c p v) =
toRawMessage (NoteOff c p v) =
Message.Channel $ Channel.Cons c
(Channel.Voice $ Voice.NoteOff (toRawPitch p) (Voice.toVelocity $ fromUCtrl v))
toRawMessage (Control c n v) =
toRawMessage (Volume c v) =
Message.Channel (Channel.Cons c
(Channel.Voice (Voice.Control n (fromUCtrl v))))
(Channel.Voice (Voice.Control volume v)))
toRawMessage (Instrument c p) =
Message.Channel (Channel.Cons c
(Channel.Voice (Voice.ProgramChange p)))
......@@ -11,7 +11,6 @@ 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.Message
import RMCA.Translator.Note
......
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