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