]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Auxiliary/Yampa.hs
Add flake.nix
[tmp/julm/arpeggigon.git] / src / RMCA / Auxiliary / Yampa.hs
1 {-# LANGUAGE Arrows #-}
2
3 module RMCA.Auxiliary.Yampa where
4
5 import FRP.Yampa
6 import Data.Maybe
7 import RMCA.Auxiliary.Misc
8 import Control.Monad
9
10 -- | = Yampa
11
12 countTo :: (Integral b) => b -> SF (Event a) (Event b)
13 countTo n = count >>^ filterE (== n)
14
15 -- | Synchonizes two event sources. An event on the first source will be delayed until an event occurs on the second.
16 --
17 -- Ex:
18 -- Event a => . . 1 . . . . 2 . . . 3 . . 4 . . . . . 5 . . 6 . . . . .
19 -- Event b => . a . . . b . . . c . . . . . . d . e . f . . . . . g . .
20 -- wairFor => . . . . . 1 . . . 2 . . . . . . 4 . . . 5 . . . . . 6 . .
21
22 -- A more direct approach, and without any use of *> to avoid depending
23 -- on applicatives.
24
25 waitForEvent :: SF (Event a, Event b) (Event a)
26 waitForEvent = sscanPrim procEvts NoEvent NoEvent
27 where
28 procEvts eaPrev (NoEvent, NoEvent) = Just (eaPrev, NoEvent)
29 procEvts _ (ea@(Event _), NoEvent) = Just (ea, NoEvent)
30 procEvts eaPrev (NoEvent, Event _) = Just (NoEvent, eaPrev)
31 procEvts _ (ea@(Event _), Event _) = Just (NoEvent, ea)
32
33 {-
34 waitForEvent :: SF (Event a, Event b) (Event a)
35 waitForEvent = proc (ea,eb) -> do
36 em <- arr $ uncurry $ mapMerge Left Right (\_ b -> Right b) -< (ea,eb)
37 hob <- dAccumHoldBy accumulator NoEvent -< em
38 returnA -< eb *> (ea `lMerge` hob)
39 where accumulator :: Event a -> Either a b -> Event a
40 accumulator _ (Left a) = Event a
41 accumulator _ (Right _) = NoEvent
42 --accumulator _ (Right b) =
43 -}
44
45 {-
46 waitForEvent :: SF (Event b, Event a) (Event b)
47 waitForEvent = proc (eb,ea) -> do
48 rec
49 es' <- iPre NoEvent -< es
50 es <- rSwitch waitAux -< ((eb,ea),es' `tag` waitAux)
51 returnA -< es
52 where waitAux = proc (eb,ea) -> do
53 --ea' <- (if b then notYet else identity) -< ea
54 eb' <- accumHoldBy (\_ b -> Event b) NoEvent -< eb
55 returnA -< ea *> eb'
56 -}
57 -- | 'stepBack' contains its previous argument as its output. Because it's hard to define it at time 0, it's wrapped up in a 'Maybe'.
58 stepBack :: SF a (Maybe a)
59 stepBack = sscan f (Nothing, Nothing) >>^ snd
60 where f :: (Maybe a, Maybe a) -> a -> (Maybe a, Maybe a)
61 f (Nothing,_) x' = (Just x', Nothing)
62 f (Just x, _) x' = (Just x', Just x)
63
64 -- | Like 'stepBack' but the output value is always defined and is equal to the input at time 0.
65 stepBack' :: SF a a
66 stepBack' = proc x -> do
67 x' <- stepBack -< x
68 returnA -< fromMaybe x x'
69
70 -- | Throws an 'Event' when the incoming signal change. The 'Event' is tagged with the new value.
71 onChange :: (Eq a) => SF a (Event a)
72 onChange = proc x -> do
73 x' <- stepBack -< x
74 let makeEvent x x'
75 | isNothing x' = NoEvent
76 | otherwise = let x'' = fromJust x' in
77 if x'' == x then NoEvent else Event x
78 returnA -< makeEvent x x'
79
80 -- | Similar to 'onChange' but contains its initial value in the first
81 -- event.
82 onChange' :: (Eq a) => SF a (Event a)
83 onChange' = proc x -> do
84 x' <- stepBack -< x
85 -- If it's the first value, throw an Event, else behave like onChange.
86 let makeEvent x x'
87 | isNothing x' = Event x
88 | otherwise = let x'' = fromJust x' in
89 if x'' == x then NoEvent else Event x
90 returnA -< makeEvent x x'
91
92 -- | Integrates some variable modulo something.
93 integralMod :: (Real a, VectorSpace a s) => a -> SF a a
94 integralMod x = intMod' 0
95 where intMod' x0 = switch (intMod'' x0) (\y -> intMod' (y - x))
96 intMod'' x0 = proc t -> do
97 it <- (+ x0) ^<< integral -< t
98 es <- edgeBy (\_ y -> if y > x then Just y else Nothing) 0 -< it
99 returnA -< (it,es)
100
101
102
103 -- | Generates a sine function whose period is given as a varying input.
104 varFreqSine :: SF DTime Double
105 varFreqSine = sin ^<< (2*pi*) ^<< integralMod 1 <<^ (1/)
106
107 -- | Generates an 'Event' with a regular period, which is given as an input to the signal function.
108 repeatedlyS :: a -> SF DTime (Event a)
109 repeatedlyS x = edgeBy (\a b -> if a * b < 0 then Just x else Nothing) 0
110 <<< varFreqSine <<^ (2*)
111
112 repeatedlyS' :: a -> SF DTime (Event a)
113 repeatedlyS' x = (repeatedlyS x &&& now x) >>> arr (uncurry lMerge)
114
115 -- |
116 -- = Curry and uncurry functions