module Main where
-import Control.Concurrent
-import Data.ReactiveValue
-import FRP.Yampa
-import Graphics.UI.Gtk
-import Graphics.UI.Gtk.Board.BoardLink
-import Graphics.UI.Gtk.Layout.BackgroundContainer
-import Hails.Yampa
-import RMCA.Auxiliary
-import RMCA.Configuration
-import RMCA.GUI.Board
-import RMCA.GUI.Buttons
-import RMCA.GUI.LayerSettings
-import RMCA.GUI.MainSettings
-import RMCA.GUI.MultiBoard
-import RMCA.GUI.NoteSettings
-import RMCA.Layer.Board
-import RMCA.Translator.Jack
+import Control.Concurrent
+import qualified Data.IntMap as M
+import Data.ReactiveValue
+import FRP.Yampa
+import Graphics.UI.Gtk
+import Graphics.UI.Gtk.Board.BoardLink
+import Graphics.UI.Gtk.Layout.BackgroundContainer
+import Hails.Yampa
+import RMCA.Auxiliary
+import RMCA.Configuration
+import RMCA.Global.Clock
+import RMCA.GUI.Board
+import RMCA.GUI.Buttons
+import RMCA.GUI.LayerSettings
+import RMCA.GUI.MainSettings
+import RMCA.GUI.MultiBoard
+import RMCA.GUI.NoteSettings
+import RMCA.Layer.Board
+import RMCA.Layer.Layer
+import RMCA.Semantics
+import RMCA.Translator.Jack
main :: IO ()
main = do
(globalSettingsBox, tempoRV) <- globalSettings
boxPackStart settingsBox globalSettingsBox PackNatural 0
globalSep <- hSeparatorNew
- boxPackStart settingsBox globalSep PackNatural 0
+ boxPackStart settingsBox globalSep PackNatural 10
- ( buttonBox
- , playRV, stopRV, pauseRV, recordRV
- , confSaveRV, confLoadRV
- , addLayerRV, rmLayerRV ) <- getButtons
+ (buttonBox,
+ playRV,stopRV,pauseRV,recordRV,
+ confSaveRV,confLoadRV,
+ addLayerRV,rmLayerRV) <- getButtons
boxPackEnd settingsBox buttonBox PackNatural 0
boardQueue <- newCBMVarRW mempty
boxPackStart settingsBox laySep PackNatural 0
(noteSettingsBox, guiCellMCBMVar) <- noteSettingsBox
- (boardCont, chanMapRV, _{-curPageRV-}) <- createNotebook addLayerRV rmLayerRV
- layerMCBMVar guiCellMCBMVar
+ tc <- newTickableClock
+ (boardCont, boardMapRV, layerMapRV, phRVMapRV) <- createNotebook tc
+ addLayerRV rmLayerRV
+ layerMCBMVar guiCellMCBMVar
boxPackStart mainBox boardCont PackNatural 0
--handleSaveLoad tempoRV boardRV layerRV instrRV pieceArrRV confSaveRV confLoadRV
-{-
+
boardRunRV <- newCBMVarRW BoardStop
reactiveValueOnCanRead playRV $ reactiveValueWrite boardRunRV BoardStart
reactiveValueOnCanRead stopRV $ reactiveValueWrite boardRunRV BoardStop
- board <- reactiveValueRead boardRV
- layer <- reactiveValueRead layerRV
+ boardMap <- reactiveValueRead boardMapRV
+ layerMap <- reactiveValueRead layerMapRV
tempo <- reactiveValueRead tempoRV
- (inBoard, outBoard) <- yampaReactiveDual (board, layer, tempo, BoardStop) boardSF
let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
- inRV = liftR4 (,,,)
- boardRV layerRV tempoRV' boardRunRV
+ inRV = liftR4 (\bm lm t br -> (t,br,M.intersectionWith (,) bm lm))
+ boardMapRV layerMapRV tempoRV' boardRunRV
+ initSig <- reactiveValueRead inRV
+ (inBoard, outBoard) <- yampaReactiveDual initSig (boardRun initSig)
+ --reactiveValueOnCanRead inRV (reactiveValueRead inRV >>= print . M.keys)
inRV =:> inBoard
- reactiveValueOnCanRead outBoard $
+ reactiveValueOnCanRead outBoard $ do
+ out <- reactiveValueRead outBoard
+ --print out
+ phRVMap <- reactiveValueRead phRVMapRV
+
+ let eventsMap = M.filter isEvent out
+ writePh chan val =
+ fromMaybeM_ $ (`reactiveValueWrite` val) <$>
+ M.lookup chan phRVMap
+ noteMap = M.map (eventToList . snd . splitE) out
+ sequence_ $ M.mapWithKey writePh $
+ M.map (fst . fromEvent) $ M.filter isEvent out
+ reactiveValueAppend boardQueue $ M.map (,[]) noteMap
+
+
+{-
reactiveValueRead (liftR (event mempty (,[]) <<< snd <<< splitE) outBoard) >>=
- reactiveValueAppend boardQueue
+ reactiveValueAppend boardQueue-}
-- This needs to be set last otherwise phRV is written to, so
-- inBoard is written to and the notes don't get played. There
-- supposedly is no guaranty of order but apparently there is…
- fmap fst <^> outBoard >:> phRV
putStrLn "Board started."
-- Jack setup
- forkIO $ jackSetup tempoRV chanRV boardQueue
--}
+ forkIO $ jackSetup tc boardQueue tempoRV
+
widgetShowAll window
------------------------------------------------------------