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.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   boardRunRV <- newCBMVarRW BoardStop
 105   reactiveValueOnCanRead playRV $ reactiveValueWrite boardRunRV BoardStart
 106   reactiveValueOnCanRead stopRV $ reactiveValueWrite boardRunRV BoardStop
 107   board <- reactiveValueRead boardRV
 108   (inBoard, outBoard) <- yampaReactiveDual (board, layer, tempo, BoardStop) boardSF
 109   let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
 110       inRV = liftR4 (,,,)
 111              boardRV layerRV tempoRV' boardRunRV
 112   --let inRV = onTick clock inRV
 113   inRV =:> inBoard
 114   reactiveValueOnCanRead outBoard $
 115     reactiveValueRead (liftR (event mempty (,[]) <<< snd <<< splitE) outBoard) >>=
 116     reactiveValueAppend boardQueue
 117   -- This needs to be set last otherwise phRV is written to, so
 118   -- inBoard is written to and the notes don't get played. There
 119   -- supposedly is no guaranty of order but apparently there is…
 120   fmap fst <^> outBoard >:> phRV
 121   putStrLn "Board started."
 122   -- Jack setup
 123   forkIO $ jackSetup tempoRV chanRV boardQueue
 124   widgetShowAll window
 125   pieceBox <- clickHandling pieceArrRV guiBoard =<< vBoxNew False 10
 126   -- Piece characteristic
 127   --pieceBox <- pieceButtons pieceArrRV guiBoard =<< vBoxNew False 10
 128   ------------------------------------------------------------
 129
 130   boxPackStart settingsBox pieceBox PackNatural 10
 131   onDestroy window mainQuit
 132   mainGUI