]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/GUI/NoteSettings.hs
Segmenting the main a little.
[tmp/julm/arpeggigon.git] / src / RMCA / GUI / NoteSettings.hs
1 {-# LANGUAGE ScopedTypeVariables, TupleSections #-}
2
3 module RMCA.GUI.NoteSettings 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.Bifunctor as BF
10 import Data.Maybe
11 import Data.ReactiveValue
12 import Data.String
13 import Data.Tuple
14 import Graphics.UI.Gtk hiding (Action)
15 import Graphics.UI.Gtk.Board.TiledBoard hiding (Board)
16 import Graphics.UI.Gtk.Reactive
17 import RMCA.Auxiliary.RV
18 import RMCA.GUI.Board
19 import RMCA.Semantics
20
21 fromMaybeM_ :: (Monad m) => Maybe (m ()) -> m ()
22 fromMaybeM_ = fromMaybe (return ())
23
24 setNAttr :: NoteAttr -> Action -> Action
25 setNAttr _ Inert = Inert
26 setNAttr _ Absorb = Absorb
27 setNAttr na (Stop _) = Stop na
28 setNAttr na (ChDir b _ dir) = ChDir b na dir
29 setNAttr na (Split _) = Split na
30
31 getNAttr :: Action -> Maybe NoteAttr
32 getNAttr Inert = Nothing
33 getNAttr Absorb = Nothing
34 getNAttr (Stop na) = Just na
35 getNAttr (ChDir _ na _) = Just na
36 getNAttr (Split na) = Just na
37
38 comboBoxIndexRV :: (ComboBoxClass box) =>
39 box -> ReactiveFieldReadWrite IO Int
40 comboBoxIndexRV box = ReactiveFieldReadWrite setter getter notifier
41 where getter = comboBoxGetActive box
42 setter = comboBoxSetActive box
43 notifier = void . on box changed
44
45 clickHandling :: Array Pos (ReactiveFieldWrite IO GUICell)
46 -> IOBoard -> VBox -> IO VBox
47 clickHandling pieceArrRV board pieceBox = do
48 naBox <- vBoxNew False 10
49 boxPackStart pieceBox naBox PackNatural 10
50
51 -- Articulation box
52 artCombo <- comboBoxNewText
53 artIndex <- mapM (\art -> do i <- comboBoxAppendText artCombo
54 (fromString $ show art)
55 return (art,i)) [NoAccent ..]
56 comboBoxSetActive artCombo 0
57 boxPackStart naBox artCombo PackNatural 10
58 let indexToArt i = fromMaybe NoAccent $ lookup i $ map swap artIndex
59 artToIndex a = fromMaybe (-1) $ lookup a artIndex
60 artComboRV = liftRW (bijection (indexToArt,artToIndex)) $
61 comboBoxIndexRV artCombo
62
63 -- Slide box
64 slideCombo <- comboBoxNewText
65 slideIndex <- mapM (\sli -> do i <- comboBoxAppendText slideCombo
66 (fromString $ show sli)
67 return (sli,i)) [NoSlide ..]
68 comboBoxSetActive slideCombo 0
69 boxPackStart naBox slideCombo PackNatural 10
70 let indexToSlide i = fromMaybe NoSlide $ lookup i $ map swap slideIndex
71 slideToIndex s = fromMaybe (-1) $ lookup s slideIndex
72 slideComboRV = liftRW (bijection (indexToSlide,slideToIndex)) $
73 comboBoxIndexRV slideCombo
74
75 -- Repeat count box
76 rCountAdj <- adjustmentNew 1 0 10 1 1 0
77 rCount <- spinButtonNew rCountAdj 1 0
78 boxPackStart pieceBox rCount PackNatural 10
79 let rCountRV = spinButtonValueIntReactive rCount
80
81 -- Side RV
82 -- Carries the index of the tile to display and what to display.
83 setRV <- newCBMVarRW ((0,0),inertCell)
84
85 reactiveValueOnCanRead rCountRV $ do
86 nRCount <- reactiveValueRead rCountRV
87 (i,oCell) <- reactiveValueRead setRV
88 let nCell = oCell { repeatCount = nRCount }
89 reactiveValueWrite setRV (i,nCell)
90 reactiveValueWrite (pieceArrRV ! i) nCell
91
92 reactiveValueOnCanRead slideComboRV $ do
93 nSlide <- reactiveValueRead slideComboRV
94 (i,oCell) <- reactiveValueRead setRV
95 let nCa :: Maybe NoteAttr
96 nCa = (\na -> na { naOrn = (naOrn na) { ornSlide = nSlide } }) <$>
97 (getNAttr $ cellAction oCell)
98 nCell :: GUICell
99 nCell = if (isJust nCa)
100 then oCell { cellAction =
101 setNAttr (fromJust nCa) (cellAction oCell)
102 }
103 else oCell
104 reactiveValueWrite setRV (i,nCell)
105 reactiveValueWrite (pieceArrRV ! i) nCell
106
107 reactiveValueOnCanRead artComboRV $ do
108 --nArt <- reactiveValueRead artComboRV
109 (i,oCell) <- reactiveValueRead setRV
110 let nCa :: Maybe NoteAttr
111 nCa = getNAttr $ cellAction oCell
112 nCell :: GUICell
113 nCell = if (isJust nCa)
114 then oCell { cellAction =
115 setNAttr (fromJust nCa) (cellAction oCell) }
116 else oCell
117 reactiveValueWrite setRV (i,nCell)
118 reactiveValueWrite (pieceArrRV ! i) nCell
119
120 let hideNa :: IO ()
121 hideNa = do widgetHide slideCombo
122 widgetHide artCombo
123 widgetShow rCount
124 showNa :: IO ()
125 showNa = do widgetShow slideCombo
126 widgetShow artCombo
127 widgetShow rCount
128 updateNaBox :: GUICell -> IO ()
129 updateNaBox GUICell { cellAction = act } = case act of
130 Inert -> hideNa
131 Absorb -> hideNa
132 _ -> showNa
133
134 state <- newEmptyMVar
135 boardOnPress board
136 (\iPos -> liftIO $ do
137 postGUIAsync $ void $ tryPutMVar state iPos
138 return True
139 )
140 boardOnRelease board
141 (\fPos -> liftIO $ do
142 postGUIAsync $ do
143 mp <- boardGetPiece fPos board
144 mstate <- tryTakeMVar state
145 when (fPos `elem` validArea && isJust mp) $ do
146 let piece = snd $ fromJust mp
147 when (maybe False (== fPos) mstate) $ do
148 boardSetPiece fPos (BF.second rotateGUICell (Player,piece)) board
149 nmp <- boardGetPiece fPos board
150 print nmp
151 when (isJust nmp) $ do
152 let nC = snd $ fromJust nmp
153 reactiveValueWrite setRV (fPos,nC)
154 fromMaybeM_ $ reactiveValueWrite artComboRV <$>
155 naArt <$> getNAttr (cellAction nC)
156 fromMaybeM_ $ reactiveValueWrite slideComboRV <$>
157 ornSlide <$> naOrn <$> getNAttr (cellAction nC)
158 reactiveValueWrite rCountRV $ repeatCount nC
159 return True
160 )
161
162 reactiveValueOnCanRead setRV (reactiveValueRead setRV >>= updateNaBox . snd)
163
164 widgetShow pieceBox
165 widgetShow naBox
166 return pieceBox