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