RMCA/Main.hs

   1 {-# LANGUAGE 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.Reactive
  10 import Hails.Yampa
  11 import RMCA.Auxiliary.Concurrent
  12 import RMCA.Auxiliary.RV
  13 import RMCA.Global.Clock
  14 import RMCA.GUI.Buttons
  15 import RMCA.Layer.Board
  16 import RMCA.Layer.Layer
  17 import RMCA.Semantics
  18 import RMCA.Translator.Jack
  19 import RMCA.Translator.Message
  20 import RMCA.Translator.Translator
  21 import Graphics.UI.Gtk.Layout.BackgroundContainer
  22 import RMCA.GUI.Board
  23 import Graphics.UI.Gtk.Board.BoardLink
  24
  25 import Control.Monad
  26 import Data.Ratio
  27
  28 floatConv :: (ReactiveValueReadWrite a b m,
  29               Real c, Real b, Fractional c, Fractional b) =>
  30              a -> ReactiveFieldReadWrite m c
  31 floatConv = liftRW $ bijection (realToFrac, realToFrac)
  32
  33 boardRVIO = newCBMVarRW $
  34     makeBoard [((0,0),  mkCell (ChDir True na1 NE)),
  35                ((1,1),  mkCellRpt (ChDir False na1 NW) 3),
  36                ((0,1),  mkCell (ChDir False na1 S))]
  37             {-makeBoard [((0,0), mkCell (ChDir True na1 N)),
  38                ((0,2), mkCellRpt (ChDir False na2 SE) 3),
  39                ((2,1), mkCell (ChDir False na1 SW)),
  40                ((1,1), mkCellRpt (ChDir False na1 N) 0) {- Skipped! -},
  41                ((0,4), mkCellRpt (ChDir True na1 N) (-1)) {- Rpt indef. -},
  42                ((0, -6), mkCell (ChDir True na1 N)),
  43                ((0, -2), mkCell (ChDir False na3 S) {- Silent -})]-}
  44
  45 na1 = NoteAttr {
  46           naArt = Accent13,
  47           naDur = 1 % 1,
  48           naOrn = Ornaments Nothing [] NoSlide
  49       }
  50
  51 na2 = NoteAttr {
  52           naArt = NoAccent,
  53           naDur = 1 % 1,
  54           naOrn = Ornaments Nothing [(10, MIDICVRnd)] SlideUp
  55       }
  56
  57 na3 = NoteAttr {
  58           naArt = Accent13,
  59           naDur = 0,
  60           naOrn = Ornaments Nothing [] NoSlide
  61       }
  62
  63
  64 bpb :: Int
  65 bpb = 4
  66
  67 newTempoRV :: IO (ReactiveFieldReadWrite IO Tempo)
  68 newTempoRV = newCBMVarRW 200
  69
  70 main :: IO ()
  71 main = do
  72   -- GUI
  73   initGUI
  74   window <- windowNew
  75   -- Main box
  76   mainBox <- hBoxNew True 0
  77   set window [ windowTitle := "Reactogon"
  78              --, windowDefaultWidth := 250
  79              --, windowDefaultHeight := 500
  80              , containerChild := mainBox
  81              , containerBorderWidth := 10
  82              ]
  83   windowMaximize window
  84
  85   settingsBox <- vBoxNew False 0
  86   boxPackEnd mainBox settingsBox PackNatural 0
  87   globalSettingsBox <- vBoxNew False 10
  88   boxPackStart settingsBox globalSettingsBox PackNatural 0
  89   tempoAdj <- adjustmentNew 120 40 200 1 1 1
  90   tempoLabel <- labelNew (Just "Tempo")
  91   boxPackStart globalSettingsBox tempoLabel PackNatural 0
  92   tempoScale <- hScaleNew tempoAdj
  93   boxPackStart globalSettingsBox tempoScale PackNatural 0
  94   scaleSetDigits tempoScale 0
  95   let tempoRV =
  96         bijection (floor, fromIntegral) `liftRW` scaleValueReactive tempoScale
  97   globalSep <- hSeparatorNew
  98   boxPackStart settingsBox globalSep PackNatural 0
  99
 100   layerSettingsBox <- hBoxNew True 10
 101   boxPackStart settingsBox layerSettingsBox PackNatural 0
 102
 103   layTempoBox <- hBoxNew False 10
 104   boxPackStart layerSettingsBox layTempoBox PackNatural 0
 105   layTempoLabel <- labelNew (Just "Layer tempo")
 106   labelSetAngle layTempoLabel 90
 107   boxPackStart layTempoBox layTempoLabel PackNatural 0
 108   layTempoAdj <- adjustmentNew 1 0 2 1 1 1
 109   layTempoScale <- vScaleNew layTempoAdj
 110   boxPackStart layTempoBox layTempoScale PackNatural 0
 111   laySep <- hSeparatorNew
 112
 113   strBox <- hBoxNew False 10
 114   boxPackStart layerSettingsBox strBox PackNatural 0
 115   strLabel <- labelNew (Just "Strength")
 116   labelSetAngle strLabel 90
 117   boxPackStart strBox strLabel PackNatural 0
 118   strAdj <- adjustmentNew 1 0 1 0.01 0.01 0
 119   layStrengthScale <- vScaleNew strAdj
 120   boxPackStart strBox layStrengthScale PackNatural 0
 121
 122   bpbBox <- vBoxNew False 10
 123   boxPackStart layerSettingsBox bpbBox PackNatural 0
 124   bpbLabel <- labelNew (Just "Beat per bar")
 125   labelSetLineWrap bpbLabel True
 126   boxPackStart bpbBox bpbLabel PackNatural 0
 127   bpbAdj <- adjustmentNew 4 1 16 1 1 0
 128   bpbButton <- spinButtonNew bpbAdj 1 0
 129   boxPackStart bpbBox bpbButton PackNatural 0
 130
 131   boxPackStart settingsBox laySep PackNatural 0
 132
 133   layPitchRV <- newCBMVarRW 1
 134   let layTempoRV = floatConv $ scaleValueReactive layTempoScale
 135       strengthRV = floatConv $  scaleValueReactive layStrengthScale
 136       bpbRV = spinButtonValueIntReactive bpbButton
 137       f1 Layer { relTempo = d
 138                , relPitch = p
 139                , strength = s
 140                , beatsPerBar = bpb
 141                } = (d,p,s,bpb)
 142       f2 (d,p,s,bpb) = Layer { relTempo = d
 143                              , relPitch = p
 144                              , strength = s
 145                              , beatsPerBar = bpb
 146                              }
 147       layerRV =
 148         liftRW4 (bijection (f1,f2)) layTempoRV layPitchRV strengthRV bpbRV
 149
 150
 151   buttonBox <- hBoxNew True 10
 152   boxPackEnd settingsBox buttonBox PackNatural 0
 153   buttonPlay <- buttonNewFromStock gtkMediaPlay
 154   boxPackStart buttonBox buttonPlay PackRepel 0
 155   buttonPause <- buttonNewFromStock gtkMediaPause
 156   boxPackStart buttonBox buttonPause PackRepel 0
 157   buttonStop <- buttonNewFromStock gtkMediaStop
 158   boxPackStart buttonBox buttonStop PackRepel 0
 159   buttonRecord <- buttonNewFromStock gtkMediaRecord
 160   boxPackStart buttonBox buttonRecord PackRepel 0
 161
 162   -- Board
 163   boardCont <- backgroundContainerNew
 164   game <- initGame
 165   board <- attachGameRules game
 166   --centerBoard <- alignmentNew 0.5 0.5 0 0
 167   containerAdd boardCont board
 168   --containerAdd boardCont centerBoard
 169   boxPackStart mainBox boardCont PackNatural 0
 170   --boxPackStart mainBox boardCont PackNatural 0
 171   ------------------------------------------------------------------------------
 172   boardQueue <- newCBMVarRW []
 173   -- Board setup
 174   layer <- reactiveValueRead layerRV
 175   tempo <- reactiveValueRead tempoRV
 176   boardRV <- boardRVIO
 177   board <- reactiveValueRead boardRV
 178   (inBoard, outBoard) <- yampaReactiveDual (board, layer, tempo)
 179                          (boardSF $ startHeads board)
 180   let inRV = liftRW2 (bijection (\(x,y,z) -> (x,(y,z)), \(x,(y,z)) -> (x,y,z)))
 181              boardRV $ pairRW layerRV tempoRV
 182   clock <- mkClockRV 100
 183   clock ^:> inRV
 184   inRV =:> inBoard
 185   --reactiveValueOnCanRead outBoard (reactiveValueRead outBoard >>= print . ("Board out " ++) . show)
 186   reactiveValueOnCanRead outBoard $ do
 187     bq <- reactiveValueRead boardQueue
 188     ob <- reactiveValueRead $ liftR (event [] id) outBoard
 189     reactiveValueWrite boardQueue (bq ++ ob)
 190   -- /!\ To be removed.
 191   --reactiveValueOnCanRead outBoard (reactiveValueRead outBoard >>= print)
 192   putStrLn "Board started."
 193   -- Jack setup
 194   forkIO $ jackSetup tempoRV (constR 0) boardQueue
 195   widgetShowAll window
 196   onDestroy window mainQuit
 197   mainGUI
 198   --return ()