src/RMCA/GUI/MultiBoard.hs

   1 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
   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.Layer.Layer
  20 import           RMCA.MCBMVar
  21 import           RMCA.Semantics
  22
  23 createNotebook :: ( ReactiveValueRead addLayer () IO
  24                   , ReactiveValueRead rmLayer () IO
  25                   ) =>
  26                   addLayer
  27                -> rmLayer
  28                -> MCBMVar Layer
  29                -> MCBMVar GUICell
  30                -> IO ( Notebook
  31                      , ReactiveFieldRead IO (M.IntMap Board)
  32                      , ReactiveFieldRead IO (M.IntMap Layer)
  33                      , ReactiveFieldRead IO
  34                        (M.IntMap (ReactiveFieldWrite IO [PlayHead]))
  35                      )
  36 createNotebook addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
  37   n <- notebookNew
  38   let curPageRV = ReactiveFieldReadWrite setter getter notifier
  39         where (ReactiveFieldRead getter _) = notebookGetCurrentPagePassive n
  40               -- afterSwitchPage is deprecated but switchPage gets us
  41               -- the old page number and not the new one and using
  42               -- afterSwitchPage doesn't trigger a warning.
  43               setter = postGUIAsync . notebookSetCurrentPage n
  44               notifier io = void $ afterSwitchPage n (const io)
  45
  46   pageChanRV <- newCBMVarRW []
  47   let foundHole = let foundHole' [] = 0
  48                       foundHole' [x] = x + 1
  49                       foundHole' (x:y:xs) = if x + 1 /= y then x + 1 else foundHole (y:xs)
  50                   in foundHole' . sort
  51
  52
  53   let curChanRV = liftR2 (!!) pageChanRV curPageRV
  54   ------------------------------------------------------------------------------
  55   -- First board
  56   ------------------------------------------------------------------------------
  57
  58   chanMapRV <- newCBMVarRW M.empty
  59   guiCellHidMVar <- newEmptyMVar
  60   let clickHandler ioBoard = do
  61         state <- newEmptyMVar
  62         boardOnPress ioBoard
  63           (\iPos -> liftIO $ do
  64               postGUIAsync $ void $ tryPutMVar state iPos
  65               return True
  66           )
  67         boardOnRelease ioBoard
  68           (\fPos -> do
  69             button <- eventButton
  70             liftIO $ postGUIAsync $ do
  71               mp <- boardGetPiece fPos ioBoard
  72               mstate <- tryTakeMVar state
  73               when (fPos `elem` validArea && isJust mp) $ do
  74                 let piece = snd $ fromJust mp
  75                 when (button == RightButton && maybe False (== fPos) mstate) $ do
  76                   let nCell = rotateGUICell piece
  77                   boardSetPiece fPos (Player,nCell) ioBoard
  78                 nmp <- boardGetPiece fPos ioBoard
  79                 when (button == LeftButton && isJust nmp) $ do
  80                   let nCell = snd $ fromJust nmp
  81                   mOHid <- tryTakeMVar guiCellHidMVar
  82                   forM_ mOHid $ removeCallbackMCBMVar guiCellMCBMVar
  83                   reactiveValueWrite guiCellMCBMVar nCell
  84                   nHid <- installCallbackMCBMVar guiCellMCBMVar $ do
  85                     cp <- reactiveValueRead curChanRV
  86                     guiVal <- reactiveValueRead guiCellMCBMVar
  87                     mChanRV <- M.lookup cp <$> reactiveValueRead chanMapRV
  88                     when (isNothing mChanRV) $ error "Can't get piece array!"
  89                     let (_,pieceArrRV,_) = fromJust mChanRV
  90                     reactiveValueWrite (pieceArrRV ! fPos) guiVal
  91                   putMVar guiCellHidMVar nHid
  92             return True
  93           )
  94
  95   boardCont <- backgroundContainerNew
  96   guiBoard <- attachGameRules =<< initGame
  97   clickHandler guiBoard
  98   centerBoard <- alignmentNew 0.5 0.5 0 0
  99   containerAdd centerBoard guiBoard
 100   containerAdd boardCont centerBoard
 101
 102   fstP <- notebookAppendPage n boardCont "Lol first"
 103   notebookPageNumber <- newCBMVarRW (1 :: Int)
 104
 105   initBoardRV guiBoard >>=
 106     \(boardRV, pieceArrRV, phRV) -> reactiveValueRead chanMapRV >>=
 107     reactiveValueWrite chanMapRV . M.insert fstP (boardRV,pieceArrRV,phRV)
 108
 109   reactiveValueRead pageChanRV >>=
 110     reactiveValueWrite pageChanRV . (\pc -> pc ++ [foundHole pc])
 111   layerMapRV <- newCBMVarRW $ M.insert fstP defaultLayer M.empty
 112
 113   let updateLayer cp = do
 114         nLayer <- reactiveValueRead layerMCBMVar
 115         reactiveValueRead layerMapRV >>=
 116           reactiveValueWrite layerMapRV . M.insert cp nLayer
 117
 118   layerHidMVar <- newEmptyMVar
 119
 120   installCallbackMCBMVar layerMCBMVar
 121     (reactiveValueRead curChanRV >>= updateLayer) >>= putMVar layerHidMVar
 122
 123   ------------------------------------------------------------------------------
 124   -- Following boards
 125   ------------------------------------------------------------------------------
 126
 127   reactiveValueOnCanRead addLayerRV $ postGUIAsync $ do
 128     np <- reactiveValueRead notebookPageNumber
 129     unless (np >= 16) $ do
 130       reactiveValueWrite notebookPageNumber (np + 1)
 131       nBoardCont <- backgroundContainerNew
 132
 133       nGuiBoard <- attachGameRules =<< initGame
 134       clickHandler nGuiBoard
 135       nCenterBoard <- alignmentNew 0.5 0.5 0 0
 136       containerAdd nCenterBoard nGuiBoard
 137       containerAdd nBoardCont nCenterBoard
 138
 139       notebookAppendPage n nBoardCont $ show np
 140       pChan <- reactiveValueRead pageChanRV
 141       let newCP = foundHole pChan
 142       (nBoardRV, nPieceArrRV, nPhRV) <- initBoardRV nGuiBoard
 143
 144       reactiveValueRead chanMapRV >>=
 145         reactiveValueWrite chanMapRV . M.insert newCP (nBoardRV,nPieceArrRV,nPhRV)
 146       reactiveValueRead layerMapRV >>=
 147         reactiveValueWrite layerMapRV . M.insert newCP defaultLayer
 148
 149       --reactiveValueWrite curPageRV newP
 150       reactiveValueWrite pageChanRV (pChan ++ [newCP])
 151       widgetShowAll n
 152
 153   reactiveValueOnCanRead rmLayerRV $ postGUIAsync $ do
 154     np <- reactiveValueRead notebookPageNumber
 155     when (np > 1) $ do
 156       cp <- reactiveValueRead curPageRV
 157       oldCP <- reactiveValueRead curChanRV
 158       let rmIndex :: Int -> [a] -> [a]
 159           rmIndex n l = take n l ++ drop (n + 1) l
 160       notebookRemovePage n cp
 161
 162       reactiveValueRead pageChanRV >>=
 163         reactiveValueWrite pageChanRV . rmIndex cp
 164
 165       reactiveValueRead notebookPageNumber >>=
 166         reactiveValueWrite notebookPageNumber . subtract 1
 167
 168       reactiveValueRead chanMapRV >>=
 169         reactiveValueWrite chanMapRV . M.delete oldCP
 170       reactiveValueRead layerMapRV >>=
 171         reactiveValueWrite layerMapRV . M.delete oldCP
 172
 173       --updateRV curPageRV
 174
 175     widgetShowAll n
 176     return ()
 177
 178   reactiveValueOnCanRead curChanRV $ do
 179     cp <- reactiveValueRead curChanRV
 180     when (cp >= 0) $ do
 181       takeMVar layerHidMVar >>= removeCallbackMCBMVar layerMCBMVar
 182       layerMap <- reactiveValueRead layerMapRV
 183       let mSelLayer = M.lookup cp layerMap
 184       when (isNothing mSelLayer) $ error "Not found selected layer!"
 185       let selLayer = fromJust mSelLayer
 186       reactiveValueWrite layerMCBMVar selLayer
 187       installCallbackMCBMVar layerMCBMVar (updateLayer cp) >>=
 188         putMVar layerHidMVar
 189       return ()
 190
 191     oldCurChanRV <- newCBMVarRW =<< reactiveValueRead curChanRV
 192     reactiveValueOnCanRead curChanRV $ do
 193       oldC <- reactiveValueRead oldCurChanRV
 194       newC <- reactiveValueRead curChanRV
 195       when (oldC /= newC) $ do
 196         reactiveValueWrite oldCurChanRV newC
 197         tryTakeMVar guiCellHidMVar >>=
 198           fromMaybeM_ . fmap (removeCallbackMCBMVar guiCellMCBMVar)
 199         reactiveValueWrite guiCellMCBMVar inertCell
 200
 201   ------------------------------------------------------------------------------
 202   -- Flatten maps
 203   ------------------------------------------------------------------------------
 204   let {-phMapRV :: ReactiveFieldWrite IO (M.IntMap [PlayHead])
 205       phMapRV = ReactiveFieldWrite setter
 206         where setter phM = sequence_ $ M.mapWithKey writePhs phM
 207               writePhs :: Int -> [PlayHead] -> IO ()
 208               writePhs k phs = do chanMap <- reactiveValueRead chanMapRV
 209                                   let mselChan = M.lookup k chanMap
 210                                   when (isNothing mselChan) $
 211                                     error "Can't find layer!"
 212                                   let (_,_,phsRV) = fromJust mselChan
 213                                   reactiveValueWrite phsRV phs
 214 -}
 215       phMapRV :: ReactiveFieldRead IO (M.IntMap (ReactiveFieldWrite IO [PlayHead]))
 216       phMapRV = liftR (M.map (\(_,_,b) -> b)) chanMapRV
 217
 218       boardMapRV :: ReactiveFieldRead IO (M.IntMap Board)
 219       boardMapRV = ReactiveFieldRead getter notifier
 220         where notifier io = do
 221                 chanMap <- reactiveValueRead chanMapRV
 222                 mapM_ ((`reactiveValueOnCanRead` io) . \(b,_,_) -> b) chanMap
 223               getter = do
 224                 chanMap <- reactiveValueRead chanMapRV
 225                 mapM (reactiveValueRead . \(b,_,_) -> b) chanMap
 226
 227   return (n, boardMapRV, readOnly layerMapRV, phMapRV)