1 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables,
4 module RMCA.GUI.NoteSettings where
6 import Control.Concurrent.MVar
8 import Control.Monad.IO.Class
10 import qualified Data.Bifunctor as BF
15 import Data.ReactiveValue
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
25 fromMaybeM_ :: (Monad m) => Maybe (m ()) -> m ()
26 fromMaybeM_ = fromMaybe (return ())
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
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
42 symbolString :: [(Duration,String)]
43 symbolString = map (\(_,y,z) -> (z,y)) noteSymbList
45 noteList :: [(String,Duration)]
46 noteList = map (\(x,_,y) -> (x,y)) noteSymbList
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)
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
64 clickHandling :: (ReactiveValueWrite cell GUICell IO) =>
66 -> IOBoard -> VBox -> IO VBox
67 clickHandling pieceArrRV board pieceBox = do
68 naBox <- vBoxNew False 10
69 boxPackStart pieceBox naBox PackNatural 10
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."
82 artToIndex a = case lookup a artIndex of
83 Nothing -> error "In artToIndex: failed \
84 \to find the correct index for the articulation."
86 artComboRV = bijection (indexToArt,artToIndex) `liftRW`
87 comboBoxIndexRV artCombo
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."
100 slideToIndex s = case lookup s slideIndex of
101 Nothing -> error "In slideToIndex: failed\
102 \to find the correct index for the slide."
104 slideComboRV = bijection (indexToSlide,slideToIndex) `liftRW`
105 comboBoxIndexRV slideCombo
108 noteDurBox <- hBoxNew False 10
109 noteDurCombo <- comboBoxNewText
110 noteDurIndex <- mapM (\(str,dur) -> do i <- comboBoxAppendText noteDurCombo
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."
118 durToIndex d = case lookup d noteDurIndex of
119 Nothing -> error "In durToIndex: failed\
120 \to find the correct index for the duration."
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
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
137 -- Carries the index of the tile to display and what to display.
138 setRV <- newCBMVarRW ((0,0),inertCell)
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)
146 nCell = if isJust nCa
147 then oCell { cellAction =
148 setNAttr (fromJust nCa) (cellAction oCell) }
150 reactiveValueWrite setRV (i,nCell)
151 fromMaybeM_ $ reactiveValueWrite noteDurLabelRV <$> lookup nDur symbolString
152 reactiveValueWrite (pieceArrRV ! i) nCell
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
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)
169 nCell = if isJust nCa
170 then oCell { cellAction =
171 setNAttr (fromJust nCa) (cellAction oCell)
174 reactiveValueWrite setRV (i,nCell)
175 reactiveValueWrite (pieceArrRV ! i) nCell
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)
183 nCell = if isJust nCa
184 then oCell { cellAction =
185 setNAttr (fromJust nCa) (cellAction oCell) }
187 reactiveValueWrite setRV (i,nCell)
188 reactiveValueWrite (pieceArrRV ! i) nCell
191 hideNa = do widgetHide slideCombo
194 widgetHideAll noteDurBox
196 showNa = do widgetShow slideCombo
199 widgetShowAll noteDurBox
200 updateNaBox :: GUICell -> IO ()
201 updateNaBox GUICell { cellAction = act } = case act of
206 state <- newEmptyMVar
208 (\iPos -> liftIO $ do
209 postGUIAsync $ void $ tryPutMVar state iPos
214 button <- eventButton
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
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)
231 reactiveValueWrite slideComboRV . ornSlide . naOrn <$> getNAttr (cellAction nC)
232 reactiveValueWrite rCountRV $ repeatCount nC
233 fromMaybeM_ $ reactiveValueWrite noteDurRV . naDur <$>
234 getNAttr (cellAction nC)
238 reactiveValueOnCanRead setRV (reactiveValueRead setRV >>= updateNaBox . snd)