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.RV
  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.Semantics
  21 import RMCA.Translator.Jack
  22
  23 main :: IO ()
  24 main = do
  25   -- GUI
  26   initGUI
  27   window <- windowNew
  28   -- Main box
  29   mainBox <- hBoxNew False 10
  30   set window [ windowTitle := "Reactogon"
  31              , containerChild := mainBox
  32              , containerBorderWidth := 10
  33              ]
  34   windowMaximize window
  35
  36   boardQueue <- newCBMVarRW mempty
  37   chanRV <- newCBMVarRW 0
  38
  39   settingsBox <- vBoxNew False 0
  40   boxPackEnd mainBox settingsBox PackNatural 0
  41   (globalSettingsBox, tempoRV) <- globalSettings
  42   boxPackStart settingsBox globalSettingsBox PackNatural 0
  43   globalSep <- hSeparatorNew
  44   boxPackStart settingsBox globalSep PackNatural 0
  45
  46   (layerSettingsVBox, layerRV) <- 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) <- getButtons
  52   boxPackEnd settingsBox buttonBox PackNatural 0
  53
  54   -- Board
  55   boardCont <- backgroundContainerNew
  56   game <- initGame
  57   guiBoard <- attachGameRules game
  58   centerBoard <- alignmentNew 0.5 0.5 0 0
  59   containerAdd centerBoard guiBoard
  60   containerAdd boardCont centerBoard
  61   boxPackStart mainBox boardCont PackNatural 0
  62   --boxPackStart mainBox boardCont PackNatural 0
  63   ------------------------------------------------------------------------------
  64   -- Board setup
  65   layer <- reactiveValueRead layerRV
  66   tempo <- reactiveValueRead tempoRV
  67   (boardRV, pieceArrRV, phRV) <- initBoardRV guiBoard
  68   reactiveValueOnCanRead playRV
  69     (reactiveValueRead boardRV >>= reactiveValueWrite phRV . startHeads)
  70   reactiveValueOnCanRead stopRV $ reactiveValueWrite phRV []
  71   board <- reactiveValueRead boardRV
  72   ph <- reactiveValueRead phRV
  73   (inBoard, outBoard) <- yampaReactiveDual (board, layer, ph, tempo) boardSF
  74   let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
  75       inRV = liftR4 id
  76              boardRV layerRV phRV tempoRV'
  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   -- Piece characteristic
  92   --pieceBox <- pieceButtons pieceArrRV guiBoard =<< vBoxNew False 10
  93   ------------------------------------------------------------
  94
  95   boxPackStart settingsBox pieceBox PackNatural 10
  96   onDestroy window mainQuit
  97   mainGUI