]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - RMCA/Layer/Board.hs
Playheads and notes are correct.
[tmp/julm/arpeggigon.git] / RMCA / Layer / Board.hs
1 {-# LANGUAGE Arrows, FlexibleContexts #-}
2
3 module RMCA.Layer.Board ( boardSF
4 ) where
5
6 import Control.Concurrent
7 import Control.Concurrent.MVar
8 import Control.Monad
9 import Data.ReactiveValue
10 import Data.Tuple
11 import FRP.Yampa
12 import Hails.Yampa
13 import RMCA.Auxiliary.Curry
14 import RMCA.Global.Clock
15 import RMCA.Layer.Layer
16 import RMCA.Semantics
17
18 import Debug.Trace
19
20 -- The state of the board is described by the list of the playheads
21 -- and the different actions onto the board.
22 boardAction :: SF ((Board, Layer, [PlayHead]), Event BeatNo)
23 (Event ([PlayHead], [Note]))
24 boardAction = proc ((board, Layer { relPitch = rp
25 , strength = s
26 , beatsPerBar = bpb
27 },ph), ebno) ->
28 arr $ fmap (uncurry5 advanceHeads)
29 -< ebno `tag` (board, fromEvent ebno, rp, s, ph)
30 --returnA -< traceShow e e
31
32 boardSF :: SF (Board, Layer, [PlayHead], Tempo) (Event ([PlayHead], [Note]))
33 boardSF = proc (board, l, ph, t) -> do
34 ebno <- layerMetronome -< (t, l)
35 boardAction -< ((board, l, ph), ebno)
36
37 {-
38 -- We need the list of initial playheads
39 boardSF :: [PlayHead] -> SF (Board, Layer, Tempo) (Event [Note])
40 boardSF iph = proc (board, l@Layer { relPitch = rp
41 , strength = s
42 }, t) -> do
43 ebno <- layerMetronome -< (t,l)
44 boardSF' iph -< ((board, l), ebno)
45 where
46 boardSF' :: [PlayHead] -> SF ((Board, Layer), Event BeatNo) (Event [Note])
47 boardSF' ph = dSwitch (boardAction ph >>> arr splitE >>> arr swap)
48 (\nph -> second notYet >>> boardSF' nph)
49
50
51 {-
52 boardSetup :: Board
53 -> ReactiveFieldReadWrite IO Tempo
54 -> ReactiveFieldReadWrite IO Layer
55 -> ReactiveFieldReadWrite IO [Note]
56 -> IO ()
57 boardSetup board tempoRV layerRV outBoardRV = do
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 10
63 inRV =:> inBoard
64 clock ^:> inRV
65 reactiveValueOnCanRead outBoard
66 (reactiveValueRead outBoard >>= reactiveValueWrite outBoardRV . event [] id)
67 putStrLn "Board started."
68 n <- newEmptyMVar
69 takeMVar n
70 return ()
71 -}
72 -}