MultiBoard.hs 11 KB
Newer Older
Guerric Chupin's avatar
Guerric Chupin committed
1
{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TupleSections #-}
2 3 4

module RMCA.GUI.MultiBoard where

5 6 7 8
import           Control.Concurrent.MVar
import           Control.Monad
import           Control.Monad.IO.Class
import           Data.Array
9
import           Data.CBRef
10
import qualified Data.IntMap                                as M
11
import           Data.List
12 13 14 15 16 17 18 19
import           Data.Maybe
import           Data.ReactiveValue
import           Graphics.UI.Gtk
import           Graphics.UI.Gtk.Board.TiledBoard           hiding (Board)
import           Graphics.UI.Gtk.Layout.BackgroundContainer
import           Graphics.UI.Gtk.Reactive.Gtk2
import           RMCA.Auxiliary
import           RMCA.GUI.Board
Guerric Chupin's avatar
Guerric Chupin committed
20 21
import           RMCA.IOClockworks
import           RMCA.Layer.LayerConf
22
import           RMCA.MCBMVar
Guerric Chupin's avatar
Guerric Chupin committed
23
import           RMCA.ReactiveValueAtomicUpdate
24
import           RMCA.Semantics
Guerric Chupin's avatar
Guerric Chupin committed
25
import           RMCA.Translator.Message
26

Guerric Chupin's avatar
Guerric Chupin committed
27 28 29
maxLayers :: Int
maxLayers = 16

30 31
createNotebook :: ( ReactiveValueRead addLayer () IO
                  , ReactiveValueRead rmLayer () IO
Guerric Chupin's avatar
Guerric Chupin committed
32
                  , ReactiveValueAtomicUpdate board (M.IntMap ([Note],[Message])) IO
33
                  ) =>
Guerric Chupin's avatar
Guerric Chupin committed
34 35
                  board
               -> IOTick
36
               -> addLayer
37
               -> rmLayer
Guerric Chupin's avatar
Guerric Chupin committed
38 39 40
               -> MCBMVar StaticLayerConf
               -> MCBMVar DynLayerConf
               -> MCBMVar SynthConf
41
               -> MCBMVar GUICell
42
               -> IO ( Notebook
43
                     , ReactiveFieldRead IO (M.IntMap Board)
44
                     , CBRef (M.IntMap LayerConf)
45 46
                     , ReactiveFieldRead IO
                       (M.IntMap (ReactiveFieldWrite IO [PlayHead]))
47
                     )
Guerric Chupin's avatar
Guerric Chupin committed
48 49
createNotebook boardQueue tc addLayerRV rmLayerRV
  statMCBMVar dynMCBMVar synthMCBMVar guiCellMCBMVar = do
50
  n <- notebookNew
51
  let curPageRV = ReactiveFieldReadWrite setter getter notifier
52 53 54
        where (ReactiveFieldRead getter _) = notebookGetCurrentPagePassive n
              -- afterSwitchPage is deprecated but switchPage gets us
              -- the old page number and not the new one and using
Guerric Chupin's avatar
Guerric Chupin committed
55
              -- afterSwitchPage doesn't trigger a warning so…
56 57 58 59 60
              setter = postGUIAsync . notebookSetCurrentPage n
              notifier io = void $ afterSwitchPage n (const io)

  pageChanRV <- newCBMVarRW []
  let foundHole = let foundHole' [] = 0
61
                      foundHole' [x] = x + 1
62 63 64 65 66
                      foundHole' (x:y:xs) = if x + 1 /= y then x + 1 else foundHole (y:xs)
                  in foundHole' . sort


  let curChanRV = liftR2 (!!) pageChanRV curPageRV
67 68 69
  ------------------------------------------------------------------------------
  -- First board
  ------------------------------------------------------------------------------
70 71 72 73 74 75

  chanMapRV <- newCBMVarRW M.empty
  guiCellHidMVar <- newEmptyMVar
  let clickHandler ioBoard = do
        state <- newEmptyMVar
        boardOnPress ioBoard
76 77
          (\iPos' -> liftIO $ do
              let iPos = actualTile iPos'
78 79 80 81
              postGUIAsync $ void $ tryPutMVar state iPos
              return True
          )
        boardOnRelease ioBoard
82 83 84 85 86 87 88 89 90 91 92 93 94 95 96
          (\fPos' -> do
              let fPos = actualTile fPos'
              button <- eventButton
              liftIO $ postGUIAsync $ do
                mp <- boardGetPiece fPos ioBoard
                mstate <- tryTakeMVar state
                when (fPos `elem` validArea && isJust mp) $ do
                  let piece = snd $ fromJust mp
                  when (button == RightButton && maybe False (== fPos) mstate) $ do
                    let nCell = rotateGUICell piece
                    boardSetPiece fPos (Player,nCell) ioBoard
                  nmp <- boardGetPiece fPos ioBoard
                  when (button == LeftButton && isJust nmp) $ do
                    let nCell = snd $ fromJust nmp
                    mOHid <- tryTakeMVar guiCellHidMVar
97
                    maybe (return ()) (removeCallbackMCBMVar guiCellMCBMVar) mOHid
98 99 100 101
                    reactiveValueWrite guiCellMCBMVar nCell
                    nHid <- installCallbackMCBMVar guiCellMCBMVar $ do
                      cp <- reactiveValueRead curChanRV
                      guiVal <- reactiveValueRead guiCellMCBMVar
102 103
                      mChanRV <- fmap (M.lookup cp)
                                      (reactiveValueRead chanMapRV)
104 105 106 107 108
                      when (isNothing mChanRV) $ error "Can't get piece array!"
                      let (_,pieceArrRV,_) = fromJust mChanRV
                      reactiveValueWrite (pieceArrRV ! fPos) guiVal
                    putMVar guiCellHidMVar nHid
              return True
109 110
          )

111 112
  boardCont <- backgroundContainerNew
  guiBoard <- attachGameRules =<< initGame
113
  clickHandler guiBoard
114 115 116 117
  centerBoard <- alignmentNew 0.5 0.5 0 0
  containerAdd centerBoard guiBoard
  containerAdd boardCont centerBoard

Guerric Chupin's avatar
Guerric Chupin committed
118
  fstP <- notebookAppendPage n boardCont ""
119
  notebookPageNumber <- newCBMVarRW (1 :: Int)
120

121
  initBoardRV tc guiBoard >>=
122 123 124
    \(boardRV, pieceArrRV, phRV) -> reactiveValueRead chanMapRV >>=
    reactiveValueWrite chanMapRV . M.insert fstP (boardRV,pieceArrRV,phRV)

125 126
  reactiveValueRead pageChanRV >>=
    reactiveValueWrite pageChanRV . (\pc -> pc ++ [foundHole pc])
127

128 129
  layerMapRV <- newCBRef $ M.insert fstP defaultLayerConf M.empty
  reactiveValueOnCanRead layerMapRV $ do
130 131
    synth <- fmap (fmap (\(_,_,s) -> s)) (reactiveValueRead layerMapRV)
    sequence_ $ M.elems $ M.mapWithKey
132 133
      (\chan mess -> reactiveValueAppend boardQueue $
        M.singleton chan $ ([],) $ synthMessage chan mess) synth
134

Guerric Chupin's avatar
Guerric Chupin committed
135 136
  let updateDynLayer cp = do
        nDyn <- reactiveValueRead dynMCBMVar
137 138
        reactiveValueUpdate_ layerMapRV
          (M.adjust (\(stat,_,synth) -> (stat,nDyn,synth)) cp)
Guerric Chupin's avatar
Guerric Chupin committed
139
      updateSynth cp = do
140 141 142
        nSynth <- reactiveValueRead synthMCBMVar
        reactiveValueUpdate_ layerMapRV
          (M.adjust (\(stat,dyn,_) -> (stat,dyn,nSynth)) cp)
Guerric Chupin's avatar
Guerric Chupin committed
143
        reactiveValueAppend boardQueue $
144
          M.singleton cp $ ([],) $ synthMessage cp nSynth
Guerric Chupin's avatar
Guerric Chupin committed
145 146 147 148
      updateStatLayer cp = do
        nStat <- reactiveValueRead statMCBMVar
        reactiveValueUpdate_ layerMapRV
          (M.adjust (\(_,dyn,synth) -> (nStat,dyn,synth)) cp)
Guerric Chupin's avatar
Guerric Chupin committed
149 150 151 152 153 154 155 156 157 158 159

  statHidMVar <- newEmptyMVar
  dynHidMVar <- newEmptyMVar
  synthHidMVar <- newEmptyMVar

  installCallbackMCBMVar statMCBMVar
    (reactiveValueRead curChanRV >>= updateStatLayer) >>= putMVar statHidMVar
  installCallbackMCBMVar dynMCBMVar
    (reactiveValueRead curChanRV >>= updateDynLayer) >>= putMVar dynHidMVar
  installCallbackMCBMVar synthMCBMVar
    (reactiveValueRead curChanRV >>= updateSynth) >>= putMVar synthHidMVar
160 161 162 163 164 165

  ------------------------------------------------------------------------------
  -- Following boards
  ------------------------------------------------------------------------------

  reactiveValueOnCanRead addLayerRV $ postGUIAsync $ do
166
    np <- reactiveValueRead notebookPageNumber
Guerric Chupin's avatar
Guerric Chupin committed
167
    unless (np >= maxLayers) $ do
168 169 170 171 172
      reactiveValueWrite notebookPageNumber (np + 1)
      nBoardCont <- backgroundContainerNew

      nGuiBoard <- attachGameRules =<< initGame
      clickHandler nGuiBoard
173 174 175 176
      nCenterBoard <- alignmentNew 0.5 0.5 0 0
      containerAdd nCenterBoard nGuiBoard
      containerAdd nBoardCont nCenterBoard

177
      notebookAppendPage n nBoardCont $ show np
178 179
      pChan <- reactiveValueRead pageChanRV
      let newCP = foundHole pChan
180
      (nBoardRV, nPieceArrRV, nPhRV) <- initBoardRV tc nGuiBoard
181 182

      reactiveValueRead chanMapRV >>=
183 184
        reactiveValueWrite chanMapRV . M.insert newCP (nBoardRV,nPieceArrRV,nPhRV)
      reactiveValueRead layerMapRV >>=
Guerric Chupin's avatar
Guerric Chupin committed
185
        reactiveValueWrite layerMapRV . M.insert newCP defaultLayerConf
186

187 188
      --reactiveValueWrite curPageRV newP
      reactiveValueWrite pageChanRV (pChan ++ [newCP])
189
      widgetShowAll n
190 191 192 193

  reactiveValueOnCanRead rmLayerRV $ postGUIAsync $ do
    np <- reactiveValueRead notebookPageNumber
    when (np > 1) $ do
194 195 196 197
      cp <- reactiveValueRead curPageRV
      oldCP <- reactiveValueRead curChanRV
      let rmIndex :: Int -> [a] -> [a]
          rmIndex n l = take n l ++ drop (n + 1) l
198
      notebookRemovePage n cp
199

200 201 202
      reactiveValueRead pageChanRV >>=
        reactiveValueWrite pageChanRV . rmIndex cp

203 204 205 206
      reactiveValueRead notebookPageNumber >>=
        reactiveValueWrite notebookPageNumber . subtract 1

      reactiveValueRead chanMapRV >>=
207
        reactiveValueWrite chanMapRV . M.delete oldCP
Guerric Chupin's avatar
Guerric Chupin committed
208

209
      reactiveValueRead layerMapRV >>=
210 211
        reactiveValueWrite layerMapRV . M.delete oldCP

212 213 214
    widgetShowAll n
    return ()

215 216 217
  reactiveValueOnCanRead curChanRV $ do
    cp <- reactiveValueRead curChanRV
    when (cp >= 0) $ do
Guerric Chupin's avatar
Guerric Chupin committed
218 219 220
      takeMVar dynHidMVar >>= removeCallbackMCBMVar dynMCBMVar
      takeMVar statHidMVar >>= removeCallbackMCBMVar statMCBMVar
      takeMVar synthHidMVar >>= removeCallbackMCBMVar synthMCBMVar
221 222 223 224
      layerMap <- reactiveValueRead layerMapRV
      let mSelLayer = M.lookup cp layerMap
      when (isNothing mSelLayer) $ error "Not found selected layer!"
      let selLayer = fromJust mSelLayer
Guerric Chupin's avatar
Guerric Chupin committed
225 226 227 228 229 230 231 232 233
      reactiveValueWrite dynMCBMVar (dynConf selLayer)
      installCallbackMCBMVar dynMCBMVar (updateDynLayer cp) >>=
        putMVar dynHidMVar
      reactiveValueWrite statMCBMVar (staticConf selLayer)
      installCallbackMCBMVar statMCBMVar (updateStatLayer cp) >>=
        putMVar statHidMVar
      reactiveValueWrite synthMCBMVar (synthConf selLayer)
      installCallbackMCBMVar synthMCBMVar (updateSynth cp) >>=
        putMVar synthHidMVar
234
      return ()
235

236 237 238 239 240 241 242 243 244 245
    oldCurChanRV <- newCBMVarRW =<< reactiveValueRead curChanRV
    reactiveValueOnCanRead curChanRV $ do
      oldC <- reactiveValueRead oldCurChanRV
      newC <- reactiveValueRead curChanRV
      when (oldC /= newC) $ do
        reactiveValueWrite oldCurChanRV newC
        tryTakeMVar guiCellHidMVar >>=
          fromMaybeM_ . fmap (removeCallbackMCBMVar guiCellMCBMVar)
        reactiveValueWrite guiCellMCBMVar inertCell

246
  ------------------------------------------------------------------------------
247
  -- Flatten maps
248
  ------------------------------------------------------------------------------
Guerric Chupin's avatar
Guerric Chupin committed
249
  let phMapRV :: ReactiveFieldRead IO (M.IntMap (ReactiveFieldWrite IO [PlayHead]))
250 251 252 253
      phMapRV = liftR (M.map (\(_,_,b) -> b)) chanMapRV

      boardMapRV :: ReactiveFieldRead IO (M.IntMap Board)
      boardMapRV = ReactiveFieldRead getter notifier
254 255
        where notifier io = do
                chanMap <- reactiveValueRead chanMapRV
256
                intMapMapM_ ((`reactiveValueOnCanRead` io) . \(b,_,_) -> b) chanMap
257 258
              getter = do
                chanMap <- reactiveValueRead chanMapRV
259
                intMapMapM (reactiveValueRead . \(b,_,_) -> b) chanMap
260

261
  return (n, boardMapRV, layerMapRV, phMapRV)
262 263 264 265 266 267 268 269 270 271 272 273

------------------------------------------------------------------------------
-- IntMap versions of mapM etc. to make code work with GHC 7.8.3
------------------------------------------------------------------------------

intMapMapM_ :: (Functor m, Monad m) => (a -> m b) -> M.IntMap a -> m ()
intMapMapM_ f im = mapM_ f (M.elems im)

intMapMapM :: (Functor m, Monad m) => (a -> m b) -> M.IntMap a -> m (M.IntMap b)
intMapMapM f im = fmap (M.fromList . zip ks) (mapM f es)
    where
        (ks, es) = unzip (M.toList im)