src/RMCA/Main.hs

   1 {-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-}
   2
   3 module Main where
   4
   5 import Control.Concurrent
   6 import Data.ReactiveValue
   7 import Data.String
   8 import Data.Tuple
   9 import FRP.Yampa
  10 import Graphics.UI.Gtk
  11 import Graphics.UI.Gtk.Board.BoardLink
  12 import Graphics.UI.Gtk.Layout.BackgroundContainer
  13 import Graphics.UI.Gtk.Reactive
  14 import Hails.Yampa
  15 import RMCA.Auxiliary.RV
  16 import RMCA.GUI.Board
  17 import RMCA.GUI.Buttons
  18 import RMCA.GUI.MainSettings
  19 import RMCA.GUI.NoteSettings
  20 import RMCA.Layer.Board
  21 import RMCA.Layer.Layer
  22 import RMCA.Semantics
  23 import RMCA.Translator.Instruments
  24 import RMCA.Translator.Jack
  25
  26 floatConv :: (ReactiveValueReadWrite a b m,
  27               Real c, Real b, Fractional c, Fractional b) =>
  28              a -> ReactiveFieldReadWrite m c
  29 floatConv = liftRW $ bijection (realToFrac, realToFrac)
  30
  31 main :: IO ()
  32 main = do
  33   -- GUI
  34   initGUI
  35   window <- windowNew
  36   -- Main box
  37   mainBox <- hBoxNew False 10
  38   set window [ windowTitle := "Reactogon"
  39              , containerChild := mainBox
  40              , containerBorderWidth := 10
  41              ]
  42   windowMaximize window
  43
  44   settingsBox <- vBoxNew False 0
  45   boxPackEnd mainBox settingsBox PackNatural 0
  46   (globalSettingsBox, tempoRV) <- globalSettings
  47   boxPackStart settingsBox globalSettingsBox PackNatural 0
  48   globalSep <- hSeparatorNew
  49   boxPackStart settingsBox globalSep PackNatural 0
  50
  51   layerSettingsVBox <- vBoxNew True 10
  52   boxPackStart settingsBox layerSettingsVBox PackNatural 0
  53   layerSettingsBox <- hBoxNew True 10
  54   boxPackStart layerSettingsVBox layerSettingsBox PackNatural 0
  55
  56   layTempoBox <- hBoxNew False 10
  57   boxPackStart layerSettingsBox layTempoBox PackNatural 0
  58   layTempoLabel <- labelNew (Just "Layer tempo")
  59   labelSetAngle layTempoLabel 90
  60   boxPackStart layTempoBox layTempoLabel PackNatural 0
  61   layTempoAdj <- adjustmentNew 1 0 2 1 1 1
  62   layTempoScale <- vScaleNew layTempoAdj
  63   boxPackStart layTempoBox layTempoScale PackNatural 0
  64   laySep <- hSeparatorNew
  65
  66   strBox <- hBoxNew False 10
  67   boxPackStart layerSettingsBox strBox PackNatural 0
  68   strLabel <- labelNew (Just "Strength")
  69   labelSetAngle strLabel 90
  70   boxPackStart strBox strLabel PackNatural 0
  71   strAdj <- adjustmentNew 1 0 1 0.01 0.01 0
  72   layStrengthScale <- vScaleNew strAdj
  73   boxPackStart strBox layStrengthScale PackNatural 0
  74
  75   bpbBox <- vBoxNew False 10
  76   boxPackStart layerSettingsBox bpbBox PackNatural 0
  77   bpbLabel <- labelNew (Just "Beat per bar")
  78   labelSetLineWrap bpbLabel True
  79   boxPackStart bpbBox bpbLabel PackNatural 0
  80   bpbAdj <- adjustmentNew 4 1 16 1 1 0
  81   bpbButton <- spinButtonNew bpbAdj 1 0
  82   boxPackStart bpbBox bpbButton PackNatural 0
  83
  84   instrumentCombo <- comboBoxNewText
  85   instrumentIndex <- mapM (\(ind,ins) ->
  86                              do i <- comboBoxAppendText instrumentCombo $
  87                                      fromString ins
  88                                 return (i, ind)) instrumentList
  89   comboBoxSetActive instrumentCombo 0
  90   boxPackStart layerSettingsVBox instrumentCombo PackNatural 10
  91   let indexToInstr i = case (lookup i instrumentIndex) of
  92         Nothing -> error "Can't get the selected instrument."
  93         Just x -> x
  94       instrToIndex ins = case (lookup ins $ map swap instrumentIndex) of
  95         Nothing -> error "Can't retrieve the index for the instrument."
  96         Just x -> x
  97       instrumentComboRV = bijection (indexToInstr, instrToIndex) `liftRW`
  98                           comboBoxIndexRV instrumentCombo
  99 {-
 100   reactiveValueOnCanRead instrumentComboRV $ do
 101     ins <- reactiveValueRead instrumentComboRV
 102     bq <- reactiveValueRead boardQueue
 103     let body = ProgramChange $ toProgram ins
 104
 105     reactiveValueWrite boardQueue (bq ++
 106   -}
 107   boxPackStart settingsBox laySep PackNatural 0
 108
 109   layPitchRV <- newCBMVarRW 1
 110   let layTempoRV = floatConv $ scaleValueReactive layTempoScale
 111       strengthRV = floatConv $  scaleValueReactive layStrengthScale
 112       bpbRV = spinButtonValueIntReactive bpbButton
 113       f1 Layer { relTempo = d
 114                , relPitch = p
 115                , strength = s
 116                , beatsPerBar = bpb
 117                } = (d,p,s,bpb)
 118       f2 (d,p,s,bpb) = Layer { relTempo = d
 119                              , relPitch = p
 120                              , strength = s
 121                              , beatsPerBar = bpb
 122                              }
 123       layerRV =
 124         liftRW4 (bijection (f1,f2)) layTempoRV layPitchRV strengthRV bpbRV
 125
 126   (buttonBox, playRV, stopRV, pauseRV, recordRV) <- getButtons
 127   boxPackEnd settingsBox buttonBox PackNatural 0
 128
 129   -- Board
 130   boardCont <- backgroundContainerNew
 131   game <- initGame
 132   guiBoard <- attachGameRules game
 133   centerBoard <- alignmentNew 0.5 0.5 0 0
 134   containerAdd centerBoard guiBoard
 135   containerAdd boardCont centerBoard
 136   boxPackStart mainBox boardCont PackNatural 0
 137   --boxPackStart mainBox boardCont PackNatural 0
 138   ------------------------------------------------------------------------------
 139   boardQueue <- newCBMVarRW []
 140   -- Board setup
 141   layer <- reactiveValueRead layerRV
 142   tempo <- reactiveValueRead tempoRV
 143   (boardRV, pieceArrRV, phRV) <- initBoardRV guiBoard
 144   reactiveValueOnCanRead playRV
 145     (reactiveValueRead boardRV >>= reactiveValueWrite phRV . startHeads)
 146   reactiveValueOnCanRead stopRV $ reactiveValueWrite phRV []
 147   board <- reactiveValueRead boardRV
 148   ph <- reactiveValueRead phRV
 149   (inBoard, outBoard) <- yampaReactiveDual (board, layer, ph, tempo) boardSF
 150   let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
 151       inRV = liftR4 id
 152              boardRV layerRV phRV tempoRV'
 153   --let inRV = onTick clock inRV
 154   inRV =:> inBoard
 155   reactiveValueOnCanRead outBoard $ do
 156     bq <- reactiveValueRead boardQueue
 157     ob <- reactiveValueRead $ liftR (event [] id <<< snd <<< splitE) outBoard
 158     reactiveValueWrite boardQueue (bq ++ ob)
 159   -- This needs to be set last otherwise phRV is written to, so
 160   -- inBoard is written to and the notes don't get played. There
 161   -- supposedly is no guaranty of order but apparently there is…
 162   (fst <$>) <^> outBoard >:> phRV
 163   putStrLn "Board started."
 164   -- Jack setup
 165   forkIO $ jackSetup tempoRV (constR 0) boardQueue
 166   widgetShowAll window
 167   pieceBox <- clickHandling pieceArrRV guiBoard =<< vBoxNew False 10
 168   -- Piece characteristic
 169   --pieceBox <- pieceButtons pieceArrRV guiBoard =<< vBoxNew False 10
 170   ------------------------------------------------------------
 171
 172   boxPackStart settingsBox pieceBox PackNatural 10
 173   onDestroy window mainQuit
 174   mainGUI