]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - RMCA/Main.hs
Hexagonal shape.
[tmp/julm/arpeggigon.git] / RMCA / Main.hs
1 {-# LANGUAGE ScopedTypeVariables #-}
2
3 module Main where
4
5 import Control.Concurrent
6 import Data.ReactiveValue
7 import FRP.Yampa
8 import Graphics.UI.Gtk
9 import Graphics.UI.Gtk.Reactive
10 import Hails.Yampa
11 import RMCA.Auxiliary.Concurrent
12 import RMCA.Auxiliary.RV
13 import RMCA.Global.Clock
14 import RMCA.GUI.Buttons
15 import RMCA.Layer.Board
16 import RMCA.Layer.Layer
17 import RMCA.Semantics
18 import RMCA.Translator.Jack
19 import RMCA.Translator.Message
20 import RMCA.Translator.Translator
21 import Graphics.UI.Gtk.Layout.BackgroundContainer
22
23 import Control.Monad
24 import Data.Ratio
25
26 floatConv :: (ReactiveValueReadWrite a b m,
27 Real c, Real b, Fractional c, Fractional b) =>
28 a -> ReactiveFieldReadWrite m c
29 floatConv = liftRW $ bijection (realToFrac, realToFrac)
30
31 boardRVIO = newCBMVarRW $
32 makeBoard [((0,0), mkCell (ChDir True na1 NE)),
33 ((1,1), mkCellRpt (ChDir False na1 NW) 3),
34 ((0,1), mkCell (ChDir False na1 S))]
35 {-makeBoard [((0,0), mkCell (ChDir True na1 N)),
36 ((0,2), mkCellRpt (ChDir False na2 SE) 3),
37 ((2,1), mkCell (ChDir False na1 SW)),
38 ((1,1), mkCellRpt (ChDir False na1 N) 0) {- Skipped! -},
39 ((0,4), mkCellRpt (ChDir True na1 N) (-1)) {- Rpt indef. -},
40 ((0, -6), mkCell (ChDir True na1 N)),
41 ((0, -2), mkCell (ChDir False na3 S) {- Silent -})]-}
42
43 na1 = NoteAttr {
44 naArt = Accent13,
45 naDur = 1 % 1,
46 naOrn = Ornaments Nothing [] NoSlide
47 }
48
49 na2 = NoteAttr {
50 naArt = NoAccent,
51 naDur = 1 % 1,
52 naOrn = Ornaments Nothing [(10, MIDICVRnd)] SlideUp
53 }
54
55 na3 = NoteAttr {
56 naArt = Accent13,
57 naDur = 0,
58 naOrn = Ornaments Nothing [] NoSlide
59 }
60
61
62 bpb :: Int
63 bpb = 4
64
65 newTempoRV :: IO (ReactiveFieldReadWrite IO Tempo)
66 newTempoRV = newCBMVarRW 200
67
68 main :: IO ()
69 main = do
70 -- GUI
71 initGUI
72 window <- windowNew
73 -- Main box
74 mainBox <- hBoxNew True 0
75 set window [ windowTitle := "Reactogon"
76 --, windowDefaultWidth := 250
77 --, windowDefaultHeight := 500
78 , containerChild := mainBox
79 , containerBorderWidth := 10
80 ]
81
82 settingsBox <- vBoxNew False 0
83 boxPackEnd mainBox settingsBox PackNatural 0
84 globalSettingsBox <- vBoxNew False 10
85 boxPackStart settingsBox globalSettingsBox PackNatural 0
86 tempoAdj <- adjustmentNew 96 0 200 1 1 1
87 tempoLabel <- labelNew (Just "Tempo")
88 boxPackStart globalSettingsBox tempoLabel PackNatural 0
89 tempoScale <- hScaleNew tempoAdj
90 boxPackStart globalSettingsBox tempoScale PackNatural 0
91 scaleSetDigits tempoScale 0
92 let tempoRV =
93 bijection (floor, fromIntegral) `liftRW` scaleValueReactive tempoScale
94 globalSep <- hSeparatorNew
95 boxPackStart settingsBox globalSep PackNatural 0
96
97 layerSettingsBox <- hBoxNew True 10
98 boxPackStart settingsBox layerSettingsBox PackNatural 0
99
100 layTempoBox <- hBoxNew False 10
101 boxPackStart layerSettingsBox layTempoBox PackNatural 0
102 layTempoLabel <- labelNew (Just "Layer tempo")
103 labelSetAngle layTempoLabel 90
104 boxPackStart layTempoBox layTempoLabel PackNatural 0
105 layTempoScale <- vScaleNewWithRange 0 1 0.01
106 boxPackStart layTempoBox layTempoScale PackNatural 0
107 laySep <- hSeparatorNew
108
109 strBox <- hBoxNew False 10
110 boxPackStart layerSettingsBox strBox PackNatural 0
111 strLabel <- labelNew (Just "Strength")
112 labelSetAngle strLabel 90
113 boxPackStart strBox strLabel PackNatural 0
114 strAdj <- adjustmentNew 1 0 1 0.01 0.01 0
115 layStrengthScale <- vScaleNew strAdj
116 boxPackStart strBox layStrengthScale PackNatural 0
117
118 bpbBox <- vBoxNew False 10
119 boxPackStart layerSettingsBox bpbBox PackNatural 0
120 bpbLabel <- labelNew (Just "Beat per bar")
121 labelSetLineWrap bpbLabel True
122 boxPackStart bpbBox bpbLabel PackNatural 0
123 bpbAdj <- adjustmentNew 4 1 16 1 1 0
124 bpbButton <- spinButtonNew bpbAdj 1 0
125 boxPackStart bpbBox bpbButton PackNatural 0
126
127 boxPackStart settingsBox laySep PackNatural 0
128
129 layPitchRV <- newCBMVarRW 1
130 let layTempoRV = floatConv $ scaleValueReactive layTempoScale
131 strengthRV = floatConv $ scaleValueReactive layStrengthScale
132 bpbRV = spinButtonValueIntReactive bpbButton
133 f1 Layer { relTempo = d
134 , relPitch = p
135 , strength = s
136 , beatsPerBar = bpb
137 } = (d,p,s,bpb)
138 f2 (d,p,s,bpb) = Layer { relTempo = d
139 , relPitch = p
140 , strength = s
141 , beatsPerBar = bpb
142 }
143 layerRV =
144 liftRW4 (bijection (f1,f2)) layTempoRV layPitchRV strengthRV bpbRV
145
146
147 buttonBox <- hBoxNew True 10
148 boxPackEnd settingsBox buttonBox PackNatural 0
149 buttonPlay <- buttonNewFromStock gtkMediaPlay
150 boxPackStart buttonBox buttonPlay PackRepel 0
151 buttonPause <- buttonNewFromStock gtkMediaPause
152 boxPackStart buttonBox buttonPause PackRepel 0
153 buttonStop <- buttonNewFromStock gtkMediaStop
154 boxPackStart buttonBox buttonStop PackRepel 0
155 buttonRecord <- buttonNewFromStock gtkMediaRecord
156 boxPackStart buttonBox buttonRecord PackRepel 0
157
158 -- Board
159 boardCont <- backgroundContainerNewWithPicture "ussr.png"
160 containerAdd mainBox boardCont
161 --boxPackStart mainBox boardCont PackNatural 0
162 ------------------------------------------------------------------------------
163 boardQueue <- newCBMVarRW []
164 -- Board setup
165 layer <- reactiveValueRead layerRV
166 tempo <- reactiveValueRead tempoRV
167 boardRV <- boardRVIO
168 board <- reactiveValueRead boardRV
169 (inBoard, outBoard) <- yampaReactiveDual (board, layer, tempo)
170 (boardSF $ startHeads board)
171 let inRV = liftRW2 (bijection (\(x,y,z) -> (x,(y,z)), \(x,(y,z)) -> (x,y,z)))
172 boardRV $ pairRW layerRV tempoRV
173 clock <- mkClockRV 100
174 clock ^:> inRV
175 inRV =:> inBoard
176 --reactiveValueOnCanRead outBoard (reactiveValueRead outBoard >>= print . ("Board out " ++) . show)
177 reactiveValueOnCanRead outBoard $ do
178 bq <- reactiveValueRead boardQueue
179 ob <- reactiveValueRead $ liftR (event [] id) outBoard
180 reactiveValueWrite boardQueue (bq ++ ob)
181 -- /!\ To be removed.
182 --reactiveValueOnCanRead outBoard (reactiveValueRead outBoard >>= print)
183 putStrLn "Board started."
184 -- Jack setup
185 forkIO $ jackSetup tempoRV (constR 0) boardQueue
186 widgetShowAll window
187 onDestroy window mainQuit
188 mainGUI
189 --return ()