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
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) =
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
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
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 $
=<< 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
{-# 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
--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
sourcephile / git / tmp / julm / arpeggigon.git / commitdiff