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.Layer
  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 :: (ReactiveValueReadWrite board
  36                   (M.IntMap ([Note],[Message])) IO) =>
  37                  board
  38               -> IO ( VBox
  39                     , MCBMVar Layer
  40                     , MCBMVar Int
  41                     )
  42 layerSettings boardQueue = do
  43   ------------------------------------------------------------------------------
  44   -- GUI Boxes
  45   ------------------------------------------------------------------------------
  46   layerSettingsVBox <- vBoxNew True 10
  47   layerSettingsBox <- hBoxNew True 10
  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 PackNatural 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 PackNatural 0
  83   (Requisition layVolW layVolH) <- widgetSizeRequest layVolumeScale
  84   widgetSetSizeRequest layerSettingsBox layVolW (max layVolH 100)
  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 PackNatural 0
  94
  95   bpbBox <- vBoxNew False 0
  96   boxPackStart layerSettingsBox bpbBox PackNatural 0
  97   bpbLabel <- labelNew (Just "Beat 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   instrumentCombo <- comboBoxNewText
 109   instrumentIndex <- mapM (\(ind,ins) ->
 110                              do i <- comboBoxAppendText instrumentCombo $
 111                                      fromString ins
 112                                 return (i, ind)) instrumentList
 113   comboBoxSetActive instrumentCombo 0
 114   boxPackStart layerSettingsVBox instrumentCombo PackNatural 10
 115   ------------------------------------------------------------------------------
 116   -- RVs
 117   ------------------------------------------------------------------------------
 118   let indexToInstr i = fromMaybe (error "Can't get the selected instrument.") $
 119                        lookup i instrumentIndex
 120       instrToIndex ins =
 121         fromMaybe (error "Can't retrieve the index for the instrument.") $
 122         lookup ins $ map swap instrumentIndex
 123       instrumentComboRV = bijection (indexToInstr, instrToIndex) `liftRW`
 124                           comboBoxIndexRV instrumentCombo
 125
 126   instrMCBMVar <- newMCBMVar =<< reactiveValueRead instrumentComboRV
 127   layPitchRV <- newCBMVarRW 1
 128
 129   let strengthRV = floatConv $ scaleValueReactive layStrengthScale
 130       bpbRV = spinButtonValueIntReactive bpbButton
 131       layVolumeRV = liftRW (bijection (floor, fromIntegral)) $
 132                     scaleValueReactive layVolumeScale
 133       f2 d p s bpb v  = Layer { layerBeat = d
 134                               , relPitch = p
 135                               , strength = s
 136                               , beatsPerBar = bpb
 137                               , volume = v
 138                               }
 139
 140   layerMCBMVar <- newMCBMVar =<< reactiveValueRead
 141     (liftR5 f2 layBeatRV layPitchRV strengthRV bpbRV layVolumeRV)
 142
 143   reactiveValueOnCanRead layerMCBMVar $ postGUIAsync $ do
 144     nLayer <- reactiveValueRead layerMCBMVar
 145     reactiveValueWriteOnNotEq layBeatRV $ layerBeat nLayer
 146     reactiveValueWriteOnNotEq layPitchRV $ relPitch nLayer
 147     reactiveValueWriteOnNotEq strengthRV $ strength nLayer
 148     reactiveValueWriteOnNotEq bpbRV $ beatsPerBar nLayer
 149     reactiveValueWriteOnNotEq layVolumeRV $ volume nLayer
 150
 151   syncRightOnLeftWithBoth (\nt ol -> ol { layerBeat = nt })
 152     layBeatRV layerMCBMVar
 153   syncRightOnLeftWithBoth (\np ol -> ol { relPitch = np })
 154     layPitchRV layerMCBMVar
 155   syncRightOnLeftWithBoth (\ns ol -> ol { strength = ns })
 156     strengthRV layerMCBMVar
 157   syncRightOnLeftWithBoth (\nb ol -> ol { beatsPerBar = nb})
 158     bpbRV layerMCBMVar
 159   syncRightOnLeftWithBoth (\nv ol -> ol { volume = nv })
 160     layVolumeRV layerMCBMVar
 161
 162 {-
 163   reactiveValueOnCanRead layVolumeRV $ do
 164     vol <- reactiveValueRead layVolumeRV
 165     chan <- reactiveValueRead chanRV
 166     let vol' = floor ((fromIntegral vol / 100) * 127)
 167     reactiveValueAppend boardQueue ([],[Volume (mkChannel chan) vol'])
 168 -}
 169   return (layerSettingsVBox, layerMCBMVar, instrMCBMVar)