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, playRV, stopRV, pauseRV, recordRV) <- getButtons
 101   boxPackEnd settingsBox buttonBox PackNatural 0
 102
 103   -- Board
 104   boardCont <- backgroundContainerNew
 105   game <- initGame
 106   guiBoard <- attachGameRules game
 107   centerBoard <- alignmentNew 0.5 0.5 0 0
 108   containerAdd centerBoard guiBoard
 109   containerAdd boardCont centerBoard
 110   boxPackStart mainBox boardCont PackNatural 0
 111   --boxPackStart mainBox boardCont PackNatural 0
 112   ------------------------------------------------------------------------------
 113   boardQueue <- newCBMVarRW []
 114   -- Board setup
 115   layer <- reactiveValueRead layerRV
 116   tempo <- reactiveValueRead tempoRV
 117   (boardRV, pieceArrRV, phRV) <- initBoardRV guiBoard
 118   reactiveValueOnCanRead playRV
 119     (reactiveValueRead boardRV >>= reactiveValueWrite phRV . startHeads)
 120   reactiveValueOnCanRead stopRV $ reactiveValueWrite phRV []
 121   board <- reactiveValueRead boardRV
 122   ph <- reactiveValueRead phRV
 123   (inBoard, outBoard) <- yampaReactiveDual (board, layer, ph, tempo) boardSF
 124   let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
 125       inRV = liftR4 id
 126              boardRV layerRV phRV tempoRV'
 127   --let inRV = onTick clock inRV
 128   inRV =:> inBoard
 129   reactiveValueOnCanRead outBoard $ do
 130     bq <- reactiveValueRead boardQueue
 131     ob <- reactiveValueRead $ liftR (event [] id <<< snd <<< splitE) outBoard
 132     reactiveValueWrite boardQueue (bq ++ ob)
 133   -- This needs to be set last otherwise phRV is written to, so
 134   -- inBoard is written to and the notes don't get played. There
 135   -- supposedly is no guaranty of order but apparently there is…
 136   (fst <$>) <^> outBoard >:> phRV
 137   putStrLn "Board started."
 138   -- Jack setup
 139   forkIO $ jackSetup tempoRV (constR 0) boardQueue
 140   widgetShowAll window
 141   pieceBox <- clickHandling pieceArrRV guiBoard =<< vBoxNew False 10
 142   -- Piece characteristic
 143   --pieceBox <- pieceButtons pieceArrRV guiBoard =<< vBoxNew False 10
 144   ------------------------------------------------------------
 145
 146   boxPackStart settingsBox pieceBox PackNatural 10
 147   onDestroy window mainQuit
 148   mainGUI