Commit 831ce64c authored by Guerric Chupin's avatar Guerric Chupin

Minor SF refactoring.

parent 5c340354
{-# LANGUAGE Arrows #-}
module RMCA.Layer.Board ( boardRun
, BoardRun (..)
, SwitchBoard (..)
) where
import qualified Data.IntMap as M
import Data.List ((\\))
import qualified Data.IntMap as M
import Data.List ((\\))
import FRP.Yampa
import RMCA.Auxiliary
import RMCA.Global.Clock
import RMCA.Layer.Layer
import RMCA.Layer.LayerConf
import RMCA.Semantics
data BoardRun = BoardStart | BoardStop deriving (Eq, Show)
data SwitchBoard = StartBoard StaticLayerConf
| ContinueBoard
| StopBoard
updatePhOnSwitch :: Board -> [PlayHead] -> SwitchBoard -> [PlayHead]
updatePhOnSwitch _ _ (StopBoard {}) = []
updatePhOnSwitch board _ (StartBoard {}) = startHeads board
updatePhOnSwitch board oldPhs (ContinueBoard {}) = oldPhs ++ startHeads board
{-
noStopBoard :: Event SwitchBoard -> Event SwitchBoard
noStopBoard (Event (StopBoard {})) = NoEvent
noStopBoard e = e
-}
{-
genPlayHeads :: Board -> SwitchBoard -> [PlayHead]
genPlayHeads _ (StopBoard {}) = []
genPlayHeads board _ = startHeads board
-}
{-
continueBoard :: Event SwitchBoard -> Event [PlayHead]
continueBoard board (Event (ContinueBoard {})) = Event $ startHeads board
continueBoard _ _ = NoEvent
-}
startBoard :: Event SwitchBoard -> Event StaticLayerConf
startBoard (Event (StartBoard st)) = Event st
startBoard _ = NoEvent
stopBoard :: Event SwitchBoard -> Event SwitchBoard
stopBoard e@(Event StopBoard) = e
stopBoard _ = NoEvent
-- singleboard is a simple running board. Given an initial list of
-- play heads, it runs the board by the beat. It produces events but
-- also a constant output of the states of the play heads to allow for
-- adding them.
singleBoard :: [PlayHead]
-> SF (Board, Layer, Event BeatNo) (Event ([PlayHead], [Note]))
singleBoard iPh = proc (board, Layer { relPitch = rp
, strength = s
}, ebno) ->
accumBy advanceHeads' (iPh,[]) -< ebno `tag` (board, fromEvent ebno, rp, s)
-> SF (Board,DynLayerConf,Event BeatNo)
(Event [Note], [PlayHead])
singleBoard iPh = proc (board, DynLayerConf { relPitch = rp
, strength = s
}, ebno) -> do
(phs,notes) <- accumHoldBy advanceHeads' (iPh,[])
-< ebno `tag` (board, fromEvent ebno, rp, s)
returnA -< (ebno `tag` notes, phs)
where advanceHeads' (ph,_) (board,bno,rp,s) = advanceHeads board bno rp s ph
boardSF :: SF (Event AbsBeat, Board, Layer, BoardRun)
(Event ([PlayHead], [Note]))
boardSF = proc (eabs, board, l, br) -> do
ebno <- layerMetronome -< (eabs,l)
ess <- onChange -< br
boardSwitch [] -< ((board, l, ebno), ess `tag` (br, startHeads board))
-- dynSingleBoard differs from singleBoard in that it receives a
-- SwitchBoard event allowing it to start/stop the board.
dynSingleBoard :: SF (Board, DynLayerConf, Event BeatNo, Event SwitchBoard)
(Event [Note], [PlayHead])
dynSingleBoard = proc (board, dynConf, ebno, esb) -> do
rec
res@(_,curPhs) <- rSwitch $ singleBoard []
-< ( (board, dynConf, ebno)
, fmap (singleBoard . updatePhOnSwitch board curPhs') esb)
curPhs' <- iPre [] -< curPhs
returnA -< res
boardSwitch :: [PlayHead]
-> SF ((Board, Layer, Event BeatNo), Event (BoardRun, [PlayHead]))
(Event ([PlayHead],[Note]))
boardSwitch rPh = dSwitch (singleBoard rPh *** (identity >>> notYet)) fnSwitch
where fnSwitch (BoardStart, iPh) = boardSwitch iPh
fnSwitch (BoardStop, _) = boardSwitch []
boardSF :: StaticLayerConf
-> SF (Event AbsBeat, Board, DynLayerConf, Event SwitchBoard)
(Event [Note], [PlayHead])
boardSF (StaticLayerConf { beatsPerBar = bpb }) =
proc (eabs, board, dynConf, esb) -> do
ebno <- rSwitch never -< ( (eabs,dynConf)
, layerMetronome <$> startBoard esb)
dynSingleBoard -< (board,dynConf,ebno,esb)
--------------------------------------------------------------------------------
----------------------------------------------------------------------------
-- Machinery to make boards run in parallel
--------------------------------------------------------------------------------
----------------------------------------------------------------------------
{-
boardRun :: M.IntMap StaticLayerConf
-> SF (Tempo, Event SwitchBoard, M.IntMap (Board,DynLayerConf))
(M.IntMap (Event [Note], [PlayHead]))
boardRun iMap = undefined
where routing :: ( Event AbsBeat, Event SwitchBoard
, M.IntMap (Board, DynLayerConf))
-> M.IntMap sf
-> M.IntMap
((Event AbsBeat, Board, DynLayerConf, Event SwitchBoard),sf)
routing (eb,es,mSig) sfs = M.unionWith (,)
(fmap (\(board,layer) -> (eb,board,layer,es)) mSig)
sfs
-}
boardRun' :: M.IntMap (SF (Event AbsBeat,Board,Layer,BoardRun)
(Event ([PlayHead],[Note])))
-> SF (Event AbsBeat, BoardRun, M.IntMap (Board,Layer))
(M.IntMap (Event ([PlayHead],[Note])))
boardRun' :: M.IntMap (SF (Event AbsBeat,Board,DynLayerConf,Event SwitchBoard)
(Event [Note], [PlayHead]))
-> SF (Event AbsBeat, M.IntMap (Board,DynLayerConf,Event SwitchBoard))
(M.IntMap (Event [Note], [PlayHead]))
boardRun' iSF = boardRun'' iSF (lengthChange iSF)
where boardRun'' iSF swSF = pSwitch routeBoard iSF swSF contSwitch
contSwitch contSig (oldSig, newSig) = boardRun'' newSF
(lengthChange newSF >>> notYet)
where newSF = foldr (\k m -> M.insert k boardSF m)
where defaultBoardSF = boardSF defaultStaticLayerConf
newSF = foldr (\k m -> M.insert k defaultBoardSF m)
(foldr M.delete contSig oldSig) newSig
lengthChange iSig = edgeBy diffSig ik <<^ M.keys <<^ (\(_,_,x) -> x) <<^ fst
lengthChange iSig = edgeBy diffSig ik <<^ M.keys <<^ (\(_,x) -> x) <<^ fst
where ik = M.keys iSig
-- Old elements removed in nL are on the left, new elements added to
-- nL are on the right.
......@@ -58,16 +115,22 @@ boardRun' iSF = boardRun'' iSF (lengthChange iSF)
diffSig oL nL
| oL == nL = Nothing
| otherwise = Just (oL \\ nL, nL \\ oL)
routeBoard :: (Event AbsBeat,BoardRun,M.IntMap (Board,Layer))
routeBoard :: (Event AbsBeat,M.IntMap (Board,DynLayerConf,Event SwitchBoard))
-> M.IntMap sf
-> M.IntMap ((Event AbsBeat,Board,Layer,BoardRun),sf)
routeBoard (evs,br,map) =
M.intersectionWith (,) ((\(b,l) -> (evs,b,l,br)) <$> map)
-> M.IntMap ((Event AbsBeat,Board,DynLayerConf,Event SwitchBoard),sf)
routeBoard (evs,map) sfs =
M.intersectionWith (,) ((\(b,l,ebs) -> (evs,b,l,ebs)) <$> map) sfs
boardRun :: (Tempo, BoardRun, M.IntMap (Board,Layer))
-> SF (Tempo, BoardRun, M.IntMap (Board,Layer))
(M.IntMap (Event ([PlayHead],[Note])))
boardRun (_,_,iMap) = mkBeat >>> boardRun' (iMap $> boardSF)
where mkBeat = proc (t,x,y) -> do
e <- metronome -< t
returnA -< (e,x,y)
boardRun :: M.IntMap StaticLayerConf
-> SF (Tempo, M.IntMap (Board,DynLayerConf,Event SwitchBoard))
(M.IntMap (Event [Note], [PlayHead]))
boardRun iMap = mkBeat >>> (boardRun' $ fmap boardSF iMap)
where mkBeat = proc (t,map) -> do
esb <- arr (foldr selEvent NoEvent) <<^ fmap (\(_,_,e) -> e) -< map
eab <- rSwitch never -< (t, lMerge (stopBoard esb `tag` never)
(startBoard esb `tag` metronome))
returnA -< (eab,map)
selEvent x NoEvent = x
selEvent e@(Event (StopBoard {})) _ = e
selEvent (Event (StartBoard {})) f@(Event (StopBoard {})) = f
selEvent _ x = x
{-# LANGUAGE Arrows, TupleSections #-}
module RMCA.Layer.Layer where
import Data.CBMVar
import Data.Ratio
import Data.ReactiveValue
import FRP.Yampa
import RMCA.Auxiliary
import RMCA.Global.Clock
import RMCA.Semantics
-- Data representing the state of a layer. It is updated continuously.
data Layer = Layer { layerBeat :: Rational
, relPitch :: RelPitch
, strength :: Strength
, beatsPerBar :: BeatsPerBar
, volume :: Int
} deriving (Show,Read,Eq)
layerMetronome :: SF (Event AbsBeat, Layer) (Event BeatNo)
layerMetronome = proc (eb, Layer { layerBeat = r
, beatsPerBar = bpb }) -> do
ewbno <- accumFilter (\_ (ab,r) -> ((),selectBeat (ab,r))) () -< (,r) <$> eb
accumBy (flip nextBeatNo) 1 -< ewbno `tag` bpb
where selectBeat (absBeat, layBeat) =
maybeIf ((absBeat - 1) `mod` floor (fromIntegral maxAbsBeat * layBeat) == 0)
{-
-- /!\ To be changed in the initialization of the bpb /!\
layerMetronome :: SF (Tempo, Layer) (Event BeatNo)
layerMetronome = proc (t,l@Layer { beatsPerBar = bpb }) -> do
eb <- metronome <<< layerTempo -< (t,l)
accumBy (flip nextBeatNo) 1 -< eb `tag` bpb
-}
layerRV :: CBMVar Layer -> ReactiveFieldReadWrite IO Layer
layerRV mvar = ReactiveFieldReadWrite setter getter notifier
where setter :: Layer -> IO ()
setter = writeCBMVar mvar
getter :: IO Layer
getter = readCBMVar mvar
notifier :: IO () -> IO ()
notifier = installCallbackCBMVar mvar
getDefaultLayerRV :: IO (ReactiveFieldReadWrite IO Layer)
getDefaultLayerRV = layerRV <$> newCBMVar defaultLayer
defaultLayer :: Layer
defaultLayer = Layer { layerBeat = 1 % 4
, relPitch = 0
, strength = 1
, beatsPerBar = 4
, volume = 127
}
{-# LANGUAGE Arrows, TupleSections #-}
module RMCA.Layer.LayerConf where
import Data.Ratio
import Data.ReactiveValue
import FRP.Yampa
import RMCA.Auxiliary
import RMCA.Global.Clock
import RMCA.Semantics
-- | Datatype representing dynamically modifiable characteristics for a layer.
data DynLayerConf = DynLayerConf { layerBeat :: Rational
, relPitch :: RelPitch
, strength :: Strength
} deriving (Show, Read, Eq)
-- | Datatype representing statically modifiable characteristics for a layer.
data StaticLayerConf = StaticLayerConf { beatsPerBar :: BeatsPerBar
} deriving (Show, Read, Eq)
-- | Datatype containing informations useful for the synthetizer.
data SynthConf = SynthConf { volume :: Int
, instrument :: InstrumentNo
} deriving (Show, Read, Eq)
type LayerConf = (StaticLayerConf, DynLayerConf, SynthConf)
dynConf :: LayerConf -> DynLayerConf
dynConf (_,d,_) = d
staticConf :: LayerConf -> StaticLayerConf
staticConf (s,_,_) = s
synthConf :: LayerConf -> SynthConf
synthConf (_,_,s) = s
layerMetronome :: StaticLayerConf
-> SF (Event AbsBeat, DynLayerConf) (Event BeatNo)
layerMetronome (StaticLayerConf { beatsPerBar = bpb
}) =
proc (eb, DynLayerConf { layerBeat = r
}) -> do
ewbno <- accumFilter (\_ (ab,r) -> ((),selectBeat (ab,r))) () -< (,r) <$> eb
accumBy (flip nextBeatNo) 1 -< ewbno `tag` bpb
where selectBeat (absBeat, layBeat) =
maybeIf ((absBeat - 1) `mod`
floor (fromIntegral maxAbsBeat * layBeat) == 0)
getDefaultLayerConfRV :: IO (ReactiveFieldReadWrite IO LayerConf)
getDefaultLayerConfRV = newCBMVarRW defaultLayerConf
defaultLayerConf :: LayerConf
defaultLayerConf = (defaultStaticLayerConf,defaultDynLayerConf,defaultSynthConf)
defaultStaticLayerConf :: StaticLayerConf
defaultStaticLayerConf = StaticLayerConf { beatsPerBar = 4
}
defaultDynLayerConf :: DynLayerConf
defaultDynLayerConf = DynLayerConf { layerBeat = 1 % 4
, relPitch = 0
, strength = 1
}
defaultSynthConf :: SynthConf
defaultSynthConf = SynthConf { volume = 127
, instrument = 0
}
......@@ -42,6 +42,8 @@ import RMCA.Auxiliary
-- Basic Type Synonyms
------------------------------------------------------------------------------
type InstrumentNo = Int
-- Unipolar control value; [0, 1]
type UCtrl = Double
......
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