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