]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/GUI/LayerSettings.hs
Multiple layer internals done. Translator not finished.
[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
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 instrMCBMVar <- newMCBMVar =<< reactiveValueRead instrumentComboRV
89 {-
90 ins <- reactiveValueRead instrumentComboRV
91 chan <- reactiveValueRead chanRV
92 reactiveValueAppend boardQueue ([],[Instrument (mkChannel chan)
93 (mkProgram ins)])
94
95 reactiveValueOnCanRead instrumentComboRV changeInst
96 -}
97 layPitchRV <- newCBMVarRW 1
98 let layTempoRV = floatConv $ scaleValueReactive layTempoScale
99 strengthRV = floatConv $ scaleValueReactive layStrengthScale
100 bpbRV = spinButtonValueIntReactive bpbButton
101 layVolumeRV = liftRW (bijection (floor, fromIntegral)) $
102 scaleValueReactive layVolumeScale
103 {-
104 f1 Layer { relTempo = d
105 , relPitch = p
106 , strength = s
107 , beatsPerBar = bpb
108 , volume = v
109 } = (d,p,s,bpb,v)-}
110 f2 d p s bpb v = Layer { relTempo = d
111 , relPitch = p
112 , strength = s
113 , beatsPerBar = bpb
114 , volume = v
115 }
116
117 {-
118 layerRV = liftRW5 (bijection (f1,f2))
119 layTempoRV layPitchRV strengthRV bpbRV layVolumeRV
120 -}
121
122 layerMCBMVar <- newMCBMVar =<< reactiveValueRead (liftR5 f2 layTempoRV layPitchRV strengthRV bpbRV layVolumeRV)
123
124 reactiveValueOnCanRead layerMCBMVar $ do
125 nLayer <- reactiveValueRead layerMCBMVar
126 reactiveValueWriteOnNotEq layTempoRV $ relTempo nLayer
127 reactiveValueWriteOnNotEq layPitchRV $ relPitch nLayer
128 reactiveValueWriteOnNotEq strengthRV $ strength nLayer
129 reactiveValueWriteOnNotEq bpbRV $ beatsPerBar nLayer
130 reactiveValueWriteOnNotEq layVolumeRV $ volume nLayer
131
132 syncRightOnLeftWithBoth (\nt ol -> ol { relTempo = nt }) layTempoRV layerMCBMVar
133 syncRightOnLeftWithBoth (\np ol -> ol { relPitch = np }) layPitchRV layerMCBMVar
134 syncRightOnLeftWithBoth (\ns ol -> ol { strength = ns }) strengthRV layerMCBMVar
135 syncRightOnLeftWithBoth (\nb ol -> ol { beatsPerBar = nb}) bpbRV layerMCBMVar
136 syncRightOnLeftWithBoth (\nv ol -> ol { volume = nv }) layVolumeRV layerMCBMVar
137
138 {-
139 reactiveValueOnCanRead layVolumeRV $ do
140 vol <- reactiveValueRead layVolumeRV
141 chan <- reactiveValueRead chanRV
142 let vol' = floor ((fromIntegral vol / 100) * 127)
143 reactiveValueAppend boardQueue ([],[Volume (mkChannel chan) vol'])
144 -}
145 return (layerSettingsVBox, layerMCBMVar, instrMCBMVar)