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 True 10
  46   boxPackStart layerSettingsVBox layerSettingsBox PackNatural 0
  47
  48
  49   layBeatBox <- hBoxNew False 10
  50   layBeatCombo <- comboBoxNewText
  51   layBeatIndex <- mapM (\(str,dur) -> do i <- comboBoxAppendText layBeatCombo
  52                                               (fromString str)
  53                                          return (dur,i)) noteList'
  54   comboBoxSetActive layBeatCombo 0
  55   let indexToDur i =
  56         fromMaybe (error "In indexToDur: failed \
  57                          \to find the correct \
  58                          \ duration for the \
  59                          \selected index.") $ lookup i $ map swap layBeatIndex
  60       durToIndex d =
  61         fromMaybe (error "In durToIndex: \
  62                          \failed to find \
  63                          \the correct index \
  64                          \for the duration.") $ lookup d layBeatIndex
  65       layBeatRV = bijection (indexToDur, durToIndex) `liftRW`
  66                   comboBoxIndexRV layBeatCombo
  67   layBeatLabel <- labelNew (Just "Layer beat"){-=<<
  68                   (`lookup` symbolString) <$> reactiveValueRead layBeatRV-}
  69   --labelSetAngle layBeatLabel 90
  70   labelSetLineWrap layBeatLabel True
  71   let layBeatLabelRV = labelTextReactive layBeatLabel
  72   boxPackStart layerSettingsBox layBeatBox PackNatural 0
  73   auxLayBeatBox <- vBoxNew False 0
  74   boxPackEnd layBeatBox auxLayBeatBox PackRepel 0
  75   boxPackStart auxLayBeatBox layBeatLabel PackRepel 0
  76   boxPackStart auxLayBeatBox layBeatCombo PackNatural 0
  77
  78   layVolumeAdj <- adjustmentNew 100 0 100 1 1 1
  79   (layVolumeBox,layVolumeScale) <- mkVScale "Volume" layVolumeAdj
  80   boxPackStart layerSettingsBox layVolumeBox PackNatural 0
  81   (Requisition layVolW layVolH) <- widgetSizeRequest layVolumeScale
  82   widgetSetSizeRequest layerSettingsBox layVolW (max layVolH 100)
  83   scaleSetDigits layVolumeScale 0
  84   {-
  85   layTempoAdj <- adjustmentNew 1 0 2 0.1 0.1 1
  86   (layTempoBox, layTempoScale) <- mkVScale "Layer tempo" layTempoAdj
  87   boxPackStart layerSettingsBox layTempoBox PackNatural 0
  88 -}
  89   strAdj <- adjustmentNew 0.8 0 2 0.1 0.1 0
  90   (strBox, layStrengthScale) <- mkVScale "Strength" strAdj
  91   boxPackStart layerSettingsBox strBox PackNatural 0
  92
  93   bpbBox <- vBoxNew False 0
  94   boxPackStart layerSettingsBox bpbBox PackNatural 0
  95   bpbLabel <- labelNew (Just "Beat per bar")
  96   labelSetLineWrap bpbLabel True
  97   bpbAdj <- adjustmentNew 4 1 16 1 1 0
  98   bpbButton <- spinButtonNew bpbAdj 1 0
  99   auxBpbBox <- vBoxNew False 0
 100   centerAl <- alignmentNew 0.5 0.5 0 0
 101   containerAdd auxBpbBox centerAl
 102   boxPackStart bpbBox auxBpbBox PackRepel 0
 103   boxPackStart auxBpbBox bpbLabel PackGrow 0
 104   boxPackStart auxBpbBox bpbButton PackGrow 0
 105
 106   instrumentCombo <- comboBoxNewText
 107   instrumentIndex <- mapM (\(ind,ins) ->
 108                              do i <- comboBoxAppendText instrumentCombo $
 109                                      fromString ins
 110                                 return (i, ind)) instrumentList
 111   comboBoxSetActive instrumentCombo 0
 112   boxPackStart layerSettingsVBox instrumentCombo PackNatural 10
 113   ------------------------------------------------------------------------------
 114   -- RVs
 115   ------------------------------------------------------------------------------
 116   let indexToInstr i = fromMaybe (error "Can't get the selected instrument.") $
 117                        lookup i instrumentIndex
 118       instrToIndex ins =
 119         fromMaybe (error "Can't retrieve the index for the instrument.") $
 120         lookup ins $ map swap instrumentIndex
 121       instrumentComboRV = bijection (indexToInstr, instrToIndex) `liftRW`
 122                           comboBoxIndexRV instrumentCombo
 123       layVolumeRV = liftRW (bijection (floor, fromIntegral)) $
 124                     scaleValueReactive layVolumeScale
 125
 126   synthMCBMVar <- newMCBMVar
 127     =<< reactiveValueRead (liftR2 SynthConf layVolumeRV instrumentComboRV)
 128
 129   layPitchRV <- newCBMVarRW 1
 130   let strengthRV = floatConv $ scaleValueReactive layStrengthScale
 131
 132   dynMCBMVar <- newMCBMVar
 133     =<< reactiveValueRead (liftR3 DynLayerConf layBeatRV layPitchRV strengthRV)
 134
 135   let bpbRV = spinButtonValueIntReactive bpbButton
 136   statMCBMVar <- newMCBMVar
 137     =<< reactiveValueRead (liftR StaticLayerConf bpbRV)
 138
 139   reactiveValueOnCanRead dynMCBMVar $ postGUIAsync $ do
 140     nDyn <- reactiveValueRead dynMCBMVar
 141     reactiveValueWriteOnNotEq layBeatRV $ layerBeat nDyn
 142     reactiveValueWriteOnNotEq layPitchRV $ relPitch nDyn
 143     reactiveValueWriteOnNotEq strengthRV $ strength nDyn
 144
 145   reactiveValueOnCanRead statMCBMVar $ postGUIAsync $ do
 146     nStat <- reactiveValueRead statMCBMVar
 147     reactiveValueWriteOnNotEq bpbRV $ beatsPerBar nStat
 148
 149   reactiveValueOnCanRead synthMCBMVar $ do
 150     nSynth <- reactiveValueRead synthMCBMVar
 151     reactiveValueWriteOnNotEq layVolumeRV $ volume nSynth
 152     reactiveValueWriteOnNotEq instrumentComboRV $ instrument nSynth
 153
 154   syncRightOnLeftWithBoth (\nt ol -> ol { layerBeat = nt })
 155     layBeatRV dynMCBMVar
 156   syncRightOnLeftWithBoth (\np ol -> ol { relPitch = np })
 157     layPitchRV dynMCBMVar
 158   syncRightOnLeftWithBoth (\ns ol -> ol { strength = ns })
 159     strengthRV dynMCBMVar
 160   syncRightOnLeftWithBoth (\nb ol -> ol { beatsPerBar = nb})
 161     bpbRV statMCBMVar
 162   syncRightOnLeftWithBoth (\nv ol -> ol { volume = nv })
 163     layVolumeRV synthMCBMVar
 164   syncRightOnLeftWithBoth (\ni ol -> ol { instrument = ni })
 165     instrumentComboRV synthMCBMVar
 166
 167 {-
 168   reactiveValueOnCanRead layVolumeRV $ do
 169     vol <- reactiveValueRead layVolumeRV
 170     chan <- reactiveValueRead chanRV
 171     let vol' = floor ((fromIntegral vol / 100) * 127)
 172     reactiveValueAppend boardQueue ([],[Volume (mkChannel chan) vol'])
 173 -}
 174   return (layerSettingsVBox, statMCBMVar, dynMCBMVar, synthMCBMVar)