Commit 75e792b4 authored by Guerric Chupin's avatar Guerric Chupin

Board SF refactored.

parent 9125533b
......@@ -18,6 +18,9 @@ bound (min, max) x
| x > max = max
| otherwise = x
fromMaybeM_ :: (Monad m) => Maybe (m ()) -> m ()
fromMaybeM_ = fromMaybe (return ())
--------------------------------------------------------------------------------
-- FRP
--------------------------------------------------------------------------------
......
......@@ -8,6 +8,7 @@ import qualified Data.Bifunctor as BF
import Data.Maybe
import Data.ReactiveValue
import Graphics.UI.Gtk
import RMCA.Auxiliary
import RMCA.GUI.Board
import RMCA.Layer.Layer
import RMCA.Semantics
......@@ -76,3 +77,44 @@ errorLoad = messageDialogNewWithMarkup Nothing [] MessageError ButtonsClose
errorSave :: IO ()
errorSave = messageDialogNewWithMarkup Nothing [] MessageError ButtonsClose
"Error saving the configuration file!" >>= widgetShow
handleSaveLoad :: ( ReactiveValueRead save () IO
, ReactiveValueRead load () IO
, ReactiveValueReadWrite instr InstrumentNo IO
, ReactiveValueReadWrite layer Layer IO
, ReactiveValueRead board Board IO
, ReactiveValueReadWrite tempo Tempo IO
, ReactiveValueWrite cell GUICell IO) =>
tempo -> board -> layer -> instr
-> Array Pos cell -> save -> load -> IO ()
handleSaveLoad tempoRV boardRV layerRV instrRV pieceArrRV confSaveRV confLoadRV = do
fcs <- fileChooserDialogNew (Just "Save configuration") Nothing
FileChooserActionSave [("Cancel",ResponseCancel),("Ok",ResponseOk)]
reactFilt <- fileFilterNew
fileFilterAddPattern reactFilt "*.react"
fileFilterSetName reactFilt "RMCA conf files."
fileChooserAddFilter fcs reactFilt
fcl <- fileChooserDialogNew (Just "Load configuration") Nothing
FileChooserActionOpen [("Cancel",ResponseCancel),("Ok",ResponseOk)]
fileChooserAddFilter fcl reactFilt
reactiveValueOnCanRead confSaveRV $ postGUIAsync $ do
widgetShowAll fcs
let respHandle ResponseOk =
fileChooserGetFilename fcs >>= fromMaybeM_ .
fmap (\f -> saveConfiguration f tempoRV layerRV boardRV instrRV)
respHandle _ = return ()
onResponse fcs (\r -> respHandle r >> widgetHide fcs)
return ()
reactiveValueOnCanRead confLoadRV $ postGUIAsync $ do
widgetShowAll fcl
let respHandle ResponseOk =
fileChooserGetFilename fcl >>= fromMaybeM_ .
fmap (\f -> loadConfiguration f tempoRV layerRV pieceArrRV instrRV)
respHandle _ = return ()
onResponse fcl (\r -> respHandle r >> widgetHide fcl)
return ()
......@@ -205,7 +205,7 @@ initGame = do
initBoardRV :: BIO.Board Int Tile (Player,GUICell)
-> IO ( ReactiveFieldRead IO Board
, Array Pos (ReactiveFieldWrite IO GUICell)
, ReactiveFieldReadWrite IO [PlayHead])
, ReactiveFieldWrite IO [PlayHead])
initBoardRV board@BIO.Board { boardPieces = (GameBoard gArray) } = do
-- RV creation
phMVar <- newCBMVar []
......@@ -262,7 +262,7 @@ initBoardRV board@BIO.Board { boardPieces = (GameBoard gArray) } = do
[(i, ReactiveFieldWrite (setterW i))
| i <- validArea :: [(Int,Int)]]
return (b,arrW,ph)
return (b,arrW,writeOnly ph)
fileToPixbuf :: IO [(FilePath,Pixbuf)]
fileToPixbuf = mapM (\f -> let f' = ("img/" ++ f) in
......
......@@ -22,9 +22,6 @@ import RMCA.Auxiliary
import RMCA.GUI.Board
import RMCA.Semantics
fromMaybeM_ :: (Monad m) => Maybe (m ()) -> m ()
fromMaybeM_ = fromMaybe (return ())
setNAttr :: NoteAttr -> Action -> Action
setNAttr _ Inert = Inert
setNAttr _ Absorb = Absorb
......
......@@ -44,6 +44,6 @@ boardSF = proc (board, l, t, br) -> do
boardSwitch :: [PlayHead]
-> SF ((Board, Layer,Event BeatNo), Event (BoardRun, [PlayHead]))
(Event ([PlayHead],[Note]))
boardSwitch rPh = dSwitch (singleBoard rPh *** identity) fnSwitch
boardSwitch rPh = dSwitch (singleBoard rPh *** (identity >>> notYet)) fnSwitch
where fnSwitch (BoardStart, iPh) = boardSwitch iPh
fnSwitch (BoardStop, _) = boardSwitch []
......@@ -17,12 +17,13 @@ import RMCA.GUI.LayerSettings
import RMCA.GUI.MainSettings
import RMCA.GUI.NoteSettings
import RMCA.Layer.Board
import RMCA.Semantics
import RMCA.Translator.Jack
main :: IO ()
main = do
-- GUI
------------------------------------------------------------------------------
-- Main GUI
------------------------------------------------------------------------------
initGUI
window <- windowNew
-- Main box
......@@ -33,9 +34,6 @@ main = do
]
windowMaximize window
boardQueue <- newCBMVarRW mempty
chanRV <- newCBMVarRW 0
settingsBox <- vBoxNew False 0
boxPackEnd mainBox settingsBox PackNatural 0
(globalSettingsBox, tempoRV) <- globalSettings
......@@ -43,6 +41,8 @@ main = do
globalSep <- hSeparatorNew
boxPackStart settingsBox globalSep PackNatural 0
boardQueue <- newCBMVarRW mempty
chanRV <- newCBMVarRW 0
(layerSettingsVBox, layerRV, instrRV) <- layerSettings chanRV boardQueue
boxPackStart settingsBox layerSettingsVBox PackNatural 0
laySep <- hSeparatorNew
......@@ -53,53 +53,18 @@ main = do
-- Board
boardCont <- backgroundContainerNew
game <- initGame
guiBoard <- attachGameRules game
guiBoard <- attachGameRules =<< initGame
centerBoard <- alignmentNew 0.5 0.5 0 0
containerAdd centerBoard guiBoard
containerAdd boardCont centerBoard
boxPackStart mainBox boardCont PackNatural 0
--boxPackStart mainBox boardCont PackNatural 0
------------------------------------------------------------------------------
-- Board setup
layer <- reactiveValueRead layerRV
tempo <- reactiveValueRead tempoRV
(boardRV, pieceArrRV, phRV) <- initBoardRV guiBoard
--fcsw <- windowNew
fcs <- fileChooserDialogNew (Just "Save configuration") Nothing
FileChooserActionSave [("Cancel",ResponseCancel),("Ok",ResponseOk)]
--containerAdd fcsw fcs
reactFilt <- fileFilterNew
fileFilterAddPattern reactFilt "*.react"
fileFilterSetName reactFilt "RMCA conf files."
fileChooserAddFilter fcs reactFilt
--fclw <- windowNew
fcl <- fileChooserDialogNew (Just "Load configuration") Nothing
FileChooserActionOpen [("Cancel",ResponseCancel),("Ok",ResponseOk)]
--containerAdd fclw fcl
fileChooserAddFilter fcl reactFilt
reactiveValueOnCanRead confSaveRV $ postGUIAsync $ do
widgetShowAll fcs
let respHandle ResponseOk =
fileChooserGetFilename fcs >>= fromMaybeM_ .
fmap (\f -> saveConfiguration f tempoRV layerRV boardRV instrRV)
respHandle _ = return ()
onResponse fcs (\r -> respHandle r >> widgetHide fcs)
return ()
reactiveValueOnCanRead confLoadRV $ postGUIAsync $ do
widgetShowAll fcl
let respHandle ResponseOk =
fileChooserGetFilename fcl >>= fromMaybeM_ .
fmap (\f -> loadConfiguration f tempoRV layerRV pieceArrRV instrRV)
respHandle _ = return ()
onResponse fcl (\r -> respHandle r >> widgetHide fcl)
return ()
handleSaveLoad tempoRV boardRV layerRV instrRV pieceArrRV confSaveRV confLoadRV
boardRunRV <- newCBMVarRW BoardStop
reactiveValueOnCanRead playRV $ reactiveValueWrite boardRunRV BoardStart
......@@ -123,8 +88,6 @@ main = do
forkIO $ jackSetup tempoRV chanRV boardQueue
widgetShowAll window
pieceBox <- clickHandling pieceArrRV guiBoard =<< vBoxNew False 10
-- Piece characteristic
--pieceBox <- pieceButtons pieceArrRV guiBoard =<< vBoxNew False 10
------------------------------------------------------------
boxPackStart settingsBox pieceBox PackNatural 10
......
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