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