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.Auxiliary
  15 import           RMCA.Configuration
  16 import           RMCA.GUI.Board
  17 import           RMCA.GUI.Buttons
  18 import           RMCA.GUI.LayerSettings
  19 import           RMCA.GUI.MainSettings
  20 import           RMCA.GUI.MultiBoard
  21 import           RMCA.GUI.NoteSettings
  22 import           RMCA.Layer.Board
  23 import           RMCA.Layer.Layer
  24 import           RMCA.Semantics
  25 import           RMCA.Translator.Jack
  26
  27 main :: IO ()
  28 main = do
  29   ------------------------------------------------------------------------------
  30   -- Main GUI
  31   ------------------------------------------------------------------------------
  32   initGUI
  33   window <- windowNew
  34   -- Main box
  35   mainBox <- hBoxNew False 10
  36   set window [ windowTitle := "Reactogon"
  37              , containerChild := mainBox
  38              , containerBorderWidth := 10
  39              ]
  40   windowMaximize window
  41
  42   settingsBox <- vBoxNew False 0
  43   boxPackEnd mainBox settingsBox PackNatural 0
  44   (globalSettingsBox, tempoRV) <- globalSettings
  45   boxPackStart settingsBox globalSettingsBox PackNatural 0
  46   globalSep <- hSeparatorNew
  47   boxPackStart settingsBox globalSep PackNatural 0
  48
  49   (buttonBox,
  50    playRV,stopRV,pauseRV,recordRV,
  51    confSaveRV,confLoadRV,
  52    addLayerRV,rmLayerRV) <- getButtons
  53   boxPackEnd settingsBox buttonBox PackNatural 0
  54
  55   boardQueue <- newCBMVarRW mempty
  56   (layerSettingsVBox, layerMCBMVar, instrMCBMVar) <- layerSettings boardQueue
  57   boxPackStart settingsBox layerSettingsVBox PackNatural 0
  58   laySep <- hSeparatorNew
  59   boxPackStart settingsBox laySep PackNatural 0
  60
  61   (noteSettingsBox, guiCellMCBMVar) <- noteSettingsBox
  62   (boardCont, boardMapRV, layerMapRV, phRVMapRV) <- createNotebook
  63                                                     addLayerRV rmLayerRV
  64                                                     layerMCBMVar guiCellMCBMVar
  65   boxPackStart mainBox boardCont PackNatural 0
  66
  67   --handleSaveLoad tempoRV boardRV layerRV instrRV pieceArrRV confSaveRV confLoadRV
  68
  69   boardRunRV <- newCBMVarRW BoardStop
  70   reactiveValueOnCanRead playRV $ reactiveValueWrite boardRunRV BoardStart
  71   reactiveValueOnCanRead stopRV $ reactiveValueWrite boardRunRV BoardStop
  72   boardMap <- reactiveValueRead boardMapRV
  73   layerMap <- reactiveValueRead layerMapRV
  74   tempo <- reactiveValueRead tempoRV
  75   let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
  76       inRV :: ReactiveFieldRead IO (M.IntMap (Board,Layer,Tempo,BoardRun))
  77       inRV = liftR4 (\bm lm t br -> M.map (\(b,l) -> (b,l,t,br)) $
  78                       M.intersectionWith (,) bm lm)
  79              boardMapRV layerMapRV tempoRV' boardRunRV
  80   initSF <- reactiveValueRead inRV
  81   (inBoard, outBoard) <- yampaReactiveDual initSF (boardRun initSF)
  82   inRV =:> inBoard
  83   reactiveValueOnCanRead outBoard $ do
  84     out <- reactiveValueRead outBoard
  85     phRVMap <- reactiveValueRead phRVMapRV
  86
  87     let eventsMap = M.filter isEvent out
  88         writePh chan val =
  89           fromMaybeM_ $ fmap (\ph -> reactiveValueWrite ph val) $
  90           M.lookup chan phRVMap
  91         noteMap = M.map ((\ev -> if isEvent ev then fromEvent ev else []) . snd . splitE) out
  92     sequence_ $ M.mapWithKey writePh $
  93       M.map (fst . fromEvent) $ M.filter isEvent out
  94
  95     --reactiveValueAppend boardQueue $ M.map (,[]) noteMap
  96
  97
  98 {-
  99     reactiveValueRead (liftR (event mempty (,[]) <<< snd <<< splitE) outBoard) >>=
 100       reactiveValueAppend boardQueue-}
 101   -- This needs to be set last otherwise phRV is written to, so
 102   -- inBoard is written to and the notes don't get played. There
 103   -- supposedly is no guaranty of order but apparently there is…
 104   putStrLn "Board started."
 105   -- Jack setup
 106   --forkIO $ jackSetup tempoRV boardQueue
 107
 108   widgetShowAll window
 109   ------------------------------------------------------------
 110
 111   boxPackStart settingsBox noteSettingsBox PackNatural 10
 112   onDestroy window mainQuit
 113   mainGUI