From c29586e772429e6ed1f502311df8d0765452f6d2 Mon Sep 17 00:00:00 2001 From: Guerric Chupin <guerric.chupin@gmail.com> Date: Thu, 8 Sep 2016 16:07:20 +0100 Subject: [PATCH] Reworks to the GUI --- src/RMCA/Auxiliary.hs | 20 ++++++--- src/RMCA/Configuration.hs | 9 ++-- src/RMCA/EventProvider.hs | 41 ++++++++++++++++++ src/RMCA/GUI/Board.hs | 10 ++--- src/RMCA/GUI/LayerSettings.hs | 77 ++++++++++++++++++---------------- src/RMCA/GUI/MultiBoard.hs | 79 ++++++++++++++++++++++------------- src/RMCA/Global/Clock.hs | 51 ---------------------- src/RMCA/IOClockworks.hs | 61 +++++++++++++++++++++++++++ src/RMCA/Layer/Board.hs | 14 ------- src/RMCA/Layer/LayerConf.hs | 9 ++++ src/RMCA/Main.hs | 57 ++++++++++++++++--------- src/RMCA/Translator/Jack.hs | 7 ++-- src/RMCA/YampaReactive.hs | 37 ++++++++++++++++ 13 files changed, 303 insertions(+), 169 deletions(-) create mode 100644 src/RMCA/EventProvider.hs create mode 100644 src/RMCA/IOClockworks.hs create mode 100644 src/RMCA/YampaReactive.hs diff --git a/src/RMCA/Auxiliary.hs b/src/RMCA/Auxiliary.hs index 250dc45..0a42d65 100644 --- a/src/RMCA/Auxiliary.hs +++ b/src/RMCA/Auxiliary.hs @@ -3,12 +3,12 @@ -- | Auxiliary functions used throughout the code. module RMCA.Auxiliary where -import Control.Monad -import Data.CBMVar -import Data.Fixed -import Data.Maybe -import Data.ReactiveValue -import FRP.Yampa +import Control.Monad +import Data.CBMVar +import qualified Data.IntMap as M +import Data.Maybe +import Data.ReactiveValue +import FRP.Yampa -- |= General functions @@ -59,6 +59,14 @@ eventIf b = if b then Event () else NoEvent maybeIf :: Bool -> Maybe () maybeIf b = if b then Just () else Nothing +intersectionWith3 :: (a -> b -> c -> d) + -> M.IntMap a + -> M.IntMap b + -> M.IntMap c + -> M.IntMap d +intersectionWith3 f m n p = + M.intersectionWith (\x (y,z) -> f x y z) m $ M.intersectionWith (,) n p + -- | = Yampa -- | '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'. diff --git a/src/RMCA/Configuration.hs b/src/RMCA/Configuration.hs index 67b70ae..5e5ff79 100644 --- a/src/RMCA/Configuration.hs +++ b/src/RMCA/Configuration.hs @@ -6,7 +6,7 @@ module RMCA.Configuration where import Control.Arrow import Control.Exception import Data.Array -import qualified Data.IntMap as M +import qualified Data.IntMap as M import Data.List import Data.Maybe import Data.ReactiveValue @@ -14,12 +14,10 @@ import Graphics.UI.Gtk import RMCA.Auxiliary import RMCA.GUI.Board import RMCA.GUI.MultiBoard -import RMCA.Layer.Layer +import RMCA.Layer.LayerConf import RMCA.Semantics import Text.Read -type InstrumentNo = Int - data BoardConf = BoardConf { confLayers :: [(BoardInit,Layer,InstrumentNo)] , confTempo :: Tempo } deriving(Read,Show) @@ -105,7 +103,8 @@ handleSaveLoad :: ( ReactiveValueReadWrite tempo Tempo IO tempo -> board -> layer -> instr -> boards -> addLayer -> rmLayer -> save -> load -> IO () --handleSaveLoad :: _ -handleSaveLoad tempoRV boardRV layerRV instrRV pieceArrRV addLayerRV rmLayerRV confSaveRV confLoadRV = do +handleSaveLoad tempoRV boardRV layerRV instrRV pieceArrRV + addLayerRV rmLayerRV confSaveRV confLoadRV = do fcs <- fileChooserDialogNew (Just "Save configuration") Nothing FileChooserActionSave [("Cancel",ResponseCancel),("Ok",ResponseOk)] reactFilt <- fileFilterNew diff --git a/src/RMCA/EventProvider.hs b/src/RMCA/EventProvider.hs new file mode 100644 index 0000000..280a12b --- /dev/null +++ b/src/RMCA/EventProvider.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TupleSections #-} + +module RMCA.EventProvider ( EventProvider + , newEventProvider + , stopProviding + , getEPfromRV + ) where + +import Control.Concurrent.MVar +import Data.ReactiveValue +import FRP.Yampa +import RMCA.Auxiliary + +newtype EventProvider a = EventProvider (MVar (Event a, [IO ()])) + +newEventProvider :: Maybe a -> IO (EventProvider a) +newEventProvider = fmap EventProvider . newMVar . (,[]) . maybeToEvent + +-- Stop event production without triggering the callbacks. +stopProviding :: EventProvider a -> IO () +stopProviding (EventProvider mvar) = + modifyMVar_ mvar (\(_,cbs) -> return (NoEvent,cbs)) + +getEPfromRV :: (ReactiveValueRead a b IO) => a -> IO (EventProvider b) +getEPfromRV rv = do + ep <- newEventProvider . Just =<< reactiveValueRead rv + (Event <^> rv) =:> ep + return ep + +instance ReactiveValueRead (EventProvider a) (Event a) IO where + reactiveValueRead (EventProvider mvar) = + modifyMVar mvar $ \(mval,cbs) -> return ((NoEvent,cbs), mval) + reactiveValueOnCanRead (EventProvider mvar) io = + modifyMVar_ mvar $ \(mval,cbs) -> return (mval, cbs ++ [io]) + +instance ReactiveValueWrite (EventProvider a) (Event a) IO where + reactiveValueWrite (EventProvider mvar) val = do + modifyMVar_ mvar (\(_,cbs) -> return (val,cbs)) + readMVar mvar >>= sequence_ . snd + +instance ReactiveValueReadWrite (EventProvider a) (Event a) IO where diff --git a/src/RMCA/GUI/Board.hs b/src/RMCA/GUI/Board.hs index c167cd5..4c36bd4 100644 --- a/src/RMCA/GUI/Board.hs +++ b/src/RMCA/GUI/Board.hs @@ -14,10 +14,10 @@ module RMCA.GUI.Board ( GUICell (..) , actualTile ) where +import Control.Arrow import Control.Monad import Data.Array import Data.Array.MArray -import qualified Data.Bifunctor as BF import Data.Board.GameBoardIO import Data.CBMVar import Data.Maybe @@ -33,8 +33,8 @@ import Graphics.UI.Gtk.Board.TiledBoard hiding ) import qualified Graphics.UI.Gtk.Board.TiledBoard as BIO import Paths_RMCA -import RMCA.Global.Clock import RMCA.GUI.HelpersRewrite +import RMCA.IOClockworks import RMCA.Semantics newtype GUIBoard = GUIBoard { toGS :: GameState Int Tile Player GUICell } @@ -172,7 +172,7 @@ initGame = do -- Initializes a readable RV for the board and an readable-writable RV -- for the playheads. Also installs some handlers for pieces modification. -initBoardRV :: TickableClock +initBoardRV :: IOTick -> BIO.Board Int Tile (Player,GUICell) -> IO ( ReactiveFieldRead IO Board , Array Pos (ReactiveFieldWrite IO GUICell) @@ -184,8 +184,8 @@ initBoardRV tc board@BIO.Board { boardPieces = (GameBoard gArray) } = do getterB = do (boardArray :: [((Int,Int),Maybe (Player,GUICell))]) <- getAssocs gArray let board = makeBoard $ - map (BF.first fromGUICoords . - BF.second ((\(_,c) -> (cellAction c,repeatCount c)) . + map (first fromGUICoords . + second ((\(_,c) -> (cellAction c,repeatCount c)) . fromJust)) $ filter (isJust . snd) boardArray return board diff --git a/src/RMCA/GUI/LayerSettings.hs b/src/RMCA/GUI/LayerSettings.hs index 7080c71..189a9df 100644 --- a/src/RMCA/GUI/LayerSettings.hs +++ b/src/RMCA/GUI/LayerSettings.hs @@ -11,7 +11,7 @@ import Graphics.UI.Gtk import Graphics.UI.Gtk.Reactive import RMCA.Auxiliary import RMCA.GUI.NoteSettings -import RMCA.Layer.Layer +import RMCA.Layer.LayerConf import RMCA.MCBMVar import RMCA.Semantics import RMCA.Translator.Instruments @@ -32,14 +32,12 @@ mkVScale s adj = do boxPackStart hBox boxScale PackNatural 0 return (hBox,boxScale) -layerSettings :: (ReactiveValueReadWrite board - (M.IntMap ([Note],[Message])) IO) => - board - -> IO ( VBox - , MCBMVar Layer - , MCBMVar Int +layerSettings :: IO ( VBox + , MCBMVar StaticLayerConf + , MCBMVar DynLayerConf + , MCBMVar SynthConf ) -layerSettings boardQueue = do +layerSettings = do ------------------------------------------------------------------------------ -- GUI Boxes ------------------------------------------------------------------------------ @@ -122,42 +120,49 @@ layerSettings boardQueue = do lookup ins $ map swap instrumentIndex instrumentComboRV = bijection (indexToInstr, instrToIndex) `liftRW` comboBoxIndexRV instrumentCombo + layVolumeRV = liftRW (bijection (floor, fromIntegral)) $ + scaleValueReactive layVolumeScale - instrMCBMVar <- newMCBMVar =<< reactiveValueRead instrumentComboRV - layPitchRV <- newCBMVarRW 1 + synthMCBMVar <- newMCBMVar + =<< reactiveValueRead (liftR2 SynthConf layVolumeRV instrumentComboRV) + layPitchRV <- newCBMVarRW 1 let strengthRV = floatConv $ scaleValueReactive layStrengthScale - bpbRV = spinButtonValueIntReactive bpbButton - layVolumeRV = liftRW (bijection (floor, fromIntegral)) $ - scaleValueReactive layVolumeScale - f2 d p s bpb v = Layer { layerBeat = d - , relPitch = p - , strength = s - , beatsPerBar = bpb - , volume = v - } - - layerMCBMVar <- newMCBMVar =<< reactiveValueRead - (liftR5 f2 layBeatRV layPitchRV strengthRV bpbRV layVolumeRV) - - reactiveValueOnCanRead layerMCBMVar $ postGUIAsync $ do - nLayer <- reactiveValueRead layerMCBMVar - reactiveValueWriteOnNotEq layBeatRV $ layerBeat nLayer - reactiveValueWriteOnNotEq layPitchRV $ relPitch nLayer - reactiveValueWriteOnNotEq strengthRV $ strength nLayer - reactiveValueWriteOnNotEq bpbRV $ beatsPerBar nLayer - reactiveValueWriteOnNotEq layVolumeRV $ volume nLayer + + dynMCBMVar <- newMCBMVar + =<< reactiveValueRead (liftR3 DynLayerConf layBeatRV layPitchRV strengthRV) + + let bpbRV = spinButtonValueIntReactive bpbButton + statMCBMVar <- newMCBMVar + =<< reactiveValueRead (liftR StaticLayerConf bpbRV) + + reactiveValueOnCanRead dynMCBMVar $ postGUIAsync $ do + nDyn <- reactiveValueRead dynMCBMVar + reactiveValueWriteOnNotEq layBeatRV $ layerBeat nDyn + reactiveValueWriteOnNotEq layPitchRV $ relPitch nDyn + reactiveValueWriteOnNotEq strengthRV $ strength nDyn + + reactiveValueOnCanRead statMCBMVar $ postGUIAsync $ do + nStat <- reactiveValueRead statMCBMVar + reactiveValueWriteOnNotEq bpbRV $ beatsPerBar nStat + + reactiveValueOnCanRead synthMCBMVar $ do + nSynth <- reactiveValueRead synthMCBMVar + reactiveValueWriteOnNotEq layVolumeRV $ volume nSynth + reactiveValueWriteOnNotEq instrumentComboRV $ instrument nSynth syncRightOnLeftWithBoth (\nt ol -> ol { layerBeat = nt }) - layBeatRV layerMCBMVar + layBeatRV dynMCBMVar syncRightOnLeftWithBoth (\np ol -> ol { relPitch = np }) - layPitchRV layerMCBMVar + layPitchRV dynMCBMVar syncRightOnLeftWithBoth (\ns ol -> ol { strength = ns }) - strengthRV layerMCBMVar + strengthRV dynMCBMVar syncRightOnLeftWithBoth (\nb ol -> ol { beatsPerBar = nb}) - bpbRV layerMCBMVar + bpbRV statMCBMVar syncRightOnLeftWithBoth (\nv ol -> ol { volume = nv }) - layVolumeRV layerMCBMVar + layVolumeRV synthMCBMVar + syncRightOnLeftWithBoth (\ni ol -> ol { instrument = ni }) + instrumentComboRV synthMCBMVar {- reactiveValueOnCanRead layVolumeRV $ do @@ -166,4 +171,4 @@ layerSettings boardQueue = do let vol' = floor ((fromIntegral vol / 100) * 127) reactiveValueAppend boardQueue ([],[Volume (mkChannel chan) vol']) -} - return (layerSettingsVBox, layerMCBMVar, instrMCBMVar) + return (layerSettingsVBox, statMCBMVar, dynMCBMVar, synthMCBMVar) diff --git a/src/RMCA/GUI/MultiBoard.hs b/src/RMCA/GUI/MultiBoard.hs index e7c26cf..9d14b18 100644 --- a/src/RMCA/GUI/MultiBoard.hs +++ b/src/RMCA/GUI/MultiBoard.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TupleSections #-} module RMCA.GUI.MultiBoard where @@ -15,37 +15,42 @@ import Graphics.UI.Gtk.Board.TiledBoard hiding (Board) import Graphics.UI.Gtk.Layout.BackgroundContainer import Graphics.UI.Gtk.Reactive.Gtk2 import RMCA.Auxiliary -import RMCA.Global.Clock import RMCA.GUI.Board -import RMCA.Layer.Layer +import RMCA.IOClockworks +import RMCA.Layer.LayerConf import RMCA.MCBMVar import RMCA.Semantics +import RMCA.Translator.Message maxLayers :: Int maxLayers = 16 createNotebook :: ( ReactiveValueRead addLayer () IO , ReactiveValueRead rmLayer () IO + , ReactiveValueReadWrite board (M.IntMap ([Note],[Message])) IO ) => - TickableClock + board + -> IOTick -> addLayer -> rmLayer - -> MCBMVar Layer - -> MCBMVar InstrumentNo + -> MCBMVar StaticLayerConf + -> MCBMVar DynLayerConf + -> MCBMVar SynthConf -> MCBMVar GUICell -> IO ( Notebook , ReactiveFieldRead IO (M.IntMap Board) - , ReactiveFieldRead IO (M.IntMap Layer) + , ReactiveFieldRead IO (M.IntMap LayerConf) , ReactiveFieldRead IO (M.IntMap (ReactiveFieldWrite IO [PlayHead])) ) -createNotebook tc addLayerRV rmLayerRV layerMCBMVar instrMCBMVar guiCellMCBMVar = do +createNotebook boardQueue tc addLayerRV rmLayerRV + statMCBMVar dynMCBMVar synthMCBMVar guiCellMCBMVar = do n <- notebookNew let curPageRV = ReactiveFieldReadWrite setter getter notifier where (ReactiveFieldRead getter _) = notebookGetCurrentPagePassive n -- afterSwitchPage is deprecated but switchPage gets us -- the old page number and not the new one and using - -- afterSwitchPage doesn't trigger a warning. + -- afterSwitchPage doesn't trigger a warning so⦠setter = postGUIAsync . notebookSetCurrentPage n notifier io = void $ afterSwitchPage n (const io) @@ -116,20 +121,30 @@ createNotebook tc addLayerRV rmLayerRV layerMCBMVar instrMCBMVar guiCellMCBMVar reactiveValueRead pageChanRV >>= reactiveValueWrite pageChanRV . (\pc -> pc ++ [foundHole pc]) - layerMapRV <- newCBMVarRW $ M.insert fstP defaultLayer M.empty - let updateLayer cp = do - nLayer <- reactiveValueRead layerMCBMVar - reactiveValueRead layerMapRV >>= - reactiveValueWrite layerMapRV . M.insert cp nLayer - - layerHidMVar <- newEmptyMVar - instrHidMVar <- newEmptyMVar + layerMapRV <- newCBMVarRW $ M.insert fstP defaultLayerConf M.empty - installCallbackMCBMVar layerMCBMVar - (reactiveValueRead curChanRV >>= updateLayer) >>= putMVar layerHidMVar - installCallbackMCBMVar instrMCBMVar - (reactiveValueRead curChanRV >>= updateInstr) >>= putMVar instrHidMVar + let updateDynLayer cp = do + nDyn <- reactiveValueRead dynMCBMVar + reactiveValueRead layerMapRV >>= + reactiveValueWrite layerMapRV . + M.adjust (\(stat,_,synth) -> (stat,nDyn,synth)) cp + updateSynth cp = do + synthState <- reactiveValueRead synthMCBMVar + reactiveValueAppend boardQueue $ + M.singleton cp $ ([],) $ synthMessage cp synthState + updateStatLayer _ = return ()--undefined + + statHidMVar <- newEmptyMVar + dynHidMVar <- newEmptyMVar + synthHidMVar <- newEmptyMVar + + installCallbackMCBMVar statMCBMVar + (reactiveValueRead curChanRV >>= updateStatLayer) >>= putMVar statHidMVar + installCallbackMCBMVar dynMCBMVar + (reactiveValueRead curChanRV >>= updateDynLayer) >>= putMVar dynHidMVar + installCallbackMCBMVar synthMCBMVar + (reactiveValueRead curChanRV >>= updateSynth) >>= putMVar synthHidMVar ------------------------------------------------------------------------------ -- Following boards @@ -155,7 +170,7 @@ createNotebook tc addLayerRV rmLayerRV layerMCBMVar instrMCBMVar guiCellMCBMVar reactiveValueRead chanMapRV >>= reactiveValueWrite chanMapRV . M.insert newCP (nBoardRV,nPieceArrRV,nPhRV) reactiveValueRead layerMapRV >>= - reactiveValueWrite layerMapRV . M.insert newCP defaultLayer + reactiveValueWrite layerMapRV . M.insert newCP defaultLayerConf --reactiveValueWrite curPageRV newP reactiveValueWrite pageChanRV (pChan ++ [newCP]) @@ -178,26 +193,32 @@ createNotebook tc addLayerRV rmLayerRV layerMCBMVar instrMCBMVar guiCellMCBMVar reactiveValueRead chanMapRV >>= reactiveValueWrite chanMapRV . M.delete oldCP + reactiveValueRead layerMapRV >>= reactiveValueWrite layerMapRV . M.delete oldCP - --updateRV curPageRV - widgetShowAll n return () reactiveValueOnCanRead curChanRV $ do cp <- reactiveValueRead curChanRV when (cp >= 0) $ do - takeMVar layerHidMVar >>= removeCallbackMCBMVar layerMCBMVar - takeMVar instrHidMVar >>= removeCallbackMCBMVar instrMCBMVar + takeMVar dynHidMVar >>= removeCallbackMCBMVar dynMCBMVar + takeMVar statHidMVar >>= removeCallbackMCBMVar statMCBMVar + takeMVar synthHidMVar >>= removeCallbackMCBMVar synthMCBMVar layerMap <- reactiveValueRead layerMapRV let mSelLayer = M.lookup cp layerMap when (isNothing mSelLayer) $ error "Not found selected layer!" let selLayer = fromJust mSelLayer - reactiveValueWrite layerMCBMVar selLayer - installCallbackMCBMVar layerMCBMVar (updateLayer cp) >>= - putMVar layerHidMVar + reactiveValueWrite dynMCBMVar (dynConf selLayer) + installCallbackMCBMVar dynMCBMVar (updateDynLayer cp) >>= + putMVar dynHidMVar + reactiveValueWrite statMCBMVar (staticConf selLayer) + installCallbackMCBMVar statMCBMVar (updateStatLayer cp) >>= + putMVar statHidMVar + reactiveValueWrite synthMCBMVar (synthConf selLayer) + installCallbackMCBMVar synthMCBMVar (updateSynth cp) >>= + putMVar synthHidMVar return () oldCurChanRV <- newCBMVarRW =<< reactiveValueRead curChanRV diff --git a/src/RMCA/Global/Clock.hs b/src/RMCA/Global/Clock.hs index 481101b..3e40252 100644 --- a/src/RMCA/Global/Clock.hs +++ b/src/RMCA/Global/Clock.hs @@ -4,15 +4,8 @@ module RMCA.Global.Clock ( AbsBeat , maxAbsBeat , metronome , tempoToQNoteIvl - , TickableClock - , newTickableClock - , tickClock ) where -import Control.Concurrent -import Control.Monad -import Data.CBMVar -import Data.ReactiveValue import FRP.Yampa import RMCA.Auxiliary import RMCA.Semantics @@ -34,47 +27,3 @@ metronome = accumBy (\pb _ -> nextBeatNo maxAbsBeat pb) 1 <<< -- Tempo is the number of quarter notes per minute. tempoToQNoteIvl :: Tempo -> DTime tempoToQNoteIvl = (15/) . fromIntegral - -type TickingClock = (CBMVar (), ThreadId) - --- Make a clock that will execute any IO when it updates. -mkClockGeneric :: IO () -> DTime -> IO TickingClock -mkClockGeneric io d = do - n <- newCBMVar () - tid <- forkIO $ forever $ do - threadDelay dInt - modifyCBMVar n return - io - return (n, tid) - where dInt = floor $ d * 1000 - --- Ticking clock in the IO monad, sending callbacks every t milliseconds. -mkClock :: DTime -> IO TickingClock -mkClock = mkClockGeneric (return ()) - --- For debugging purposes. -mkClockDebug :: DTime -> IO TickingClock -mkClockDebug = mkClockGeneric (putStrLn "Ping !") - -clockRV :: TickingClock -> ReactiveFieldRead IO ThreadId -clockRV (mvar, tid) = ReactiveFieldRead (return tid) - (installCallbackCBMVar mvar) - -mkClockRV :: DTime -> IO (ReactiveFieldRead IO ThreadId) -mkClockRV d = clockRV <$> mkClock d - -stopClock :: TickingClock -> IO () -stopClock (_,t) = killThread t - --- | A clock that can be written to. -newtype TickableClock = TickableClock (CBMVar ()) - -tickClock :: TickableClock -> IO () -tickClock (TickableClock cl) = writeCBMVar cl () - -newTickableClock :: IO TickableClock -newTickableClock = TickableClock <$> newCBMVar () - -instance ReactiveValueRead TickableClock () IO where - reactiveValueRead _ = return () - reactiveValueOnCanRead (TickableClock tc) = installCallbackCBMVar tc diff --git a/src/RMCA/IOClockworks.hs b/src/RMCA/IOClockworks.hs new file mode 100644 index 0000000..376a447 --- /dev/null +++ b/src/RMCA/IOClockworks.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module RMCA.IOClockworks ( IOMetronome + , mkClockGeneric + , mkClock + , mkClockDebug + , stopIOMetronome + , IOTick + , newIOTick + , tickIOTick + ) where + +import Control.Concurrent +import Control.Monad +import Data.ReactiveValue +import FRP.Yampa (DTime) + +-- A reactive value carrying unit that ticks at a regular pace. On a +-- tick, it executes IO actions attached to it with +-- reactiveValueOnCanRead. +newtype IOMetronome = IOMetronome (MVar [IO ()], ThreadId) + +instance ReactiveValueRead IOMetronome () IO where + reactiveValueRead _ = return () + reactiveValueOnCanRead (IOMetronome (mvar,_)) io = + modifyMVar_ mvar (\cbs -> return (cbs ++ [io])) + +-- Make a clock that will execute any IO when it updates. +mkClockGeneric :: IO () -> DTime -> IO IOMetronome +mkClockGeneric io d = do + n <- newMVar [] + tid <- forkIO $ forever $ do + threadDelay dInt + readMVar n >>= sequence_ + io + return $ IOMetronome (n, tid) + where dInt = floor $ d * 1000 + +-- Ticking clock in the IO monad, sending callbacks every t milliseconds. +mkClock :: DTime -> IO IOMetronome +mkClock = mkClockGeneric (return ()) + +-- For debugging purposes. +mkClockDebug :: DTime -> IO IOMetronome +mkClockDebug = mkClockGeneric (putStrLn "Ping!") + +stopIOMetronome :: IOMetronome -> IO () +stopIOMetronome (IOMetronome (_,tid)) = killThread tid + +newtype IOTick = IOTick (MVar [IO ()]) + +newIOTick :: IO IOTick +newIOTick = IOTick <$> newMVar [] + +tickIOTick :: IOTick -> IO () +tickIOTick (IOTick mvar) = readMVar mvar >>= sequence_ + +instance ReactiveValueRead IOTick () IO where + reactiveValueRead _ = return () + reactiveValueOnCanRead (IOTick mvar) io = + modifyMVar_ mvar (\cbs -> return (cbs ++ [io])) diff --git a/src/RMCA/Layer/Board.hs b/src/RMCA/Layer/Board.hs index d17674e..aaeb37c 100644 --- a/src/RMCA/Layer/Board.hs +++ b/src/RMCA/Layer/Board.hs @@ -81,20 +81,6 @@ boardSF (StaticLayerConf { beatsPerBar = bpb }) = ---------------------------------------------------------------------------- -- 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,DynLayerConf,Event SwitchBoard) (Event [Note], [PlayHead])) diff --git a/src/RMCA/Layer/LayerConf.hs b/src/RMCA/Layer/LayerConf.hs index 5f22926..24b3039 100644 --- a/src/RMCA/Layer/LayerConf.hs +++ b/src/RMCA/Layer/LayerConf.hs @@ -2,12 +2,14 @@ module RMCA.Layer.LayerConf where +import Data.IntMap (IntMap) import Data.Ratio import Data.ReactiveValue import FRP.Yampa import RMCA.Auxiliary import RMCA.Global.Clock import RMCA.Semantics +import RMCA.Translator.Message -- | Datatype representing dynamically modifiable characteristics for a layer. data DynLayerConf = DynLayerConf { layerBeat :: Rational @@ -24,6 +26,13 @@ data SynthConf = SynthConf { volume :: Int , instrument :: InstrumentNo } deriving (Show, Read, Eq) +synthMessage :: Int -> SynthConf -> [Message] +synthMessage chan (SynthConf { volume = v + , instrument = i + }) = [ Volume (mkChannel chan) v + , Instrument (mkChannel chan) (mkProgram i) + ] + type LayerConf = (StaticLayerConf, DynLayerConf, SynthConf) dynConf :: LayerConf -> DynLayerConf diff --git a/src/RMCA/Main.hs b/src/RMCA/Main.hs index 0375b48..b2e91df 100644 --- a/src/RMCA/Main.hs +++ b/src/RMCA/Main.hs @@ -11,7 +11,8 @@ import Graphics.UI.Gtk.Board.BoardLink import Graphics.UI.Gtk.Layout.BackgroundContainer import Hails.Yampa import RMCA.Auxiliary -import RMCA.Configuration +--import RMCA.Configuration +import RMCA.EventProvider import RMCA.Global.Clock import RMCA.GUI.Board import RMCA.GUI.Buttons @@ -19,10 +20,12 @@ import RMCA.GUI.LayerSettings import RMCA.GUI.MainSettings import RMCA.GUI.MultiBoard import RMCA.GUI.NoteSettings +import RMCA.IOClockworks import RMCA.Layer.Board -import RMCA.Layer.Layer +import RMCA.Layer.LayerConf import RMCA.Semantics import RMCA.Translator.Jack +import RMCA.YampaReactive main :: IO () main = do @@ -53,45 +56,59 @@ main = do boxPackEnd settingsBox buttonBox PackNatural 0 boardQueue <- newCBMVarRW mempty - (layerSettingsVBox, layerMCBMVar, instrMCBMVar) <- layerSettings boardQueue + (layerSettingsVBox, statMCBMVar, dynMCBMVar, synthMCBMVar) <- layerSettings boxPackStart settingsBox layerSettingsVBox PackNatural 0 laySep <- hSeparatorNew boxPackStart settingsBox laySep PackNatural 0 (noteSettingsBox, guiCellMCBMVar) <- noteSettingsBox - tc <- newTickableClock - (boardCont, boardMapRV, layerMapRV, instrMapRV, phRVMapRV) <- - createNotebook tc addLayerRV rmLayerRV layerMCBMVar instrMCBMVar guiCellMCBMVar + tc <- newIOTick + (boardCont, boardMapRV, layerMapRV, phRVMapRV) <- + createNotebook boardQueue tc addLayerRV rmLayerRV + statMCBMVar dynMCBMVar synthMCBMVar guiCellMCBMVar boxPackStart mainBox boardCont PackNatural 0 - handleSaveLoad tempoRV boardMapRV layerMapRV instrMapRV phRVMapRV - addLayerRV rmLayerRV confSaveRV confLoadRV + --handleSaveLoad tempoRV boardMapRV layerMapRV instrMapRV phRVMapRV + --addLayerRV rmLayerRV confSaveRV confLoadRV - boardRunRV <- newCBMVarRW BoardStop - reactiveValueOnCanRead playRV $ reactiveValueWrite boardRunRV BoardStart - reactiveValueOnCanRead stopRV $ reactiveValueWrite boardRunRV BoardStop + funBoardRunRV <- getEPfromRV =<< newCBMVarRW (const StopBoard) + isStartMVar <- newMVar False + reactiveValueOnCanRead playRV $ do + isStarted <- readMVar isStartMVar + if isStarted + then reactiveValueWrite funBoardRunRV $ Event $ const ContinueBoard + else do modifyMVar_ isStartMVar $ const $ return True + reactiveValueWrite funBoardRunRV $ Event StartBoard + reactiveValueOnCanRead stopRV $ do + modifyMVar_ isStartMVar $ const $ return False + reactiveValueWrite funBoardRunRV $ Event $ const StopBoard boardMap <- reactiveValueRead boardMapRV layerMap <- reactiveValueRead layerMapRV tempo <- reactiveValueRead tempoRV let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV - inRV = liftR4 (\bm lm t br -> (t,br,M.intersectionWith (,) bm lm)) - boardMapRV layerMapRV tempoRV' boardRunRV - initSig <- reactiveValueRead inRV - (inBoard, outBoard) <- yampaReactiveDual initSig (boardRun initSig) + 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 + --(inBoard, outBoard) <- yampaReactiveDual initSig (boardRun + --initSig) + outBoard <- yampaReactiveFrom (boardRun initSig) inRV --reactiveValueOnCanRead inRV (reactiveValueRead inRV >>= print . M.keys) - inRV =:> inBoard + --inRV =:> inBoard reactiveValueOnCanRead outBoard $ do out <- reactiveValueRead outBoard --print out phRVMap <- reactiveValueRead phRVMapRV - let eventsMap = M.filter isEvent out + let noteMap = M.map fromEvent $ M.filter isEvent $ M.map fst out writePh chan val = fromMaybeM_ $ (`reactiveValueWrite` val) <$> M.lookup chan phRVMap - noteMap = M.map (eventToList . snd . splitE) out - sequence_ $ M.mapWithKey writePh $ - M.map (fst . fromEvent) $ M.filter isEvent out + sequence_ $ M.mapWithKey writePh $ M.map snd out reactiveValueAppend boardQueue $ M.map (,[]) noteMap diff --git a/src/RMCA/Translator/Jack.hs b/src/RMCA/Translator/Jack.hs index 76f9de7..cd4f84b 100644 --- a/src/RMCA/Translator/Jack.hs +++ b/src/RMCA/Translator/Jack.hs @@ -16,6 +16,7 @@ import qualified Foreign.C.Error as E import Graphics.UI.Gtk import RMCA.Auxiliary import RMCA.Global.Clock +import RMCA.IOClockworks import RMCA.Semantics import RMCA.Translator.Message import RMCA.Translator.RV @@ -48,7 +49,7 @@ handleErrorJack _ = postGUIAsync $ do jackSetup :: (ReactiveValueReadWrite board (M.IntMap ([Note],[Message])) IO , ReactiveValueRead tempo Tempo IO) => - TickableClock + IOTick -> board -> tempo -> IO () @@ -73,7 +74,7 @@ jackCallBack :: ( ReactiveValueReadWrite toProcess [(Frames, RawMessage)] IO , ReactiveValueReadWrite board (M.IntMap ([Note],[Message])) IO , ReactiveValueRead tempo Tempo IO) => - TickableClock + IOTick -> JMIDI.Port Jack.Input -> JMIDI.Port Jack.Output -> toProcess @@ -97,5 +98,5 @@ jackCallBack tc input output toProcessRV boardQueue tempoRV putStrLn ("Out: " ++ show (map fst go)) reactiveValueWrite outMIDIRV go reactiveValueWrite toProcessRV old - tickClock tc + tickIOTick tc -------------- diff --git a/src/RMCA/YampaReactive.hs b/src/RMCA/YampaReactive.hs new file mode 100644 index 0000000..f82d199 --- /dev/null +++ b/src/RMCA/YampaReactive.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-} + +module RMCA.YampaReactive where + +import Data.ReactiveValue +import FRP.Yampa +import Hails.Yampa +import RMCA.IOClockworks + +yampaReactiveFrom :: (ReactiveValueRead c a IO) => SF a b -> c + -> IO (ReactiveFieldRead IO b) +yampaReactiveFrom sf rv = do + init <- reactiveValueRead rv + (input,output) <- yampaReactiveDual init sf + rv =:> input + return output + +yampaReactiveWithMetronome :: (ReactiveValueRead c a IO) => + a -> SF a b -> c -> DTime + -> IO (ReactiveFieldRead IO b) +yampaReactiveWithMetronome init sf rv dt = do + clock <- mkClock dt + (input,output) <- yampaReactiveDual init sf + rv =:> input + reactiveValueOnCanRead clock $ + reactiveValueRead rv >>= reactiveValueWrite input + return output + +yampaReactiveWithTick :: (ReactiveValueRead c a IO) => + a -> SF a b -> c -> IOTick + -> IO (ReactiveFieldRead IO b) +yampaReactiveWithTick init sf rv tick = do + (input,output) <- yampaReactiveDual init sf + rv =:> input + reactiveValueOnCanRead tick $ + reactiveValueRead rv >>= reactiveValueWrite input + return output -- 2.47.0