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