Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 246 lines (190 sloc) 7.372 kB
c0e473a foo
alex authored
1 module Pattern where
2
3 import Control.Applicative
7323f69 @yaxu first commit
authored
4 import Data.Fixed
c0e473a foo
alex authored
5 import Data.List
5745356 foo
alex authored
6 import Data.Maybe
7323f69 @yaxu first commit
authored
7
6ecfa70 @yaxu aha
authored
8 data Pattern a = Atom {event :: a}
13b8d19 @yaxu things, and rational numbers
authored
9 | Cycle {patterns :: [Pattern a]}
10 | Signal {at :: Rational -> Pattern a}
11 | Silence
12 | Arc {pattern :: Pattern a,
13 onset :: Rational,
14 scale :: Rational,
15 reps :: Rational
16 }
c0e473a foo
alex authored
17
10aa5f7 no comment
alex authored
18 joinPattern :: Pattern (Pattern a) -> Pattern a
19 joinPattern = mapAtom (\(Atom x) -> x)
0f40ddb @yaxu foo
authored
20
10abb7b aha
alex authored
21 instance Applicative Pattern where
22 pure = Atom
10aa5f7 no comment
alex authored
23
9fef49c @yaxu simplify
authored
24 Atom f <*> xs = f <$> xs
25 fs <*> (Atom x) = (\f -> f x) <$> fs
10aa5f7 no comment
alex authored
26
10abb7b aha
alex authored
27 (Cycle fs) <*> xs = Cycle $ map (<*> xs) fs
28 fs <*> (Cycle xs) = Cycle $ map (fs <*>) xs
29
30 fs@(Arc {onset = o}) <*> s@(Signal {}) = fs <*> (at s o)
31 fs@(Arc {}) <*> xs@(Arc {}) | isIn fs xs = fs {pattern = (pattern fs) <*> (pattern xs)}
13b8d19 @yaxu things, and rational numbers
authored
32 | otherwise = Silence
10abb7b aha
alex authored
33
34 fs@(Signal {}) <*> xs = Signal $ (<*> xs) . (at fs)
35 fs <*> xs@(Signal {}) = Signal $ (fs <*>) . (at xs)
13b8d19 @yaxu things, and rational numbers
authored
36 _ <*> Silence = Silence
37 Silence <*> _ = Silence
38
39
40 instance Monad Pattern where
41 return = pure
42 m >>= f = joinPattern (fmap f m)
10abb7b aha
alex authored
43
44 --where s n = mapAtom (\x -> mapAtom (\f -> Atom $ (event f) (event x)) (at fs n)) xs
45
46 isIn :: Pattern a -> Pattern b -> Bool
13b8d19 @yaxu things, and rational numbers
authored
47 isIn (Arc {onset = o1}) (Arc {onset = o2, reps = r2})
48 = (o1 >= o2 && o1 < (o2 + r2))
49 -- || (r2 == 0 && o1 == o2)
10abb7b aha
alex authored
50 isIn _ _ = False -- only makes sense for Arcs
10aa5f7 no comment
alex authored
51
52 --data Pattern a = Atom a | Arc (Pattern a) (Double) (Maybe Double) | Cycle
c0e473a foo
alex authored
53
54 instance Functor Pattern where
6ecfa70 @yaxu aha
authored
55 fmap f p@(Atom {event = a}) = p {event = f a}
56 fmap f p@(Arc {pattern = p'}) = p {pattern = fmap f p'}
1a550c1 hmm
alex authored
57 fmap f p@(Cycle {patterns = ps}) = p {patterns = fmap (fmap f) ps}
10abb7b aha
alex authored
58 fmap f p@(Signal _) = p {at = (fmap f) . (at p)}
13b8d19 @yaxu things, and rational numbers
authored
59 fmap _ Silence = Silence
c0e473a foo
alex authored
60
1a550c1 hmm
alex authored
61 instance (Show a) => Show (Pattern a) where
13b8d19 @yaxu things, and rational numbers
authored
62 show (Atom e) = show e
63 show (Arc p o d r) = concat ["[", show p, "@", show o, "x", show d, "]"]
64 show (Cycle ps) = "(" ++ (intercalate ", " (map show ps)) ++ ")"
10abb7b aha
alex authored
65 show (Signal s) = "*signal*"
13b8d19 @yaxu things, and rational numbers
authored
66 show Silence = "~"
7323f69 @yaxu first commit
authored
67
68 class Patternable p where
6ecfa70 @yaxu aha
authored
69 toPattern :: p a -> Pattern a
7323f69 @yaxu first commit
authored
70
71 instance Patternable [] where
6ecfa70 @yaxu aha
authored
72 toPattern xs = Cycle ps
1a550c1 hmm
alex authored
73 where
6ecfa70 @yaxu aha
authored
74 ps = map (\x -> Arc {pattern = Atom $ xs !! x,
75 onset = (fromIntegral x) /
13b8d19 @yaxu things, and rational numbers
authored
76 (fromIntegral l),
77 scale = 1 / (fromIntegral l),
78 reps = 1
1a550c1 hmm
alex authored
79 }
13b8d19 @yaxu things, and rational numbers
authored
80 ) [0 .. l - 1]
81 l = length xs
7323f69 @yaxu first commit
authored
82
6ecfa70 @yaxu aha
authored
83 {-size :: Pattern a -> Double
be8be0d @yaxu foo
authored
84 size (Atom {}) = 1
591994f @yaxu foo
authored
85 size (Cycle {extent = e}) = e
be8be0d @yaxu foo
authored
86 size (Combo []) = 0
87 size (Combo ps) = maximum $ map size ps
6ecfa70 @yaxu aha
authored
88 -}
89
90
91 silence :: Pattern a
13b8d19 @yaxu things, and rational numbers
authored
92 silence = Silence
be8be0d @yaxu foo
authored
93
1a550c1 hmm
alex authored
94 mapAtom :: (Pattern a -> Pattern b) -> Pattern a -> Pattern b
6ecfa70 @yaxu aha
authored
95 mapAtom f p@(Atom {}) = f p
96 mapAtom f p@(Arc {pattern = p'}) = p {pattern = mapAtom f p'}
1a550c1 hmm
alex authored
97 mapAtom f p@(Cycle {patterns = ps}) = p {patterns = fmap (mapAtom f) ps}
10abb7b aha
alex authored
98 mapAtom f p@(Signal _) = p {at = fmap (mapAtom f) (at p)}
13b8d19 @yaxu things, and rational numbers
authored
99 mapAtom _ Silence = Silence
10abb7b aha
alex authored
100
101 filterP :: (Pattern a -> Bool) -> Pattern a -> Pattern a
102 filterP f p@(Atom {}) | f p = p
13b8d19 @yaxu things, and rational numbers
authored
103 | otherwise = Silence
10abb7b aha
alex authored
104 filterP f p@(Cycle ps) | f p = p {patterns = map (filterP f) ps}
13b8d19 @yaxu things, and rational numbers
authored
105 | otherwise = Silence
10abb7b aha
alex authored
106 filterP f p@(Arc {}) | f p = p {pattern = filterP f (pattern p)}
13b8d19 @yaxu things, and rational numbers
authored
107 | otherwise = Silence
10abb7b aha
alex authored
108 filterP f p@(Signal {}) | f p = p {at = (filterP f) . (at p)}
13b8d19 @yaxu things, and rational numbers
authored
109 filterP _ Silence = Silence
c0e473a foo
alex authored
110
6ecfa70 @yaxu aha
authored
111 mapArc :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
112 mapArc f p@(Atom {}) = p
113 mapArc f p@(Arc {pattern = p'}) = f $ p {pattern = mapArc f p'}
114 mapArc f p@(Cycle {patterns = ps}) = p {patterns = fmap (mapArc f) ps}
10abb7b aha
alex authored
115 mapArc f p@(Signal _) = p {at = fmap (mapArc f) (at p)}
13b8d19 @yaxu things, and rational numbers
authored
116 mapArc _ Silence = Silence
10abb7b aha
alex authored
117
6ecfa70 @yaxu aha
authored
118
119 {-
1a550c1 hmm
alex authored
120 mapEvent :: (Event a -> Event b) -> Pattern a -> Pattern b
121 mapEvent f p = mapAtom (\p' -> p' {event = f (event p')}) p
6ecfa70 @yaxu aha
authored
122 -}
7323f69 @yaxu first commit
authored
123
13b8d19 @yaxu things, and rational numbers
authored
124 mapOnset :: (Rational -> Rational) -> Pattern a -> Pattern a
6ecfa70 @yaxu aha
authored
125 mapOnset f p = mapArc (\p' -> p' {onset = f $ onset p'}) p
7323f69 @yaxu first commit
authored
126
1a550c1 hmm
alex authored
127 rev :: Pattern a -> Pattern a
128 rev = mapOnset (1 -)
129
13b8d19 @yaxu things, and rational numbers
authored
130 (<~) :: Rational -> Pattern a -> Pattern a
1a550c1 hmm
alex authored
131 d <~ p = mapOnset (\x -> mod' (x - d) 1) p
7323f69 @yaxu first commit
authored
132
13b8d19 @yaxu things, and rational numbers
authored
133 (~>) :: Rational -> Pattern a -> Pattern a
1a550c1 hmm
alex authored
134 d ~> p = (0-d) <~ p
7323f69 @yaxu first commit
authored
135
6ecfa70 @yaxu aha
authored
136
13b8d19 @yaxu things, and rational numbers
authored
137 -- assumes equal scale..
6ecfa70 @yaxu aha
authored
138
139 cat :: [Pattern a] -> Pattern a
140 cat ps = Cycle $ map a [0 .. (length ps) - 1]
141 where l = length ps
13b8d19 @yaxu things, and rational numbers
authored
142 s = 1 / (fromIntegral l)
6ecfa70 @yaxu aha
authored
143 a n = Arc {pattern = ps !! n,
13b8d19 @yaxu things, and rational numbers
authored
144 onset = s * (fromIntegral n),
145 scale = s,
146 reps = 1
6ecfa70 @yaxu aha
authored
147 }
148
7323f69 @yaxu first commit
authored
149 every :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
150 every 0 _ p = p
151 every n f p = cat $ (take (n-1) $ repeat p) ++ [f p]
152
0f40ddb @yaxu foo
authored
153
1a550c1 hmm
alex authored
154 --cat :: [Pattern a] -> Pattern a
155 --cat ps = Cycle (concatMap events ps') n
156 -- where shrunk = map (\p -> mapTime (* ((periodP p) / n)) p) ps
157 -- withOffsets = zip (0:(map (\p -> (periodP p) / n) shrunk)) shrunk
158 -- ps' = map (\(o, p) -> mapTime (+ o) p) $ accumFst withOffsets
159 -- n = (sum $ (map periodP) ps)
c0e473a foo
alex authored
160
1a550c1 hmm
alex authored
161 combine :: [Pattern a] -> Pattern a
6ecfa70 @yaxu aha
authored
162 combine = Cycle
7323f69 @yaxu first commit
authored
163
1a550c1 hmm
alex authored
164 --accumOnsets :: [Event a] -> [Event a]
165 --accumOnsets = scanl1 (\a b -> mapOnset (+ (onset a)) b)
c0e473a foo
alex authored
166
1a550c1 hmm
alex authored
167 --accumFst :: [(Double, a)] -> [(Double, a)]
168 --accumFst = scanl1 (\a b -> mapFst (+ (fst a)) b)
7323f69 @yaxu first commit
authored
169
10abb7b aha
alex authored
170 sinewave :: Pattern Double
171 sinewave = Signal {at = f}
13b8d19 @yaxu things, and rational numbers
authored
172 where f x = Arc {pattern = Atom $ (sin . (pi * 2 *)) (fromRational x),
10abb7b aha
alex authored
173 onset = mod' x 1,
13b8d19 @yaxu things, and rational numbers
authored
174 scale = 1,
175 reps = 1
10abb7b aha
alex authored
176 }
177
178 sinewave1 :: Pattern Double
179 sinewave1 = fmap ((/ 2) . (+ 1)) sinewave
180
181 {-
be8be0d @yaxu foo
authored
182 sample :: Int -> Signal a -> Pattern a
6ecfa70 @yaxu aha
authored
183 sample n s = Cycle ps
10aa5f7 no comment
alex authored
184 where
6ecfa70 @yaxu aha
authored
185 d = 1 / (fromIntegral n)
186 ps = map (\x ->
187 Arc {
188 pattern = Atom (s $ (fromIntegral x) * d),
189 onset = (fromIntegral x) * d,
13b8d19 @yaxu things, and rational numbers
authored
190 density = d
6ecfa70 @yaxu aha
authored
191 }
192 )
193 [0 .. (n - 1)]
be8be0d @yaxu foo
authored
194
10abb7b aha
alex authored
195 modulateOnset :: (a -> Double -> Double) -> Signal a -> Pattern b -> Pattern b
196 modulateOnset f s p = mapOnset (\x -> f (s x) x) p
7323f69 @yaxu first commit
authored
197
10abb7b aha
alex authored
198 wobble :: Double -> Pattern a -> Pattern a
199 wobble d p = modulateOnset (+) (fmap (*d) sinewave) p
200 -}
7323f69 @yaxu first commit
authored
201 mapFst :: (a -> b) -> (a, c) -> (b, c)
202 mapFst f (x,y) = (f x,y)
203
591994f @yaxu foo
authored
204 mapFsts :: (a -> b) -> [(a, c)] -> [(b, c)]
205 mapFsts = map . mapFst
206
7323f69 @yaxu first commit
authored
207 mapSnd :: (a -> b) -> (c, a) -> (c, b)
208 mapSnd f (x,y) = (x,f y)
209
6ecfa70 @yaxu aha
authored
210 mapSnds :: (a -> b) -> [(c, a)] -> [(c, b)]
211 mapSnds = map . mapSnd
212
1a550c1 hmm
alex authored
213
214
13b8d19 @yaxu things, and rational numbers
authored
215 flatten :: Pattern a -> [(Rational, a)]
6ecfa70 @yaxu aha
authored
216 flatten (Atom e) = [(0, e)]
13b8d19 @yaxu things, and rational numbers
authored
217 flatten Arc {pattern = p, onset = o, scale = s, reps = r} =
218 squash o s $ flatten p
6ecfa70 @yaxu aha
authored
219 flatten (Cycle ps) = concatMap flatten ps
13b8d19 @yaxu things, and rational numbers
authored
220 flatten Silence = []
221
222 flat :: (Rational, Rational) -> Pattern a -> [(Rational, a)]
223 flat (o, d) (Atom e) = [(0, e)]
224 flat (a, b) Arc {pattern = p, onset = o, scale = s, reps = r}
225 | isWithin = squash o s $ flat (a', b') p
226 | otherwise = []
227 where s' = b - a
228 a' = (o - a) / s'
229 b' = a' + (s / s')
230 isWithin = a' >= 0 && b' < 1
231
232 flat (a, b) (Cycle ps) = concatMap (flat (a, b)) ps
233 flat _ Silence = []
234
235 squash :: Rational -> Rational -> [(Rational, a)] -> [(Rational, a)]
236 squash o s es = mapFsts ((+ o) . (* s)) es
591994f @yaxu foo
authored
237
5745356 foo
alex authored
238
6ecfa70 @yaxu aha
authored
239 {-
5745356 foo
alex authored
240 accumFst :: [(Double, a)] -> [(Double, a)]
241 accumFst = scanl1 (\a b -> mapFst (+ (fst a)) b)
6ecfa70 @yaxu aha
authored
242 modulate :: (a -> b -> c) -> Pattern a -> Signal b -> Pattern c
243 modulate f p s = fmap (
244 -}
1a550c1 hmm
alex authored
245
Something went wrong with that request. Please try again.