1 {-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, TupleSections #-}
5 import Control.Concurrent
6 import qualified Data.IntMap as M
7 import Data.ReactiveValue
10 import Graphics.UI.Gtk.Board.BoardLink
11 import Graphics.UI.Gtk.Layout.BackgroundContainer
14 --import RMCA.Configuration
15 import RMCA.EventProvider
16 import RMCA.Global.Clock
18 import RMCA.GUI.Buttons
19 import RMCA.GUI.LayerSettings
20 import RMCA.GUI.MainSettings
21 import RMCA.GUI.MultiBoard
22 import RMCA.GUI.NoteSettings
23 import RMCA.IOClockworks
24 import RMCA.Layer.Board
25 import RMCA.Layer.LayerConf
27 import RMCA.Translator.Jack
28 import RMCA.YampaReactive
32 ------------------------------------------------------------------------------
34 ------------------------------------------------------------------------------
38 mainBox <- hBoxNew False 10
39 set window [ windowTitle := "Reactogon"
40 , containerChild := mainBox
41 , containerBorderWidth := 10
45 settingsBox <- vBoxNew False 0
46 boxPackEnd mainBox settingsBox PackNatural 0
47 (globalSettingsBox, tempoRV) <- globalSettings
48 boxPackStart settingsBox globalSettingsBox PackNatural 0
49 globalSep <- hSeparatorNew
50 boxPackStart settingsBox globalSep PackNatural 10
53 playRV,stopRV,pauseRV,recordRV,
54 confSaveRV,confLoadRV,
55 addLayerRV,rmLayerRV) <- getButtons
56 boxPackEnd settingsBox buttonBox PackNatural 0
58 boardQueue <- newCBMVarRW mempty
59 (layerSettingsVBox, statMCBMVar, dynMCBMVar, synthMCBMVar) <- layerSettings
60 boxPackStart settingsBox layerSettingsVBox PackNatural 0
61 laySep <- hSeparatorNew
62 boxPackStart settingsBox laySep PackNatural 0
64 (noteSettingsBox, guiCellMCBMVar) <- noteSettingsBox
66 (boardCont, boardMapRV, layerMapRV, phRVMapRV) <-
67 createNotebook boardQueue tc addLayerRV rmLayerRV
68 statMCBMVar dynMCBMVar synthMCBMVar guiCellMCBMVar
69 boxPackStart mainBox boardCont PackNatural 0
71 --handleSaveLoad tempoRV boardMapRV layerMapRV instrMapRV phRVMapRV
72 --addLayerRV rmLayerRV confSaveRV confLoadRV
74 boardStatusRV <- getEPfromRV =<< newCBMVarRW Stopped
75 isStartMVar <- newMVar False
76 reactiveValueOnCanRead playRV $ do
77 isStarted <- readMVar isStartMVar
79 then reactiveValueWrite boardStatusRV $ Event Running
80 else do modifyMVar_ isStartMVar $ const $ return True
81 reactiveValueWrite boardStatusRV $ Event Running
82 reactiveValueOnCanRead stopRV $ do
83 modifyMVar_ isStartMVar $ const $ return False
84 reactiveValueWrite boardStatusRV $ Event Stopped
85 boardMap <- reactiveValueRead boardMapRV
86 layerMap <- reactiveValueRead layerMapRV
87 tempo <- reactiveValueRead tempoRV
88 let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
89 jointedMapRV = liftR (fmap (\(x,y) -> (x,y,NoEvent))) $
90 liftR2 (M.intersectionWith (,)) boardMapRV layerMapRV
91 inRV = liftR3 (,,) tempoRV' boardStatusRV jointedMapRV
92 initSig <- reactiveValueRead layerMapRV
93 --(inBoard, outBoard) <- yampaReactiveDual initSig (boardRun
95 outBoard <- yampaReactiveFrom (layers initSig) inRV
96 --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
112 reactiveValueRead (liftR (event mempty (,[]) <<< snd <<< splitE) outBoard) >>=
113 reactiveValueAppend boardQueue-}
114 -- This needs to be set last otherwise phRV is written to, so
115 -- inBoard is written to and the notes don't get played. There
116 -- supposedly is no guaranty of order but apparently there is…
117 putStrLn "Board started."
119 forkIO $ jackSetup tc boardQueue tempoRV
122 ------------------------------------------------------------
124 boxPackStart settingsBox noteSettingsBox PackNatural 10
125 onDestroy window mainQuit