1 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
3 module RMCA.GUI.MultiBoard where
5 import Control.Concurrent.MVar
7 import Control.Monad.IO.Class
9 import qualified Data.IntMap as M
12 import Data.ReactiveValue
13 import Graphics.UI.Gtk
14 import Graphics.UI.Gtk.Board.TiledBoard hiding (Board)
15 import Graphics.UI.Gtk.Layout.BackgroundContainer
16 import Graphics.UI.Gtk.Reactive.Gtk2
19 import RMCA.Layer.Layer
23 createNotebook :: ( ReactiveValueRead addLayer () IO
24 , ReactiveValueRead rmLayer () IO
31 , ReactiveFieldRead IO (M.IntMap Board)
32 , ReactiveFieldRead IO (M.IntMap Layer)
33 , ReactiveFieldRead IO
34 (M.IntMap (ReactiveFieldWrite IO [PlayHead]))
36 createNotebook addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
38 let curPageRV = ReactiveFieldReadWrite setter getter notifier
39 where (ReactiveFieldRead getter _) = notebookGetCurrentPagePassive n
40 -- afterSwitchPage is deprecated but switchPage gets us
41 -- the old page number and not the new one and using
42 -- afterSwitchPage doesn't trigger a warning.
43 setter = postGUIAsync . notebookSetCurrentPage n
44 notifier io = void $ afterSwitchPage n (const io)
46 pageChanRV <- newCBMVarRW []
47 let foundHole = let foundHole' [] = 0
48 foundHole' [x] = x + 1
49 foundHole' (x:y:xs) = if x + 1 /= y then x + 1 else foundHole (y:xs)
53 let curChanRV = liftR2 (!!) pageChanRV curPageRV
54 ------------------------------------------------------------------------------
56 ------------------------------------------------------------------------------
58 chanMapRV <- newCBMVarRW M.empty
59 guiCellHidMVar <- newEmptyMVar
60 let clickHandler ioBoard = do
63 (\iPos' -> liftIO $ do
64 let iPos = actualTile iPos'
65 postGUIAsync $ void $ tryPutMVar state iPos
68 boardOnRelease ioBoard
70 let fPos = actualTile fPos'
72 liftIO $ postGUIAsync $ do
73 mp <- boardGetPiece fPos ioBoard
74 mstate <- tryTakeMVar state
75 when (fPos `elem` validArea && isJust mp) $ do
76 let piece = snd $ fromJust mp
77 when (button == RightButton && maybe False (== fPos) mstate) $ do
78 let nCell = rotateGUICell piece
79 boardSetPiece fPos (Player,nCell) ioBoard
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
97 boardCont <- backgroundContainerNew
98 guiBoard <- attachGameRules =<< initGame
100 centerBoard <- alignmentNew 0.5 0.5 0 0
101 containerAdd centerBoard guiBoard
102 containerAdd boardCont centerBoard
104 fstP <- notebookAppendPage n boardCont "Lol first"
105 notebookPageNumber <- newCBMVarRW (1 :: Int)
107 initBoardRV guiBoard >>=
108 \(boardRV, pieceArrRV, phRV) -> reactiveValueRead chanMapRV >>=
109 reactiveValueWrite chanMapRV . M.insert fstP (boardRV,pieceArrRV,phRV)
111 reactiveValueRead pageChanRV >>=
112 reactiveValueWrite pageChanRV . (\pc -> pc ++ [foundHole pc])
113 layerMapRV <- newCBMVarRW $ M.insert fstP defaultLayer M.empty
115 let updateLayer cp = do
116 nLayer <- reactiveValueRead layerMCBMVar
117 reactiveValueRead layerMapRV >>=
118 reactiveValueWrite layerMapRV . M.insert cp nLayer
120 layerHidMVar <- newEmptyMVar
122 installCallbackMCBMVar layerMCBMVar
123 (reactiveValueRead curChanRV >>= updateLayer) >>= putMVar layerHidMVar
125 ------------------------------------------------------------------------------
127 ------------------------------------------------------------------------------
129 reactiveValueOnCanRead addLayerRV $ postGUIAsync $ do
130 np <- reactiveValueRead notebookPageNumber
131 unless (np >= 16) $ do
132 reactiveValueWrite notebookPageNumber (np + 1)
133 nBoardCont <- backgroundContainerNew
135 nGuiBoard <- attachGameRules =<< initGame
136 clickHandler nGuiBoard
137 nCenterBoard <- alignmentNew 0.5 0.5 0 0
138 containerAdd nCenterBoard nGuiBoard
139 containerAdd nBoardCont nCenterBoard
141 notebookAppendPage n nBoardCont $ show np
142 pChan <- reactiveValueRead pageChanRV
143 let newCP = foundHole pChan
144 (nBoardRV, nPieceArrRV, nPhRV) <- initBoardRV nGuiBoard
146 reactiveValueRead chanMapRV >>=
147 reactiveValueWrite chanMapRV . M.insert newCP (nBoardRV,nPieceArrRV,nPhRV)
148 reactiveValueRead layerMapRV >>=
149 reactiveValueWrite layerMapRV . M.insert newCP defaultLayer
151 --reactiveValueWrite curPageRV newP
152 reactiveValueWrite pageChanRV (pChan ++ [newCP])
155 reactiveValueOnCanRead rmLayerRV $ postGUIAsync $ do
156 np <- reactiveValueRead notebookPageNumber
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
164 reactiveValueRead pageChanRV >>=
165 reactiveValueWrite pageChanRV . rmIndex cp
167 reactiveValueRead notebookPageNumber >>=
168 reactiveValueWrite notebookPageNumber . subtract 1
170 reactiveValueRead chanMapRV >>=
171 reactiveValueWrite chanMapRV . M.delete oldCP
172 reactiveValueRead layerMapRV >>=
173 reactiveValueWrite layerMapRV . M.delete oldCP
180 reactiveValueOnCanRead curChanRV $ do
181 cp <- reactiveValueRead curChanRV
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) >>=
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
203 ------------------------------------------------------------------------------
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
217 phMapRV :: ReactiveFieldRead IO (M.IntMap (ReactiveFieldWrite IO [PlayHead]))
218 phMapRV = liftR (M.map (\(_,_,b) -> b)) chanMapRV
220 boardMapRV :: ReactiveFieldRead IO (M.IntMap Board)
221 boardMapRV = ReactiveFieldRead getter notifier
222 where notifier io = do
223 chanMap <- reactiveValueRead chanMapRV
224 mapM_ ((`reactiveValueOnCanRead` io) . \(b,_,_) -> b) chanMap
226 chanMap <- reactiveValueRead chanMapRV
227 mapM (reactiveValueRead . \(b,_,_) -> b) chanMap
229 return (n, boardMapRV, readOnly layerMapRV, phMapRV)