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   --reactiveValueOnCanRead inRV (reactiveValueRead inRV >>= print . M.keys)
  83   inRV =:> inBoard
  84   reactiveValueOnCanRead outBoard $ do
  85     out <- reactiveValueRead outBoard
  86     --print out
  87     phRVMap <- reactiveValueRead phRVMapRV
  88
  89     let eventsMap = M.filter isEvent out
  90         writePh chan val =
  91           fromMaybeM_ $ fmap (\ph -> reactiveValueWrite ph val) $
  92           M.lookup chan phRVMap
  93         noteMap = M.map ((\ev -> if isEvent ev then fromEvent ev else []) . snd . splitE) out
  94     sequence_ $ M.mapWithKey writePh $
  95       M.map (fst . fromEvent) $ M.filter isEvent out
  96
  97     --reactiveValueAppend boardQueue $ M.map (,[]) noteMap
  98
  99
 100 {-
 101     reactiveValueRead (liftR (event mempty (,[]) <<< snd <<< splitE) outBoard) >>=
 102       reactiveValueAppend boardQueue-}
 103   -- This needs to be set last otherwise phRV is written to, so
 104   -- inBoard is written to and the notes don't get played. There
 105   -- supposedly is no guaranty of order but apparently there is…
 106   putStrLn "Board started."
 107   -- Jack setup
 108   --forkIO $ jackSetup tempoRV boardQueue
 109
 110   widgetShowAll window
 111   ------------------------------------------------------------
 112
 113   boxPackStart settingsBox noteSettingsBox PackNatural 10
 114   onDestroy window mainQuit
 115   mainGUI