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           Graphics.UI.Gtk.Board.BoardLink
  11 import           Graphics.UI.Gtk.Layout.BackgroundContainer
  12 import           Hails.Yampa
  13 import           RMCA.Auxiliary
  14 --import           RMCA.Configuration
  15 import           RMCA.EventProvider
  16 import           RMCA.Global.Clock
  17 import           RMCA.GUI.Board
  18 import           RMCA.GUI.Buttons
  19 import           RMCA.GUI.LayerSettings
  20 import           RMCA.GUI.MainSettings
  21 import           RMCA.GUI.MultiBoard
  22 import           RMCA.GUI.NoteSettings
  23 import           RMCA.IOClockworks
  24 import           RMCA.Layer.Board
  25 import           RMCA.Layer.LayerConf
  26 import           RMCA.Semantics
  27 import           RMCA.Translator.Jack
  28 import           RMCA.YampaReactive
  29
  30 main :: IO ()
  31 main = do
  32   ------------------------------------------------------------------------------
  33   -- Main GUI
  34   ------------------------------------------------------------------------------
  35   initGUI
  36   window <- windowNew
  37   -- Main box
  38   mainBox <- hBoxNew False 10
  39   set window [ windowTitle := "Reactogon"
  40              , containerChild := mainBox
  41              , containerBorderWidth := 10
  42              ]
  43   windowMaximize window
  44
  45   settingsBox <- vBoxNew False 0
  46   boxPackEnd mainBox settingsBox PackNatural 0
  47   (globalSettingsBox, tempoRV) <- globalSettings
  48   boxPackStart settingsBox globalSettingsBox PackNatural 0
  49   globalSep <- hSeparatorNew
  50   boxPackStart settingsBox globalSep PackNatural 10
  51
  52   (buttonBox,
  53    playRV,stopRV,pauseRV,recordRV,
  54    confSaveRV,confLoadRV,
  55    addLayerRV,rmLayerRV) <- getButtons
  56   boxPackEnd settingsBox buttonBox PackNatural 0
  57
  58   boardQueue <- newCBMVarRW mempty
  59   (layerSettingsVBox, statMCBMVar, dynMCBMVar, synthMCBMVar) <- layerSettings
  60   boxPackStart settingsBox layerSettingsVBox PackNatural 0
  61   laySep <- hSeparatorNew
  62   boxPackStart settingsBox laySep PackNatural 0
  63
  64   (noteSettingsBox, guiCellMCBMVar) <- noteSettingsBox
  65   tc <- newIOTick
  66   (boardCont, boardMapRV, layerMapRV, phRVMapRV) <-
  67     createNotebook boardQueue tc addLayerRV rmLayerRV
  68     statMCBMVar dynMCBMVar synthMCBMVar guiCellMCBMVar
  69   boxPackStart mainBox boardCont PackNatural 0
  70
  71   --handleSaveLoad tempoRV boardMapRV layerMapRV instrMapRV phRVMapRV
  72     --addLayerRV rmLayerRV confSaveRV confLoadRV
  73
  74   boardStatusRV <- getEPfromRV =<< newCBMVarRW Stopped
  75   isStartMVar <- newMVar False
  76   reactiveValueOnCanRead playRV $ do
  77     isStarted <- readMVar isStartMVar
  78     if isStarted
  79       then reactiveValueWrite boardStatusRV $ Event Running
  80       else do modifyMVar_ isStartMVar $ const $ return True
  81               reactiveValueWrite boardStatusRV $ Event Running
  82   reactiveValueOnCanRead stopRV $ do
  83     modifyMVar_ isStartMVar $ const $ return False
  84     reactiveValueWrite boardStatusRV $ Event Stopped
  85   boardMap <- reactiveValueRead boardMapRV
  86   layerMap <- reactiveValueRead layerMapRV
  87   tempo <- reactiveValueRead tempoRV
  88   let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
  89       jointedMapRV = liftR (fmap (\(x,y) -> (x,y,NoEvent))) $
  90                      liftR2 (M.intersectionWith (,)) boardMapRV layerMapRV
  91       inRV = liftR3 (,,) tempoRV' boardStatusRV jointedMapRV
  92   initSig <- reactiveValueRead layerMapRV
  93   --(inBoard, outBoard) <- yampaReactiveDual initSig (boardRun
  94     --initSig)
  95   outBoard <- yampaReactiveFrom (layers initSig) inRV
  96   --reactiveValueOnCanRead inRV (reactiveValueRead inRV >>= print . M.keys)
  97   --inRV =:> inBoard
  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
 111 {-
 112     reactiveValueRead (liftR (event mempty (,[]) <<< snd <<< splitE) outBoard) >>=
 113       reactiveValueAppend boardQueue-}
 114   -- This needs to be set last otherwise phRV is written to, so
 115   -- inBoard is written to and the notes don't get played. There
 116   -- supposedly is no guaranty of order but apparently there is…
 117   putStrLn "Board started."
 118   -- Jack setup
 119   forkIO $ jackSetup tc boardQueue tempoRV
 120
 121   widgetShowAll window
 122   ------------------------------------------------------------
 123
 124   boxPackStart settingsBox noteSettingsBox PackNatural 10
 125   onDestroy window mainQuit
 126   mainGUI