]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - RMCA/Layer/Board.hs
Compiles but crashes.
[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) (Event ([PlayHead], [Note]))
23 boardAction = proc ((board, Layer { relPitch = rp
24 , strength = s
25 , beatsPerBar = bpb
26 },ph), ebno) ->
27 arr $ fmap (uncurry5 advanceHeads)
28 -< ebno `tag` (board, fromEvent ebno, rp, s, ph)
29 --returnA -< traceShow e e
30
31 boardSF :: SF (Board, Layer, [PlayHead], Tempo) (Event ([PlayHead], [Note]))
32 boardSF = proc (board, l, ph, t) -> do
33 ebno <- layerMetronome -< (t, l)
34 boardAction -< ((board, l, ph), ebno)
35
36 {-
37 -- We need the list of initial playheads
38 boardSF :: [PlayHead] -> SF (Board, Layer, Tempo) (Event [Note])
39 boardSF iph = proc (board, l@Layer { relPitch = rp
40 , strength = s
41 }, t) -> do
42 ebno <- layerMetronome -< (t,l)
43 boardSF' iph -< ((board, l), ebno)
44 where
45 boardSF' :: [PlayHead] -> SF ((Board, Layer), Event BeatNo) (Event [Note])
46 boardSF' ph = dSwitch (boardAction ph >>> arr splitE >>> arr swap)
47 (\nph -> second notYet >>> boardSF' nph)
48
49
50 {-
51 boardSetup :: Board
52 -> ReactiveFieldReadWrite IO Tempo
53 -> ReactiveFieldReadWrite IO Layer
54 -> ReactiveFieldReadWrite IO [Note]
55 -> IO ()
56 boardSetup board tempoRV layerRV outBoardRV = do
57 layer <- reactiveValueRead layerRV
58 tempo <- reactiveValueRead tempoRV
59 (inBoard, outBoard) <- yampaReactiveDual (layer, tempo) (boardSF board)
60 let inRV = pairRW layerRV tempoRV
61 clock <- mkClockRV 10
62 inRV =:> inBoard
63 clock ^:> inRV
64 reactiveValueOnCanRead outBoard
65 (reactiveValueRead outBoard >>= reactiveValueWrite outBoardRV . event [] id)
66 putStrLn "Board started."
67 n <- newEmptyMVar
68 takeMVar n
69 return ()
70 -}
71 -}