]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Main.hs
Rework on instruments.
[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 Graphics.UI.Gtk.Board.BoardLink
11 import Graphics.UI.Gtk.Layout.BackgroundContainer
12 import Hails.Yampa
13 import RMCA.Auxiliary
14 import RMCA.Configuration
15 import RMCA.Global.Clock
16 import RMCA.GUI.Board
17 import RMCA.GUI.Buttons
18 import RMCA.GUI.LayerSettings
19 import RMCA.GUI.MainSettings
20 import RMCA.GUI.MultiBoard
21 import RMCA.GUI.NoteSettings
22 import RMCA.Layer.Board
23 import RMCA.Layer.Layer
24 import RMCA.Semantics
25 import RMCA.Translator.Jack
26
27 main :: IO ()
28 main = do
29 ------------------------------------------------------------------------------
30 -- Main GUI
31 ------------------------------------------------------------------------------
32 initGUI
33 window <- windowNew
34 -- Main box
35 mainBox <- hBoxNew False 10
36 set window [ windowTitle := "Reactogon"
37 , containerChild := mainBox
38 , containerBorderWidth := 10
39 ]
40 windowMaximize window
41
42 settingsBox <- vBoxNew False 0
43 boxPackEnd mainBox settingsBox PackNatural 0
44 (globalSettingsBox, tempoRV) <- globalSettings
45 boxPackStart settingsBox globalSettingsBox PackNatural 0
46 globalSep <- hSeparatorNew
47 boxPackStart settingsBox globalSep PackNatural 10
48
49 (buttonBox,
50 playRV,stopRV,pauseRV,recordRV,
51 confSaveRV,confLoadRV,
52 addLayerRV,rmLayerRV) <- getButtons
53 boxPackEnd settingsBox buttonBox PackNatural 0
54
55 boardQueue <- newCBMVarRW mempty
56 (layerSettingsVBox, layerMCBMVar, instrMCBMVar) <- layerSettings boardQueue
57 boxPackStart settingsBox layerSettingsVBox PackNatural 0
58 laySep <- hSeparatorNew
59 boxPackStart settingsBox laySep PackNatural 0
60
61 (noteSettingsBox, guiCellMCBMVar) <- noteSettingsBox
62 tc <- newTickableClock
63 (boardCont, boardMapRV, layerMapRV, instrMapRV, phRVMapRV) <-
64 createNotebook tc addLayerRV rmLayerRV layerMCBMVar instrMCBMVar guiCellMCBMVar
65 boxPackStart mainBox boardCont PackNatural 0
66
67 handleSaveLoad tempoRV boardMapRV layerMapRV instrMapRV phRVMapRV
68 addLayerRV rmLayerRV confSaveRV confLoadRV
69
70 boardRunRV <- newCBMVarRW BoardStop
71 reactiveValueOnCanRead playRV $ reactiveValueWrite boardRunRV BoardStart
72 reactiveValueOnCanRead stopRV $ reactiveValueWrite boardRunRV BoardStop
73 boardMap <- reactiveValueRead boardMapRV
74 layerMap <- reactiveValueRead layerMapRV
75 tempo <- reactiveValueRead tempoRV
76 let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
77 inRV = liftR4 (\bm lm t br -> (t,br,M.intersectionWith (,) bm lm))
78 boardMapRV layerMapRV tempoRV' boardRunRV
79 initSig <- reactiveValueRead inRV
80 (inBoard, outBoard) <- yampaReactiveDual initSig (boardRun initSig)
81 --reactiveValueOnCanRead inRV (reactiveValueRead inRV >>= print . M.keys)
82 inRV =:> inBoard
83 reactiveValueOnCanRead outBoard $ do
84 out <- reactiveValueRead outBoard
85 --print out
86 phRVMap <- reactiveValueRead phRVMapRV
87
88 let eventsMap = M.filter isEvent out
89 writePh chan val =
90 fromMaybeM_ $ (`reactiveValueWrite` val) <$>
91 M.lookup chan phRVMap
92 noteMap = M.map (eventToList . snd . splitE) out
93 sequence_ $ M.mapWithKey writePh $
94 M.map (fst . fromEvent) $ M.filter isEvent out
95 reactiveValueAppend boardQueue $ M.map (,[]) noteMap
96
97
98 {-
99 reactiveValueRead (liftR (event mempty (,[]) <<< snd <<< splitE) outBoard) >>=
100 reactiveValueAppend boardQueue-}
101 -- This needs to be set last otherwise phRV is written to, so
102 -- inBoard is written to and the notes don't get played. There
103 -- supposedly is no guaranty of order but apparently there is…
104 putStrLn "Board started."
105 -- Jack setup
106 forkIO $ jackSetup tc boardQueue tempoRV
107
108 widgetShowAll window
109 ------------------------------------------------------------
110
111 boxPackStart settingsBox noteSettingsBox PackNatural 10
112 onDestroy window mainQuit
113 mainGUI