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