]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - RCMA/Layer/Board.hs
Moved Reactogon to RCMA.
[tmp/julm/arpeggigon.git] / RCMA / Layer / Board.hs
1 {-# LANGUAGE Arrows #-}
2
3 module Reactogon.Layer.Board where
4
5 import FRP.Yampa
6 import Reactogon.Layer.Layer
7 import Reactogon.Semantics
8
9 -- The state of the board is described by the list of the playheads
10 -- and the different actions onto the board.
11 -- It can then be modified discretly when a beat is received or
12 -- continuously when the user acts on it.
13 boardAction :: Board
14 -> SF (Layer, [PlayHead], Event BeatNo)
15 (Event ([PlayHead], [Note]))
16 boardAction board = proc (Layer { relPitch = rp
17 , strength = s
18 , beatsPerBar = bpb
19 }, pl, ebn) -> do
20 ahSF <<^ arr propEvent -< (ebn, rp, s, pl)
21 where
22 uncurry4 :: (a -> b -> c -> d -> e) -> (a,b,c,d) -> e
23 uncurry4 f (a,b,c,d) = f a b c d
24 ahSF :: SF (Event (BeatNo, RelPitch, Strength, [PlayHead]))
25 (Event ([PlayHead], [Note]))
26 ahSF = arr $ fmap (uncurry4 $ advanceHeads board)
27 propEvent (a,b,c,d) = if isEvent a then Event (fromEvent a,b,c,d) else NoEvent