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   boardQueue <- newCBMVarRW mempty
  46   chanRV <- newCBMVarRW 0
  47   (layerSettingsVBox, layerRV, instrRV) <- layerSettings chanRV boardQueue
  48   boxPackStart settingsBox layerSettingsVBox PackNatural 0
  49   laySep <- hSeparatorNew
  50   boxPackStart settingsBox laySep PackNatural 0
  51
  52   (   buttonBox
  53     , playRV, stopRV, pauseRV, recordRV
  54     , confSaveRV, confLoadRV
  55     , addLayerRV, rmLayerRV ) <- getButtons
  56   boxPackEnd settingsBox buttonBox PackNatural 0
  57
  58   (   boardCont, pieceBox
  59     , boardRV, pieceArrRV, phRV) <- createNotebook addLayerRV rmLayerRV layerRV tempoRV
  60   boxPackStart mainBox boardCont PackNatural 0
  61
  62
  63   handleSaveLoad tempoRV boardRV layerRV instrRV pieceArrRV confSaveRV confLoadRV
  64
  65   boardRunRV <- newCBMVarRW BoardStop
  66   reactiveValueOnCanRead playRV $ reactiveValueWrite boardRunRV BoardStart
  67   reactiveValueOnCanRead stopRV $ reactiveValueWrite boardRunRV BoardStop
  68   board <- reactiveValueRead boardRV
  69   layer <- reactiveValueRead layerRV
  70   tempo <- reactiveValueRead tempoRV
  71   (inBoard, outBoard) <- yampaReactiveDual (board, layer, tempo, BoardStop) boardSF
  72   let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
  73       inRV = liftR4 (,,,)
  74              boardRV layerRV tempoRV' boardRunRV
  75   --let inRV = onTick clock inRV
  76   inRV =:> inBoard
  77   reactiveValueOnCanRead outBoard $
  78     reactiveValueRead (liftR (event mempty (,[]) <<< snd <<< splitE) outBoard) >>=
  79     reactiveValueAppend boardQueue
  80   -- This needs to be set last otherwise phRV is written to, so
  81   -- inBoard is written to and the notes don't get played. There
  82   -- supposedly is no guaranty of order but apparently there is…
  83   fmap fst <^> outBoard >:> phRV
  84   putStrLn "Board started."
  85   -- Jack setup
  86   forkIO $ jackSetup tempoRV chanRV boardQueue
  87   widgetShowAll window
  88   ------------------------------------------------------------
  89
  90   boxPackStart settingsBox pieceBox PackNatural 10
  91   onDestroy window mainQuit
  92   mainGUI