src/RMCA/GUI/MultiBoard.hs

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