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