src/RMCA/GUI/LayerSettings.hs

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