]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - RMCA/Main.hs
Add « update on event » function on RVs.
[tmp/julm/arpeggigon.git] / 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) -}