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