Commit 486260f8 authored by Guerric Chupin's avatar Guerric Chupin

Add metronome making function.

parent 907bd4b2
......@@ -13,6 +13,13 @@ stepBack = sscan f (Nothing, Nothing) >>^ snd
f (Nothing,Nothing) x' = (Just x', Nothing)
f (Just x, _) x' = (Just x', Just x)
-- Just like stepBack but the output value is always defined and is
-- equal to the input at time 0.
stepBack' :: SF a a
stepBack' = proc x -> do
x' <- stepBack -< x
returnA -< maybe x id x'
-- Throws an Event when the incoming signal change. The Event is
-- tagged with the new value.
onChange :: (Eq a) => SF a (Event a)
......@@ -23,3 +30,18 @@ onChange = proc x -> do
| isJust x' = let x'' = fromJust x' in
if x'' == x then NoEvent else Event x
returnA -< makeEvent x x'
-- Similar to onChange but contains its initial value in the first
-- event.
onChange' :: (Eq a) => SF a (Event a)
onChange' = proc x -> do
x' <- stepBack -< x
-- If it's the first value, throw an Event, else behave like onChange.
let makeEvent x x'
| isNothing x' = Event x
| isJust x' = let x'' = fromJust x' in
if x'' == x then NoEvent else Event x
returnA -< makeEvent x x'
discard :: a -> ()
discard _ = ()
module Reactogon.Global.Clock where
import Reactogon.Auxiliary.Auxiliary
import Reactogon.Semantics
import FRP.Yampa
tempo :: SF () Tempo
tempo = constant 96
import Debug.Trace
metronome :: SF Tempo (Event Beat)
metronome = undefined
tempo :: Tempo -> SF () Tempo
tempo = constant
-- The initial value is arbitrary but never appears because the switch
-- is immediate.
metronome :: SF () Tempo -> SF () (Event Beat)
metronome tempo = switch ((repeatedly (tempoToDTime 60) ())
&&&
(discard ^>> tempo >>> onChange')) (metronome' tempo)
where metronome' :: SF () Tempo -> Tempo -> SF () (Event Beat)
metronome' tempo t = (switch ((repeatedly (tempoToDTime t) ())
&&&
(discard ^>> tempo >>> onChange))
(metronome' tempo))
tempoToDTime :: Tempo -> DTime
tempoToDTime = (60/) . fromIntegral
......@@ -13,10 +13,13 @@ data Layer = Layer { relTempo :: Double
}
layerClock :: SF () Tempo -> SF Layer Tempo
layerClock tempo = proc Layer { relTempo = r } -> do
layerClock globalTempo = proc Layer { relTempo = r } -> do
t <- tempo -< ()
returnA -< floor $ r * fromIntegral t
layerMetronome :: a
layerMetronome = metronome layerClock
-- A layer is a producer of events triggered by the system beat clock.
layer :: SF () (Event Beat) -> SF Layer (Event Note)
layer beatSource = undefined
......@@ -494,7 +494,7 @@ ppNotes bpb nss = ppnAux (zip [(br,bn) | br <- [1..], bn <- [1..bpb]] nss)
leftJustify :: Int -> String -> String
leftJustify w s = take (w - length s) (repeat ' ') ++ s
{-
------------------------------------------------------------------------------
-- Simple test
------------------------------------------------------------------------------
......@@ -530,3 +530,4 @@ main = ppNotes bpb (take 50 (runRMCA testBoard
0
0.8
[PlayHead (0,0) 1 N]))
-}
import Reactogon.Global.Clock
import Reactogon.Auxiliary.Auxiliary
import Reactogon.Semantics
import FRP.Yampa
main :: IO ()
main = do{-
putStr "Test tempo: "
print testTempo'
putStr "Test onChange': "
print testonChange'-}
putStr "Testing metronome: "
print testMetronome
tempo' :: SF () Tempo
tempo' = switch ((constant 30)
&&&
(after 20 10)) (\t -> switch ((constant t)
&&&
(after 20 60)) (constant))
testTempo' = embed ((tempo'))
((), take 120 $ repeat (1, Nothing))
testonChange' = embed ((discard ^>> tempo' >>> onChange'))
((), take 120 $ repeat (1, Nothing))
testMetronome = embed (metronome (tempo'))
((), take 120 $ repeat (1, Nothing))
import Reactogon.Auxiliary.Auxiliary
import FRP.Yampa
main :: IO ()
main = do
putStr "Testing onChange: "
print testOnChange
putStr "Testing onChange': "
print testOnChange'
testOnChange =
embed onChange (1, [(1, Just 1), (1, Just 1), (1, Just 2), (1, Just 3), (1, Just 3)])
testOnChange' =
embed onChange' (1, [(1, Just 1), (1, Just 1), (1, Just 2), (1, Just 3), (1, Just 3)])
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment