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.GUI.Board
  16 import           RMCA.GUI.Buttons
  17 import           RMCA.GUI.LayerSettings
  18 import           RMCA.GUI.MainSettings
  19 import           RMCA.GUI.MultiBoard
  20 import           RMCA.GUI.NoteSettings
  21 import           RMCA.Layer.Board
  22 import           RMCA.Layer.Layer
  23 import           RMCA.Semantics
  24 import           RMCA.Translator.Jack
  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 PackNatural 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 <- newCBMVarRW mempty
  55   (layerSettingsVBox, layerMCBMVar, instrMCBMVar) <- layerSettings boardQueue
  56   boxPackStart settingsBox layerSettingsVBox PackNatural 0
  57   laySep <- hSeparatorNew
  58   boxPackStart settingsBox laySep PackNatural 0
  59
  60   (noteSettingsBox, guiCellMCBMVar) <- noteSettingsBox
  61   (boardCont, boardMapRV, layerMapRV, phRVMapRV) <- createNotebook
  62                                                     addLayerRV rmLayerRV
  63                                                     layerMCBMVar guiCellMCBMVar
  64   boxPackStart mainBox boardCont PackNatural 0
  65
  66   --handleSaveLoad tempoRV boardRV layerRV instrRV pieceArrRV confSaveRV confLoadRV
  67
  68   boardRunRV <- newCBMVarRW BoardStop
  69   reactiveValueOnCanRead playRV $ reactiveValueWrite boardRunRV BoardStart
  70   reactiveValueOnCanRead stopRV $ reactiveValueWrite boardRunRV BoardStop
  71   boardMap <- reactiveValueRead boardMapRV
  72   layerMap <- reactiveValueRead layerMapRV
  73   tempo <- reactiveValueRead tempoRV
  74   let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
  75       inRV = liftR4 (\bm lm t br -> (t,br,M.intersectionWith (,) bm lm))
  76              boardMapRV layerMapRV tempoRV' boardRunRV
  77   initSig <- reactiveValueRead inRV
  78   (inBoard, outBoard) <- yampaReactiveDual initSig (boardRun initSig)
  79   --reactiveValueOnCanRead inRV (reactiveValueRead inRV >>= print . M.keys)
  80   inRV =:> inBoard
  81   reactiveValueOnCanRead outBoard $ do
  82     out <- reactiveValueRead outBoard
  83     --print out
  84     phRVMap <- reactiveValueRead phRVMapRV
  85
  86     let eventsMap = M.filter isEvent out
  87         writePh chan val =
  88           fromMaybeM_ $ (`reactiveValueWrite` val) <$>
  89           M.lookup chan phRVMap
  90         noteMap = M.map (eventToList . snd . splitE) out
  91     sequence_ $ M.mapWithKey writePh $
  92       M.map (fst . fromEvent) $ M.filter isEvent out
  93     reactiveValueAppend boardQueue $ M.map (,[]) noteMap
  94
  95
  96 {-
  97     reactiveValueRead (liftR (event mempty (,[]) <<< snd <<< splitE) outBoard) >>=
  98       reactiveValueAppend boardQueue-}
  99   -- This needs to be set last otherwise phRV is written to, so
 100   -- inBoard is written to and the notes don't get played. There
 101   -- supposedly is no guaranty of order but apparently there is…
 102   putStrLn "Board started."
 103   -- Jack setup
 104   forkIO $ jackSetup boardQueue tempoRV
 105
 106   widgetShowAll window
 107   ------------------------------------------------------------
 108
 109   boxPackStart settingsBox noteSettingsBox PackNatural 10
 110   onDestroy window mainQuit
 111   mainGUI