]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/GUI/LayerSettings.hs
Add flake.nix
[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)) $
51 filter (\(_,dur) -> dur /= 0) noteList'
52 comboBoxSetActive layBeatCombo 0
53 let indexToDur i =
54 fromMaybe (error "In indexToDur: failed \
55 \to find the correct \
56 \ duration for the \
57 \selected index.") $ lookup i $ map swap layBeatIndex
58 durToIndex d =
59 fromMaybe (error "In durToIndex: \
60 \failed to find \
61 \the correct index \
62 \for the duration.") $ lookup d layBeatIndex
63 layBeatRV = bijection (indexToDur, durToIndex) `liftRW`
64 comboBoxIndexRV layBeatCombo
65 layBeatLabel <- labelNew (Just "Layer beat"){-=<<
66 (`lookup` symbolString) <$> reactiveValueRead layBeatRV-}
67 --labelSetAngle layBeatLabel 90
68 labelSetLineWrap layBeatLabel True
69 --let layBeatLabelRV = labelTextReactive layBeatLabel
70 boxPackStart layerSettingsBox layBeatBox PackRepel 0
71 auxLayBeatBox <- vBoxNew False 0
72 boxPackEnd layBeatBox auxLayBeatBox PackRepel 0
73 boxPackStart auxLayBeatBox layBeatLabel PackRepel 0
74 boxPackStart auxLayBeatBox layBeatCombo PackNatural 0
75
76 layVolumeAdj <- adjustmentNew 100 0 100 1 1 1
77 (layVolumeBox,layVolumeScale) <- mkVScale "Volume" layVolumeAdj
78 boxPackStart layerSettingsBox layVolumeBox PackRepel 0
79 (Requisition layVolW layVolH) <- widgetSizeRequest layVolumeScale
80 widgetSetSizeRequest layerSettingsBox layVolW (max layVolH 75)
81 scaleSetDigits layVolumeScale 0
82 {-
83 layTempoAdj <- adjustmentNew 1 0 2 0.1 0.1 1
84 (layTempoBox, layTempoScale) <- mkVScale "Layer tempo" layTempoAdj
85 boxPackStart layerSettingsBox layTempoBox PackNatural 0
86 -}
87 strAdj <- adjustmentNew 0.8 0 2 0.1 0.1 0
88 (strBox, layStrengthScale) <- mkVScale "Strength" strAdj
89 boxPackStart layerSettingsBox strBox PackRepel 0
90
91 layerSettingsBox' <- hBoxNew False 10
92 boxPackStart layerSettingsVBox layerSettingsBox' PackNatural 0
93 centerSettings' <- alignmentNew 0 0.5 0 0
94 containerAdd layerSettingsBox' centerSettings'
95
96 bpbBox <- vBoxNew False 0
97 boxPackStart layerSettingsBox' bpbBox PackRepel 0
98 bpbLabel <- labelNew (Just "Beats per bar")
99 labelSetLineWrap bpbLabel True
100 bpbAdj <- adjustmentNew 4 1 16 1 1 0
101 bpbButton <- spinButtonNew bpbAdj 1 0
102 auxBpbBox <- vBoxNew False 0
103 centerAl <- alignmentNew 0.5 0.5 0 0
104 containerAdd auxBpbBox centerAl
105 boxPackStart bpbBox auxBpbBox PackRepel 0
106 boxPackStart auxBpbBox bpbLabel PackGrow 0
107 boxPackStart auxBpbBox bpbButton PackGrow 0
108
109 repeatBox <- vBoxNew False 0
110 boxPackStart layerSettingsBox' repeatBox PackRepel 0
111 repeatLabel <- labelNew (Just "Repeat count")
112 labelSetLineWrap repeatLabel True
113 repeatAdj <- adjustmentNew 1 1 100 1 1 0
114 repeatButton <- spinButtonNew repeatAdj 1 0
115 auxRepeatBox <- vBoxNew False 0
116 centerAl' <- alignmentNew 0.5 0.5 0 0
117 containerAdd auxRepeatBox centerAl'
118 boxPackStart repeatBox auxRepeatBox PackRepel 0
119 boxPackStart auxRepeatBox repeatLabel PackGrow 0
120 boxPackStart auxRepeatBox repeatButton PackGrow 0
121 repeatCheckButton <- checkButtonNewWithLabel "Enable repeat count"
122 boxPackStart auxRepeatBox repeatCheckButton PackGrow 0
123 keepCheckButton <- checkButtonNewWithLabel "Keep heads on restart"
124 boxPackStart auxRepeatBox keepCheckButton PackGrow 0
125
126 instrumentCombo <- comboBoxNewText
127 instrumentIndex <- mapM (\(ind,ins) ->
128 do i <- comboBoxAppendText instrumentCombo $
129 fromString ins
130 return (i, ind)) instrumentList
131 comboBoxSetActive instrumentCombo 0
132 boxPackStart layerSettingsVBox instrumentCombo PackNatural 0
133 -------------------------------------------------------------------------
134 -- RVs
135 -------------------------------------------------------------------------
136 let indexToInstr i = fromMaybe (error "Can't get the selected instrument.") $
137 lookup i instrumentIndex
138 instrToIndex ins =
139 fromMaybe (error "Can't retrieve the index for the instrument.") $
140 lookup ins $ map swap instrumentIndex
141 instrumentComboRV = bijection (indexToInstr, instrToIndex) `liftRW`
142 comboBoxIndexRV instrumentCombo
143 layVolumeRV = liftRW (bijection (round, fromIntegral)) $
144 scaleValueReactive layVolumeScale
145 keepCheckRV = toggleButtonActiveReactive keepCheckButton
146
147 synthMCBMVar <- newMCBMVar
148 =<< reactiveValueRead (liftR2 SynthConf layVolumeRV instrumentComboRV)
149
150 layPitchRV <- newCBMVarRW 1
151 let strengthRV = floatConv $ scaleValueReactive layStrengthScale
152
153 dynMCBMVar <- newMCBMVar
154 =<< reactiveValueRead
155 (liftR4 DynLayerConf layBeatRV layPitchRV strengthRV keepCheckRV)
156
157 let bpbRV = spinButtonValueIntReactive bpbButton
158 repeatCheckRV = toggleButtonActiveReactive repeatCheckButton
159 repeatRV' = spinButtonValueIntReactive repeatButton
160 repeatRV = let f (act,r) = if act then Just r else Nothing
161 g r = case r of
162 Nothing -> (False,0)
163 Just n -> (True,n)
164 in liftRW2 (bijection (g,f)) repeatCheckRV repeatRV'
165 repeatSensitive = widgetSensitiveReactive repeatButton
166 repeatCheckSensitive = widgetSensitiveReactive repeatCheckButton
167 bpbSensitiveRV = widgetSensitiveReactive bpbButton
168
169 reactiveValueOnCanRead isStartedRV $
170 reactiveValueRead isStartedRV >>=
171 \case
172 Running -> do reactiveValueRead repeatCheckRV
173 reactiveValueWrite repeatSensitive False
174 reactiveValueWrite bpbSensitiveRV False
175 reactiveValueWrite repeatCheckSensitive False
176 Stopped -> do reactiveValueRead repeatCheckRV >>=
177 reactiveValueWrite repeatSensitive
178 reactiveValueWrite bpbSensitiveRV True
179 reactiveValueWrite repeatCheckSensitive True
180
181 repeatCheckRV =:> repeatSensitive
182 --repeatCheckRV =:> keepCheckSensitive
183 reactiveValueWrite repeatCheckRV False
184 reactiveValueWrite repeatSensitive False
185
186 statMCBMVar <- newMCBMVar
187 =<< reactiveValueRead (liftR2 StaticLayerConf bpbRV repeatRV)
188
189 reactiveValueOnCanRead dynMCBMVar $ postGUIAsync $ do
190 nDyn <- reactiveValueRead dynMCBMVar
191 reactiveValueWriteOnNotEq layBeatRV $ layerBeat nDyn
192 reactiveValueWriteOnNotEq layPitchRV $ relPitch nDyn
193 reactiveValueWriteOnNotEq strengthRV $ strength nDyn
194 reactiveValueWriteOnNotEq keepCheckRV $ keepHeads nDyn
195
196 reactiveValueOnCanRead statMCBMVar $ postGUIAsync $ do
197 nStat <- reactiveValueRead statMCBMVar
198 reactiveValueWriteOnNotEq bpbRV $ beatsPerBar nStat
199 reactiveValueWriteOnNotEq repeatRV $ repeatCount nStat
200
201 reactiveValueOnCanRead synthMCBMVar $ do
202 nSynth <- reactiveValueRead synthMCBMVar
203 reactiveValueWriteOnNotEq layVolumeRV $ volume nSynth
204 reactiveValueWriteOnNotEq instrumentComboRV $ instrument nSynth
205
206 syncRightOnLeftWithBoth (\nt ol -> ol { layerBeat = nt })
207 layBeatRV dynMCBMVar
208 syncRightOnLeftWithBoth (\np ol -> ol { relPitch = np })
209 layPitchRV dynMCBMVar
210 syncRightOnLeftWithBoth (\ns ol -> ol { strength = ns })
211 strengthRV dynMCBMVar
212 syncRightOnLeftWithBoth (\nk ol -> ol { keepHeads = nk })
213 keepCheckRV dynMCBMVar
214 syncRightOnLeftWithBoth (\nb ol -> ol { beatsPerBar = nb })
215 bpbRV statMCBMVar
216 syncRightOnLeftWithBoth (\nr ol -> ol { repeatCount = nr })
217 repeatRV statMCBMVar
218 syncRightOnLeftWithBoth (\nv ol -> ol { volume = nv })
219 layVolumeRV synthMCBMVar
220 syncRightOnLeftWithBoth (\ni ol -> ol { instrument = ni })
221 instrumentComboRV synthMCBMVar
222
223 return (layerSettingsVBox, statMCBMVar, dynMCBMVar, synthMCBMVar)