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 import           Debug.Trace
  21
  22 floatConv :: (ReactiveValueReadWrite a b m,
  23               Real c, Real b, Fractional c, Fractional b) =>
  24              a -> ReactiveFieldReadWrite m c
  25 floatConv = liftRW $ bijection (realToFrac, realToFrac)
  26
  27 mkVScale :: String -> Adjustment -> IO (HBox,VScale)
  28 mkVScale s adj = do
  29   hBox <- hBoxNew False 10
  30   boxLabel <- labelNew (Just s)
  31   labelSetAngle boxLabel 90
  32   boxPackStart hBox boxLabel PackNatural 0
  33   boxScale <- vScaleNew adj
  34   boxPackStart hBox boxScale PackNatural 0
  35   return (hBox,boxScale)
  36
  37 layerSettings :: (ReactiveValueReadWrite board (M.IntMap ([(LTempo,Note)],[Message])) IO) =>
  38                  board
  39               -> IO ( VBox
  40                     , MCBMVar Layer
  41                     , MCBMVar Int
  42                     )
  43 layerSettings boardQueue = do
  44   ------------------------------------------------------------------------------
  45   -- GUI Boxes
  46   ------------------------------------------------------------------------------
  47   layerSettingsVBox <- vBoxNew False 10
  48   layerSettingsBox <- hBoxNew True 10
  49   boxPackStart layerSettingsVBox layerSettingsBox PackNatural 0
  50
  51   layVolumeAdj <- adjustmentNew 100 0 100 1 1 1
  52   (layVolumeBox,layVolumeScale) <- mkVScale "Volume" layVolumeAdj
  53   boxPackStart layerSettingsBox layVolumeBox PackNatural 0
  54   scaleSetDigits layVolumeScale 0
  55
  56   layTempoAdj <- adjustmentNew 1 0 2 0.1 0.1 1
  57   (layTempoBox, layTempoScale) <- mkVScale "Layer tempo" layTempoAdj
  58   boxPackStart layerSettingsBox layTempoBox PackNatural 0
  59
  60   strAdj <- adjustmentNew 0.8 0 2 0.1 0.1 0
  61   (strBox, layStrengthScale) <- mkVScale "Strength" strAdj
  62   boxPackStart layerSettingsBox strBox PackNatural 0
  63
  64   bpbBox <- vBoxNew False 10
  65   boxPackStart layerSettingsBox bpbBox PackNatural 0
  66   bpbLabel <- labelNew (Just "Beat per bar")
  67   labelSetLineWrap bpbLabel True
  68   boxPackStart bpbBox bpbLabel PackNatural 0
  69   bpbAdj <- adjustmentNew 4 1 16 1 1 0
  70   bpbButton <- spinButtonNew bpbAdj 1 0
  71   boxPackStart bpbBox bpbButton PackNatural 0
  72
  73   instrumentCombo <- comboBoxNewText
  74   instrumentIndex <- mapM (\(ind,ins) ->
  75                              do i <- comboBoxAppendText instrumentCombo $
  76                                      fromString ins
  77                                 return (i, ind)) instrumentList
  78   comboBoxSetActive instrumentCombo 0
  79   boxPackStart layerSettingsVBox instrumentCombo PackNatural 10
  80
  81   ------------------------------------------------------------------------------
  82   -- RVs
  83   ------------------------------------------------------------------------------
  84   let indexToInstr i = fromMaybe (error "Can't get the selected instrument.") $
  85                        lookup i instrumentIndex
  86       instrToIndex ins =
  87         fromMaybe (error "Can't retrieve the index for the instrument.") $
  88         lookup ins $ map swap instrumentIndex
  89       instrumentComboRV = bijection (indexToInstr, instrToIndex) `liftRW`
  90                           comboBoxIndexRV instrumentCombo
  91
  92   instrMCBMVar <- newMCBMVar =<< reactiveValueRead instrumentComboRV
  93   layPitchRV <- newCBMVarRW 1
  94
  95   let layTempoRV = floatConv $ scaleValueReactive layTempoScale
  96       strengthRV = floatConv $ scaleValueReactive layStrengthScale
  97       bpbRV = spinButtonValueIntReactive bpbButton
  98       layVolumeRV = liftRW (bijection (floor, fromIntegral)) $
  99                     scaleValueReactive layVolumeScale
 100       f2 d p s bpb v  = Layer { relTempo = d
 101                               , relPitch = p
 102                               , strength = s
 103                               , beatsPerBar = bpb
 104                               , volume = v
 105                               }
 106
 107   layerMCBMVar <- newMCBMVar =<< reactiveValueRead
 108     (liftR5 f2 layTempoRV layPitchRV strengthRV bpbRV layVolumeRV)
 109
 110   reactiveValueOnCanRead layerMCBMVar $ postGUIAsync $ do
 111     nLayer <- reactiveValueRead layerMCBMVar
 112     reactiveValueWriteOnNotEq layTempoRV $ relTempo nLayer
 113     reactiveValueWriteOnNotEq layPitchRV $ relPitch nLayer
 114     reactiveValueWriteOnNotEq strengthRV $ strength nLayer
 115     reactiveValueWriteOnNotEq bpbRV $ beatsPerBar nLayer
 116     reactiveValueWriteOnNotEq layVolumeRV $ volume nLayer
 117
 118   syncRightOnLeftWithBoth (\nt ol -> ol { relTempo = nt })
 119     layTempoRV layerMCBMVar
 120   syncRightOnLeftWithBoth (\np ol -> ol { relPitch = np })
 121     layPitchRV layerMCBMVar
 122   syncRightOnLeftWithBoth (\ns ol -> ol { strength = ns })
 123     strengthRV layerMCBMVar
 124   syncRightOnLeftWithBoth (\nb ol -> ol { beatsPerBar = nb})
 125     bpbRV layerMCBMVar
 126   syncRightOnLeftWithBoth (\nv ol -> ol { volume = nv })
 127     layVolumeRV layerMCBMVar
 128
 129 {-
 130   reactiveValueOnCanRead layVolumeRV $ do
 131     vol <- reactiveValueRead layVolumeRV
 132     chan <- reactiveValueRead chanRV
 133     let vol' = floor ((fromIntegral vol / 100) * 127)
 134     reactiveValueAppend boardQueue ([],[Volume (mkChannel chan) vol'])
 135 -}
 136   return (layerSettingsVBox, layerMCBMVar, instrMCBMVar)