src/RMCA/GUI/MultiBoard.hs

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