-- | 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
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'.
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
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)
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
--- /dev/null
+{-# 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
, 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
)
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 }
-- 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)
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
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
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
------------------------------------------------------------------------------
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
let vol' = floor ((fromIntegral vol / 100) * 127)
reactiveValueAppend boardQueue ([],[Volume (mkChannel chan) vol'])
-}
- return (layerSettingsVBox, layerMCBMVar, instrMCBMVar)
+ return (layerSettingsVBox, statMCBMVar, dynMCBMVar, synthMCBMVar)
-{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TupleSections #-}
module RMCA.GUI.MultiBoard where
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)
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
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])
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
, 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
-- 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
--- /dev/null
+{-# 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]))
----------------------------------------------------------------------------
-- 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]))
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
, 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
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
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
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
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
jackSetup :: (ReactiveValueReadWrite board
(M.IntMap ([Note],[Message])) IO
, ReactiveValueRead tempo Tempo IO) =>
- TickableClock
+ IOTick
-> board
-> tempo
-> IO ()
, ReactiveValueReadWrite board
(M.IntMap ([Note],[Message])) IO
, ReactiveValueRead tempo Tempo IO) =>
- TickableClock
+ IOTick
-> JMIDI.Port Jack.Input
-> JMIDI.Port Jack.Output
-> toProcess
putStrLn ("Out: " ++ show (map fst go))
reactiveValueWrite outMIDIRV go
reactiveValueWrite toProcessRV old
- tickClock tc
+ tickIOTick tc
--------------
--- /dev/null
+{-# 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
sourcephile / git / tmp / julm / arpeggigon.git / commitdiff