src/RMCA/GUI/MultiBoard.hs

   1 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
   2
   3 module RMCA.GUI.MultiBoard where
   4
   5 import           Control.Arrow
   6 import           Control.Concurrent.MVar
   7 import           Control.Monad
   8 import           Control.Monad.IO.Class
   9 import           Data.Array
  10 import           Data.List
  11 import qualified Data.Map                                   as M
  12 import           Data.Maybe
  13 import           Data.ReactiveValue
  14 import           Graphics.UI.Gtk
  15 import           Graphics.UI.Gtk.Board.BoardLink
  16 import           Graphics.UI.Gtk.Board.TiledBoard           hiding (Board)
  17 import           Graphics.UI.Gtk.Layout.BackgroundContainer
  18 import           Graphics.UI.Gtk.Reactive.Gtk2
  19 import           RMCA.Auxiliary
  20 import           RMCA.GUI.Board
  21 import           RMCA.Layer.Layer
  22 import           RMCA.MCBMVar
  23 import           RMCA.Semantics
  24
  25 -- In GTk, a “thing with tabs” has the, I think, very confusing name
  26 -- Notebook.
  27
  28 createNotebook :: ( ReactiveValueRead addLayer () IO
  29                   , ReactiveValueRead rmLayer () IO
  30                   ) =>
  31                   addLayer
  32                -> rmLayer
  33                -> MCBMVar Layer
  34                -> MCBMVar GUICell
  35                -> IO ( Notebook
  36                      , ReactiveFieldReadWrite IO
  37                        (M.Map Int ( ReactiveFieldRead IO Board
  38                                   , Array Pos (ReactiveFieldWrite IO GUICell)
  39                                   , ReactiveFieldWrite IO [PlayHead]
  40                                   ))
  41                      , ReactiveFieldReadWrite IO Int
  42                      )
  43 createNotebook addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
  44   n <- notebookNew
  45   let curPageRV = ReactiveFieldReadWrite setter getter notifier
  46         where (ReactiveFieldRead getter _) = notebookGetCurrentPagePassive n
  47               -- afterSwitchPage is deprecated but switchPage gets us
  48               -- the old page number and not the new one and using
  49               -- afterSwitchPage doesn't trigger a warning.
  50               setter = postGUIAsync . notebookSetCurrentPage n
  51               notifier io = void $ afterSwitchPage n (const io)
  52
  53   pageChanRV <- newCBMVarRW []
  54   let foundHole = let foundHole' [] = 0
  55                       foundHole' (x:[]) = x + 1
  56                       foundHole' (x:y:xs) = if x + 1 /= y then x + 1 else foundHole (y:xs)
  57                   in foundHole' . sort
  58
  59
  60   let curChanRV = liftR2 (!!) pageChanRV curPageRV
  61   ------------------------------------------------------------------------------
  62   -- First board
  63   ------------------------------------------------------------------------------
  64
  65   chanMapRV <- newCBMVarRW M.empty
  66   guiCellHidMVar <- newEmptyMVar
  67   let clickHandler ioBoard = do
  68         state <- newEmptyMVar
  69         boardOnPress ioBoard
  70           (\iPos -> liftIO $ do
  71               postGUIAsync $ void $ tryPutMVar state iPos
  72               return True
  73           )
  74         boardOnRelease ioBoard
  75           (\fPos -> do
  76             button <- eventButton
  77             liftIO $ postGUIAsync $ do
  78               mp <- boardGetPiece fPos ioBoard
  79               mstate <- tryTakeMVar state
  80               when (fPos `elem` validArea && isJust mp) $ do
  81                 let piece = snd $ fromJust mp
  82                 when (button == RightButton && maybe False (== fPos) mstate) $
  83                   boardSetPiece fPos (second rotateGUICell (Player,piece)) ioBoard
  84                 nmp <- boardGetPiece fPos ioBoard
  85                 when (button == LeftButton && isJust nmp) $ do
  86                   let nCell = snd $ fromJust nmp
  87                   reactiveValueWrite guiCellMCBMVar nCell
  88                   mOHid <- tryTakeMVar guiCellHidMVar
  89                   when (isJust mOHid) $
  90                     removeCallbackMCBMVar guiCellMCBMVar $ fromJust mOHid
  91                   nHid <- installCallbackMCBMVar guiCellMCBMVar $ do
  92                     cp <- reactiveValueRead curChanRV
  93                     guiVal <- reactiveValueRead guiCellMCBMVar
  94                     mChanRV <- M.lookup cp <$> reactiveValueRead chanMapRV
  95                     when (isNothing mChanRV) $ error "Can't get piece array!"
  96                     let (_,pieceArrRV,_) = fromJust mChanRV
  97                     reactiveValueWrite (pieceArrRV ! fPos) guiVal
  98                   putMVar guiCellHidMVar nHid
  99             return True
 100           )
 101
 102   boardCont <- backgroundContainerNew
 103   guiBoard <- attachGameRules =<< initGame
 104   clickHandler guiBoard
 105   centerBoard <- alignmentNew 0.5 0.5 0 0
 106   containerAdd centerBoard guiBoard
 107   containerAdd boardCont centerBoard
 108
 109   fstP <- notebookAppendPage n boardCont "Lol first"
 110   notebookPageNumber <- newCBMVarRW 1
 111
 112   initBoardRV guiBoard >>=
 113     \(boardRV, pieceArrRV, phRV) -> reactiveValueRead chanMapRV >>=
 114     reactiveValueWrite chanMapRV . M.insert fstP (boardRV,pieceArrRV,phRV)
 115
 116   reactiveValueRead pageChanRV >>=
 117     reactiveValueWrite pageChanRV . (\pc -> pc ++ [foundHole pc])
 118   layerMapRV <- newCBMVarRW $ M.insert fstP defaultLayer M.empty
 119
 120   let updateLayer cp = do
 121         nLayer <- reactiveValueRead layerMCBMVar
 122         reactiveValueRead layerMapRV >>=
 123           reactiveValueWrite layerMapRV . M.insert cp nLayer
 124
 125   layerHidMVar <- newEmptyMVar
 126
 127   installCallbackMCBMVar layerMCBMVar
 128     (reactiveValueRead curChanRV >>= updateLayer) >>= putMVar layerHidMVar
 129
 130   ------------------------------------------------------------------------------
 131   -- Following boards
 132   ------------------------------------------------------------------------------
 133
 134   reactiveValueOnCanRead addLayerRV $ postGUIAsync $ do
 135     np <- reactiveValueRead notebookPageNumber
 136     unless (np >= 16) $ do
 137       reactiveValueWrite notebookPageNumber (np + 1)
 138       nBoardCont <- backgroundContainerNew
 139
 140       nGuiBoard <- attachGameRules =<< initGame
 141       clickHandler nGuiBoard
 142       nCenterBoard <- alignmentNew 0.5 0.5 0 0
 143       containerAdd nCenterBoard nGuiBoard
 144       containerAdd nBoardCont nCenterBoard
 145
 146       newP <- notebookAppendPage n nBoardCont $ show np
 147       pChan <- reactiveValueRead pageChanRV
 148       let newCP = foundHole pChan
 149       print ("newP" ++ " " ++ show newP)
 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     print cp
 189     when (cp >= 0) $ do
 190       reactiveValueRead pageChanRV >>= print
 191       takeMVar layerHidMVar >>= removeCallbackMCBMVar layerMCBMVar
 192       layerMap <- reactiveValueRead layerMapRV
 193       --print $ M.keys layerMap
 194       let mSelLayer = M.lookup cp layerMap
 195       when (isNothing mSelLayer) $ error "Not found selected layer!"
 196       let selLayer = fromJust mSelLayer
 197       reactiveValueWrite layerMCBMVar selLayer
 198       installCallbackMCBMVar layerMCBMVar (updateLayer cp) >>=
 199         putMVar layerHidMVar
 200       return ()
 201
 202   ------------------------------------------------------------------------------
 203   -- Handle clicks
 204   ------------------------------------------------------------------------------
 205
 206
 207
 208
 209
 210   ------------------------------------------------------------------------------
 211   -- For good measure
 212   ------------------------------------------------------------------------------
 213   return (n, chanMapRV, curPageRV)
 214   --return ()