-{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TupleSections #-}
module RMCA.GUI.MultiBoard where
import Control.Monad
import Control.Monad.IO.Class
import Data.Array
+import Data.CBRef
+import qualified Data.IntMap as M
import Data.List
-import qualified Data.Map as M
import Data.Maybe
import Data.ReactiveValue
import Graphics.UI.Gtk
-import Graphics.UI.Gtk.Board.BoardLink
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.GUI.Board
-import RMCA.Layer.Layer
+import RMCA.IOClockworks
+import RMCA.Layer.LayerConf
import RMCA.MCBMVar
+import RMCA.ReactiveValueAtomicUpdate
import RMCA.Semantics
+import RMCA.Translator.Message
--- In GTk, a “thing with tabs” has the, I think, very confusing name
--- Notebook.
+maxLayers :: Int
+maxLayers = 16
createNotebook :: ( ReactiveValueRead addLayer () IO
, ReactiveValueRead rmLayer () IO
+ , ReactiveValueAtomicUpdate board (M.IntMap ([Note],[Message])) IO
) =>
- addLayer
+ board
+ -> IOTick
+ -> addLayer
-> rmLayer
- -> MCBMVar Layer
+ -> MCBMVar StaticLayerConf
+ -> MCBMVar DynLayerConf
+ -> MCBMVar SynthConf
-> MCBMVar GUICell
-> IO ( Notebook
- , ReactiveFieldReadWrite IO
- (M.Map Int ( ReactiveFieldRead IO Board
- , Array Pos (ReactiveFieldWrite IO GUICell)
- , ReactiveFieldWrite IO [PlayHead]
- ))
- , ReactiveFieldReadWrite IO Int
+ , ReactiveFieldRead IO (M.IntMap Board)
+ , CBRef (M.IntMap LayerConf)
+ , ReactiveFieldRead IO
+ (M.IntMap (ReactiveFieldWrite IO [PlayHead]))
)
-createNotebook addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
+createNotebook boardQueue tc addLayerRV rmLayerRV
+ statMCBMVar dynMCBMVar synthMCBMVar guiCellMCBMVar = do
n <- notebookNew
let curPageRV = ReactiveFieldReadWrite setter getter notifier
where (ReactiveFieldRead getter _) = notebookGetCurrentPagePassive n
-- afterSwitchPage is deprecated but switchPage gets us
-- the old page number and not the new one and using
- -- afterSwitchPage doesn't trigger a warning.
+ -- afterSwitchPage doesn't trigger a warning so…
setter = postGUIAsync . notebookSetCurrentPage n
notifier io = void $ afterSwitchPage n (const io)
pageChanRV <- newCBMVarRW []
let foundHole = let foundHole' [] = 0
- foundHole' (x:[]) = x + 1
+ foundHole' [x] = x + 1
foundHole' (x:y:xs) = if x + 1 /= y then x + 1 else foundHole (y:xs)
in foundHole' . sort
let clickHandler ioBoard = do
state <- newEmptyMVar
boardOnPress ioBoard
- (\iPos -> liftIO $ do
+ (\iPos' -> liftIO $ do
+ let iPos = actualTile iPos'
postGUIAsync $ void $ tryPutMVar state iPos
return True
)
boardOnRelease ioBoard
- (\fPos -> do
- button <- eventButton
- liftIO $ postGUIAsync $ do
- mp <- boardGetPiece fPos ioBoard
- mstate <- tryTakeMVar state
- when (fPos `elem` validArea && isJust mp) $ do
- let piece = snd $ fromJust mp
- when (button == RightButton && maybe False (== fPos) mstate) $ do
- let nCell = rotateGUICell piece
- --boardSetPiece fPos nPiece ioBoard
- reactiveValueWrite guiCellMCBMVar nCell
- nmp <- boardGetPiece fPos ioBoard
- when (button == LeftButton && isJust nmp) $ do
- let nCell = snd $ fromJust nmp
- mOHid <- tryTakeMVar guiCellHidMVar
- when (isJust mOHid) $
- removeCallbackMCBMVar guiCellMCBMVar $ fromJust mOHid
- reactiveValueWrite guiCellMCBMVar nCell
- nHid <- installCallbackMCBMVar guiCellMCBMVar $ do
- cp <- reactiveValueRead curChanRV
- guiVal <- reactiveValueRead guiCellMCBMVar
- mChanRV <- M.lookup cp <$> reactiveValueRead chanMapRV
- when (isNothing mChanRV) $ error "Can't get piece array!"
- let (_,pieceArrRV,_) = fromJust mChanRV
- reactiveValueWrite (pieceArrRV ! fPos) guiVal
- putMVar guiCellHidMVar nHid
- return True
+ (\fPos' -> do
+ let fPos = actualTile fPos'
+ button <- eventButton
+ liftIO $ postGUIAsync $ do
+ mp <- boardGetPiece fPos ioBoard
+ mstate <- tryTakeMVar state
+ when (fPos `elem` validArea && isJust mp) $ do
+ let piece = snd $ fromJust mp
+ when (button == RightButton && maybe False (== fPos) mstate) $ do
+ let nCell = rotateGUICell piece
+ boardSetPiece fPos (Player,nCell) ioBoard
+ nmp <- boardGetPiece fPos ioBoard
+ when (button == LeftButton && isJust nmp) $ do
+ let nCell = snd $ fromJust nmp
+ mOHid <- tryTakeMVar guiCellHidMVar
+ forM_ mOHid $ removeCallbackMCBMVar guiCellMCBMVar
+ reactiveValueWrite guiCellMCBMVar nCell
+ nHid <- installCallbackMCBMVar guiCellMCBMVar $ do
+ cp <- reactiveValueRead curChanRV
+ guiVal <- reactiveValueRead guiCellMCBMVar
+ mChanRV <- M.lookup cp <$> reactiveValueRead chanMapRV
+ when (isNothing mChanRV) $ error "Can't get piece array!"
+ let (_,pieceArrRV,_) = fromJust mChanRV
+ reactiveValueWrite (pieceArrRV ! fPos) guiVal
+ putMVar guiCellHidMVar nHid
+ return True
)
boardCont <- backgroundContainerNew
containerAdd centerBoard guiBoard
containerAdd boardCont centerBoard
- fstP <- notebookAppendPage n boardCont "Lol first"
- notebookPageNumber <- newCBMVarRW 1
+ fstP <- notebookAppendPage n boardCont ""
+ notebookPageNumber <- newCBMVarRW (1 :: Int)
- initBoardRV guiBoard >>=
+ initBoardRV tc guiBoard >>=
\(boardRV, pieceArrRV, phRV) -> reactiveValueRead chanMapRV >>=
reactiveValueWrite chanMapRV . M.insert fstP (boardRV,pieceArrRV,phRV)
reactiveValueRead pageChanRV >>=
reactiveValueWrite pageChanRV . (\pc -> pc ++ [foundHole pc])
- layerMapRV <- newCBMVarRW $ M.insert fstP defaultLayer M.empty
- let updateLayer cp = do
- nLayer <- reactiveValueRead layerMCBMVar
- reactiveValueRead layerMapRV >>=
- reactiveValueWrite layerMapRV . M.insert cp nLayer
+ layerMapRV <- newCBRef $ M.insert fstP defaultLayerConf M.empty
+ reactiveValueOnCanRead layerMapRV $ do
+ synth <- fmap (\(_,_,s) -> s) <$> reactiveValueRead layerMapRV
+ sequence_ $ M.mapWithKey
+ (\chan mess -> reactiveValueAppend boardQueue $
+ M.singleton chan $ ([],) $ synthMessage chan mess) synth
+
+ let updateDynLayer cp = do
+ nDyn <- reactiveValueRead dynMCBMVar
+ reactiveValueUpdate_ layerMapRV
+ (M.adjust (\(stat,_,synth) -> (stat,nDyn,synth)) cp)
+ updateSynth cp = do
+ synthState <- reactiveValueRead synthMCBMVar
+ reactiveValueAppend boardQueue $
+ M.singleton cp $ ([],) $ synthMessage cp synthState
+ updateStatLayer cp = do
+ nStat <- reactiveValueRead statMCBMVar
+ reactiveValueUpdate_ layerMapRV
+ (M.adjust (\(_,dyn,synth) -> (nStat,dyn,synth)) cp)
- layerHidMVar <- newEmptyMVar
+ statHidMVar <- newEmptyMVar
+ dynHidMVar <- newEmptyMVar
+ synthHidMVar <- newEmptyMVar
- installCallbackMCBMVar layerMCBMVar
- (reactiveValueRead curChanRV >>= updateLayer) >>= putMVar layerHidMVar
+ installCallbackMCBMVar statMCBMVar
+ (reactiveValueRead curChanRV >>= updateStatLayer) >>= putMVar statHidMVar
+ installCallbackMCBMVar dynMCBMVar
+ (reactiveValueRead curChanRV >>= updateDynLayer) >>= putMVar dynHidMVar
+ installCallbackMCBMVar synthMCBMVar
+ (reactiveValueRead curChanRV >>= updateSynth) >>= putMVar synthHidMVar
------------------------------------------------------------------------------
-- Following boards
reactiveValueOnCanRead addLayerRV $ postGUIAsync $ do
np <- reactiveValueRead notebookPageNumber
- unless (np >= 16) $ do
+ unless (np >= maxLayers) $ do
reactiveValueWrite notebookPageNumber (np + 1)
nBoardCont <- backgroundContainerNew
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)
reactiveValueRead layerMapRV >>=
- reactiveValueWrite layerMapRV . M.insert newCP defaultLayer
+ reactiveValueWrite layerMapRV . M.insert newCP defaultLayerConf
--reactiveValueWrite curPageRV newP
reactiveValueWrite pageChanRV (pChan ++ [newCP])
reactiveValueRead chanMapRV >>=
reactiveValueWrite chanMapRV . M.delete oldCP
+
reactiveValueRead layerMapRV >>=
reactiveValueWrite layerMapRV . M.delete oldCP
- --updateRV curPageRV
-
widgetShowAll n
return ()
reactiveValueOnCanRead curChanRV $ do
cp <- reactiveValueRead curChanRV
when (cp >= 0) $ do
- takeMVar layerHidMVar >>= removeCallbackMCBMVar layerMCBMVar
+ takeMVar dynHidMVar >>= removeCallbackMCBMVar dynMCBMVar
+ takeMVar statHidMVar >>= removeCallbackMCBMVar statMCBMVar
+ takeMVar synthHidMVar >>= removeCallbackMCBMVar synthMCBMVar
layerMap <- reactiveValueRead layerMapRV
let mSelLayer = M.lookup cp layerMap
when (isNothing mSelLayer) $ error "Not found selected layer!"
let selLayer = fromJust mSelLayer
- reactiveValueWrite layerMCBMVar selLayer
- installCallbackMCBMVar layerMCBMVar (updateLayer cp) >>=
- putMVar layerHidMVar
+ reactiveValueWrite dynMCBMVar (dynConf selLayer)
+ installCallbackMCBMVar dynMCBMVar (updateDynLayer cp) >>=
+ putMVar dynHidMVar
+ reactiveValueWrite statMCBMVar (staticConf selLayer)
+ installCallbackMCBMVar statMCBMVar (updateStatLayer cp) >>=
+ putMVar statHidMVar
+ reactiveValueWrite synthMCBMVar (synthConf selLayer)
+ installCallbackMCBMVar synthMCBMVar (updateSynth cp) >>=
+ putMVar synthHidMVar
return ()
oldCurChanRV <- newCBMVarRW =<< reactiveValueRead curChanRV
reactiveValueWrite guiCellMCBMVar inertCell
------------------------------------------------------------------------------
- -- For good measure
+ -- Flatten maps
------------------------------------------------------------------------------
- return (n, chanMapRV, curPageRV)
+ let phMapRV :: ReactiveFieldRead IO (M.IntMap (ReactiveFieldWrite IO [PlayHead]))
+ phMapRV = liftR (M.map (\(_,_,b) -> b)) chanMapRV
+
+ boardMapRV :: ReactiveFieldRead IO (M.IntMap Board)
+ boardMapRV = ReactiveFieldRead getter notifier
+ where notifier io = do
+ chanMap <- reactiveValueRead chanMapRV
+ mapM_ ((`reactiveValueOnCanRead` io) . \(b,_,_) -> b) chanMap
+ getter = do
+ chanMap <- reactiveValueRead chanMapRV
+ mapM (reactiveValueRead . \(b,_,_) -> b) chanMap
+
+ return (n, boardMapRV, layerMapRV, phMapRV)
sourcephile / git / tmp / julm / arpeggigon.git / blobdiff