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