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