Commit f19a0561 by Guerric Chupin

Cleaned up code.

parent a603f3ae
......@@ -37,9 +37,7 @@ import RMCA.GUI.HelpersRewrite
import RMCA.IOClockworks
import RMCA.Semantics
newtype GUIBoard = GUIBoard { toGS :: GameState Int Tile Player GUICell }
type IOBoard = BIO.Board Int Tile (Player,GUICell)
newtype GUIBoard = GUIBoard (GameState Int Tile Player GUICell)
-- There are two types of tiles that can be distinguished by setting
-- two different colors for debugging purposes. A future release might
......@@ -65,10 +63,12 @@ hexW = round d
where d :: Double
d = 4 * fromIntegral tileW / 3
{-
hexH :: Int
hexH = round d
where d :: Double
d = sqrt 3 * fromIntegral hexW / 2
-}
boardToTile :: [(Int,Int,Tile)]
boardToTile = [(x,y,selTile) | (x,y) <- range ( (xMin-1,yMin)
......
......@@ -41,17 +41,6 @@ toggleButtonNewFromStock s = do
labelSetUseUnderline buttonLabel True
packButton button buttonBox buttonLabel buttonImg
buttonBoxNewWithLabelFromStock :: StockId -> IO HBox
buttonBoxNewWithLabelFromStock s = do
buttonBox <- hBoxNew False 0
buttonImg <- imageNewFromStock s IconSizeButton
stockTxt <- stockLookupItem s
buttonLabel <- labelNew (siLabel <$> stockTxt)
labelSetUseUnderline buttonLabel True
boxPackStart buttonBox buttonImg PackRepel 0
boxPackStart buttonBox buttonLabel PackRepel 0
return buttonBox
getButtons :: (ReactiveValueRead boardStatus RunStatus IO) =>
boardStatus -> IO ( VBox
, ReactiveFieldRead IO ()
......
......@@ -152,13 +152,14 @@ layerSettings isStartedRV = do
let bpbRV = spinButtonValueIntReactive bpbButton
repeatCheckRV = toggleButtonActiveReactive repeatCheckButton
repeatRV' = spinButtonValueIntReactive repeatButton
repeatRV = liftR2 (\act r -> if act then Just r else Nothing)
repeatCheckRV repeatRV'
repeatRV = let f (act,r) = if act then Just r else Nothing
g r = case r of
Nothing -> (False,0)
Just n -> (True,n)
in liftRW2 (bijection (g,f)) repeatCheckRV repeatRV'
repeatSensitive = widgetSensitiveReactive repeatButton
repeatCheckSensitive = widgetSensitiveReactive repeatCheckButton
bpbSensitiveRV <- swapHandlerStorage $
widgetSensitiveReactive bpbButton
bpbSensitiveRV = widgetSensitiveReactive bpbButton
reactiveValueOnCanRead isStartedRV $
reactiveValueRead isStartedRV >>=
......@@ -188,6 +189,7 @@ layerSettings isStartedRV = do
reactiveValueOnCanRead statMCBMVar $ postGUIAsync $ do
nStat <- reactiveValueRead statMCBMVar
reactiveValueWriteOnNotEq bpbRV $ beatsPerBar nStat
reactiveValueWriteOnNotEq repeatRV $ repeatCount nStat
reactiveValueOnCanRead synthMCBMVar $ do
nSynth <- reactiveValueRead synthMCBMVar
......@@ -200,8 +202,10 @@ layerSettings isStartedRV = do
layPitchRV dynMCBMVar
syncRightOnLeftWithBoth (\ns ol -> ol { strength = ns })
strengthRV dynMCBMVar
syncRightOnLeftWithBoth (\nb ol -> ol { beatsPerBar = nb})
syncRightOnLeftWithBoth (\nb ol -> ol { beatsPerBar = nb })
bpbRV statMCBMVar
syncRightOnLeftWithBoth (\nr ol -> ol { repeatCount = nr })
repeatRV statMCBMVar
syncRightOnLeftWithBoth (\nv ol -> ol { volume = nv })
layVolumeRV synthMCBMVar
syncRightOnLeftWithBoth (\ni ol -> ol { instrument = ni })
......
......@@ -139,7 +139,10 @@ createNotebook boardQueue tc addLayerRV rmLayerRV
synthState <- reactiveValueRead synthMCBMVar
reactiveValueAppend boardQueue $
M.singleton cp $ ([],) $ synthMessage cp synthState
updateStatLayer _ = return ()--undefined
updateStatLayer cp = do
nStat <- reactiveValueRead statMCBMVar
reactiveValueUpdate_ layerMapRV
(M.adjust (\(_,dyn,synth) -> (nStat,dyn,synth)) cp)
statHidMVar <- newEmptyMVar
dynHidMVar <- newEmptyMVar
......
......@@ -46,9 +46,9 @@ layer = layerStopped
returnA -< ((en,phs),e)
lrAux slc iphs = proc (eab, b, (slc',dlc,_), ers) -> do
ebno <- layerMetronome slc -< (traceShow eab eab, dlc)
ebno <- layerMetronome slc -< (eab, dlc)
enphs@(_,phs) <- automaton iphs -< (b, dlc, ebno)
r <- (case repeatCount slc of
r <- (case let a = repeatCount slc in traceShow a a of
Nothing -> never
Just n -> countTo (n * beatsPerBar slc)) -< ebno
let ers' = ers `lMerge` (r `tag` Running)
......
......@@ -2,7 +2,6 @@
module RMCA.Layer.LayerConf where
import Data.IntMap (IntMap)
import Data.Ratio
import Data.ReactiveValue
import FRP.Yampa
......
......@@ -79,9 +79,6 @@ main = do
boardStatusEP <- getEPfromRV boardStatusRV
reactiveValueOnCanRead playRV $ reactiveValueWrite boardStatusRV Running
reactiveValueOnCanRead stopRV $ 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
......
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module RMCA.ReactiveValueAtomicUpdate where
......
......@@ -4,7 +4,6 @@ module RMCA.Translator.RV where
import Control.Monad.Exception.Synchronous (ExceptionalT, resolveT)
import qualified Data.Bifunctor as BF
import Data.CBMVar
import qualified Data.EventList.Absolute.TimeBody as EventListAbs
import qualified Data.List as L
import Data.Ord (comparing)
......
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