src/RMCA/GUI/LayerSettings.hs

   1 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TupleSections #-}
   2
   3 module RMCA.GUI.LayerSettings where
   4
   5 import qualified Data.IntMap                 as M
   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.LayerConf
  15 import           RMCA.MCBMVar
  16 import           RMCA.Semantics
  17 import           RMCA.Translator.Instruments
  18 import           RMCA.Translator.Message
  19
  20 floatConv :: (ReactiveValueReadWrite a b m,
  21               Real c, Real b, Fractional c, Fractional b) =>
  22              a -> ReactiveFieldReadWrite m c
  23 floatConv = liftRW $ bijection (realToFrac, realToFrac)
  24
  25 mkVScale :: String -> Adjustment -> IO (HBox,VScale)
  26 mkVScale s adj = do
  27   hBox <- hBoxNew False 10
  28   boxLabel <- labelNew (Just s)
  29   labelSetAngle boxLabel 90
  30   boxPackStart hBox boxLabel PackNatural 0
  31   boxScale <- vScaleNew adj
  32   boxPackStart hBox boxScale PackNatural 0
  33   return (hBox,boxScale)
  34
  35 layerSettings :: IO ( VBox
  36                     , MCBMVar StaticLayerConf
  37                     , MCBMVar DynLayerConf
  38                     , MCBMVar SynthConf
  39                     )
  40 layerSettings = do
  41   ------------------------------------------------------------------------------
  42   -- GUI Boxes
  43   ------------------------------------------------------------------------------
  44   layerSettingsVBox <- vBoxNew True 10
  45   layerSettingsBox <- hBoxNew False 0
  46   centerSettings <- alignmentNew 0.5 0.5 0 0
  47   containerAdd layerSettingsBox centerSettings
  48   boxPackStart layerSettingsVBox layerSettingsBox PackNatural 0
  49
  50
  51   layBeatBox <- hBoxNew False 10
  52   layBeatCombo <- comboBoxNewText
  53   layBeatIndex <- mapM (\(str,dur) -> do i <- comboBoxAppendText layBeatCombo
  54                                               (fromString str)
  55                                          return (dur,i)) noteList'
  56   comboBoxSetActive layBeatCombo 0
  57   let indexToDur i =
  58         fromMaybe (error "In indexToDur: failed \
  59                          \to find the correct \
  60                          \ duration for the \
  61                          \selected index.") $ lookup i $ map swap layBeatIndex
  62       durToIndex d =
  63         fromMaybe (error "In durToIndex: \
  64                          \failed to find \
  65                          \the correct index \
  66                          \for the duration.") $ lookup d layBeatIndex
  67       layBeatRV = bijection (indexToDur, durToIndex) `liftRW`
  68                   comboBoxIndexRV layBeatCombo
  69   layBeatLabel <- labelNew (Just "Layer beat"){-=<<
  70                   (`lookup` symbolString) <$> reactiveValueRead layBeatRV-}
  71   --labelSetAngle layBeatLabel 90
  72   labelSetLineWrap layBeatLabel True
  73   let layBeatLabelRV = labelTextReactive layBeatLabel
  74   boxPackStart layerSettingsBox layBeatBox PackRepel 0
  75   auxLayBeatBox <- vBoxNew False 0
  76   boxPackEnd layBeatBox auxLayBeatBox PackRepel 0
  77   boxPackStart auxLayBeatBox layBeatLabel PackRepel 0
  78   boxPackStart auxLayBeatBox layBeatCombo PackNatural 0
  79
  80   layVolumeAdj <- adjustmentNew 100 0 100 1 1 1
  81   (layVolumeBox,layVolumeScale) <- mkVScale "Volume" layVolumeAdj
  82   boxPackStart layerSettingsBox layVolumeBox PackRepel 0
  83   (Requisition layVolW layVolH) <- widgetSizeRequest layVolumeScale
  84   widgetSetSizeRequest layerSettingsBox layVolW (max layVolH 75)
  85   scaleSetDigits layVolumeScale 0
  86   {-
  87   layTempoAdj <- adjustmentNew 1 0 2 0.1 0.1 1
  88   (layTempoBox, layTempoScale) <- mkVScale "Layer tempo" layTempoAdj
  89   boxPackStart layerSettingsBox layTempoBox PackNatural 0
  90 -}
  91   strAdj <- adjustmentNew 0.8 0 2 0.1 0.1 0
  92   (strBox, layStrengthScale) <- mkVScale "Strength" strAdj
  93   boxPackStart layerSettingsBox strBox PackRepel 0
  94
  95   layerSettingsBox' <- hBoxNew False 10
  96   boxPackStart layerSettingsVBox layerSettingsBox' PackNatural 0
  97   centerSettings' <- alignmentNew 0 0.5 0 0
  98   containerAdd layerSettingsBox' centerSettings'
  99
 100   bpbBox <- vBoxNew False 0
 101   boxPackStart layerSettingsBox' bpbBox PackRepel 0
 102   bpbLabel <- labelNew (Just "Beat per bar")
 103   labelSetLineWrap bpbLabel True
 104   bpbAdj <- adjustmentNew 4 1 16 1 1 0
 105   bpbButton <- spinButtonNew bpbAdj 1 0
 106   auxBpbBox <- vBoxNew False 0
 107   centerAl <- alignmentNew 0.5 0.5 0 0
 108   containerAdd auxBpbBox centerAl
 109   boxPackStart bpbBox auxBpbBox PackRepel 0
 110   boxPackStart auxBpbBox bpbLabel PackGrow 0
 111   boxPackStart auxBpbBox bpbButton PackGrow 0
 112
 113   repeatBox <- vBoxNew False 0
 114   boxPackStart layerSettingsBox' repeatBox PackRepel 0
 115   repeatLabel <- labelNew (Just "Repeat count")
 116   labelSetLineWrap repeatLabel True
 117   repeatAdj <- adjustmentNew 0 0 100 1 1 0
 118   repeatButton <- spinButtonNew repeatAdj 1 0
 119   auxRepeatBox <- vBoxNew False 0
 120   centerAl' <- alignmentNew 0.5 0.5 0 0
 121   containerAdd auxRepeatBox centerAl'
 122   boxPackStart repeatBox auxRepeatBox PackRepel 0
 123   boxPackStart auxRepeatBox repeatLabel PackGrow 0
 124   boxPackStart auxRepeatBox repeatButton PackGrow 0
 125   repeatCheckButton <- checkButtonNewWithLabel "Unable repeat count"
 126   boxPackStart auxRepeatBox repeatCheckButton PackGrow 0
 127
 128   instrumentCombo <- comboBoxNewText
 129   instrumentIndex <- mapM (\(ind,ins) ->
 130                              do i <- comboBoxAppendText instrumentCombo $
 131                                      fromString ins
 132                                 return (i, ind)) instrumentList
 133   comboBoxSetActive instrumentCombo 0
 134   boxPackStart layerSettingsVBox instrumentCombo PackNatural 10
 135   ------------------------------------------------------------------------------
 136   -- RVs
 137   ------------------------------------------------------------------------------
 138   let indexToInstr i = fromMaybe (error "Can't get the selected instrument.") $
 139                        lookup i instrumentIndex
 140       instrToIndex ins =
 141         fromMaybe (error "Can't retrieve the index for the instrument.") $
 142         lookup ins $ map swap instrumentIndex
 143       instrumentComboRV = bijection (indexToInstr, instrToIndex) `liftRW`
 144                           comboBoxIndexRV instrumentCombo
 145       layVolumeRV = liftRW (bijection (floor, fromIntegral)) $
 146                     scaleValueReactive layVolumeScale
 147
 148   synthMCBMVar <- newMCBMVar
 149     =<< reactiveValueRead (liftR2 SynthConf layVolumeRV instrumentComboRV)
 150
 151   layPitchRV <- newCBMVarRW 1
 152   let strengthRV = floatConv $ scaleValueReactive layStrengthScale
 153
 154   dynMCBMVar <- newMCBMVar
 155     =<< reactiveValueRead (liftR3 DynLayerConf layBeatRV layPitchRV strengthRV)
 156
 157   let bpbRV = spinButtonValueIntReactive bpbButton
 158       repeatCheckRV = toggleButtonActiveReactive repeatCheckButton
 159       repeatRV' = spinButtonValueIntReactive repeatButton
 160       repeatRV = liftR2 (\act r -> if act then Just r else Nothing)
 161                  repeatCheckRV repeatRV'
 162   reactiveValueWrite repeatCheckRV False
 163   --reactiveValueOnCanRead repeatCheckRV $ do
 164
 165   statMCBMVar <- newMCBMVar
 166     =<< reactiveValueRead (liftR2 StaticLayerConf bpbRV repeatRV)
 167
 168   reactiveValueOnCanRead dynMCBMVar $ postGUIAsync $ do
 169     nDyn <- reactiveValueRead dynMCBMVar
 170     reactiveValueWriteOnNotEq layBeatRV $ layerBeat nDyn
 171     reactiveValueWriteOnNotEq layPitchRV $ relPitch nDyn
 172     reactiveValueWriteOnNotEq strengthRV $ strength nDyn
 173
 174   reactiveValueOnCanRead statMCBMVar $ postGUIAsync $ do
 175     nStat <- reactiveValueRead statMCBMVar
 176     reactiveValueWriteOnNotEq bpbRV $ beatsPerBar nStat
 177
 178   reactiveValueOnCanRead synthMCBMVar $ do
 179     nSynth <- reactiveValueRead synthMCBMVar
 180     reactiveValueWriteOnNotEq layVolumeRV $ volume nSynth
 181     reactiveValueWriteOnNotEq instrumentComboRV $ instrument nSynth
 182
 183   syncRightOnLeftWithBoth (\nt ol -> ol { layerBeat = nt })
 184     layBeatRV dynMCBMVar
 185   syncRightOnLeftWithBoth (\np ol -> ol { relPitch = np })
 186     layPitchRV dynMCBMVar
 187   syncRightOnLeftWithBoth (\ns ol -> ol { strength = ns })
 188     strengthRV dynMCBMVar
 189   syncRightOnLeftWithBoth (\nb ol -> ol { beatsPerBar = nb})
 190     bpbRV statMCBMVar
 191   syncRightOnLeftWithBoth (\nv ol -> ol { volume = nv })
 192     layVolumeRV synthMCBMVar
 193   syncRightOnLeftWithBoth (\ni ol -> ol { instrument = ni })
 194     instrumentComboRV synthMCBMVar
 195
 196 {-
 197   reactiveValueOnCanRead layVolumeRV $ do
 198     vol <- reactiveValueRead layVolumeRV
 199     chan <- reactiveValueRead chanRV
 200     let vol' = floor ((fromIntegral vol / 100) * 127)
 201     reactiveValueAppend boardQueue ([],[Volume (mkChannel chan) vol'])
 202 -}
 203   return (layerSettingsVBox, statMCBMVar, dynMCBMVar, synthMCBMVar)