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