Commit f0440c41 by Guerric Chupin

Refactoring to FRP.

parent c29586e7
......@@ -69,6 +69,9 @@ intersectionWith3 f m n p =
-- | = Yampa
countTo :: (Integral b, Ord b) => b -> SF (Event a) (Event b)
countTo n = count >>^ filterE (> n)
-- | '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
......
......@@ -2,11 +2,18 @@
module RMCA.EventProvider ( EventProvider
, newEventProvider
, newEmptyEventProvider
, stopProviding
, getEPfromRV
, EventProviderQueue
, newEventProviderQueue
, newEmptyEventProviderQueue
, emptyProviderQueue
, getEPQfromRV
) where
import Control.Concurrent.MVar
import Control.Monad
import Data.ReactiveValue
import FRP.Yampa
import RMCA.Auxiliary
......@@ -16,6 +23,9 @@ newtype EventProvider a = EventProvider (MVar (Event a, [IO ()]))
newEventProvider :: Maybe a -> IO (EventProvider a)
newEventProvider = fmap EventProvider . newMVar . (,[]) . maybeToEvent
newEmptyEventProvider :: IO (EventProvider a)
newEmptyEventProvider = newEventProvider Nothing
-- Stop event production without triggering the callbacks.
stopProviding :: EventProvider a -> IO ()
stopProviding (EventProvider mvar) =
......@@ -39,3 +49,35 @@ instance ReactiveValueWrite (EventProvider a) (Event a) IO where
readMVar mvar >>= sequence_ . snd
instance ReactiveValueReadWrite (EventProvider a) (Event a) IO where
newtype EventProviderQueue a = EventProviderQueue (MVar ([a], [IO ()]))
newEventProviderQueue :: [a] -> IO (EventProviderQueue a)
newEventProviderQueue = fmap EventProviderQueue . newMVar . (,[])
newEmptyEventProviderQueue :: IO (EventProviderQueue a)
newEmptyEventProviderQueue = newEventProviderQueue []
emptyProviderQueue :: EventProviderQueue a -> IO ()
emptyProviderQueue (EventProviderQueue mvar) =
modifyMVar_ mvar (\(_,cbs) -> return ([],cbs))
getEPQfromRV :: (ReactiveValueRead a b IO) => a -> IO (EventProviderQueue b)
getEPQfromRV rv = do
ep <- newEventProviderQueue . (:[]) =<< reactiveValueRead rv
(Event <^> rv) =:> ep
return ep
instance ReactiveValueRead (EventProviderQueue a) (Event a) IO where
reactiveValueRead (EventProviderQueue mvar) =
modifyMVar mvar popEventMVar
where popEventMVar ([],cbs) = return (([],cbs), NoEvent)
popEventMVar (el,cbs) = return ((init el,cbs), Event $ last el)
reactiveValueOnCanRead (EventProviderQueue mvar) io =
modifyMVar_ mvar $ \(mval,cbs) -> return (mval, cbs ++ [io])
instance ReactiveValueWrite (EventProviderQueue a) (Event a) IO where
reactiveValueWrite (EventProviderQueue mvar) val = do
when (isEvent val) $
modifyMVar_ mvar $ \(mval,cbs) -> return (fromEvent val:mval,cbs)
readMVar mvar >>= sequence_ . snd
......@@ -2,13 +2,14 @@
module RMCA.GUI.LayerSettings where
import qualified Data.IntMap as M
import qualified Data.IntMap as M
import Data.Maybe
import Data.ReactiveValue
import Data.String
import Data.Tuple
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Reactive
import Graphics.UI.Gtk.Reactive.ToggleButton
import RMCA.Auxiliary
import RMCA.GUI.NoteSettings
import RMCA.Layer.LayerConf
......@@ -103,6 +104,21 @@ layerSettings = do
boxPackStart auxBpbBox bpbLabel PackGrow 0
boxPackStart auxBpbBox bpbButton PackGrow 0
repeatBox <- vBoxNew False 0
boxPackStart layerSettingsBox repeatBox PackNatural 0
repeatLabel <- labelNew (Just "Repeat count")
labelSetLineWrap repeatLabel True
repeatAdj <- adjustmentNew 0 0 100 1 1 0
repeatButton <- spinButtonNew repeatAdj 1 0
auxRepeatBox <- vBoxNew False 0
centerAl' <- alignmentNew 0.5 0.5 0 0
containerAdd auxRepeatBox centerAl'
boxPackStart repeatBox auxRepeatBox PackRepel 0
boxPackStart auxRepeatBox repeatLabel PackGrow 0
boxPackStart auxRepeatBox repeatButton PackGrow 0
repeatCheckButton <- checkButtonNewWithLabel "Unable repeat count"
boxPackStart auxRepeatBox repeatCheckButton PackGrow 0
instrumentCombo <- comboBoxNewText
instrumentIndex <- mapM (\(ind,ins) ->
do i <- comboBoxAppendText instrumentCombo $
......@@ -133,8 +149,15 @@ layerSettings = do
=<< reactiveValueRead (liftR3 DynLayerConf layBeatRV layPitchRV strengthRV)
let bpbRV = spinButtonValueIntReactive bpbButton
repeatCheckRV = toggleButtonActiveReactive repeatCheckButton
repeatRV' = spinButtonValueIntReactive repeatButton
repeatRV = liftR2 (\act r -> if act then Just r else Nothing)
repeatCheckRV repeatRV'
reactiveValueWrite repeatCheckRV False
--reactiveValueOnCanRead repeatCheckRV $ do
statMCBMVar <- newMCBMVar
=<< reactiveValueRead (liftR StaticLayerConf bpbRV)
=<< reactiveValueRead (liftR2 StaticLayerConf bpbRV repeatRV)
reactiveValueOnCanRead dynMCBMVar $ postGUIAsync $ do
nDyn <- reactiveValueRead dynMCBMVar
......
......@@ -25,3 +25,6 @@ gtkMediaAdd = stringToGlib "gtk-add"
gtkMediaRemove :: DefaultGlibString
gtkMediaRemove = stringToGlib "gtk-remove"
gtkMediaRestart :: DefaultGlibString
gtkMediaRestart = stringToGlib "gtk-refresh"
{-# LANGUAGE Arrows #-}
module RMCA.Layer.Board ( boardRun
, SwitchBoard (..)
) where
module RMCA.Layer.Board where
import qualified Data.IntMap as M
import Data.List ((\\))
import FRP.Yampa
import RMCA.Auxiliary
import RMCA.Global.Clock
import RMCA.Layer.LayerConf
import RMCA.Semantics
data SwitchBoard = StartBoard StaticLayerConf
| ContinueBoard
| StopBoard
data RunStatus = Running | Stopped
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
automaton :: [PlayHead]
-> SF (Board, DynLayerConf, Event BeatNo)
(Event [Note], [PlayHead])
automaton iphs = proc (b, DynLayerConf { relPitch = rp
, strength = s
}, ebno) -> do
enphs <- accumBy advanceHeads' (iphs,[])
-< ebno `tag` (b, fromEvent ebno, rp, s)
(ephs,en) <- arr splitE -< enphs
phs <- hold iphs -< ephs
returnA -< (en, phs)
where advanceHeads' (ph,_) (board,bno,rp,s) = advanceHeads board bno rp s ph
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,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
layer :: SF (Event AbsBeat, Board, LayerConf, Event RunStatus)
(Event [Note], [PlayHead])
layer = layerStopped
where switchStatus (rs, slc, iphs) = case rs of
Stopped -> layerStopped
Running -> layerRunning slc iphs
layerStopped = switch lsAux switchStatus
layerRunning slc iphs = switch (lrAux slc iphs) switchStatus
-- 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
lsAux = proc (_, b, (slc,_,_), ers) -> do
en <- never -< ()
phs <- constant [] -< ()
e <- notYet -< fmap (\rs -> (rs, slc, startHeads b)) ers
returnA -< ((en,phs),e)
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)
lrAux slc iphs = proc (eab, b, (slc',dlc,_), ers) -> do
ebno <- layerMetronome slc -< (eab, dlc)
enphs@(_,phs) <- automaton iphs -< (b, dlc, ebno)
r <- (case repeatCount slc of
Nothing -> never
Just n -> countTo (n * beatsPerBar slc)) -< ebno
let ers' = ers `lMerge` (r `tag` Running)
e <- notYet -< fmap (\rs -> (rs, slc', phs ++ startHeads b)) ers'
returnA -< (enphs,e)
----------------------------------------------------------------------------
-- Machinery to make boards run in parallel
----------------------------------------------------------------------------
layers :: M.IntMap a
-> SF (Tempo, Event RunStatus,
M.IntMap (Board,LayerConf,Event RunStatus))
(M.IntMap (Event [Note], [PlayHead]))
layers imap = proc (t,erun,map) -> do
elc <- edgeBy diffSig (M.keys imap) -< M.keys map
let e = fmap switchCol elc
newMetronome Running = metronome
newMetronome Stopped = never
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
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 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
where ik = M.keys iSig
-- Old elements removed in nL are on the left, new elements added to
-- nL are on the right.
diffSig :: [Int] -> [Int] -> Maybe ([Int],[Int])
diffSig oL nL
| oL == nL = Nothing
| otherwise = Just (oL \\ nL, nL \\ oL)
routeBoard :: (Event AbsBeat,M.IntMap (Board,DynLayerConf,Event SwitchBoard))
-> M.IntMap sf
-> M.IntMap ((Event AbsBeat,Board,DynLayerConf,Event SwitchBoard),sf)
routeBoard (evs,map) sfs =
M.intersectionWith (,) ((\(b,l,ebs) -> (evs,b,l,ebs)) <$> map) sfs
diffSig :: [Int] -> [Int] -> Maybe ([Int],[Int])
diffSig oL nL
| oL == nL = Nothing
| otherwise = Just (oL \\ nL, nL \\ oL)
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
switchCol (oldSig,newSig) col =
foldr (\k m -> M.insert k layer m)
(foldr M.delete col oldSig) newSig
......@@ -19,6 +19,7 @@ data DynLayerConf = DynLayerConf { layerBeat :: Rational
-- | Datatype representing statically modifiable characteristics for a layer.
data StaticLayerConf = StaticLayerConf { beatsPerBar :: BeatsPerBar
, repeatCount :: Maybe Int
} deriving (Show, Read, Eq)
-- | Datatype containing informations useful for the synthetizer.
......@@ -64,6 +65,7 @@ defaultLayerConf = (defaultStaticLayerConf,defaultDynLayerConf,defaultSynthConf)
defaultStaticLayerConf :: StaticLayerConf
defaultStaticLayerConf = StaticLayerConf { beatsPerBar = 4
, repeatCount = Nothing
}
defaultDynLayerConf :: DynLayerConf
defaultDynLayerConf = DynLayerConf { layerBeat = 1 % 4
......
......@@ -71,32 +71,28 @@ main = do
--handleSaveLoad tempoRV boardMapRV layerMapRV instrMapRV phRVMapRV
--addLayerRV rmLayerRV confSaveRV confLoadRV
funBoardRunRV <- getEPfromRV =<< newCBMVarRW (const StopBoard)
boardStatusRV <- getEPfromRV =<< newCBMVarRW Stopped
isStartMVar <- newMVar False
reactiveValueOnCanRead playRV $ do
isStarted <- readMVar isStartMVar
if isStarted
then reactiveValueWrite funBoardRunRV $ Event $ const ContinueBoard
then reactiveValueWrite boardStatusRV $ Event Running
else do modifyMVar_ isStartMVar $ const $ return True
reactiveValueWrite funBoardRunRV $ Event StartBoard
reactiveValueWrite boardStatusRV $ Event Running
reactiveValueOnCanRead stopRV $ do
modifyMVar_ isStartMVar $ const $ return False
reactiveValueWrite funBoardRunRV $ Event $ const StopBoard
reactiveValueWrite boardStatusRV $ Event Stopped
boardMap <- reactiveValueRead boardMapRV
layerMap <- reactiveValueRead layerMapRV
tempo <- reactiveValueRead tempoRV
let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
statConfRV = liftR (fmap staticConf) layerMapRV
boardRunRV = liftR2 (\fb lm -> fmap ((fb <*>) . Event) lm)
funBoardRunRV statConfRV
dynConfRV = liftR (fmap dynConf) layerMapRV
jointedMapRV = liftR3 (intersectionWith3 (,,))
boardMapRV dynConfRV boardRunRV
inRV = liftR2 (,) tempoRV' jointedMapRV
initSig <- reactiveValueRead statConfRV
jointedMapRV = liftR (fmap (\(x,y) -> (x,y,NoEvent))) $
liftR2 (M.intersectionWith (,)) boardMapRV layerMapRV
inRV = liftR3 (,,) tempoRV' boardStatusRV jointedMapRV
initSig <- reactiveValueRead layerMapRV
--(inBoard, outBoard) <- yampaReactiveDual initSig (boardRun
--initSig)
outBoard <- yampaReactiveFrom (boardRun initSig) inRV
outBoard <- yampaReactiveFrom (layers initSig) inRV
--reactiveValueOnCanRead inRV (reactiveValueRead inRV >>= print . M.keys)
--inRV =:> inBoard
reactiveValueOnCanRead outBoard $ do
......
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