src/RMCA/Main.hs

   1 {-# LANGUAGE LambdaCase, MultiParamTypeClasses, ScopedTypeVariables,
   2              TupleSections #-}
   3
   4 module Main where
   5
   6 import           Control.Concurrent
   7 import qualified Data.IntMap                    as M
   8 import           Data.ReactiveValue
   9 import           FRP.Yampa
  10 import           Graphics.UI.Gtk
  11 import           RMCA.Auxiliary
  12 --import           RMCA.Configuration
  13 import           Data.CBRef
  14 import           RMCA.EventProvider
  15 import           RMCA.GUI.Buttons
  16 import           RMCA.GUI.LayerSettings
  17 import           RMCA.GUI.MainSettings
  18 import           RMCA.GUI.MultiBoard
  19 import           RMCA.GUI.NoteSettings
  20 import           RMCA.IOClockworks
  21 import           RMCA.Layer.Board
  22 import           RMCA.ReactiveValueAtomicUpdate
  23 import           RMCA.Translator.Jack
  24 import           RMCA.YampaReactive
  25
  26 main :: IO ()
  27 main = do
  28   ------------------------------------------------------------------------------
  29   -- Main GUI
  30   ------------------------------------------------------------------------------
  31   initGUI
  32   window <- windowNew
  33   -- Main box
  34   mainBox <- hBoxNew False 10
  35   set window [ windowTitle := "Reactogon"
  36              , containerChild := mainBox
  37              , containerBorderWidth := 10
  38              ]
  39   windowMaximize window
  40
  41   settingsBox <- vBoxNew False 0
  42   boxPackEnd mainBox settingsBox PackGrow 0
  43   (globalSettingsBox, tempoRV) <- globalSettings
  44   boxPackStart settingsBox globalSettingsBox PackNatural 0
  45   globalSep <- hSeparatorNew
  46   boxPackStart settingsBox globalSep PackNatural 10
  47
  48   (buttonBox,
  49    playRV,stopRV,pauseRV,recordRV,
  50    confSaveRV,confLoadRV,
  51    addLayerRV,rmLayerRV) <- getButtons
  52   boxPackEnd settingsBox buttonBox PackNatural 0
  53
  54   boardQueue <- newCBRef mempty
  55   --isStartMVar <- newMVar False
  56   boardStatusRV <- newCBMVarRW Stopped
  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 $
  81     reactiveValueRead boardStatusRV >>=
  82       \case
  83         Running -> reactiveValueWrite boardStatusRV Running
  84         Stopped -> reactiveValueWrite boardStatusRV Running
  85   reactiveValueOnCanRead stopRV $ reactiveValueWrite boardStatusRV Stopped
  86   boardMap <- reactiveValueRead boardMapRV
  87   layerMap <- reactiveValueRead layerMapRV
  88   tempo <- reactiveValueRead tempoRV
  89   let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
  90       jointedMapRV = liftR (fmap (\(x,y) -> (x,y,NoEvent))) $
  91                      liftR2 (M.intersectionWith (,)) boardMapRV layerMapRV
  92       inRV = liftR3 (,,) tempoRV' boardStatusEP jointedMapRV
  93   initSig <- reactiveValueRead layerMapRV
  94   --(inBoard, outBoard) <- yampaReactiveDual initSig (boardRun
  95     --initSig)
  96   outBoard <- yampaReactiveFrom (layers initSig) inRV
  97   --reactiveValueOnCanRead inRV (reactiveValueRead inRV >>= print . M.keys)
  98   reactiveValueOnCanRead outBoard $ do
  99     out <- reactiveValueRead outBoard
 100     --print out
 101     phRVMap <- reactiveValueRead phRVMapRV
 102
 103     let noteMap = M.map fromEvent $ M.filter isEvent $ M.map fst out
 104         writePh chan val =
 105           fromMaybeM_ $ (`reactiveValueWrite` val) <$>
 106           M.lookup chan phRVMap
 107     sequence_ $ M.mapWithKey writePh $ M.map snd out
 108     reactiveValueAppend boardQueue $ M.map (,[]) noteMap
 109
 110   putStrLn "Board started."
 111
 112   forkIO $ jackSetup tc boardQueue tempoRV
 113
 114   widgetShowAll window
 115   ------------------------------------------------------------
 116
 117   boxPackStart settingsBox noteSettingsBox PackNatural 10
 118   onDestroy window mainQuit
 119   mainGUI