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)