Commit a0697da3 by Guerric Chupin

Board queue atomic.

parent 9ce6e916
......@@ -69,7 +69,7 @@ intersectionWith3 f m n p =
-- | = Yampa
countTo :: (Integral b, Ord b) => b -> SF (Event a) (Event b)
countTo :: (Integral 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'.
......@@ -139,17 +139,6 @@ newCBMVarRW val = do
notifier = installCallbackCBMVar mvar
return $ ReactiveFieldReadWrite setter getter notifier
-- | Appends a value to a reactive value.
reactiveValueAppend :: (Monoid b, ReactiveValueReadWrite a b m) =>
a -> b -> m ()
reactiveValueAppend rv v = do ov <- reactiveValueRead rv
reactiveValueWrite rv (ov `mappend` v)
-- | Writes 'mempty' to a reactive value containing a 'Monoid'.
reactiveValueEmpty :: (Monoid b, ReactiveValueReadWrite a b m) =>
a -> m ()
reactiveValueEmpty rv = reactiveValueWrite rv mempty
-- | Writes a value to a reactive value if the value is different from the one already in the reactive value.
reactiveValueWriteOnNotEq :: ( Eq b
, ReactiveValueReadWrite a b m) =>
......
......@@ -2,20 +2,17 @@
module RMCA.GUI.LayerSettings where
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 RMCA.Auxiliary
import RMCA.GUI.NoteSettings
import RMCA.Layer.LayerConf
import RMCA.MCBMVar
import RMCA.Semantics
import RMCA.Translator.Instruments
import RMCA.Translator.Message
import Data.Maybe
import Data.ReactiveValue
import Data.String
import Data.Tuple
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Reactive
import RMCA.Auxiliary
import RMCA.GUI.NoteSettings
import RMCA.Layer.LayerConf
import RMCA.MCBMVar
import RMCA.Translator.Instruments
floatConv :: (ReactiveValueReadWrite a b m,
Real c, Real b, Fractional c, Fractional b) =>
......@@ -33,6 +30,7 @@ mkVScale s adj = do
return (hBox,boxScale)
layerSettings :: IO ( VBox
, ReactiveFieldWrite IO Bool
, MCBMVar StaticLayerConf
, MCBMVar DynLayerConf
, MCBMVar SynthConf
......@@ -70,7 +68,7 @@ layerSettings = do
(`lookup` symbolString) <$> reactiveValueRead layBeatRV-}
--labelSetAngle layBeatLabel 90
labelSetLineWrap layBeatLabel True
let layBeatLabelRV = labelTextReactive layBeatLabel
--let layBeatLabelRV = labelTextReactive layBeatLabel
boxPackStart layerSettingsBox layBeatBox PackRepel 0
auxLayBeatBox <- vBoxNew False 0
boxPackEnd layBeatBox auxLayBeatBox PackRepel 0
......@@ -99,7 +97,7 @@ layerSettings = do
bpbBox <- vBoxNew False 0
boxPackStart layerSettingsBox' bpbBox PackRepel 0
bpbLabel <- labelNew (Just "Beat per bar")
bpbLabel <- labelNew (Just "Beats per bar")
labelSetLineWrap bpbLabel True
bpbAdj <- adjustmentNew 4 1 16 1 1 0
bpbButton <- spinButtonNew bpbAdj 1 0
......@@ -114,7 +112,7 @@ layerSettings = do
boxPackStart layerSettingsBox' repeatBox PackRepel 0
repeatLabel <- labelNew (Just "Repeat count")
labelSetLineWrap repeatLabel True
repeatAdj <- adjustmentNew 0 0 100 1 1 0
repeatAdj <- adjustmentNew 0 0 (fromIntegral (maxBound :: Int)) 1 1 0
repeatButton <- spinButtonNew repeatAdj 1 0
auxRepeatBox <- vBoxNew False 0
centerAl' <- alignmentNew 0.5 0.5 0 0
......@@ -159,8 +157,22 @@ layerSettings = do
repeatRV' = spinButtonValueIntReactive repeatButton
repeatRV = liftR2 (\act r -> if act then Just r else Nothing)
repeatCheckRV repeatRV'
repeatSensitive = widgetSensitiveReactive repeatButton
repeatCheckSensitive = widgetSensitiveReactive repeatCheckButton
bpbSensitiveRV = widgetSensitiveReactive bpbButton
statConfSensitive =
liftW2 (\b -> (b,b)) bpbSensitiveRV repeatCheckSensitive
{-
reactiveValueOnCanRead bpbSensitiveRV $ do
issens <- reactiveValueRead repeatCheckSensitive
if issens
then reactiveValueRead repeatCheckRV >>=
reactiveValueWrite repeatSensitive
else reactiveValueWrite repeatSensitive False
-}
repeatCheckRV =:> repeatSensitive
reactiveValueWrite repeatCheckRV False
--reactiveValueOnCanRead repeatCheckRV $ do
reactiveValueWrite repeatSensitive False
statMCBMVar <- newMCBMVar
=<< reactiveValueRead (liftR2 StaticLayerConf bpbRV repeatRV)
......@@ -193,11 +205,6 @@ layerSettings = do
syncRightOnLeftWithBoth (\ni ol -> ol { instrument = ni })
instrumentComboRV synthMCBMVar
{-
reactiveValueOnCanRead layVolumeRV $ do
vol <- reactiveValueRead layVolumeRV
chan <- reactiveValueRead chanRV
let vol' = floor ((fromIntegral vol / 100) * 127)
reactiveValueAppend boardQueue ([],[Volume (mkChannel chan) vol'])
-}
return (layerSettingsVBox, statMCBMVar, dynMCBMVar, synthMCBMVar)
return ( layerSettingsVBox
, statConfSensitive
, statMCBMVar, dynMCBMVar, synthMCBMVar)
......@@ -19,6 +19,7 @@ import RMCA.GUI.Board
import RMCA.IOClockworks
import RMCA.Layer.LayerConf
import RMCA.MCBMVar
import RMCA.ReactiveValueAtomicUpdate
import RMCA.Semantics
import RMCA.Translator.Message
......@@ -27,7 +28,7 @@ maxLayers = 16
createNotebook :: ( ReactiveValueRead addLayer () IO
, ReactiveValueRead rmLayer () IO
, ReactiveValueReadWrite board (M.IntMap ([Note],[Message])) IO
, ReactiveValueAtomicUpdate board (M.IntMap ([Note],[Message])) IO
) =>
board
-> IOTick
......
......@@ -3,18 +3,14 @@
module Main where
import Control.Concurrent
import qualified Data.IntMap as M
import qualified Data.IntMap as M
import Data.ReactiveValue
import FRP.Yampa
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Board.BoardLink
import Graphics.UI.Gtk.Layout.BackgroundContainer
import Hails.Yampa
import RMCA.Auxiliary
--import RMCA.Configuration
import Data.CBRef
import RMCA.EventProvider
import RMCA.Global.Clock
import RMCA.GUI.Board
import RMCA.GUI.Buttons
import RMCA.GUI.LayerSettings
import RMCA.GUI.MainSettings
......@@ -22,8 +18,7 @@ import RMCA.GUI.MultiBoard
import RMCA.GUI.NoteSettings
import RMCA.IOClockworks
import RMCA.Layer.Board
import RMCA.Layer.LayerConf
import RMCA.Semantics
import RMCA.ReactiveValueAtomicUpdate
import RMCA.Translator.Jack
import RMCA.YampaReactive
......@@ -43,7 +38,7 @@ main = do
windowMaximize window
settingsBox <- vBoxNew False 0
boxPackEnd mainBox settingsBox PackNatural 0
boxPackEnd mainBox settingsBox PackGrow 0
(globalSettingsBox, tempoRV) <- globalSettings
boxPackStart settingsBox globalSettingsBox PackNatural 0
globalSep <- hSeparatorNew
......@@ -55,8 +50,8 @@ main = do
addLayerRV,rmLayerRV) <- getButtons
boxPackEnd settingsBox buttonBox PackNatural 0
boardQueue <- newCBMVarRW mempty
(layerSettingsVBox, statMCBMVar, dynMCBMVar, synthMCBMVar) <- layerSettings
boardQueue <- newCBRef mempty
(layerSettingsVBox, statConfSensitiveRV, statMCBMVar, dynMCBMVar, synthMCBMVar) <- layerSettings
boxPackStart settingsBox layerSettingsVBox PackNatural 0
laySep <- hSeparatorNew
boxPackStart settingsBox laySep PackNatural 0
......@@ -71,24 +66,31 @@ main = do
--handleSaveLoad tempoRV boardMapRV layerMapRV instrMapRV phRVMapRV
--addLayerRV rmLayerRV confSaveRV confLoadRV
boardStatusRV <- getEPfromRV =<< newCBMVarRW Stopped
boardStatusRV <- newCBMVarRW Stopped
reactiveValueOnCanRead boardStatusRV $ do
bs <- reactiveValueRead boardStatusRV
case bs of
Running -> reactiveValueWrite statConfSensitiveRV False
Stopped -> reactiveValueWrite statConfSensitiveRV True
boardStatusEP <- getEPfromRV boardStatusRV
isStartMVar <- newMVar False
reactiveValueOnCanRead playRV $ do
isStarted <- readMVar isStartMVar
if isStarted
then reactiveValueWrite boardStatusRV $ Event Running
then reactiveValueWrite boardStatusRV Running
else do modifyMVar_ isStartMVar $ const $ return True
reactiveValueWrite boardStatusRV $ Event Running
reactiveValueWrite boardStatusRV Running
reactiveValueOnCanRead stopRV $ do
modifyMVar_ isStartMVar $ const $ return False
reactiveValueWrite boardStatusRV $ Event Stopped
reactiveValueWrite boardStatusRV Stopped
boardMap <- reactiveValueRead boardMapRV
layerMap <- reactiveValueRead layerMapRV
tempo <- reactiveValueRead tempoRV
let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
jointedMapRV = liftR (fmap (\(x,y) -> (x,y,NoEvent))) $
liftR2 (M.intersectionWith (,)) boardMapRV layerMapRV
inRV = liftR3 (,,) tempoRV' boardStatusRV jointedMapRV
inRV = liftR3 (,,) tempoRV' boardStatusEP jointedMapRV
initSig <- reactiveValueRead layerMapRV
--(inBoard, outBoard) <- yampaReactiveDual initSig (boardRun
--initSig)
......
......@@ -6,17 +6,16 @@ module RMCA.Translator.Jack ( jackSetup
) where
import Control.Arrow
import Control.Concurrent.MVar
import qualified Control.Monad.Exception.Synchronous as Sync
import qualified Control.Monad.Trans.Class as Trans
import Data.CBRef
import Data.Foldable
import qualified Data.IntMap as M
import Data.ReactiveValue
import qualified Foreign.C.Error as E
import Graphics.UI.Gtk
import RMCA.Auxiliary
import RMCA.Global.Clock
import RMCA.IOClockworks
import RMCA.ReactiveValueAtomicUpdate
import RMCA.Semantics
import RMCA.Translator.Message
import RMCA.Translator.RV
......@@ -46,7 +45,7 @@ handleErrorJack _ = postGUIAsync $ do
-- Starts a default client with an input and an output port. Doesn't
-- do anything as such.
jackSetup :: (ReactiveValueReadWrite board
jackSetup :: (ReactiveValueAtomicUpdate board
(M.IntMap ([Note],[Message])) IO
, ReactiveValueRead tempo Tempo IO) =>
IOTick
......@@ -54,7 +53,7 @@ jackSetup :: (ReactiveValueReadWrite board
-> tempo
-> IO ()
jackSetup tc boardQueue tempoRV = Sync.resolveT handleErrorJack $ do
toProcessRV <- Trans.lift $ newCBMVarRW []
toProcessRV <- Trans.lift $ newCBRef []
Jack.withClientDefault rmcaName $ \client ->
Jack.withPort client outPortName $ \output ->
Jack.withPort client inPortName $ \input ->
......@@ -70,8 +69,8 @@ jackSetup tc boardQueue tempoRV = Sync.resolveT handleErrorJack $ do
-- them with value coming from the machine itself and stuff them into
-- the output port. When this function is not running, events are
-- processed.
jackCallBack :: ( ReactiveValueReadWrite toProcess [(Frames, RawMessage)] IO
, ReactiveValueReadWrite board
jackCallBack :: ( ReactiveValueAtomicUpdate toProcess [(Frames, RawMessage)] IO
, ReactiveValueAtomicUpdate board
(M.IntMap ([Note],[Message])) IO
, ReactiveValueRead tempo Tempo IO) =>
IOTick
......@@ -91,11 +90,11 @@ jackCallBack tc input output toProcessRV boardQueue tempoRV
tempo <- reactiveValueRead tempoRV
concat . toList . gatherMessages tempo nframesInt <$>
reactiveValueRead boardQueue >>= \bq ->
reactiveValueAppend toProcessRV bq >> putStrLn ("BoardQueue: " ++ show (map fst bq))
reactiveValueAppend toProcessRV bq-- >> putStrLn ("BoardQueue: " ++ show (map fst bq))
reactiveValueEmpty boardQueue
(go, old') <- schedule nframesInt <$> reactiveValueRead toProcessRV
let old = map (first (+ (- nframesInt))) old'
putStrLn ("Out: " ++ show (map fst go))
--putStrLn ("Out: " ++ show (map fst go))
reactiveValueWrite outMIDIRV go
reactiveValueWrite toProcessRV old
tickIOTick tc
......
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