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