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