]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Main.hs
Board SF refactored.
[tmp/julm/arpeggigon.git] / src / RMCA / Main.hs
1 {-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, TupleSections #-}
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 Hails.Yampa
12 import RMCA.Auxiliary
13 import RMCA.Configuration
14 import RMCA.GUI.Board
15 import RMCA.GUI.Buttons
16 import RMCA.GUI.LayerSettings
17 import RMCA.GUI.MainSettings
18 import RMCA.GUI.NoteSettings
19 import RMCA.Layer.Board
20 import RMCA.Translator.Jack
21
22 main :: IO ()
23 main = do
24 ------------------------------------------------------------------------------
25 -- Main GUI
26 ------------------------------------------------------------------------------
27 initGUI
28 window <- windowNew
29 -- Main box
30 mainBox <- hBoxNew False 10
31 set window [ windowTitle := "Reactogon"
32 , containerChild := mainBox
33 , containerBorderWidth := 10
34 ]
35 windowMaximize window
36
37 settingsBox <- vBoxNew False 0
38 boxPackEnd mainBox settingsBox PackNatural 0
39 (globalSettingsBox, tempoRV) <- globalSettings
40 boxPackStart settingsBox globalSettingsBox PackNatural 0
41 globalSep <- hSeparatorNew
42 boxPackStart settingsBox globalSep PackNatural 0
43
44 boardQueue <- newCBMVarRW mempty
45 chanRV <- newCBMVarRW 0
46 (layerSettingsVBox, layerRV, instrRV) <- layerSettings chanRV boardQueue
47 boxPackStart settingsBox layerSettingsVBox PackNatural 0
48 laySep <- hSeparatorNew
49 boxPackStart settingsBox laySep PackNatural 0
50
51 (buttonBox, playRV, stopRV, pauseRV, recordRV, confSaveRV, confLoadRV) <- getButtons
52 boxPackEnd settingsBox buttonBox PackNatural 0
53
54 -- Board
55 boardCont <- backgroundContainerNew
56 guiBoard <- attachGameRules =<< initGame
57 centerBoard <- alignmentNew 0.5 0.5 0 0
58 containerAdd centerBoard guiBoard
59 containerAdd boardCont centerBoard
60 boxPackStart mainBox boardCont PackNatural 0
61 ------------------------------------------------------------------------------
62 -- Board setup
63 layer <- reactiveValueRead layerRV
64 tempo <- reactiveValueRead tempoRV
65 (boardRV, pieceArrRV, phRV) <- initBoardRV guiBoard
66
67 handleSaveLoad tempoRV boardRV layerRV instrRV pieceArrRV confSaveRV confLoadRV
68
69 boardRunRV <- newCBMVarRW BoardStop
70 reactiveValueOnCanRead playRV $ reactiveValueWrite boardRunRV BoardStart
71 reactiveValueOnCanRead stopRV $ reactiveValueWrite boardRunRV BoardStop
72 board <- reactiveValueRead boardRV
73 (inBoard, outBoard) <- yampaReactiveDual (board, layer, tempo, BoardStop) boardSF
74 let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
75 inRV = liftR4 (,,,)
76 boardRV layerRV tempoRV' boardRunRV
77 --let inRV = onTick clock inRV
78 inRV =:> inBoard
79 reactiveValueOnCanRead outBoard $
80 reactiveValueRead (liftR (event mempty (,[]) <<< snd <<< splitE) outBoard) >>=
81 reactiveValueAppend boardQueue
82 -- This needs to be set last otherwise phRV is written to, so
83 -- inBoard is written to and the notes don't get played. There
84 -- supposedly is no guaranty of order but apparently there is…
85 fmap fst <^> outBoard >:> phRV
86 putStrLn "Board started."
87 -- Jack setup
88 forkIO $ jackSetup tempoRV chanRV boardQueue
89 widgetShowAll window
90 pieceBox <- clickHandling pieceArrRV guiBoard =<< vBoxNew False 10
91 ------------------------------------------------------------
92
93 boxPackStart settingsBox pieceBox PackNatural 10
94 onDestroy window mainQuit
95 mainGUI