src/RMCA/Main.hs

   1 {-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, TupleSections #-}
   2
   3 module Main where
   4
   5 import Control.Concurrent
   6 import Data.ReactiveValue
   7 import FRP.Yampa
   8 import Graphics.UI.Gtk
   9 import Graphics.UI.Gtk.Board.BoardLink
  10 import Graphics.UI.Gtk.Layout.BackgroundContainer
  11 import Hails.Yampa
  12 import RMCA.Auxiliary
  13 import RMCA.Configuration
  14 import RMCA.GUI.Board
  15 import RMCA.GUI.Buttons
  16 import RMCA.GUI.LayerSettings
  17 import RMCA.GUI.MainSettings
  18 import RMCA.GUI.MultiBoard
  19 import RMCA.GUI.NoteSettings
  20 import RMCA.Layer.Board
  21 import RMCA.Translator.Jack
  22
  23 main :: IO ()
  24 main = do
  25   ------------------------------------------------------------------------------
  26   -- Main GUI
  27   ------------------------------------------------------------------------------
  28   initGUI
  29   window <- windowNew
  30   -- Main box
  31   mainBox <- hBoxNew False 10
  32   set window [ windowTitle := "Reactogon"
  33              , containerChild := mainBox
  34              , containerBorderWidth := 10
  35              ]
  36   windowMaximize window
  37
  38   settingsBox <- vBoxNew False 0
  39   boxPackEnd mainBox settingsBox PackNatural 0
  40   (globalSettingsBox, tempoRV) <- globalSettings
  41   boxPackStart settingsBox globalSettingsBox PackNatural 0
  42   globalSep <- hSeparatorNew
  43   boxPackStart settingsBox globalSep PackNatural 0
  44
  45   (   buttonBox
  46     , playRV, stopRV, pauseRV, recordRV
  47     , confSaveRV, confLoadRV
  48     , addLayerRV, rmLayerRV ) <- getButtons
  49   boxPackEnd settingsBox buttonBox PackNatural 0
  50
  51   boardQueue <- newCBMVarRW mempty
  52   (layerSettingsVBox, layerMCBMVar, instrMCBMVar) <- layerSettings boardQueue
  53   boxPackStart settingsBox layerSettingsVBox PackNatural 0
  54   laySep <- hSeparatorNew
  55   boxPackStart settingsBox laySep PackNatural 0
  56
  57   (noteSettingsBox, guiCellMCBMVar) <- noteSettingsBox
  58   (boardCont, chanMapRV, _{-curPageRV-}) <- createNotebook addLayerRV rmLayerRV
  59                                        layerMCBMVar guiCellMCBMVar
  60   boxPackStart mainBox boardCont PackNatural 0
  61
  62   --handleSaveLoad tempoRV boardRV layerRV instrRV pieceArrRV confSaveRV confLoadRV
  63 {-
  64   boardRunRV <- newCBMVarRW BoardStop
  65   reactiveValueOnCanRead playRV $ reactiveValueWrite boardRunRV BoardStart
  66   reactiveValueOnCanRead stopRV $ reactiveValueWrite boardRunRV BoardStop
  67   board <- reactiveValueRead boardRV
  68   layer <- reactiveValueRead layerRV
  69   tempo <- reactiveValueRead tempoRV
  70   (inBoard, outBoard) <- yampaReactiveDual (board, layer, tempo, BoardStop) boardSF
  71   let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
  72       inRV = liftR4 (,,,)
  73              boardRV layerRV tempoRV' boardRunRV
  74   inRV =:> inBoard
  75   reactiveValueOnCanRead outBoard $
  76     reactiveValueRead (liftR (event mempty (,[]) <<< snd <<< splitE) outBoard) >>=
  77     reactiveValueAppend boardQueue
  78   -- This needs to be set last otherwise phRV is written to, so
  79   -- inBoard is written to and the notes don't get played. There
  80   -- supposedly is no guaranty of order but apparently there is…
  81   fmap fst <^> outBoard >:> phRV
  82   putStrLn "Board started."
  83   -- Jack setup
  84   forkIO $ jackSetup tempoRV chanRV boardQueue
  85 -}
  86   widgetShowAll window
  87   ------------------------------------------------------------
  88
  89   boxPackStart settingsBox noteSettingsBox PackNatural 10
  90   onDestroy window mainQuit
  91   mainGUI