]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/GUI/NoteSettings.hs
Multiple layer internals done. Translator not finished.
[tmp/julm/arpeggigon.git] / src / RMCA / GUI / NoteSettings.hs
1 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables,
2 TupleSections #-}
3
4 module RMCA.GUI.NoteSettings where
5
6 import Control.Monad
7 import Data.List
8 import Data.Maybe
9 import Data.Ord
10 import Data.Ratio
11 import Data.ReactiveValue
12 import Data.String
13 import Data.Tuple
14 import Graphics.UI.Gtk hiding (Action)
15 import Graphics.UI.Gtk.Reactive
16 import RMCA.Auxiliary
17 import RMCA.GUI.Board
18 import RMCA.MCBMVar
19 import RMCA.Semantics
20
21 setNAttr :: NoteAttr -> Action -> Action
22 setNAttr _ Inert = Inert
23 setNAttr _ Absorb = Absorb
24 setNAttr na (Stop _) = Stop na
25 setNAttr na (ChDir b _ dir) = ChDir b na dir
26 setNAttr na (Split _) = Split na
27
28 getNAttr :: Action -> Maybe NoteAttr
29 getNAttr Inert = Nothing
30 getNAttr Absorb = Nothing
31 getNAttr (Stop na) = Just na
32 getNAttr (ChDir _ na _) = Just na
33 getNAttr (Split na) = Just na
34
35 symbolString :: [(Duration,String)]
36 symbolString = map (\(_,y,z) -> (z,y)) noteSymbList
37
38 noteList :: [(String,Duration)]
39 noteList = map (\(x,_,y) -> (x,y)) noteSymbList
40
41 noteSymbList :: [(String, String, Duration)]
42 noteSymbList = sortBy (comparing (\(_,_,x) -> x))
43 [ ("♩", "Quarter note", 1 % 4)
44 , ("♪", "Eighth note ", 1 % 8)
45 , ("𝅗𝅥", "Half note", 1 % 2)
46 , ("𝅘𝅥𝅯", "Sixteenth note", 1 % 16)
47 , ("𝅝", "Whole note", 1)
48 ]
49
50 comboBoxIndexRV :: (ComboBoxClass box) =>
51 box -> ReactiveFieldReadWrite IO Int
52 comboBoxIndexRV box = ReactiveFieldReadWrite setter getter notifier
53 where getter = comboBoxGetActive box
54 setter = comboBoxSetActive box
55 notifier = void . on box changed
56
57 noteSettingsBox :: IO (VBox, MCBMVar GUICell)
58 noteSettingsBox = do
59 pieceBox <- vBoxNew False 10
60 naBox <- vBoxNew False 10
61 boxPackStart pieceBox naBox PackNatural 10
62
63 -- Articulation box
64 artCombo <- comboBoxNewText
65 artIndex <- mapM (\art -> do i <- comboBoxAppendText artCombo
66 (fromString $ show art)
67 return (art,i)) [NoAccent ..]
68 comboBoxSetActive artCombo 0
69 boxPackStart naBox artCombo PackNatural 10
70 let indexToArt i =
71 fromMaybe (error "In indexToArt: failed \
72 \to find the selected \
73 \articulation.") $ lookup i $ map swap artIndex
74 artToIndex a = fromMaybe (error "In artToIndex: failed \
75 \to find the correct index \
76 \for the \
77 \articulation.") $ lookup a artIndex
78 artComboRV = bijection (indexToArt,artToIndex) `liftRW`
79 comboBoxIndexRV artCombo
80
81 -- Slide box
82 slideCombo <- comboBoxNewText
83 slideIndex <- mapM (\sli -> do i <- comboBoxAppendText slideCombo
84 (fromString $ show sli)
85 return (sli,i)) [NoSlide ..]
86 comboBoxSetActive slideCombo 0
87 boxPackStart naBox slideCombo PackNatural 10
88 let indexToSlide i =
89 fromMaybe (error "In indexToSlide: failed \
90 \to find the correct slide \
91 \for the selected \
92 \index.") $ lookup i $ map swap slideIndex
93 slideToIndex s =
94 fromMaybe (error "In slideToIndex: failed \
95 \to find \
96 \the correct index \
97 \for the slide.") $ lookup s slideIndex
98 slideComboRV = bijection (indexToSlide,slideToIndex) `liftRW`
99 comboBoxIndexRV slideCombo
100
101 -- Note duration box
102 noteDurBox <- hBoxNew False 10
103 noteDurCombo <- comboBoxNewText
104 noteDurIndex <- mapM (\(str,dur) -> do i <- comboBoxAppendText noteDurCombo
105 (fromString str)
106 return (dur,i)) noteList
107 comboBoxSetActive noteDurCombo 0
108 let indexToDur i =
109 fromMaybe (error "In indexToDur: failed \
110 \to find the correct \
111 \ duration for the \
112 \selected index.") $ lookup i $ map swap noteDurIndex
113 durToIndex d =
114 fromMaybe (error "In durToIndex: \
115 \failed to find \
116 \the correct index \
117 \for the duration.") $ lookup d noteDurIndex
118 noteDurRV = bijection (indexToDur, durToIndex) `liftRW`
119 comboBoxIndexRV noteDurCombo
120 noteDurLabel <- labelNew =<< (`lookup` symbolString) <$> reactiveValueRead noteDurRV
121 let noteDurLabelRV = labelTextReactive noteDurLabel
122 boxPackStart naBox noteDurBox PackNatural 10
123 boxPackStart noteDurBox noteDurCombo PackNatural 10
124 boxPackStart noteDurBox noteDurLabel PackNatural 10
125
126 -- Repeat count box
127 rCountAdj <- adjustmentNew 1 0 100 1 1 0
128 rCount <- spinButtonNew rCountAdj 1 0
129 boxPackStart pieceBox rCount PackNatural 10
130 let rCountRV = spinButtonValueIntReactive rCount
131
132 -- Side RV
133 -- Carries the index of the tile to display and what to display.
134 setRV <- newMCBMVar inertCell
135
136 reactiveValueOnCanRead noteDurRV $ do
137 nDur <- reactiveValueRead noteDurRV
138 oCell <- reactiveValueRead setRV
139 let nCa :: Maybe NoteAttr
140 nCa = (\na -> na { naDur = nDur }) <$> getNAttr (cellAction oCell)
141 nCell :: GUICell
142 nCell = if isJust nCa
143 then oCell { cellAction =
144 setNAttr (fromJust nCa) (cellAction oCell) }
145 else oCell
146 reactiveValueWriteOnNotEq setRV nCell
147 fromMaybeM_ $ reactiveValueWrite noteDurLabelRV <$> lookup nDur symbolString
148
149
150 reactiveValueOnCanRead rCountRV $ do
151 nRCount <- reactiveValueRead rCountRV
152 oCell <- reactiveValueRead setRV
153 let nCell = oCell { repeatCount = nRCount }
154 reactiveValueWrite setRV nCell
155
156 reactiveValueOnCanRead slideComboRV $ do
157 nSlide <- reactiveValueRead slideComboRV
158 oCell <- reactiveValueRead setRV
159 let nCa :: Maybe NoteAttr
160 nCa = (\na -> na { naOrn = (naOrn na) { ornSlide = nSlide } }) <$>
161 getNAttr (cellAction oCell)
162 nCell :: GUICell
163 nCell = if isJust nCa
164 then oCell { cellAction =
165 setNAttr (fromJust nCa) (cellAction oCell)
166 }
167 else oCell
168 reactiveValueWrite setRV nCell
169
170 reactiveValueOnCanRead artComboRV $ do
171 nArt <- reactiveValueRead artComboRV
172 oCell <- reactiveValueRead setRV
173 let nCa :: Maybe NoteAttr
174 nCa = (\na -> na { naArt = nArt }) <$> getNAttr (cellAction oCell)
175 nCell :: GUICell
176 nCell = if isJust nCa
177 then oCell { cellAction =
178 setNAttr (fromJust nCa) (cellAction oCell) }
179 else oCell
180 reactiveValueWrite setRV nCell
181
182 let hideNa :: IO ()
183 hideNa = do widgetHide slideCombo
184 widgetHide artCombo
185 widgetShow rCount
186 widgetHideAll noteDurBox
187 showNa :: IO ()
188 showNa = do widgetShow slideCombo
189 widgetShow artCombo
190 widgetShow rCount
191 widgetShowAll noteDurBox
192 updateNaBox :: GUICell -> IO ()
193 updateNaBox GUICell { cellAction = act } = case act of
194 Inert -> hideNa
195 Absorb -> hideNa
196 _ -> showNa
197
198 reactiveValueOnCanRead setRV $ do
199 nCell <- reactiveValueRead setRV
200 fromMaybeM_ (reactiveValueWriteOnNotEq artComboRV . naArt <$> getNAttr (cellAction nCell))
201 fromMaybeM_ (reactiveValueWriteOnNotEq slideComboRV . ornSlide . naOrn <$> getNAttr (cellAction nCell))
202 reactiveValueWriteOnNotEq rCountRV $ repeatCount nCell
203 fromMaybeM_ (reactiveValueWriteOnNotEq noteDurRV . naDur <$> getNAttr (cellAction nCell))
204 updateNaBox nCell
205
206 {-
207 state <- newEmptyMVar
208 boardOnPress board
209 (\iPos -> liftIO $ do
210 postGUIAsync $ void $ tryPutMVar state iPos
211 return True
212 )
213 boardOnRelease board
214 (\fPos -> do
215 button <- eventButton
216 liftIO $
217 postGUIAsync $ do
218 mp <- boardGetPiece fPos board
219 mstate <- tryTakeMVar state
220 when (fPos `elem` validArea && isJust mp) $ do
221 let piece = snd $ fromJust mp
222 when (button == RightButton && maybe False (== fPos) mstate) $
223 boardSetPiece fPos (BF.second rotateGUICell (Player,piece)) board
224 nmp <- boardGetPiece fPos board
225 when (button == LeftButton && isJust nmp) $ do
226 let nC = snd $ fromJust nmp
227 reactiveValueWrite setRV (fPos,nC)
228 fromMaybeM_ $ reactiveValueWrite artComboRV . naArt <$>
229 getNAttr (cellAction nC)
230 fromMaybeM_ $
231 reactiveValueWrite slideComboRV . ornSlide . naOrn <$> getNAttr (cellAction nC)
232 reactiveValueWrite rCountRV $ repeatCount nC
233 fromMaybeM_ $ reactiveValueWrite noteDurRV . naDur <$>
234 getNAttr (cellAction nC)
235 return True
236 )
237
238 reactiveValueOnCanRead setRV (reactiveValueRead setRV >>= updateNaBox . snd)
239
240 widgetShow pieceBox
241 widgetShow naBox
242 -}
243
244 --setMCBMVar <- newMCBMVar =<< reactiveValueRead setRV
245 --setMCBMVar =:= setRV
246 widgetShow pieceBox
247 widgetShow naBox
248 return (pieceBox,setRV)