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