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