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 funBoardRunRV <- getEPfromRV =<< newCBMVarRW (const StopBoard)
75 isStartMVar <- newMVar False
76 reactiveValueOnCanRead playRV $ do
77 isStarted <- readMVar isStartMVar
79 then reactiveValueWrite funBoardRunRV $ Event $ const ContinueBoard
80 else do modifyMVar_ isStartMVar $ const $ return True
81 reactiveValueWrite funBoardRunRV $ Event StartBoard
82 reactiveValueOnCanRead stopRV $ do
83 modifyMVar_ isStartMVar $ const $ return False
84 reactiveValueWrite funBoardRunRV $ Event $ const StopBoard
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 statConfRV = liftR (fmap staticConf) layerMapRV
90 boardRunRV = liftR2 (\fb lm -> fmap ((fb <*>) . Event) lm)
91 funBoardRunRV statConfRV
92 dynConfRV = liftR (fmap dynConf) layerMapRV
93 jointedMapRV = liftR3 (intersectionWith3 (,,))
94 boardMapRV dynConfRV boardRunRV
95 inRV = liftR2 (,) tempoRV' jointedMapRV
96 initSig <- reactiveValueRead statConfRV
97 --(inBoard, outBoard) <- yampaReactiveDual initSig (boardRun
99 outBoard <- yampaReactiveFrom (boardRun initSig) inRV
100 --reactiveValueOnCanRead inRV (reactiveValueRead inRV >>= print . M.keys)
102 reactiveValueOnCanRead outBoard $ do
103 out <- reactiveValueRead outBoard
105 phRVMap <- reactiveValueRead phRVMapRV
107 let noteMap = M.map fromEvent $ M.filter isEvent $ M.map fst out
109 fromMaybeM_ $ (`reactiveValueWrite` val) <$>
110 M.lookup chan phRVMap
111 sequence_ $ M.mapWithKey writePh $ M.map snd out
112 reactiveValueAppend boardQueue $ M.map (,[]) noteMap
116 reactiveValueRead (liftR (event mempty (,[]) <<< snd <<< splitE) outBoard) >>=
117 reactiveValueAppend boardQueue-}
118 -- This needs to be set last otherwise phRV is written to, so
119 -- inBoard is written to and the notes don't get played. There
120 -- supposedly is no guaranty of order but apparently there is…
121 putStrLn "Board started."
123 forkIO $ jackSetup tc boardQueue tempoRV
126 ------------------------------------------------------------
128 boxPackStart settingsBox noteSettingsBox PackNatural 10
129 onDestroy window mainQuit