]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Main.hs
Add README.
[tmp/julm/arpeggigon.git] / src / RMCA / Main.hs
1 {-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, TupleSections #-}
2
3 module Main where
4
5 import Control.Concurrent
6 import qualified Data.IntMap as M
7 import Data.ReactiveValue
8 import FRP.Yampa
9 import Graphics.UI.Gtk
10 import RMCA.Auxiliary
11 --import RMCA.Configuration
12 import Data.CBRef
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
24
25 main :: IO ()
26 main = do
27 ------------------------------------------------------------------------------
28 -- Main GUI
29 ------------------------------------------------------------------------------
30 initGUI
31 window <- windowNew
32 -- Main box
33 mainBox <- hBoxNew False 10
34 set window [ windowTitle := "Reactogon"
35 , containerChild := mainBox
36 , containerBorderWidth := 10
37 ]
38 windowMaximize window
39
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
46
47 boardStatusRV <- newCBMVarRW Stopped
48
49 (buttonBox,
50 playRV,stopRV,pauseRV,recordRV,
51 confSaveRV,confLoadRV,
52 addLayerRV,rmLayerRV) <- getButtons boardStatusRV
53 boxPackEnd settingsBox buttonBox PackNatural 0
54
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
61
62 (noteSettingsBox, guiCellMCBMVar) <- noteSettingsBox
63 tc <- newIOTick
64 (boardCont, boardMapRV, layerMapRV, phRVMapRV) <-
65 createNotebook boardQueue tc addLayerRV rmLayerRV
66 statMCBMVar dynMCBMVar synthMCBMVar guiCellMCBMVar
67 boxPackStart mainBox boardCont PackNatural 0
68
69 --handleSaveLoad tempoRV boardMapRV layerMapRV instrMapRV phRVMapRV
70 --addLayerRV rmLayerRV confSaveRV confLoadRV
71
72 {-
73 reactiveValueOnCanRead boardStatusRV $ do
74 bs <- reactiveValueRead boardStatusRV
75 case bs of
76 Running -> reactiveValueWrite statConfSensitiveRV False
77 Stopped -> reactiveValueWrite statConfSensitiveRV True
78 -}
79 boardStatusEP <- getEPfromRV boardStatusRV
80 reactiveValueOnCanRead playRV $ reactiveValueWrite boardStatusRV Running
81 reactiveValueOnCanRead stopRV $ reactiveValueWrite boardStatusRV Stopped
82 let tempoRV' = liftR2 (\paused tempo -> if paused then 0 else tempo)
83 pauseRV tempoRV
84 jointedMapRV = liftR (fmap (\(x,y) -> (x,y,NoEvent))) $
85 liftR2 (M.intersectionWith (,)) boardMapRV layerMapRV
86 inRV = liftR3 (,,) tempoRV' boardStatusEP jointedMapRV
87 initSig <- reactiveValueRead layerMapRV
88 --(inBoard, outBoard) <- yampaReactiveDual initSig (boardRun
89 --initSig)
90 outBoard <- yampaReactiveWithMetronome (layers initSig) inRV 15
91 --reactiveValueOnCanRead inRV (reactiveValueRead inRV >>= print . M.keys)
92 reactiveValueOnCanRead outBoard $ do
93 out <- reactiveValueRead outBoard
94 --print out
95 phRVMap <- reactiveValueRead phRVMapRV
96
97 let noteMap = M.map fromEvent $ M.filter isEvent $ M.map fst out
98 writePh chan val =
99 fromMaybeM_ $ (`reactiveValueWrite` val) <$>
100 M.lookup chan phRVMap
101 sequence_ $ M.mapWithKey writePh $ M.map snd out
102 reactiveValueAppend boardQueue $ M.map (,[]) noteMap
103
104 putStrLn "Board started."
105
106 forkIO $ jackSetup tc boardQueue tempoRV layerMapRV
107
108 widgetShowAll window
109 ------------------------------------------------------------
110
111 boxPackStart settingsBox noteSettingsBox PackNatural 10
112 onDestroy window mainQuit
113 mainGUI