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   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 10
 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)