From 345509022c1a7eea311158361bcdbaa2fbc24c32 Mon Sep 17 00:00:00 2001
From: jin <psyzj1@nottingham.ac.uk>
Date: Tue, 29 Aug 2017 09:28:48 +0800
Subject: [PATCH] Add button to clear single layer
---
src/RMCA/GUI/Board.hs | 1 +
src/RMCA/GUI/Buttons.hs | 6 +++
src/RMCA/GUI/MultiBoard.hs | 76 ++++++++++++++++++++++++++++++------
src/RMCA/GUI/NoteSettings.hs | 3 --
src/RMCA/GUI/StockId.hs | 3 ++
src/RMCA/Main.hs | 4 +-
6 files changed, 77 insertions(+), 16 deletions(-)
diff --git a/src/RMCA/GUI/Board.hs b/src/RMCA/GUI/Board.hs
index 06d464c..372b8f2 100644
--- a/src/RMCA/GUI/Board.hs
+++ b/src/RMCA/GUI/Board.hs
@@ -191,6 +191,7 @@ initBoardRV tc board@BIO.Board { boardPieces = (GameBoard gArray) } = do
second ((\(_,c) -> (cellAction c,repeatCount c)) .
fromJust)) $
filter (isJust . snd) boardArray
+ -- print board
return board
notifierB :: IO () -> IO ()
diff --git a/src/RMCA/GUI/Buttons.hs b/src/RMCA/GUI/Buttons.hs
index 5fef4fb..663736b 100644
--- a/src/RMCA/GUI/Buttons.hs
+++ b/src/RMCA/GUI/Buttons.hs
@@ -51,6 +51,7 @@ getButtons :: (ReactiveValueRead boardStatus RunStatus IO) =>
, ReactiveFieldRead IO ()
, ReactiveFieldRead IO ()
, ReactiveFieldRead IO ()
+ , ReactiveFieldRead IO ()
)
getButtons boardStatusRV = do
--addRestartButton
@@ -70,6 +71,10 @@ getButtons boardStatusRV = do
let rmLayerRV = buttonActivateField buttonRmLayer
boxPackStart buttonBoxAddRmLayers buttonRmLayer PackGrow 0
+ buttonRmAll <- buttonNewFromStockWithLabel gtkMediaRemove "Clear"
+ let rmAllRV = buttonActivateField buttonRmAll
+ boxPackStart buttonBoxAddRmLayers buttonRmAll PackGrow 0
+
buttonBoxSaveLoad <- hBoxNew True 10
boxPackStart buttonBox buttonBoxSaveLoad PackNatural 0
@@ -114,4 +119,5 @@ getButtons boardStatusRV = do
, confLoadRV
, addLayerRV
, rmLayerRV
+ , rmAllRV
)
diff --git a/src/RMCA/GUI/MultiBoard.hs b/src/RMCA/GUI/MultiBoard.hs
index cde2db7..c10ba4c 100644
--- a/src/RMCA/GUI/MultiBoard.hs
+++ b/src/RMCA/GUI/MultiBoard.hs
@@ -33,12 +33,14 @@ layerName = "Layer"
createNotebook :: ( ReactiveValueRead addLayer () IO
, ReactiveValueRead rmLayer () IO
+ , ReactiveValueRead clear () IO
, ReactiveValueAtomicUpdate board (M.IntMap ([Note],[Message])) IO
) =>
board
-> IOTick
-> addLayer
-> rmLayer
+ -> clear
-> MCBMVar StaticLayerConf
-> MCBMVar DynLayerConf
-> MCBMVar SynthConf
@@ -49,7 +51,7 @@ createNotebook :: ( ReactiveValueRead addLayer () IO
, ReactiveFieldRead IO
(M.IntMap (ReactiveFieldWrite IO [PlayHead]))
)
-createNotebook boardQueue tc addLayerRV rmLayerRV
+createNotebook boardQueue tc addLayerRV rmLayerRV clearRV
statMCBMVar dynMCBMVar synthMCBMVar guiCellMCBMVar = do
n <- notebookNew
let curPageRV = ReactiveFieldReadWrite setter getter notifier
@@ -61,13 +63,10 @@ createNotebook boardQueue tc addLayerRV rmLayerRV
notifier io = void $ afterSwitchPage n (const io)
pageChanRV <- newCBMVarRW []
- let foundHole = let foundHole' [] = 0
- foundHole' [x] = x + 1
- foundHole' (x:y:xs) = if x + 1 /= y then x + 1 else foundHole (y:xs)
- in foundHole' . sort
+ let foundHole ns = head $ [0..15] \\ ns
- let curChanRV = liftR2 (!!) pageChanRV curPageRV
+ curChanRV = liftR2 (!!) pageChanRV curPageRV
------------------------------------------------------------------------------
-- First board
------------------------------------------------------------------------------
@@ -119,7 +118,7 @@ createNotebook boardQueue tc addLayerRV rmLayerRV
containerAdd centerBoard guiBoard
containerAdd boardCont centerBoard
- fstP <- notebookAppendPage n boardCont layerName
+ fstP <- notebookAppendPage n boardCont "layer-0"
notebookPageNumber <- newCBMVarRW (1 :: Int)
initBoardRV tc guiBoard >>=
@@ -127,7 +126,7 @@ createNotebook boardQueue tc addLayerRV rmLayerRV
reactiveValueWrite chanMapRV . M.insert fstP (boardRV,pieceArrRV,phRV)
reactiveValueRead pageChanRV >>=
- reactiveValueWrite pageChanRV . (\pc -> pc ++ [foundHole pc])
+ reactiveValueWrite pageChanRV . (\pc -> insert (foundHole pc) pc)
layerMapRV <- newCBRef $ M.insert fstP defaultLayerConf M.empty
reactiveValueOnCanRead layerMapRV $ do
@@ -178,7 +177,8 @@ createNotebook boardQueue tc addLayerRV rmLayerRV
containerAdd nCenterBoard nGuiBoard
containerAdd nBoardCont nCenterBoard
- notebookAppendPage n nBoardCont layerName
+ pageChan <- reactiveValueRead pageChanRV
+ notebookAppendPage n nBoardCont $ "layer-"++show (foundHole pageChan)
pChan <- reactiveValueRead pageChanRV
let newCP = foundHole pChan
(nBoardRV, nPieceArrRV, nPhRV) <- initBoardRV tc nGuiBoard
@@ -188,8 +188,8 @@ createNotebook boardQueue tc addLayerRV rmLayerRV
reactiveValueRead layerMapRV >>=
reactiveValueWrite layerMapRV . M.insert newCP defaultLayerConf
- --reactiveValueWrite curPageRV newP
reactiveValueWrite pageChanRV (pChan ++ [newCP])
+ -- reactiveValueRead pageChanRV >>= print
widgetShowAll n
reactiveValueOnCanRead rmLayerRV $ postGUIAsync $ do
@@ -213,8 +213,62 @@ createNotebook boardQueue tc addLayerRV rmLayerRV
reactiveValueRead layerMapRV >>=
reactiveValueWrite layerMapRV . M.delete oldCP
+ reactiveValueRead notebookPageNumber >>= print
+ -- notebookGetNPages n >>= print . show
+ -- reactiveValueRead pageChanRV >>= print
+
+ widgetShowAll n
+ return ()
+
+ reactiveValueOnCanRead clearRV $ postGUIAsync $ do
+ np <- reactiveValueRead notebookPageNumber
+ unless (np >= maxLayers) $ do
+ {-
+ let temp p = if (p > 1) then do
+ cp <- reactiveValueRead curPageRV
+ oldCP <- reactiveValueRead curChanRV
+ let rmIndex :: Int -> [a] -> [a]
+ rmIndex n l = take n l ++ drop (n + 1) l
+ notebookRemovePage n 0
+ {-
+ reactiveValueRead pageChanRV >>= print
+ reactiveValueRead curPageRV >>= print
+ reactiveValueRead notebookPageNumber >>= print
+ notebookGetNPages n >>= print . show
+ reactiveValueRead curChanRV >>= print
+ -}
+ reactiveValueRead pageChanRV >>=
+ reactiveValueWrite pageChanRV . rmIndex cp
+
+ reactiveValueRead notebookPageNumber >>=
+ reactiveValueWrite notebookPageNumber . subtract 1
+
+ reactiveValueRead chanMapRV >>=
+ reactiveValueWrite chanMapRV . M.delete oldCP
+
+ reactiveValueRead layerMapRV >>=
+ reactiveValueWrite layerMapRV . M.delete oldCP
+
+ temp (p - 1)
+
+ else
+ return ()
+ temp np
+ -}
+ curChan <- reactiveValueRead curChanRV
+ -- print "curChan = " >> print curChan
+ -- print "pageMap = " >> reactiveValueRead pageChanRV >>= print
+ chanMap <- reactiveValueRead chanMapRV
+ let mSelChan = M.lookup curChan chanMap
+ when (isNothing mSelChan) $ error "Not found selected chan!"
+ let selChan = fromJust mSelChan
+ pieceArrRV :: Array Pos (ReactiveFieldWrite IO GUICell)
+ pieceArrRV = (\(_,s,_) -> s) selChan
+ sequence_ [reactiveValueWrite (pieceArrRV ! i) inertCell | i <- validArea]
+
widgetShowAll n
return ()
+
reactiveValueOnCanRead curChanRV $ do
cp <- reactiveValueRead curChanRV
@@ -233,7 +287,7 @@ createNotebook boardQueue tc addLayerRV rmLayerRV
installCallbackMCBMVar statMCBMVar (updateStatLayer cp) >>=
putMVar statHidMVar
reactiveValueWrite synthMCBMVar (synthConf selLayer)
- installCallbackMCBMVar synthMCBMVar (updateSynth cp) >>=
+ installCallbackMCBMVar synthMCBMVar (updateSynth $ cp) >>=
putMVar synthHidMVar
return ()
diff --git a/src/RMCA/GUI/NoteSettings.hs b/src/RMCA/GUI/NoteSettings.hs
index e3933a8..45647f2 100644
--- a/src/RMCA/GUI/NoteSettings.hs
+++ b/src/RMCA/GUI/NoteSettings.hs
@@ -19,9 +19,6 @@ import RMCA.GUI.Board
import RMCA.MCBMVar
import RMCA.Semantics
-toJust :: a -> Maybe a
-toJust a = Just a
-
getSplit :: Action -> Maybe Action
getSplit (Split na ds) = Just (Split na ds)
getSplit _ = Nothing
diff --git a/src/RMCA/GUI/StockId.hs b/src/RMCA/GUI/StockId.hs
index 0d5b365..8c17478 100644
--- a/src/RMCA/GUI/StockId.hs
+++ b/src/RMCA/GUI/StockId.hs
@@ -26,5 +26,8 @@ gtkMediaAdd = stringToGlib "gtk-add"
gtkMediaRemove :: DefaultGlibString
gtkMediaRemove = stringToGlib "gtk-remove"
+gtkMediaRmAll :: DefaultGlibString
+gtkMediaRmAll = stringToGlib "gtk-clear"
+
gtkMediaRestart :: DefaultGlibString
gtkMediaRestart = stringToGlib "gtk-refresh"
diff --git a/src/RMCA/Main.hs b/src/RMCA/Main.hs
index e40f854..3959ce0 100644
--- a/src/RMCA/Main.hs
+++ b/src/RMCA/Main.hs
@@ -50,7 +50,7 @@ main = do
(buttonBox,
playRV,stopRV,pauseRV,recordRV,
confSaveRV,confLoadRV,
- addLayerRV,rmLayerRV) <- getButtons boardStatusRV
+ addLayerRV,rmLayerRV, rmAllRV) <- getButtons boardStatusRV
boxPackEnd settingsBox buttonBox PackNatural 0
boardQueue <- newCBRef mempty
@@ -63,7 +63,7 @@ main = do
(noteSettingsBox, guiCellMCBMVar) <- noteSettingsBox
tc <- newIOTick
(boardCont, boardMapRV, layerMapRV, phRVMapRV) <-
- createNotebook boardQueue tc addLayerRV rmLayerRV
+ createNotebook boardQueue tc addLayerRV rmLayerRV rmAllRV
statMCBMVar dynMCBMVar synthMCBMVar guiCellMCBMVar
boxPackStart mainBox boardCont PackNatural 0
--
2.47.2