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 Hails.Yampa
   9 import RMCA.Auxiliary.Concurrent
  10 import RMCA.Auxiliary.RV
  11 import RMCA.Global.Clock
  12 import RMCA.Layer.Board
  13 import RMCA.Layer.Layer
  14 import RMCA.Semantics
  15 import RMCA.Translator.Jack
  16 import RMCA.Translator.Message
  17 import RMCA.Translator.Translator
  18
  19 import Control.Monad
  20 import Data.Ratio
  21
  22 boardRVIO = newCBMVarRW $
  23     makeBoard [((0,0),  mkCell (ChDir True na1 NE)),
  24                ((1,1),  mkCellRpt (ChDir False na1 NW) 3),
  25                ((0,1),  mkCell (ChDir False na1 S))]
  26             {-makeBoard [((0,0), mkCell (ChDir True na1 N)),
  27                ((0,2), mkCellRpt (ChDir False na2 SE) 3),
  28                ((2,1), mkCell (ChDir False na1 SW)),
  29                ((1,1), mkCellRpt (ChDir False na1 N) 0) {- Skipped! -},
  30                ((0,4), mkCellRpt (ChDir True na1 N) (-1)) {- Rpt indef. -},
  31                ((0, -6), mkCell (ChDir True na1 N)),
  32                ((0, -2), mkCell (ChDir False na3 S) {- Silent -})]-}
  33
  34 na1 = NoteAttr {
  35           naArt = Accent13,
  36           naDur = 1 % 1,
  37           naOrn = Ornaments Nothing [] NoSlide
  38       }
  39
  40 na2 = NoteAttr {
  41           naArt = NoAccent,
  42           naDur = 1 % 1,
  43           naOrn = Ornaments Nothing [(10, MIDICVRnd)] SlideUp
  44       }
  45
  46 na3 = NoteAttr {
  47           naArt = Accent13,
  48           naDur = 0,
  49           naOrn = Ornaments Nothing [] NoSlide
  50       }
  51
  52
  53 bpb :: Int
  54 bpb = 4
  55
  56 newTempoRV :: IO (ReactiveFieldReadWrite IO Tempo)
  57 newTempoRV = newCBMVarRW 200
  58
  59 main :: IO ()
  60 main = do
  61   layerRV <- getDefaultLayerRV
  62   boardQueue <- newCBMVarRW []
  63   -- Board setup
  64   layer <- reactiveValueRead layerRV
  65   tempoRV <- newTempoRV
  66   tempo <- reactiveValueRead tempoRV
  67   boardRV <- boardRVIO
  68   board <- reactiveValueRead boardRV
  69   (inBoard, outBoard) <- yampaReactiveDual (board, layer, tempo)
  70                          (boardSF $ startHeads board)
  71   let inRV = liftRW2 (bijection (\(x,y,z) -> (x,(y,z)), \(x,(y,z)) -> (x,y,z)))
  72              boardRV $ pairRW layerRV tempoRV
  73   clock <- mkClockRV 100
  74   clock ^:> inRV
  75   inRV =:> inBoard
  76   --reactiveValueOnCanRead outBoard (reactiveValueRead outBoard >>= print . ("Board out " ++) . show)
  77   reactiveValueOnCanRead outBoard $ do
  78     bq <- reactiveValueRead boardQueue
  79     ob <- reactiveValueRead $ liftR (event [] id) outBoard
  80     reactiveValueWrite boardQueue (bq ++ ob)
  81   -- /!\ To be removed.
  82   --reactiveValueOnCanRead outBoard (reactiveValueRead outBoard >>= print)
  83   putStrLn "Board started."
  84   -- Jack setup
  85   jackSetup tempoRV (constR 0) boardQueue
  86   --return ()