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                   , ReactiveValueRead clear () IO
  37                   , ReactiveValueAtomicUpdate board (M.IntMap ([Note],[Message])) IO
  38                   ) =>
  39                   board
  40                -> IOTick
  41                -> addLayer
  42                -> rmLayer
  43                -> clear
  44                -> MCBMVar StaticLayerConf
  45                -> MCBMVar DynLayerConf
  46                -> MCBMVar SynthConf
  47                -> MCBMVar GUICell
  48                -> IO ( Notebook
  49                      , ReactiveFieldRead IO (M.IntMap Board)
  50                      , CBRef (M.IntMap LayerConf)
  51                      , ReactiveFieldRead IO
  52                        (M.IntMap (ReactiveFieldWrite IO [PlayHead]))
  53                      )
  54 createNotebook boardQueue tc addLayerRV rmLayerRV clearRV
  55   statMCBMVar dynMCBMVar synthMCBMVar guiCellMCBMVar = do
  56   n <- notebookNew
  57   let curPageRV = ReactiveFieldReadWrite setter getter notifier
  58         where (ReactiveFieldRead getter _) = notebookGetCurrentPagePassive n
  59               -- afterSwitchPage is deprecated but switchPage gets us
  60               -- the old page number and not the new one and using
  61               -- afterSwitchPage doesn't trigger a warning so…
  62               setter = postGUIAsync . notebookSetCurrentPage n
  63               notifier io = void $ afterSwitchPage n (const io)
  64
  65   pageChanRV <- newCBMVarRW []
  66
  67   let foundHole ns = head $ [0..15] \\ ns
  68
  69       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 "layer-0"
 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 -> insert (foundHole pc) 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       pageChan <- reactiveValueRead pageChanRV
 181       notebookAppendPage n nBoardCont $ "layer-"++show (foundHole pageChan)
 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 pageChanRV (pChan ++ [newCP])
 192       -- reactiveValueRead pageChanRV >>= print
 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       reactiveValueRead notebookPageNumber >>= print
 217       -- notebookGetNPages n >>= print . show
 218       -- reactiveValueRead pageChanRV >>= print
 219
 220     widgetShowAll n
 221     return ()
 222
 223   reactiveValueOnCanRead clearRV $ postGUIAsync $ do
 224     np <- reactiveValueRead notebookPageNumber
 225     unless (np >= maxLayers) $ do
 226       {-
 227       let temp p = if (p > 1) then do
 228             cp <- reactiveValueRead curPageRV
 229             oldCP <- reactiveValueRead curChanRV
 230             let rmIndex :: Int -> [a] -> [a]
 231                 rmIndex n l = take n l ++ drop (n + 1) l
 232             notebookRemovePage n 0
 233             {-
 234             reactiveValueRead pageChanRV >>= print
 235             reactiveValueRead curPageRV >>= print
 236             reactiveValueRead notebookPageNumber >>= print
 237             notebookGetNPages n >>= print . show
 238             reactiveValueRead curChanRV >>= print
 239             -}
 240             reactiveValueRead pageChanRV >>=
 241               reactiveValueWrite pageChanRV . rmIndex cp
 242
 243             reactiveValueRead notebookPageNumber >>=
 244               reactiveValueWrite notebookPageNumber . subtract 1
 245
 246             reactiveValueRead chanMapRV >>=
 247               reactiveValueWrite chanMapRV . M.delete oldCP
 248
 249             reactiveValueRead layerMapRV >>=
 250               reactiveValueWrite layerMapRV . M.delete oldCP
 251
 252             temp (p - 1)
 253
 254           else
 255             return ()
 256       temp np
 257       -}
 258       curChan <- reactiveValueRead curChanRV
 259       -- print "curChan = " >> print curChan
 260       -- print "pageMap = " >> reactiveValueRead pageChanRV >>= print
 261       chanMap <- reactiveValueRead chanMapRV
 262       let mSelChan = M.lookup curChan chanMap
 263       when (isNothing mSelChan) $ error "Not found selected chan!"
 264       let selChan = fromJust mSelChan
 265           pieceArrRV :: Array Pos (ReactiveFieldWrite IO GUICell)
 266           pieceArrRV = (\(_,s,_) -> s) selChan
 267       sequence_ [reactiveValueWrite (pieceArrRV ! i) inertCell | i <- validArea]
 268
 269     widgetShowAll n
 270     return ()
 271
 272
 273   reactiveValueOnCanRead curChanRV $ do
 274     cp <- reactiveValueRead curChanRV
 275     when (cp >= 0) $ do
 276       takeMVar dynHidMVar >>= removeCallbackMCBMVar dynMCBMVar
 277       takeMVar statHidMVar >>= removeCallbackMCBMVar statMCBMVar
 278       takeMVar synthHidMVar >>= removeCallbackMCBMVar synthMCBMVar
 279       layerMap <- reactiveValueRead layerMapRV
 280       let mSelLayer = M.lookup cp layerMap
 281       when (isNothing mSelLayer) $ error "Not found selected layer!"
 282       let selLayer = fromJust mSelLayer
 283       reactiveValueWrite dynMCBMVar (dynConf selLayer)
 284       installCallbackMCBMVar dynMCBMVar (updateDynLayer cp) >>=
 285         putMVar dynHidMVar
 286       reactiveValueWrite statMCBMVar (staticConf selLayer)
 287       installCallbackMCBMVar statMCBMVar (updateStatLayer cp) >>=
 288         putMVar statHidMVar
 289       reactiveValueWrite synthMCBMVar (synthConf selLayer)
 290       installCallbackMCBMVar synthMCBMVar (updateSynth $ cp) >>=
 291         putMVar synthHidMVar
 292       return ()
 293
 294     oldCurChanRV <- newCBMVarRW =<< reactiveValueRead curChanRV
 295     reactiveValueOnCanRead curChanRV $ do
 296       oldC <- reactiveValueRead oldCurChanRV
 297       newC <- reactiveValueRead curChanRV
 298       when (oldC /= newC) $ do
 299         reactiveValueWrite oldCurChanRV newC
 300         tryTakeMVar guiCellHidMVar >>=
 301           fromMaybeM_ . fmap (removeCallbackMCBMVar guiCellMCBMVar)
 302         reactiveValueWrite guiCellMCBMVar inertCell
 303
 304   ------------------------------------------------------------------------------
 305   -- Flatten maps
 306   ------------------------------------------------------------------------------
 307   let phMapRV :: ReactiveFieldRead IO (M.IntMap (ReactiveFieldWrite IO [PlayHead]))
 308       phMapRV = liftR (M.map (\(_,_,b) -> b)) chanMapRV
 309
 310       boardMapRV :: ReactiveFieldRead IO (M.IntMap Board)
 311       boardMapRV = ReactiveFieldRead getter notifier
 312         where notifier io = do
 313                 chanMap <- reactiveValueRead chanMapRV
 314                 intMapMapM_ ((`reactiveValueOnCanRead` io) . \(b,_,_) -> b) chanMap
 315               getter = do
 316                 chanMap <- reactiveValueRead chanMapRV
 317                 intMapMapM (reactiveValueRead . \(b,_,_) -> b) chanMap
 318
 319   return (n, boardMapRV, layerMapRV, phMapRV)
 320
 321 ------------------------------------------------------------------------------
 322 -- IntMap versions of mapM etc. to make code work with GHC 7.8.3
 323 ------------------------------------------------------------------------------
 324
 325 intMapMapM_ :: (Functor m, Monad m) => (a -> m b) -> M.IntMap a -> m ()
 326 intMapMapM_ f im = mapM_ f (M.elems im)
 327
 328 intMapMapM :: (Functor m, Monad m) => (a -> m b) -> M.IntMap a -> m (M.IntMap b)
 329 intMapMapM f im = fmap (M.fromList . zip ks) (mapM f es)
 330     where
 331         (ks, es) = unzip (M.toList im)