]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Main.hs
Minor refactoring.
[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.ReactiveValue
7 import FRP.Yampa
8 import Graphics.UI.Gtk
9 import Graphics.UI.Gtk.Board.BoardLink
10 import Graphics.UI.Gtk.Layout.BackgroundContainer
11 import Hails.Yampa
12 import RMCA.Auxiliary
13 import RMCA.Configuration
14 import RMCA.GUI.Board
15 import RMCA.GUI.Buttons
16 import RMCA.GUI.LayerSettings
17 import RMCA.GUI.MainSettings
18 import RMCA.GUI.NoteSettings
19 import RMCA.Layer.Board
20 import RMCA.Semantics
21 import RMCA.Translator.Jack
22
23 main :: IO ()
24 main = do
25 -- GUI
26 initGUI
27 window <- windowNew
28 -- Main box
29 mainBox <- hBoxNew False 10
30 set window [ windowTitle := "Reactogon"
31 , containerChild := mainBox
32 , containerBorderWidth := 10
33 ]
34 windowMaximize window
35
36 boardQueue <- newCBMVarRW mempty
37 chanRV <- newCBMVarRW 0
38
39 settingsBox <- vBoxNew False 0
40 boxPackEnd mainBox settingsBox PackNatural 0
41 (globalSettingsBox, tempoRV) <- globalSettings
42 boxPackStart settingsBox globalSettingsBox PackNatural 0
43 globalSep <- hSeparatorNew
44 boxPackStart settingsBox globalSep PackNatural 0
45
46 (layerSettingsVBox, layerRV, instrRV) <- layerSettings chanRV boardQueue
47 boxPackStart settingsBox layerSettingsVBox PackNatural 0
48 laySep <- hSeparatorNew
49 boxPackStart settingsBox laySep PackNatural 0
50
51 (buttonBox, playRV, stopRV, pauseRV, recordRV, confSaveRV, confLoadRV) <- getButtons
52 boxPackEnd settingsBox buttonBox PackNatural 0
53
54 -- Board
55 boardCont <- backgroundContainerNew
56 game <- initGame
57 guiBoard <- attachGameRules game
58 centerBoard <- alignmentNew 0.5 0.5 0 0
59 containerAdd centerBoard guiBoard
60 containerAdd boardCont centerBoard
61 boxPackStart mainBox boardCont PackNatural 0
62 --boxPackStart mainBox boardCont PackNatural 0
63 ------------------------------------------------------------------------------
64 -- Board setup
65 layer <- reactiveValueRead layerRV
66 tempo <- reactiveValueRead tempoRV
67 (boardRV, pieceArrRV, phRV) <- initBoardRV guiBoard
68
69 --fcsw <- windowNew
70 fcs <- fileChooserDialogNew (Just "Save configuration") Nothing
71 FileChooserActionSave [("Cancel",ResponseCancel),("Ok",ResponseOk)]
72 --containerAdd fcsw fcs
73 reactFilt <- fileFilterNew
74 fileFilterAddPattern reactFilt "*.react"
75 fileFilterSetName reactFilt "RMCA conf files."
76 fileChooserAddFilter fcs reactFilt
77
78 --fclw <- windowNew
79 fcl <- fileChooserDialogNew (Just "Load configuration") Nothing
80 FileChooserActionOpen [("Cancel",ResponseCancel),("Ok",ResponseOk)]
81 --containerAdd fclw fcl
82 fileChooserAddFilter fcl reactFilt
83
84 reactiveValueOnCanRead confSaveRV $ postGUIAsync $ do
85 widgetShowAll fcs
86 let respHandle ResponseOk =
87 fileChooserGetFilename fcs >>= fromMaybeM_ .
88 fmap (\f -> saveConfiguration f tempoRV layerRV boardRV instrRV)
89 respHandle _ = return ()
90
91 onResponse fcs (\r -> respHandle r >> widgetHide fcs)
92 return ()
93
94 reactiveValueOnCanRead confLoadRV $ postGUIAsync $ do
95 widgetShowAll fcl
96 let respHandle ResponseOk =
97 fileChooserGetFilename fcl >>= fromMaybeM_ .
98 fmap (\f -> loadConfiguration f tempoRV layerRV pieceArrRV instrRV)
99 respHandle _ = return ()
100
101 onResponse fcl (\r -> respHandle r >> widgetHide fcl)
102 return ()
103
104 boardRunRV <- newCBMVarRW BoardStop
105 reactiveValueOnCanRead playRV $ reactiveValueWrite boardRunRV BoardStart
106 reactiveValueOnCanRead stopRV $ reactiveValueWrite boardRunRV BoardStop
107 board <- reactiveValueRead boardRV
108 (inBoard, outBoard) <- yampaReactiveDual (board, layer, tempo, BoardStop) boardSF
109 let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
110 inRV = liftR4 (,,,)
111 boardRV layerRV tempoRV' boardRunRV
112 --let inRV = onTick clock inRV
113 inRV =:> inBoard
114 reactiveValueOnCanRead outBoard $
115 reactiveValueRead (liftR (event mempty (,[]) <<< snd <<< splitE) outBoard) >>=
116 reactiveValueAppend boardQueue
117 -- This needs to be set last otherwise phRV is written to, so
118 -- inBoard is written to and the notes don't get played. There
119 -- supposedly is no guaranty of order but apparently there is…
120 fmap fst <^> outBoard >:> phRV
121 putStrLn "Board started."
122 -- Jack setup
123 forkIO $ jackSetup tempoRV chanRV boardQueue
124 widgetShowAll window
125 pieceBox <- clickHandling pieceArrRV guiBoard =<< vBoxNew False 10
126 -- Piece characteristic
127 --pieceBox <- pieceButtons pieceArrRV guiBoard =<< vBoxNew False 10
128 ------------------------------------------------------------
129
130 boxPackStart settingsBox pieceBox PackNatural 10
131 onDestroy window mainQuit
132 mainGUI