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