Commit 2ebf9b76 by Guerric Chupin

Greying out for static conf works.

parent 13066145
* Lots of things in IO actions (Jack.hs, Main.hs, etc.) should be
written as separate functions (especially on RVs).
* Able to move an inert piece in some unknown conditions. Which
shouldn't happend.
module RMCA.Auxiliary.Misc where
import Data.Maybe
import FRP.Yampa
-- |= General functions
-- | Reversed version of '(\<$\>)'.
(<$$>) :: (Functor f) => f a -> (a -> b) -> f b
(<$$>) = flip (<$>)
-- | Reversed version of '(<$)'.
($>) :: (Functor f) => f a -> b -> f b
($>) = flip (<$)
-- | @bound (min,max)@ behaves like identity if the supplied value is between @min@ and @max@, otherwise it is replaced either by @min@ or by @max@.
bound :: (Ord a) => (a, a) -> a -> a
bound (min, max) x
| x < min = min
| x > max = max
| otherwise = x
fromMaybeM_ :: (Monad m) => Maybe (m ()) -> m ()
fromMaybeM_ = fromMaybe (return ())
safeHead :: [a] -> Maybe a
safeHead [] = Nothing
safeHead (x:_) = Just x
safeTail :: [a] -> [a]
safeTail [] = []
safeTail (_:xs) = xs
maybeToEvent :: Maybe a -> Event a
maybeToEvent Nothing = NoEvent
maybeToEvent (Just x) = Event x
eventToMaybe :: Event a -> Maybe a
eventToMaybe NoEvent = Nothing
eventToMaybe (Event x) = Just x
eventToList :: Event [a] -> [a]
eventToList NoEvent = []
eventToList (Event x) = x
-- | Generates an 'Event' if the given condition is 'True'.
eventIf :: Bool -> Event ()
eventIf b = if b then Event () else NoEvent
-- | Generates a 'Just' value if the given condition is 'True'.
maybeIf :: Bool -> Maybe ()
maybeIf b = if b then Just () else Nothing
curry3 :: ((a,b,c) -> d) -> a -> b -> c -> d
curry3 f a b c = f (a,b,c)
uncurry3 :: (a -> b -> c -> d) -> (a,b,c) -> d
uncurry3 f (a,b,c) = f a b c
curry4 :: ((a,b,c,d) -> e) -> a -> b -> c -> d -> e
curry4 f a b c d = f (a,b,c,d)
uncurry4 :: (a -> b -> c -> d -> e) -> (a,b,c,d) -> e
uncurry4 f (a,b,c,d) = f a b c d
curry5 :: ((a,b,c,d,e) -> f) -> a -> b -> c -> d -> e -> f
curry5 f a b c d e = f (a,b,c,d,e)
uncurry5 :: (a -> b -> c -> d -> e -> f) -> (a,b,c,d,e) -> f
uncurry5 f (a,b,c,d,e) = f a b c d e
{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
module RMCA.Auxiliary.ReactiveValue where
import Control.Monad
import Data.CBMVar
import Data.CBRef
import Data.ReactiveValue
import FRP.Yampa
import RMCA.Auxiliary.Misc
-- |
-- = Auxiliary functions for manipulating reactive values
-- | Creates a new 'CBMVar' wrapped into a reactive field.
newCBMVarRW :: a -> IO (ReactiveFieldReadWrite IO a)
newCBMVarRW val = do
mvar <- newCBMVar val
let getter = readCBMVar mvar
setter = writeCBMVar mvar
notifier = installCallbackCBMVar mvar
return $ ReactiveFieldReadWrite setter getter notifier
-- | 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) =>
a -> b -> m ()
reactiveValueWriteOnNotEq rv nv = do
ov <- reactiveValueRead rv
when (ov /= nv) $ reactiveValueWrite rv nv
-- | Relation that will update when the value is an 'Event'.
(>:>) :: (ReactiveValueRead a (Event b) IO, ReactiveValueWrite c b IO) =>
a -> c -> IO ()
eventRV >:> rv = reactiveValueOnCanRead eventRV syncOnEvent
where syncOnEvent = do
erv <- reactiveValueRead eventRV
when (isEvent erv) $ reactiveValueWrite rv $ fromEvent erv
-- | When the reactive value on the left changes, the value on the right is updated using the value it contains and the value on the left with the provided function.
syncRightOnLeftWithBoth :: ( ReactiveValueRead a b m
, ReactiveValueReadWrite c d m
) => (b -> d -> d) -> a -> c -> m ()
syncRightOnLeftWithBoth f l r = reactiveValueOnCanRead l $ do
nl <- reactiveValueRead l
or <- reactiveValueRead r
reactiveValueWrite r (f nl or)
-- | Forces to update an reactive value by writing to it with the value it contains.
updateRV :: (ReactiveValueReadWrite a b m) => a -> m ()
updateRV rv = reactiveValueRead rv >>= reactiveValueWrite rv
floatConv :: (ReactiveValueReadWrite a b m,
Real c, Real b, Fractional c, Fractional b) =>
a -> ReactiveFieldReadWrite m c
floatConv = liftRW $ bijection (realToFrac, realToFrac)
swapHandlerStorage :: (ReactiveValueReadWrite a b IO) =>
a -> IO (ReactiveFieldReadWrite IO b)
swapHandlerStorage rv = do
ioref <- newCBRef ()
let setter val = reactiveValueWrite rv val >> writeCBRef ioref ()
getter = reactiveValueRead rv
notifier = installCallbackCBRef ioref
return $ ReactiveFieldReadWrite setter getter notifier
liftW3 :: ( Monad m
, ReactiveValueWrite a b m
, ReactiveValueWrite c d m
, ReactiveValueWrite e f m) =>
(i -> (b,d,f)) -> a -> c -> e -> ReactiveFieldWrite m i
liftW3 f a b c = ReactiveFieldWrite setter
where setter x = do
let (x1,x2,x3) = f x
reactiveValueWrite a x1
reactiveValueWrite b x2
reactiveValueWrite c x3
liftRW3 :: ( ReactiveValueReadWrite a b m
, ReactiveValueReadWrite c d m
, ReactiveValueReadWrite e f m) =>
BijectiveFunc i (b,d,f) -> a -> c -> e -> ReactiveFieldReadWrite m i
liftRW3 bij a b c =
ReactiveFieldReadWrite setter getter notifier
where ReactiveFieldRead getter notifier = liftR3 (curry3 f2) a b c
ReactiveFieldWrite setter = liftW3 f1 a b c
(f1, f2) = (direct bij, inverse bij)
liftR4 :: ( ReactiveValueRead a b m
, ReactiveValueRead c d m
, ReactiveValueRead e f m
, ReactiveValueRead g h m) =>
(b -> d -> f -> h -> i) -> a -> c -> e -> g -> ReactiveFieldRead m i
liftR4 f a b c d = ReactiveFieldRead getter notifier
where getter = do
x1 <- reactiveValueRead a
x2 <- reactiveValueRead b
x3 <- reactiveValueRead c
x4 <- reactiveValueRead d
return $ f x1 x2 x3 x4
notifier p = do
reactiveValueOnCanRead a p
reactiveValueOnCanRead b p
reactiveValueOnCanRead c p
reactiveValueOnCanRead d p
liftW4 :: ( Monad m
, ReactiveValueWrite a b m
, ReactiveValueWrite c d m
, ReactiveValueWrite e f m
, ReactiveValueWrite g h m) =>
(i -> (b,d,f,h)) -> a -> c -> e -> g -> ReactiveFieldWrite m i
liftW4 f a b c d = ReactiveFieldWrite setter
where setter x = do
let (x1,x2,x3,x4) = f x
reactiveValueWrite a x1
reactiveValueWrite b x2
reactiveValueWrite c x3
reactiveValueWrite d x4
liftRW4 :: ( ReactiveValueReadWrite a b m
, ReactiveValueReadWrite c d m
, ReactiveValueReadWrite e f m
, ReactiveValueReadWrite g h m) =>
BijectiveFunc i (b,d,f,h) -> a -> c -> e -> g
-> ReactiveFieldReadWrite m i
liftRW4 bij a b c d =
ReactiveFieldReadWrite setter getter notifier
where ReactiveFieldRead getter notifier = liftR4 (curry4 f2) a b c d
ReactiveFieldWrite setter = liftW4 f1 a b c d
(f1, f2) = (direct bij, inverse bij)
liftR5 :: ( ReactiveValueRead a b m
, ReactiveValueRead c d m
, ReactiveValueRead e f m
, ReactiveValueRead g h m
, ReactiveValueRead i j m) =>
(b -> d -> f -> h -> j -> k) -> a -> c -> e -> g -> i
-> ReactiveFieldRead m k
liftR5 f a b c d e = ReactiveFieldRead getter notifier
where getter = do
x1 <- reactiveValueRead a
x2 <- reactiveValueRead b
x3 <- reactiveValueRead c
x4 <- reactiveValueRead d
x5 <- reactiveValueRead e
return $ f x1 x2 x3 x4 x5
notifier p = do
reactiveValueOnCanRead a p
reactiveValueOnCanRead b p
reactiveValueOnCanRead c p
reactiveValueOnCanRead d p
reactiveValueOnCanRead e p
liftW5 :: ( Monad m
, ReactiveValueWrite a b m
, ReactiveValueWrite c d m
, ReactiveValueWrite e f m
, ReactiveValueWrite g h m
, ReactiveValueWrite i j m) =>
(k -> (b,d,f,h,j)) -> a -> c -> e -> g -> i -> ReactiveFieldWrite m k
liftW5 f a b c d e = ReactiveFieldWrite setter
where setter x = do
let (x1,x2,x3,x4,x5) = f x
reactiveValueWrite a x1
reactiveValueWrite b x2
reactiveValueWrite c x3
reactiveValueWrite d x4
reactiveValueWrite e x5
liftRW5 :: ( ReactiveValueReadWrite a b m
, ReactiveValueReadWrite c d m
, ReactiveValueReadWrite e f m
, ReactiveValueReadWrite g h m
, ReactiveValueReadWrite i j m) =>
BijectiveFunc k (b,d,f,h,j) -> a -> c -> e -> g -> i
-> ReactiveFieldReadWrite m k
liftRW5 bij a b c d e =
ReactiveFieldReadWrite setter getter notifier
where ReactiveFieldRead getter notifier = liftR5 (curry5 f2) a b c d e
ReactiveFieldWrite setter = liftW5 f1 a b c d e
(f1, f2) = (direct bij, inverse bij)
{-# LANGUAGE Arrows #-}
module RMCA.Auxiliary.Yampa where
import FRP.Yampa
import Data.Maybe
import RMCA.Auxiliary.Misc
-- | = Yampa
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'.
stepBack :: SF a (Maybe a)
stepBack = sscan f (Nothing, Nothing) >>^ snd
where f :: (Maybe a, Maybe a) -> a -> (Maybe a, Maybe a)
f (Nothing,_) x' = (Just x', Nothing)
f (Just x, _) x' = (Just x', Just x)
-- | Like 'stepBack' but the output value is always defined and is equal to the input at time 0.
stepBack' :: SF a a
stepBack' = proc x -> do
x' <- stepBack -< x
returnA -< fromMaybe x x'
-- | Throws an 'Event' when the incoming signal change. The 'Event' is tagged with the new value.
onChange :: (Eq a) => SF a (Event a)
onChange = proc x -> do
x' <- stepBack -< x
let makeEvent x x'
| isNothing x' = NoEvent
| otherwise = let x'' = fromJust x' in
if x'' == x then NoEvent else Event x
returnA -< makeEvent x x'
-- | Similar to 'onChange' but contains its initial value in the first
-- event.
onChange' :: (Eq a) => SF a (Event a)
onChange' = proc x -> do
x' <- stepBack -< x
-- If it's the first value, throw an Event, else behave like onChange.
let makeEvent x x'
| isNothing x' = Event x
| otherwise = let x'' = fromJust x' in
if x'' == x then NoEvent else Event x
returnA -< makeEvent x x'
-- | Integrates some variable modulo something.
integralMod :: (Real a, VectorSpace a s) => a -> SF a a
integralMod x = intMod' 0
where intMod' x0 = switch (intMod'' x0) (\y -> intMod' (y - x))
intMod'' x0 = proc t -> do
it <- (+ x0) ^<< integral -< t
es <- edgeBy (\_ y -> maybeIf (y > x) $> y) 0 -< it
returnA -< (it,es)
-- | Generates a sine function whose period is given as a varying input.
varFreqSine :: SF DTime Double
varFreqSine = sin ^<< (2*pi*) ^<< integralMod 1 <<^ (1/)
-- | Generates an 'Event' with a regular period, which is given as an input to the signal function.
repeatedlyS :: a -> SF DTime (Event a)
repeatedlyS x = edgeBy (\a b -> maybeIf (a * b < 0) $> x) 0
<<< varFreqSine <<^ (2*)
-- |
-- = Curry and uncurry functions
{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TupleSections #-}
{-# LANGUAGE FlexibleContexts, LambdaCase, MultiParamTypeClasses, TupleSections
#-}
module RMCA.GUI.LayerSettings where
......@@ -10,15 +11,11 @@ import Graphics.UI.Gtk
import Graphics.UI.Gtk.Reactive
import RMCA.Auxiliary
import RMCA.GUI.NoteSettings
import RMCA.Layer.Board
import RMCA.Layer.LayerConf
import RMCA.MCBMVar
import RMCA.Translator.Instruments
floatConv :: (ReactiveValueReadWrite a b m,
Real c, Real b, Fractional c, Fractional b) =>
a -> ReactiveFieldReadWrite m c
floatConv = liftRW $ bijection (realToFrac, realToFrac)
mkVScale :: String -> Adjustment -> IO (HBox,VScale)
mkVScale s adj = do
hBox <- hBoxNew False 10
......@@ -29,13 +26,13 @@ mkVScale s adj = do
boxPackStart hBox boxScale PackNatural 0
return (hBox,boxScale)
layerSettings :: IO ( VBox
, ReactiveFieldWrite IO Bool
, MCBMVar StaticLayerConf
, MCBMVar DynLayerConf
, MCBMVar SynthConf
)
layerSettings = do
layerSettings :: (ReactiveValueRead isStarted RunStatus IO) =>
isStarted -> IO ( VBox
, MCBMVar StaticLayerConf
, MCBMVar DynLayerConf
, MCBMVar SynthConf
)
layerSettings isStartedRV = do
------------------------------------------------------------------------------
-- GUI Boxes
------------------------------------------------------------------------------
......@@ -159,17 +156,22 @@ layerSettings = do
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
-}
bpbSensitiveRV <- swapHandlerStorage $
widgetSensitiveReactive bpbButton
reactiveValueOnCanRead isStartedRV $ do
reactiveValueRead isStartedRV >>=
\case
Running -> do reactiveValueRead repeatCheckRV
reactiveValueWrite repeatSensitive False
reactiveValueWrite bpbSensitiveRV False
reactiveValueWrite repeatCheckSensitive False
Stopped -> do reactiveValueRead repeatCheckRV >>=
reactiveValueWrite repeatSensitive
reactiveValueWrite bpbSensitiveRV True
reactiveValueWrite repeatCheckSensitive True
repeatCheckRV =:> repeatSensitive
reactiveValueWrite repeatCheckRV False
reactiveValueWrite repeatSensitive False
......@@ -205,6 +207,4 @@ layerSettings = do
syncRightOnLeftWithBoth (\ni ol -> ol { instrument = ni })
instrumentComboRV synthMCBMVar
return ( layerSettingsVBox
, statConfSensitive
, statMCBMVar, dynMCBMVar, synthMCBMVar)
return (layerSettingsVBox, statMCBMVar, dynMCBMVar, synthMCBMVar)
......@@ -47,8 +47,8 @@ synthConf (_,_,s) = s
layerMetronome :: StaticLayerConf
-> SF (Event AbsBeat, DynLayerConf) (Event BeatNo)
layerMetronome (StaticLayerConf { beatsPerBar = bpb
}) =
layerMetronome StaticLayerConf { beatsPerBar = bpb
} =
proc (eb, DynLayerConf { layerBeat = r
}) -> do
ewbno <- accumFilter (\_ (ab,r) -> ((),selectBeat (ab,r))) () -< (,r) <$> eb
......
{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, TupleSections #-}
{-# LANGUAGE LambdaCase, MultiParamTypeClasses, ScopedTypeVariables,
TupleSections #-}
module Main where
......@@ -51,7 +52,9 @@ main = do
boxPackEnd settingsBox buttonBox PackNatural 0
boardQueue <- newCBRef mempty
(layerSettingsVBox, statConfSensitiveRV, statMCBMVar, dynMCBMVar, synthMCBMVar) <- layerSettings
--isStartMVar <- newMVar False
boardStatusRV <- newCBMVarRW Stopped
(layerSettingsVBox, statMCBMVar, dynMCBMVar, synthMCBMVar) <- layerSettings boardStatusRV
boxPackStart settingsBox layerSettingsVBox PackNatural 0
laySep <- hSeparatorNew
boxPackStart settingsBox laySep PackNatural 0
......@@ -66,24 +69,20 @@ main = do
--handleSaveLoad tempoRV boardMapRV layerMapRV instrMapRV phRVMapRV
--addLayerRV rmLayerRV confSaveRV confLoadRV
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 Running
else do modifyMVar_ isStartMVar $ const $ return True
reactiveValueWrite boardStatusRV Running
reactiveValueOnCanRead stopRV $ do
modifyMVar_ isStartMVar $ const $ return False
reactiveValueWrite boardStatusRV Stopped
reactiveValueOnCanRead playRV $
reactiveValueRead boardStatusRV >>=
\case
Running -> reactiveValueWrite boardStatusRV Running
Stopped -> reactiveValueWrite boardStatusRV Running
reactiveValueOnCanRead stopRV $ reactiveValueWrite boardStatusRV Stopped
boardMap <- reactiveValueRead boardMapRV
layerMap <- reactiveValueRead layerMapRV
tempo <- reactiveValueRead tempoRV
......@@ -96,7 +95,6 @@ main = do
--initSig)
outBoard <- yampaReactiveFrom (layers initSig) inRV
--reactiveValueOnCanRead inRV (reactiveValueRead inRV >>= print . M.keys)
--inRV =:> inBoard
reactiveValueOnCanRead outBoard $ do
out <- reactiveValueRead outBoard
--print out
......@@ -109,15 +107,8 @@ main = do
sequence_ $ M.mapWithKey writePh $ M.map snd out
reactiveValueAppend boardQueue $ M.map (,[]) noteMap
{-
reactiveValueRead (liftR (event mempty (,[]) <<< snd <<< splitE) outBoard) >>=
reactiveValueAppend boardQueue-}
-- This needs to be set last otherwise phRV is written to, so
-- inBoard is written to and the notes don't get played. There
-- supposedly is no guaranty of order but apparently there is…
putStrLn "Board started."
-- Jack setup
forkIO $ jackSetup tc boardQueue tempoRV
widgetShowAll window
......
......@@ -6,6 +6,13 @@ import Control.Monad
import Data.CBRef
import Data.ReactiveValue
reactiveValueNonAtomicUpdate :: (ReactiveValueReadWrite a b m) =>
a -> (b -> b) -> m b
reactiveValueNonAtomicUpdate rv f = do
val <- reactiveValueRead rv
reactiveValueWrite rv $ f val
return val
class (ReactiveValueReadWrite a b m) => ReactiveValueAtomicUpdate a b m where
reactiveValueUpdate :: a -> (b -> b) -> m b
......@@ -15,7 +22,7 @@ reactiveValueAppend rv val = void $ reactiveValueUpdate rv (`mappend` val)
reactiveValueEmpty :: (Monoid b, ReactiveValueAtomicUpdate a b m) =>
a -> m b
reactiveValueEmpty rv = reactiveValueUpdate rv (\_ -> mempty)
reactiveValueEmpty rv = reactiveValueUpdate rv (const mempty)
instance ReactiveValueRead (CBRef a) a IO where
reactiveValueRead = readCBRef
......
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