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 96 0 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   layTempoScale <- vScaleNewWithRange 0 1 0.01
 109   boxPackStart layTempoBox layTempoScale PackNatural 0
 110   laySep <- hSeparatorNew
 111
 112   strBox <- hBoxNew False 10
 113   boxPackStart layerSettingsBox strBox PackNatural 0
 114   strLabel <- labelNew (Just "Strength")
 115   labelSetAngle strLabel 90
 116   boxPackStart strBox strLabel PackNatural 0
 117   strAdj <- adjustmentNew 1 0 1 0.01 0.01 0
 118   layStrengthScale <- vScaleNew strAdj
 119   boxPackStart strBox layStrengthScale PackNatural 0
 120
 121   bpbBox <- vBoxNew False 10
 122   boxPackStart layerSettingsBox bpbBox PackNatural 0
 123   bpbLabel <- labelNew (Just "Beat per bar")
 124   labelSetLineWrap bpbLabel True
 125   boxPackStart bpbBox bpbLabel PackNatural 0
 126   bpbAdj <- adjustmentNew 4 1 16 1 1 0
 127   bpbButton <- spinButtonNew bpbAdj 1 0
 128   boxPackStart bpbBox bpbButton PackNatural 0
 129
 130   boxPackStart settingsBox laySep PackNatural 0
 131
 132   layPitchRV <- newCBMVarRW 1
 133   let layTempoRV = floatConv $ scaleValueReactive layTempoScale
 134       strengthRV = floatConv $  scaleValueReactive layStrengthScale
 135       bpbRV = spinButtonValueIntReactive bpbButton
 136       f1 Layer { relTempo = d
 137                , relPitch = p
 138                , strength = s
 139                , beatsPerBar = bpb
 140                } = (d,p,s,bpb)
 141       f2 (d,p,s,bpb) = Layer { relTempo = d
 142                              , relPitch = p
 143                              , strength = s
 144                              , beatsPerBar = bpb
 145                              }
 146       layerRV =
 147         liftRW4 (bijection (f1,f2)) layTempoRV layPitchRV strengthRV bpbRV
 148
 149
 150   buttonBox <- hBoxNew True 10
 151   boxPackEnd settingsBox buttonBox PackNatural 0
 152   buttonPlay <- buttonNewFromStock gtkMediaPlay
 153   boxPackStart buttonBox buttonPlay PackRepel 0
 154   buttonPause <- buttonNewFromStock gtkMediaPause
 155   boxPackStart buttonBox buttonPause PackRepel 0
 156   buttonStop <- buttonNewFromStock gtkMediaStop
 157   boxPackStart buttonBox buttonStop PackRepel 0
 158   buttonRecord <- buttonNewFromStock gtkMediaRecord
 159   boxPackStart buttonBox buttonRecord PackRepel 0
 160
 161   -- Board
 162   boardCont <- backgroundContainerNew
 163   game <- initGame
 164   board <- attachGameRules game
 165   --centerBoard <- alignmentNew 0.5 0.5 0 0
 166   containerAdd boardCont board
 167   --containerAdd boardCont centerBoard
 168   boxPackStart mainBox boardCont PackNatural 0
 169   --boxPackStart mainBox boardCont PackNatural 0
 170   ------------------------------------------------------------------------------
 171   boardQueue <- newCBMVarRW []
 172   -- Board setup
 173   layer <- reactiveValueRead layerRV
 174   tempo <- reactiveValueRead tempoRV
 175   boardRV <- boardRVIO
 176   board <- reactiveValueRead boardRV
 177   (inBoard, outBoard) <- yampaReactiveDual (board, layer, tempo)
 178                          (boardSF $ startHeads board)
 179   let inRV = liftRW2 (bijection (\(x,y,z) -> (x,(y,z)), \(x,(y,z)) -> (x,y,z)))
 180              boardRV $ pairRW layerRV tempoRV
 181   clock <- mkClockRV 100
 182   clock ^:> inRV
 183   inRV =:> inBoard
 184   --reactiveValueOnCanRead outBoard (reactiveValueRead outBoard >>= print . ("Board out " ++) . show)
 185   reactiveValueOnCanRead outBoard $ do
 186     bq <- reactiveValueRead boardQueue
 187     ob <- reactiveValueRead $ liftR (event [] id) outBoard
 188     reactiveValueWrite boardQueue (bq ++ ob)
 189   -- /!\ To be removed.
 190   --reactiveValueOnCanRead outBoard (reactiveValueRead outBoard >>= print)
 191   putStrLn "Board started."
 192   -- Jack setup
 193   forkIO $ jackSetup tempoRV (constR 0) boardQueue
 194   widgetShowAll window
 195   onDestroy window mainQuit
 196   mainGUI
 197   --return ()