src/RMCA/Main.hs

   1 {-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, TupleSections #-}
   2
   3 module Main where
   4
   5 import           Control.Concurrent
   6 import           Data.CBRef
   7 import qualified Data.IntMap                    as M
   8 import           Data.Monoid
   9 import           Data.ReactiveValue
  10 import           FRP.Yampa
  11 import           Graphics.UI.Gtk
  12 import           RMCA.Auxiliary
  13 --import           RMCA.Configuration
  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 := "Arpeggigon"
  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   boardStatusRV <- newCBMVarRW Stopped
  49
  50   (buttonBox,
  51    playRV,stopRV,pauseRV,recordRV,
  52    confSaveRV,confLoadRV,
  53    addLayerRV,rmLayerRV) <- getButtons boardStatusRV
  54   boxPackEnd settingsBox buttonBox PackNatural 0
  55
  56   boardQueue <- newCBRef mempty
  57   --isStartMVar <- newMVar False
  58   (layerSettingsVBox, statMCBMVar, dynMCBMVar, synthMCBMVar) <- layerSettings boardStatusRV
  59   boxPackStart settingsBox layerSettingsVBox PackNatural 0
  60   laySep <- hSeparatorNew
  61   boxPackStart settingsBox laySep PackNatural 0
  62
  63   (noteSettingsBox, guiCellMCBMVar) <- noteSettingsBox
  64   tc <- newIOTick
  65   (boardCont, boardMapRV, layerMapRV, phRVMapRV) <-
  66     createNotebook boardQueue tc addLayerRV rmLayerRV
  67     statMCBMVar dynMCBMVar synthMCBMVar guiCellMCBMVar
  68   boxPackStart mainBox boardCont PackNatural 0
  69
  70   --handleSaveLoad tempoRV boardMapRV layerMapRV instrMapRV phRVMapRV
  71     --addLayerRV rmLayerRV confSaveRV confLoadRV
  72
  73   {-
  74   reactiveValueOnCanRead boardStatusRV $ do
  75     bs <- reactiveValueRead boardStatusRV
  76     case bs of
  77       Running -> reactiveValueWrite statConfSensitiveRV False
  78       Stopped -> reactiveValueWrite statConfSensitiveRV True
  79 -}
  80   boardStatusEP <- getEPfromRV boardStatusRV
  81   reactiveValueOnCanRead playRV $ reactiveValueWrite boardStatusRV Running
  82   reactiveValueOnCanRead stopRV $ reactiveValueWrite boardStatusRV Stopped
  83   let tempoRV' = liftR2 (\paused tempo -> if paused then 0 else tempo)
  84                  pauseRV tempoRV
  85       jointedMapRV = liftR (fmap (\(x,y) -> (x,y,NoEvent))) $
  86                      liftR2 (M.intersectionWith (,)) boardMapRV layerMapRV
  87       inRV = liftR3 (,,) tempoRV' boardStatusEP jointedMapRV
  88   initSig <- reactiveValueRead layerMapRV
  89   --(inBoard, outBoard) <- yampaReactiveDual initSig (boardRun
  90     --initSig)
  91   outBoard <- yampaReactiveWithMetronome (layers initSig) inRV 15
  92   --reactiveValueOnCanRead inRV (reactiveValueRead inRV >>= print . M.keys)
  93   reactiveValueOnCanRead outBoard $ do
  94     out <- reactiveValueRead outBoard
  95     --print out
  96     phRVMap <- reactiveValueRead phRVMapRV
  97
  98     let noteMap = M.map fromEvent $ M.filter isEvent $ M.map fst out
  99         writePh chan val =
 100           fromMaybeM_ $ fmap (`reactiveValueWrite` val)
 101                              (M.lookup chan phRVMap)
 102     sequence_ $ M.elems $ M.mapWithKey writePh $ M.map snd out
 103     reactiveValueAppend boardQueue $ M.map (,[]) noteMap
 104
 105   putStrLn "Board started."
 106
 107   forkIO $ jackSetup tc boardQueue tempoRV layerMapRV
 108
 109   widgetShowAll window
 110   ------------------------------------------------------------
 111
 112   boxPackStart settingsBox noteSettingsBox PackNatural 10
 113   onDestroy window mainQuit
 114   mainGUI