]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - RMCA/Main.hs
Playheads and notes are correct.
[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 import Graphics.UI.Gtk.Board.BoardLink
24 import Game.Board.BasicTurnGame
25 import Graphics.UI.Gtk.Board.TiledBoard
26 import Data.Array.MArray
27 import qualified Graphics.UI.Gtk.Board.TiledBoard as BIO
28 import Data.Array.IO
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 True 0
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 boardCont 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 reactiveValueOnCanRead playRV
183 (reactiveValueRead boardRV >>= reactiveValueWrite phRV . startHeads)
184 reactiveValueOnCanRead stopRV $ reactiveValueWrite phRV []
185 board <- reactiveValueRead boardRV
186 ph <- reactiveValueRead phRV
187 (inBoard, outBoard) <- yampaReactiveDual (board, layer, ph, tempo) boardSF
188 let inRV = liftR4 id
189 boardRV layerRV phRV tempoRV
190 clock <- mkClockRV 100
191 --let inRV = onTick clock inRV
192 inRV =:> inBoard
193 reactiveValueOnCanRead outBoard $ do
194 bq <- reactiveValueRead boardQueue
195 ob <- reactiveValueRead $ liftR (event [] id <<< snd <<< splitE) outBoard
196 reactiveValueWrite boardQueue (bq ++ ob)
197 -- This needs to be set last otherwise phRV is written to, so
198 -- inBoard is written to and the notes don't get played. There
199 -- supposedly is no guaranty of order but apparently there is…
200 (fst <$>) <^> outBoard >:> phRV
201 putStrLn "Board started."
202 -- Jack setup
203 forkIO $ jackSetup tempoRV (constR 0) boardQueue
204 widgetShowAll window
205 onDestroy window mainQuit
206 mainGUI
207 --return ()