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.Layer.Board
  15 import RMCA.Layer.Layer
  16 import RMCA.Semantics
  17 import RMCA.Translator.Jack
  18 import RMCA.Translator.Message
  19 import RMCA.Translator.Translator
  20
  21 import Control.Monad
  22 import Data.Ratio
  23
  24 boardRVIO = newCBMVarRW $
  25     makeBoard [((0,0),  mkCell (ChDir True na1 NE)),
  26                ((1,1),  mkCellRpt (ChDir False na1 NW) 3),
  27                ((0,1),  mkCell (ChDir False na1 S))]
  28             {-makeBoard [((0,0), mkCell (ChDir True na1 N)),
  29                ((0,2), mkCellRpt (ChDir False na2 SE) 3),
  30                ((2,1), mkCell (ChDir False na1 SW)),
  31                ((1,1), mkCellRpt (ChDir False na1 N) 0) {- Skipped! -},
  32                ((0,4), mkCellRpt (ChDir True na1 N) (-1)) {- Rpt indef. -},
  33                ((0, -6), mkCell (ChDir True na1 N)),
  34                ((0, -2), mkCell (ChDir False na3 S) {- Silent -})]-}
  35
  36 na1 = NoteAttr {
  37           naArt = Accent13,
  38           naDur = 1 % 1,
  39           naOrn = Ornaments Nothing [] NoSlide
  40       }
  41
  42 na2 = NoteAttr {
  43           naArt = NoAccent,
  44           naDur = 1 % 1,
  45           naOrn = Ornaments Nothing [(10, MIDICVRnd)] SlideUp
  46       }
  47
  48 na3 = NoteAttr {
  49           naArt = Accent13,
  50           naDur = 0,
  51           naOrn = Ornaments Nothing [] NoSlide
  52       }
  53
  54
  55 bpb :: Int
  56 bpb = 4
  57
  58 newTempoRV :: IO (ReactiveFieldReadWrite IO Tempo)
  59 newTempoRV = newCBMVarRW 200
  60
  61 main :: IO ()
  62 main = do
  63   -- GUI
  64   initGUI
  65   window <- windowNew
  66   set window [ windowTitle := "Reactogon"
  67              ]
  68   globalSettingsBox <- vBoxNew False 10
  69   containerAdd window globalSettingsBox
  70   tempoAdj <- adjustmentNew 96 0 200 1 1 0
  71   tempoLabel <- labelNew (Just "Tempo")
  72   boxPackStart globalSettingsBox tempoLabel PackNatural 0
  73   tempoScale <- hScaleNew tempoAdj
  74   boxPackStart globalSettingsBox tempoScale PackGrow 0
  75   let tempoRV = bijection (floor, fromIntegral) `liftRW` scaleValueReactive tempoScale
  76   ------------------------------------------------------------------------------
  77   layerRV <- getDefaultLayerRV
  78   boardQueue <- newCBMVarRW []
  79   -- Board setup
  80   layer <- reactiveValueRead layerRV
  81   tempo <- reactiveValueRead tempoRV
  82   boardRV <- boardRVIO
  83   board <- reactiveValueRead boardRV
  84   (inBoard, outBoard) <- yampaReactiveDual (board, layer, tempo)
  85                          (boardSF $ startHeads board)
  86   let inRV = liftRW2 (bijection (\(x,y,z) -> (x,(y,z)), \(x,(y,z)) -> (x,y,z)))
  87              boardRV $ pairRW layerRV tempoRV
  88   clock <- mkClockRV 100
  89   clock ^:> inRV
  90   inRV =:> inBoard
  91   --reactiveValueOnCanRead outBoard (reactiveValueRead outBoard >>= print . ("Board out " ++) . show)
  92   reactiveValueOnCanRead outBoard $ do
  93     bq <- reactiveValueRead boardQueue
  94     ob <- reactiveValueRead $ liftR (event [] id) outBoard
  95     reactiveValueWrite boardQueue (bq ++ ob)
  96   -- /!\ To be removed.
  97   --reactiveValueOnCanRead outBoard (reactiveValueRead outBoard >>= print)
  98   putStrLn "Board started."
  99   -- Jack setup
 100   forkIO $ jackSetup tempoRV (constR 0) boardQueue
 101   widgetShowAll window
 102   onDestroy window mainQuit
 103   mainGUI
 104   --return ()