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