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