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, phRVMapRV) <- createNotebook tc
  64                                                     addLayerRV rmLayerRV
  65                                                     layerMCBMVar guiCellMCBMVar
  66   boxPackStart mainBox boardCont PackNatural 0
  67
  68   --handleSaveLoad tempoRV boardRV layerRV instrRV pieceArrRV 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