Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 371 lines (284 sloc) 11.853 kb
c0e473a foo
alex authored
1 module Pattern where
2
3 import Control.Applicative
7323f69 Alex McLean first commit
authored
4 import Data.Fixed
c0e473a foo
alex authored
5 import Data.List
5745356 foo
alex authored
6 import Data.Maybe
e9fb83a Alex McLean more there
authored
7 import Data.Ratio
1a7e47c Alex McLean getting there
authored
8 import Debug.Trace
7323f69 Alex McLean first commit
authored
9
6ecfa70 Alex McLean aha
authored
10 data Pattern a = Atom {event :: a}
13b8d19 Alex McLean things, and rational numbers
authored
11 | Cycle {patterns :: [Pattern a]}
0be7bab Alex McLean hm
authored
12 | Composition {cf :: (Rational, Rational) -> Pattern a}
13b8d19 Alex McLean things, and rational numbers
authored
13 | Signal {at :: Rational -> Pattern a}
14 | Silence
15 | Arc {pattern :: Pattern a,
16 onset :: Rational,
17 scale :: Rational,
18 reps :: Rational
19 }
c0e473a foo
alex authored
20
10aa5f7 no comment
alex authored
21 joinPattern :: Pattern (Pattern a) -> Pattern a
22 joinPattern = mapAtom (\(Atom x) -> x)
0f40ddb Alex McLean foo
authored
23
10abb7b aha
alex authored
24 instance Applicative Pattern where
25 pure = Atom
67a24f7 Alex McLean new pattern again
authored
26
27 -- Pattern (a -> b) <*> Pattern a -> Pattern b
10aa5f7 no comment
alex authored
28
67a24f7 Alex McLean new pattern again
authored
29 -- Apply a pattern to every pattern of functions in a cycle
30 (Cycle fs) <*> x = Cycle $ map (<*> x) fs
265e8fd Alex McLean bugfix applicative
authored
31
67a24f7 Alex McLean new pattern again
authored
32 -- Apply every subpattern in a cycle to a pattern of functions
33 f <*> (Cycle xs) = Cycle $ map (f <*>) xs
34 cd 07976
35 -- Apply every value inside a pattern to a function
265e8fd Alex McLean bugfix applicative
authored
36 Atom f <*> xs = f <$> xs
67a24f7 Alex McLean new pattern again
authored
37
38 -- Apply a value to every function inside a pattern
265e8fd Alex McLean bugfix applicative
authored
39 fs <*> (Atom x) = (\f -> f x) <$> fs
10abb7b aha
alex authored
40
67a24f7 Alex McLean new pattern again
authored
41 -- Simple case of two unit arcs
0be7bab Alex McLean hm
authored
42 fs@(Arc {reps = 1}) <*> xs@(Arc {reps = 1}) = down
67a24f7 Alex McLean new pattern again
authored
43 where down | startsIn fs xs = fs {pattern = (pattern fs) <*> (pattern xs)}
0be7bab Alex McLean hm
authored
44 | otherwise = Silence
45
46 fs@(Arc {}) <*> xs@(Arc {}) = Composition f
47 where f r = a <*> b
48 where a | reps fs == 1 = fs
49 | otherwise = flatten r fs
50 b | reps xs == 1 = xs
51 | otherwise = flatten r xs
10abb7b aha
alex authored
52
1b628e1 Alex McLean bugfix
authored
53 fs@(Arc {onset = o}) <*> s@(Signal {}) = applySignal (0, 1) fs (at s)
54
0be7bab Alex McLean hm
authored
55 (Composition f) <*> xs = Composition f'
56 where f' o = (f o) <*> xs
57
58 fs <*> (Composition f) = Composition f'
59 where f' o = fs <*> (f o)
60
10abb7b aha
alex authored
61 fs@(Signal {}) <*> xs = Signal $ (<*> xs) . (at fs)
62 fs <*> xs@(Signal {}) = Signal $ (fs <*>) . (at xs)
13b8d19 Alex McLean things, and rational numbers
authored
63 _ <*> Silence = Silence
64 Silence <*> _ = Silence
65
1a7e47c Alex McLean getting there
authored
66 _ %% 0 = 0
67 a %% b = a % b
68
69 _ // 0 = 0
70 a // b = a / b
71
1b628e1 Alex McLean bugfix
authored
72 applySignal :: (Rational, Rational) -> Pattern (a -> b) -> (Rational -> Pattern a) -> Pattern b
73
74 applySignal (o, s) p@(Cycle fs) sig
75 = Cycle $ map (\f -> applySignal (o, s) f sig) fs
76
77 applySignal (o, s) p@(Arc {pattern = p', onset = o', scale = s'}) sig
78 = p {pattern = applySignal (o'', s'') p' sig}
79 where o'' = o + (o' * s)
edd64f7 Alex McLean add triangles and bugfix signal application
authored
80 s'' = (o + ((o' + s') * s)) - o''
1b628e1 Alex McLean bugfix
authored
81
82 applySignal (o, s) fs sig
83 = fs <*> (sig o)
13b8d19 Alex McLean things, and rational numbers
authored
84
85 instance Monad Pattern where
86 return = pure
87 m >>= f = joinPattern (fmap f m)
10abb7b aha
alex authored
88
89 --where s n = mapAtom (\x -> mapAtom (\f -> Atom $ (event f) (event x)) (at fs n)) xs
90
67a24f7 Alex McLean new pattern again
authored
91 -- does a start within b?
92 startsIn :: Pattern a -> Pattern b -> Bool
93 startsIn (Arc {onset = o1}) (Arc {onset = o2, scale = s})
265e8fd Alex McLean bugfix applicative
authored
94 = (o1 >= o2 && o1 < (o2 + s))
13b8d19 Alex McLean things, and rational numbers
authored
95 -- || (r2 == 0 && o1 == o2)
67a24f7 Alex McLean new pattern again
authored
96 startsIn _ _ = False
c0e473a foo
alex authored
97
98 instance Functor Pattern where
6ecfa70 Alex McLean aha
authored
99 fmap f p@(Atom {event = a}) = p {event = f a}
100 fmap f p@(Arc {pattern = p'}) = p {pattern = fmap f p'}
1a550c1 hmm
alex authored
101 fmap f p@(Cycle {patterns = ps}) = p {patterns = fmap (fmap f) ps}
10abb7b aha
alex authored
102 fmap f p@(Signal _) = p {at = (fmap f) . (at p)}
0be7bab Alex McLean hm
authored
103 fmap f p@(Composition f') = Composition $ \o -> fmap f (f' o)
104
13b8d19 Alex McLean things, and rational numbers
authored
105 fmap _ Silence = Silence
c0e473a foo
alex authored
106
1a550c1 hmm
alex authored
107 instance (Show a) => Show (Pattern a) where
13b8d19 Alex McLean things, and rational numbers
authored
108 show (Atom e) = show e
67a24f7 Alex McLean new pattern again
authored
109 show (Arc p o s r) = concat [" [", show p, "@(", show o, ")x(", show s, ")-(", show r, ")]"]
1a7e47c Alex McLean getting there
authored
110 show (Cycle ps) = " (" ++ (intercalate ", " (map show ps)) ++ ") "
0be7bab Alex McLean hm
authored
111 show (Composition _) = "*composition*"
10abb7b aha
alex authored
112 show (Signal s) = "*signal*"
13b8d19 Alex McLean things, and rational numbers
authored
113 show Silence = "~"
7323f69 Alex McLean first commit
authored
114
1a7e47c Alex McLean getting there
authored
115
7323f69 Alex McLean first commit
authored
116 class Patternable p where
6ecfa70 Alex McLean aha
authored
117 toPattern :: p a -> Pattern a
7323f69 Alex McLean first commit
authored
118
119 instance Patternable [] where
1a7e47c Alex McLean getting there
authored
120 toPattern [] = Silence
6ecfa70 Alex McLean aha
authored
121 toPattern xs = Cycle ps
1a550c1 hmm
alex authored
122 where
6ecfa70 Alex McLean aha
authored
123 ps = map (\x -> Arc {pattern = Atom $ xs !! x,
1a7e47c Alex McLean getting there
authored
124 onset = (fromIntegral x) %%
13b8d19 Alex McLean things, and rational numbers
authored
125 (fromIntegral l),
1a7e47c Alex McLean getting there
authored
126 scale = 1 %% (fromIntegral l),
13b8d19 Alex McLean things, and rational numbers
authored
127 reps = 1
1a550c1 hmm
alex authored
128 }
13b8d19 Alex McLean things, and rational numbers
authored
129 ) [0 .. l - 1]
130 l = length xs
7323f69 Alex McLean first commit
authored
131
6ecfa70 Alex McLean aha
authored
132 {-size :: Pattern a -> Double
be8be0d Alex McLean foo
authored
133 size (Atom {}) = 1
591994f Alex McLean foo
authored
134 size (Cycle {extent = e}) = e
be8be0d Alex McLean foo
authored
135 size (Combo []) = 0
136 size (Combo ps) = maximum $ map size ps
6ecfa70 Alex McLean aha
authored
137 -}
138
139
140 silence :: Pattern a
13b8d19 Alex McLean things, and rational numbers
authored
141 silence = Silence
be8be0d Alex McLean foo
authored
142
1a550c1 hmm
alex authored
143 mapAtom :: (Pattern a -> Pattern b) -> Pattern a -> Pattern b
6ecfa70 Alex McLean aha
authored
144 mapAtom f p@(Atom {}) = f p
145 mapAtom f p@(Arc {pattern = p'}) = p {pattern = mapAtom f p'}
1a550c1 hmm
alex authored
146 mapAtom f p@(Cycle {patterns = ps}) = p {patterns = fmap (mapAtom f) ps}
10abb7b aha
alex authored
147 mapAtom f p@(Signal _) = p {at = fmap (mapAtom f) (at p)}
0be7bab Alex McLean hm
authored
148 mapAtom f (Composition f') = Composition (\o -> mapAtom f (f' o))
13b8d19 Alex McLean things, and rational numbers
authored
149 mapAtom _ Silence = Silence
10abb7b aha
alex authored
150
151 filterP :: (Pattern a -> Bool) -> Pattern a -> Pattern a
152 filterP f p@(Atom {}) | f p = p
13b8d19 Alex McLean things, and rational numbers
authored
153 | otherwise = Silence
10abb7b aha
alex authored
154 filterP f p@(Cycle ps) | f p = p {patterns = map (filterP f) ps}
13b8d19 Alex McLean things, and rational numbers
authored
155 | otherwise = Silence
10abb7b aha
alex authored
156 filterP f p@(Arc {}) | f p = p {pattern = filterP f (pattern p)}
13b8d19 Alex McLean things, and rational numbers
authored
157 | otherwise = Silence
10abb7b aha
alex authored
158 filterP f p@(Signal {}) | f p = p {at = (filterP f) . (at p)}
0be7bab Alex McLean hm
authored
159 | otherwise = Silence
160 filterP f p@(Composition f') | f p = Composition (\o -> filterP f (f' o))
161 | otherwise = Silence
13b8d19 Alex McLean things, and rational numbers
authored
162 filterP _ Silence = Silence
c0e473a foo
alex authored
163
6ecfa70 Alex McLean aha
authored
164 mapArc :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
165 mapArc f p@(Atom {}) = p
166 mapArc f p@(Arc {pattern = p'}) = f $ p {pattern = mapArc f p'}
167 mapArc f p@(Cycle {patterns = ps}) = p {patterns = fmap (mapArc f) ps}
10abb7b aha
alex authored
168 mapArc f p@(Signal _) = p {at = fmap (mapArc f) (at p)}
0be7bab Alex McLean hm
authored
169 mapArc f (Composition f') = Composition (\o -> mapArc f (f' o))
170
13b8d19 Alex McLean things, and rational numbers
authored
171 mapArc _ Silence = Silence
10abb7b aha
alex authored
172
6ecfa70 Alex McLean aha
authored
173
174 {-
1a550c1 hmm
alex authored
175 mapEvent :: (Event a -> Event b) -> Pattern a -> Pattern b
176 mapEvent f p = mapAtom (\p' -> p' {event = f (event p')}) p
6ecfa70 Alex McLean aha
authored
177 -}
7323f69 Alex McLean first commit
authored
178
13b8d19 Alex McLean things, and rational numbers
authored
179 mapOnset :: (Rational -> Rational) -> Pattern a -> Pattern a
6ecfa70 Alex McLean aha
authored
180 mapOnset f p = mapArc (\p' -> p' {onset = f $ onset p'}) p
7323f69 Alex McLean first commit
authored
181
1a550c1 hmm
alex authored
182 rev :: Pattern a -> Pattern a
866c506 Alex McLean working
authored
183 rev = mapOnset (\x -> x + (((ceiling x)%1) - x))
1a550c1 hmm
alex authored
184
13b8d19 Alex McLean things, and rational numbers
authored
185 (<~) :: Rational -> Pattern a -> Pattern a
0be7bab Alex McLean hm
authored
186 d <~ p = Arc p (mod' (0 - d) 1) 1 1
7323f69 Alex McLean first commit
authored
187
13b8d19 Alex McLean things, and rational numbers
authored
188 (~>) :: Rational -> Pattern a -> Pattern a
1a550c1 hmm
alex authored
189 d ~> p = (0-d) <~ p
7323f69 Alex McLean first commit
authored
190
6ecfa70 Alex McLean aha
authored
191
13b8d19 Alex McLean things, and rational numbers
authored
192 -- assumes equal scale..
6ecfa70 Alex McLean aha
authored
193
194 cat :: [Pattern a] -> Pattern a
866c506 Alex McLean working
authored
195 cat [] = Silence
6ecfa70 Alex McLean aha
authored
196 cat ps = Cycle $ map a [0 .. (length ps) - 1]
197 where l = length ps
866c506 Alex McLean working
authored
198 s = 1 % (fromIntegral l)
6ecfa70 Alex McLean aha
authored
199 a n = Arc {pattern = ps !! n,
13b8d19 Alex McLean things, and rational numbers
authored
200 onset = s * (fromIntegral n),
201 scale = s,
866c506 Alex McLean working
authored
202 reps = 1
6ecfa70 Alex McLean aha
authored
203 }
204
7323f69 Alex McLean first commit
authored
205 every :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
206 every 0 _ p = p
866c506 Alex McLean working
authored
207 every n f p = slow (fromIntegral n %1) $ cat $ (take (n-1) $ repeat p) ++ [f p]
7323f69 Alex McLean first commit
authored
208
0f40ddb Alex McLean foo
authored
209
1a550c1 hmm
alex authored
210 --cat :: [Pattern a] -> Pattern a
211 --cat ps = Cycle (concatMap events ps') n
212 -- where shrunk = map (\p -> mapTime (* ((periodP p) / n)) p) ps
213 -- withOffsets = zip (0:(map (\p -> (periodP p) / n) shrunk)) shrunk
214 -- ps' = map (\(o, p) -> mapTime (+ o) p) $ accumFst withOffsets
215 -- n = (sum $ (map periodP) ps)
c0e473a foo
alex authored
216
1a550c1 hmm
alex authored
217 combine :: [Pattern a] -> Pattern a
6ecfa70 Alex McLean aha
authored
218 combine = Cycle
7323f69 Alex McLean first commit
authored
219
1a550c1 hmm
alex authored
220 --accumOnsets :: [Event a] -> [Event a]
221 --accumOnsets = scanl1 (\a b -> mapOnset (+ (onset a)) b)
c0e473a foo
alex authored
222
1a550c1 hmm
alex authored
223 --accumFst :: [(Double, a)] -> [(Double, a)]
224 --accumFst = scanl1 (\a b -> mapFst (+ (fst a)) b)
7323f69 Alex McLean first commit
authored
225
10abb7b aha
alex authored
226 sinewave :: Pattern Double
227 sinewave = Signal {at = f}
1b628e1 Alex McLean bugfix
authored
228 where f x = Atom $ (sin . (pi * 2 *)) (fromRational x)
10abb7b aha
alex authored
229
230 sinewave1 :: Pattern Double
231 sinewave1 = fmap ((/ 2) . (+ 1)) sinewave
232
edd64f7 Alex McLean add triangles and bugfix signal application
authored
233
234 triwave1 :: Pattern Double
235 triwave1 = Signal {at = f}
236 where f x = Atom $ mod' (fromRational x) 1
237
238 triwave :: Pattern Double
239 triwave = Signal {at = f}
240 where f x = fmap ((subtract 1) . (*2)) triwave1
241
242
1a7e47c Alex McLean getting there
authored
243 squarewave1 :: Pattern Double
244 squarewave1 = Signal {at = f}
245 where f x = Atom $ fromIntegral $ floor $ (mod' (fromRational x) 1) * 2
246
247 squarewave :: Pattern Double
248 squarewave = fmap ((subtract 1) . (* 2)) squarewave1
249
003cfae Alex McLean fiddle
authored
250 discretise :: Int -> Pattern a -> Pattern a
251 discretise n s = Cycle ps
10aa5f7 no comment
alex authored
252 where
1a7e47c Alex McLean getting there
authored
253 d = 1 %% (fromIntegral n)
6ecfa70 Alex McLean aha
authored
254 ps = map (\x ->
255 Arc {
1b628e1 Alex McLean bugfix
authored
256 pattern = (at s $ (fromIntegral x) * d),
6ecfa70 Alex McLean aha
authored
257 onset = (fromIntegral x) * d,
1b628e1 Alex McLean bugfix
authored
258 scale = d,
259 reps = 1
6ecfa70 Alex McLean aha
authored
260 }
261 )
262 [0 .. (n - 1)]
be8be0d Alex McLean foo
authored
263
1b628e1 Alex McLean bugfix
authored
264 {-
10abb7b aha
alex authored
265 modulateOnset :: (a -> Double -> Double) -> Signal a -> Pattern b -> Pattern b
266 modulateOnset f s p = mapOnset (\x -> f (s x) x) p
7323f69 Alex McLean first commit
authored
267
10abb7b aha
alex authored
268 wobble :: Double -> Pattern a -> Pattern a
269 wobble d p = modulateOnset (+) (fmap (*d) sinewave) p
270 -}
0be7bab Alex McLean hm
authored
271
7323f69 Alex McLean first commit
authored
272 mapFst :: (a -> b) -> (a, c) -> (b, c)
273 mapFst f (x,y) = (f x,y)
274
591994f Alex McLean foo
authored
275 mapFsts :: (a -> b) -> [(a, c)] -> [(b, c)]
276 mapFsts = map . mapFst
277
7323f69 Alex McLean first commit
authored
278 mapSnd :: (a -> b) -> (c, a) -> (c, b)
279 mapSnd f (x,y) = (x,f y)
280
6ecfa70 Alex McLean aha
authored
281 mapSnds :: (a -> b) -> [(c, a)] -> [(c, b)]
282 mapSnds = map . mapSnd
283
0be7bab Alex McLean hm
authored
284 flat :: (Rational, Rational) -> Pattern a -> [((Rational, Rational), a)]
285
866c506 Alex McLean working
authored
286 flat (a, b) (Silence) = []
0be7bab Alex McLean hm
authored
287 flat (a, b) (Atom e) = foo -- trace ("\n" ++ show e ++ ": " ++ show a ++ "/" ++ show b ++ "=" ++ show (map fst foo)) $ foo
288 where foo = map (\x -> ((x%1,(x+1)%1),e)) [ceiling a .. (ceiling b) - 1]
289 flat (a, b) (Composition f) = flat (a,b) $ f (a,b)
290 where explode (x, y) = ((x * (b - a)) + a, (y * (b - a)) + a)
866c506 Alex McLean working
authored
291 flat (a, b) (Cycle ps) = concatMap (flat (a, b)) ps
292
0be7bab Alex McLean hm
authored
293 -- TODO - this is a bit of a hack for rotation
294 flat (a, b) p@(Arc {pattern = p', onset = o', scale = 1, reps = 1})
295 = mapFsts (\(x, y) -> (x + o',y + o')) $ flat (a-o',b-o') p'
296
866c506 Alex McLean working
authored
297 flat (a, b) p@(Arc {pattern = p', onset = o', scale = s', reps = r'})
298 | a >= b = []
299 | otherwise = (mapFsts squash (flat (a'', b'') p')) ++ rest
300 where start = (floor a) % 1 -- start of loop
301 next = start + 1 -- next loop
302 b' = min b next -- limit of present recursion along range
303 innerStart = (r'*start) -- inner loop start
304 innerNext = (r'*(start + 1))
305 a'' = min innerNext $ innerStart + (max 0 (((a - start) - o') / s'))
306 b'' = min innerNext $ innerStart + (max 0 (((b - start) - o') / s'))
0be7bab Alex McLean hm
authored
307 -- a'' = min innerNext $ innerStart + (max 0 (((a - start) - o') / s'))
308 -- b'' = min innerNext $ innerStart + (max 0 (((b - start) - o') / s'))
866c506 Alex McLean working
authored
309 rest = flat (next, b) p
0be7bab Alex McLean hm
authored
310 squash (x,y) = (start + o' + ((x - innerStart) * s'),
311 start + o' + ((y - innerStart) * s')
312 )
313
866c506 Alex McLean working
authored
314
0be7bab Alex McLean hm
authored
315 flat r p@(Signal _) = flat r $ discretise 64 p
866c506 Alex McLean working
authored
316
317 {-
318
319 flat (o, s) Arc {pattern = p, onset = a', scale = s', reps = r}
1a7e47c Alex McLean getting there
authored
320 | isIn = squash a' s' $ flat (max a'' 0, min s'' 1) p
13b8d19 Alex McLean things, and rational numbers
authored
321 | otherwise = []
866c506 Alex McLean working
authored
322 where a = o
323 b = a+s
a9230e3 Alex McLean restore to working
authored
324 b' = a'+s'
325 ia = max a a'
326 ib = min b b'
327 is = ib - ia
328 a'' = (ia - a') / s'
329 b'' = (ib - a') / s'
330 s'' = b'' - a''
331 isIn = a'' < 1 && b'' > 0 && a'' < b''
332 isIn' = tr $ isIn
333 tr = trace $ intercalate ", " [show a, show b, show a', show b', show isIn]
334
866c506 Alex McLean working
authored
335 -}
a9230e3 Alex McLean restore to working
authored
336 --flat (o, s) arc@(Arc {pattern = p, onset = o', scale = s', reps = r})
337 -- = flat (o, s) (arc {reps = 1, scale = s' / r, onset = o' + (mod' o r)})
338 -- where
5a508a3 Alex McLean broken in order to fix
authored
339
1a7e47c Alex McLean getting there
authored
340
341 isWithin :: Rational -> Rational -> Rational -> Rational -> Bool
1b628e1 Alex McLean bugfix
authored
342 isWithin a b a' b' = or [a' >= a && a' < b,
343 b' > a && b' <= b,
344 a' <= a && b' >= b
345 ]
13b8d19 Alex McLean things, and rational numbers
authored
346
347
e9fb83a Alex McLean more there
authored
348 flat' :: (Rational, Rational) -> Pattern a -> [(Double, a)]
0be7bab Alex McLean hm
authored
349 flat' r p = mapFsts (\(x,y) -> fromRational $ (x - (fst r)) / (snd r - fst r)) (flat r p)
e9fb83a Alex McLean more there
authored
350
866c506 Alex McLean working
authored
351 slow :: Rational -> Pattern a -> Pattern a
352 slow x p = Arc p 0 x (1/x)
e9fb83a Alex McLean more there
authored
353
67a24f7 Alex McLean new pattern again
authored
354 density x p = slow (1/x) p
355
0be7bab Alex McLean hm
authored
356 unit :: Pattern a -> Bool
357 unit p = reps p == (1 / scale p)
358
359 flatten :: (Rational, Rational) -> Pattern a -> Pattern a
360 flatten (x, y) p = Cycle $ map (\(o, s, e) -> (Arc (Atom e) o s 1)) xs
361 where xs = map norm $ flat (x,y) p
362 norm ((x', y'), e) = ((x' - x) / d, (y' - x')/d, e)
363 d = y - x
364
866c506 Alex McLean working
authored
365 --squash :: Rational -> Rational -> [(Rational, a)] -> [(Rational, a)]
366 --squash o s es = mapFsts ((+ o) . (* s)) es
591994f Alex McLean foo
authored
367
0be7bab Alex McLean hm
authored
368 run len = toPattern [0 .. len-1]
369 scan n = cat $ map run [1 .. n]
70bd240 Alex McLean foo
authored
370
Something went wrong with that request. Please try again.