]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/GUI/MultiBoard.hs
Add a warning about Jack in the README.
[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 layerName :: String
31 layerName = "Layer"
32
33 createNotebook :: ( ReactiveValueRead addLayer () IO
34 , ReactiveValueRead rmLayer () IO
35 , ReactiveValueAtomicUpdate board (M.IntMap ([Note],[Message])) IO
36 ) =>
37 board
38 -> IOTick
39 -> addLayer
40 -> rmLayer
41 -> MCBMVar StaticLayerConf
42 -> MCBMVar DynLayerConf
43 -> MCBMVar SynthConf
44 -> MCBMVar GUICell
45 -> IO ( Notebook
46 , ReactiveFieldRead IO (M.IntMap Board)
47 , CBRef (M.IntMap LayerConf)
48 , ReactiveFieldRead IO
49 (M.IntMap (ReactiveFieldWrite IO [PlayHead]))
50 )
51 createNotebook boardQueue tc addLayerRV rmLayerRV
52 statMCBMVar dynMCBMVar synthMCBMVar guiCellMCBMVar = do
53 n <- notebookNew
54 let curPageRV = ReactiveFieldReadWrite setter getter notifier
55 where (ReactiveFieldRead getter _) = notebookGetCurrentPagePassive n
56 -- afterSwitchPage is deprecated but switchPage gets us
57 -- the old page number and not the new one and using
58 -- afterSwitchPage doesn't trigger a warning so…
59 setter = postGUIAsync . notebookSetCurrentPage n
60 notifier io = void $ afterSwitchPage n (const io)
61
62 pageChanRV <- newCBMVarRW []
63 let foundHole = let foundHole' [] = 0
64 foundHole' [x] = x + 1
65 foundHole' (x:y:xs) = if x + 1 /= y then x + 1 else foundHole (y:xs)
66 in foundHole' . sort
67
68
69 let 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 layerName
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 -> pc ++ [foundHole 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 notebookAppendPage n nBoardCont layerName
181 pChan <- reactiveValueRead pageChanRV
182 let newCP = foundHole pChan
183 (nBoardRV, nPieceArrRV, nPhRV) <- initBoardRV tc nGuiBoard
184
185 reactiveValueRead chanMapRV >>=
186 reactiveValueWrite chanMapRV . M.insert newCP (nBoardRV,nPieceArrRV,nPhRV)
187 reactiveValueRead layerMapRV >>=
188 reactiveValueWrite layerMapRV . M.insert newCP defaultLayerConf
189
190 --reactiveValueWrite curPageRV newP
191 reactiveValueWrite pageChanRV (pChan ++ [newCP])
192 widgetShowAll n
193
194 reactiveValueOnCanRead rmLayerRV $ postGUIAsync $ do
195 np <- reactiveValueRead notebookPageNumber
196 when (np > 1) $ do
197 cp <- reactiveValueRead curPageRV
198 oldCP <- reactiveValueRead curChanRV
199 let rmIndex :: Int -> [a] -> [a]
200 rmIndex n l = take n l ++ drop (n + 1) l
201 notebookRemovePage n cp
202
203 reactiveValueRead pageChanRV >>=
204 reactiveValueWrite pageChanRV . rmIndex cp
205
206 reactiveValueRead notebookPageNumber >>=
207 reactiveValueWrite notebookPageNumber . subtract 1
208
209 reactiveValueRead chanMapRV >>=
210 reactiveValueWrite chanMapRV . M.delete oldCP
211
212 reactiveValueRead layerMapRV >>=
213 reactiveValueWrite layerMapRV . M.delete oldCP
214
215 widgetShowAll n
216 return ()
217
218 reactiveValueOnCanRead curChanRV $ do
219 cp <- reactiveValueRead curChanRV
220 when (cp >= 0) $ do
221 takeMVar dynHidMVar >>= removeCallbackMCBMVar dynMCBMVar
222 takeMVar statHidMVar >>= removeCallbackMCBMVar statMCBMVar
223 takeMVar synthHidMVar >>= removeCallbackMCBMVar synthMCBMVar
224 layerMap <- reactiveValueRead layerMapRV
225 let mSelLayer = M.lookup cp layerMap
226 when (isNothing mSelLayer) $ error "Not found selected layer!"
227 let selLayer = fromJust mSelLayer
228 reactiveValueWrite dynMCBMVar (dynConf selLayer)
229 installCallbackMCBMVar dynMCBMVar (updateDynLayer cp) >>=
230 putMVar dynHidMVar
231 reactiveValueWrite statMCBMVar (staticConf selLayer)
232 installCallbackMCBMVar statMCBMVar (updateStatLayer cp) >>=
233 putMVar statHidMVar
234 reactiveValueWrite synthMCBMVar (synthConf selLayer)
235 installCallbackMCBMVar synthMCBMVar (updateSynth cp) >>=
236 putMVar synthHidMVar
237 return ()
238
239 oldCurChanRV <- newCBMVarRW =<< reactiveValueRead curChanRV
240 reactiveValueOnCanRead curChanRV $ do
241 oldC <- reactiveValueRead oldCurChanRV
242 newC <- reactiveValueRead curChanRV
243 when (oldC /= newC) $ do
244 reactiveValueWrite oldCurChanRV newC
245 tryTakeMVar guiCellHidMVar >>=
246 fromMaybeM_ . fmap (removeCallbackMCBMVar guiCellMCBMVar)
247 reactiveValueWrite guiCellMCBMVar inertCell
248
249 ------------------------------------------------------------------------------
250 -- Flatten maps
251 ------------------------------------------------------------------------------
252 let phMapRV :: ReactiveFieldRead IO (M.IntMap (ReactiveFieldWrite IO [PlayHead]))
253 phMapRV = liftR (M.map (\(_,_,b) -> b)) chanMapRV
254
255 boardMapRV :: ReactiveFieldRead IO (M.IntMap Board)
256 boardMapRV = ReactiveFieldRead getter notifier
257 where notifier io = do
258 chanMap <- reactiveValueRead chanMapRV
259 intMapMapM_ ((`reactiveValueOnCanRead` io) . \(b,_,_) -> b) chanMap
260 getter = do
261 chanMap <- reactiveValueRead chanMapRV
262 intMapMapM (reactiveValueRead . \(b,_,_) -> b) chanMap
263
264 return (n, boardMapRV, layerMapRV, phMapRV)
265
266 ------------------------------------------------------------------------------
267 -- IntMap versions of mapM etc. to make code work with GHC 7.8.3
268 ------------------------------------------------------------------------------
269
270 intMapMapM_ :: (Functor m, Monad m) => (a -> m b) -> M.IntMap a -> m ()
271 intMapMapM_ f im = mapM_ f (M.elems im)
272
273 intMapMapM :: (Functor m, Monad m) => (a -> m b) -> M.IntMap a -> m (M.IntMap b)
274 intMapMapM f im = fmap (M.fromList . zip ks) (mapM f es)
275 where
276 (ks, es) = unzip (M.toList im)