1 {-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, TupleSections #-}
5 import Control.Concurrent
6 import qualified Data.IntMap as M
7 import Data.ReactiveValue
11 --import RMCA.Configuration
13 import RMCA.EventProvider
14 import RMCA.GUI.Buttons
15 import RMCA.GUI.LayerSettings
16 import RMCA.GUI.MainSettings
17 import RMCA.GUI.MultiBoard
18 import RMCA.GUI.NoteSettings
19 import RMCA.IOClockworks
20 import RMCA.Layer.Board
21 import RMCA.ReactiveValueAtomicUpdate
22 import RMCA.Translator.Jack
23 import RMCA.YampaReactive
27 ------------------------------------------------------------------------------
29 ------------------------------------------------------------------------------
33 mainBox <- hBoxNew False 10
34 set window [ windowTitle := "Reactogon"
35 , containerChild := mainBox
36 , containerBorderWidth := 10
40 settingsBox <- vBoxNew False 0
41 boxPackEnd mainBox settingsBox PackGrow 0
42 (globalSettingsBox, tempoRV) <- globalSettings
43 boxPackStart settingsBox globalSettingsBox PackNatural 0
44 globalSep <- hSeparatorNew
45 boxPackStart settingsBox globalSep PackNatural 10
47 boardStatusRV <- newCBMVarRW Stopped
50 playRV,stopRV,pauseRV,recordRV,
51 confSaveRV,confLoadRV,
52 addLayerRV,rmLayerRV) <- getButtons boardStatusRV
53 boxPackEnd settingsBox buttonBox PackNatural 0
55 boardQueue <- newCBRef mempty
56 --isStartMVar <- newMVar False
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 $ reactiveValueWrite boardStatusRV Running
81 reactiveValueOnCanRead stopRV $ reactiveValueWrite boardStatusRV Stopped
82 let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
83 jointedMapRV = liftR (fmap (\(x,y) -> (x,y,NoEvent))) $
84 liftR2 (M.intersectionWith (,)) boardMapRV layerMapRV
85 inRV = liftR3 (,,) tempoRV' boardStatusEP jointedMapRV
86 initSig <- reactiveValueRead layerMapRV
87 --(inBoard, outBoard) <- yampaReactiveDual initSig (boardRun
89 outBoard <- yampaReactiveFrom (layers initSig) inRV
90 --reactiveValueOnCanRead inRV (reactiveValueRead inRV >>= print . M.keys)
91 reactiveValueOnCanRead outBoard $ do
92 out <- reactiveValueRead outBoard
94 phRVMap <- reactiveValueRead phRVMapRV
96 let noteMap = M.map fromEvent $ M.filter isEvent $ M.map fst out
98 fromMaybeM_ $ (`reactiveValueWrite` val) <$>
100 sequence_ $ M.mapWithKey writePh $ M.map snd out
101 reactiveValueAppend boardQueue $ M.map (,[]) noteMap
103 putStrLn "Board started."
105 forkIO $ jackSetup tc boardQueue tempoRV layerMapRV
108 ------------------------------------------------------------
110 boxPackStart settingsBox noteSettingsBox PackNatural 10
111 onDestroy window mainQuit