]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Main.hs
Repeat count colors the tile.
[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 Data.CBRef
7 import qualified Data.IntMap as M
8 import Data.Monoid
9 import Data.ReactiveValue
10 import FRP.Yampa
11 import Graphics.UI.Gtk
12 import RMCA.Auxiliary
13 --import RMCA.Configuration
14 import RMCA.EventProvider
15 import RMCA.GUI.Buttons
16 import RMCA.GUI.LayerSettings
17 import RMCA.GUI.MainSettings
18 import RMCA.GUI.MultiBoard
19 import RMCA.GUI.NoteSettings
20 import RMCA.IOClockworks
21 import RMCA.Layer.Board
22 import RMCA.ReactiveValueAtomicUpdate
23 import RMCA.Translator.Jack
24 import RMCA.YampaReactive
25
26 main :: IO ()
27 main = do
28 ------------------------------------------------------------------------------
29 -- Main GUI
30 ------------------------------------------------------------------------------
31 initGUI
32 window <- windowNew
33 -- Main box
34 mainBox <- hBoxNew False 10
35 set window [ windowTitle := "Arpeggigon"
36 , containerChild := mainBox
37 , containerBorderWidth := 10
38 ]
39 windowMaximize window
40
41 settingsBox <- vBoxNew False 0
42 boxPackEnd mainBox settingsBox PackGrow 0
43 (globalSettingsBox, tempoRV) <- globalSettings
44 boxPackStart settingsBox globalSettingsBox PackNatural 0
45 globalSep <- hSeparatorNew
46 boxPackStart settingsBox globalSep PackNatural 10
47
48 boardStatusRV <- newCBMVarRW Stopped
49
50 (buttonBox,
51 playRV,stopRV,pauseRV,recordRV,
52 confSaveRV,confLoadRV,
53 addLayerRV,rmLayerRV) <- getButtons boardStatusRV
54 boxPackEnd settingsBox buttonBox PackNatural 0
55
56 boardQueue <- newCBRef mempty
57 --isStartMVar <- newMVar False
58 (layerSettingsVBox, statMCBMVar, dynMCBMVar, synthMCBMVar) <- layerSettings boardStatusRV
59 boxPackStart settingsBox layerSettingsVBox PackNatural 0
60 laySep <- hSeparatorNew
61 boxPackStart settingsBox laySep PackNatural 0
62
63 (noteSettingsBox, guiCellMCBMVar) <- noteSettingsBox
64 tc <- newIOTick
65 (boardCont, boardMapRV, layerMapRV, phRVMapRV) <-
66 createNotebook boardQueue tc addLayerRV rmLayerRV
67 statMCBMVar dynMCBMVar synthMCBMVar guiCellMCBMVar
68 boxPackStart mainBox boardCont PackNatural 0
69
70 --handleSaveLoad tempoRV boardMapRV layerMapRV instrMapRV phRVMapRV
71 --addLayerRV rmLayerRV confSaveRV confLoadRV
72
73 {-
74 reactiveValueOnCanRead boardStatusRV $ do
75 bs <- reactiveValueRead boardStatusRV
76 case bs of
77 Running -> reactiveValueWrite statConfSensitiveRV False
78 Stopped -> reactiveValueWrite statConfSensitiveRV True
79 -}
80 boardStatusEP <- getEPfromRV boardStatusRV
81 reactiveValueOnCanRead playRV $ reactiveValueWrite boardStatusRV Running
82 reactiveValueOnCanRead stopRV $ reactiveValueWrite boardStatusRV Stopped
83 let tempoRV' = liftR2 (\paused tempo -> if paused then 0 else tempo)
84 pauseRV tempoRV
85 jointedMapRV = liftR (fmap (\(x,y) -> (x,y,NoEvent))) $
86 liftR2 (M.intersectionWith (,)) boardMapRV layerMapRV
87 inRV = liftR3 (,,) tempoRV' boardStatusEP jointedMapRV
88 initSig <- reactiveValueRead layerMapRV
89 --(inBoard, outBoard) <- yampaReactiveDual initSig (boardRun
90 --initSig)
91 outBoard <- yampaReactiveWithMetronome (layers initSig) inRV 15
92 --reactiveValueOnCanRead inRV (reactiveValueRead inRV >>= print . M.keys)
93 reactiveValueOnCanRead outBoard $ do
94 out <- reactiveValueRead outBoard
95 --print out
96 phRVMap <- reactiveValueRead phRVMapRV
97
98 let noteMap = M.map fromEvent $ M.filter isEvent $ M.map fst out
99 writePh chan val =
100 fromMaybeM_ $ fmap (`reactiveValueWrite` val)
101 (M.lookup chan phRVMap)
102 sequence_ $ M.elems $ M.mapWithKey writePh $ M.map snd out
103 reactiveValueAppend boardQueue $ M.map (,[]) noteMap
104
105 putStrLn "Board started."
106
107 forkIO $ jackSetup tc boardQueue tempoRV layerMapRV
108
109 widgetShowAll window
110 ------------------------------------------------------------
111
112 boxPackStart settingsBox noteSettingsBox PackNatural 10
113 onDestroy window mainQuit
114 mainGUI