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