Commit f4eafe80 by Guerric Chupin

Repeat button waits for the next beat before restarting.

parent 7ff01d1f
......@@ -6,11 +6,42 @@ import FRP.Yampa
import Data.Maybe
import RMCA.Auxiliary.Misc
import Debug.Trace
-- | = Yampa
countTo :: (Integral b) => b -> SF (Event a) (Event b)
countTo n = count >>^ filterE (== n)
-- | Synchonizes two event sources. An event on the first source will be delayed until an event occurs on the second.
--
-- Ex:
-- Event a => . . 1 . . . . 2 . . . 3 . . 4 . . . . . 5 . . 6 . . . . .
-- Event b => . a . . . b . . . c . . . . . . d . e . f . . . . . g . .
-- wairFor => . . . . . 1 . . . 2 . . . . . . 4 . . . 5 . . . . . 6 . .
waitForEvent :: (Show a, Show b) => SF (Event a, Event b) (Event a)
waitForEvent = proc (ea,eb) -> do
em <- arr $ uncurry $ mapMerge Left Right (\_ b -> Right b) -< let a = (ea,eb) in traceShow a a
hob <- dAccumHoldBy accumulator NoEvent -< em
returnA -< let a = eb *> (ea `lMerge` hob) in traceShow (a,eb) a
where accumulator :: Event a -> Either a b -> Event a
accumulator _ (Left a) = Event a
accumulator _ (Right _) = NoEvent
--accumulator _ (Right b) =
{-
waitForEvent :: SF (Event b, Event a) (Event b)
waitForEvent = proc (eb,ea) -> do
rec
es' <- iPre NoEvent -< es
es <- rSwitch waitAux -< ((eb,ea),es' `tag` waitAux)
returnA -< es
where waitAux = proc (eb,ea) -> do
--ea' <- (if b then notYet else identity) -< ea
eb' <- accumHoldBy (\_ b -> Event b) NoEvent -< eb
returnA -< ea *> eb'
-}
-- | 'stepBack' contains its previous argument as its output. Because it's hard to define it at time 0, it's wrapped up in a 'Maybe'.
stepBack :: SF a (Maybe a)
stepBack = sscan f (Nothing, Nothing) >>^ snd
......
......@@ -119,6 +119,8 @@ layerSettings isStartedRV = do
boxPackStart auxRepeatBox repeatButton PackGrow 0
repeatCheckButton <- checkButtonNewWithLabel "Unable repeat count"
boxPackStart auxRepeatBox repeatCheckButton PackGrow 0
keepCheckButton <- checkButtonNewWithLabel "Keep heads on restart"
boxPackStart auxRepeatBox keepCheckButton PackGrow 0
instrumentCombo <- comboBoxNewText
instrumentIndex <- mapM (\(ind,ins) ->
......@@ -127,9 +129,9 @@ layerSettings isStartedRV = do
return (i, ind)) instrumentList
comboBoxSetActive instrumentCombo 0
boxPackStart layerSettingsVBox instrumentCombo PackNatural 10
------------------------------------------------------------------------------
-------------------------------------------------------------------------
-- RVs
------------------------------------------------------------------------------
-------------------------------------------------------------------------
let indexToInstr i = fromMaybe (error "Can't get the selected instrument.") $
lookup i instrumentIndex
instrToIndex ins =
......@@ -137,8 +139,9 @@ layerSettings isStartedRV = do
lookup ins $ map swap instrumentIndex
instrumentComboRV = bijection (indexToInstr, instrToIndex) `liftRW`
comboBoxIndexRV instrumentCombo
layVolumeRV = liftRW (bijection (floor, fromIntegral)) $
layVolumeRV = liftRW (bijection (round, fromIntegral)) $
scaleValueReactive layVolumeScale
keepCheckRV = toggleButtonActiveReactive keepCheckButton
synthMCBMVar <- newMCBMVar
=<< reactiveValueRead (liftR2 SynthConf layVolumeRV instrumentComboRV)
......@@ -147,7 +150,8 @@ layerSettings isStartedRV = do
let strengthRV = floatConv $ scaleValueReactive layStrengthScale
dynMCBMVar <- newMCBMVar
=<< reactiveValueRead (liftR3 DynLayerConf layBeatRV layPitchRV strengthRV)
=<< reactiveValueRead
(liftR4 DynLayerConf layBeatRV layPitchRV strengthRV keepCheckRV)
let bpbRV = spinButtonValueIntReactive bpbButton
repeatCheckRV = toggleButtonActiveReactive repeatCheckButton
......@@ -174,6 +178,7 @@ layerSettings isStartedRV = do
reactiveValueWrite repeatCheckSensitive True
repeatCheckRV =:> repeatSensitive
--repeatCheckRV =:> keepCheckSensitive
reactiveValueWrite repeatCheckRV False
reactiveValueWrite repeatSensitive False
......@@ -185,6 +190,7 @@ layerSettings isStartedRV = do
reactiveValueWriteOnNotEq layBeatRV $ layerBeat nDyn
reactiveValueWriteOnNotEq layPitchRV $ relPitch nDyn
reactiveValueWriteOnNotEq strengthRV $ strength nDyn
reactiveValueWriteOnNotEq keepCheckRV $ keepHeads nDyn
reactiveValueOnCanRead statMCBMVar $ postGUIAsync $ do
nStat <- reactiveValueRead statMCBMVar
......@@ -202,6 +208,8 @@ layerSettings isStartedRV = do
layPitchRV dynMCBMVar
syncRightOnLeftWithBoth (\ns ol -> ol { strength = ns })
strengthRV dynMCBMVar
syncRightOnLeftWithBoth (\nk ol -> ol { keepHeads = nk })
keepCheckRV dynMCBMVar
syncRightOnLeftWithBoth (\nb ol -> ol { beatsPerBar = nb })
bpbRV statMCBMVar
syncRightOnLeftWithBoth (\nr ol -> ol { repeatCount = nr })
......
......@@ -12,7 +12,7 @@ import RMCA.Semantics
import Debug.Trace
data RunStatus = Running | Stopped
data RunStatus = Running | Stopped deriving(Show, Eq)
layerMetronome :: StaticLayerConf
-> SF (Event AbsBeat, DynLayerConf) (Event BeatNo)
......@@ -59,13 +59,17 @@ layer = layerStopped
lrAux slc iphs = proc (eab, b, (slc',dlc,_), ers) -> do
ebno <- layerMetronome slc -< (eab, dlc)
enphs@(_,phs) <- automaton iphs -< (b, dlc, traceShow ebno ebno)
r <- (case let a = repeatCount slc in traceShow a a of
enphs@(_,phs) <- automaton iphs -< (b, dlc, ebno)
r <- (case repeatCount slc of
Nothing -> never
Just n -> countTo (1 + n * beatsPerBar slc)) -< ebno
let ers' = ers `lMerge` (r `tag` Running)
erun <- waitForEvent -< (filterE (== Running) ers,ebno)
estop <- arr $ filterE (/= Running) -< ers
let ers' = erun `lMerge` estop
ers'' = ers' `lMerge` (r `tag` Running)
ophs <- iPre iphs -< phs
e <- notYet -< fmap (\rs -> (rs, slc', ophs ++ startHeads b)) ers'
let ophs' = if keepHeads dlc then ophs else []
e <- notYet -< fmap (\rs -> (rs, slc', ophs' ++ startHeads b)) (ers'')
returnA -< (enphs,e)
layers :: M.IntMap a
......@@ -77,7 +81,12 @@ layers imap = proc (t,erun,map) -> do
let e = fmap switchCol elc
newMetronome Running = metronome
newMetronome Stopped = never
eabs <- rSwitch metronome -< (t, newMetronome <$> erun)
erun' <- accumFilter (\oRS nRS ->
case (oRS,nRS) of
(Stopped,_) -> (nRS,Just nRS)
(Running, Stopped) -> (Stopped,Just Stopped)
_ -> (oRS,Nothing)) Stopped -< erun
eabs <- rSwitch metronome -< (t, newMetronome <$> erun')
rpSwitch routing (imap $> layer) -< ((eabs,erun,map),e)
where routing (eabs,erun,map) sfs = M.intersectionWith (,)
(fmap (\(b,l,er) -> (eabs,b,l,erun `lMerge` er)) map) sfs
......
......@@ -4,9 +4,7 @@ module RMCA.Layer.LayerConf where
import Data.Ratio
import Data.ReactiveValue
import FRP.Yampa
import RMCA.Auxiliary
import RMCA.Global.Clock
import RMCA.Semantics
import RMCA.Translator.Message
......@@ -14,6 +12,7 @@ import RMCA.Translator.Message
data DynLayerConf = DynLayerConf { layerBeat :: Rational
, relPitch :: RelPitch
, strength :: Strength
, keepHeads :: Bool
} deriving (Show, Read, Eq)
-- | Datatype representing statically modifiable characteristics for a layer.
......@@ -58,6 +57,7 @@ defaultDynLayerConf :: DynLayerConf
defaultDynLayerConf = DynLayerConf { layerBeat = 1 % 4
, relPitch = 0
, strength = 1
, keepHeads = False
}
defaultSynthConf :: SynthConf
defaultSynthConf = SynthConf { volume = 127
......
......@@ -87,7 +87,7 @@ main = do
initSig <- reactiveValueRead layerMapRV
--(inBoard, outBoard) <- yampaReactiveDual initSig (boardRun
--initSig)
outBoard <- yampaReactiveFrom (layers initSig) inRV
outBoard <- yampaReactiveWithMetronome (layers initSig) inRV 15
--reactiveValueOnCanRead inRV (reactiveValueRead inRV >>= print . M.keys)
reactiveValueOnCanRead outBoard $ do
out <- reactiveValueRead outBoard
......
......@@ -16,10 +16,11 @@ yampaReactiveFrom sf rv = do
return output
yampaReactiveWithMetronome :: (ReactiveValueRead c a IO) =>
a -> SF a b -> c -> DTime
SF a b -> c -> DTime
-> IO (ReactiveFieldRead IO b)
yampaReactiveWithMetronome init sf rv dt = do
yampaReactiveWithMetronome sf rv dt = do
clock <- mkClock dt
init <- reactiveValueRead rv
(input,output) <- yampaReactiveDual init sf
rv =:> input
reactiveValueOnCanRead clock $
......
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