]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/GUI/NoteSettings.hs
Edit change log.
[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 =<< (`lookup` symbolString) <$> reactiveValueRead noteDurRV
124 let noteDurLabelRV = labelTextReactive noteDurLabel
125 boxPackStart naBox noteDurBox PackNatural 0
126 boxPackStart noteDurBox noteDurCombo PackNatural 0
127 boxPackStart noteDurBox noteDurLabel PackNatural 0
128
129 -- Repeat count box
130 rCountAdj <- adjustmentNew 1 0 100 1 1 0
131 rCount <- spinButtonNew rCountAdj 1 0
132 boxPackStart pieceBox rCount PackNatural 0
133 let rCountRV = spinButtonValueIntReactive rCount
134
135 -- Side RV
136 -- Carries the index of the tile to display and what to display.
137 setRV <- newMCBMVar inertCell
138
139 reactiveValueOnCanRead noteDurRV $ do
140 nDur <- reactiveValueRead noteDurRV
141 oCell <- reactiveValueRead setRV
142 let nCa :: Maybe NoteAttr
143 nCa = (\na -> na { naDur = nDur }) <$> getNAttr (cellAction oCell)
144 nCell :: GUICell
145 nCell = if isJust nCa
146 then oCell { cellAction =
147 setNAttr (fromJust nCa) (cellAction oCell) }
148 else oCell
149 reactiveValueWriteOnNotEq setRV nCell
150 fromMaybeM_ $ reactiveValueWrite noteDurLabelRV <$> lookup nDur symbolString
151
152
153 reactiveValueOnCanRead rCountRV $ do
154 nRCount <- reactiveValueRead rCountRV
155 oCell <- reactiveValueRead setRV
156 let nCell = oCell { repeatCount = nRCount }
157 reactiveValueWrite setRV nCell
158
159 reactiveValueOnCanRead slideComboRV $ do
160 nSlide <- reactiveValueRead slideComboRV
161 oCell <- reactiveValueRead setRV
162 let nCa :: Maybe NoteAttr
163 nCa = (\na -> na { naOrn = (naOrn na) { ornSlide = nSlide } }) <$>
164 getNAttr (cellAction oCell)
165 nCell :: GUICell
166 nCell = if isJust nCa
167 then oCell { cellAction =
168 setNAttr (fromJust nCa) (cellAction oCell)
169 }
170 else oCell
171 reactiveValueWrite setRV nCell
172
173 reactiveValueOnCanRead artComboRV $ do
174 nArt <- reactiveValueRead artComboRV
175 oCell <- reactiveValueRead setRV
176 let nCa :: Maybe NoteAttr
177 nCa = (\na -> na { naArt = nArt }) <$> getNAttr (cellAction oCell)
178 nCell :: GUICell
179 nCell = if isJust nCa
180 then oCell { cellAction =
181 setNAttr (fromJust nCa) (cellAction oCell) }
182 else oCell
183 reactiveValueWrite setRV nCell
184
185 let hideNa :: IO ()
186 hideNa = do widgetHide slideCombo
187 widgetHide artCombo
188 widgetShow rCount
189 widgetHideAll noteDurBox
190 showNa :: IO ()
191 showNa = do widgetShow slideCombo
192 widgetShow artCombo
193 widgetShow rCount
194 widgetShowAll noteDurBox
195 updateNaBox :: GUICell -> IO ()
196 updateNaBox GUICell { cellAction = act } = case act of
197 Inert -> hideNa
198 Absorb -> hideNa
199 _ -> showNa
200
201 reactiveValueOnCanRead setRV $ postGUIAsync $ do
202 nCell <- reactiveValueRead setRV
203 fromMaybeM_ (reactiveValueWriteOnNotEq artComboRV . naArt <$>
204 getNAttr (cellAction nCell))
205 fromMaybeM_ (reactiveValueWriteOnNotEq slideComboRV . ornSlide . naOrn <$>
206 getNAttr (cellAction nCell))
207 reactiveValueWriteOnNotEq rCountRV $ repeatCount nCell
208 fromMaybeM_ (reactiveValueWriteOnNotEq noteDurRV . naDur <$>
209 getNAttr (cellAction nCell))
210 updateNaBox nCell
211
212 widgetShow pieceBox
213 widgetShow naBox
214 return (pieceBox,setRV)