]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/GUI/LayerSettings.hs
Hlint suggestions.
[tmp/julm/arpeggigon.git] / 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
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)