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 tempoRV :: ReactiveFieldReadWrite IO Tempo
  53 tempoRV = ReactiveFieldReadWrite (\_ -> return ()) (return 96) (\_ -> return ())
  54
  55 main :: IO ()
  56 main = do
  57   layerRV <- getDefaultLayerRV
  58   -- Board setup
  59   layer <- reactiveValueRead layerRV
  60   tempo <- reactiveValueRead tempoRV
  61   boardRV <- boardRVIO
  62   board <- reactiveValueRead boardRV
  63   (inBoard, outBoard) <- yampaReactiveDual (board, layer, tempo) boardSF
  64   let inRV = liftRW2 (bijection (\(x,y,z) -> (x,(y,z)), \(x,(y,z)) -> (x,y,z)))
  65              boardRV $ pairRW layerRV tempoRV
  66   clock <- mkClockRV 100
  67   clock ^:> inRV
  68   inRV =:> inBoard
  69   --reactiveValueOnCanRead outBoard (reactiveValueRead outBoard >>= print . ("Board out " ++) . show)
  70   -- /!\ To be removed.
  71   --reactiveValueOnCanRead outBoard (reactiveValueRead outBoard >>= print)
  72   putStrLn "Board started."
  73   -- Jack setup
  74   jackSetup (liftR2 (\t n -> (t, 0, event [] id n)) tempoRV outBoard)
  75   return ()
  76
  77 {-jackT <- forkChild $ jackSetup (liftR2 (\t n -> (t, 0, n)) tempoRV
  78   boardOutRV) -}