]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - RMCA/Main.hs
System producing notes but no sound.
[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 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 $ startHeads board)
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) -}