]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/GUI/LayerSettings.hs
Restart icon working.
[tmp/julm/arpeggigon.git] / src / RMCA / GUI / LayerSettings.hs
1 {-# LANGUAGE FlexibleContexts, LambdaCase, MultiParamTypeClasses, TupleSections
2 #-}
3
4 module RMCA.GUI.LayerSettings where
5
6 import Data.Maybe
7 import Data.ReactiveValue
8 import Data.String
9 import Data.Tuple
10 import Graphics.UI.Gtk
11 import Graphics.UI.Gtk.Reactive
12 import RMCA.Auxiliary
13 import RMCA.GUI.NoteSettings
14 import RMCA.Layer.Board
15 import RMCA.Layer.LayerConf
16 import RMCA.MCBMVar
17 import RMCA.Translator.Instruments
18
19 mkVScale :: String -> Adjustment -> IO (HBox,VScale)
20 mkVScale s adj = do
21 hBox <- hBoxNew False 10
22 boxLabel <- labelNew (Just s)
23 labelSetAngle boxLabel 90
24 boxPackStart hBox boxLabel PackNatural 0
25 boxScale <- vScaleNew adj
26 boxPackStart hBox boxScale PackNatural 0
27 return (hBox,boxScale)
28
29 layerSettings :: (ReactiveValueRead isStarted RunStatus IO) =>
30 isStarted -> IO ( VBox
31 , MCBMVar StaticLayerConf
32 , MCBMVar DynLayerConf
33 , MCBMVar SynthConf
34 )
35 layerSettings isStartedRV = do
36 ------------------------------------------------------------------------------
37 -- GUI Boxes
38 ------------------------------------------------------------------------------
39 layerSettingsVBox <- vBoxNew True 10
40 layerSettingsBox <- hBoxNew False 0
41 centerSettings <- alignmentNew 0.5 0.5 0 0
42 containerAdd layerSettingsBox centerSettings
43 boxPackStart layerSettingsVBox layerSettingsBox PackNatural 0
44
45
46 layBeatBox <- hBoxNew False 10
47 layBeatCombo <- comboBoxNewText
48 layBeatIndex <- mapM (\(str,dur) -> do i <- comboBoxAppendText layBeatCombo
49 (fromString str)
50 return (dur,i)) noteList'
51 comboBoxSetActive layBeatCombo 0
52 let indexToDur i =
53 fromMaybe (error "In indexToDur: failed \
54 \to find the correct \
55 \ duration for the \
56 \selected index.") $ lookup i $ map swap layBeatIndex
57 durToIndex d =
58 fromMaybe (error "In durToIndex: \
59 \failed to find \
60 \the correct index \
61 \for the duration.") $ lookup d layBeatIndex
62 layBeatRV = bijection (indexToDur, durToIndex) `liftRW`
63 comboBoxIndexRV layBeatCombo
64 layBeatLabel <- labelNew (Just "Layer beat"){-=<<
65 (`lookup` symbolString) <$> reactiveValueRead layBeatRV-}
66 --labelSetAngle layBeatLabel 90
67 labelSetLineWrap layBeatLabel True
68 --let layBeatLabelRV = labelTextReactive layBeatLabel
69 boxPackStart layerSettingsBox layBeatBox PackRepel 0
70 auxLayBeatBox <- vBoxNew False 0
71 boxPackEnd layBeatBox auxLayBeatBox PackRepel 0
72 boxPackStart auxLayBeatBox layBeatLabel PackRepel 0
73 boxPackStart auxLayBeatBox layBeatCombo PackNatural 0
74
75 layVolumeAdj <- adjustmentNew 100 0 100 1 1 1
76 (layVolumeBox,layVolumeScale) <- mkVScale "Volume" layVolumeAdj
77 boxPackStart layerSettingsBox layVolumeBox PackRepel 0
78 (Requisition layVolW layVolH) <- widgetSizeRequest layVolumeScale
79 widgetSetSizeRequest layerSettingsBox layVolW (max layVolH 75)
80 scaleSetDigits layVolumeScale 0
81 {-
82 layTempoAdj <- adjustmentNew 1 0 2 0.1 0.1 1
83 (layTempoBox, layTempoScale) <- mkVScale "Layer tempo" layTempoAdj
84 boxPackStart layerSettingsBox layTempoBox PackNatural 0
85 -}
86 strAdj <- adjustmentNew 0.8 0 2 0.1 0.1 0
87 (strBox, layStrengthScale) <- mkVScale "Strength" strAdj
88 boxPackStart layerSettingsBox strBox PackRepel 0
89
90 layerSettingsBox' <- hBoxNew False 10
91 boxPackStart layerSettingsVBox layerSettingsBox' PackNatural 0
92 centerSettings' <- alignmentNew 0 0.5 0 0
93 containerAdd layerSettingsBox' centerSettings'
94
95 bpbBox <- vBoxNew False 0
96 boxPackStart layerSettingsBox' bpbBox PackRepel 0
97 bpbLabel <- labelNew (Just "Beats per bar")
98 labelSetLineWrap bpbLabel True
99 bpbAdj <- adjustmentNew 4 1 16 1 1 0
100 bpbButton <- spinButtonNew bpbAdj 1 0
101 auxBpbBox <- vBoxNew False 0
102 centerAl <- alignmentNew 0.5 0.5 0 0
103 containerAdd auxBpbBox centerAl
104 boxPackStart bpbBox auxBpbBox PackRepel 0
105 boxPackStart auxBpbBox bpbLabel PackGrow 0
106 boxPackStart auxBpbBox bpbButton PackGrow 0
107
108 repeatBox <- vBoxNew False 0
109 boxPackStart layerSettingsBox' repeatBox PackRepel 0
110 repeatLabel <- labelNew (Just "Repeat count")
111 labelSetLineWrap repeatLabel True
112 repeatAdj <- adjustmentNew 0 0 (fromIntegral (maxBound :: Int)) 1 1 0
113 repeatButton <- spinButtonNew repeatAdj 1 0
114 auxRepeatBox <- vBoxNew False 0
115 centerAl' <- alignmentNew 0.5 0.5 0 0
116 containerAdd auxRepeatBox centerAl'
117 boxPackStart repeatBox auxRepeatBox PackRepel 0
118 boxPackStart auxRepeatBox repeatLabel PackGrow 0
119 boxPackStart auxRepeatBox repeatButton PackGrow 0
120 repeatCheckButton <- checkButtonNewWithLabel "Unable repeat count"
121 boxPackStart auxRepeatBox repeatCheckButton PackGrow 0
122
123 instrumentCombo <- comboBoxNewText
124 instrumentIndex <- mapM (\(ind,ins) ->
125 do i <- comboBoxAppendText instrumentCombo $
126 fromString ins
127 return (i, ind)) instrumentList
128 comboBoxSetActive instrumentCombo 0
129 boxPackStart layerSettingsVBox instrumentCombo PackNatural 10
130 ------------------------------------------------------------------------------
131 -- RVs
132 ------------------------------------------------------------------------------
133 let indexToInstr i = fromMaybe (error "Can't get the selected instrument.") $
134 lookup i instrumentIndex
135 instrToIndex ins =
136 fromMaybe (error "Can't retrieve the index for the instrument.") $
137 lookup ins $ map swap instrumentIndex
138 instrumentComboRV = bijection (indexToInstr, instrToIndex) `liftRW`
139 comboBoxIndexRV instrumentCombo
140 layVolumeRV = liftRW (bijection (floor, fromIntegral)) $
141 scaleValueReactive layVolumeScale
142
143 synthMCBMVar <- newMCBMVar
144 =<< reactiveValueRead (liftR2 SynthConf layVolumeRV instrumentComboRV)
145
146 layPitchRV <- newCBMVarRW 1
147 let strengthRV = floatConv $ scaleValueReactive layStrengthScale
148
149 dynMCBMVar <- newMCBMVar
150 =<< reactiveValueRead (liftR3 DynLayerConf layBeatRV layPitchRV strengthRV)
151
152 let bpbRV = spinButtonValueIntReactive bpbButton
153 repeatCheckRV = toggleButtonActiveReactive repeatCheckButton
154 repeatRV' = spinButtonValueIntReactive repeatButton
155 repeatRV = liftR2 (\act r -> if act then Just r else Nothing)
156 repeatCheckRV repeatRV'
157 repeatSensitive = widgetSensitiveReactive repeatButton
158 repeatCheckSensitive = widgetSensitiveReactive repeatCheckButton
159
160 bpbSensitiveRV <- swapHandlerStorage $
161 widgetSensitiveReactive bpbButton
162
163 reactiveValueOnCanRead isStartedRV $
164 reactiveValueRead isStartedRV >>=
165 \case
166 Running -> do reactiveValueRead repeatCheckRV
167 reactiveValueWrite repeatSensitive False
168 reactiveValueWrite bpbSensitiveRV False
169 reactiveValueWrite repeatCheckSensitive False
170 Stopped -> do reactiveValueRead repeatCheckRV >>=
171 reactiveValueWrite repeatSensitive
172 reactiveValueWrite bpbSensitiveRV True
173 reactiveValueWrite repeatCheckSensitive True
174
175 repeatCheckRV =:> repeatSensitive
176 reactiveValueWrite repeatCheckRV False
177 reactiveValueWrite repeatSensitive False
178
179 statMCBMVar <- newMCBMVar
180 =<< reactiveValueRead (liftR2 StaticLayerConf bpbRV repeatRV)
181
182 reactiveValueOnCanRead dynMCBMVar $ postGUIAsync $ do
183 nDyn <- reactiveValueRead dynMCBMVar
184 reactiveValueWriteOnNotEq layBeatRV $ layerBeat nDyn
185 reactiveValueWriteOnNotEq layPitchRV $ relPitch nDyn
186 reactiveValueWriteOnNotEq strengthRV $ strength nDyn
187
188 reactiveValueOnCanRead statMCBMVar $ postGUIAsync $ do
189 nStat <- reactiveValueRead statMCBMVar
190 reactiveValueWriteOnNotEq bpbRV $ beatsPerBar nStat
191
192 reactiveValueOnCanRead synthMCBMVar $ do
193 nSynth <- reactiveValueRead synthMCBMVar
194 reactiveValueWriteOnNotEq layVolumeRV $ volume nSynth
195 reactiveValueWriteOnNotEq instrumentComboRV $ instrument nSynth
196
197 syncRightOnLeftWithBoth (\nt ol -> ol { layerBeat = nt })
198 layBeatRV dynMCBMVar
199 syncRightOnLeftWithBoth (\np ol -> ol { relPitch = np })
200 layPitchRV dynMCBMVar
201 syncRightOnLeftWithBoth (\ns ol -> ol { strength = ns })
202 strengthRV dynMCBMVar
203 syncRightOnLeftWithBoth (\nb ol -> ol { beatsPerBar = nb})
204 bpbRV statMCBMVar
205 syncRightOnLeftWithBoth (\nv ol -> ol { volume = nv })
206 layVolumeRV synthMCBMVar
207 syncRightOnLeftWithBoth (\ni ol -> ol { instrument = ni })
208 instrumentComboRV synthMCBMVar
209
210 return (layerSettingsVBox, statMCBMVar, dynMCBMVar, synthMCBMVar)