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