]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/GUI/LayerSettings.hs
Edit change log.
[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 5
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 1 1 100 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 keepCheckButton <- checkButtonNewWithLabel "Keep heads on restart"
123 boxPackStart auxRepeatBox keepCheckButton PackGrow 0
124
125 instrumentCombo <- comboBoxNewText
126 instrumentIndex <- mapM (\(ind,ins) ->
127 do i <- comboBoxAppendText instrumentCombo $
128 fromString ins
129 return (i, ind)) instrumentList
130 comboBoxSetActive instrumentCombo 0
131 boxPackStart layerSettingsVBox instrumentCombo PackNatural 0
132 -------------------------------------------------------------------------
133 -- RVs
134 -------------------------------------------------------------------------
135 let indexToInstr i = fromMaybe (error "Can't get the selected instrument.") $
136 lookup i instrumentIndex
137 instrToIndex ins =
138 fromMaybe (error "Can't retrieve the index for the instrument.") $
139 lookup ins $ map swap instrumentIndex
140 instrumentComboRV = bijection (indexToInstr, instrToIndex) `liftRW`
141 comboBoxIndexRV instrumentCombo
142 layVolumeRV = liftRW (bijection (round, fromIntegral)) $
143 scaleValueReactive layVolumeScale
144 keepCheckRV = toggleButtonActiveReactive keepCheckButton
145
146 synthMCBMVar <- newMCBMVar
147 =<< reactiveValueRead (liftR2 SynthConf layVolumeRV instrumentComboRV)
148
149 layPitchRV <- newCBMVarRW 1
150 let strengthRV = floatConv $ scaleValueReactive layStrengthScale
151
152 dynMCBMVar <- newMCBMVar
153 =<< reactiveValueRead
154 (liftR4 DynLayerConf layBeatRV layPitchRV strengthRV keepCheckRV)
155
156 let bpbRV = spinButtonValueIntReactive bpbButton
157 repeatCheckRV = toggleButtonActiveReactive repeatCheckButton
158 repeatRV' = spinButtonValueIntReactive repeatButton
159 repeatRV = let f (act,r) = if act then Just r else Nothing
160 g r = case r of
161 Nothing -> (False,0)
162 Just n -> (True,n)
163 in liftRW2 (bijection (g,f)) repeatCheckRV repeatRV'
164 repeatSensitive = widgetSensitiveReactive repeatButton
165 repeatCheckSensitive = widgetSensitiveReactive repeatCheckButton
166 bpbSensitiveRV = widgetSensitiveReactive bpbButton
167
168 reactiveValueOnCanRead isStartedRV $
169 reactiveValueRead isStartedRV >>=
170 \case
171 Running -> do reactiveValueRead repeatCheckRV
172 reactiveValueWrite repeatSensitive False
173 reactiveValueWrite bpbSensitiveRV False
174 reactiveValueWrite repeatCheckSensitive False
175 Stopped -> do reactiveValueRead repeatCheckRV >>=
176 reactiveValueWrite repeatSensitive
177 reactiveValueWrite bpbSensitiveRV True
178 reactiveValueWrite repeatCheckSensitive True
179
180 repeatCheckRV =:> repeatSensitive
181 --repeatCheckRV =:> keepCheckSensitive
182 reactiveValueWrite repeatCheckRV False
183 reactiveValueWrite repeatSensitive False
184
185 statMCBMVar <- newMCBMVar
186 =<< reactiveValueRead (liftR2 StaticLayerConf bpbRV repeatRV)
187
188 reactiveValueOnCanRead dynMCBMVar $ postGUIAsync $ do
189 nDyn <- reactiveValueRead dynMCBMVar
190 reactiveValueWriteOnNotEq layBeatRV $ layerBeat nDyn
191 reactiveValueWriteOnNotEq layPitchRV $ relPitch nDyn
192 reactiveValueWriteOnNotEq strengthRV $ strength nDyn
193 reactiveValueWriteOnNotEq keepCheckRV $ keepHeads nDyn
194
195 reactiveValueOnCanRead statMCBMVar $ postGUIAsync $ do
196 nStat <- reactiveValueRead statMCBMVar
197 reactiveValueWriteOnNotEq bpbRV $ beatsPerBar nStat
198 reactiveValueWriteOnNotEq repeatRV $ repeatCount nStat
199
200 reactiveValueOnCanRead synthMCBMVar $ do
201 nSynth <- reactiveValueRead synthMCBMVar
202 reactiveValueWriteOnNotEq layVolumeRV $ volume nSynth
203 reactiveValueWriteOnNotEq instrumentComboRV $ instrument nSynth
204
205 syncRightOnLeftWithBoth (\nt ol -> ol { layerBeat = nt })
206 layBeatRV dynMCBMVar
207 syncRightOnLeftWithBoth (\np ol -> ol { relPitch = np })
208 layPitchRV dynMCBMVar
209 syncRightOnLeftWithBoth (\ns ol -> ol { strength = ns })
210 strengthRV dynMCBMVar
211 syncRightOnLeftWithBoth (\nk ol -> ol { keepHeads = nk })
212 keepCheckRV dynMCBMVar
213 syncRightOnLeftWithBoth (\nb ol -> ol { beatsPerBar = nb })
214 bpbRV statMCBMVar
215 syncRightOnLeftWithBoth (\nr ol -> ol { repeatCount = nr })
216 repeatRV statMCBMVar
217 syncRightOnLeftWithBoth (\nv ol -> ol { volume = nv })
218 layVolumeRV synthMCBMVar
219 syncRightOnLeftWithBoth (\ni ol -> ol { instrument = ni })
220 instrumentComboRV synthMCBMVar
221
222 return (layerSettingsVBox, statMCBMVar, dynMCBMVar, synthMCBMVar)