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 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       (ReactiveFieldRead getter notifier) = notebookGetCurrentPagePassive n
  46       (ReactiveFieldWrite setter) = notebookSetCurrentPageReactive n
  47   ------------------------------------------------------------------------------
  48   -- First board
  49   ------------------------------------------------------------------------------
  50
  51   chanMapRV <- newCBMVarRW M.empty
  52   guiCellHidMVar <- newEmptyMVar
  53   let clickHandler ioBoard = do
  54         state <- newEmptyMVar
  55         boardOnPress ioBoard
  56           (\iPos -> liftIO $ do
  57               postGUIAsync $ void $ tryPutMVar state iPos
  58               return True
  59           )
  60         boardOnRelease ioBoard
  61           (\fPos -> do
  62             button <- eventButton
  63             liftIO $ postGUIAsync $ do
  64               mp <- boardGetPiece fPos ioBoard
  65               mstate <- tryTakeMVar state
  66               when (fPos `elem` validArea && isJust mp) $ do
  67                 let piece = snd $ fromJust mp
  68                 when (button == RightButton && maybe False (== fPos) mstate) $
  69                   boardSetPiece fPos (second rotateGUICell (Player,piece)) ioBoard
  70                 nmp <- boardGetPiece fPos ioBoard
  71                 when (button == LeftButton && isJust nmp) $ do
  72                   let nCell = snd $ fromJust nmp
  73                   reactiveValueWrite guiCellMCBMVar nCell
  74                   mOHid <- tryTakeMVar guiCellHidMVar
  75                   when (isJust mOHid) $
  76                     removeCallbackMCBMVar guiCellMCBMVar $ fromJust mOHid
  77                   nHid <- installCallbackMCBMVar guiCellMCBMVar $ do
  78                     cp <- reactiveValueRead curPageRV
  79                     guiVal <- reactiveValueRead guiCellMCBMVar
  80                     mChanRV <- M.lookup cp <$> reactiveValueRead chanMapRV
  81                     when (isNothing mChanRV) $ error "Can't get piece array!"
  82                     let (_,pieceArrRV,_) = fromJust mChanRV
  83                     reactiveValueWrite (pieceArrRV ! fPos) guiVal
  84                   putMVar guiCellHidMVar nHid
  85             return True
  86           )
  87
  88   boardCont <- backgroundContainerNew
  89   guiBoard <- attachGameRules =<< initGame
  90   clickHandler guiBoard
  91   centerBoard <- alignmentNew 0.5 0.5 0 0
  92   containerAdd centerBoard guiBoard
  93   containerAdd boardCont centerBoard
  94
  95   fstP <- notebookPrependPage n boardCont "Lol first"
  96   notebookPageNumber <- newCBMVarRW 1
  97
  98   initBoardRV guiBoard >>=
  99     \(boardRV, pieceArrRV, phRV) -> reactiveValueRead chanMapRV >>=
 100     reactiveValueWrite chanMapRV . M.insert fstP (boardRV,pieceArrRV,phRV)
 101
 102   layerMapRV <- newCBMVarRW $ M.insert fstP defaultLayer M.empty
 103
 104   let updateLayer cp = do
 105         nLayer <- reactiveValueRead layerMCBMVar
 106         reactiveValueRead layerMapRV >>=
 107           reactiveValueWrite layerMapRV . M.insert cp nLayer
 108
 109   layerHidMVar <- newEmptyMVar
 110
 111   installCallbackMCBMVar layerMCBMVar
 112     (reactiveValueRead curPageRV >>= updateLayer) >>= putMVar layerHidMVar
 113
 114   ------------------------------------------------------------------------------
 115   -- Following boards
 116   ------------------------------------------------------------------------------
 117
 118   reactiveValueOnCanRead addLayerRV $ postGUIAsync $ do
 119     np <- reactiveValueRead notebookPageNumber
 120     unless (np >= 16) $ do
 121       reactiveValueWrite notebookPageNumber (np + 1)
 122       nBoardCont <- backgroundContainerNew
 123
 124       nGuiBoard <- attachGameRules =<< initGame
 125       clickHandler nGuiBoard
 126       centerBoard <- alignmentNew 0.5 0.5 0 0
 127       containerAdd centerBoard nGuiBoard
 128       containerAdd nBoardCont centerBoard
 129
 130       newP <- notebookAppendPage n boardCont "sdlkfhd"
 131       (nBoardRV, nPieceArrRV, nPhRV) <- initBoardRV nGuiBoard
 132
 133       reactiveValueRead chanMapRV >>=
 134         reactiveValueWrite chanMapRV . M.insert newP (nBoardRV,nPieceArrRV,nPhRV)
 135
 136       reactiveValueWrite curPageRV newP
 137
 138       widgetShowAll n
 139
 140   reactiveValueOnCanRead rmLayerRV $ postGUIAsync $ do
 141     np <- reactiveValueRead notebookPageNumber
 142     when (np > 1) $ do
 143       cp <- notebookGetCurrentPage n
 144       notebookRemovePage n cp
 145
 146       reactiveValueRead notebookPageNumber >>=
 147         reactiveValueWrite notebookPageNumber . subtract 1
 148
 149       reactiveValueRead chanMapRV >>=
 150         reactiveValueWrite chanMapRV . M.delete cp
 151       reactiveValueRead layerMapRV >>=
 152         reactiveValueWrite layerMapRV . M.delete cp
 153
 154     widgetShowAll n
 155     return ()
 156
 157   reactiveValueOnCanRead curPageRV $ do
 158     takeMVar layerHidMVar >>= removeCallbackMCBMVar layerMCBMVar
 159     cp <- reactiveValueRead curPageRV
 160     layerMap <- reactiveValueRead layerMapRV
 161     let mSelLayer = M.lookup cp layerMap
 162     when (isNothing mSelLayer) $ error "Not found selected layer!"
 163     let selLayer = fromJust mSelLayer
 164     reactiveValueWrite layerMCBMVar selLayer
 165     installCallbackMCBMVar layerMCBMVar (updateLayer cp) >>= putMVar layerHidMVar
 166     return ()
 167
 168   ------------------------------------------------------------------------------
 169   -- Handle clicks
 170   ------------------------------------------------------------------------------
 171
 172
 173
 174
 175
 176   ------------------------------------------------------------------------------
 177   -- For good measure
 178   ------------------------------------------------------------------------------
 179   return (n, chanMapRV, curPageRV)
 180   --return ()