]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/GUI/NoteSettings.hs
Whiter hexagon.
[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 noteList' :: [(String,Duration)]
42 noteList' = map (\(x,y,z) -> (x ++ " " ++ y,z)) noteSymbList
43
44 noteSymbList :: [(String, String, Duration)]
45 noteSymbList = sortBy (comparing (\(_,_,x) -> x))
46 [ ("♩", "Quarter note", 1 % 4)
47 , ("♪", "Eighth note ", 1 % 8)
48 , ("𝅗𝅥", "Half note", 1 % 2)
49 , ("𝅘𝅥𝅯", "Sixteenth note", 1 % 16)
50 , ("𝅝", "Whole note", 1)
51 ]
52
53 comboBoxIndexRV :: (ComboBoxClass box) =>
54 box -> ReactiveFieldReadWrite IO Int
55 comboBoxIndexRV box = ReactiveFieldReadWrite setter getter notifier
56 where getter = comboBoxGetActive box
57 setter = comboBoxSetActive box
58 notifier = void . on box changed
59
60 noteSettingsBox :: IO (VBox, MCBMVar GUICell)
61 noteSettingsBox = do
62 pieceBox <- vBoxNew False 5
63 naBox <- vBoxNew False 5
64 boxPackStart pieceBox naBox PackNatural 0
65
66 -- Articulation box
67 artCombo <- comboBoxNewText
68 artIndex <- mapM (\art -> do i <- comboBoxAppendText artCombo
69 (fromString $ show art)
70 return (art,i)) [NoAccent ..]
71 comboBoxSetActive artCombo 0
72 boxPackStart naBox artCombo PackNatural 0
73 let indexToArt i =
74 fromMaybe (error "In indexToArt: failed \
75 \to find the selected \
76 \articulation.") $ lookup i $ map swap artIndex
77 artToIndex a = fromMaybe (error "In artToIndex: failed \
78 \to find the correct index \
79 \for the \
80 \articulation.") $ lookup a artIndex
81 artComboRV = bijection (indexToArt,artToIndex) `liftRW`
82 comboBoxIndexRV artCombo
83
84 -- Slide box
85 slideCombo <- comboBoxNewText
86 slideIndex <- mapM (\sli -> do i <- comboBoxAppendText slideCombo
87 (fromString $ show sli)
88 return (sli,i)) [NoSlide ..]
89 comboBoxSetActive slideCombo 0
90 boxPackStart naBox slideCombo PackNatural 0
91 let indexToSlide i =
92 fromMaybe (error "In indexToSlide: failed \
93 \to find the correct slide \
94 \for the selected \
95 \index.") $ lookup i $ map swap slideIndex
96 slideToIndex s =
97 fromMaybe (error "In slideToIndex: failed \
98 \to find \
99 \the correct index \
100 \for the slide.") $ lookup s slideIndex
101 slideComboRV = bijection (indexToSlide,slideToIndex) `liftRW`
102 comboBoxIndexRV slideCombo
103
104 -- Note duration box
105 noteDurBox <- hBoxNew False 10
106 noteDurCombo <- comboBoxNewText
107 noteDurIndex <- mapM (\(str,dur) -> do i <- comboBoxAppendText noteDurCombo
108 (fromString str)
109 return (dur,i)) noteList
110 comboBoxSetActive noteDurCombo 0
111 let indexToDur i =
112 fromMaybe (error "In indexToDur: failed \
113 \to find the correct \
114 \ duration for the \
115 \selected index.") $ lookup i $ map swap noteDurIndex
116 durToIndex d =
117 fromMaybe (error "In durToIndex: \
118 \failed to find \
119 \the correct index \
120 \for the duration.") $ lookup d noteDurIndex
121 noteDurRV = bijection (indexToDur, durToIndex) `liftRW`
122 comboBoxIndexRV noteDurCombo
123 noteDurLabel <- labelNew =<< fmap (`lookup` symbolString)
124 (reactiveValueRead noteDurRV)
125 let noteDurLabelRV = labelTextReactive noteDurLabel
126 boxPackStart naBox noteDurBox PackNatural 0
127 boxPackStart noteDurBox noteDurCombo PackNatural 0
128 boxPackStart noteDurBox noteDurLabel PackNatural 0
129
130 -- Repeat count box
131 rCountAdj <- adjustmentNew 1 0 100 1 1 0
132 rCount <- spinButtonNew rCountAdj 1 0
133 boxPackStart pieceBox rCount PackNatural 0
134 let rCountRV = spinButtonValueIntReactive rCount
135
136 -- Side RV
137 -- Carries the index of the tile to display and what to display.
138 setRV <- newMCBMVar inertCell
139
140 reactiveValueOnCanRead noteDurRV $ do
141 nDur <- reactiveValueRead noteDurRV
142 oCell <- reactiveValueRead setRV
143 let nCa :: Maybe NoteAttr
144 nCa = fmap (\na -> na { naDur = nDur }) (getNAttr (cellAction oCell))
145 nCell :: GUICell
146 nCell = if isJust nCa
147 then oCell { cellAction =
148 setNAttr (fromJust nCa) (cellAction oCell) }
149 else oCell
150 reactiveValueWriteOnNotEq setRV nCell
151 fromMaybeM_ $ fmap (reactiveValueWrite noteDurLabelRV)
152 (lookup nDur symbolString)
153
154
155 reactiveValueOnCanRead rCountRV $ do
156 nRCount <- reactiveValueRead rCountRV
157 oCell <- reactiveValueRead setRV
158 let nCell = oCell { repeatCount = nRCount }
159 reactiveValueWrite setRV nCell
160
161 reactiveValueOnCanRead slideComboRV $ do
162 nSlide <- reactiveValueRead slideComboRV
163 oCell <- reactiveValueRead setRV
164 let nCa :: Maybe NoteAttr
165 nCa = fmap (\na -> na { naOrn = (naOrn na) { ornSlide = nSlide } })
166 (getNAttr (cellAction oCell))
167 nCell :: GUICell
168 nCell = if isJust nCa
169 then oCell { cellAction =
170 setNAttr (fromJust nCa) (cellAction oCell)
171 }
172 else oCell
173 reactiveValueWrite setRV nCell
174
175 reactiveValueOnCanRead artComboRV $ do
176 nArt <- reactiveValueRead artComboRV
177 oCell <- reactiveValueRead setRV
178 let nCa :: Maybe NoteAttr
179 nCa = fmap (\na -> na { naArt = nArt }) (getNAttr (cellAction oCell))
180 nCell :: GUICell
181 nCell = if isJust nCa
182 then oCell { cellAction =
183 setNAttr (fromJust nCa) (cellAction oCell) }
184 else oCell
185 reactiveValueWrite setRV nCell
186
187 let hideNa :: IO ()
188 hideNa = do widgetHide slideCombo
189 widgetHide artCombo
190 widgetShow rCount
191 widgetHideAll noteDurBox
192 showNa :: IO ()
193 showNa = do widgetShow slideCombo
194 widgetShow artCombo
195 widgetShow rCount
196 widgetShowAll noteDurBox
197 updateNaBox :: GUICell -> IO ()
198 updateNaBox GUICell { cellAction = act } = case act of
199 Inert -> hideNa
200 Absorb -> hideNa
201 _ -> showNa
202
203 reactiveValueOnCanRead setRV $ postGUIAsync $ do
204 nCell <- reactiveValueRead setRV
205 fromMaybeM_ (fmap (reactiveValueWriteOnNotEq artComboRV . naArt)
206 (getNAttr (cellAction nCell)))
207 fromMaybeM_ (fmap (reactiveValueWriteOnNotEq slideComboRV
208 . ornSlide . naOrn)
209 (getNAttr (cellAction nCell)))
210 reactiveValueWriteOnNotEq rCountRV $ repeatCount nCell
211 fromMaybeM_ (fmap (reactiveValueWriteOnNotEq noteDurRV . naDur)
212 (getNAttr (cellAction nCell)))
213 updateNaBox nCell
214
215 widgetShow pieceBox
216 widgetShow naBox
217 return (pieceBox,setRV)