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   boardMap <- reactiveValueRead boardMapRV
  83   layerMap <- reactiveValueRead layerMapRV
  84   tempo <- reactiveValueRead tempoRV
  85   let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
  86       jointedMapRV = liftR (fmap (\(x,y) -> (x,y,NoEvent))) $
  87                      liftR2 (M.intersectionWith (,)) boardMapRV layerMapRV
  88       inRV = liftR3 (,,) tempoRV' boardStatusEP jointedMapRV
  89   initSig <- reactiveValueRead layerMapRV
  90   --(inBoard, outBoard) <- yampaReactiveDual initSig (boardRun
  91     --initSig)
  92   outBoard <- yampaReactiveFrom (layers initSig) inRV
  93   --reactiveValueOnCanRead inRV (reactiveValueRead inRV >>= print . M.keys)
  94   reactiveValueOnCanRead outBoard $ do
  95     out <- reactiveValueRead outBoard
  96     --print out
  97     phRVMap <- reactiveValueRead phRVMapRV
  98
  99     let noteMap = M.map fromEvent $ M.filter isEvent $ M.map fst out
 100         writePh chan val =
 101           fromMaybeM_ $ (`reactiveValueWrite` val) <$>
 102           M.lookup chan phRVMap
 103     sequence_ $ M.mapWithKey writePh $ M.map snd out
 104     reactiveValueAppend boardQueue $ M.map (,[]) noteMap
 105
 106   putStrLn "Board started."
 107
 108   forkIO $ jackSetup tc boardQueue tempoRV layerMapRV
 109
 110   widgetShowAll window
 111   ------------------------------------------------------------
 112
 113   boxPackStart settingsBox noteSettingsBox PackNatural 10
 114   onDestroy window mainQuit
 115   mainGUI