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   {-
  89   ins <- reactiveValueRead instrumentComboRV
  90   chan <- reactiveValueRead chanRV
  91   reactiveValueAppend boardQueue ([],[Instrument (mkChannel chan)
  92 (mkProgram ins)])
  93
  94   reactiveValueOnCanRead instrumentComboRV changeInst
  95 -}
  96   layPitchRV <- newCBMVarRW 1
  97   let layTempoRV = floatConv $ scaleValueReactive layTempoScale
  98       strengthRV = floatConv $  scaleValueReactive layStrengthScale
  99       bpbRV = spinButtonValueIntReactive bpbButton
 100       layVolumeRV = liftRW (bijection (floor, fromIntegral)) $
 101                     scaleValueReactive layVolumeScale
 102       f1 Layer { relTempo = d
 103                , relPitch = p
 104                , strength = s
 105                , beatsPerBar = bpb
 106                , volume = v
 107                } = (d,p,s,bpb,v)
 108       f2 (d,p,s,bpb,v)  = Layer { relTempo = d
 109                                 , relPitch = p
 110                                 , strength = s
 111                                 , beatsPerBar = bpb
 112                                 , volume = v
 113                                 }
 114       layerRV = liftRW5 (bijection (f1,f2))
 115                 layTempoRV layPitchRV strengthRV bpbRV layVolumeRV
 116
 117
 118   layerMMVar <- newMCBMVar =<< reactiveValueRead layerRV
 119   reactiveValueOnCanRead layerRV $
 120     reactiveValueRead layerRV >>= writeMCBMVar layerMMVar
 121   installCallbackMCBMVar layerMMVar $
 122     readMCBMVar layerMMVar >>= reactiveValueWrite layerRV
 123
 124   instrMMVar <- newMCBMVar =<< reactiveValueRead instrumentComboRV
 125   reactiveValueOnCanRead instrumentComboRV $
 126     reactiveValueRead instrumentComboRV >>= writeMCBMVar instrMMVar
 127   installCallbackMCBMVar instrMMVar $
 128     readMCBMVar instrMMVar >>= reactiveValueWrite instrumentComboRV
 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, layerMMVar, instrMMVar)