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.NoteSettings
  19 import RMCA.Layer.Board
  20 import RMCA.Translator.Jack
  21
  22 main :: IO ()
  23 main = do
  24   ------------------------------------------------------------------------------
  25   -- Main GUI
  26   ------------------------------------------------------------------------------
  27   initGUI
  28   window <- windowNew
  29   -- Main box
  30   mainBox <- hBoxNew False 10
  31   set window [ windowTitle := "Reactogon"
  32              , containerChild := mainBox
  33              , containerBorderWidth := 10
  34              ]
  35   windowMaximize window
  36
  37   settingsBox <- vBoxNew False 0
  38   boxPackEnd mainBox settingsBox PackNatural 0
  39   (globalSettingsBox, tempoRV) <- globalSettings
  40   boxPackStart settingsBox globalSettingsBox PackNatural 0
  41   globalSep <- hSeparatorNew
  42   boxPackStart settingsBox globalSep PackNatural 0
  43
  44   boardQueue <- newCBMVarRW mempty
  45   chanRV <- newCBMVarRW 0
  46   (layerSettingsVBox, layerRV, instrRV) <- layerSettings chanRV boardQueue
  47   boxPackStart settingsBox layerSettingsVBox PackNatural 0
  48   laySep <- hSeparatorNew
  49   boxPackStart settingsBox laySep PackNatural 0
  50
  51   (buttonBox, playRV, stopRV, pauseRV, recordRV, confSaveRV, confLoadRV) <- getButtons
  52   boxPackEnd settingsBox buttonBox PackNatural 0
  53
  54   -- Board
  55   boardCont <- backgroundContainerNew
  56   guiBoard <- attachGameRules =<< initGame
  57   centerBoard <- alignmentNew 0.5 0.5 0 0
  58   containerAdd centerBoard guiBoard
  59   containerAdd boardCont centerBoard
  60   boxPackStart mainBox boardCont PackNatural 0
  61   ------------------------------------------------------------------------------
  62   -- Board setup
  63   layer <- reactiveValueRead layerRV
  64   tempo <- reactiveValueRead tempoRV
  65   (boardRV, pieceArrRV, phRV) <- initBoardRV guiBoard
  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   board <- reactiveValueRead boardRV
  73   (inBoard, outBoard) <- yampaReactiveDual (board, layer, tempo, BoardStop) boardSF
  74   let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
  75       inRV = liftR4 (,,,)
  76              boardRV layerRV tempoRV' boardRunRV
  77   --let inRV = onTick clock inRV
  78   inRV =:> inBoard
  79   reactiveValueOnCanRead outBoard $
  80     reactiveValueRead (liftR (event mempty (,[]) <<< snd <<< splitE) outBoard) >>=
  81     reactiveValueAppend boardQueue
  82   -- This needs to be set last otherwise phRV is written to, so
  83   -- inBoard is written to and the notes don't get played. There
  84   -- supposedly is no guaranty of order but apparently there is…
  85   fmap fst <^> outBoard >:> phRV
  86   putStrLn "Board started."
  87   -- Jack setup
  88   forkIO $ jackSetup tempoRV chanRV boardQueue
  89   widgetShowAll window
  90   pieceBox <- clickHandling pieceArrRV guiBoard =<< vBoxNew False 10
  91   ------------------------------------------------------------
  92
  93   boxPackStart settingsBox pieceBox PackNatural 10
  94   onDestroy window mainQuit
  95   mainGUI