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                     maybe (return ()) (removeCallbackMCBMVar guiCellMCBMVar) mOHid
  98                     reactiveValueWrite guiCellMCBMVar nCell
  99                     nHid <- installCallbackMCBMVar guiCellMCBMVar $ do
 100                       cp <- reactiveValueRead curChanRV
 101                       guiVal <- reactiveValueRead guiCellMCBMVar
 102                       mChanRV <- fmap (M.lookup cp)
 103                                       (reactiveValueRead chanMapRV)
 104                       when (isNothing mChanRV) $ error "Can't get piece array!"
 105                       let (_,pieceArrRV,_) = fromJust mChanRV
 106                       reactiveValueWrite (pieceArrRV ! fPos) guiVal
 107                     putMVar guiCellHidMVar nHid
 108               return True
 109           )
 110
 111   boardCont <- backgroundContainerNew
 112   guiBoard <- attachGameRules =<< initGame
 113   clickHandler guiBoard
 114   centerBoard <- alignmentNew 0.5 0.5 0 0
 115   containerAdd centerBoard guiBoard
 116   containerAdd boardCont centerBoard
 117
 118   fstP <- notebookAppendPage n boardCont ""
 119   notebookPageNumber <- newCBMVarRW (1 :: Int)
 120
 121   initBoardRV tc guiBoard >>=
 122     \(boardRV, pieceArrRV, phRV) -> reactiveValueRead chanMapRV >>=
 123     reactiveValueWrite chanMapRV . M.insert fstP (boardRV,pieceArrRV,phRV)
 124
 125   reactiveValueRead pageChanRV >>=
 126     reactiveValueWrite pageChanRV . (\pc -> pc ++ [foundHole pc])
 127
 128   layerMapRV <- newCBRef $ M.insert fstP defaultLayerConf M.empty
 129   reactiveValueOnCanRead layerMapRV $ do
 130     synth <- fmap (fmap (\(_,_,s) -> s)) (reactiveValueRead layerMapRV)
 131     sequence_ $ M.elems $ M.mapWithKey
 132       (\chan mess -> reactiveValueAppend boardQueue $
 133         M.singleton chan $ ([],) $ synthMessage chan mess) synth
 134
 135   let updateDynLayer cp = do
 136         nDyn <- reactiveValueRead dynMCBMVar
 137         reactiveValueUpdate_ layerMapRV
 138           (M.adjust (\(stat,_,synth) -> (stat,nDyn,synth)) cp)
 139       updateSynth cp = do
 140         nSynth <- reactiveValueRead synthMCBMVar
 141         reactiveValueUpdate_ layerMapRV
 142           (M.adjust (\(stat,dyn,_) -> (stat,dyn,nSynth)) cp)
 143         reactiveValueAppend boardQueue $
 144           M.singleton cp $ ([],) $ synthMessage cp nSynth
 145       updateStatLayer cp = do
 146         nStat <- reactiveValueRead statMCBMVar
 147         reactiveValueUpdate_ layerMapRV
 148           (M.adjust (\(_,dyn,synth) -> (nStat,dyn,synth)) cp)
 149
 150   statHidMVar <- newEmptyMVar
 151   dynHidMVar <- newEmptyMVar
 152   synthHidMVar <- newEmptyMVar
 153
 154   installCallbackMCBMVar statMCBMVar
 155     (reactiveValueRead curChanRV >>= updateStatLayer) >>= putMVar statHidMVar
 156   installCallbackMCBMVar dynMCBMVar
 157     (reactiveValueRead curChanRV >>= updateDynLayer) >>= putMVar dynHidMVar
 158   installCallbackMCBMVar synthMCBMVar
 159     (reactiveValueRead curChanRV >>= updateSynth) >>= putMVar synthHidMVar
 160
 161   ------------------------------------------------------------------------------
 162   -- Following boards
 163   ------------------------------------------------------------------------------
 164
 165   reactiveValueOnCanRead addLayerRV $ postGUIAsync $ do
 166     np <- reactiveValueRead notebookPageNumber
 167     unless (np >= maxLayers) $ do
 168       reactiveValueWrite notebookPageNumber (np + 1)
 169       nBoardCont <- backgroundContainerNew
 170
 171       nGuiBoard <- attachGameRules =<< initGame
 172       clickHandler nGuiBoard
 173       nCenterBoard <- alignmentNew 0.5 0.5 0 0
 174       containerAdd nCenterBoard nGuiBoard
 175       containerAdd nBoardCont nCenterBoard
 176
 177       notebookAppendPage n nBoardCont $ show np
 178       pChan <- reactiveValueRead pageChanRV
 179       let newCP = foundHole pChan
 180       (nBoardRV, nPieceArrRV, nPhRV) <- initBoardRV tc nGuiBoard
 181
 182       reactiveValueRead chanMapRV >>=
 183         reactiveValueWrite chanMapRV . M.insert newCP (nBoardRV,nPieceArrRV,nPhRV)
 184       reactiveValueRead layerMapRV >>=
 185         reactiveValueWrite layerMapRV . M.insert newCP defaultLayerConf
 186
 187       --reactiveValueWrite curPageRV newP
 188       reactiveValueWrite pageChanRV (pChan ++ [newCP])
 189       widgetShowAll n
 190
 191   reactiveValueOnCanRead rmLayerRV $ postGUIAsync $ do
 192     np <- reactiveValueRead notebookPageNumber
 193     when (np > 1) $ do
 194       cp <- reactiveValueRead curPageRV
 195       oldCP <- reactiveValueRead curChanRV
 196       let rmIndex :: Int -> [a] -> [a]
 197           rmIndex n l = take n l ++ drop (n + 1) l
 198       notebookRemovePage n cp
 199
 200       reactiveValueRead pageChanRV >>=
 201         reactiveValueWrite pageChanRV . rmIndex cp
 202
 203       reactiveValueRead notebookPageNumber >>=
 204         reactiveValueWrite notebookPageNumber . subtract 1
 205
 206       reactiveValueRead chanMapRV >>=
 207         reactiveValueWrite chanMapRV . M.delete oldCP
 208
 209       reactiveValueRead layerMapRV >>=
 210         reactiveValueWrite layerMapRV . M.delete oldCP
 211
 212     widgetShowAll n
 213     return ()
 214
 215   reactiveValueOnCanRead curChanRV $ do
 216     cp <- reactiveValueRead curChanRV
 217     when (cp >= 0) $ do
 218       takeMVar dynHidMVar >>= removeCallbackMCBMVar dynMCBMVar
 219       takeMVar statHidMVar >>= removeCallbackMCBMVar statMCBMVar
 220       takeMVar synthHidMVar >>= removeCallbackMCBMVar synthMCBMVar
 221       layerMap <- reactiveValueRead layerMapRV
 222       let mSelLayer = M.lookup cp layerMap
 223       when (isNothing mSelLayer) $ error "Not found selected layer!"
 224       let selLayer = fromJust mSelLayer
 225       reactiveValueWrite dynMCBMVar (dynConf selLayer)
 226       installCallbackMCBMVar dynMCBMVar (updateDynLayer cp) >>=
 227         putMVar dynHidMVar
 228       reactiveValueWrite statMCBMVar (staticConf selLayer)
 229       installCallbackMCBMVar statMCBMVar (updateStatLayer cp) >>=
 230         putMVar statHidMVar
 231       reactiveValueWrite synthMCBMVar (synthConf selLayer)
 232       installCallbackMCBMVar synthMCBMVar (updateSynth cp) >>=
 233         putMVar synthHidMVar
 234       return ()
 235
 236     oldCurChanRV <- newCBMVarRW =<< reactiveValueRead curChanRV
 237     reactiveValueOnCanRead curChanRV $ do
 238       oldC <- reactiveValueRead oldCurChanRV
 239       newC <- reactiveValueRead curChanRV
 240       when (oldC /= newC) $ do
 241         reactiveValueWrite oldCurChanRV newC
 242         tryTakeMVar guiCellHidMVar >>=
 243           fromMaybeM_ . fmap (removeCallbackMCBMVar guiCellMCBMVar)
 244         reactiveValueWrite guiCellMCBMVar inertCell
 245
 246   ------------------------------------------------------------------------------
 247   -- Flatten maps
 248   ------------------------------------------------------------------------------
 249   let phMapRV :: ReactiveFieldRead IO (M.IntMap (ReactiveFieldWrite IO [PlayHead]))
 250       phMapRV = liftR (M.map (\(_,_,b) -> b)) chanMapRV
 251
 252       boardMapRV :: ReactiveFieldRead IO (M.IntMap Board)
 253       boardMapRV = ReactiveFieldRead getter notifier
 254         where notifier io = do
 255                 chanMap <- reactiveValueRead chanMapRV
 256                 intMapMapM_ ((`reactiveValueOnCanRead` io) . \(b,_,_) -> b) chanMap
 257               getter = do
 258                 chanMap <- reactiveValueRead chanMapRV
 259                 intMapMapM (reactiveValueRead . \(b,_,_) -> b) chanMap
 260
 261   return (n, boardMapRV, layerMapRV, phMapRV)
 262
 263 ------------------------------------------------------------------------------
 264 -- IntMap versions of mapM etc. to make code work with GHC 7.8.3
 265 ------------------------------------------------------------------------------
 266
 267 intMapMapM_ :: (Functor m, Monad m) => (a -> m b) -> M.IntMap a -> m ()
 268 intMapMapM_ f im = mapM_ f (M.elems im)
 269
 270 intMapMapM :: (Functor m, Monad m) => (a -> m b) -> M.IntMap a -> m (M.IntMap b)
 271 intMapMapM f im = fmap (M.fromList . zip ks) (mapM f es)
 272     where
 273         (ks, es) = unzip (M.toList im)