1 {-# LANGUAGE LambdaCase, MultiParamTypeClasses, ScopedTypeVariables,
6 import Control.Concurrent
7 import qualified Data.IntMap as M
8 import Data.ReactiveValue
10 import Graphics.UI.Gtk
12 --import RMCA.Configuration
14 import RMCA.EventProvider
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.IOClockworks
21 import RMCA.Layer.Board
22 import RMCA.ReactiveValueAtomicUpdate
23 import RMCA.Translator.Jack
24 import RMCA.YampaReactive
28 ------------------------------------------------------------------------------
30 ------------------------------------------------------------------------------
34 mainBox <- hBoxNew False 10
35 set window [ windowTitle := "Reactogon"
36 , containerChild := mainBox
37 , containerBorderWidth := 10
41 settingsBox <- vBoxNew False 0
42 boxPackEnd mainBox settingsBox PackGrow 0
43 (globalSettingsBox, tempoRV) <- globalSettings
44 boxPackStart settingsBox globalSettingsBox PackNatural 0
45 globalSep <- hSeparatorNew
46 boxPackStart settingsBox globalSep PackNatural 10
49 playRV,stopRV,pauseRV,recordRV,
50 confSaveRV,confLoadRV,
51 addLayerRV,rmLayerRV) <- getButtons
52 boxPackEnd settingsBox buttonBox PackNatural 0
54 boardQueue <- newCBRef mempty
55 --isStartMVar <- newMVar False
56 boardStatusRV <- newCBMVarRW Stopped
57 (layerSettingsVBox, statMCBMVar, dynMCBMVar, synthMCBMVar) <- layerSettings boardStatusRV
58 boxPackStart settingsBox layerSettingsVBox PackNatural 0
59 laySep <- hSeparatorNew
60 boxPackStart settingsBox laySep PackNatural 0
62 (noteSettingsBox, guiCellMCBMVar) <- noteSettingsBox
64 (boardCont, boardMapRV, layerMapRV, phRVMapRV) <-
65 createNotebook boardQueue tc addLayerRV rmLayerRV
66 statMCBMVar dynMCBMVar synthMCBMVar guiCellMCBMVar
67 boxPackStart mainBox boardCont PackNatural 0
69 --handleSaveLoad tempoRV boardMapRV layerMapRV instrMapRV phRVMapRV
70 --addLayerRV rmLayerRV confSaveRV confLoadRV
73 reactiveValueOnCanRead boardStatusRV $ do
74 bs <- reactiveValueRead boardStatusRV
76 Running -> reactiveValueWrite statConfSensitiveRV False
77 Stopped -> reactiveValueWrite statConfSensitiveRV True
79 boardStatusEP <- getEPfromRV boardStatusRV
80 reactiveValueOnCanRead playRV $
81 reactiveValueRead boardStatusRV >>=
83 Running -> reactiveValueWrite boardStatusRV Running
84 Stopped -> reactiveValueWrite boardStatusRV Running
85 reactiveValueOnCanRead stopRV $ reactiveValueWrite boardStatusRV Stopped
86 boardMap <- reactiveValueRead boardMapRV
87 layerMap <- reactiveValueRead layerMapRV
88 tempo <- reactiveValueRead tempoRV
89 let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
90 jointedMapRV = liftR (fmap (\(x,y) -> (x,y,NoEvent))) $
91 liftR2 (M.intersectionWith (,)) boardMapRV layerMapRV
92 inRV = liftR3 (,,) tempoRV' boardStatusEP jointedMapRV
93 initSig <- reactiveValueRead layerMapRV
94 --(inBoard, outBoard) <- yampaReactiveDual initSig (boardRun
96 outBoard <- yampaReactiveFrom (layers initSig) inRV
97 --reactiveValueOnCanRead inRV (reactiveValueRead inRV >>= print . M.keys)
98 reactiveValueOnCanRead outBoard $ do
99 out <- reactiveValueRead outBoard
101 phRVMap <- reactiveValueRead phRVMapRV
103 let noteMap = M.map fromEvent $ M.filter isEvent $ M.map fst out
105 fromMaybeM_ $ (`reactiveValueWrite` val) <$>
106 M.lookup chan phRVMap
107 sequence_ $ M.mapWithKey writePh $ M.map snd out
108 reactiveValueAppend boardQueue $ M.map (,[]) noteMap
110 putStrLn "Board started."
112 forkIO $ jackSetup tc boardQueue tempoRV
115 ------------------------------------------------------------
117 boxPackStart settingsBox noteSettingsBox PackNatural 10
118 onDestroy window mainQuit