src/RMCA/GUI/MultiBoard.hs

   1 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TupleSections #-}
   2
   3 module RMCA.GUI.MultiBoard where
   4
   5 import           Control.Concurrent.MVar
   6 import           Control.Monad
   7 import           Control.Monad.IO.Class
   8 import           Data.Array
   9 import           Data.CBRef
  10 import qualified Data.IntMap                                as M
  11 import           Data.List
  12 import           Data.Maybe
  13 import           Data.ReactiveValue
  14 import           Graphics.UI.Gtk
  15 import           Graphics.UI.Gtk.Board.TiledBoard           hiding (Board)
  16 import           Graphics.UI.Gtk.Layout.BackgroundContainer
  17 import           Graphics.UI.Gtk.Reactive.Gtk2
  18 import           RMCA.Auxiliary
  19 import           RMCA.GUI.Board
  20 import           RMCA.IOClockworks
  21 import           RMCA.Layer.LayerConf
  22 import           RMCA.MCBMVar
  23 import           RMCA.ReactiveValueAtomicUpdate
  24 import           RMCA.Semantics
  25 import           RMCA.Translator.Message
  26
  27 maxLayers :: Int
  28 maxLayers = 16
  29
  30 createNotebook :: ( ReactiveValueRead addLayer () IO
  31                   , ReactiveValueRead rmLayer () IO
  32                   , ReactiveValueAtomicUpdate board (M.IntMap ([Note],[Message])) IO
  33                   ) =>
  34                   board
  35                -> IOTick
  36                -> addLayer
  37                -> rmLayer
  38                -> MCBMVar StaticLayerConf
  39                -> MCBMVar DynLayerConf
  40                -> MCBMVar SynthConf
  41                -> MCBMVar GUICell
  42                -> IO ( Notebook
  43                      , ReactiveFieldRead IO (M.IntMap Board)
  44                      , CBRef (M.IntMap LayerConf)
  45                      , ReactiveFieldRead IO
  46                        (M.IntMap (ReactiveFieldWrite IO [PlayHead]))
  47                      )
  48 createNotebook boardQueue tc addLayerRV rmLayerRV
  49   statMCBMVar dynMCBMVar synthMCBMVar guiCellMCBMVar = do
  50   n <- notebookNew
  51   let curPageRV = ReactiveFieldReadWrite setter getter notifier
  52         where (ReactiveFieldRead getter _) = notebookGetCurrentPagePassive n
  53               -- afterSwitchPage is deprecated but switchPage gets us
  54               -- the old page number and not the new one and using
  55               -- afterSwitchPage doesn't trigger a warning so…
  56               setter = postGUIAsync . notebookSetCurrentPage n
  57               notifier io = void $ afterSwitchPage n (const io)
  58
  59   pageChanRV <- newCBMVarRW []
  60   let foundHole = let foundHole' [] = 0
  61                       foundHole' [x] = x + 1
  62                       foundHole' (x:y:xs) = if x + 1 /= y then x + 1 else foundHole (y:xs)
  63                   in foundHole' . sort
  64
  65
  66   let curChanRV = liftR2 (!!) pageChanRV curPageRV
  67   ------------------------------------------------------------------------------
  68   -- First board
  69   ------------------------------------------------------------------------------
  70
  71   chanMapRV <- newCBMVarRW M.empty
  72   guiCellHidMVar <- newEmptyMVar
  73   let clickHandler ioBoard = do
  74         state <- newEmptyMVar
  75         boardOnPress ioBoard
  76           (\iPos' -> liftIO $ do
  77               let iPos = actualTile iPos'
  78               postGUIAsync $ void $ tryPutMVar state iPos
  79               return True
  80           )
  81         boardOnRelease ioBoard
  82           (\fPos' -> do
  83               let fPos = actualTile fPos'
  84               button <- eventButton
  85               liftIO $ postGUIAsync $ do
  86                 mp <- boardGetPiece fPos ioBoard
  87                 mstate <- tryTakeMVar state
  88                 when (fPos `elem` validArea && isJust mp) $ do
  89                   let piece = snd $ fromJust mp
  90                   when (button == RightButton && maybe False (== fPos) mstate) $ do
  91                     let nCell = rotateGUICell piece
  92                     boardSetPiece fPos (Player,nCell) ioBoard
  93                   nmp <- boardGetPiece fPos ioBoard
  94                   when (button == LeftButton && isJust nmp) $ do
  95                     let nCell = snd $ fromJust nmp
  96                     mOHid <- tryTakeMVar guiCellHidMVar
  97                     forM_ mOHid $ removeCallbackMCBMVar guiCellMCBMVar
  98                     reactiveValueWrite guiCellMCBMVar nCell
  99                     nHid <- installCallbackMCBMVar guiCellMCBMVar $ do
 100                       cp <- reactiveValueRead curChanRV
 101                       guiVal <- reactiveValueRead guiCellMCBMVar
 102                       mChanRV <- M.lookup cp <$> reactiveValueRead chanMapRV
 103                       when (isNothing mChanRV) $ error "Can't get piece array!"
 104                       let (_,pieceArrRV,_) = fromJust mChanRV
 105                       reactiveValueWrite (pieceArrRV ! fPos) guiVal
 106                     putMVar guiCellHidMVar nHid
 107               return True
 108           )
 109
 110   boardCont <- backgroundContainerNew
 111   guiBoard <- attachGameRules =<< initGame
 112   clickHandler guiBoard
 113   centerBoard <- alignmentNew 0.5 0.5 0 0
 114   containerAdd centerBoard guiBoard
 115   containerAdd boardCont centerBoard
 116
 117   fstP <- notebookAppendPage n boardCont ""
 118   notebookPageNumber <- newCBMVarRW (1 :: Int)
 119
 120   initBoardRV tc guiBoard >>=
 121     \(boardRV, pieceArrRV, phRV) -> reactiveValueRead chanMapRV >>=
 122     reactiveValueWrite chanMapRV . M.insert fstP (boardRV,pieceArrRV,phRV)
 123
 124   reactiveValueRead pageChanRV >>=
 125     reactiveValueWrite pageChanRV . (\pc -> pc ++ [foundHole pc])
 126
 127   layerMapRV <- newCBRef $ M.insert fstP defaultLayerConf M.empty
 128   reactiveValueOnCanRead layerMapRV $ do
 129     synth <- fmap (\(_,_,s) -> s) <$> reactiveValueRead layerMapRV
 130     sequence_ $ M.mapWithKey
 131       (\chan mess -> reactiveValueAppend boardQueue $
 132         M.singleton chan $ ([],) $ synthMessage chan mess) synth
 133
 134   let updateDynLayer cp = do
 135         nDyn <- reactiveValueRead dynMCBMVar
 136         reactiveValueUpdate_ layerMapRV
 137           (M.adjust (\(stat,_,synth) -> (stat,nDyn,synth)) cp)
 138       updateSynth cp = do
 139         synthState <- reactiveValueRead synthMCBMVar
 140         reactiveValueAppend boardQueue $
 141           M.singleton cp $ ([],) $ synthMessage cp synthState
 142       updateStatLayer cp = do
 143         nStat <- reactiveValueRead statMCBMVar
 144         reactiveValueUpdate_ layerMapRV
 145           (M.adjust (\(_,dyn,synth) -> (nStat,dyn,synth)) cp)
 146
 147   statHidMVar <- newEmptyMVar
 148   dynHidMVar <- newEmptyMVar
 149   synthHidMVar <- newEmptyMVar
 150
 151   installCallbackMCBMVar statMCBMVar
 152     (reactiveValueRead curChanRV >>= updateStatLayer) >>= putMVar statHidMVar
 153   installCallbackMCBMVar dynMCBMVar
 154     (reactiveValueRead curChanRV >>= updateDynLayer) >>= putMVar dynHidMVar
 155   installCallbackMCBMVar synthMCBMVar
 156     (reactiveValueRead curChanRV >>= updateSynth) >>= putMVar synthHidMVar
 157
 158   ------------------------------------------------------------------------------
 159   -- Following boards
 160   ------------------------------------------------------------------------------
 161
 162   reactiveValueOnCanRead addLayerRV $ postGUIAsync $ do
 163     np <- reactiveValueRead notebookPageNumber
 164     unless (np >= maxLayers) $ do
 165       reactiveValueWrite notebookPageNumber (np + 1)
 166       nBoardCont <- backgroundContainerNew
 167
 168       nGuiBoard <- attachGameRules =<< initGame
 169       clickHandler nGuiBoard
 170       nCenterBoard <- alignmentNew 0.5 0.5 0 0
 171       containerAdd nCenterBoard nGuiBoard
 172       containerAdd nBoardCont nCenterBoard
 173
 174       notebookAppendPage n nBoardCont $ show np
 175       pChan <- reactiveValueRead pageChanRV
 176       let newCP = foundHole pChan
 177       (nBoardRV, nPieceArrRV, nPhRV) <- initBoardRV tc nGuiBoard
 178
 179       reactiveValueRead chanMapRV >>=
 180         reactiveValueWrite chanMapRV . M.insert newCP (nBoardRV,nPieceArrRV,nPhRV)
 181       reactiveValueRead layerMapRV >>=
 182         reactiveValueWrite layerMapRV . M.insert newCP defaultLayerConf
 183
 184       --reactiveValueWrite curPageRV newP
 185       reactiveValueWrite pageChanRV (pChan ++ [newCP])
 186       widgetShowAll n
 187
 188   reactiveValueOnCanRead rmLayerRV $ postGUIAsync $ do
 189     np <- reactiveValueRead notebookPageNumber
 190     when (np > 1) $ do
 191       cp <- reactiveValueRead curPageRV
 192       oldCP <- reactiveValueRead curChanRV
 193       let rmIndex :: Int -> [a] -> [a]
 194           rmIndex n l = take n l ++ drop (n + 1) l
 195       notebookRemovePage n cp
 196
 197       reactiveValueRead pageChanRV >>=
 198         reactiveValueWrite pageChanRV . rmIndex cp
 199
 200       reactiveValueRead notebookPageNumber >>=
 201         reactiveValueWrite notebookPageNumber . subtract 1
 202
 203       reactiveValueRead chanMapRV >>=
 204         reactiveValueWrite chanMapRV . M.delete oldCP
 205
 206       reactiveValueRead layerMapRV >>=
 207         reactiveValueWrite layerMapRV . M.delete oldCP
 208
 209     widgetShowAll n
 210     return ()
 211
 212   reactiveValueOnCanRead curChanRV $ do
 213     cp <- reactiveValueRead curChanRV
 214     when (cp >= 0) $ do
 215       takeMVar dynHidMVar >>= removeCallbackMCBMVar dynMCBMVar
 216       takeMVar statHidMVar >>= removeCallbackMCBMVar statMCBMVar
 217       takeMVar synthHidMVar >>= removeCallbackMCBMVar synthMCBMVar
 218       layerMap <- reactiveValueRead layerMapRV
 219       let mSelLayer = M.lookup cp layerMap
 220       when (isNothing mSelLayer) $ error "Not found selected layer!"
 221       let selLayer = fromJust mSelLayer
 222       reactiveValueWrite dynMCBMVar (dynConf selLayer)
 223       installCallbackMCBMVar dynMCBMVar (updateDynLayer cp) >>=
 224         putMVar dynHidMVar
 225       reactiveValueWrite statMCBMVar (staticConf selLayer)
 226       installCallbackMCBMVar statMCBMVar (updateStatLayer cp) >>=
 227         putMVar statHidMVar
 228       reactiveValueWrite synthMCBMVar (synthConf selLayer)
 229       installCallbackMCBMVar synthMCBMVar (updateSynth cp) >>=
 230         putMVar synthHidMVar
 231       return ()
 232
 233     oldCurChanRV <- newCBMVarRW =<< reactiveValueRead curChanRV
 234     reactiveValueOnCanRead curChanRV $ do
 235       oldC <- reactiveValueRead oldCurChanRV
 236       newC <- reactiveValueRead curChanRV
 237       when (oldC /= newC) $ do
 238         reactiveValueWrite oldCurChanRV newC
 239         tryTakeMVar guiCellHidMVar >>=
 240           fromMaybeM_ . fmap (removeCallbackMCBMVar guiCellMCBMVar)
 241         reactiveValueWrite guiCellMCBMVar inertCell
 242
 243   ------------------------------------------------------------------------------
 244   -- Flatten maps
 245   ------------------------------------------------------------------------------
 246   let phMapRV :: ReactiveFieldRead IO (M.IntMap (ReactiveFieldWrite IO [PlayHead]))
 247       phMapRV = liftR (M.map (\(_,_,b) -> b)) chanMapRV
 248
 249       boardMapRV :: ReactiveFieldRead IO (M.IntMap Board)
 250       boardMapRV = ReactiveFieldRead getter notifier
 251         where notifier io = do
 252                 chanMap <- reactiveValueRead chanMapRV
 253                 mapM_ ((`reactiveValueOnCanRead` io) . \(b,_,_) -> b) chanMap
 254               getter = do
 255                 chanMap <- reactiveValueRead chanMapRV
 256                 mapM (reactiveValueRead . \(b,_,_) -> b) chanMap
 257
 258   return (n, boardMapRV, layerMapRV, phMapRV)