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