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