Commit b396d636 authored by Guerric Chupin's avatar Guerric Chupin

Used a global clock to update the board.

parent 92e82a94
......@@ -35,4 +35,5 @@ html/
*.prof
*.ps
*.html
*.folded
\ No newline at end of file
*.folded
/doc
\ No newline at end of file
{-# LANGUAGE Arrows, FlexibleContexts, MultiParamTypeClasses #-}
-- | Auxiliary functions used throughout the code.
module RMCA.Auxiliary where
import Control.Monad
......@@ -9,16 +10,20 @@ import Data.Maybe
import Data.ReactiveValue
import FRP.Yampa
--------------------------------------------------------------------------------
-- General functions
--------------------------------------------------------------------------------
import Debug.Trace
-- |= 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
......@@ -48,33 +53,30 @@ 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
--------------------------------------------------------------------------------
-- 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' 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)
-- Just like stepBack but the output value is always defined and is
-- equal to the input at time 0.
-- | 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.
-- | 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
......@@ -84,14 +86,7 @@ onChange = proc x -> do
if x'' == x then NoEvent else Event x
returnA -< makeEvent x x'
varFreqSine :: SF DTime Double
varFreqSine = sin ^<< (2*pi*) ^<< (`mod'` 1) ^<< integral <<^ (1/)
repeatedlyS :: a -> SF DTime (Event a)
repeatedlyS x = edgeBy (\a b -> maybeIf (a * b > 0) $> x) 0
<<< varFreqSine <<^ (2*)
-- Similar to onChange but contains its initial value in the first
-- | Similar to 'onChange' but contains its initial value in the first
-- event.
onChange' :: (Eq a) => SF a (Event a)
onChange' = proc x -> do
......@@ -103,10 +98,19 @@ onChange' = proc x -> do
if x'' == x then NoEvent else Event x
returnA -< makeEvent x x'
--------------------------------------------------------------------------------
-- Reactive Values
--------------------------------------------------------------------------------
-- | Generates a sine function whose period is given as a varying input.
varFreqSine :: SF DTime Double
varFreqSine = sin ^<< (2*pi*) ^<< integral <<^ (1/)
-- | Generates an 'Event' at a regular frequency, which is given as an input to the signal function.
repeatedlyS :: a -> SF DTime (Event a)
repeatedlyS x = edgeBy (\a b -> traceShow (a,b) (maybeIf (a * b < 0) $> x)) 0
<<< varFreqSine <<^ (2*)
-- |
-- = 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
......@@ -115,15 +119,18 @@ 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) =>
a -> b -> m ()
......@@ -131,8 +138,7 @@ reactiveValueWriteOnNotEq rv nv = do
ov <- reactiveValueRead rv
when (ov /= nv) $ reactiveValueWrite rv nv
-- Update when the value is an Event. It would be nice to have that
-- even for Maybe as well.
-- | 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
......@@ -140,6 +146,7 @@ eventRV >:> rv = reactiveValueOnCanRead eventRV syncOnEvent
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 ()
......@@ -148,6 +155,7 @@ syncRightOnLeftWithBoth f l r = reactiveValueOnCanRead l $ do
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
......@@ -268,9 +276,8 @@ liftRW5 bij a b c d e =
ReactiveFieldWrite setter = liftW5 f1 a b c d e
(f1, f2) = (direct bij, inverse bij)
--------------------------------------------------------------------------------
-- Curry and uncurry functions
--------------------------------------------------------------------------------
-- |
-- = Curry and uncurry functions
curry3 :: ((a,b,c) -> d) -> a -> b -> c -> d
curry3 f a b c = f (a,b,c)
......
......@@ -172,14 +172,14 @@ 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 :: BIO.Board Int Tile (Player,GUICell)
initBoardRV :: TickableClock
-> BIO.Board Int Tile (Player,GUICell)
-> IO ( ReactiveFieldRead IO Board
, Array Pos (ReactiveFieldWrite IO GUICell)
, ReactiveFieldWrite IO [PlayHead])
initBoardRV board@BIO.Board { boardPieces = (GameBoard gArray) } = do
initBoardRV tc board@BIO.Board { boardPieces = (GameBoard gArray) } = do
-- RV creation
phMVar <- newCBMVar []
notBMVar <- mkClockRV 50
let getterB :: IO Board
getterB = do
(boardArray :: [((Int,Int),Maybe (Player,GUICell))]) <- getAssocs gArray
......@@ -191,7 +191,7 @@ initBoardRV board@BIO.Board { boardPieces = (GameBoard gArray) } = do
return board
notifierB :: IO () -> IO ()
notifierB = reactiveValueOnCanRead notBMVar
notifierB = reactiveValueOnCanRead tc
getterP :: IO [PlayHead]
getterP = readCBMVar phMVar
......
......@@ -175,7 +175,6 @@ attachGameRules game = do
board `boardOnPieceDragStart` \pos' -> do
let pos = actualTile pos'
putStrLn ("dragStart: " ++ show pos' ++ show pos)
visualGame <- readIORef vgRef
let game' = gameS visualGame
return (moveEnabled game' && canMove game' (curPlayer game') pos)
......@@ -183,7 +182,6 @@ attachGameRules game = do
board `boardOnPieceDragOver` \posF' posT' -> do
let posF = actualTile posF'
posT = actualTile posT'
putStrLn ("dragOver: " ++ show posF ++ show posT)
visualGame <- readIORef vgRef
let game' = gameS visualGame
return (moveEnabled game' && canMoveTo game' (curPlayer game') posF posT)
......
......@@ -15,6 +15,7 @@ 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.MCBMVar
......@@ -23,7 +24,8 @@ import RMCA.Semantics
createNotebook :: ( ReactiveValueRead addLayer () IO
, ReactiveValueRead rmLayer () IO
) =>
addLayer
TickableClock
-> addLayer
-> rmLayer
-> MCBMVar Layer
-> MCBMVar GUICell
......@@ -33,7 +35,7 @@ createNotebook :: ( ReactiveValueRead addLayer () IO
, ReactiveFieldRead IO
(M.IntMap (ReactiveFieldWrite IO [PlayHead]))
)
createNotebook addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
createNotebook tc addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
n <- notebookNew
let curPageRV = ReactiveFieldReadWrite setter getter notifier
where (ReactiveFieldRead getter _) = notebookGetCurrentPagePassive n
......@@ -104,7 +106,7 @@ createNotebook addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
fstP <- notebookAppendPage n boardCont "Lol first"
notebookPageNumber <- newCBMVarRW (1 :: Int)
initBoardRV guiBoard >>=
initBoardRV tc guiBoard >>=
\(boardRV, pieceArrRV, phRV) -> reactiveValueRead chanMapRV >>=
reactiveValueWrite chanMapRV . M.insert fstP (boardRV,pieceArrRV,phRV)
......@@ -141,7 +143,7 @@ createNotebook addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
notebookAppendPage n nBoardCont $ show np
pChan <- reactiveValueRead pageChanRV
let newCP = foundHole pChan
(nBoardRV, nPieceArrRV, nPhRV) <- initBoardRV nGuiBoard
(nBoardRV, nPieceArrRV, nPhRV) <- initBoardRV tc nGuiBoard
reactiveValueRead chanMapRV >>=
reactiveValueWrite chanMapRV . M.insert newCP (nBoardRV,nPieceArrRV,nPhRV)
......
module RMCA.Global.Clock where
{-# LANGUAGE MultiParamTypeClasses #-}
module RMCA.Global.Clock ( AbsBeat
, maxAbsBeat
, metronome
, tempoToQNoteIvl
, TickableClock
, newTickableClock
, tickClock
) where
import Control.Concurrent
import Control.Monad
......@@ -56,3 +65,16 @@ 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
......@@ -12,6 +12,7 @@ import Graphics.UI.Gtk.Layout.BackgroundContainer
import Hails.Yampa
import RMCA.Auxiliary
import RMCA.Configuration
import RMCA.Global.Clock
import RMCA.GUI.Board
import RMCA.GUI.Buttons
import RMCA.GUI.LayerSettings
......@@ -58,7 +59,8 @@ main = do
boxPackStart settingsBox laySep PackNatural 0
(noteSettingsBox, guiCellMCBMVar) <- noteSettingsBox
(boardCont, boardMapRV, layerMapRV, phRVMapRV) <- createNotebook
tc <- newTickableClock
(boardCont, boardMapRV, layerMapRV, phRVMapRV) <- createNotebook tc
addLayerRV rmLayerRV
layerMCBMVar guiCellMCBMVar
boxPackStart mainBox boardCont PackNatural 0
......@@ -101,7 +103,7 @@ main = do
-- supposedly is no guaranty of order but apparently there is…
putStrLn "Board started."
-- Jack setup
forkIO $ jackSetup boardQueue tempoRV
forkIO $ jackSetup tc boardQueue tempoRV
widgetShowAll window
------------------------------------------------------------
......
......@@ -6,6 +6,7 @@ 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.Foldable
......@@ -13,6 +14,7 @@ import qualified Data.IntMap as M
import Data.ReactiveValue
import qualified Foreign.C.Error as E
import RMCA.Auxiliary
import RMCA.Global.Clock
import RMCA.Semantics
import RMCA.Translator.Message
import RMCA.Translator.RV
......@@ -34,19 +36,22 @@ outPortName = "output"
jackSetup :: (ReactiveValueReadWrite board
(M.IntMap ([Note],[Message])) IO
, ReactiveValueRead tempo Tempo IO) =>
board
TickableClock
-> board
-> tempo
-> IO ()
jackSetup boardQueue tempoRV = Jack.handleExceptions $ do
jackSetup tc boardQueue tempoRV = Jack.handleExceptions $ do
toProcessRV <- Trans.lift $ newCBMVarRW []
Jack.withClientDefault rmcaName $ \client ->
Jack.withPort client outPortName $ \output ->
Jack.withPort client inPortName $ \input ->
Jack.withProcess client (jackCallBack input output
Jack.withProcess client (jackCallBack tc input output
toProcessRV boardQueue tempoRV) $
Jack.withActivation client $ Trans.lift $ do
putStrLn $ "Started " ++ rmcaName ++ " JACK client."
--newEmptyMVar >>= takeMVar
Jack.waitForBreak
return ()
-- The callback function. It pumps value out of the input port, mix
-- them with value coming from the machine itself and stuff them into
......@@ -56,14 +61,15 @@ jackCallBack :: ( ReactiveValueReadWrite toProcess [(Frames, RawMessage)] IO
, ReactiveValueReadWrite board
(M.IntMap ([Note],[Message])) IO
, ReactiveValueRead tempo Tempo IO) =>
JMIDI.Port Jack.Input
TickableClock
-> JMIDI.Port Jack.Input
-> JMIDI.Port Jack.Output
-> toProcess
-> board
-> tempo
-> Jack.NFrames
-> Sync.ExceptionalT E.Errno IO ()
jackCallBack input output toProcessRV boardQueue tempoRV
jackCallBack tc input output toProcessRV boardQueue tempoRV
nframes@(Jack.NFrames nframesInt') = do
let inMIDIRV = inMIDIEvent input nframes
outMIDIRV = outMIDIEvent output nframes
......@@ -79,4 +85,5 @@ jackCallBack input output toProcessRV boardQueue tempoRV
putStrLn ("Out: " ++ show (map fst go))
reactiveValueWrite outMIDIRV go
reactiveValueWrite toProcessRV old
tickClock 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