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