From 486260f8e13df06e1a30c54b691ea37f88a6d4ad Mon Sep 17 00:00:00 2001
From: Guerric Chupin <guerric.chupin@gmail.com>
Date: Mon, 23 May 2016 13:39:18 +0100
Subject: [PATCH] Add metronome making function.
---
Reactogon/Auxiliary/Auxiliary.hs | 22 ++++++++++++++++++++++
Reactogon/Global/Clock.hs | 23 +++++++++++++++++++----
Reactogon/Layer/Layer.hs | 5 ++++-
Reactogon/Semantics.hs | 3 ++-
Reactogon/tests/testClock.hs | 27 +++++++++++++++++++++++++++
Reactogon/tests/testOnChange.hs | 15 +++++++++++++++
6 files changed, 89 insertions(+), 6 deletions(-)
create mode 100644 Reactogon/tests/testClock.hs
create mode 100644 Reactogon/tests/testOnChange.hs
diff --git a/Reactogon/Auxiliary/Auxiliary.hs b/Reactogon/Auxiliary/Auxiliary.hs
index 90e25fa..cbc41e7 100644
--- a/Reactogon/Auxiliary/Auxiliary.hs
+++ b/Reactogon/Auxiliary/Auxiliary.hs
@@ -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 _ = ()
diff --git a/Reactogon/Global/Clock.hs b/Reactogon/Global/Clock.hs
index 673ba15..41c0f00 100644
--- a/Reactogon/Global/Clock.hs
+++ b/Reactogon/Global/Clock.hs
@@ -1,10 +1,25 @@
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
diff --git a/Reactogon/Layer/Layer.hs b/Reactogon/Layer/Layer.hs
index a9e8fe5..abb443d 100644
--- a/Reactogon/Layer/Layer.hs
+++ b/Reactogon/Layer/Layer.hs
@@ -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
diff --git a/Reactogon/Semantics.hs b/Reactogon/Semantics.hs
index 725b6f1..a58af66 100644
--- a/Reactogon/Semantics.hs
+++ b/Reactogon/Semantics.hs
@@ -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]))
+-}
diff --git a/Reactogon/tests/testClock.hs b/Reactogon/tests/testClock.hs
new file mode 100644
index 0000000..43fe586
--- /dev/null
+++ b/Reactogon/tests/testClock.hs
@@ -0,0 +1,27 @@
+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))
diff --git a/Reactogon/tests/testOnChange.hs b/Reactogon/tests/testOnChange.hs
new file mode 100644
index 0000000..aa85361
--- /dev/null
+++ b/Reactogon/tests/testOnChange.hs
@@ -0,0 +1,15 @@
+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)])
--
2.47.2