Commit c29586e7 by Guerric Chupin

Reworks to the GUI

parent f37eeaf9
......@@ -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'.
......
......@@ -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
......
{-# 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
......@@ -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
......
......@@ -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)
{-# 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
......
......@@ -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
{-# 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]))
......@@ -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]))
......
......@@ -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
......
......@@ -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
......
......@@ -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
--------------
{-# 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