src/RMCA/Main.hs

   1 {-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-}
   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 Graphics.UI.Gtk.Reactive
  12 import Hails.Yampa
  13 import RMCA.Auxiliary.RV
  14 import RMCA.GUI.Board
  15 import RMCA.GUI.Buttons
  16 import RMCA.GUI.MainSettings
  17 import RMCA.GUI.NoteSettings
  18 import RMCA.Layer.Board
  19 import RMCA.Layer.Layer
  20 import RMCA.Semantics
  21 import RMCA.Translator.Jack
  22
  23 floatConv :: (ReactiveValueReadWrite a b m,
  24               Real c, Real b, Fractional c, Fractional b) =>
  25              a -> ReactiveFieldReadWrite m c
  26 floatConv = liftRW $ bijection (realToFrac, realToFrac)
  27
  28 main :: IO ()
  29 main = do
  30   -- GUI
  31   initGUI
  32   window <- windowNew
  33   -- Main box
  34   mainBox <- hBoxNew False 10
  35   set window [ windowTitle := "Reactogon"
  36              --, windowDefaultWidth := 250
  37              --, windowDefaultHeight := 500
  38              , containerChild := mainBox
  39              , containerBorderWidth := 10
  40              ]
  41   windowMaximize window
  42
  43   settingsBox <- vBoxNew False 0
  44   boxPackEnd mainBox settingsBox PackNatural 0
  45   (globalSettingsBox, tempoRV) <- globalSettings
  46   boxPackStart settingsBox globalSettingsBox PackNatural 0
  47   globalSep <- hSeparatorNew
  48   boxPackStart settingsBox globalSep PackNatural 0
  49
  50   layerSettingsBox <- hBoxNew True 10
  51   boxPackStart settingsBox layerSettingsBox PackNatural 0
  52
  53   layTempoBox <- hBoxNew False 10
  54   boxPackStart layerSettingsBox layTempoBox PackNatural 0
  55   layTempoLabel <- labelNew (Just "Layer tempo")
  56   labelSetAngle layTempoLabel 90
  57   boxPackStart layTempoBox layTempoLabel PackNatural 0
  58   layTempoAdj <- adjustmentNew 1 0 2 1 1 1
  59   layTempoScale <- vScaleNew layTempoAdj
  60   boxPackStart layTempoBox layTempoScale PackNatural 0
  61   laySep <- hSeparatorNew
  62
  63   strBox <- hBoxNew False 10
  64   boxPackStart layerSettingsBox strBox PackNatural 0
  65   strLabel <- labelNew (Just "Strength")
  66   labelSetAngle strLabel 90
  67   boxPackStart strBox strLabel PackNatural 0
  68   strAdj <- adjustmentNew 1 0 1 0.01 0.01 0
  69   layStrengthScale <- vScaleNew strAdj
  70   boxPackStart strBox layStrengthScale PackNatural 0
  71
  72   bpbBox <- vBoxNew False 10
  73   boxPackStart layerSettingsBox bpbBox PackNatural 0
  74   bpbLabel <- labelNew (Just "Beat per bar")
  75   labelSetLineWrap bpbLabel True
  76   boxPackStart bpbBox bpbLabel PackNatural 0
  77   bpbAdj <- adjustmentNew 4 1 16 1 1 0
  78   bpbButton <- spinButtonNew bpbAdj 1 0
  79   boxPackStart bpbBox bpbButton PackNatural 0
  80
  81   boxPackStart settingsBox laySep PackNatural 0
  82
  83   layPitchRV <- newCBMVarRW 1
  84   let layTempoRV = floatConv $ scaleValueReactive layTempoScale
  85       strengthRV = floatConv $  scaleValueReactive layStrengthScale
  86       bpbRV = spinButtonValueIntReactive bpbButton
  87       f1 Layer { relTempo = d
  88                , relPitch = p
  89                , strength = s
  90                , beatsPerBar = bpb
  91                } = (d,p,s,bpb)
  92       f2 (d,p,s,bpb) = Layer { relTempo = d
  93                              , relPitch = p
  94                              , strength = s
  95                              , beatsPerBar = bpb
  96                              }
  97       layerRV =
  98         liftRW4 (bijection (f1,f2)) layTempoRV layPitchRV strengthRV bpbRV
  99
 100   buttonBox <- hBoxNew True 10
 101   boxPackEnd settingsBox buttonBox PackNatural 0
 102   buttonPlay <- buttonNewFromStock gtkMediaPlay
 103   let playRV = buttonActivateField buttonPlay
 104   boxPackStart buttonBox buttonPlay PackRepel 0
 105   buttonPause <- buttonNewFromStock gtkMediaPause
 106   boxPackStart buttonBox buttonPause PackRepel 0
 107   buttonStop <- buttonNewFromStock gtkMediaStop
 108   let stopRV = buttonActivateField buttonStop
 109   boxPackStart buttonBox buttonStop PackRepel 0
 110   buttonRecord <- buttonNewFromStock gtkMediaRecord
 111   boxPackStart buttonBox buttonRecord PackRepel 0
 112
 113   -- Board
 114   boardCont <- backgroundContainerNew
 115   game <- initGame
 116   guiBoard <- attachGameRules game
 117   centerBoard <- alignmentNew 0.5 0.5 0 0
 118   containerAdd centerBoard guiBoard
 119   containerAdd boardCont centerBoard
 120   boxPackStart mainBox boardCont PackNatural 0
 121   --boxPackStart mainBox boardCont PackNatural 0
 122   ------------------------------------------------------------------------------
 123   boardQueue <- newCBMVarRW []
 124   -- Board setup
 125   layer <- reactiveValueRead layerRV
 126   tempo <- reactiveValueRead tempoRV
 127   (boardRV, pieceArrRV, phRV) <- initBoardRV guiBoard
 128   reactiveValueOnCanRead playRV
 129     (reactiveValueRead boardRV >>= reactiveValueWrite phRV . startHeads)
 130   reactiveValueOnCanRead stopRV $ reactiveValueWrite phRV []
 131   board <- reactiveValueRead boardRV
 132   ph <- reactiveValueRead phRV
 133   (inBoard, outBoard) <- yampaReactiveDual (board, layer, ph, tempo) boardSF
 134   let inRV = liftR4 id
 135              boardRV layerRV phRV tempoRV
 136   --let inRV = onTick clock inRV
 137   inRV =:> inBoard
 138   reactiveValueOnCanRead outBoard $ do
 139     bq <- reactiveValueRead boardQueue
 140     ob <- reactiveValueRead $ liftR (event [] id <<< snd <<< splitE) outBoard
 141     reactiveValueWrite boardQueue (bq ++ ob)
 142   -- This needs to be set last otherwise phRV is written to, so
 143   -- inBoard is written to and the notes don't get played. There
 144   -- supposedly is no guaranty of order but apparently there is…
 145   (fst <$>) <^> outBoard >:> phRV
 146   putStrLn "Board started."
 147   -- Jack setup
 148   forkIO $ jackSetup tempoRV (constR 0) boardQueue
 149   widgetShowAll window
 150   pieceBox <- clickHandling pieceArrRV guiBoard =<< vBoxNew False 10
 151   -- Piece characteristic
 152   --pieceBox <- pieceButtons pieceArrRV guiBoard =<< vBoxNew False 10
 153   ------------------------------------------------------------
 154
 155   boxPackStart settingsBox pieceBox PackNatural 10
 156   onDestroy window mainQuit
 157   mainGUI