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
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
24 import RMCA.Translator.Jack
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 PackNatural 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 <- newCBMVarRW mempty
55 (layerSettingsVBox, layerMCBMVar, instrMCBMVar) <- layerSettings boardQueue
56 boxPackStart settingsBox layerSettingsVBox PackNatural 0
57 laySep <- hSeparatorNew
58 boxPackStart settingsBox laySep PackNatural 0
60 (noteSettingsBox, guiCellMCBMVar) <- noteSettingsBox
61 (boardCont, boardMapRV, layerMapRV, phRVMapRV) <- createNotebook
63 layerMCBMVar guiCellMCBMVar
64 boxPackStart mainBox boardCont PackNatural 0
66 --handleSaveLoad tempoRV boardRV layerRV instrRV pieceArrRV confSaveRV confLoadRV
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)
81 reactiveValueOnCanRead outBoard $ do
82 out <- reactiveValueRead outBoard
84 phRVMap <- reactiveValueRead phRVMapRV
86 let eventsMap = M.filter isEvent out
88 fromMaybeM_ $ fmap (`reactiveValueWrite` val) $
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
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."
104 forkIO $ jackSetup boardQueue tempoRV
107 ------------------------------------------------------------
109 boxPackStart settingsBox noteSettingsBox PackNatural 10
110 onDestroy window mainQuit