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