]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Main.hs
Refactored parallel boards.
[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 qualified Data.IntMap as M
7 import Data.ReactiveValue
8 import FRP.Yampa
9 import Graphics.UI.Gtk
10 import Graphics.UI.Gtk.Board.BoardLink
11 import Graphics.UI.Gtk.Layout.BackgroundContainer
12 import Hails.Yampa
13 import RMCA.Auxiliary
14 import RMCA.Configuration
15 import RMCA.GUI.Board
16 import RMCA.GUI.Buttons
17 import RMCA.GUI.LayerSettings
18 import RMCA.GUI.MainSettings
19 import RMCA.GUI.MultiBoard
20 import RMCA.GUI.NoteSettings
21 import RMCA.Layer.Board
22 import RMCA.Layer.Layer
23 import RMCA.Semantics
24 import RMCA.Translator.Jack
25
26 main :: IO ()
27 main = do
28 ------------------------------------------------------------------------------
29 -- Main GUI
30 ------------------------------------------------------------------------------
31 initGUI
32 window <- windowNew
33 -- Main box
34 mainBox <- hBoxNew False 10
35 set window [ windowTitle := "Reactogon"
36 , containerChild := mainBox
37 , containerBorderWidth := 10
38 ]
39 windowMaximize window
40
41 settingsBox <- vBoxNew False 0
42 boxPackEnd mainBox settingsBox PackNatural 0
43 (globalSettingsBox, tempoRV) <- globalSettings
44 boxPackStart settingsBox globalSettingsBox PackNatural 0
45 globalSep <- hSeparatorNew
46 boxPackStart settingsBox globalSep PackNatural 10
47
48 (buttonBox,
49 playRV,stopRV,pauseRV,recordRV,
50 confSaveRV,confLoadRV,
51 addLayerRV,rmLayerRV) <- getButtons
52 boxPackEnd settingsBox buttonBox PackNatural 0
53
54 boardQueue <- newCBMVarRW mempty
55 (layerSettingsVBox, layerMCBMVar, instrMCBMVar) <- layerSettings boardQueue
56 boxPackStart settingsBox layerSettingsVBox PackNatural 0
57 laySep <- hSeparatorNew
58 boxPackStart settingsBox laySep PackNatural 0
59
60 (noteSettingsBox, guiCellMCBMVar) <- noteSettingsBox
61 (boardCont, boardMapRV, layerMapRV, phRVMapRV) <- createNotebook
62 addLayerRV rmLayerRV
63 layerMCBMVar guiCellMCBMVar
64 boxPackStart mainBox boardCont PackNatural 0
65
66 --handleSaveLoad tempoRV boardRV layerRV instrRV pieceArrRV confSaveRV confLoadRV
67
68 boardRunRV <- newCBMVarRW BoardStop
69 reactiveValueOnCanRead playRV $ reactiveValueWrite boardRunRV BoardStart
70 reactiveValueOnCanRead stopRV $ reactiveValueWrite boardRunRV BoardStop
71 boardMap <- reactiveValueRead boardMapRV
72 layerMap <- reactiveValueRead layerMapRV
73 tempo <- reactiveValueRead tempoRV
74 let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
75 inRV = liftR4 (\bm lm t br -> (t,br,M.intersectionWith (,) bm lm))
76 boardMapRV layerMapRV tempoRV' boardRunRV
77 initSig <- reactiveValueRead inRV
78 (inBoard, outBoard) <- yampaReactiveDual initSig (boardRun initSig)
79 --reactiveValueOnCanRead inRV (reactiveValueRead inRV >>= print . M.keys)
80 inRV =:> inBoard
81 reactiveValueOnCanRead outBoard $ do
82 out <- reactiveValueRead outBoard
83 --print out
84 phRVMap <- reactiveValueRead phRVMapRV
85
86 let eventsMap = M.filter isEvent out
87 writePh chan val =
88 fromMaybeM_ $ fmap (`reactiveValueWrite` val) $
89 M.lookup chan phRVMap
90 noteMap = M.map (eventToList . snd . splitE) out
91 sequence_ $ M.mapWithKey writePh $
92 M.map (fst . fromEvent) $ M.filter isEvent out
93 reactiveValueAppend boardQueue $ M.map (,[]) noteMap
94
95
96 {-
97 reactiveValueRead (liftR (event mempty (,[]) <<< snd <<< splitE) outBoard) >>=
98 reactiveValueAppend boardQueue-}
99 -- This needs to be set last otherwise phRV is written to, so
100 -- inBoard is written to and the notes don't get played. There
101 -- supposedly is no guaranty of order but apparently there is…
102 putStrLn "Board started."
103 -- Jack setup
104 forkIO $ jackSetup boardQueue tempoRV
105
106 widgetShowAll window
107 ------------------------------------------------------------
108
109 boxPackStart settingsBox noteSettingsBox PackNatural 10
110 onDestroy window mainQuit
111 mainGUI