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