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   (buttonBox,
  48    playRV,stopRV,pauseRV,recordRV,
  49    confSaveRV,confLoadRV,
  50    addLayerRV,rmLayerRV) <- getButtons
  51   boxPackEnd settingsBox buttonBox PackNatural 0
  52
  53   boardQueue <- newCBRef mempty
  54   (layerSettingsVBox, statConfSensitiveRV, statMCBMVar, dynMCBMVar, synthMCBMVar) <- layerSettings
  55   boxPackStart settingsBox layerSettingsVBox PackNatural 0
  56   laySep <- hSeparatorNew
  57   boxPackStart settingsBox laySep PackNatural 0
  58
  59   (noteSettingsBox, guiCellMCBMVar) <- noteSettingsBox
  60   tc <- newIOTick
  61   (boardCont, boardMapRV, layerMapRV, phRVMapRV) <-
  62     createNotebook boardQueue tc addLayerRV rmLayerRV
  63     statMCBMVar dynMCBMVar synthMCBMVar guiCellMCBMVar
  64   boxPackStart mainBox boardCont PackNatural 0
  65
  66   --handleSaveLoad tempoRV boardMapRV layerMapRV instrMapRV phRVMapRV
  67     --addLayerRV rmLayerRV confSaveRV confLoadRV
  68
  69   boardStatusRV <- newCBMVarRW Stopped
  70   reactiveValueOnCanRead boardStatusRV $ do
  71     bs <- reactiveValueRead boardStatusRV
  72     case bs of
  73       Running -> reactiveValueWrite statConfSensitiveRV False
  74       Stopped -> reactiveValueWrite statConfSensitiveRV True
  75
  76   boardStatusEP <- getEPfromRV boardStatusRV
  77   isStartMVar <- newMVar False
  78   reactiveValueOnCanRead playRV $ do
  79     isStarted <- readMVar isStartMVar
  80     if isStarted
  81       then reactiveValueWrite boardStatusRV Running
  82       else do modifyMVar_ isStartMVar $ const $ return True
  83               reactiveValueWrite boardStatusRV Running
  84   reactiveValueOnCanRead stopRV $ do
  85     modifyMVar_ isStartMVar $ const $ return False
  86     reactiveValueWrite boardStatusRV Stopped
  87   boardMap <- reactiveValueRead boardMapRV
  88   layerMap <- reactiveValueRead layerMapRV
  89   tempo <- reactiveValueRead tempoRV
  90   let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
  91       jointedMapRV = liftR (fmap (\(x,y) -> (x,y,NoEvent))) $
  92                      liftR2 (M.intersectionWith (,)) boardMapRV layerMapRV
  93       inRV = liftR3 (,,) tempoRV' boardStatusEP jointedMapRV
  94   initSig <- reactiveValueRead layerMapRV
  95   --(inBoard, outBoard) <- yampaReactiveDual initSig (boardRun
  96     --initSig)
  97   outBoard <- yampaReactiveFrom (layers initSig) inRV
  98   --reactiveValueOnCanRead inRV (reactiveValueRead inRV >>= print . M.keys)
  99   --inRV =:> inBoard
 100   reactiveValueOnCanRead outBoard $ do
 101     out <- reactiveValueRead outBoard
 102     --print out
 103     phRVMap <- reactiveValueRead phRVMapRV
 104
 105     let noteMap = M.map fromEvent $ M.filter isEvent $ M.map fst out
 106         writePh chan val =
 107           fromMaybeM_ $ (`reactiveValueWrite` val) <$>
 108           M.lookup chan phRVMap
 109     sequence_ $ M.mapWithKey writePh $ M.map snd out
 110     reactiveValueAppend boardQueue $ M.map (,[]) noteMap
 111
 112
 113 {-
 114     reactiveValueRead (liftR (event mempty (,[]) <<< snd <<< splitE) outBoard) >>=
 115       reactiveValueAppend boardQueue-}
 116   -- This needs to be set last otherwise phRV is written to, so
 117   -- inBoard is written to and the notes don't get played. There
 118   -- supposedly is no guaranty of order but apparently there is…
 119   putStrLn "Board started."
 120   -- Jack setup
 121   forkIO $ jackSetup tc boardQueue tempoRV
 122
 123   widgetShowAll window
 124   ------------------------------------------------------------
 125
 126   boxPackStart settingsBox noteSettingsBox PackNatural 10
 127   onDestroy window mainQuit
 128   mainGUI