]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/GUI/MultiBoard.hs
Hlint suggestions.
[tmp/julm/arpeggigon.git] / src / RMCA / GUI / MultiBoard.hs
1 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TupleSections #-}
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 Data.CBRef
10 import qualified Data.IntMap as M
11 import Data.List
12 import Data.Maybe
13 import Data.ReactiveValue
14 import Graphics.UI.Gtk
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.IOClockworks
21 import RMCA.Layer.LayerConf
22 import RMCA.MCBMVar
23 import RMCA.ReactiveValueAtomicUpdate
24 import RMCA.Semantics
25 import RMCA.Translator.Message
26
27 maxLayers :: Int
28 maxLayers = 16
29
30 createNotebook :: ( ReactiveValueRead addLayer () IO
31 , ReactiveValueRead rmLayer () IO
32 , ReactiveValueAtomicUpdate board (M.IntMap ([Note],[Message])) IO
33 ) =>
34 board
35 -> IOTick
36 -> addLayer
37 -> rmLayer
38 -> MCBMVar StaticLayerConf
39 -> MCBMVar DynLayerConf
40 -> MCBMVar SynthConf
41 -> MCBMVar GUICell
42 -> IO ( Notebook
43 , ReactiveFieldRead IO (M.IntMap Board)
44 , CBRef (M.IntMap LayerConf)
45 , ReactiveFieldRead IO
46 (M.IntMap (ReactiveFieldWrite IO [PlayHead]))
47 )
48 createNotebook boardQueue tc addLayerRV rmLayerRV
49 statMCBMVar dynMCBMVar synthMCBMVar guiCellMCBMVar = do
50 n <- notebookNew
51 let curPageRV = ReactiveFieldReadWrite setter getter notifier
52 where (ReactiveFieldRead getter _) = notebookGetCurrentPagePassive n
53 -- afterSwitchPage is deprecated but switchPage gets us
54 -- the old page number and not the new one and using
55 -- afterSwitchPage doesn't trigger a warning so…
56 setter = postGUIAsync . notebookSetCurrentPage n
57 notifier io = void $ afterSwitchPage n (const io)
58
59 pageChanRV <- newCBMVarRW []
60 let foundHole = let foundHole' [] = 0
61 foundHole' [x] = x + 1
62 foundHole' (x:y:xs) = if x + 1 /= y then x + 1 else foundHole (y:xs)
63 in foundHole' . sort
64
65
66 let curChanRV = liftR2 (!!) pageChanRV curPageRV
67 ------------------------------------------------------------------------------
68 -- First board
69 ------------------------------------------------------------------------------
70
71 chanMapRV <- newCBMVarRW M.empty
72 guiCellHidMVar <- newEmptyMVar
73 let clickHandler ioBoard = do
74 state <- newEmptyMVar
75 boardOnPress ioBoard
76 (\iPos' -> liftIO $ do
77 let iPos = actualTile iPos'
78 postGUIAsync $ void $ tryPutMVar state iPos
79 return True
80 )
81 boardOnRelease ioBoard
82 (\fPos' -> do
83 let fPos = actualTile fPos'
84 button <- eventButton
85 liftIO $ postGUIAsync $ do
86 mp <- boardGetPiece fPos ioBoard
87 mstate <- tryTakeMVar state
88 when (fPos `elem` validArea && isJust mp) $ do
89 let piece = snd $ fromJust mp
90 when (button == RightButton && maybe False (== fPos) mstate) $ do
91 let nCell = rotateGUICell piece
92 boardSetPiece fPos (Player,nCell) ioBoard
93 nmp <- boardGetPiece fPos ioBoard
94 when (button == LeftButton && isJust nmp) $ do
95 let nCell = snd $ fromJust nmp
96 mOHid <- tryTakeMVar guiCellHidMVar
97 forM_ mOHid $ removeCallbackMCBMVar guiCellMCBMVar
98 reactiveValueWrite guiCellMCBMVar nCell
99 nHid <- installCallbackMCBMVar guiCellMCBMVar $ do
100 cp <- reactiveValueRead curChanRV
101 guiVal <- reactiveValueRead guiCellMCBMVar
102 mChanRV <- M.lookup cp <$> reactiveValueRead chanMapRV
103 when (isNothing mChanRV) $ error "Can't get piece array!"
104 let (_,pieceArrRV,_) = fromJust mChanRV
105 reactiveValueWrite (pieceArrRV ! fPos) guiVal
106 putMVar guiCellHidMVar nHid
107 return True
108 )
109
110 boardCont <- backgroundContainerNew
111 guiBoard <- attachGameRules =<< initGame
112 clickHandler guiBoard
113 centerBoard <- alignmentNew 0.5 0.5 0 0
114 containerAdd centerBoard guiBoard
115 containerAdd boardCont centerBoard
116
117 fstP <- notebookAppendPage n boardCont ""
118 notebookPageNumber <- newCBMVarRW (1 :: Int)
119
120 initBoardRV tc guiBoard >>=
121 \(boardRV, pieceArrRV, phRV) -> reactiveValueRead chanMapRV >>=
122 reactiveValueWrite chanMapRV . M.insert fstP (boardRV,pieceArrRV,phRV)
123
124 reactiveValueRead pageChanRV >>=
125 reactiveValueWrite pageChanRV . (\pc -> pc ++ [foundHole pc])
126
127 layerMapRV <- newCBRef $ M.insert fstP defaultLayerConf M.empty
128 reactiveValueOnCanRead layerMapRV $ do
129 synth <- fmap (\(_,_,s) -> s) <$> reactiveValueRead layerMapRV
130 sequence_ $ M.mapWithKey
131 (\chan mess -> reactiveValueAppend boardQueue $
132 M.singleton chan $ ([],) $ synthMessage chan mess) synth
133
134 let updateDynLayer cp = do
135 nDyn <- reactiveValueRead dynMCBMVar
136 reactiveValueUpdate_ layerMapRV
137 (M.adjust (\(stat,_,synth) -> (stat,nDyn,synth)) cp)
138 updateSynth cp = do
139 nSynth <- reactiveValueRead synthMCBMVar
140 reactiveValueUpdate_ layerMapRV
141 (M.adjust (\(stat,dyn,_) -> (stat,dyn,nSynth)) cp)
142 reactiveValueAppend boardQueue $
143 M.singleton cp $ ([],) $ synthMessage cp nSynth
144 updateStatLayer cp = do
145 nStat <- reactiveValueRead statMCBMVar
146 reactiveValueUpdate_ layerMapRV
147 (M.adjust (\(_,dyn,synth) -> (nStat,dyn,synth)) cp)
148
149 statHidMVar <- newEmptyMVar
150 dynHidMVar <- newEmptyMVar
151 synthHidMVar <- newEmptyMVar
152
153 installCallbackMCBMVar statMCBMVar
154 (reactiveValueRead curChanRV >>= updateStatLayer) >>= putMVar statHidMVar
155 installCallbackMCBMVar dynMCBMVar
156 (reactiveValueRead curChanRV >>= updateDynLayer) >>= putMVar dynHidMVar
157 installCallbackMCBMVar synthMCBMVar
158 (reactiveValueRead curChanRV >>= updateSynth) >>= putMVar synthHidMVar
159
160 ------------------------------------------------------------------------------
161 -- Following boards
162 ------------------------------------------------------------------------------
163
164 reactiveValueOnCanRead addLayerRV $ postGUIAsync $ do
165 np <- reactiveValueRead notebookPageNumber
166 unless (np >= maxLayers) $ do
167 reactiveValueWrite notebookPageNumber (np + 1)
168 nBoardCont <- backgroundContainerNew
169
170 nGuiBoard <- attachGameRules =<< initGame
171 clickHandler nGuiBoard
172 nCenterBoard <- alignmentNew 0.5 0.5 0 0
173 containerAdd nCenterBoard nGuiBoard
174 containerAdd nBoardCont nCenterBoard
175
176 notebookAppendPage n nBoardCont $ show np
177 pChan <- reactiveValueRead pageChanRV
178 let newCP = foundHole pChan
179 (nBoardRV, nPieceArrRV, nPhRV) <- initBoardRV tc nGuiBoard
180
181 reactiveValueRead chanMapRV >>=
182 reactiveValueWrite chanMapRV . M.insert newCP (nBoardRV,nPieceArrRV,nPhRV)
183 reactiveValueRead layerMapRV >>=
184 reactiveValueWrite layerMapRV . M.insert newCP defaultLayerConf
185
186 --reactiveValueWrite curPageRV newP
187 reactiveValueWrite pageChanRV (pChan ++ [newCP])
188 widgetShowAll n
189
190 reactiveValueOnCanRead rmLayerRV $ postGUIAsync $ do
191 np <- reactiveValueRead notebookPageNumber
192 when (np > 1) $ do
193 cp <- reactiveValueRead curPageRV
194 oldCP <- reactiveValueRead curChanRV
195 let rmIndex :: Int -> [a] -> [a]
196 rmIndex n l = take n l ++ drop (n + 1) l
197 notebookRemovePage n cp
198
199 reactiveValueRead pageChanRV >>=
200 reactiveValueWrite pageChanRV . rmIndex cp
201
202 reactiveValueRead notebookPageNumber >>=
203 reactiveValueWrite notebookPageNumber . subtract 1
204
205 reactiveValueRead chanMapRV >>=
206 reactiveValueWrite chanMapRV . M.delete oldCP
207
208 reactiveValueRead layerMapRV >>=
209 reactiveValueWrite layerMapRV . M.delete oldCP
210
211 widgetShowAll n
212 return ()
213
214 reactiveValueOnCanRead curChanRV $ do
215 cp <- reactiveValueRead curChanRV
216 when (cp >= 0) $ do
217 takeMVar dynHidMVar >>= removeCallbackMCBMVar dynMCBMVar
218 takeMVar statHidMVar >>= removeCallbackMCBMVar statMCBMVar
219 takeMVar synthHidMVar >>= removeCallbackMCBMVar synthMCBMVar
220 layerMap <- reactiveValueRead layerMapRV
221 let mSelLayer = M.lookup cp layerMap
222 when (isNothing mSelLayer) $ error "Not found selected layer!"
223 let selLayer = fromJust mSelLayer
224 reactiveValueWrite dynMCBMVar (dynConf selLayer)
225 installCallbackMCBMVar dynMCBMVar (updateDynLayer cp) >>=
226 putMVar dynHidMVar
227 reactiveValueWrite statMCBMVar (staticConf selLayer)
228 installCallbackMCBMVar statMCBMVar (updateStatLayer cp) >>=
229 putMVar statHidMVar
230 reactiveValueWrite synthMCBMVar (synthConf selLayer)
231 installCallbackMCBMVar synthMCBMVar (updateSynth cp) >>=
232 putMVar synthHidMVar
233 return ()
234
235 oldCurChanRV <- newCBMVarRW =<< reactiveValueRead curChanRV
236 reactiveValueOnCanRead curChanRV $ do
237 oldC <- reactiveValueRead oldCurChanRV
238 newC <- reactiveValueRead curChanRV
239 when (oldC /= newC) $ do
240 reactiveValueWrite oldCurChanRV newC
241 tryTakeMVar guiCellHidMVar >>=
242 fromMaybeM_ . fmap (removeCallbackMCBMVar guiCellMCBMVar)
243 reactiveValueWrite guiCellMCBMVar inertCell
244
245 ------------------------------------------------------------------------------
246 -- Flatten maps
247 ------------------------------------------------------------------------------
248 let phMapRV :: ReactiveFieldRead IO (M.IntMap (ReactiveFieldWrite IO [PlayHead]))
249 phMapRV = liftR (M.map (\(_,_,b) -> b)) chanMapRV
250
251 boardMapRV :: ReactiveFieldRead IO (M.IntMap Board)
252 boardMapRV = ReactiveFieldRead getter notifier
253 where notifier io = do
254 chanMap <- reactiveValueRead chanMapRV
255 mapM_ ((`reactiveValueOnCanRead` io) . \(b,_,_) -> b) chanMap
256 getter = do
257 chanMap <- reactiveValueRead chanMapRV
258 mapM (reactiveValueRead . \(b,_,_) -> b) chanMap
259
260 return (n, boardMapRV, layerMapRV, phMapRV)