Add button to clear single layer

diff --git a/src/RMCA/GUI/Board.hs b/src/RMCA/GUI/Board.hs
index 06d464ca243231aca046316349169a56ccd84431..372b8f290e288f7f693365fc877074d99b6a7868 100644 (file)
--- 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 5fef4fbdd931e12322dc3f060cf98e561fffe436..663736b6dc987cd7bd621bda7537cfcb0a668787 100644 (file)
--- 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 cde2db7daaab0d9969e6c0b0f8259d051e51ea5e..c10ba4c911f88524fc420b46c73f87eb563f76a9 100644 (file)
--- 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 e3933a899a66b8c390af5e0fcc6919229c6706a2..45647f2007de79379f8b9e3c5defa548f4be3096 100644 (file)
--- 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 0d5b36531dcee17e2cacc8b08bcab1f006a26dfc..8c17478593888f6570e9cf337fdfb94225f7b1f3 100644 (file)
--- 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 e40f854b6ba500824c5e70a1806cfb95eec56cd8..3959ce0a232db0b2c0c8e1431ccdcb84d6fceab7 100644 (file)
--- 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