]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/GUI/MultiBoard.hs
Removed debug.
[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 Data.List
10 import qualified Data.Map as M
11 import Data.Maybe
12 import Data.ReactiveValue
13 import Graphics.UI.Gtk
14 import Graphics.UI.Gtk.Board.BoardLink
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.Layer.Layer
21 import RMCA.MCBMVar
22 import RMCA.Semantics
23
24 -- In GTk, a “thing with tabs” has the, I think, very confusing name
25 -- Notebook.
26
27 createNotebook :: ( ReactiveValueRead addLayer () IO
28 , ReactiveValueRead rmLayer () IO
29 ) =>
30 addLayer
31 -> rmLayer
32 -> MCBMVar Layer
33 -> MCBMVar GUICell
34 -> IO ( Notebook
35 , ReactiveFieldReadWrite IO
36 (M.Map Int ( ReactiveFieldRead IO Board
37 , Array Pos (ReactiveFieldWrite IO GUICell)
38 , ReactiveFieldWrite IO [PlayHead]
39 ))
40 , ReactiveFieldReadWrite IO Int
41 )
42 createNotebook addLayerRV rmLayerRV layerMCBMVar 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 postGUIAsync $ void $ tryPutMVar state iPos
71 return True
72 )
73 boardOnRelease ioBoard
74 (\fPos -> do
75 button <- eventButton
76 liftIO $ postGUIAsync $ do
77 mp <- boardGetPiece fPos ioBoard
78 mstate <- tryTakeMVar state
79 when (fPos `elem` validArea && isJust mp) $ do
80 let piece = snd $ fromJust mp
81 when (button == RightButton && maybe False (== fPos) mstate) $ do
82 let nCell = rotateGUICell piece
83 --boardSetPiece fPos nPiece ioBoard
84 reactiveValueWrite guiCellMCBMVar nCell
85 nmp <- boardGetPiece fPos ioBoard
86 when (button == LeftButton && isJust nmp) $ do
87 let nCell = snd $ fromJust nmp
88 mOHid <- tryTakeMVar guiCellHidMVar
89 when (isJust mOHid) $
90 removeCallbackMCBMVar guiCellMCBMVar $ fromJust mOHid
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 "Lol first"
111 notebookPageNumber <- newCBMVarRW 1
112
113 initBoardRV 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
128 installCallbackMCBMVar layerMCBMVar
129 (reactiveValueRead curChanRV >>= updateLayer) >>= putMVar layerHidMVar
130
131 ------------------------------------------------------------------------------
132 -- Following boards
133 ------------------------------------------------------------------------------
134
135 reactiveValueOnCanRead addLayerRV $ postGUIAsync $ do
136 np <- reactiveValueRead notebookPageNumber
137 unless (np >= 16) $ do
138 reactiveValueWrite notebookPageNumber (np + 1)
139 nBoardCont <- backgroundContainerNew
140
141 nGuiBoard <- attachGameRules =<< initGame
142 clickHandler nGuiBoard
143 nCenterBoard <- alignmentNew 0.5 0.5 0 0
144 containerAdd nCenterBoard nGuiBoard
145 containerAdd nBoardCont nCenterBoard
146
147 newP <- notebookAppendPage n nBoardCont $ show np
148 pChan <- reactiveValueRead pageChanRV
149 let newCP = foundHole pChan
150 (nBoardRV, nPieceArrRV, nPhRV) <- initBoardRV nGuiBoard
151
152 reactiveValueRead chanMapRV >>=
153 reactiveValueWrite chanMapRV . M.insert newCP (nBoardRV,nPieceArrRV,nPhRV)
154 reactiveValueRead layerMapRV >>=
155 reactiveValueWrite layerMapRV . M.insert newCP defaultLayer
156
157 --reactiveValueWrite curPageRV newP
158 reactiveValueWrite pageChanRV (pChan ++ [newCP])
159 widgetShowAll n
160
161 reactiveValueOnCanRead rmLayerRV $ postGUIAsync $ do
162 np <- reactiveValueRead notebookPageNumber
163 when (np > 1) $ do
164 cp <- reactiveValueRead curPageRV
165 oldCP <- reactiveValueRead curChanRV
166 let rmIndex :: Int -> [a] -> [a]
167 rmIndex n l = take n l ++ drop (n + 1) l
168 notebookRemovePage n cp
169
170 reactiveValueRead pageChanRV >>=
171 reactiveValueWrite pageChanRV . rmIndex cp
172
173 reactiveValueRead notebookPageNumber >>=
174 reactiveValueWrite notebookPageNumber . subtract 1
175
176 reactiveValueRead chanMapRV >>=
177 reactiveValueWrite chanMapRV . M.delete oldCP
178 reactiveValueRead layerMapRV >>=
179 reactiveValueWrite layerMapRV . M.delete oldCP
180
181 --updateRV curPageRV
182
183 widgetShowAll n
184 return ()
185
186 reactiveValueOnCanRead curChanRV $ do
187 cp <- reactiveValueRead curChanRV
188 when (cp >= 0) $ do
189 takeMVar layerHidMVar >>= removeCallbackMCBMVar layerMCBMVar
190 layerMap <- reactiveValueRead layerMapRV
191 let mSelLayer = M.lookup cp layerMap
192 when (isNothing mSelLayer) $ error "Not found selected layer!"
193 let selLayer = fromJust mSelLayer
194 reactiveValueWrite layerMCBMVar selLayer
195 installCallbackMCBMVar layerMCBMVar (updateLayer cp) >>=
196 putMVar layerHidMVar
197 return ()
198
199 ------------------------------------------------------------------------------
200 -- For good measure
201 ------------------------------------------------------------------------------
202 return (n, chanMapRV, curPageRV)