Commit 9125533b authored by Guerric Chupin's avatar Guerric Chupin

Minor refactoring.

parent 699d70cf
{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-}
{-# LANGUAGE Arrows, FlexibleContexts, MultiParamTypeClasses #-}
module RMCA.Auxiliary.RV where
module RMCA.Auxiliary where
import Control.Monad
import Data.CBMVar
import Data.Maybe
import Data.ReactiveValue
import FRP.Yampa
import Control.Monad
import RMCA.Auxiliary.Curry
leftSyncWith :: (ReactiveValueRead a b m, ReactiveValueWrite c d m) =>
(b -> d) -> a -> c -> m ()
leftSyncWith f a c = reactiveValueOnCanRead a
(reactiveValueRead a >>= reactiveValueWrite c . f)
{-
(=:$:>) :: (ReactiveValueRead a b m, ReactiveValueWrite c d m) =>
(b -> d) -> a -> c -> m ()
(=:$:>) = leftSyncWith
-}
newCBMVarRW :: forall a. a -> IO (ReactiveFieldReadWrite IO a)
--------------------------------------------------------------------------------
-- General functions
--------------------------------------------------------------------------------
bound :: (Ord a) => (a, a) -> a -> a
bound (min, max) x
| x < min = min
| x > max = max
| otherwise = x
--------------------------------------------------------------------------------
-- FRP
--------------------------------------------------------------------------------
-- 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,Nothing) x' = (Just x', Nothing)
f (Just x, _) x' = (Just x', Just x)
-- Just 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
| isJust x' = 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
| isJust x' = let x'' = fromJust x' in
if x'' == x then NoEvent else Event x
returnA -< makeEvent x x'
--------------------------------------------------------------------------------
-- Reactive Values
--------------------------------------------------------------------------------
newCBMVarRW :: a -> IO (ReactiveFieldReadWrite IO a)
newCBMVarRW val = do
mvar <- newCBMVar val
let getter :: IO a
getter = readCBMVar mvar
setter :: a -> IO ()
let getter = readCBMVar mvar
setter = writeCBMVar mvar
notifier :: IO () -> IO ()
notifier = installCallbackCBMVar mvar
return $ ReactiveFieldReadWrite setter getter notifier
emptyRW :: (Monoid b, ReactiveValueReadWrite a b m) => a -> m b
emptyRW rv = do
val <- reactiveValueRead rv
reactiveValueWrite rv mempty
return val
emptyW :: (Monoid b, ReactiveValueWrite a b m) => a -> m ()
emptyW rv = reactiveValueWrite rv mempty
reactiveValueAppend :: (Monoid b, ReactiveValueReadWrite a b m) =>
a -> b -> m ()
reactiveValueAppend rv v = do ov <- reactiveValueRead rv
reactiveValueWrite rv (ov `mappend` v)
onTick :: (ReactiveValueRead a b m, ReactiveValueRead c d m) =>
a -> c -> ReactiveFieldRead m d
onTick notif rv = ReactiveFieldRead getter notifier
where getter = reactiveValueRead rv
notifier cb = do
reactiveValueOnCanRead notif cb
reactiveValueOnCanRead rv cb
addHandlerR :: (ReactiveValueRead a b m) =>
a
-> (m () -> m())
-> ReactiveFieldRead m b
addHandlerR x h = ReactiveFieldRead (reactiveValueRead x)
(\p -> reactiveValueOnCanRead x p >> h p)
emptyRW :: (Monoid b, ReactiveValueReadWrite a b m) => a -> m b
emptyRW rv = do
val <- reactiveValueRead rv
reactiveValueWrite rv mempty
return val
-- Update when the value is an Event. It would be nice to have that
-- even for Maybe as well.
......@@ -70,11 +96,7 @@ 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
(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
......@@ -85,11 +107,7 @@ liftW3 f a b c = ReactiveFieldWrite setter
liftRW3 :: ( ReactiveValueReadWrite a b m
, ReactiveValueReadWrite c d m
, ReactiveValueReadWrite e f m) =>
BijectiveFunc i (b,d,f)
-> a
-> c
-> e
-> ReactiveFieldReadWrite m i
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
......@@ -100,19 +118,14 @@ 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
(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)
return $ f x1 x2 x3 x4
notifier p = do
reactiveValueOnCanRead a p
reactiveValueOnCanRead b p
......@@ -124,12 +137,7 @@ liftW4 :: ( Monad 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
(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
......@@ -142,15 +150,11 @@ 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
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 f2 a b c d
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)
......@@ -159,12 +163,7 @@ liftR5 :: ( ReactiveValueRead a b m
, ReactiveValueRead e f m
, ReactiveValueRead g h m
, ReactiveValueRead i j m) =>
((b,d,f,h,j) -> k)
-> a
-> c
-> e
-> g
-> i
(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
......@@ -173,7 +172,7 @@ liftR5 f a b c d e = ReactiveFieldRead getter notifier
x3 <- reactiveValueRead c
x4 <- reactiveValueRead d
x5 <- reactiveValueRead e
return $ f (x1, x2, x3, x4, x5)
return $ f x1 x2 x3 x4 x5
notifier p = do
reactiveValueOnCanRead a p
reactiveValueOnCanRead b p
......@@ -187,13 +186,7 @@ liftW5 :: ( Monad 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
(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
......@@ -208,15 +201,32 @@ liftRW5 :: ( ReactiveValueReadWrite a b 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
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 f2 a b c d e
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)
--------------------------------------------------------------------------------
-- Curry and uncurry functions
--------------------------------------------------------------------------------
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 Arrows #-}
module RMCA.Auxiliary.Auxiliary where
import Data.Maybe
import FRP.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.
stepBack :: SF a (Maybe a)
stepBack = sscan f (Nothing, Nothing) >>^ snd
where f :: (Maybe a, Maybe a) -> a -> (Maybe a, Maybe a)
f (Nothing,Nothing) x' = (Just x', Nothing)
f (Just x, _) x' = (Just x', Just x)
-- Just 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
| isJust x' = 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
| isJust x' = let x'' = fromJust x' in
if x'' == x then NoEvent else Event x
returnA -< makeEvent x x'
discard :: a -> ()
discard _ = ()
bound :: (Ord a) => (a, a) -> a -> a
bound (min, max) x
| x < min = min
| x > max = max
| otherwise = x
module RMCA.Auxiliary.Concurrent where
import Control.Concurrent
import Control.Concurrent.MVar
forkChild :: IO () -> IO (MVar ())
forkChild io = do
mvar <- newEmptyMVar
forkFinally io (\_ -> putMVar mvar ())
return mvar
-- Contains function to currify/uncurrify functions with more than
-- two arguments. It might be useful to use Template Haskell there.
module RMCA.Auxiliary.Curry where
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
......@@ -21,6 +21,8 @@ import Paths_RMCA
import RMCA.Global.Clock
import RMCA.Semantics
import Debug.Trace
data GUICell = GUICell { cellAction :: Action
, repeatCount :: Int
, asPh :: Bool
......@@ -207,7 +209,7 @@ initBoardRV :: BIO.Board Int Tile (Player,GUICell)
initBoardRV board@BIO.Board { boardPieces = (GameBoard gArray) } = do
-- RV creation
phMVar <- newCBMVar []
notBMVar <- mkClockRV 100
notBMVar <- mkClockRV 10
let getterB :: IO Board
getterB = do
(boardArray :: [((Int,Int),Maybe (Player,GUICell))]) <- getAssocs gArray
......@@ -254,6 +256,7 @@ initBoardRV board@BIO.Board { boardPieces = (GameBoard gArray) } = do
setterW :: (Int,Int) -> GUICell -> IO ()
setterW i g = postGUIAsync $ boardSetPiece i (Player,g) board
arrW :: Array Pos (ReactiveFieldWrite IO GUICell)
arrW = array (minimum validArea, maximum validArea)
[(i, ReactiveFieldWrite (setterW i))
......
......@@ -8,7 +8,7 @@ import Data.String
import Data.Tuple
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Reactive
import RMCA.Auxiliary.RV
import RMCA.Auxiliary
import RMCA.GUI.NoteSettings
import RMCA.Layer.Layer
import RMCA.Semantics
......
......@@ -18,7 +18,7 @@ import Data.Tuple
import Graphics.UI.Gtk hiding (Action)
import Graphics.UI.Gtk.Board.TiledBoard hiding (Board)
import Graphics.UI.Gtk.Reactive
import RMCA.Auxiliary.RV
import RMCA.Auxiliary
import RMCA.GUI.Board
import RMCA.Semantics
......
......@@ -5,12 +5,9 @@ import Control.Monad
import Data.CBMVar
import Data.ReactiveValue
import FRP.Yampa
import RMCA.Auxiliary.Auxiliary
import RMCA.Auxiliary
import RMCA.Semantics
tempo :: Tempo -> SF () Tempo
tempo = constant
-- The initial value is arbitrary but never appears because the switch
-- is immediate.
metronome :: SF Tempo (Event Beat)
......
{-# LANGUAGE Arrows, FlexibleContexts #-}
{-# LANGUAGE Arrows #-}
module RMCA.Layer.Board ( boardSF
) where
module RMCA.Layer.Board where
import FRP.Yampa
import RMCA.Auxiliary.Curry
import RMCA.Auxiliary
import RMCA.Layer.Layer
import RMCA.Semantics
data BoardRun = BoardStart | BoardStop deriving Eq
{-
-- The state of the board is described by the list of the playheads
-- and the different actions onto the board.
boardAction :: SF ((Board, Layer, [PlayHead]), Event BeatNo)
......@@ -23,40 +25,25 @@ boardSF :: SF (Board, Layer, [PlayHead], Tempo) (Event ([PlayHead], [Note]))
boardSF = proc (board, l, ph, t) -> do
ebno <- layerMetronome -< (t, l)
boardAction -< ((board, l, ph), ebno)
-}
{-
-- We need the list of initial playheads
boardSF :: [PlayHead] -> SF (Board, Layer, Tempo) (Event [Note])
boardSF iph = proc (board, l@Layer { relPitch = rp
, strength = s
}, t) -> do
ebno <- layerMetronome -< (t,l)
boardSF' iph -< ((board, l), ebno)
where
boardSF' :: [PlayHead] -> SF ((Board, Layer), Event BeatNo) (Event [Note])
boardSF' ph = dSwitch (boardAction ph >>> arr splitE >>> arr swap)
(\nph -> second notYet >>> boardSF' nph)
singleBoard :: [PlayHead]
-> SF (Board, Layer, Event BeatNo) (Event ([PlayHead], [Note]))
singleBoard iPh = proc (board, Layer { relPitch = rp
, strength = s
}, ebno) ->
accumBy advanceHeads' (iPh,[]) -< ebno `tag` (board, fromEvent ebno, rp, s)
where advanceHeads' (ph,_) (board,bno,rp,s) = uncurry5 advanceHeads (board,bno,rp,s,ph)
boardSF :: SF (Board, Layer, Tempo, BoardRun) (Event ([PlayHead], [Note]))
boardSF = proc (board, l, t, br) -> do
ebno <- layerMetronome -< (t,l)
ess <- onChange -< br
boardSwitch [] -< ((board, l, ebno), ess `tag` (br, startHeads board))
{-
boardSetup :: Board
-> ReactiveFieldReadWrite IO Tempo
-> ReactiveFieldReadWrite IO Layer
-> ReactiveFieldReadWrite IO [Note]
-> IO ()
boardSetup board tempoRV layerRV outBoardRV = do
layer <- reactiveValueRead layerRV
tempo <- reactiveValueRead tempoRV
(inBoard, outBoard) <- yampaReactiveDual (layer, tempo) (boardSF board)
let inRV = pairRW layerRV tempoRV
clock <- mkClockRV 10
inRV =:> inBoard
clock ^:> inRV
reactiveValueOnCanRead outBoard
(reactiveValueRead outBoard >>= reactiveValueWrite outBoardRV . event [] id)
putStrLn "Board started."
n <- newEmptyMVar
takeMVar n
return ()
-}
-}
boardSwitch :: [PlayHead]
-> SF ((Board, Layer,Event BeatNo), Event (BoardRun, [PlayHead]))
(Event ([PlayHead],[Note]))
boardSwitch rPh = dSwitch (singleBoard rPh *** identity) fnSwitch
where fnSwitch (BoardStart, iPh) = boardSwitch iPh
fnSwitch (BoardStop, _) = boardSwitch []
module RMCA.Layer.PlayHead where
import RMCA.Semantics
import FRP.Yampa
playHead :: SF () ()
......@@ -9,7 +9,7 @@ import Graphics.UI.Gtk
import Graphics.UI.Gtk.Board.BoardLink
import Graphics.UI.Gtk.Layout.BackgroundContainer
import Hails.Yampa
import RMCA.Auxiliary.RV
import RMCA.Auxiliary
import RMCA.Configuration
import RMCA.GUI.Board
import RMCA.GUI.Buttons
......@@ -101,15 +101,14 @@ main = do
onResponse fcl (\r -> respHandle r >> widgetHide fcl)
return ()
reactiveValueOnCanRead playRV
(reactiveValueRead boardRV >>= reactiveValueWrite phRV . startHeads)
reactiveValueOnCanRead stopRV $ reactiveValueWrite phRV []
boardRunRV <- newCBMVarRW BoardStop
reactiveValueOnCanRead playRV $ reactiveValueWrite boardRunRV BoardStart
reactiveValueOnCanRead stopRV $ reactiveValueWrite boardRunRV BoardStop
board <- reactiveValueRead boardRV
ph <- reactiveValueRead phRV
(inBoard, outBoard) <- yampaReactiveDual (board, layer, ph, tempo) boardSF
(inBoard, outBoard) <- yampaReactiveDual (board, layer, tempo, BoardStop) boardSF
let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
inRV = liftR4 id
boardRV layerRV phRV tempoRV'
inRV = liftR4 (,,,)
boardRV layerRV tempoRV' boardRunRV
--let inRV = onTick clock inRV
inRV =:> inBoard
reactiveValueOnCanRead outBoard $
......
......@@ -33,9 +33,9 @@
module RMCA.Semantics where
import Data.Array
import Data.List (intercalate, nub)
import Data.Maybe (catMaybes)
import RMCA.Auxiliary.Auxiliary
import Data.List (intercalate, nub)
import Data.Maybe (catMaybes)
import RMCA.Auxiliary
------------------------------------------------------------------------------
......
......@@ -12,7 +12,7 @@ import Data.CBMVar
import Data.ReactiveValue
import qualified Foreign.C.Error as E
import Hails.Yampa
import RMCA.Auxiliary.RV
import RMCA.Auxiliary
import RMCA.Semantics
import RMCA.Translator.Filter
import RMCA.Translator.Message
......
......@@ -6,7 +6,7 @@ module RMCA.Translator.Translator ( readMessages
import qualified Data.Bifunctor as BF
import FRP.Yampa
import RMCA.Auxiliary.Curry
import RMCA.Auxiliary
import RMCA.Semantics
import RMCA.Translator.Message
import RMCA.Translator.Note
......
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