]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/GUI/NoteSettings.hs
A sort of sensible multi layer GUI.
[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 <- newCBMVarRW 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 reactiveValueWrite 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 $ reactiveValueRead setRV >>= updateNaBox
199 {-
200 state <- newEmptyMVar
201 boardOnPress board
202 (\iPos -> liftIO $ do
203 postGUIAsync $ void $ tryPutMVar state iPos
204 return True
205 )
206 boardOnRelease board
207 (\fPos -> do
208 button <- eventButton
209 liftIO $
210 postGUIAsync $ do
211 mp <- boardGetPiece fPos board
212 mstate <- tryTakeMVar state
213 when (fPos `elem` validArea && isJust mp) $ do
214 let piece = snd $ fromJust mp
215 when (button == RightButton && maybe False (== fPos) mstate) $
216 boardSetPiece fPos (BF.second rotateGUICell (Player,piece)) board
217 nmp <- boardGetPiece fPos board
218 when (button == LeftButton && isJust nmp) $ do
219 let nC = snd $ fromJust nmp
220 reactiveValueWrite setRV (fPos,nC)
221 fromMaybeM_ $ reactiveValueWrite artComboRV . naArt <$>
222 getNAttr (cellAction nC)
223 fromMaybeM_ $
224 reactiveValueWrite slideComboRV . ornSlide . naOrn <$> getNAttr (cellAction nC)
225 reactiveValueWrite rCountRV $ repeatCount nC
226 fromMaybeM_ $ reactiveValueWrite noteDurRV . naDur <$>
227 getNAttr (cellAction nC)
228 return True
229 )
230
231 reactiveValueOnCanRead setRV (reactiveValueRead setRV >>= updateNaBox . snd)
232
233 widgetShow pieceBox
234 widgetShow naBox
235 -}
236
237 setMCBMVar <- newMCBMVar =<< reactiveValueRead setRV
238 setMCBMVar =:= setRV
239 return (pieceBox,setMCBMVar)