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.Layer.Board
  10 import RCMA.Layer.Layer
  11 import RCMA.Semantics
  12 import RCMA.Translator.Jack
  13 import RCMA.Translator.Message
  14 import RCMA.Translator.Translator
  15
  16 import Control.Monad
  17 import Data.Ratio
  18
  19 board =
  20     makeBoard [((0,0),  mkCell (ChDir False na1 N)),
  21                ((0,1),  mkCell (ChDir False na1 SE)),
  22                ((1,1),  mkCell (Split na1)),
  23                ((1,-1), mkCell (Split na1)),
  24                ((-1,0), mkCell (ChDir False na2 NE))]
  25
  26 na1 = NoteAttr {
  27           naArt = Accent13,
  28           naDur = 1 % 4,
  29           naOrn = Ornaments Nothing [] NoSlide
  30       }
  31
  32 na2 = NoteAttr {
  33           naArt = NoAccent,
  34           naDur = 1 % 16,
  35           naOrn = Ornaments Nothing [(10, MIDICVRnd)] SlideUp
  36       }
  37
  38 na3 = NoteAttr {
  39           naArt = Accent13,
  40           naDur = 0,
  41           naOrn = Ornaments Nothing [] NoSlide
  42       }
  43
  44
  45 bpb :: Int
  46 bpb = 4
  47
  48 tempoRV :: ReactiveFieldReadWrite IO Tempo
  49 tempoRV = ReactiveFieldReadWrite (\_ -> return ()) (return 96) (\_ -> return ())
  50
  51 waitForChildren :: MVar [MVar ()] -> IO ()
  52 waitForChildren children = do
  53   cs <- takeMVar children
  54   case cs of
  55     []   -> return ()
  56     m:ms -> do
  57       putMVar children ms
  58       takeMVar m
  59       waitForChildren children
  60
  61 main :: IO ()
  62 main = do
  63   (children :: MVar [MVar ()]) <- newMVar []
  64   let forkChild :: IO () -> IO ThreadId
  65       forkChild io = do
  66         mvar <- newEmptyMVar
  67         childs <- takeMVar children
  68         putMVar children (mvar:childs)
  69         forkFinally io (\_ -> putMVar mvar ())
  70
  71   layerRV <- getDefaultLayerRV
  72   boardInRV <- boardSetup board tempoRV layerRV
  73   jackT <- forkChild $ jackSetup (liftR2 (\t n -> (t, 0, n)) tempoRV boardInRV)
  74   waitForChildren children