]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/GUI/MultiBoard.hs
Add flake.nix
[tmp/julm/arpeggigon.git] / src / RMCA / GUI / MultiBoard.hs
1 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TupleSections #-}
2
3 module RMCA.GUI.MultiBoard where
4
5 import Debug.Trace
6 import Control.Concurrent.MVar
7 import Control.Monad
8 import Control.Monad.IO.Class
9 import Data.Array
10 import Data.CBRef
11 import qualified Data.IntMap as M
12 import Data.List
13 import Data.Maybe
14 import Data.ReactiveValue
15 import Graphics.UI.Gtk
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.IOClockworks
22 import RMCA.Layer.LayerConf
23 import RMCA.MCBMVar
24 import RMCA.ReactiveValueAtomicUpdate
25 import RMCA.Semantics
26 import RMCA.Translator.Message
27
28 maxLayers :: Int
29 maxLayers = 16
30
31 layerName :: String
32 layerName = "Layer"
33
34 createNotebook :: ( ReactiveValueRead addLayer () IO
35 , ReactiveValueRead rmLayer () IO
36 , ReactiveValueRead clear () IO
37 , ReactiveValueAtomicUpdate board (M.IntMap ([Note],[Message])) IO
38 ) =>
39 board
40 -> IOTick
41 -> addLayer
42 -> rmLayer
43 -> clear
44 -> MCBMVar StaticLayerConf
45 -> MCBMVar DynLayerConf
46 -> MCBMVar SynthConf
47 -> MCBMVar GUICell
48 -> IO ( Notebook
49 , ReactiveFieldRead IO (M.IntMap Board)
50 , CBRef (M.IntMap LayerConf)
51 , ReactiveFieldRead IO
52 (M.IntMap (ReactiveFieldWrite IO [PlayHead]))
53 )
54 createNotebook boardQueue tc addLayerRV rmLayerRV clearRV
55 statMCBMVar dynMCBMVar synthMCBMVar guiCellMCBMVar = do
56 n <- notebookNew
57 let curPageRV = ReactiveFieldReadWrite setter getter notifier
58 where (ReactiveFieldRead getter _) = notebookGetCurrentPagePassive n
59 -- afterSwitchPage is deprecated but switchPage gets us
60 -- the old page number and not the new one and using
61 -- afterSwitchPage doesn't trigger a warning so…
62 setter = postGUIAsync . notebookSetCurrentPage n
63 notifier io = void $ afterSwitchPage n (const io)
64
65 pageChanRV <- newCBMVarRW []
66
67 let foundHole ns = head $ [0..15] \\ ns
68
69 curChanRV = liftR2 (!!) pageChanRV curPageRV
70 ------------------------------------------------------------------------------
71 -- First board
72 ------------------------------------------------------------------------------
73
74 chanMapRV <- newCBMVarRW M.empty
75 guiCellHidMVar <- newEmptyMVar
76 let clickHandler ioBoard = do
77 state <- newEmptyMVar
78 boardOnPress ioBoard
79 (\iPos' -> liftIO $ do
80 let iPos = actualTile iPos'
81 postGUIAsync $ void $ tryPutMVar state iPos
82 return True
83 )
84 boardOnRelease ioBoard
85 (\fPos' -> do
86 let fPos = actualTile fPos'
87 button <- eventButton
88 liftIO $ postGUIAsync $ do
89 mp <- boardGetPiece fPos ioBoard
90 mstate <- tryTakeMVar state
91 when (fPos `elem` validArea && isJust mp) $ do
92 let piece = snd $ fromJust mp
93 when (button == RightButton && maybe False (== fPos) mstate) $ do
94 let nCell = rotateGUICell piece
95 boardSetPiece fPos (Player,nCell) ioBoard
96 nmp <- boardGetPiece fPos ioBoard
97 when (button == LeftButton && isJust nmp) $ do
98 let nCell = snd $ fromJust nmp
99 mOHid <- tryTakeMVar guiCellHidMVar
100 maybe (return ()) (removeCallbackMCBMVar guiCellMCBMVar) mOHid
101 reactiveValueWrite guiCellMCBMVar nCell
102 nHid <- installCallbackMCBMVar guiCellMCBMVar $ do
103 cp <- reactiveValueRead curChanRV
104 guiVal <- reactiveValueRead guiCellMCBMVar
105 mChanRV <- fmap (M.lookup cp)
106 (reactiveValueRead chanMapRV)
107 when (isNothing mChanRV) $ error "Can't get piece array!"
108 let (_,pieceArrRV,_) = fromJust mChanRV
109 reactiveValueWrite (pieceArrRV ! fPos) guiVal
110 putMVar guiCellHidMVar nHid
111 return True
112 )
113
114 boardCont <- backgroundContainerNew
115 guiBoard <- attachGameRules =<< initGame
116 clickHandler guiBoard
117 centerBoard <- alignmentNew 0.5 0.5 0 0
118 containerAdd centerBoard guiBoard
119 containerAdd boardCont centerBoard
120
121 fstP <- notebookAppendPage n boardCont "layer-0"
122 notebookPageNumber <- newCBMVarRW (1 :: Int)
123
124 initBoardRV tc guiBoard >>=
125 \(boardRV, pieceArrRV, phRV) -> reactiveValueRead chanMapRV >>=
126 reactiveValueWrite chanMapRV . M.insert fstP (boardRV,pieceArrRV,phRV)
127
128 reactiveValueRead pageChanRV >>=
129 reactiveValueWrite pageChanRV . (\pc -> insert (foundHole pc) pc)
130
131 layerMapRV <- newCBRef $ M.insert fstP defaultLayerConf M.empty
132 reactiveValueOnCanRead layerMapRV $ do
133 synth <- fmap (fmap (\(_,_,s) -> s)) (reactiveValueRead layerMapRV)
134 sequence_ $ M.elems $ M.mapWithKey
135 (\chan mess -> reactiveValueAppend boardQueue $
136 M.singleton chan $ ([],) $ synthMessage chan mess) synth
137
138 let updateDynLayer cp = do
139 nDyn <- reactiveValueRead dynMCBMVar
140 reactiveValueUpdate_ layerMapRV
141 (M.adjust (\(stat,_,synth) -> (stat,nDyn,synth)) cp)
142 updateSynth cp = do
143 nSynth <- reactiveValueRead synthMCBMVar
144 reactiveValueUpdate_ layerMapRV
145 (M.adjust (\(stat,dyn,_) -> (stat,dyn,nSynth)) cp)
146 reactiveValueAppend boardQueue $
147 M.singleton cp $ ([],) $ synthMessage cp nSynth
148 updateStatLayer cp = do
149 nStat <- reactiveValueRead statMCBMVar
150 reactiveValueUpdate_ layerMapRV
151 (M.adjust (\(_,dyn,synth) -> (nStat,dyn,synth)) cp)
152
153 statHidMVar <- newEmptyMVar
154 dynHidMVar <- newEmptyMVar
155 synthHidMVar <- newEmptyMVar
156
157 installCallbackMCBMVar statMCBMVar
158 (reactiveValueRead curChanRV >>= updateStatLayer) >>= putMVar statHidMVar
159 installCallbackMCBMVar dynMCBMVar
160 (reactiveValueRead curChanRV >>= updateDynLayer) >>= putMVar dynHidMVar
161 installCallbackMCBMVar synthMCBMVar
162 (reactiveValueRead curChanRV >>= updateSynth) >>= putMVar synthHidMVar
163
164 ------------------------------------------------------------------------------
165 -- Following boards
166 ------------------------------------------------------------------------------
167
168 reactiveValueOnCanRead addLayerRV $ postGUIAsync $ do
169 np <- reactiveValueRead notebookPageNumber
170 unless (np >= maxLayers) $ do
171 reactiveValueWrite notebookPageNumber (np + 1)
172 nBoardCont <- backgroundContainerNew
173
174 nGuiBoard <- attachGameRules =<< initGame
175 clickHandler nGuiBoard
176 nCenterBoard <- alignmentNew 0.5 0.5 0 0
177 containerAdd nCenterBoard nGuiBoard
178 containerAdd nBoardCont nCenterBoard
179
180 pageChan <- reactiveValueRead pageChanRV
181 notebookAppendPage n nBoardCont $ "layer-"++show (foundHole pageChan)
182 pChan <- reactiveValueRead pageChanRV
183 let newCP = foundHole pChan
184 (nBoardRV, nPieceArrRV, nPhRV) <- initBoardRV tc nGuiBoard
185
186 reactiveValueRead chanMapRV >>=
187 reactiveValueWrite chanMapRV . M.insert newCP (nBoardRV,nPieceArrRV,nPhRV)
188 reactiveValueRead layerMapRV >>=
189 reactiveValueWrite layerMapRV . M.insert newCP defaultLayerConf
190
191 reactiveValueWrite pageChanRV (pChan ++ [newCP])
192 -- reactiveValueRead pageChanRV >>= print
193 widgetShowAll n
194
195 reactiveValueOnCanRead rmLayerRV $ postGUIAsync $ do
196 np <- reactiveValueRead notebookPageNumber
197 when (np > 1) $ do
198 cp <- reactiveValueRead curPageRV
199 oldCP <- reactiveValueRead curChanRV
200 let rmIndex :: Int -> [a] -> [a]
201 rmIndex n l = take n l ++ drop (n + 1) l
202 notebookRemovePage n cp
203
204 reactiveValueRead pageChanRV >>=
205 reactiveValueWrite pageChanRV . rmIndex cp
206
207 reactiveValueRead notebookPageNumber >>=
208 reactiveValueWrite notebookPageNumber . subtract 1
209
210 reactiveValueRead chanMapRV >>=
211 reactiveValueWrite chanMapRV . M.delete oldCP
212
213 reactiveValueRead layerMapRV >>=
214 reactiveValueWrite layerMapRV . M.delete oldCP
215
216 reactiveValueRead notebookPageNumber >>= print
217 -- notebookGetNPages n >>= print . show
218 -- reactiveValueRead pageChanRV >>= print
219
220 widgetShowAll n
221 return ()
222
223 reactiveValueOnCanRead clearRV $ postGUIAsync $ do
224 np <- reactiveValueRead notebookPageNumber
225 unless (np >= maxLayers) $ do
226 {-
227 let temp p = if (p > 1) then do
228 cp <- reactiveValueRead curPageRV
229 oldCP <- reactiveValueRead curChanRV
230 let rmIndex :: Int -> [a] -> [a]
231 rmIndex n l = take n l ++ drop (n + 1) l
232 notebookRemovePage n 0
233 {-
234 reactiveValueRead pageChanRV >>= print
235 reactiveValueRead curPageRV >>= print
236 reactiveValueRead notebookPageNumber >>= print
237 notebookGetNPages n >>= print . show
238 reactiveValueRead curChanRV >>= print
239 -}
240 reactiveValueRead pageChanRV >>=
241 reactiveValueWrite pageChanRV . rmIndex cp
242
243 reactiveValueRead notebookPageNumber >>=
244 reactiveValueWrite notebookPageNumber . subtract 1
245
246 reactiveValueRead chanMapRV >>=
247 reactiveValueWrite chanMapRV . M.delete oldCP
248
249 reactiveValueRead layerMapRV >>=
250 reactiveValueWrite layerMapRV . M.delete oldCP
251
252 temp (p - 1)
253
254 else
255 return ()
256 temp np
257 -}
258 curChan <- reactiveValueRead curChanRV
259 -- print "curChan = " >> print curChan
260 -- print "pageMap = " >> reactiveValueRead pageChanRV >>= print
261 chanMap <- reactiveValueRead chanMapRV
262 let mSelChan = M.lookup curChan chanMap
263 when (isNothing mSelChan) $ error "Not found selected chan!"
264 let selChan = fromJust mSelChan
265 pieceArrRV :: Array Pos (ReactiveFieldWrite IO GUICell)
266 pieceArrRV = (\(_,s,_) -> s) selChan
267 sequence_ [reactiveValueWrite (pieceArrRV ! i) inertCell | i <- validArea]
268
269 widgetShowAll n
270 return ()
271
272
273 reactiveValueOnCanRead curChanRV $ do
274 cp <- reactiveValueRead curChanRV
275 when (cp >= 0) $ do
276 takeMVar dynHidMVar >>= removeCallbackMCBMVar dynMCBMVar
277 takeMVar statHidMVar >>= removeCallbackMCBMVar statMCBMVar
278 takeMVar synthHidMVar >>= removeCallbackMCBMVar synthMCBMVar
279 layerMap <- reactiveValueRead layerMapRV
280 let mSelLayer = M.lookup cp layerMap
281 when (isNothing mSelLayer) $ error "Not found selected layer!"
282 let selLayer = fromJust mSelLayer
283 reactiveValueWrite dynMCBMVar (dynConf selLayer)
284 installCallbackMCBMVar dynMCBMVar (updateDynLayer cp) >>=
285 putMVar dynHidMVar
286 reactiveValueWrite statMCBMVar (staticConf selLayer)
287 installCallbackMCBMVar statMCBMVar (updateStatLayer cp) >>=
288 putMVar statHidMVar
289 reactiveValueWrite synthMCBMVar (synthConf selLayer)
290 installCallbackMCBMVar synthMCBMVar (updateSynth $ cp) >>=
291 putMVar synthHidMVar
292 return ()
293
294 oldCurChanRV <- newCBMVarRW =<< reactiveValueRead curChanRV
295 reactiveValueOnCanRead curChanRV $ do
296 oldC <- reactiveValueRead oldCurChanRV
297 newC <- reactiveValueRead curChanRV
298 when (oldC /= newC) $ do
299 reactiveValueWrite oldCurChanRV newC
300 tryTakeMVar guiCellHidMVar >>=
301 fromMaybeM_ . fmap (removeCallbackMCBMVar guiCellMCBMVar)
302 reactiveValueWrite guiCellMCBMVar inertCell
303
304 ------------------------------------------------------------------------------
305 -- Flatten maps
306 ------------------------------------------------------------------------------
307 let phMapRV :: ReactiveFieldRead IO (M.IntMap (ReactiveFieldWrite IO [PlayHead]))
308 phMapRV = liftR (M.map (\(_,_,b) -> b)) chanMapRV
309
310 boardMapRV :: ReactiveFieldRead IO (M.IntMap Board)
311 boardMapRV = ReactiveFieldRead getter notifier
312 where notifier io = do
313 chanMap <- reactiveValueRead chanMapRV
314 intMapMapM_ ((`reactiveValueOnCanRead` io) . \(b,_,_) -> b) chanMap
315 getter = do
316 chanMap <- reactiveValueRead chanMapRV
317 intMapMapM (reactiveValueRead . \(b,_,_) -> b) chanMap
318
319 return (n, boardMapRV, layerMapRV, phMapRV)
320
321 ------------------------------------------------------------------------------
322 -- IntMap versions of mapM etc. to make code work with GHC 7.8.3
323 ------------------------------------------------------------------------------
324
325 intMapMapM_ :: (Functor m, Monad m) => (a -> m b) -> M.IntMap a -> m ()
326 intMapMapM_ f im = mapM_ f (M.elems im)
327
328 intMapMapM :: (Functor m, Monad m) => (a -> m b) -> M.IntMap a -> m (M.IntMap b)
329 intMapMapM f im = fmap (M.fromList . zip ks) (mapM f es)
330 where
331 (ks, es) = unzip (M.toList im)