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)