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 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
 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 = let f (act,r) = if act then Just r else Nothing
 156                      g r = case r of
 157                        Nothing -> (False,0)
 158                        Just n  -> (True,n)
 159                  in liftRW2 (bijection (g,f)) repeatCheckRV repeatRV'
 160       repeatSensitive = widgetSensitiveReactive repeatButton
 161       repeatCheckSensitive = widgetSensitiveReactive repeatCheckButton
 162       bpbSensitiveRV = widgetSensitiveReactive bpbButton
 163
 164   reactiveValueOnCanRead isStartedRV $
 165     reactiveValueRead isStartedRV >>=
 166     \case
 167       Running ->  do reactiveValueRead repeatCheckRV
 168                      reactiveValueWrite repeatSensitive False
 169                      reactiveValueWrite bpbSensitiveRV False
 170                      reactiveValueWrite repeatCheckSensitive False
 171       Stopped -> do reactiveValueRead repeatCheckRV >>=
 172                       reactiveValueWrite repeatSensitive
 173                     reactiveValueWrite bpbSensitiveRV True
 174                     reactiveValueWrite repeatCheckSensitive True
 175
 176   repeatCheckRV =:> repeatSensitive
 177   reactiveValueWrite repeatCheckRV False
 178   reactiveValueWrite repeatSensitive False
 179
 180   statMCBMVar <- newMCBMVar
 181     =<< reactiveValueRead (liftR2 StaticLayerConf bpbRV repeatRV)
 182
 183   reactiveValueOnCanRead dynMCBMVar $ postGUIAsync $ do
 184     nDyn <- reactiveValueRead dynMCBMVar
 185     reactiveValueWriteOnNotEq layBeatRV $ layerBeat nDyn
 186     reactiveValueWriteOnNotEq layPitchRV $ relPitch nDyn
 187     reactiveValueWriteOnNotEq strengthRV $ strength nDyn
 188
 189   reactiveValueOnCanRead statMCBMVar $ postGUIAsync $ do
 190     nStat <- reactiveValueRead statMCBMVar
 191     reactiveValueWriteOnNotEq bpbRV $ beatsPerBar nStat
 192     reactiveValueWriteOnNotEq repeatRV $ repeatCount nStat
 193
 194   reactiveValueOnCanRead synthMCBMVar $ do
 195     nSynth <- reactiveValueRead synthMCBMVar
 196     reactiveValueWriteOnNotEq layVolumeRV $ volume nSynth
 197     reactiveValueWriteOnNotEq instrumentComboRV $ instrument nSynth
 198
 199   syncRightOnLeftWithBoth (\nt ol -> ol { layerBeat = nt })
 200     layBeatRV dynMCBMVar
 201   syncRightOnLeftWithBoth (\np ol -> ol { relPitch = np })
 202     layPitchRV dynMCBMVar
 203   syncRightOnLeftWithBoth (\ns ol -> ol { strength = ns })
 204     strengthRV dynMCBMVar
 205   syncRightOnLeftWithBoth (\nb ol -> ol { beatsPerBar = nb })
 206     bpbRV statMCBMVar
 207   syncRightOnLeftWithBoth (\nr ol -> ol { repeatCount = nr })
 208     repeatRV statMCBMVar
 209   syncRightOnLeftWithBoth (\nv ol -> ol { volume = nv })
 210     layVolumeRV synthMCBMVar
 211   syncRightOnLeftWithBoth (\ni ol -> ol { instrument = ni })
 212     instrumentComboRV synthMCBMVar
 213
 214   return (layerSettingsVBox, statMCBMVar, dynMCBMVar, synthMCBMVar)