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         nSynth <- reactiveValueRead synthMCBMVar
 140         reactiveValueUpdate_ layerMapRV
 141           (M.adjust (\(stat,dyn,_) -> (stat,dyn,nSynth)) cp)
 142         reactiveValueAppend boardQueue $
 143           M.singleton cp $ ([],) $ synthMessage cp nSynth
 144       updateStatLayer cp = do
 145         nStat <- reactiveValueRead statMCBMVar
 146         reactiveValueUpdate_ layerMapRV
 147           (M.adjust (\(_,dyn,synth) -> (nStat,dyn,synth)) cp)
 148
 149   statHidMVar <- newEmptyMVar
 150   dynHidMVar <- newEmptyMVar
 151   synthHidMVar <- newEmptyMVar
 152
 153   installCallbackMCBMVar statMCBMVar
 154     (reactiveValueRead curChanRV >>= updateStatLayer) >>= putMVar statHidMVar
 155   installCallbackMCBMVar dynMCBMVar
 156     (reactiveValueRead curChanRV >>= updateDynLayer) >>= putMVar dynHidMVar
 157   installCallbackMCBMVar synthMCBMVar
 158     (reactiveValueRead curChanRV >>= updateSynth) >>= putMVar synthHidMVar
 159
 160   ------------------------------------------------------------------------------
 161   -- Following boards
 162   ------------------------------------------------------------------------------
 163
 164   reactiveValueOnCanRead addLayerRV $ postGUIAsync $ do
 165     np <- reactiveValueRead notebookPageNumber
 166     unless (np >= maxLayers) $ do
 167       reactiveValueWrite notebookPageNumber (np + 1)
 168       nBoardCont <- backgroundContainerNew
 169
 170       nGuiBoard <- attachGameRules =<< initGame
 171       clickHandler nGuiBoard
 172       nCenterBoard <- alignmentNew 0.5 0.5 0 0
 173       containerAdd nCenterBoard nGuiBoard
 174       containerAdd nBoardCont nCenterBoard
 175
 176       notebookAppendPage n nBoardCont $ show np
 177       pChan <- reactiveValueRead pageChanRV
 178       let newCP = foundHole pChan
 179       (nBoardRV, nPieceArrRV, nPhRV) <- initBoardRV tc nGuiBoard
 180
 181       reactiveValueRead chanMapRV >>=
 182         reactiveValueWrite chanMapRV . M.insert newCP (nBoardRV,nPieceArrRV,nPhRV)
 183       reactiveValueRead layerMapRV >>=
 184         reactiveValueWrite layerMapRV . M.insert newCP defaultLayerConf
 185
 186       --reactiveValueWrite curPageRV newP
 187       reactiveValueWrite pageChanRV (pChan ++ [newCP])
 188       widgetShowAll n
 189
 190   reactiveValueOnCanRead rmLayerRV $ postGUIAsync $ do
 191     np <- reactiveValueRead notebookPageNumber
 192     when (np > 1) $ do
 193       cp <- reactiveValueRead curPageRV
 194       oldCP <- reactiveValueRead curChanRV
 195       let rmIndex :: Int -> [a] -> [a]
 196           rmIndex n l = take n l ++ drop (n + 1) l
 197       notebookRemovePage n cp
 198
 199       reactiveValueRead pageChanRV >>=
 200         reactiveValueWrite pageChanRV . rmIndex cp
 201
 202       reactiveValueRead notebookPageNumber >>=
 203         reactiveValueWrite notebookPageNumber . subtract 1
 204
 205       reactiveValueRead chanMapRV >>=
 206         reactiveValueWrite chanMapRV . M.delete oldCP
 207
 208       reactiveValueRead layerMapRV >>=
 209         reactiveValueWrite layerMapRV . M.delete oldCP
 210
 211     widgetShowAll n
 212     return ()
 213
 214   reactiveValueOnCanRead curChanRV $ do
 215     cp <- reactiveValueRead curChanRV
 216     when (cp >= 0) $ do
 217       takeMVar dynHidMVar >>= removeCallbackMCBMVar dynMCBMVar
 218       takeMVar statHidMVar >>= removeCallbackMCBMVar statMCBMVar
 219       takeMVar synthHidMVar >>= removeCallbackMCBMVar synthMCBMVar
 220       layerMap <- reactiveValueRead layerMapRV
 221       let mSelLayer = M.lookup cp layerMap
 222       when (isNothing mSelLayer) $ error "Not found selected layer!"
 223       let selLayer = fromJust mSelLayer
 224       reactiveValueWrite dynMCBMVar (dynConf selLayer)
 225       installCallbackMCBMVar dynMCBMVar (updateDynLayer cp) >>=
 226         putMVar dynHidMVar
 227       reactiveValueWrite statMCBMVar (staticConf selLayer)
 228       installCallbackMCBMVar statMCBMVar (updateStatLayer cp) >>=
 229         putMVar statHidMVar
 230       reactiveValueWrite synthMCBMVar (synthConf selLayer)
 231       installCallbackMCBMVar synthMCBMVar (updateSynth cp) >>=
 232         putMVar synthHidMVar
 233       return ()
 234
 235     oldCurChanRV <- newCBMVarRW =<< reactiveValueRead curChanRV
 236     reactiveValueOnCanRead curChanRV $ do
 237       oldC <- reactiveValueRead oldCurChanRV
 238       newC <- reactiveValueRead curChanRV
 239       when (oldC /= newC) $ do
 240         reactiveValueWrite oldCurChanRV newC
 241         tryTakeMVar guiCellHidMVar >>=
 242           fromMaybeM_ . fmap (removeCallbackMCBMVar guiCellMCBMVar)
 243         reactiveValueWrite guiCellMCBMVar inertCell
 244
 245   ------------------------------------------------------------------------------
 246   -- Flatten maps
 247   ------------------------------------------------------------------------------
 248   let phMapRV :: ReactiveFieldRead IO (M.IntMap (ReactiveFieldWrite IO [PlayHead]))
 249       phMapRV = liftR (M.map (\(_,_,b) -> b)) chanMapRV
 250
 251       boardMapRV :: ReactiveFieldRead IO (M.IntMap Board)
 252       boardMapRV = ReactiveFieldRead getter notifier
 253         where notifier io = do
 254                 chanMap <- reactiveValueRead chanMapRV
 255                 mapM_ ((`reactiveValueOnCanRead` io) . \(b,_,_) -> b) chanMap
 256               getter = do
 257                 chanMap <- reactiveValueRead chanMapRV
 258                 mapM (reactiveValueRead . \(b,_,_) -> b) chanMap
 259
 260   return (n, boardMapRV, layerMapRV, phMapRV)