]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Layer/Board.hs
Hlint suggestions.
[tmp/julm/arpeggigon.git] / src / RMCA / Layer / Board.hs
1 {-# LANGUAGE Arrows, FlexibleContexts #-}
2
3 module RMCA.Layer.Board ( boardSF
4 ) where
5
6 import FRP.Yampa
7 import RMCA.Auxiliary.Curry
8 import RMCA.Layer.Layer
9 import RMCA.Semantics
10
11 -- The state of the board is described by the list of the playheads
12 -- and the different actions onto the board.
13 boardAction :: SF ((Board, Layer, [PlayHead]), Event BeatNo)
14 (Event ([PlayHead], [Note]))
15 boardAction = proc ((board, Layer { relPitch = rp
16 , strength = s
17 },ph), ebno) ->
18 arr $ fmap (uncurry5 advanceHeads)
19 -< ebno `tag` (board, fromEvent ebno, rp, s, ph)
20 --returnA -< traceShow e e
21
22 boardSF :: SF (Board, Layer, [PlayHead], Tempo) (Event ([PlayHead], [Note]))
23 boardSF = proc (board, l, ph, t) -> do
24 ebno <- layerMetronome -< (t, l)
25 boardAction -< ((board, l, ph), ebno)
26
27 {-
28 -- We need the list of initial playheads
29 boardSF :: [PlayHead] -> SF (Board, Layer, Tempo) (Event [Note])
30 boardSF iph = proc (board, l@Layer { relPitch = rp
31 , strength = s
32 }, t) -> do
33 ebno <- layerMetronome -< (t,l)
34 boardSF' iph -< ((board, l), ebno)
35 where
36 boardSF' :: [PlayHead] -> SF ((Board, Layer), Event BeatNo) (Event [Note])
37 boardSF' ph = dSwitch (boardAction ph >>> arr splitE >>> arr swap)
38 (\nph -> second notYet >>> boardSF' nph)
39
40
41 {-
42 boardSetup :: Board
43 -> ReactiveFieldReadWrite IO Tempo
44 -> ReactiveFieldReadWrite IO Layer
45 -> ReactiveFieldReadWrite IO [Note]
46 -> IO ()
47 boardSetup board tempoRV layerRV outBoardRV = do
48 layer <- reactiveValueRead layerRV
49 tempo <- reactiveValueRead tempoRV
50 (inBoard, outBoard) <- yampaReactiveDual (layer, tempo) (boardSF board)
51 let inRV = pairRW layerRV tempoRV
52 clock <- mkClockRV 10
53 inRV =:> inBoard
54 clock ^:> inRV
55 reactiveValueOnCanRead outBoard
56 (reactiveValueRead outBoard >>= reactiveValueWrite outBoardRV . event [] id)
57 putStrLn "Board started."
58 n <- newEmptyMVar
59 takeMVar n
60 return ()
61 -}
62 -}