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) $
  90                     removeCallbackMCBMVar guiCellMCBMVar $ fromJust mOHid
  91                   reactiveValueWrite guiCellMCBMVar nCell
  92                   nHid <- installCallbackMCBMVar guiCellMCBMVar $ do
  93                     cp <- reactiveValueRead curChanRV
  94                     guiVal <- reactiveValueRead guiCellMCBMVar
  95                     mChanRV <- M.lookup cp <$> reactiveValueRead chanMapRV
  96                     when (isNothing mChanRV) $ error "Can't get piece array!"
  97                     let (_,pieceArrRV,_) = fromJust mChanRV
  98                     reactiveValueWrite (pieceArrRV ! fPos) guiVal
  99                   putMVar guiCellHidMVar nHid
 100             return True
 101           )
 102
 103   boardCont <- backgroundContainerNew
 104   guiBoard <- attachGameRules =<< initGame
 105   clickHandler guiBoard
 106   centerBoard <- alignmentNew 0.5 0.5 0 0
 107   containerAdd centerBoard guiBoard
 108   containerAdd boardCont centerBoard
 109
 110   fstP <- notebookAppendPage n boardCont "Lol first"
 111   notebookPageNumber <- newCBMVarRW 1
 112
 113   initBoardRV guiBoard >>=
 114     \(boardRV, pieceArrRV, phRV) -> reactiveValueRead chanMapRV >>=
 115     reactiveValueWrite chanMapRV . M.insert fstP (boardRV,pieceArrRV,phRV)
 116
 117   reactiveValueRead pageChanRV >>=
 118     reactiveValueWrite pageChanRV . (\pc -> pc ++ [foundHole pc])
 119   layerMapRV <- newCBMVarRW $ M.insert fstP defaultLayer M.empty
 120
 121   let updateLayer cp = do
 122         nLayer <- reactiveValueRead layerMCBMVar
 123         reactiveValueRead layerMapRV >>=
 124           reactiveValueWrite layerMapRV . M.insert cp nLayer
 125
 126   layerHidMVar <- newEmptyMVar
 127
 128   installCallbackMCBMVar layerMCBMVar
 129     (reactiveValueRead curChanRV >>= updateLayer) >>= putMVar layerHidMVar
 130
 131   ------------------------------------------------------------------------------
 132   -- Following boards
 133   ------------------------------------------------------------------------------
 134
 135   reactiveValueOnCanRead addLayerRV $ postGUIAsync $ do
 136     np <- reactiveValueRead notebookPageNumber
 137     unless (np >= 16) $ do
 138       reactiveValueWrite notebookPageNumber (np + 1)
 139       nBoardCont <- backgroundContainerNew
 140
 141       nGuiBoard <- attachGameRules =<< initGame
 142       clickHandler nGuiBoard
 143       nCenterBoard <- alignmentNew 0.5 0.5 0 0
 144       containerAdd nCenterBoard nGuiBoard
 145       containerAdd nBoardCont nCenterBoard
 146
 147       newP <- notebookAppendPage n nBoardCont $ show np
 148       pChan <- reactiveValueRead pageChanRV
 149       let newCP = foundHole pChan
 150       (nBoardRV, nPieceArrRV, nPhRV) <- initBoardRV nGuiBoard
 151
 152       reactiveValueRead chanMapRV >>=
 153         reactiveValueWrite chanMapRV . M.insert newCP (nBoardRV,nPieceArrRV,nPhRV)
 154       reactiveValueRead layerMapRV >>=
 155         reactiveValueWrite layerMapRV . M.insert newCP defaultLayer
 156
 157       --reactiveValueWrite curPageRV newP
 158       reactiveValueWrite pageChanRV (pChan ++ [newCP])
 159       widgetShowAll n
 160
 161   reactiveValueOnCanRead rmLayerRV $ postGUIAsync $ do
 162     np <- reactiveValueRead notebookPageNumber
 163     when (np > 1) $ do
 164       cp <- reactiveValueRead curPageRV
 165       oldCP <- reactiveValueRead curChanRV
 166       let rmIndex :: Int -> [a] -> [a]
 167           rmIndex n l = take n l ++ drop (n + 1) l
 168       notebookRemovePage n cp
 169
 170       reactiveValueRead pageChanRV >>=
 171         reactiveValueWrite pageChanRV . rmIndex cp
 172
 173       reactiveValueRead notebookPageNumber >>=
 174         reactiveValueWrite notebookPageNumber . subtract 1
 175
 176       reactiveValueRead chanMapRV >>=
 177         reactiveValueWrite chanMapRV . M.delete oldCP
 178       reactiveValueRead layerMapRV >>=
 179         reactiveValueWrite layerMapRV . M.delete oldCP
 180
 181       --updateRV curPageRV
 182
 183     widgetShowAll n
 184     return ()
 185
 186   reactiveValueOnCanRead curChanRV $ do
 187     cp <- reactiveValueRead curChanRV
 188     when (cp >= 0) $ do
 189       takeMVar layerHidMVar >>= removeCallbackMCBMVar layerMCBMVar
 190       layerMap <- reactiveValueRead layerMapRV
 191       let mSelLayer = M.lookup cp layerMap
 192       when (isNothing mSelLayer) $ error "Not found selected layer!"
 193       let selLayer = fromJust mSelLayer
 194       reactiveValueWrite layerMCBMVar selLayer
 195       installCallbackMCBMVar layerMCBMVar (updateLayer cp) >>=
 196         putMVar layerHidMVar
 197       return ()
 198
 199   ------------------------------------------------------------------------------
 200   -- For good measure
 201   ------------------------------------------------------------------------------
 202   return (n, chanMapRV, curPageRV)