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                      , ReactiveFieldReadWrite 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 nPiece ioBoard
  79                   reactiveValueWrite guiCellMCBMVar nCell
  80                 nmp <- boardGetPiece fPos ioBoard
  81                 when (button == LeftButton && isJust nmp) $ do
  82                   let nCell = snd $ fromJust nmp
  83                   mOHid <- tryTakeMVar guiCellHidMVar
  84                   forM_ mOHid $ removeCallbackMCBMVar guiCellMCBMVar
  85                   reactiveValueWrite guiCellMCBMVar nCell
  86                   nHid <- installCallbackMCBMVar guiCellMCBMVar $ do
  87                     cp <- reactiveValueRead curChanRV
  88                     guiVal <- reactiveValueRead guiCellMCBMVar
  89                     mChanRV <- M.lookup cp <$> reactiveValueRead chanMapRV
  90                     when (isNothing mChanRV) $ error "Can't get piece array!"
  91                     let (_,pieceArrRV,_) = fromJust mChanRV
  92                     reactiveValueWrite (pieceArrRV ! fPos) guiVal
  93                   putMVar guiCellHidMVar nHid
  94             return True
  95           )
  96
  97   boardCont <- backgroundContainerNew
  98   guiBoard <- attachGameRules =<< initGame
  99   clickHandler guiBoard
 100   centerBoard <- alignmentNew 0.5 0.5 0 0
 101   containerAdd centerBoard guiBoard
 102   containerAdd boardCont centerBoard
 103
 104   fstP <- notebookAppendPage n boardCont "Lol first"
 105   notebookPageNumber <- newCBMVarRW 1
 106
 107   initBoardRV guiBoard >>=
 108     \(boardRV, pieceArrRV, phRV) -> reactiveValueRead chanMapRV >>=
 109     reactiveValueWrite chanMapRV . M.insert fstP (boardRV,pieceArrRV,phRV)
 110
 111   reactiveValueRead pageChanRV >>=
 112     reactiveValueWrite pageChanRV . (\pc -> pc ++ [foundHole pc])
 113   layerMapRV <- newCBMVarRW $ M.insert fstP defaultLayer M.empty
 114
 115   let updateLayer cp = do
 116         nLayer <- reactiveValueRead layerMCBMVar
 117         reactiveValueRead layerMapRV >>=
 118           reactiveValueWrite layerMapRV . M.insert cp nLayer
 119
 120   layerHidMVar <- newEmptyMVar
 121
 122   installCallbackMCBMVar layerMCBMVar
 123     (reactiveValueRead curChanRV >>= updateLayer) >>= putMVar layerHidMVar
 124
 125   ------------------------------------------------------------------------------
 126   -- Following boards
 127   ------------------------------------------------------------------------------
 128
 129   reactiveValueOnCanRead addLayerRV $ postGUIAsync $ do
 130     np <- reactiveValueRead notebookPageNumber
 131     unless (np >= 16) $ do
 132       reactiveValueWrite notebookPageNumber (np + 1)
 133       nBoardCont <- backgroundContainerNew
 134
 135       nGuiBoard <- attachGameRules =<< initGame
 136       clickHandler nGuiBoard
 137       nCenterBoard <- alignmentNew 0.5 0.5 0 0
 138       containerAdd nCenterBoard nGuiBoard
 139       containerAdd nBoardCont nCenterBoard
 140
 141       notebookAppendPage n nBoardCont $ show np
 142       pChan <- reactiveValueRead pageChanRV
 143       let newCP = foundHole pChan
 144       (nBoardRV, nPieceArrRV, nPhRV) <- initBoardRV nGuiBoard
 145
 146       reactiveValueRead chanMapRV >>=
 147         reactiveValueWrite chanMapRV . M.insert newCP (nBoardRV,nPieceArrRV,nPhRV)
 148       reactiveValueRead layerMapRV >>=
 149         reactiveValueWrite layerMapRV . M.insert newCP defaultLayer
 150
 151       --reactiveValueWrite curPageRV newP
 152       reactiveValueWrite pageChanRV (pChan ++ [newCP])
 153       widgetShowAll n
 154
 155   reactiveValueOnCanRead rmLayerRV $ postGUIAsync $ do
 156     np <- reactiveValueRead notebookPageNumber
 157     when (np > 1) $ do
 158       cp <- reactiveValueRead curPageRV
 159       oldCP <- reactiveValueRead curChanRV
 160       let rmIndex :: Int -> [a] -> [a]
 161           rmIndex n l = take n l ++ drop (n + 1) l
 162       notebookRemovePage n cp
 163
 164       reactiveValueRead pageChanRV >>=
 165         reactiveValueWrite pageChanRV . rmIndex cp
 166
 167       reactiveValueRead notebookPageNumber >>=
 168         reactiveValueWrite notebookPageNumber . subtract 1
 169
 170       reactiveValueRead chanMapRV >>=
 171         reactiveValueWrite chanMapRV . M.delete oldCP
 172       reactiveValueRead layerMapRV >>=
 173         reactiveValueWrite layerMapRV . M.delete oldCP
 174
 175       --updateRV curPageRV
 176
 177     widgetShowAll n
 178     return ()
 179
 180   reactiveValueOnCanRead curChanRV $ do
 181     cp <- reactiveValueRead curChanRV
 182     when (cp >= 0) $ do
 183       takeMVar layerHidMVar >>= removeCallbackMCBMVar layerMCBMVar
 184       layerMap <- reactiveValueRead layerMapRV
 185       let mSelLayer = M.lookup cp layerMap
 186       when (isNothing mSelLayer) $ error "Not found selected layer!"
 187       let selLayer = fromJust mSelLayer
 188       reactiveValueWrite layerMCBMVar selLayer
 189       installCallbackMCBMVar layerMCBMVar (updateLayer cp) >>=
 190         putMVar layerHidMVar
 191       return ()
 192
 193     oldCurChanRV <- newCBMVarRW =<< reactiveValueRead curChanRV
 194     reactiveValueOnCanRead curChanRV $ do
 195       oldC <- reactiveValueRead oldCurChanRV
 196       newC <- reactiveValueRead curChanRV
 197       when (oldC /= newC) $ do
 198         reactiveValueWrite oldCurChanRV newC
 199         tryTakeMVar guiCellHidMVar >>=
 200           fromMaybeM_ . fmap (removeCallbackMCBMVar guiCellMCBMVar)
 201         reactiveValueWrite guiCellMCBMVar inertCell
 202
 203   ------------------------------------------------------------------------------
 204   -- Flatten maps
 205   ------------------------------------------------------------------------------
 206   let {-phMapRV :: ReactiveFieldWrite IO (M.IntMap [PlayHead])
 207       phMapRV = ReactiveFieldWrite setter
 208         where setter phM = sequence_ $ M.mapWithKey writePhs phM
 209               writePhs :: Int -> [PlayHead] -> IO ()
 210               writePhs k phs = do chanMap <- reactiveValueRead chanMapRV
 211                                   let mselChan = M.lookup k chanMap
 212                                   when (isNothing mselChan) $
 213                                     error "Can't find layer!"
 214                                   let (_,_,phsRV) = fromJust mselChan
 215                                   reactiveValueWrite phsRV phs
 216 -}
 217       phMapRV :: ReactiveFieldRead IO (M.IntMap (ReactiveFieldWrite IO [PlayHead]))
 218       phMapRV = liftR (M.map (\(_,_,b) -> b)) chanMapRV
 219
 220       boardMapRV :: ReactiveFieldRead IO (M.IntMap Board)
 221       boardMapRV = ReactiveFieldRead getter notifier
 222         where notifier = reactiveValueOnCanRead chanMapRV
 223               getter = do
 224                 chanMap <- reactiveValueRead chanMapRV
 225                 sequence (M.map (reactiveValueRead . \(b,_,_) -> b) chanMap)
 226
 227   return (n, boardMapRV, layerMapRV, phMapRV)