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, 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   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
  69   --fcsw <- windowNew
  70   fcs <- fileChooserDialogNew (Just "Save configuration") Nothing
  71          FileChooserActionSave [("Cancel",ResponseCancel),("Ok",ResponseOk)]
  72   --containerAdd fcsw fcs
  73   reactFilt <- fileFilterNew
  74   fileFilterAddPattern reactFilt "*.react"
  75   fileFilterSetName reactFilt "RMCA conf files."
  76   fileChooserAddFilter fcs reactFilt
  77
  78   --fclw <- windowNew
  79   fcl <- fileChooserDialogNew (Just "Load configuration") Nothing
  80          FileChooserActionOpen [("Cancel",ResponseCancel),("Ok",ResponseOk)]
  81   --containerAdd fclw fcl
  82   fileChooserAddFilter fcl reactFilt
  83
  84   reactiveValueOnCanRead confSaveRV $ postGUIAsync $ do
  85     widgetShowAll fcs
  86     let respHandle ResponseOk =
  87           fileChooserGetFilename fcs >>= fromMaybeM_ .
  88           fmap (\f -> saveConfiguration f tempoRV layerRV boardRV instrRV)
  89         respHandle _ = return ()
  90
  91     onResponse fcs (\r -> respHandle r >> widgetHide fcs)
  92     return ()
  93
  94   reactiveValueOnCanRead confLoadRV $ postGUIAsync $ do
  95     widgetShowAll fcl
  96     let respHandle ResponseOk =
  97           fileChooserGetFilename fcl >>= fromMaybeM_ .
  98           fmap (\f -> loadConfiguration f tempoRV layerRV pieceArrRV instrRV)
  99         respHandle _ = return ()
 100
 101     onResponse fcl (\r -> respHandle r >> widgetHide fcl)
 102     return ()
 103
 104   reactiveValueOnCanRead playRV
 105     (reactiveValueRead boardRV >>= reactiveValueWrite phRV . startHeads)
 106   reactiveValueOnCanRead stopRV $ reactiveValueWrite phRV []
 107   board <- reactiveValueRead boardRV
 108   ph <- reactiveValueRead phRV
 109   (inBoard, outBoard) <- yampaReactiveDual (board, layer, ph, tempo) boardSF
 110   let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
 111       inRV = liftR4 id
 112              boardRV layerRV phRV tempoRV'
 113   --let inRV = onTick clock inRV
 114   inRV =:> inBoard
 115   reactiveValueOnCanRead outBoard $
 116     reactiveValueRead (liftR (event mempty (,[]) <<< snd <<< splitE) outBoard) >>=
 117     reactiveValueAppend boardQueue
 118   -- This needs to be set last otherwise phRV is written to, so
 119   -- inBoard is written to and the notes don't get played. There
 120   -- supposedly is no guaranty of order but apparently there is…
 121   fmap fst <^> outBoard >:> phRV
 122   putStrLn "Board started."
 123   -- Jack setup
 124   forkIO $ jackSetup tempoRV chanRV boardQueue
 125   widgetShowAll window
 126   pieceBox <- clickHandling pieceArrRV guiBoard =<< vBoxNew False 10
 127   -- Piece characteristic
 128   --pieceBox <- pieceButtons pieceArrRV guiBoard =<< vBoxNew False 10
 129   ------------------------------------------------------------
 130
 131   boxPackStart settingsBox pieceBox PackNatural 10
 132   onDestroy window mainQuit
 133   mainGUI