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