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