src/RMCA/GUI/LayerSettings.hs

   1 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TupleSections #-}
   2
   3 module RMCA.GUI.LayerSettings where
   4
   5 import Data.ReactiveValue
   6 import Data.String
   7 import Data.Tuple
   8 import Graphics.UI.Gtk
   9 import Graphics.UI.Gtk.Reactive
  10 import RMCA.Auxiliary.RV
  11 import RMCA.GUI.NoteSettings
  12 import RMCA.Layer.Layer
  13 import RMCA.Semantics
  14 import RMCA.Translator.Instruments
  15 import RMCA.Translator.Message
  16
  17 floatConv :: (ReactiveValueReadWrite a b m,
  18               Real c, Real b, Fractional c, Fractional b) =>
  19              a -> ReactiveFieldReadWrite m c
  20 floatConv = liftRW $ bijection (realToFrac, realToFrac)
  21
  22 layerSettings :: ( ReactiveValueReadWrite board ([Note],[Message]) IO
  23                  , ReactiveValueRead chan Int IO) =>
  24                  chan -> board -> IO (VBox, ReactiveFieldReadWrite IO Layer)
  25 layerSettings chanRV boardQueue = do
  26   layerSettingsVBox <- vBoxNew True 10
  27   layerSettingsBox <- hBoxNew True 10
  28   boxPackStart layerSettingsVBox layerSettingsBox PackNatural 0
  29
  30   layTempoBox <- hBoxNew False 10
  31   boxPackStart layerSettingsBox layTempoBox PackNatural 0
  32   layTempoLabel <- labelNew (Just "Layer tempo")
  33   labelSetAngle layTempoLabel 90
  34   boxPackStart layTempoBox layTempoLabel PackNatural 0
  35   layTempoAdj <- adjustmentNew 1 0 2 1 1 1
  36   layTempoScale <- vScaleNew layTempoAdj
  37   boxPackStart layTempoBox layTempoScale PackNatural 0
  38
  39   strBox <- hBoxNew False 10
  40   boxPackStart layerSettingsBox strBox PackNatural 0
  41   strLabel <- labelNew (Just "Strength")
  42   labelSetAngle strLabel 90
  43   boxPackStart strBox strLabel PackNatural 0
  44   strAdj <- adjustmentNew 1 0 1 0.01 0.01 0
  45   layStrengthScale <- vScaleNew strAdj
  46   boxPackStart strBox layStrengthScale PackNatural 0
  47
  48   bpbBox <- vBoxNew False 10
  49   boxPackStart layerSettingsBox bpbBox PackNatural 0
  50   bpbLabel <- labelNew (Just "Beat per bar")
  51   labelSetLineWrap bpbLabel True
  52   boxPackStart bpbBox bpbLabel PackNatural 0
  53   bpbAdj <- adjustmentNew 4 1 16 1 1 0
  54   bpbButton <- spinButtonNew bpbAdj 1 0
  55   boxPackStart bpbBox bpbButton PackNatural 0
  56
  57   instrumentCombo <- comboBoxNewText
  58   instrumentIndex <- mapM (\(ind,ins) ->
  59                              do i <- comboBoxAppendText instrumentCombo $
  60                                      fromString ins
  61                                 return (i, ind)) instrumentList
  62   comboBoxSetActive instrumentCombo 0
  63   boxPackStart layerSettingsVBox instrumentCombo PackNatural 10
  64   let indexToInstr i = case (lookup i instrumentIndex) of
  65         Nothing -> error "Can't get the selected instrument."
  66         Just x -> x
  67       instrToIndex ins = case (lookup ins $ map swap instrumentIndex) of
  68         Nothing -> error "Can't retrieve the index for the instrument."
  69         Just x -> x
  70       instrumentComboRV = bijection (indexToInstr, instrToIndex) `liftRW`
  71                           comboBoxIndexRV instrumentCombo
  72
  73   reactiveValueOnCanRead instrumentComboRV $ do
  74     ins <- reactiveValueRead instrumentComboRV
  75     chan <- reactiveValueRead chanRV
  76     reactiveValueAppend boardQueue ([],[Instrument (mkChannel chan) (mkProgram ins)])
  77
  78   layPitchRV <- newCBMVarRW 1
  79   let layTempoRV = floatConv $ scaleValueReactive layTempoScale
  80       strengthRV = floatConv $  scaleValueReactive layStrengthScale
  81       bpbRV = spinButtonValueIntReactive bpbButton
  82       f1 Layer { relTempo = d
  83                , relPitch = p
  84                , strength = s
  85                , beatsPerBar = bpb
  86                } = (d,p,s,bpb)
  87       f2 (d,p,s,bpb) = Layer { relTempo = d
  88                              , relPitch = p
  89                              , strength = s
  90                              , beatsPerBar = bpb
  91                              }
  92       layerRV =
  93         liftRW4 (bijection (f1,f2)) layTempoRV layPitchRV strengthRV bpbRV
  94   return (layerSettingsVBox, layerRV)